cryptol-2.8.0/ 0000755 0000000 0000000 00000000000 07346545000 011406 5 ustar 00 0000000 0000000 cryptol-2.8.0/CHANGES.md 0000755 0000000 0000000 00000010767 07346545000 013016 0 ustar 00 0000000 0000000 # 2.8.0 (September 4, 2019)
## New features
* Added support for indexing on the left-hand sides of declarations,
record field constructors, and record updaters (issue #577). This
builds on a new primitive function called `generate`, where the new
syntax `x @ i = e` is sugar for `x = generate (\i -> e)`.
* Added support for element type ascriptions on sequence enumerations.
The syntax `[a,b..c:t]` indicates that the elements should be of type
`t`.
* Added support for wildcards in sequence enumerations. For example, the
syntax `[1 .. _] : [3][8]` yields `[0x01, 0x02, 0x03]`. It can also be
used polymorphically. For example, the most general type of `[1 .. _]`
is `{n, a} (n >= 1, Literal n a, fin n) => [n]a`
* Changed the syntax of type signatures to allow multiple constraint
arrows in type schemas (issue #599). The following are now equivalent:
f : {a} (fin a, a >= 1) => [a] -> [a]
f : {a} (fin a) => (a >= 1) => [a] -> [a]
* Added a mechanism for user-defined type constraint operators, and use
this to define the new type constraint synonyms (<) and (>) (issues
#400, #618).
* Added support for primitive type declarations. The prelude now uses
this mechanism to declare all of the basic types.
* Added support for Haskell-style "block arguments", reducing the need
for parentheses in some cases. For example, `generate (\i -> i +1)`
can now be written `generate \i -> i + 1`.
* Improved shadowing errors (part of the fix for issue #569).
## Bug fixes
* Closed many issues, including #265, #367, #437, #508, #522, #549,
#557, #559, #569, #578, #590, #595, #596, #601, #607, #608, #610,
#615, #621, and #636.
# 2.7.0 (April 30, 2019)
## New features
* Added syntax for record updates (see #399 for details of implemented
and planned features).
* Updated the `:browse` command to list module parameters (issue #586).
* Added support for test vector creation (the `:dumptests` command).
This feature computes a list of random inputs and outputs for the
given expression of function type and saves it to a file. This is
useful for generating tests from a trusted Cryptol specification to
apply to an implementation written in another language.
## Breaking changes
* Removed the `[x..]` construct from the language (issue #574). It
was shorthand for `[x..2^^n-1]` for a bit vector of size `n`, which was
often not what the user intended. Users should instead write either
`[x..y]` or `[x...]`, to construct a smaller range or a lazy sequence,
respectively.
* Renamed the value-level `width` function to `length`, and generalized
its type (issue #550). It does not behave identically to the
type-level `width` operator, which led to confusion. The name
`length` matches more closely with similar functions in other
languages.
## Bug fixes
* Improved type checking performance of decimal literals.
* Improved type checking of `/^` and `%^` (issues #581, #582).
* Improved performance of sequence updates with the `update` primitive
(issue #579).
* Fixed elapsed time printed by `:prove` and `:sat` (issue #572).
* Fixed SMT-Lib formulas generated for right shifts (issue #566).
* Fixed crash when importing non-parameterized modules with the
backtick prefix (issue #565).
* Improved performance of symbolic execution for `Z n` (issue #554).
* Fixed interpretation of the `satNum` option so finding multiple
solutions doesn't run forever (issue #553).
* Improved type checking of the `length` function (issue #548).
* Improved error message when trying to prove properties in
parameterized modules (issue #545).
* Stopped warning about defaulting at the REPL when `warnDefaulting` is
set to `false` (issue #543).
* Fixed builds on non-x86 architectures (issue #542).
* Made browsing of interactively-bound identifiers work better (issue #538).
* Fixed a bug that allowed changing the semantics of the `_ # _`
pattern and the `-` and `~` operators by creating local definitions
of functions that they expand to (issue #568).
* Closed issues #498, #547, #551, #562, and #563.
## Solver versions
Cryptol can interact with a variety of external SMT solvers to
support the `:prove` and `:sat` commands, and requires Z3 for its
type checker. Many versions of these solvers will work correctly, but
for Yices and Z3 we recommend the following specific versions.
* Z3 4.7.1
* Yices 2.6.1
For Yices, this is the latest version at the time of this writing.
For Z3, it is not, and the latest versions (4.8.x) include changes
that cause some examples that previously succeeded to time out when
type checking.
cryptol-2.8.0/LICENSE 0000644 0000000 0000000 00000002740 07346545000 012416 0 ustar 00 0000000 0000000 Copyright (c) 2013-2019 Galois Inc.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
* Neither the name of Galois, Inc. nor the names of its contributors
may be used to endorse or promote products derived from this
software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
cryptol-2.8.0/Setup.hs 0000644 0000000 0000000 00000000355 07346545000 013045 0 ustar 00 0000000 0000000 -- |
-- Module : Main
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
import Distribution.Simple
main = defaultMain
cryptol-2.8.0/bench/ 0000755 0000000 0000000 00000000000 07346545000 012465 5 ustar 00 0000000 0000000 cryptol-2.8.0/bench/Main.hs 0000644 0000000 0000000 00000014132 07346545000 013706 0 ustar 00 0000000 0000000 -- |
-- Module : Main
-- Copyright : (c) 2015-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.FilePath ((>))
import qualified System.Directory as Dir
import qualified Cryptol.Eval as E
import qualified Cryptol.Eval.Monad as E
import qualified Cryptol.Eval.Value as E
import qualified Cryptol.ModuleSystem.Base as M
import qualified Cryptol.ModuleSystem.Env as M
import qualified Cryptol.ModuleSystem.Monad as M
import qualified Cryptol.ModuleSystem.NamingEnv as M
import Cryptol.ModuleSystem.Interface (noIfaceParams)
import qualified Cryptol.Parser as P
import qualified Cryptol.Parser.AST as P
import qualified Cryptol.Parser.NoInclude as P
import qualified Cryptol.Symbolic as S
import qualified Cryptol.Symbolic.Value as S
import qualified Cryptol.TypeCheck as T
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.Utils.Ident as I
import Cryptol.Utils.Logger(quietLogger)
import qualified Data.SBV.Dynamic as SBV
import Criterion.Main
main :: IO ()
main = do
cd <- Dir.getCurrentDirectory
defaultMain [
bgroup "parser" [
parser "Prelude" "lib/Cryptol.cry"
, parser "PreludeWithExtras" "bench/data/PreludeWithExtras.cry"
, parser "BigSequence" "bench/data/BigSequence.cry"
, parser "BigSequenceHex" "bench/data/BigSequenceHex.cry"
, parser "AES" "bench/data/AES.cry"
, parser "SHA512" "bench/data/SHA512.cry"
]
, bgroup "typechecker" [
tc cd "Prelude" "lib/Cryptol.cry"
, tc cd "PreludeWithExtras" "bench/data/PreludeWithExtras.cry"
, tc cd "BigSequence" "bench/data/BigSequence.cry"
, tc cd "BigSequenceHex" "bench/data/BigSequenceHex.cry"
, tc cd "AES" "bench/data/AES.cry"
, tc cd "SHA512" "bench/data/SHA512.cry"
]
, bgroup "conc_eval" [
ceval cd "AES" "bench/data/AES.cry" "bench_correct"
, ceval cd "ZUC" "bench/data/ZUC.cry" "ZUC_TestVectors"
, ceval cd "SHA512" "bench/data/SHA512.cry" "testVector1 ()"
]
, bgroup "sym_eval" [
seval cd "AES" "bench/data/AES.cry" "bench_correct"
, seval cd "ZUC" "bench/data/ZUC.cry" "ZUC_TestVectors"
, seval cd "SHA512" "bench/data/SHA512.cry" "testVector1 ()"
]
]
-- | Evaluation options, mostly used by `trace`.
-- Since the benchmarks likely do not use base, these don't matter very much
evOpts :: E.EvalOpts
evOpts = E.EvalOpts { E.evalLogger = quietLogger
, E.evalPPOpts = E.defaultPPOpts
}
-- | Make a benchmark for parsing a Cryptol module
parser :: String -> FilePath -> Benchmark
parser name path =
env (T.readFile path) $ \(~bytes) ->
bench name $ nfIO $ do
let cfg = P.defaultConfig
{ P.cfgSource = path
, P.cfgPreProc = P.guessPreProc path
}
case P.parseModule cfg bytes of
Right pm -> return pm
Left err -> error (show err)
-- | Make a benchmark for typechecking a Cryptol module. Does parsing
-- in the setup phase in order to isolate typechecking
tc :: String -> String -> FilePath -> Benchmark
tc cd name path =
let withLib = M.withPrependedSearchPath [cd > "lib"] in
let setup = do
bytes <- T.readFile path
let cfg = P.defaultConfig
{ P.cfgSource = path
, P.cfgPreProc = P.guessPreProc path
}
Right pm = P.parseModule cfg bytes
menv <- M.initialModuleEnv
(Right ((prims, scm, tcEnv), menv'), _) <- M.runModuleM (evOpts,menv) $ withLib $ do
-- code from `loadModule` and `checkModule` in
-- `Cryptol.ModuleSystem.Base`
let pm' = M.addPrelude pm
M.loadDeps pm'
Right nim <- M.io (P.removeIncludesModule path pm')
npm <- M.noPat nim
(tcEnv,declsEnv,scm) <- M.renameModule npm
prims <- if P.thing (P.mName pm) == I.preludeName
then return (M.toPrimMap declsEnv)
else M.getPrimMap
return (prims, scm, tcEnv)
return (prims, scm, tcEnv, menv')
in env setup $ \ ~(prims, scm, tcEnv, menv) ->
bench name $ nfIO $ M.runModuleM (evOpts,menv) $ withLib $ do
let act = M.TCAction { M.tcAction = T.tcModule
, M.tcLinter = M.moduleLinter (P.thing (P.mName scm))
, M.tcPrims = prims
}
M.typecheck act scm noIfaceParams tcEnv
ceval :: String -> String -> FilePath -> T.Text -> Benchmark
ceval cd name path expr =
let withLib = M.withPrependedSearchPath [cd > "lib"] in
let setup = do
menv <- M.initialModuleEnv
(Right (texpr, menv'), _) <- M.runModuleM (evOpts,menv) $ withLib $ do
m <- M.loadModuleByPath path
M.setFocusedModule (T.mName m)
let Right pexpr = P.parseExpr expr
(_, texpr, _) <- M.checkExpr pexpr
return texpr
return (texpr, menv')
in env setup $ \ ~(texpr, menv) ->
bench name $ nfIO $ E.runEval evOpts $ do
env' <- E.evalDecls (S.allDeclGroups menv) mempty
(e :: E.Value) <- E.evalExpr env' texpr
E.forceValue e
seval :: String -> String -> FilePath -> T.Text -> Benchmark
seval cd name path expr =
let withLib = M.withPrependedSearchPath [cd > "lib"] in
let setup = do
menv <- M.initialModuleEnv
(Right (texpr, menv'), _) <- M.runModuleM (evOpts,menv) $ withLib $ do
m <- M.loadModuleByPath path
M.setFocusedModule (T.mName m)
let Right pexpr = P.parseExpr expr
(_, texpr, _) <- M.checkExpr pexpr
return texpr
return (texpr, menv')
in env setup $ \ ~(texpr, menv) ->
bench name $ nfIO $ E.runEval evOpts $ do
env' <- E.evalDecls (S.allDeclGroups menv) mempty
(e :: S.Value) <- E.evalExpr env' texpr
E.io $ SBV.generateSMTBenchmark False $
return (S.fromVBit e)
cryptol-2.8.0/bench/data/ 0000755 0000000 0000000 00000000000 07346545000 013376 5 ustar 00 0000000 0000000 cryptol-2.8.0/bench/data/AES.cry 0000755 0000000 0000000 00000041402 07346545000 014531 0 ustar 00 0000000 0000000 // Cryptol AES Implementation
// Copyright (c) 2010-2013, Galois Inc.
// www.cryptol.net
// You can freely use this source code for educational purposes.
// This is a fairly close implementation of the FIPS-197 standard:
// http://csrc.nist.gov/publications/fips/fips197/fips-197.pdf
// Nk: Number of blocks in the key
// Must be one of 4 (AES128), 6 (AES192), or 8 (AES256)
// Aside from this line, no other code below needs to change for
// implementing AES128, AES192, or AES256
module AES where
type AES128 = 4
type AES192 = 6
type AES256 = 8
type Nk = AES128
// For Cryptol 2.x | x > 0
// NkValid: `Nk -> Bit
// property NkValid k = (k == `AES128) || (k == `AES192) || (k == `AES256)
// Number of blocks and Number of rounds
type Nb = 4
type Nr = 6 + Nk
type AESKeySize = (Nk*32)
// Helper type definitions
type GF28 = [8]
type State = [4][Nb]GF28
type RoundKey = State
type KeySchedule = (RoundKey, [Nr-1]RoundKey, RoundKey)
// GF28 operations
gf28Add : {n} (fin n) => [n]GF28 -> GF28
gf28Add ps = sums ! 0
where sums = [zero] # [ p ^ s | p <- ps | s <- sums ]
irreducible = <| x^^8 + x^^4 + x^^3 + x + 1 |>
gf28Mult : (GF28, GF28) -> GF28
gf28Mult (x, y) = pmod(pmult x y) irreducible
gf28Pow : (GF28, [8]) -> GF28
gf28Pow (n, k) = pow k
where sq x = gf28Mult (x, x)
odd x = x ! 0
pow i = if i == 0 then 1
else if odd i
then gf28Mult(n, sq (pow (i >> 1)))
else sq (pow (i >> 1))
gf28Inverse : GF28 -> GF28
gf28Inverse x = gf28Pow (x, 254)
gf28DotProduct : {n} (fin n) => ([n]GF28, [n]GF28) -> GF28
gf28DotProduct (xs, ys) = gf28Add [ gf28Mult (x, y) | x <- xs
| y <- ys ]
gf28VectorMult : {n, m} (fin n) => ([n]GF28, [m][n]GF28) -> [m]GF28
gf28VectorMult (v, ms) = [ gf28DotProduct(v, m) | m <- ms ]
gf28MatrixMult : {n, m, k} (fin m) => ([n][m]GF28, [m][k]GF28) -> [n][k]GF28
gf28MatrixMult (xss, yss) = [ gf28VectorMult(xs, yss') | xs <- xss ]
where yss' = transpose yss
// The affine transform and its inverse
xformByte : GF28 -> GF28
xformByte b = gf28Add [b, (b >>> 4), (b >>> 5), (b >>> 6), (b >>> 7), c]
where c = 0x63
xformByte' : GF28 -> GF28
xformByte' b = gf28Add [(b >>> 2), (b >>> 5), (b >>> 7), d] where d = 0x05
// The SubBytes transform and its inverse
SubByte : GF28 -> GF28
SubByte b = xformByte (gf28Inverse b)
SubByte' : GF28 -> GF28
SubByte' b = sbox@b
SubBytes : State -> State
SubBytes state = [ [ SubByte' b | b <- row ] | row <- state ]
InvSubByte : GF28 -> GF28
InvSubByte b = gf28Inverse (xformByte' b)
InvSubBytes : State -> State
InvSubBytes state =[ [ InvSubByte b | b <- row ] | row <- state ]
// The ShiftRows transform and its inverse
ShiftRows : State -> State
ShiftRows state = [ row <<< shiftAmount | row <- state
| shiftAmount <- [0 .. 3]
]
InvShiftRows : State -> State
InvShiftRows state = [ row >>> shiftAmount | row <- state
| shiftAmount <- [0 .. 3]
]
// The MixColumns transform and its inverse
MixColumns : State -> State
MixColumns state = gf28MatrixMult (m, state)
where m = [[2, 3, 1, 1],
[1, 2, 3, 1],
[1, 1, 2, 3],
[3, 1, 1, 2]]
InvMixColumns : State -> State
InvMixColumns state = gf28MatrixMult (m, state)
where m = [[0x0e, 0x0b, 0x0d, 0x09],
[0x09, 0x0e, 0x0b, 0x0d],
[0x0d, 0x09, 0x0e, 0x0b],
[0x0b, 0x0d, 0x09, 0x0e]]
// The AddRoundKey transform
AddRoundKey : (RoundKey, State) -> State
AddRoundKey (rk, s) = rk ^ s
// Key expansion
Rcon : [8] -> [4]GF28
Rcon i = [(gf28Pow (<| x |>, i-1)), 0, 0, 0]
SubWord : [4]GF28 -> [4]GF28
SubWord bs = [ SubByte b | b <- bs ]
RotWord : [4]GF28 -> [4]GF28
RotWord [a0, a1, a2, a3] = [a1, a2, a3, a0]
NextWord : ([8],[4][8],[4][8]) -> [4][8]
NextWord(i, prev, old) = old ^ mask
where mask = if i % `Nk == 0
then SubWord(RotWord(prev)) ^ Rcon (i / `Nk)
else if (`Nk > 6) && (i % `Nk == 4)
then SubWord(prev)
else prev
ExpandKeyForever : [Nk][4][8] -> [inf]RoundKey
ExpandKeyForever seed = [ transpose g | g <- groupBy`{4} (keyWS seed) ]
keyWS : [Nk][4][8] -> [inf][4][8]
keyWS seed = xs
where xs = seed # [ NextWord(i, prev, old)
| i <- [ `Nk ... ]
| prev <- drop`{Nk-1} xs
| old <- xs
]
checkKey = take`{16} (drop`{8} (keyWS ["abcd", "defg", "1234", "5678"]))
checkKey2 = [transpose g | g <- groupBy`{4}checkKey]
ExpandKey : [AESKeySize] -> KeySchedule
ExpandKey key = (keys @ 0, keys @@ [1 .. (Nr - 1)], keys @ `Nr)
where seed : [Nk][4][8]
seed = split (split key)
keys = ExpandKeyForever seed
fromKS : KeySchedule -> [Nr+1][4][32]
fromKS (f, ms, l) = [ formKeyWords (transpose k) | k <- [f] # ms # [l] ]
where formKeyWords bbs = [ join bs | bs <- bbs ]
// AES rounds and inverses
AESRound : (RoundKey, State) -> State
AESRound (rk, s) = AddRoundKey (rk, MixColumns (ShiftRows (SubBytes s)))
AESFinalRound : (RoundKey, State) -> State
AESFinalRound (rk, s) = AddRoundKey (rk, ShiftRows (SubBytes s))
AESInvRound : (RoundKey, State) -> State
AESInvRound (rk, s) =
InvMixColumns (AddRoundKey (rk, InvSubBytes (InvShiftRows s)))
AESFinalInvRound : (RoundKey, State) -> State
AESFinalInvRound (rk, s) = AddRoundKey (rk, InvSubBytes (InvShiftRows s))
// Converting a 128 bit message to a State and back
msgToState : [128] -> State
msgToState msg = transpose (split (split msg))
stateToMsg : State -> [128]
stateToMsg st = join (join (transpose st))
// AES Encryption
aesEncrypt : ([128], [AESKeySize]) -> [128]
aesEncrypt (pt, key) = stateToMsg (AESFinalRound (kFinal, rounds ! 0))
where (kInit, ks, kFinal) = ExpandKey key
state0 = AddRoundKey(kInit, msgToState pt)
rounds = [state0] # [ AESRound (rk, s) | rk <- ks
| s <- rounds
]
// AES Decryption
aesDecrypt : ([128], [AESKeySize]) -> [128]
aesDecrypt (ct, key) = stateToMsg (AESFinalInvRound (kFinal, rounds ! 0))
where (kFinal, ks, kInit) = ExpandKey key
state0 = AddRoundKey(kInit, msgToState ct)
rounds = [state0] # [ AESInvRound (rk, s)
| rk <- reverse ks
| s <- rounds
]
sbox : [256]GF28
sbox = [
0x63, 0x7c, 0x77, 0x7b, 0xf2, 0x6b, 0x6f, 0xc5, 0x30, 0x01, 0x67,
0x2b, 0xfe, 0xd7, 0xab, 0x76, 0xca, 0x82, 0xc9, 0x7d, 0xfa, 0x59,
0x47, 0xf0, 0xad, 0xd4, 0xa2, 0xaf, 0x9c, 0xa4, 0x72, 0xc0, 0xb7,
0xfd, 0x93, 0x26, 0x36, 0x3f, 0xf7, 0xcc, 0x34, 0xa5, 0xe5, 0xf1,
0x71, 0xd8, 0x31, 0x15, 0x04, 0xc7, 0x23, 0xc3, 0x18, 0x96, 0x05,
0x9a, 0x07, 0x12, 0x80, 0xe2, 0xeb, 0x27, 0xb2, 0x75, 0x09, 0x83,
0x2c, 0x1a, 0x1b, 0x6e, 0x5a, 0xa0, 0x52, 0x3b, 0xd6, 0xb3, 0x29,
0xe3, 0x2f, 0x84, 0x53, 0xd1, 0x00, 0xed, 0x20, 0xfc, 0xb1, 0x5b,
0x6a, 0xcb, 0xbe, 0x39, 0x4a, 0x4c, 0x58, 0xcf, 0xd0, 0xef, 0xaa,
0xfb, 0x43, 0x4d, 0x33, 0x85, 0x45, 0xf9, 0x02, 0x7f, 0x50, 0x3c,
0x9f, 0xa8, 0x51, 0xa3, 0x40, 0x8f, 0x92, 0x9d, 0x38, 0xf5, 0xbc,
0xb6, 0xda, 0x21, 0x10, 0xff, 0xf3, 0xd2, 0xcd, 0x0c, 0x13, 0xec,
0x5f, 0x97, 0x44, 0x17, 0xc4, 0xa7, 0x7e, 0x3d, 0x64, 0x5d, 0x19,
0x73, 0x60, 0x81, 0x4f, 0xdc, 0x22, 0x2a, 0x90, 0x88, 0x46, 0xee,
0xb8, 0x14, 0xde, 0x5e, 0x0b, 0xdb, 0xe0, 0x32, 0x3a, 0x0a, 0x49,
0x06, 0x24, 0x5c, 0xc2, 0xd3, 0xac, 0x62, 0x91, 0x95, 0xe4, 0x79,
0xe7, 0xc8, 0x37, 0x6d, 0x8d, 0xd5, 0x4e, 0xa9, 0x6c, 0x56, 0xf4,
0xea, 0x65, 0x7a, 0xae, 0x08, 0xba, 0x78, 0x25, 0x2e, 0x1c, 0xa6,
0xb4, 0xc6, 0xe8, 0xdd, 0x74, 0x1f, 0x4b, 0xbd, 0x8b, 0x8a, 0x70,
0x3e, 0xb5, 0x66, 0x48, 0x03, 0xf6, 0x0e, 0x61, 0x35, 0x57, 0xb9,
0x86, 0xc1, 0x1d, 0x9e, 0xe1, 0xf8, 0x98, 0x11, 0x69, 0xd9, 0x8e,
0x94, 0x9b, 0x1e, 0x87, 0xe9, 0xce, 0x55, 0x28, 0xdf, 0x8c, 0xa1,
0x89, 0x0d, 0xbf, 0xe6, 0x42, 0x68, 0x41, 0x99, 0x2d, 0x0f, 0xb0,
0x54, 0xbb, 0x16]
// Test runs:
// cryptol> aesEncrypt (0x3243f6a8885a308d313198a2e0370734, \
// 0x2b7e151628aed2a6abf7158809cf4f3c)
// 0x3925841d02dc09fbdc118597196a0b32
// cryptol> aesEncrypt (0x00112233445566778899aabbccddeeff, \
// 0x000102030405060708090a0b0c0d0e0f)
// 0x69c4e0d86a7b0430d8cdb78070b4c55a
property AESCorrect msg key = aesDecrypt (aesEncrypt (msg, key), key) == msg
// Benchmark:
type nblocks = 128
property bench_correct = bench bench_data == bench_result
bench : [128 * nblocks] -> [128 * nblocks]
bench data = join [ aesEncrypt (block, key) | block <- split data ]
where key = 0x3243f6a8885a308d313198a2e0370734
bench_data : [128 * nblocks]
bench_data = //random 0
0xcddf97f18ad18da94ae27558e975608f673c896a718cffbc90c746160a003d540e353ea1a32cf650c25298cf353b36849f68360e07ad40a9e6c0e4dd2351dce8c06dd82c27642a5e9ce3804780d531af41768b4697b45383d58dfd98c9f2e6d5788e671229529d239b40fc9a52436c437e716cef3c5503d567eff3c2f35d806ae4431455ec096526b1b584cb4a80efde3174361e912a46bf8b7b8d3ca4cebacea935ccd766976614885f5330441ca4acee37c9728fb53708042d9952d8ef3ca544c870a7ee689f8b6d78764368e849274946d0e8bdc69f4a4004cbbce034f1d0a6f8447a756a5f9c217e377909d0c4bde859732e7263c03013c623cb1f2478b77f7838b3d3581e0aba9da951dd18466a131bca89252fc17b9bbe475530d425ac7a79cbc26a941dcc16ded680dddada735c76fa469ebeadf1c8fc33a2c7dc00b865eaec95f1448583425302a9023d39c3bb794685a5e30f196f7c0bdc2b8790d35f8bb9c4359e17ca53e8450da4db030bb67fb4cab68ef4a5edfbe120f1c9824b4faa0cc767bb7304238a798534f065cc1cc8fe310d76c2b440b64348a8e16873eddb5931313573c2cb43a47c2ff0f9c8ec264a0a6ec6474c1056fc7f376c01e5d3b6fea382b5086c7c80bb4c5505f2d4f18dc01cff4baa71eac658ca78e5acbde546dbe85dd71708fb46c8ec00ef75b9b577f93a3c550781a642d5bc4fa2da325656f737d272875b9185fe86a0e0e3eefaf51294d0f06340db93715c99df443e286c0d1e2ae869a7e0d705d6369362a220617ac4803fd205de679ea6ed82881cc2315d73c9cc8f4512ee61afaf127eac098d1d31b075c16aa902024594337c6b2a290cedcbd44190105d20de7ef16fb310400ccbc9ca6a1f4de0a9b1f82b780ee3eda52af664b883c32dd70c860905c0f9e83ee0ae5fc016b81c4c4ca70c05703035637e4988a827bf6e230ba30dc78b8c5663e14273827fb6c4aa700b95a04f1456ce15d18740ee79b7aeb85feffac9f5bd54c9a9bd494a9fc8fab4280316ac8f6552849a798e2b5d7326bb2208fdf2cf6b372311edcd87bb2b1805afd1b6e085fad1a28bc4578e1abea57227f49c141d7d08893d8083249e32cc9645748684cc5d4d492abbdaf5f8373b5e2e4bd91c15346e1d455415395bc0342185665ebeb94fda5fdf7e601961bf1f1109373e935a077a0088980844ce1c87f347380f3c805b01407cf9154f5818db41a6f5d87994df790421a9dbf7d56c11a5e723ec853f32bcf7dc0eef03bbf164564167c6212c35ddd9d6112eb43e4826d1da8f065b804fd48b5ff863b4f4246ba6ebaef90396843e084168d6826abf5f6b0e82c7a7a96707e650e86f82862c5910e0c4d6a48182656e0e76be4017c739feb2da56bb69db4b0885c772180607ce880b15064b5b9878cd1c3d4ae9657c5fdf5ca5d7755807d74e2a57aed4e9fe90c49ed4f01ae3cb812ada6b15c7009d98930d8a41cf23e8f5a962e93c8cecef6044cfcc8843d1f6b5dfb868de036fa5d992c861f056f504f54e8d077028143a2807676c02faf35435ee43cb1ece1a82c7f142be774c824b7e8e3fcad737f58f4818994842ab40a211f9569ad476beef0f2f97be0fb515cf0754641748b2af38d58937c3428a147647911734d54bf06be7f3fcab19b874ff52893af6a45c44adf11c17bf177fc0e90539327373e6594e249aca3a386272d1405455e7e8b463029c0460a31b59b9dc1a15d18cdf1997df250721735651c5e7de7059cb755aa4a0c99962e6485b2ccb02ffecb022fc867e36a63ef77ee8740af2e6f25b0d497d3bcc213a939a47a64057caf107e79661d15f469f8e32b2175bed98af21776a9a2cde4e4982ecd695b4dcef8822806cf74ac73aa5b9d8e6dc0a6d2b97b75d11553a9478296631b7a3c340113247f32bf7a7c42e85b9e517b4f9a09ab453de795f156f09d2704bfa56f5ade38e0eae826796bd54165967332985ecdd4991b8e2bb4016e0d2da173690feace03245c2ef868b44ea7892c0ce15d818a32e5bf57d53a1d86cbb3074221083cfa570c17104da26c063b3a349ce35facd3b7bf267383235a5620217d58201c74105302f3445e024313338fe93dd6f617088b41c836083ceae512782e458c4f5c74bd1987ccb098d1d89fe63a5e5881e56b0c5aba87ef2c5e8d6333d91e9dcbdc45a3c16d67b32c4e51e95231aa7e0b9342c599ebdc6ebb6e4dce1fcd98add42d6ab08707a6f5a38154ad5a3674e8a05105c5ecec180f9661122da31a94e9ad7d337ff5ab4a28a5c5cba9a393f484ed5e5f37bbb4b7caecbf9cbb432cae0b2f6bd5ce6068104f012d6428a9b172847e18f12708de6248cdf0401c865292645fb30114f4f4b53d4473b6ffc53ae0870e85c24f631f52c04d227ea9bc0a59828b6f9eafd95cac13ccfb1cdbae3550b0cd99e1812346d5d01b5a782d1d50fbedf858a4a044fd9384e3a6c10cb4227e276c7399b897b9dcbd2a5cb4e14d8341dd32029938f444fa3dcf2d23198f6bf042439cf96a534f3041774a6c3d5b6bb5bfcd8d7af57402431c7dd758da93ccef39495977cece58087ecc80b278d3e9966b7bd8b183f0379f28aa3c9a885065b8a090f3af15a15acb553b36a73d25a581e7f54f5e1f6f49c4f638ce40ba67629e910a04444d5f6b66c4548b611f851feb08d64fa4d99b83ad218d182d0e86e7f87d4923599a547effed6b9c86e853aef9e60767bff33de916bd799eaf3922ae80abadcc91c95f47e702e2fbd2631d0b77ef85f092204141250c4162b0369be64c1d6bdc2d58c02981cc1de13ae3efba34fbfb3dd0ef3ac4c502a1b87c6ee6bc1a9131b098a85d31560c60c599398d0bd80b37bf4d20df81522b2acc749178fb785
bench_result : [128 * nblocks]
bench_result =
0x9b00ae426bcc2cd6150a0af62b8be77fbb389c5b061a893588d1918f50f1f31ea1183bd81fd7faae77b4f6321a17130f46e21a2653b1f7dc520bf13305c5e7141cee9d8809d58b9b8ec2aa225120ea6ecec21fba09678bbbeda0b483ad299a8adb7b306599531cf717fd67a1c25e2adeeb48521619991e122b053c3a842936b14b6eea74734a6fc2abea6c1fc4780b2df8059ce9715299eeff7b6577409ebae71285929379cd065df0c249f9696e1b28da476ae52d55d0b1f676c619271d37d4211906d402e4eaf4df3031be5bc00962b7747e7b880bf55bee2882e5008e1c1fed70beb7e54be0545100a2e122b94536b888aaea25dde9e0715dfc892dee2b4fb8e94c6b15a2e77adad1f98e50ffef837309998fcdfd9bcb3d16dcd2a162a3b66c2533474981ba72321aaa9a611c670015fa6cbf9f7d7f26b3da415eccf01872cc3a686f659c0cc0d1d08a1d41470b0ceab527bd6499433a2f2df865982b3f616c246fe49f3a15b676983f7f853f6355bc2f4cdc39e5a29347f7031ab7d2659d0ddfb259fbdfe37eaee2e4dcbdfe0ac584038c5a98d85182ca2424f0e75b7f84d512828ed20bbd05065ed4ba0b850b51c31ecb231f2c879993038d7c9487e0fa46a84a02d4f5408faabd9f41edbbef5d6183dd880ea5b7272a2c46900e02357550c036f4b84168a3e891cd8fe33c2d521ce060a2863bb735e97614d0f5bf40068bfacb02297351db4a5bd80d8140a7e0734550967b2445d4236411e04f83e7f15f5148c9d758994cb8427238cea307ddde786dd74e5565b1dd905d085ebb5a7c725d72164adeeafd7387636c31eee2e729bd0fdf95686f957befdb190101cc23cc9b8e39c652e937bd1e21adad99b86d3b2ed0e4ed4ea4bd9d9ed2ad2b99adf40577fba6b25364cd6d96f79cb0f24ae551021904b57c1d469cfac780ea8469c530ab9d2fe6e98c270c5e1babed259878f48ab5824ebf327d8d18fd2e460334cc0ca9f3b0208c0b322a074185830c460cf58c45cef2234aa5ceb6ac294325bd4d4f9e569531165b9e731c84ffc92f453ce92464658592396f83555284a5f69288e3263d7bd083fa3257b0a11a9d8e4702ed06ebd172eacb7f559527637e0259573b1723c079465d593d5e89163e187ae7ac629ed75e398274daf9c420cac2d3b8f0de82dc9d50cd85d93460213416e3e5c0960c563d26fdb56e1e0dc79b251e95364389f6acbd78edd2664be1edc789b2c7a45b2101c69b3cdb8f9f6a2d7316d2cdca02fb5119d76c9bc93f7bc4e075eee1d453fa4668f368919d14035a7ba293d9787744f44e734443e9abc79a8d7aea71918f0a925026809cf43ae2fd1f6ea00fae2f87d4e7d83e4e86c81695d77e48d5f7080d61d878bde080cec46f4ed19d78f2b0c14db0bb6c871e6506064aa1c7b23c7d2baa9b5db5be3fc94923e09fddc13cd8322d05d990b3a9c5ce418c542eb80b1839a23ed7bc0b588ec957db3df1e1389ff0d541ec2f5331ab92fa7f85efa5ae9ec1c513365df179bb29d4f1914940c68468bd12e9fce04c8d08b6d3f1a4e2d632303ca99656bb248efbb6becad7ac6535678d6534aec746fbca6ec3dec85e4db505872e88bde65214b92eba09b91aff63c5db7e440a1f0ef0bca38759f9aaa35c0b8c565ec4307cc07a3226c992163aaa968ab9b9e507fa4b1910d1c24442615ffea299a8d7fcaf7aa2db3fac83d9f3b8a90bd9ae9100167944e01a07c011d0115870f5079d991d3dccd71fdd23b383b69409a1ba519c22194de6d1048e1195a4c716e0b27055aef816218d94972177732b0abd9df432d8f09293d8b22cc83e05522f7fa46742cd29b63357096601137130dc772717f8f4d02b5651fae2d74f72b25e9266090b95bf3ecb6ddda78edfa47346cf336e79548f9ea09eebe95da8903c86af35cb0abdaa4b78f05b2ef66342072b229a7f030e5b2f8e2ead7a8f5ea2a512cf0f02a4b0fc23e5aef4518f1c40674f5552a040cddf2daf47eec38103e6703720bdf40d68f8de4a9c9a39b1a21a2ea15337772526128abb3234bdce85dd7187a827f7aed625b862887f4ef41f656cc76c5311e34e654e0babe2230d3c1f7554106bab1dcdf18361e5579cf794af967421a1f06f80cfc254a9fa0a5b2a7bebd6dc8bbbf178f9647e356a4fd61e41301386784ba90dfaf5823a0007e50e61a0c3720b9b54edb800ba805e3817cddc7015febed997de87030f3341fad7249ce4530d55f5e0b3aac5a9de0d72c6c5672bc29440354d3a7d88873abdd090f41fa1db8740736583f74c7bfe526b283274f4bc08dea4884ccd75d34df9d8410f7e488b541f467331c5e7da352faa1019c394535472aa0f1ed1512928591e0b4335271df7a7d2d9d7fa1f7f4522be394b39bf15a7bc7a97ad21e171a638eb27d44efd57921938ed70335e3f3a8922553392db8a07e02cd4dc1184edbfbadaf09f97c50268d25dd5e7064968fde486d68b1051cef118d80c7a2c911a8cad22b26fd94f559cc12972b655ce014914cd3c20542815a0ff98ee166611eb2edc147bf2989d4fa1d72d88f7d211d05fe8e312b441edb3627982da6606d0cfa1c696979af5ff371e293c0a749f172343ab5f87ccd8a9d1c364f032e763a939f0696989a5316b48df43763d42170f598326579acba84e16508b5d4ffac1723c9bb98f7736e961c67caf3243b07760b3be602be9995a1a6b8c5360357e9fefab445229ccddd6214476a2c3af0eeadcd067db77ecaf7c84d605b99c89ab583edac68c3c8d951cce207c2df274709fe2d25477f14a8e50bc05f82b2cf49d9b56d97182b90a9395d90f23b9ee734d70d9312c9f6278f0ecd5f90c82f67693a589a94a6555f3abd8eac5408259879603acdc67b6fb cryptol-2.8.0/bench/data/BigSequence.cry 0000755 0000000 0000000 00000045661 07346545000 016326 0 ustar 00 0000000 0000000 xs = [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,625,626,627,628,629,630,631,632,633,634,635,636,637,638,639,640,641,642,643,644,645,646,647,648,649,650,651,652,653,654,655,656,657,658,659,660,661,662,663,664,665,666,667,668,669,670,671,672,673,674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691,692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709,710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727,728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745,746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763,764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781,782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799,800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835,836,837,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853,854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871,872,873,874,875,876,877,878,879,880,881,882,883,884,885,886,887,888,889,890,891,892,893,894,895,896,897,898,899,900,901,902,903,904,905,906,907,908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929,930,931,932,933,934,935,936,937,938,939,940,941,942,943,944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959,960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,975,976,977,978,979,980,981,982,983,984,985,986,987,988,989,990,991,992,993,994,995,996,997,998,999,1000,1001,1002,1003,1004,1005,1006,1007,1008,1009,1010,1011,1012,1013,1014,1015,1016,1017,1018,1019,1020,1021,1022,1023,1024,1025,1026,1027,1028,1029,1030,1031,1032,1033,1034,1035,1036,1037,1038,1039,1040,1041,1042,1043,1044,1045,1046,1047,1048,1049,1050,1051,1052,1053,1054,1055,1056,1057,1058,1059,1060,1061,1062,1063,1064,1065,1066,1067,1068,1069,1070,1071,1072,1073,1074,1075,1076,1077,1078,1079,1080,1081,1082,1083,1084,1085,1086,1087,1088,1089,1090,1091,1092,1093,1094,1095,1096,1097,1098,1099,1100,1101,1102,1103,1104,1105,1106,1107,1108,1109,1110,1111,1112,1113,1114,1115,1116,1117,1118,1119,1120,1121,1122,1123,1124,1125,1126,1127,1128,1129,1130,1131,1132,1133,1134,1135,1136,1137,1138,1139,1140,1141,1142,1143,1144,1145,1146,1147,1148,1149,1150,1151,1152,1153,1154,1155,1156,1157,1158,1159,1160,1161,1162,1163,1164,1165,1166,1167,1168,1169,1170,1171,1172,1173,1174,1175,1176,1177,1178,1179,1180,1181,1182,1183,1184,1185,1186,1187,1188,1189,1190,1191,1192,1193,1194,1195,1196,1197,1198,1199,1200,1201,1202,1203,1204,1205,1206,1207,1208,1209,1210,1211,1212,1213,1214,1215,1216,1217,1218,1219,1220,1221,1222,1223,1224,1225,1226,1227,1228,1229,1230,1231,1232,1233,1234,1235,1236,1237,1238,1239,1240,1241,1242,1243,1244,1245,1246,1247,1248,1249,1250,1251,1252,1253,1254,1255,1256,1257,1258,1259,1260,1261,1262,1263,1264,1265,1266,1267,1268,1269,1270,1271,1272,1273,1274,1275,1276,1277,1278,1279,1280,1281,1282,1283,1284,1285,1286,1287,1288,1289,1290,1291,1292,1293,1294,1295,1296,1297,1298,1299,1300,1301,1302,1303,1304,1305,1306,1307,1308,1309,1310,1311,1312,1313,1314,1315,1316,1317,1318,1319,1320,1321,1322,1323,1324,1325,1326,1327,1328,1329,1330,1331,1332,1333,1334,1335,1336,1337,1338,1339,1340,1341,1342,1343,1344,1345,1346,1347,1348,1349,1350,1351,1352,1353,1354,1355,1356,1357,1358,1359,1360,1361,1362,1363,1364,1365,1366,1367,1368,1369,1370,1371,1372,1373,1374,1375,1376,1377,1378,1379,1380,1381,1382,1383,1384,1385,1386,1387,1388,1389,1390,1391,1392,1393,1394,1395,1396,1397,1398,1399,1400,1401,1402,1403,1404,1405,1406,1407,1408,1409,1410,1411,1412,1413,1414,1415,1416,1417,1418,1419,1420,1421,1422,1423,1424,1425,1426,1427,1428,1429,1430,1431,1432,1433,1434,1435,1436,1437,1438,1439,1440,1441,1442,1443,1444,1445,1446,1447,1448,1449,1450,1451,1452,1453,1454,1455,1456,1457,1458,1459,1460,1461,1462,1463,1464,1465,1466,1467,1468,1469,1470,1471,1472,1473,1474,1475,1476,1477,1478,1479,1480,1481,1482,1483,1484,1485,1486,1487,1488,1489,1490,1491,1492,1493,1494,1495,1496,1497,1498,1499,1500,1501,1502,1503,1504,1505,1506,1507,1508,1509,1510,1511,1512,1513,1514,1515,1516,1517,1518,1519,1520,1521,1522,1523,1524,1525,1526,1527,1528,1529,1530,1531,1532,1533,1534,1535,1536,1537,1538,1539,1540,1541,1542,1543,1544,1545,1546,1547,1548,1549,1550,1551,1552,1553,1554,1555,1556,1557,1558,1559,1560,1561,1562,1563,1564,1565,1566,1567,1568,1569,1570,1571,1572,1573,1574,1575,1576,1577,1578,1579,1580,1581,1582,1583,1584,1585,1586,1587,1588,1589,1590,1591,1592,1593,1594,1595,1596,1597,1598,1599,1600,1601,1602,1603,1604,1605,1606,1607,1608,1609,1610,1611,1612,1613,1614,1615,1616,1617,1618,1619,1620,1621,1622,1623,1624,1625,1626,1627,1628,1629,1630,1631,1632,1633,1634,1635,1636,1637,1638,1639,1640,1641,1642,1643,1644,1645,1646,1647,1648,1649,1650,1651,1652,1653,1654,1655,1656,1657,1658,1659,1660,1661,1662,1663,1664,1665,1666,1667,1668,1669,1670,1671,1672,1673,1674,1675,1676,1677,1678,1679,1680,1681,1682,1683,1684,1685,1686,1687,1688,1689,1690,1691,1692,1693,1694,1695,1696,1697,1698,1699,1700,1701,1702,1703,1704,1705,1706,1707,1708,1709,1710,1711,1712,1713,1714,1715,1716,1717,1718,1719,1720,1721,1722,1723,1724,1725,1726,1727,1728,1729,1730,1731,1732,1733,1734,1735,1736,1737,1738,1739,1740,1741,1742,1743,1744,1745,1746,1747,1748,1749,1750,1751,1752,1753,1754,1755,1756,1757,1758,1759,1760,1761,1762,1763,1764,1765,1766,1767,1768,1769,1770,1771,1772,1773,1774,1775,1776,1777,1778,1779,1780,1781,1782,1783,1784,1785,1786,1787,1788,1789,1790,1791,1792,1793,1794,1795,1796,1797,1798,1799,1800,1801,1802,1803,1804,1805,1806,1807,1808,1809,1810,1811,1812,1813,1814,1815,1816,1817,1818,1819,1820,1821,1822,1823,1824,1825,1826,1827,1828,1829,1830,1831,1832,1833,1834,1835,1836,1837,1838,1839,1840,1841,1842,1843,1844,1845,1846,1847,1848,1849,1850,1851,1852,1853,1854,1855,1856,1857,1858,1859,1860,1861,1862,1863,1864,1865,1866,1867,1868,1869,1870,1871,1872,1873,1874,1875,1876,1877,1878,1879,1880,1881,1882,1883,1884,1885,1886,1887,1888,1889,1890,1891,1892,1893,1894,1895,1896,1897,1898,1899,1900,1901,1902,1903,1904,1905,1906,1907,1908,1909,1910,1911,1912,1913,1914,1915,1916,1917,1918,1919,1920,1921,1922,1923,1924,1925,1926,1927,1928,1929,1930,1931,1932,1933,1934,1935,1936,1937,1938,1939,1940,1941,1942,1943,1944,1945,1946,1947,1948,1949,1950,1951,1952,1953,1954,1955,1956,1957,1958,1959,1960,1961,1962,1963,1964,1965,1966,1967,1968,1969,1970,1971,1972,1973,1974,1975,1976,1977,1978,1979,1980,1981,1982,1983,1984,1985,1986,1987,1988,1989,1990,1991,1992,1993,1994,1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013,2014,2015,2016,2017,2018,2019,2020,2021,2022,2023,2024,2025,2026,2027,2028,2029,2030,2031,2032,2033,2034,2035,2036,2037,2038,2039,2040,2041,2042,2043,2044,2045,2046,2047,2048,2049,2050,2051,2052,2053,2054,2055,2056,2057,2058,2059,2060,2061,2062,2063,2064,2065,2066,2067,2068,2069,2070,2071,2072,2073,2074,2075,2076,2077,2078,2079,2080,2081,2082,2083,2084,2085,2086,2087,2088,2089,2090,2091,2092,2093,2094,2095,2096,2097,2098,2099,2100,2101,2102,2103,2104,2105,2106,2107,2108,2109,2110,2111,2112,2113,2114,2115,2116,2117,2118,2119,2120,2121,2122,2123,2124,2125,2126,2127,2128,2129,2130,2131,2132,2133,2134,2135,2136,2137,2138,2139,2140,2141,2142,2143,2144,2145,2146,2147,2148,2149,2150,2151,2152,2153,2154,2155,2156,2157,2158,2159,2160,2161,2162,2163,2164,2165,2166,2167,2168,2169,2170,2171,2172,2173,2174,2175,2176,2177,2178,2179,2180,2181,2182,2183,2184,2185,2186,2187,2188,2189,2190,2191,2192,2193,2194,2195,2196,2197,2198,2199,2200,2201,2202,2203,2204,2205,2206,2207,2208,2209,2210,2211,2212,2213,2214,2215,2216,2217,2218,2219,2220,2221,2222,2223,2224,2225,2226,2227,2228,2229,2230,2231,2232,2233,2234,2235,2236,2237,2238,2239,2240,2241,2242,2243,2244,2245,2246,2247,2248,2249,2250,2251,2252,2253,2254,2255,2256,2257,2258,2259,2260,2261,2262,2263,2264,2265,2266,2267,2268,2269,2270,2271,2272,2273,2274,2275,2276,2277,2278,2279,2280,2281,2282,2283,2284,2285,2286,2287,2288,2289,2290,2291,2292,2293,2294,2295,2296,2297,2298,2299,2300,2301,2302,2303,2304,2305,2306,2307,2308,2309,2310,2311,2312,2313,2314,2315,2316,2317,2318,2319,2320,2321,2322,2323,2324,2325,2326,2327,2328,2329,2330,2331,2332,2333,2334,2335,2336,2337,2338,2339,2340,2341,2342,2343,2344,2345,2346,2347,2348,2349,2350,2351,2352,2353,2354,2355,2356,2357,2358,2359,2360,2361,2362,2363,2364,2365,2366,2367,2368,2369,2370,2371,2372,2373,2374,2375,2376,2377,2378,2379,2380,2381,2382,2383,2384,2385,2386,2387,2388,2389,2390,2391,2392,2393,2394,2395,2396,2397,2398,2399,2400,2401,2402,2403,2404,2405,2406,2407,2408,2409,2410,2411,2412,2413,2414,2415,2416,2417,2418,2419,2420,2421,2422,2423,2424,2425,2426,2427,2428,2429,2430,2431,2432,2433,2434,2435,2436,2437,2438,2439,2440,2441,2442,2443,2444,2445,2446,2447,2448,2449,2450,2451,2452,2453,2454,2455,2456,2457,2458,2459,2460,2461,2462,2463,2464,2465,2466,2467,2468,2469,2470,2471,2472,2473,2474,2475,2476,2477,2478,2479,2480,2481,2482,2483,2484,2485,2486,2487,2488,2489,2490,2491,2492,2493,2494,2495,2496,2497,2498,2499,2500,2501,2502,2503,2504,2505,2506,2507,2508,2509,2510,2511,2512,2513,2514,2515,2516,2517,2518,2519,2520,2521,2522,2523,2524,2525,2526,2527,2528,2529,2530,2531,2532,2533,2534,2535,2536,2537,2538,2539,2540,2541,2542,2543,2544,2545,2546,2547,2548,2549,2550,2551,2552,2553,2554,2555,2556,2557,2558,2559,2560,2561,2562,2563,2564,2565,2566,2567,2568,2569,2570,2571,2572,2573,2574,2575,2576,2577,2578,2579,2580,2581,2582,2583,2584,2585,2586,2587,2588,2589,2590,2591,2592,2593,2594,2595,2596,2597,2598,2599,2600,2601,2602,2603,2604,2605,2606,2607,2608,2609,2610,2611,2612,2613,2614,2615,2616,2617,2618,2619,2620,2621,2622,2623,2624,2625,2626,2627,2628,2629,2630,2631,2632,2633,2634,2635,2636,2637,2638,2639,2640,2641,2642,2643,2644,2645,2646,2647,2648,2649,2650,2651,2652,2653,2654,2655,2656,2657,2658,2659,2660,2661,2662,2663,2664,2665,2666,2667,2668,2669,2670,2671,2672,2673,2674,2675,2676,2677,2678,2679,2680,2681,2682,2683,2684,2685,2686,2687,2688,2689,2690,2691,2692,2693,2694,2695,2696,2697,2698,2699,2700,2701,2702,2703,2704,2705,2706,2707,2708,2709,2710,2711,2712,2713,2714,2715,2716,2717,2718,2719,2720,2721,2722,2723,2724,2725,2726,2727,2728,2729,2730,2731,2732,2733,2734,2735,2736,2737,2738,2739,2740,2741,2742,2743,2744,2745,2746,2747,2748,2749,2750,2751,2752,2753,2754,2755,2756,2757,2758,2759,2760,2761,2762,2763,2764,2765,2766,2767,2768,2769,2770,2771,2772,2773,2774,2775,2776,2777,2778,2779,2780,2781,2782,2783,2784,2785,2786,2787,2788,2789,2790,2791,2792,2793,2794,2795,2796,2797,2798,2799,2800,2801,2802,2803,2804,2805,2806,2807,2808,2809,2810,2811,2812,2813,2814,2815,2816,2817,2818,2819,2820,2821,2822,2823,2824,2825,2826,2827,2828,2829,2830,2831,2832,2833,2834,2835,2836,2837,2838,2839,2840,2841,2842,2843,2844,2845,2846,2847,2848,2849,2850,2851,2852,2853,2854,2855,2856,2857,2858,2859,2860,2861,2862,2863,2864,2865,2866,2867,2868,2869,2870,2871,2872,2873,2874,2875,2876,2877,2878,2879,2880,2881,2882,2883,2884,2885,2886,2887,2888,2889,2890,2891,2892,2893,2894,2895,2896,2897,2898,2899,2900,2901,2902,2903,2904,2905,2906,2907,2908,2909,2910,2911,2912,2913,2914,2915,2916,2917,2918,2919,2920,2921,2922,2923,2924,2925,2926,2927,2928,2929,2930,2931,2932,2933,2934,2935,2936,2937,2938,2939,2940,2941,2942,2943,2944,2945,2946,2947,2948,2949,2950,2951,2952,2953,2954,2955,2956,2957,2958,2959,2960,2961,2962,2963,2964,2965,2966,2967,2968,2969,2970,2971,2972,2973,2974,2975,2976,2977,2978,2979,2980,2981,2982,2983,2984,2985,2986,2987,2988,2989,2990,2991,2992,2993,2994,2995,2996,2997,2998,2999,3000,3001,3002,3003,3004,3005,3006,3007,3008,3009,3010,3011,3012,3013,3014,3015,3016,3017,3018,3019,3020,3021,3022,3023,3024,3025,3026,3027,3028,3029,3030,3031,3032,3033,3034,3035,3036,3037,3038,3039,3040,3041,3042,3043,3044,3045,3046,3047,3048,3049,3050,3051,3052,3053,3054,3055,3056,3057,3058,3059,3060,3061,3062,3063,3064,3065,3066,3067,3068,3069,3070,3071,3072,3073,3074,3075,3076,3077,3078,3079,3080,3081,3082,3083,3084,3085,3086,3087,3088,3089,3090,3091,3092,3093,3094,3095,3096,3097,3098,3099,3100,3101,3102,3103,3104,3105,3106,3107,3108,3109,3110,3111,3112,3113,3114,3115,3116,3117,3118,3119,3120,3121,3122,3123,3124,3125,3126,3127,3128,3129,3130,3131,3132,3133,3134,3135,3136,3137,3138,3139,3140,3141,3142,3143,3144,3145,3146,3147,3148,3149,3150,3151,3152,3153,3154,3155,3156,3157,3158,3159,3160,3161,3162,3163,3164,3165,3166,3167,3168,3169,3170,3171,3172,3173,3174,3175,3176,3177,3178,3179,3180,3181,3182,3183,3184,3185,3186,3187,3188,3189,3190,3191,3192,3193,3194,3195,3196,3197,3198,3199,3200,3201,3202,3203,3204,3205,3206,3207,3208,3209,3210,3211,3212,3213,3214,3215,3216,3217,3218,3219,3220,3221,3222,3223,3224,3225,3226,3227,3228,3229,3230,3231,3232,3233,3234,3235,3236,3237,3238,3239,3240,3241,3242,3243,3244,3245,3246,3247,3248,3249,3250,3251,3252,3253,3254,3255,3256,3257,3258,3259,3260,3261,3262,3263,3264,3265,3266,3267,3268,3269,3270,3271,3272,3273,3274,3275,3276,3277,3278,3279,3280,3281,3282,3283,3284,3285,3286,3287,3288,3289,3290,3291,3292,3293,3294,3295,3296,3297,3298,3299,3300,3301,3302,3303,3304,3305,3306,3307,3308,3309,3310,3311,3312,3313,3314,3315,3316,3317,3318,3319,3320,3321,3322,3323,3324,3325,3326,3327,3328,3329,3330,3331,3332,3333,3334,3335,3336,3337,3338,3339,3340,3341,3342,3343,3344,3345,3346,3347,3348,3349,3350,3351,3352,3353,3354,3355,3356,3357,3358,3359,3360,3361,3362,3363,3364,3365,3366,3367,3368,3369,3370,3371,3372,3373,3374,3375,3376,3377,3378,3379,3380,3381,3382,3383,3384,3385,3386,3387,3388,3389,3390,3391,3392,3393,3394,3395,3396,3397,3398,3399,3400,3401,3402,3403,3404,3405,3406,3407,3408,3409,3410,3411,3412,3413,3414,3415,3416,3417,3418,3419,3420,3421,3422,3423,3424,3425,3426,3427,3428,3429,3430,3431,3432,3433,3434,3435,3436,3437,3438,3439,3440,3441,3442,3443,3444,3445,3446,3447,3448,3449,3450,3451,3452,3453,3454,3455,3456,3457,3458,3459,3460,3461,3462,3463,3464,3465,3466,3467,3468,3469,3470,3471,3472,3473,3474,3475,3476,3477,3478,3479,3480,3481,3482,3483,3484,3485,3486,3487,3488,3489,3490,3491,3492,3493,3494,3495,3496,3497,3498,3499,3500,3501,3502,3503,3504,3505,3506,3507,3508,3509,3510,3511,3512,3513,3514,3515,3516,3517,3518,3519,3520,3521,3522,3523,3524,3525,3526,3527,3528,3529,3530,3531,3532,3533,3534,3535,3536,3537,3538,3539,3540,3541,3542,3543,3544,3545,3546,3547,3548,3549,3550,3551,3552,3553,3554,3555,3556,3557,3558,3559,3560,3561,3562,3563,3564,3565,3566,3567,3568,3569,3570,3571,3572,3573,3574,3575,3576,3577,3578,3579,3580,3581,3582,3583,3584,3585,3586,3587,3588,3589,3590,3591,3592,3593,3594,3595,3596,3597,3598,3599,3600,3601,3602,3603,3604,3605,3606,3607,3608,3609,3610,3611,3612,3613,3614,3615,3616,3617,3618,3619,3620,3621,3622,3623,3624,3625,3626,3627,3628,3629,3630,3631,3632,3633,3634,3635,3636,3637,3638,3639,3640,3641,3642,3643,3644,3645,3646,3647,3648,3649,3650,3651,3652,3653,3654,3655,3656,3657,3658,3659,3660,3661,3662,3663,3664,3665,3666,3667,3668,3669,3670,3671,3672,3673,3674,3675,3676,3677,3678,3679,3680,3681,3682,3683,3684,3685,3686,3687,3688,3689,3690,3691,3692,3693,3694,3695,3696,3697,3698,3699,3700,3701,3702,3703,3704,3705,3706,3707,3708,3709,3710,3711,3712,3713,3714,3715,3716,3717,3718,3719,3720,3721,3722,3723,3724,3725,3726,3727,3728,3729,3730,3731,3732,3733,3734,3735,3736,3737,3738,3739,3740,3741,3742,3743,3744,3745,3746,3747,3748,3749,3750,3751,3752,3753,3754,3755,3756,3757,3758,3759,3760,3761,3762,3763,3764,3765,3766,3767,3768,3769,3770,3771,3772,3773,3774,3775,3776,3777,3778,3779,3780,3781,3782,3783,3784,3785,3786,3787,3788,3789,3790,3791,3792,3793,3794,3795,3796,3797,3798,3799,3800,3801,3802,3803,3804,3805,3806,3807,3808,3809,3810,3811,3812,3813,3814,3815,3816,3817,3818,3819,3820,3821,3822,3823,3824,3825,3826,3827,3828,3829,3830,3831,3832,3833,3834,3835,3836,3837,3838,3839,3840,3841,3842,3843,3844,3845,3846,3847,3848,3849,3850,3851,3852,3853,3854,3855,3856,3857,3858,3859,3860,3861,3862,3863,3864,3865,3866,3867,3868,3869,3870,3871,3872,3873,3874,3875,3876,3877,3878,3879,3880,3881,3882,3883,3884,3885,3886,3887,3888,3889,3890,3891,3892,3893,3894,3895,3896,3897,3898,3899,3900,3901,3902,3903,3904,3905,3906,3907,3908,3909,3910,3911,3912,3913,3914,3915,3916,3917,3918,3919,3920,3921,3922,3923,3924,3925,3926,3927,3928,3929,3930,3931,3932,3933,3934,3935,3936,3937,3938,3939,3940,3941,3942,3943,3944,3945,3946,3947,3948,3949,3950,3951,3952,3953,3954,3955,3956,3957,3958,3959,3960,3961,3962,3963,3964,3965,3966,3967,3968,3969,3970,3971,3972,3973,3974,3975,3976,3977,3978,3979,3980,3981,3982,3983,3984,3985,3986,3987,3988,3989,3990,3991,3992,3993,3994,3995,3996,3997,3998,3999,4000,4001,4002,4003,4004,4005,4006,4007,4008,4009,4010,4011,4012,4013,4014,4015,4016,4017,4018,4019,4020,4021,4022,4023,4024,4025,4026,4027,4028,4029,4030,4031,4032,4033,4034,4035,4036,4037,4038,4039,4040,4041,4042,4043,4044,4045,4046,4047,4048,4049,4050,4051,4052,4053,4054,4055,4056,4057,4058,4059,4060,4061,4062,4063,4064,4065,4066,4067,4068,4069,4070,4071,4072,4073,4074,4075,4076,4077,4078,4079,4080,4081,4082,4083,4084,4085,4086,4087,4088,4089,4090,4091,4092,4093,4094,4095]
cryptol-2.8.0/bench/data/BigSequenceHex.cry 0000755 0000000 0000000 00000070005 07346545000 016761 0 ustar 00 0000000 0000000 xs = [0x000, 0x001, 0x002, 0x003, 0x004, 0x005, 0x006, 0x007, 0x008, 0x009, 0x00a, 0x00b, 0x00c, 0x00d, 0x00e, 0x00f, 0x010, 0x011, 0x012, 0x013, 0x014, 0x015, 0x016, 0x017, 0x018, 0x019, 0x01a, 0x01b, 0x01c, 0x01d, 0x01e, 0x01f, 0x020, 0x021, 0x022, 0x023, 0x024, 0x025, 0x026, 0x027, 0x028, 0x029, 0x02a, 0x02b, 0x02c, 0x02d, 0x02e, 0x02f, 0x030, 0x031, 0x032, 0x033, 0x034, 0x035, 0x036, 0x037, 0x038, 0x039, 0x03a, 0x03b, 0x03c, 0x03d, 0x03e, 0x03f, 0x040, 0x041, 0x042, 0x043, 0x044, 0x045, 0x046, 0x047, 0x048, 0x049, 0x04a, 0x04b, 0x04c, 0x04d, 0x04e, 0x04f, 0x050, 0x051, 0x052, 0x053, 0x054, 0x055, 0x056, 0x057, 0x058, 0x059, 0x05a, 0x05b, 0x05c, 0x05d, 0x05e, 0x05f, 0x060, 0x061, 0x062, 0x063, 0x064, 0x065, 0x066, 0x067, 0x068, 0x069, 0x06a, 0x06b, 0x06c, 0x06d, 0x06e, 0x06f, 0x070, 0x071, 0x072, 0x073, 0x074, 0x075, 0x076, 0x077, 0x078, 0x079, 0x07a, 0x07b, 0x07c, 0x07d, 0x07e, 0x07f, 0x080, 0x081, 0x082, 0x083, 0x084, 0x085, 0x086, 0x087, 0x088, 0x089, 0x08a, 0x08b, 0x08c, 0x08d, 0x08e, 0x08f, 0x090, 0x091, 0x092, 0x093, 0x094, 0x095, 0x096, 0x097, 0x098, 0x099, 0x09a, 0x09b, 0x09c, 0x09d, 0x09e, 0x09f, 0x0a0, 0x0a1, 0x0a2, 0x0a3, 0x0a4, 0x0a5, 0x0a6, 0x0a7, 0x0a8, 0x0a9, 0x0aa, 0x0ab, 0x0ac, 0x0ad, 0x0ae, 0x0af, 0x0b0, 0x0b1, 0x0b2, 0x0b3, 0x0b4, 0x0b5, 0x0b6, 0x0b7, 0x0b8, 0x0b9, 0x0ba, 0x0bb, 0x0bc, 0x0bd, 0x0be, 0x0bf, 0x0c0, 0x0c1, 0x0c2, 0x0c3, 0x0c4, 0x0c5, 0x0c6, 0x0c7, 0x0c8, 0x0c9, 0x0ca, 0x0cb, 0x0cc, 0x0cd, 0x0ce, 0x0cf, 0x0d0, 0x0d1, 0x0d2, 0x0d3, 0x0d4, 0x0d5, 0x0d6, 0x0d7, 0x0d8, 0x0d9, 0x0da, 0x0db, 0x0dc, 0x0dd, 0x0de, 0x0df, 0x0e0, 0x0e1, 0x0e2, 0x0e3, 0x0e4, 0x0e5, 0x0e6, 0x0e7, 0x0e8, 0x0e9, 0x0ea, 0x0eb, 0x0ec, 0x0ed, 0x0ee, 0x0ef, 0x0f0, 0x0f1, 0x0f2, 0x0f3, 0x0f4, 0x0f5, 0x0f6, 0x0f7, 0x0f8, 0x0f9, 0x0fa, 0x0fb, 0x0fc, 0x0fd, 0x0fe, 0x0ff, 0x100, 0x101, 0x102, 0x103, 0x104, 0x105, 0x106, 0x107, 0x108, 0x109, 0x10a, 0x10b, 0x10c, 0x10d, 0x10e, 0x10f, 0x110, 0x111, 0x112, 0x113, 0x114, 0x115, 0x116, 0x117, 0x118, 0x119, 0x11a, 0x11b, 0x11c, 0x11d, 0x11e, 0x11f, 0x120, 0x121, 0x122, 0x123, 0x124, 0x125, 0x126, 0x127, 0x128, 0x129, 0x12a, 0x12b, 0x12c, 0x12d, 0x12e, 0x12f, 0x130, 0x131, 0x132, 0x133, 0x134, 0x135, 0x136, 0x137, 0x138, 0x139, 0x13a, 0x13b, 0x13c, 0x13d, 0x13e, 0x13f, 0x140, 0x141, 0x142, 0x143, 0x144, 0x145, 0x146, 0x147, 0x148, 0x149, 0x14a, 0x14b, 0x14c, 0x14d, 0x14e, 0x14f, 0x150, 0x151, 0x152, 0x153, 0x154, 0x155, 0x156, 0x157, 0x158, 0x159, 0x15a, 0x15b, 0x15c, 0x15d, 0x15e, 0x15f, 0x160, 0x161, 0x162, 0x163, 0x164, 0x165, 0x166, 0x167, 0x168, 0x169, 0x16a, 0x16b, 0x16c, 0x16d, 0x16e, 0x16f, 0x170, 0x171, 0x172, 0x173, 0x174, 0x175, 0x176, 0x177, 0x178, 0x179, 0x17a, 0x17b, 0x17c, 0x17d, 0x17e, 0x17f, 0x180, 0x181, 0x182, 0x183, 0x184, 0x185, 0x186, 0x187, 0x188, 0x189, 0x18a, 0x18b, 0x18c, 0x18d, 0x18e, 0x18f, 0x190, 0x191, 0x192, 0x193, 0x194, 0x195, 0x196, 0x197, 0x198, 0x199, 0x19a, 0x19b, 0x19c, 0x19d, 0x19e, 0x19f, 0x1a0, 0x1a1, 0x1a2, 0x1a3, 0x1a4, 0x1a5, 0x1a6, 0x1a7, 0x1a8, 0x1a9, 0x1aa, 0x1ab, 0x1ac, 0x1ad, 0x1ae, 0x1af, 0x1b0, 0x1b1, 0x1b2, 0x1b3, 0x1b4, 0x1b5, 0x1b6, 0x1b7, 0x1b8, 0x1b9, 0x1ba, 0x1bb, 0x1bc, 0x1bd, 0x1be, 0x1bf, 0x1c0, 0x1c1, 0x1c2, 0x1c3, 0x1c4, 0x1c5, 0x1c6, 0x1c7, 0x1c8, 0x1c9, 0x1ca, 0x1cb, 0x1cc, 0x1cd, 0x1ce, 0x1cf, 0x1d0, 0x1d1, 0x1d2, 0x1d3, 0x1d4, 0x1d5, 0x1d6, 0x1d7, 0x1d8, 0x1d9, 0x1da, 0x1db, 0x1dc, 0x1dd, 0x1de, 0x1df, 0x1e0, 0x1e1, 0x1e2, 0x1e3, 0x1e4, 0x1e5, 0x1e6, 0x1e7, 0x1e8, 0x1e9, 0x1ea, 0x1eb, 0x1ec, 0x1ed, 0x1ee, 0x1ef, 0x1f0, 0x1f1, 0x1f2, 0x1f3, 0x1f4, 0x1f5, 0x1f6, 0x1f7, 0x1f8, 0x1f9, 0x1fa, 0x1fb, 0x1fc, 0x1fd, 0x1fe, 0x1ff, 0x200, 0x201, 0x202, 0x203, 0x204, 0x205, 0x206, 0x207, 0x208, 0x209, 0x20a, 0x20b, 0x20c, 0x20d, 0x20e, 0x20f, 0x210, 0x211, 0x212, 0x213, 0x214, 0x215, 0x216, 0x217, 0x218, 0x219, 0x21a, 0x21b, 0x21c, 0x21d, 0x21e, 0x21f, 0x220, 0x221, 0x222, 0x223, 0x224, 0x225, 0x226, 0x227, 0x228, 0x229, 0x22a, 0x22b, 0x22c, 0x22d, 0x22e, 0x22f, 0x230, 0x231, 0x232, 0x233, 0x234, 0x235, 0x236, 0x237, 0x238, 0x239, 0x23a, 0x23b, 0x23c, 0x23d, 0x23e, 0x23f, 0x240, 0x241, 0x242, 0x243, 0x244, 0x245, 0x246, 0x247, 0x248, 0x249, 0x24a, 0x24b, 0x24c, 0x24d, 0x24e, 0x24f, 0x250, 0x251, 0x252, 0x253, 0x254, 0x255, 0x256, 0x257, 0x258, 0x259, 0x25a, 0x25b, 0x25c, 0x25d, 0x25e, 0x25f, 0x260, 0x261, 0x262, 0x263, 0x264, 0x265, 0x266, 0x267, 0x268, 0x269, 0x26a, 0x26b, 0x26c, 0x26d, 0x26e, 0x26f, 0x270, 0x271, 0x272, 0x273, 0x274, 0x275, 0x276, 0x277, 0x278, 0x279, 0x27a, 0x27b, 0x27c, 0x27d, 0x27e, 0x27f, 0x280, 0x281, 0x282, 0x283, 0x284, 0x285, 0x286, 0x287, 0x288, 0x289, 0x28a, 0x28b, 0x28c, 0x28d, 0x28e, 0x28f, 0x290, 0x291, 0x292, 0x293, 0x294, 0x295, 0x296, 0x297, 0x298, 0x299, 0x29a, 0x29b, 0x29c, 0x29d, 0x29e, 0x29f, 0x2a0, 0x2a1, 0x2a2, 0x2a3, 0x2a4, 0x2a5, 0x2a6, 0x2a7, 0x2a8, 0x2a9, 0x2aa, 0x2ab, 0x2ac, 0x2ad, 0x2ae, 0x2af, 0x2b0, 0x2b1, 0x2b2, 0x2b3, 0x2b4, 0x2b5, 0x2b6, 0x2b7, 0x2b8, 0x2b9, 0x2ba, 0x2bb, 0x2bc, 0x2bd, 0x2be, 0x2bf, 0x2c0, 0x2c1, 0x2c2, 0x2c3, 0x2c4, 0x2c5, 0x2c6, 0x2c7, 0x2c8, 0x2c9, 0x2ca, 0x2cb, 0x2cc, 0x2cd, 0x2ce, 0x2cf, 0x2d0, 0x2d1, 0x2d2, 0x2d3, 0x2d4, 0x2d5, 0x2d6, 0x2d7, 0x2d8, 0x2d9, 0x2da, 0x2db, 0x2dc, 0x2dd, 0x2de, 0x2df, 0x2e0, 0x2e1, 0x2e2, 0x2e3, 0x2e4, 0x2e5, 0x2e6, 0x2e7, 0x2e8, 0x2e9, 0x2ea, 0x2eb, 0x2ec, 0x2ed, 0x2ee, 0x2ef, 0x2f0, 0x2f1, 0x2f2, 0x2f3, 0x2f4, 0x2f5, 0x2f6, 0x2f7, 0x2f8, 0x2f9, 0x2fa, 0x2fb, 0x2fc, 0x2fd, 0x2fe, 0x2ff, 0x300, 0x301, 0x302, 0x303, 0x304, 0x305, 0x306, 0x307, 0x308, 0x309, 0x30a, 0x30b, 0x30c, 0x30d, 0x30e, 0x30f, 0x310, 0x311, 0x312, 0x313, 0x314, 0x315, 0x316, 0x317, 0x318, 0x319, 0x31a, 0x31b, 0x31c, 0x31d, 0x31e, 0x31f, 0x320, 0x321, 0x322, 0x323, 0x324, 0x325, 0x326, 0x327, 0x328, 0x329, 0x32a, 0x32b, 0x32c, 0x32d, 0x32e, 0x32f, 0x330, 0x331, 0x332, 0x333, 0x334, 0x335, 0x336, 0x337, 0x338, 0x339, 0x33a, 0x33b, 0x33c, 0x33d, 0x33e, 0x33f, 0x340, 0x341, 0x342, 0x343, 0x344, 0x345, 0x346, 0x347, 0x348, 0x349, 0x34a, 0x34b, 0x34c, 0x34d, 0x34e, 0x34f, 0x350, 0x351, 0x352, 0x353, 0x354, 0x355, 0x356, 0x357, 0x358, 0x359, 0x35a, 0x35b, 0x35c, 0x35d, 0x35e, 0x35f, 0x360, 0x361, 0x362, 0x363, 0x364, 0x365, 0x366, 0x367, 0x368, 0x369, 0x36a, 0x36b, 0x36c, 0x36d, 0x36e, 0x36f, 0x370, 0x371, 0x372, 0x373, 0x374, 0x375, 0x376, 0x377, 0x378, 0x379, 0x37a, 0x37b, 0x37c, 0x37d, 0x37e, 0x37f, 0x380, 0x381, 0x382, 0x383, 0x384, 0x385, 0x386, 0x387, 0x388, 0x389, 0x38a, 0x38b, 0x38c, 0x38d, 0x38e, 0x38f, 0x390, 0x391, 0x392, 0x393, 0x394, 0x395, 0x396, 0x397, 0x398, 0x399, 0x39a, 0x39b, 0x39c, 0x39d, 0x39e, 0x39f, 0x3a0, 0x3a1, 0x3a2, 0x3a3, 0x3a4, 0x3a5, 0x3a6, 0x3a7, 0x3a8, 0x3a9, 0x3aa, 0x3ab, 0x3ac, 0x3ad, 0x3ae, 0x3af, 0x3b0, 0x3b1, 0x3b2, 0x3b3, 0x3b4, 0x3b5, 0x3b6, 0x3b7, 0x3b8, 0x3b9, 0x3ba, 0x3bb, 0x3bc, 0x3bd, 0x3be, 0x3bf, 0x3c0, 0x3c1, 0x3c2, 0x3c3, 0x3c4, 0x3c5, 0x3c6, 0x3c7, 0x3c8, 0x3c9, 0x3ca, 0x3cb, 0x3cc, 0x3cd, 0x3ce, 0x3cf, 0x3d0, 0x3d1, 0x3d2, 0x3d3, 0x3d4, 0x3d5, 0x3d6, 0x3d7, 0x3d8, 0x3d9, 0x3da, 0x3db, 0x3dc, 0x3dd, 0x3de, 0x3df, 0x3e0, 0x3e1, 0x3e2, 0x3e3, 0x3e4, 0x3e5, 0x3e6, 0x3e7, 0x3e8, 0x3e9, 0x3ea, 0x3eb, 0x3ec, 0x3ed, 0x3ee, 0x3ef, 0x3f0, 0x3f1, 0x3f2, 0x3f3, 0x3f4, 0x3f5, 0x3f6, 0x3f7, 0x3f8, 0x3f9, 0x3fa, 0x3fb, 0x3fc, 0x3fd, 0x3fe, 0x3ff, 0x400, 0x401, 0x402, 0x403, 0x404, 0x405, 0x406, 0x407, 0x408, 0x409, 0x40a, 0x40b, 0x40c, 0x40d, 0x40e, 0x40f, 0x410, 0x411, 0x412, 0x413, 0x414, 0x415, 0x416, 0x417, 0x418, 0x419, 0x41a, 0x41b, 0x41c, 0x41d, 0x41e, 0x41f, 0x420, 0x421, 0x422, 0x423, 0x424, 0x425, 0x426, 0x427, 0x428, 0x429, 0x42a, 0x42b, 0x42c, 0x42d, 0x42e, 0x42f, 0x430, 0x431, 0x432, 0x433, 0x434, 0x435, 0x436, 0x437, 0x438, 0x439, 0x43a, 0x43b, 0x43c, 0x43d, 0x43e, 0x43f, 0x440, 0x441, 0x442, 0x443, 0x444, 0x445, 0x446, 0x447, 0x448, 0x449, 0x44a, 0x44b, 0x44c, 0x44d, 0x44e, 0x44f, 0x450, 0x451, 0x452, 0x453, 0x454, 0x455, 0x456, 0x457, 0x458, 0x459, 0x45a, 0x45b, 0x45c, 0x45d, 0x45e, 0x45f, 0x460, 0x461, 0x462, 0x463, 0x464, 0x465, 0x466, 0x467, 0x468, 0x469, 0x46a, 0x46b, 0x46c, 0x46d, 0x46e, 0x46f, 0x470, 0x471, 0x472, 0x473, 0x474, 0x475, 0x476, 0x477, 0x478, 0x479, 0x47a, 0x47b, 0x47c, 0x47d, 0x47e, 0x47f, 0x480, 0x481, 0x482, 0x483, 0x484, 0x485, 0x486, 0x487, 0x488, 0x489, 0x48a, 0x48b, 0x48c, 0x48d, 0x48e, 0x48f, 0x490, 0x491, 0x492, 0x493, 0x494, 0x495, 0x496, 0x497, 0x498, 0x499, 0x49a, 0x49b, 0x49c, 0x49d, 0x49e, 0x49f, 0x4a0, 0x4a1, 0x4a2, 0x4a3, 0x4a4, 0x4a5, 0x4a6, 0x4a7, 0x4a8, 0x4a9, 0x4aa, 0x4ab, 0x4ac, 0x4ad, 0x4ae, 0x4af, 0x4b0, 0x4b1, 0x4b2, 0x4b3, 0x4b4, 0x4b5, 0x4b6, 0x4b7, 0x4b8, 0x4b9, 0x4ba, 0x4bb, 0x4bc, 0x4bd, 0x4be, 0x4bf, 0x4c0, 0x4c1, 0x4c2, 0x4c3, 0x4c4, 0x4c5, 0x4c6, 0x4c7, 0x4c8, 0x4c9, 0x4ca, 0x4cb, 0x4cc, 0x4cd, 0x4ce, 0x4cf, 0x4d0, 0x4d1, 0x4d2, 0x4d3, 0x4d4, 0x4d5, 0x4d6, 0x4d7, 0x4d8, 0x4d9, 0x4da, 0x4db, 0x4dc, 0x4dd, 0x4de, 0x4df, 0x4e0, 0x4e1, 0x4e2, 0x4e3, 0x4e4, 0x4e5, 0x4e6, 0x4e7, 0x4e8, 0x4e9, 0x4ea, 0x4eb, 0x4ec, 0x4ed, 0x4ee, 0x4ef, 0x4f0, 0x4f1, 0x4f2, 0x4f3, 0x4f4, 0x4f5, 0x4f6, 0x4f7, 0x4f8, 0x4f9, 0x4fa, 0x4fb, 0x4fc, 0x4fd, 0x4fe, 0x4ff, 0x500, 0x501, 0x502, 0x503, 0x504, 0x505, 0x506, 0x507, 0x508, 0x509, 0x50a, 0x50b, 0x50c, 0x50d, 0x50e, 0x50f, 0x510, 0x511, 0x512, 0x513, 0x514, 0x515, 0x516, 0x517, 0x518, 0x519, 0x51a, 0x51b, 0x51c, 0x51d, 0x51e, 0x51f, 0x520, 0x521, 0x522, 0x523, 0x524, 0x525, 0x526, 0x527, 0x528, 0x529, 0x52a, 0x52b, 0x52c, 0x52d, 0x52e, 0x52f, 0x530, 0x531, 0x532, 0x533, 0x534, 0x535, 0x536, 0x537, 0x538, 0x539, 0x53a, 0x53b, 0x53c, 0x53d, 0x53e, 0x53f, 0x540, 0x541, 0x542, 0x543, 0x544, 0x545, 0x546, 0x547, 0x548, 0x549, 0x54a, 0x54b, 0x54c, 0x54d, 0x54e, 0x54f, 0x550, 0x551, 0x552, 0x553, 0x554, 0x555, 0x556, 0x557, 0x558, 0x559, 0x55a, 0x55b, 0x55c, 0x55d, 0x55e, 0x55f, 0x560, 0x561, 0x562, 0x563, 0x564, 0x565, 0x566, 0x567, 0x568, 0x569, 0x56a, 0x56b, 0x56c, 0x56d, 0x56e, 0x56f, 0x570, 0x571, 0x572, 0x573, 0x574, 0x575, 0x576, 0x577, 0x578, 0x579, 0x57a, 0x57b, 0x57c, 0x57d, 0x57e, 0x57f, 0x580, 0x581, 0x582, 0x583, 0x584, 0x585, 0x586, 0x587, 0x588, 0x589, 0x58a, 0x58b, 0x58c, 0x58d, 0x58e, 0x58f, 0x590, 0x591, 0x592, 0x593, 0x594, 0x595, 0x596, 0x597, 0x598, 0x599, 0x59a, 0x59b, 0x59c, 0x59d, 0x59e, 0x59f, 0x5a0, 0x5a1, 0x5a2, 0x5a3, 0x5a4, 0x5a5, 0x5a6, 0x5a7, 0x5a8, 0x5a9, 0x5aa, 0x5ab, 0x5ac, 0x5ad, 0x5ae, 0x5af, 0x5b0, 0x5b1, 0x5b2, 0x5b3, 0x5b4, 0x5b5, 0x5b6, 0x5b7, 0x5b8, 0x5b9, 0x5ba, 0x5bb, 0x5bc, 0x5bd, 0x5be, 0x5bf, 0x5c0, 0x5c1, 0x5c2, 0x5c3, 0x5c4, 0x5c5, 0x5c6, 0x5c7, 0x5c8, 0x5c9, 0x5ca, 0x5cb, 0x5cc, 0x5cd, 0x5ce, 0x5cf, 0x5d0, 0x5d1, 0x5d2, 0x5d3, 0x5d4, 0x5d5, 0x5d6, 0x5d7, 0x5d8, 0x5d9, 0x5da, 0x5db, 0x5dc, 0x5dd, 0x5de, 0x5df, 0x5e0, 0x5e1, 0x5e2, 0x5e3, 0x5e4, 0x5e5, 0x5e6, 0x5e7, 0x5e8, 0x5e9, 0x5ea, 0x5eb, 0x5ec, 0x5ed, 0x5ee, 0x5ef, 0x5f0, 0x5f1, 0x5f2, 0x5f3, 0x5f4, 0x5f5, 0x5f6, 0x5f7, 0x5f8, 0x5f9, 0x5fa, 0x5fb, 0x5fc, 0x5fd, 0x5fe, 0x5ff, 0x600, 0x601, 0x602, 0x603, 0x604, 0x605, 0x606, 0x607, 0x608, 0x609, 0x60a, 0x60b, 0x60c, 0x60d, 0x60e, 0x60f, 0x610, 0x611, 0x612, 0x613, 0x614, 0x615, 0x616, 0x617, 0x618, 0x619, 0x61a, 0x61b, 0x61c, 0x61d, 0x61e, 0x61f, 0x620, 0x621, 0x622, 0x623, 0x624, 0x625, 0x626, 0x627, 0x628, 0x629, 0x62a, 0x62b, 0x62c, 0x62d, 0x62e, 0x62f, 0x630, 0x631, 0x632, 0x633, 0x634, 0x635, 0x636, 0x637, 0x638, 0x639, 0x63a, 0x63b, 0x63c, 0x63d, 0x63e, 0x63f, 0x640, 0x641, 0x642, 0x643, 0x644, 0x645, 0x646, 0x647, 0x648, 0x649, 0x64a, 0x64b, 0x64c, 0x64d, 0x64e, 0x64f, 0x650, 0x651, 0x652, 0x653, 0x654, 0x655, 0x656, 0x657, 0x658, 0x659, 0x65a, 0x65b, 0x65c, 0x65d, 0x65e, 0x65f, 0x660, 0x661, 0x662, 0x663, 0x664, 0x665, 0x666, 0x667, 0x668, 0x669, 0x66a, 0x66b, 0x66c, 0x66d, 0x66e, 0x66f, 0x670, 0x671, 0x672, 0x673, 0x674, 0x675, 0x676, 0x677, 0x678, 0x679, 0x67a, 0x67b, 0x67c, 0x67d, 0x67e, 0x67f, 0x680, 0x681, 0x682, 0x683, 0x684, 0x685, 0x686, 0x687, 0x688, 0x689, 0x68a, 0x68b, 0x68c, 0x68d, 0x68e, 0x68f, 0x690, 0x691, 0x692, 0x693, 0x694, 0x695, 0x696, 0x697, 0x698, 0x699, 0x69a, 0x69b, 0x69c, 0x69d, 0x69e, 0x69f, 0x6a0, 0x6a1, 0x6a2, 0x6a3, 0x6a4, 0x6a5, 0x6a6, 0x6a7, 0x6a8, 0x6a9, 0x6aa, 0x6ab, 0x6ac, 0x6ad, 0x6ae, 0x6af, 0x6b0, 0x6b1, 0x6b2, 0x6b3, 0x6b4, 0x6b5, 0x6b6, 0x6b7, 0x6b8, 0x6b9, 0x6ba, 0x6bb, 0x6bc, 0x6bd, 0x6be, 0x6bf, 0x6c0, 0x6c1, 0x6c2, 0x6c3, 0x6c4, 0x6c5, 0x6c6, 0x6c7, 0x6c8, 0x6c9, 0x6ca, 0x6cb, 0x6cc, 0x6cd, 0x6ce, 0x6cf, 0x6d0, 0x6d1, 0x6d2, 0x6d3, 0x6d4, 0x6d5, 0x6d6, 0x6d7, 0x6d8, 0x6d9, 0x6da, 0x6db, 0x6dc, 0x6dd, 0x6de, 0x6df, 0x6e0, 0x6e1, 0x6e2, 0x6e3, 0x6e4, 0x6e5, 0x6e6, 0x6e7, 0x6e8, 0x6e9, 0x6ea, 0x6eb, 0x6ec, 0x6ed, 0x6ee, 0x6ef, 0x6f0, 0x6f1, 0x6f2, 0x6f3, 0x6f4, 0x6f5, 0x6f6, 0x6f7, 0x6f8, 0x6f9, 0x6fa, 0x6fb, 0x6fc, 0x6fd, 0x6fe, 0x6ff, 0x700, 0x701, 0x702, 0x703, 0x704, 0x705, 0x706, 0x707, 0x708, 0x709, 0x70a, 0x70b, 0x70c, 0x70d, 0x70e, 0x70f, 0x710, 0x711, 0x712, 0x713, 0x714, 0x715, 0x716, 0x717, 0x718, 0x719, 0x71a, 0x71b, 0x71c, 0x71d, 0x71e, 0x71f, 0x720, 0x721, 0x722, 0x723, 0x724, 0x725, 0x726, 0x727, 0x728, 0x729, 0x72a, 0x72b, 0x72c, 0x72d, 0x72e, 0x72f, 0x730, 0x731, 0x732, 0x733, 0x734, 0x735, 0x736, 0x737, 0x738, 0x739, 0x73a, 0x73b, 0x73c, 0x73d, 0x73e, 0x73f, 0x740, 0x741, 0x742, 0x743, 0x744, 0x745, 0x746, 0x747, 0x748, 0x749, 0x74a, 0x74b, 0x74c, 0x74d, 0x74e, 0x74f, 0x750, 0x751, 0x752, 0x753, 0x754, 0x755, 0x756, 0x757, 0x758, 0x759, 0x75a, 0x75b, 0x75c, 0x75d, 0x75e, 0x75f, 0x760, 0x761, 0x762, 0x763, 0x764, 0x765, 0x766, 0x767, 0x768, 0x769, 0x76a, 0x76b, 0x76c, 0x76d, 0x76e, 0x76f, 0x770, 0x771, 0x772, 0x773, 0x774, 0x775, 0x776, 0x777, 0x778, 0x779, 0x77a, 0x77b, 0x77c, 0x77d, 0x77e, 0x77f, 0x780, 0x781, 0x782, 0x783, 0x784, 0x785, 0x786, 0x787, 0x788, 0x789, 0x78a, 0x78b, 0x78c, 0x78d, 0x78e, 0x78f, 0x790, 0x791, 0x792, 0x793, 0x794, 0x795, 0x796, 0x797, 0x798, 0x799, 0x79a, 0x79b, 0x79c, 0x79d, 0x79e, 0x79f, 0x7a0, 0x7a1, 0x7a2, 0x7a3, 0x7a4, 0x7a5, 0x7a6, 0x7a7, 0x7a8, 0x7a9, 0x7aa, 0x7ab, 0x7ac, 0x7ad, 0x7ae, 0x7af, 0x7b0, 0x7b1, 0x7b2, 0x7b3, 0x7b4, 0x7b5, 0x7b6, 0x7b7, 0x7b8, 0x7b9, 0x7ba, 0x7bb, 0x7bc, 0x7bd, 0x7be, 0x7bf, 0x7c0, 0x7c1, 0x7c2, 0x7c3, 0x7c4, 0x7c5, 0x7c6, 0x7c7, 0x7c8, 0x7c9, 0x7ca, 0x7cb, 0x7cc, 0x7cd, 0x7ce, 0x7cf, 0x7d0, 0x7d1, 0x7d2, 0x7d3, 0x7d4, 0x7d5, 0x7d6, 0x7d7, 0x7d8, 0x7d9, 0x7da, 0x7db, 0x7dc, 0x7dd, 0x7de, 0x7df, 0x7e0, 0x7e1, 0x7e2, 0x7e3, 0x7e4, 0x7e5, 0x7e6, 0x7e7, 0x7e8, 0x7e9, 0x7ea, 0x7eb, 0x7ec, 0x7ed, 0x7ee, 0x7ef, 0x7f0, 0x7f1, 0x7f2, 0x7f3, 0x7f4, 0x7f5, 0x7f6, 0x7f7, 0x7f8, 0x7f9, 0x7fa, 0x7fb, 0x7fc, 0x7fd, 0x7fe, 0x7ff, 0x800, 0x801, 0x802, 0x803, 0x804, 0x805, 0x806, 0x807, 0x808, 0x809, 0x80a, 0x80b, 0x80c, 0x80d, 0x80e, 0x80f, 0x810, 0x811, 0x812, 0x813, 0x814, 0x815, 0x816, 0x817, 0x818, 0x819, 0x81a, 0x81b, 0x81c, 0x81d, 0x81e, 0x81f, 0x820, 0x821, 0x822, 0x823, 0x824, 0x825, 0x826, 0x827, 0x828, 0x829, 0x82a, 0x82b, 0x82c, 0x82d, 0x82e, 0x82f, 0x830, 0x831, 0x832, 0x833, 0x834, 0x835, 0x836, 0x837, 0x838, 0x839, 0x83a, 0x83b, 0x83c, 0x83d, 0x83e, 0x83f, 0x840, 0x841, 0x842, 0x843, 0x844, 0x845, 0x846, 0x847, 0x848, 0x849, 0x84a, 0x84b, 0x84c, 0x84d, 0x84e, 0x84f, 0x850, 0x851, 0x852, 0x853, 0x854, 0x855, 0x856, 0x857, 0x858, 0x859, 0x85a, 0x85b, 0x85c, 0x85d, 0x85e, 0x85f, 0x860, 0x861, 0x862, 0x863, 0x864, 0x865, 0x866, 0x867, 0x868, 0x869, 0x86a, 0x86b, 0x86c, 0x86d, 0x86e, 0x86f, 0x870, 0x871, 0x872, 0x873, 0x874, 0x875, 0x876, 0x877, 0x878, 0x879, 0x87a, 0x87b, 0x87c, 0x87d, 0x87e, 0x87f, 0x880, 0x881, 0x882, 0x883, 0x884, 0x885, 0x886, 0x887, 0x888, 0x889, 0x88a, 0x88b, 0x88c, 0x88d, 0x88e, 0x88f, 0x890, 0x891, 0x892, 0x893, 0x894, 0x895, 0x896, 0x897, 0x898, 0x899, 0x89a, 0x89b, 0x89c, 0x89d, 0x89e, 0x89f, 0x8a0, 0x8a1, 0x8a2, 0x8a3, 0x8a4, 0x8a5, 0x8a6, 0x8a7, 0x8a8, 0x8a9, 0x8aa, 0x8ab, 0x8ac, 0x8ad, 0x8ae, 0x8af, 0x8b0, 0x8b1, 0x8b2, 0x8b3, 0x8b4, 0x8b5, 0x8b6, 0x8b7, 0x8b8, 0x8b9, 0x8ba, 0x8bb, 0x8bc, 0x8bd, 0x8be, 0x8bf, 0x8c0, 0x8c1, 0x8c2, 0x8c3, 0x8c4, 0x8c5, 0x8c6, 0x8c7, 0x8c8, 0x8c9, 0x8ca, 0x8cb, 0x8cc, 0x8cd, 0x8ce, 0x8cf, 0x8d0, 0x8d1, 0x8d2, 0x8d3, 0x8d4, 0x8d5, 0x8d6, 0x8d7, 0x8d8, 0x8d9, 0x8da, 0x8db, 0x8dc, 0x8dd, 0x8de, 0x8df, 0x8e0, 0x8e1, 0x8e2, 0x8e3, 0x8e4, 0x8e5, 0x8e6, 0x8e7, 0x8e8, 0x8e9, 0x8ea, 0x8eb, 0x8ec, 0x8ed, 0x8ee, 0x8ef, 0x8f0, 0x8f1, 0x8f2, 0x8f3, 0x8f4, 0x8f5, 0x8f6, 0x8f7, 0x8f8, 0x8f9, 0x8fa, 0x8fb, 0x8fc, 0x8fd, 0x8fe, 0x8ff, 0x900, 0x901, 0x902, 0x903, 0x904, 0x905, 0x906, 0x907, 0x908, 0x909, 0x90a, 0x90b, 0x90c, 0x90d, 0x90e, 0x90f, 0x910, 0x911, 0x912, 0x913, 0x914, 0x915, 0x916, 0x917, 0x918, 0x919, 0x91a, 0x91b, 0x91c, 0x91d, 0x91e, 0x91f, 0x920, 0x921, 0x922, 0x923, 0x924, 0x925, 0x926, 0x927, 0x928, 0x929, 0x92a, 0x92b, 0x92c, 0x92d, 0x92e, 0x92f, 0x930, 0x931, 0x932, 0x933, 0x934, 0x935, 0x936, 0x937, 0x938, 0x939, 0x93a, 0x93b, 0x93c, 0x93d, 0x93e, 0x93f, 0x940, 0x941, 0x942, 0x943, 0x944, 0x945, 0x946, 0x947, 0x948, 0x949, 0x94a, 0x94b, 0x94c, 0x94d, 0x94e, 0x94f, 0x950, 0x951, 0x952, 0x953, 0x954, 0x955, 0x956, 0x957, 0x958, 0x959, 0x95a, 0x95b, 0x95c, 0x95d, 0x95e, 0x95f, 0x960, 0x961, 0x962, 0x963, 0x964, 0x965, 0x966, 0x967, 0x968, 0x969, 0x96a, 0x96b, 0x96c, 0x96d, 0x96e, 0x96f, 0x970, 0x971, 0x972, 0x973, 0x974, 0x975, 0x976, 0x977, 0x978, 0x979, 0x97a, 0x97b, 0x97c, 0x97d, 0x97e, 0x97f, 0x980, 0x981, 0x982, 0x983, 0x984, 0x985, 0x986, 0x987, 0x988, 0x989, 0x98a, 0x98b, 0x98c, 0x98d, 0x98e, 0x98f, 0x990, 0x991, 0x992, 0x993, 0x994, 0x995, 0x996, 0x997, 0x998, 0x999, 0x99a, 0x99b, 0x99c, 0x99d, 0x99e, 0x99f, 0x9a0, 0x9a1, 0x9a2, 0x9a3, 0x9a4, 0x9a5, 0x9a6, 0x9a7, 0x9a8, 0x9a9, 0x9aa, 0x9ab, 0x9ac, 0x9ad, 0x9ae, 0x9af, 0x9b0, 0x9b1, 0x9b2, 0x9b3, 0x9b4, 0x9b5, 0x9b6, 0x9b7, 0x9b8, 0x9b9, 0x9ba, 0x9bb, 0x9bc, 0x9bd, 0x9be, 0x9bf, 0x9c0, 0x9c1, 0x9c2, 0x9c3, 0x9c4, 0x9c5, 0x9c6, 0x9c7, 0x9c8, 0x9c9, 0x9ca, 0x9cb, 0x9cc, 0x9cd, 0x9ce, 0x9cf, 0x9d0, 0x9d1, 0x9d2, 0x9d3, 0x9d4, 0x9d5, 0x9d6, 0x9d7, 0x9d8, 0x9d9, 0x9da, 0x9db, 0x9dc, 0x9dd, 0x9de, 0x9df, 0x9e0, 0x9e1, 0x9e2, 0x9e3, 0x9e4, 0x9e5, 0x9e6, 0x9e7, 0x9e8, 0x9e9, 0x9ea, 0x9eb, 0x9ec, 0x9ed, 0x9ee, 0x9ef, 0x9f0, 0x9f1, 0x9f2, 0x9f3, 0x9f4, 0x9f5, 0x9f6, 0x9f7, 0x9f8, 0x9f9, 0x9fa, 0x9fb, 0x9fc, 0x9fd, 0x9fe, 0x9ff, 0xa00, 0xa01, 0xa02, 0xa03, 0xa04, 0xa05, 0xa06, 0xa07, 0xa08, 0xa09, 0xa0a, 0xa0b, 0xa0c, 0xa0d, 0xa0e, 0xa0f, 0xa10, 0xa11, 0xa12, 0xa13, 0xa14, 0xa15, 0xa16, 0xa17, 0xa18, 0xa19, 0xa1a, 0xa1b, 0xa1c, 0xa1d, 0xa1e, 0xa1f, 0xa20, 0xa21, 0xa22, 0xa23, 0xa24, 0xa25, 0xa26, 0xa27, 0xa28, 0xa29, 0xa2a, 0xa2b, 0xa2c, 0xa2d, 0xa2e, 0xa2f, 0xa30, 0xa31, 0xa32, 0xa33, 0xa34, 0xa35, 0xa36, 0xa37, 0xa38, 0xa39, 0xa3a, 0xa3b, 0xa3c, 0xa3d, 0xa3e, 0xa3f, 0xa40, 0xa41, 0xa42, 0xa43, 0xa44, 0xa45, 0xa46, 0xa47, 0xa48, 0xa49, 0xa4a, 0xa4b, 0xa4c, 0xa4d, 0xa4e, 0xa4f, 0xa50, 0xa51, 0xa52, 0xa53, 0xa54, 0xa55, 0xa56, 0xa57, 0xa58, 0xa59, 0xa5a, 0xa5b, 0xa5c, 0xa5d, 0xa5e, 0xa5f, 0xa60, 0xa61, 0xa62, 0xa63, 0xa64, 0xa65, 0xa66, 0xa67, 0xa68, 0xa69, 0xa6a, 0xa6b, 0xa6c, 0xa6d, 0xa6e, 0xa6f, 0xa70, 0xa71, 0xa72, 0xa73, 0xa74, 0xa75, 0xa76, 0xa77, 0xa78, 0xa79, 0xa7a, 0xa7b, 0xa7c, 0xa7d, 0xa7e, 0xa7f, 0xa80, 0xa81, 0xa82, 0xa83, 0xa84, 0xa85, 0xa86, 0xa87, 0xa88, 0xa89, 0xa8a, 0xa8b, 0xa8c, 0xa8d, 0xa8e, 0xa8f, 0xa90, 0xa91, 0xa92, 0xa93, 0xa94, 0xa95, 0xa96, 0xa97, 0xa98, 0xa99, 0xa9a, 0xa9b, 0xa9c, 0xa9d, 0xa9e, 0xa9f, 0xaa0, 0xaa1, 0xaa2, 0xaa3, 0xaa4, 0xaa5, 0xaa6, 0xaa7, 0xaa8, 0xaa9, 0xaaa, 0xaab, 0xaac, 0xaad, 0xaae, 0xaaf, 0xab0, 0xab1, 0xab2, 0xab3, 0xab4, 0xab5, 0xab6, 0xab7, 0xab8, 0xab9, 0xaba, 0xabb, 0xabc, 0xabd, 0xabe, 0xabf, 0xac0, 0xac1, 0xac2, 0xac3, 0xac4, 0xac5, 0xac6, 0xac7, 0xac8, 0xac9, 0xaca, 0xacb, 0xacc, 0xacd, 0xace, 0xacf, 0xad0, 0xad1, 0xad2, 0xad3, 0xad4, 0xad5, 0xad6, 0xad7, 0xad8, 0xad9, 0xada, 0xadb, 0xadc, 0xadd, 0xade, 0xadf, 0xae0, 0xae1, 0xae2, 0xae3, 0xae4, 0xae5, 0xae6, 0xae7, 0xae8, 0xae9, 0xaea, 0xaeb, 0xaec, 0xaed, 0xaee, 0xaef, 0xaf0, 0xaf1, 0xaf2, 0xaf3, 0xaf4, 0xaf5, 0xaf6, 0xaf7, 0xaf8, 0xaf9, 0xafa, 0xafb, 0xafc, 0xafd, 0xafe, 0xaff, 0xb00, 0xb01, 0xb02, 0xb03, 0xb04, 0xb05, 0xb06, 0xb07, 0xb08, 0xb09, 0xb0a, 0xb0b, 0xb0c, 0xb0d, 0xb0e, 0xb0f, 0xb10, 0xb11, 0xb12, 0xb13, 0xb14, 0xb15, 0xb16, 0xb17, 0xb18, 0xb19, 0xb1a, 0xb1b, 0xb1c, 0xb1d, 0xb1e, 0xb1f, 0xb20, 0xb21, 0xb22, 0xb23, 0xb24, 0xb25, 0xb26, 0xb27, 0xb28, 0xb29, 0xb2a, 0xb2b, 0xb2c, 0xb2d, 0xb2e, 0xb2f, 0xb30, 0xb31, 0xb32, 0xb33, 0xb34, 0xb35, 0xb36, 0xb37, 0xb38, 0xb39, 0xb3a, 0xb3b, 0xb3c, 0xb3d, 0xb3e, 0xb3f, 0xb40, 0xb41, 0xb42, 0xb43, 0xb44, 0xb45, 0xb46, 0xb47, 0xb48, 0xb49, 0xb4a, 0xb4b, 0xb4c, 0xb4d, 0xb4e, 0xb4f, 0xb50, 0xb51, 0xb52, 0xb53, 0xb54, 0xb55, 0xb56, 0xb57, 0xb58, 0xb59, 0xb5a, 0xb5b, 0xb5c, 0xb5d, 0xb5e, 0xb5f, 0xb60, 0xb61, 0xb62, 0xb63, 0xb64, 0xb65, 0xb66, 0xb67, 0xb68, 0xb69, 0xb6a, 0xb6b, 0xb6c, 0xb6d, 0xb6e, 0xb6f, 0xb70, 0xb71, 0xb72, 0xb73, 0xb74, 0xb75, 0xb76, 0xb77, 0xb78, 0xb79, 0xb7a, 0xb7b, 0xb7c, 0xb7d, 0xb7e, 0xb7f, 0xb80, 0xb81, 0xb82, 0xb83, 0xb84, 0xb85, 0xb86, 0xb87, 0xb88, 0xb89, 0xb8a, 0xb8b, 0xb8c, 0xb8d, 0xb8e, 0xb8f, 0xb90, 0xb91, 0xb92, 0xb93, 0xb94, 0xb95, 0xb96, 0xb97, 0xb98, 0xb99, 0xb9a, 0xb9b, 0xb9c, 0xb9d, 0xb9e, 0xb9f, 0xba0, 0xba1, 0xba2, 0xba3, 0xba4, 0xba5, 0xba6, 0xba7, 0xba8, 0xba9, 0xbaa, 0xbab, 0xbac, 0xbad, 0xbae, 0xbaf, 0xbb0, 0xbb1, 0xbb2, 0xbb3, 0xbb4, 0xbb5, 0xbb6, 0xbb7, 0xbb8, 0xbb9, 0xbba, 0xbbb, 0xbbc, 0xbbd, 0xbbe, 0xbbf, 0xbc0, 0xbc1, 0xbc2, 0xbc3, 0xbc4, 0xbc5, 0xbc6, 0xbc7, 0xbc8, 0xbc9, 0xbca, 0xbcb, 0xbcc, 0xbcd, 0xbce, 0xbcf, 0xbd0, 0xbd1, 0xbd2, 0xbd3, 0xbd4, 0xbd5, 0xbd6, 0xbd7, 0xbd8, 0xbd9, 0xbda, 0xbdb, 0xbdc, 0xbdd, 0xbde, 0xbdf, 0xbe0, 0xbe1, 0xbe2, 0xbe3, 0xbe4, 0xbe5, 0xbe6, 0xbe7, 0xbe8, 0xbe9, 0xbea, 0xbeb, 0xbec, 0xbed, 0xbee, 0xbef, 0xbf0, 0xbf1, 0xbf2, 0xbf3, 0xbf4, 0xbf5, 0xbf6, 0xbf7, 0xbf8, 0xbf9, 0xbfa, 0xbfb, 0xbfc, 0xbfd, 0xbfe, 0xbff, 0xc00, 0xc01, 0xc02, 0xc03, 0xc04, 0xc05, 0xc06, 0xc07, 0xc08, 0xc09, 0xc0a, 0xc0b, 0xc0c, 0xc0d, 0xc0e, 0xc0f, 0xc10, 0xc11, 0xc12, 0xc13, 0xc14, 0xc15, 0xc16, 0xc17, 0xc18, 0xc19, 0xc1a, 0xc1b, 0xc1c, 0xc1d, 0xc1e, 0xc1f, 0xc20, 0xc21, 0xc22, 0xc23, 0xc24, 0xc25, 0xc26, 0xc27, 0xc28, 0xc29, 0xc2a, 0xc2b, 0xc2c, 0xc2d, 0xc2e, 0xc2f, 0xc30, 0xc31, 0xc32, 0xc33, 0xc34, 0xc35, 0xc36, 0xc37, 0xc38, 0xc39, 0xc3a, 0xc3b, 0xc3c, 0xc3d, 0xc3e, 0xc3f, 0xc40, 0xc41, 0xc42, 0xc43, 0xc44, 0xc45, 0xc46, 0xc47, 0xc48, 0xc49, 0xc4a, 0xc4b, 0xc4c, 0xc4d, 0xc4e, 0xc4f, 0xc50, 0xc51, 0xc52, 0xc53, 0xc54, 0xc55, 0xc56, 0xc57, 0xc58, 0xc59, 0xc5a, 0xc5b, 0xc5c, 0xc5d, 0xc5e, 0xc5f, 0xc60, 0xc61, 0xc62, 0xc63, 0xc64, 0xc65, 0xc66, 0xc67, 0xc68, 0xc69, 0xc6a, 0xc6b, 0xc6c, 0xc6d, 0xc6e, 0xc6f, 0xc70, 0xc71, 0xc72, 0xc73, 0xc74, 0xc75, 0xc76, 0xc77, 0xc78, 0xc79, 0xc7a, 0xc7b, 0xc7c, 0xc7d, 0xc7e, 0xc7f, 0xc80, 0xc81, 0xc82, 0xc83, 0xc84, 0xc85, 0xc86, 0xc87, 0xc88, 0xc89, 0xc8a, 0xc8b, 0xc8c, 0xc8d, 0xc8e, 0xc8f, 0xc90, 0xc91, 0xc92, 0xc93, 0xc94, 0xc95, 0xc96, 0xc97, 0xc98, 0xc99, 0xc9a, 0xc9b, 0xc9c, 0xc9d, 0xc9e, 0xc9f, 0xca0, 0xca1, 0xca2, 0xca3, 0xca4, 0xca5, 0xca6, 0xca7, 0xca8, 0xca9, 0xcaa, 0xcab, 0xcac, 0xcad, 0xcae, 0xcaf, 0xcb0, 0xcb1, 0xcb2, 0xcb3, 0xcb4, 0xcb5, 0xcb6, 0xcb7, 0xcb8, 0xcb9, 0xcba, 0xcbb, 0xcbc, 0xcbd, 0xcbe, 0xcbf, 0xcc0, 0xcc1, 0xcc2, 0xcc3, 0xcc4, 0xcc5, 0xcc6, 0xcc7, 0xcc8, 0xcc9, 0xcca, 0xccb, 0xccc, 0xccd, 0xcce, 0xccf, 0xcd0, 0xcd1, 0xcd2, 0xcd3, 0xcd4, 0xcd5, 0xcd6, 0xcd7, 0xcd8, 0xcd9, 0xcda, 0xcdb, 0xcdc, 0xcdd, 0xcde, 0xcdf, 0xce0, 0xce1, 0xce2, 0xce3, 0xce4, 0xce5, 0xce6, 0xce7, 0xce8, 0xce9, 0xcea, 0xceb, 0xcec, 0xced, 0xcee, 0xcef, 0xcf0, 0xcf1, 0xcf2, 0xcf3, 0xcf4, 0xcf5, 0xcf6, 0xcf7, 0xcf8, 0xcf9, 0xcfa, 0xcfb, 0xcfc, 0xcfd, 0xcfe, 0xcff, 0xd00, 0xd01, 0xd02, 0xd03, 0xd04, 0xd05, 0xd06, 0xd07, 0xd08, 0xd09, 0xd0a, 0xd0b, 0xd0c, 0xd0d, 0xd0e, 0xd0f, 0xd10, 0xd11, 0xd12, 0xd13, 0xd14, 0xd15, 0xd16, 0xd17, 0xd18, 0xd19, 0xd1a, 0xd1b, 0xd1c, 0xd1d, 0xd1e, 0xd1f, 0xd20, 0xd21, 0xd22, 0xd23, 0xd24, 0xd25, 0xd26, 0xd27, 0xd28, 0xd29, 0xd2a, 0xd2b, 0xd2c, 0xd2d, 0xd2e, 0xd2f, 0xd30, 0xd31, 0xd32, 0xd33, 0xd34, 0xd35, 0xd36, 0xd37, 0xd38, 0xd39, 0xd3a, 0xd3b, 0xd3c, 0xd3d, 0xd3e, 0xd3f, 0xd40, 0xd41, 0xd42, 0xd43, 0xd44, 0xd45, 0xd46, 0xd47, 0xd48, 0xd49, 0xd4a, 0xd4b, 0xd4c, 0xd4d, 0xd4e, 0xd4f, 0xd50, 0xd51, 0xd52, 0xd53, 0xd54, 0xd55, 0xd56, 0xd57, 0xd58, 0xd59, 0xd5a, 0xd5b, 0xd5c, 0xd5d, 0xd5e, 0xd5f, 0xd60, 0xd61, 0xd62, 0xd63, 0xd64, 0xd65, 0xd66, 0xd67, 0xd68, 0xd69, 0xd6a, 0xd6b, 0xd6c, 0xd6d, 0xd6e, 0xd6f, 0xd70, 0xd71, 0xd72, 0xd73, 0xd74, 0xd75, 0xd76, 0xd77, 0xd78, 0xd79, 0xd7a, 0xd7b, 0xd7c, 0xd7d, 0xd7e, 0xd7f, 0xd80, 0xd81, 0xd82, 0xd83, 0xd84, 0xd85, 0xd86, 0xd87, 0xd88, 0xd89, 0xd8a, 0xd8b, 0xd8c, 0xd8d, 0xd8e, 0xd8f, 0xd90, 0xd91, 0xd92, 0xd93, 0xd94, 0xd95, 0xd96, 0xd97, 0xd98, 0xd99, 0xd9a, 0xd9b, 0xd9c, 0xd9d, 0xd9e, 0xd9f, 0xda0, 0xda1, 0xda2, 0xda3, 0xda4, 0xda5, 0xda6, 0xda7, 0xda8, 0xda9, 0xdaa, 0xdab, 0xdac, 0xdad, 0xdae, 0xdaf, 0xdb0, 0xdb1, 0xdb2, 0xdb3, 0xdb4, 0xdb5, 0xdb6, 0xdb7, 0xdb8, 0xdb9, 0xdba, 0xdbb, 0xdbc, 0xdbd, 0xdbe, 0xdbf, 0xdc0, 0xdc1, 0xdc2, 0xdc3, 0xdc4, 0xdc5, 0xdc6, 0xdc7, 0xdc8, 0xdc9, 0xdca, 0xdcb, 0xdcc, 0xdcd, 0xdce, 0xdcf, 0xdd0, 0xdd1, 0xdd2, 0xdd3, 0xdd4, 0xdd5, 0xdd6, 0xdd7, 0xdd8, 0xdd9, 0xdda, 0xddb, 0xddc, 0xddd, 0xdde, 0xddf, 0xde0, 0xde1, 0xde2, 0xde3, 0xde4, 0xde5, 0xde6, 0xde7, 0xde8, 0xde9, 0xdea, 0xdeb, 0xdec, 0xded, 0xdee, 0xdef, 0xdf0, 0xdf1, 0xdf2, 0xdf3, 0xdf4, 0xdf5, 0xdf6, 0xdf7, 0xdf8, 0xdf9, 0xdfa, 0xdfb, 0xdfc, 0xdfd, 0xdfe, 0xdff, 0xe00, 0xe01, 0xe02, 0xe03, 0xe04, 0xe05, 0xe06, 0xe07, 0xe08, 0xe09, 0xe0a, 0xe0b, 0xe0c, 0xe0d, 0xe0e, 0xe0f, 0xe10, 0xe11, 0xe12, 0xe13, 0xe14, 0xe15, 0xe16, 0xe17, 0xe18, 0xe19, 0xe1a, 0xe1b, 0xe1c, 0xe1d, 0xe1e, 0xe1f, 0xe20, 0xe21, 0xe22, 0xe23, 0xe24, 0xe25, 0xe26, 0xe27, 0xe28, 0xe29, 0xe2a, 0xe2b, 0xe2c, 0xe2d, 0xe2e, 0xe2f, 0xe30, 0xe31, 0xe32, 0xe33, 0xe34, 0xe35, 0xe36, 0xe37, 0xe38, 0xe39, 0xe3a, 0xe3b, 0xe3c, 0xe3d, 0xe3e, 0xe3f, 0xe40, 0xe41, 0xe42, 0xe43, 0xe44, 0xe45, 0xe46, 0xe47, 0xe48, 0xe49, 0xe4a, 0xe4b, 0xe4c, 0xe4d, 0xe4e, 0xe4f, 0xe50, 0xe51, 0xe52, 0xe53, 0xe54, 0xe55, 0xe56, 0xe57, 0xe58, 0xe59, 0xe5a, 0xe5b, 0xe5c, 0xe5d, 0xe5e, 0xe5f, 0xe60, 0xe61, 0xe62, 0xe63, 0xe64, 0xe65, 0xe66, 0xe67, 0xe68, 0xe69, 0xe6a, 0xe6b, 0xe6c, 0xe6d, 0xe6e, 0xe6f, 0xe70, 0xe71, 0xe72, 0xe73, 0xe74, 0xe75, 0xe76, 0xe77, 0xe78, 0xe79, 0xe7a, 0xe7b, 0xe7c, 0xe7d, 0xe7e, 0xe7f, 0xe80, 0xe81, 0xe82, 0xe83, 0xe84, 0xe85, 0xe86, 0xe87, 0xe88, 0xe89, 0xe8a, 0xe8b, 0xe8c, 0xe8d, 0xe8e, 0xe8f, 0xe90, 0xe91, 0xe92, 0xe93, 0xe94, 0xe95, 0xe96, 0xe97, 0xe98, 0xe99, 0xe9a, 0xe9b, 0xe9c, 0xe9d, 0xe9e, 0xe9f, 0xea0, 0xea1, 0xea2, 0xea3, 0xea4, 0xea5, 0xea6, 0xea7, 0xea8, 0xea9, 0xeaa, 0xeab, 0xeac, 0xead, 0xeae, 0xeaf, 0xeb0, 0xeb1, 0xeb2, 0xeb3, 0xeb4, 0xeb5, 0xeb6, 0xeb7, 0xeb8, 0xeb9, 0xeba, 0xebb, 0xebc, 0xebd, 0xebe, 0xebf, 0xec0, 0xec1, 0xec2, 0xec3, 0xec4, 0xec5, 0xec6, 0xec7, 0xec8, 0xec9, 0xeca, 0xecb, 0xecc, 0xecd, 0xece, 0xecf, 0xed0, 0xed1, 0xed2, 0xed3, 0xed4, 0xed5, 0xed6, 0xed7, 0xed8, 0xed9, 0xeda, 0xedb, 0xedc, 0xedd, 0xede, 0xedf, 0xee0, 0xee1, 0xee2, 0xee3, 0xee4, 0xee5, 0xee6, 0xee7, 0xee8, 0xee9, 0xeea, 0xeeb, 0xeec, 0xeed, 0xeee, 0xeef, 0xef0, 0xef1, 0xef2, 0xef3, 0xef4, 0xef5, 0xef6, 0xef7, 0xef8, 0xef9, 0xefa, 0xefb, 0xefc, 0xefd, 0xefe, 0xeff, 0xf00, 0xf01, 0xf02, 0xf03, 0xf04, 0xf05, 0xf06, 0xf07, 0xf08, 0xf09, 0xf0a, 0xf0b, 0xf0c, 0xf0d, 0xf0e, 0xf0f, 0xf10, 0xf11, 0xf12, 0xf13, 0xf14, 0xf15, 0xf16, 0xf17, 0xf18, 0xf19, 0xf1a, 0xf1b, 0xf1c, 0xf1d, 0xf1e, 0xf1f, 0xf20, 0xf21, 0xf22, 0xf23, 0xf24, 0xf25, 0xf26, 0xf27, 0xf28, 0xf29, 0xf2a, 0xf2b, 0xf2c, 0xf2d, 0xf2e, 0xf2f, 0xf30, 0xf31, 0xf32, 0xf33, 0xf34, 0xf35, 0xf36, 0xf37, 0xf38, 0xf39, 0xf3a, 0xf3b, 0xf3c, 0xf3d, 0xf3e, 0xf3f, 0xf40, 0xf41, 0xf42, 0xf43, 0xf44, 0xf45, 0xf46, 0xf47, 0xf48, 0xf49, 0xf4a, 0xf4b, 0xf4c, 0xf4d, 0xf4e, 0xf4f, 0xf50, 0xf51, 0xf52, 0xf53, 0xf54, 0xf55, 0xf56, 0xf57, 0xf58, 0xf59, 0xf5a, 0xf5b, 0xf5c, 0xf5d, 0xf5e, 0xf5f, 0xf60, 0xf61, 0xf62, 0xf63, 0xf64, 0xf65, 0xf66, 0xf67, 0xf68, 0xf69, 0xf6a, 0xf6b, 0xf6c, 0xf6d, 0xf6e, 0xf6f, 0xf70, 0xf71, 0xf72, 0xf73, 0xf74, 0xf75, 0xf76, 0xf77, 0xf78, 0xf79, 0xf7a, 0xf7b, 0xf7c, 0xf7d, 0xf7e, 0xf7f, 0xf80, 0xf81, 0xf82, 0xf83, 0xf84, 0xf85, 0xf86, 0xf87, 0xf88, 0xf89, 0xf8a, 0xf8b, 0xf8c, 0xf8d, 0xf8e, 0xf8f, 0xf90, 0xf91, 0xf92, 0xf93, 0xf94, 0xf95, 0xf96, 0xf97, 0xf98, 0xf99, 0xf9a, 0xf9b, 0xf9c, 0xf9d, 0xf9e, 0xf9f, 0xfa0, 0xfa1, 0xfa2, 0xfa3, 0xfa4, 0xfa5, 0xfa6, 0xfa7, 0xfa8, 0xfa9, 0xfaa, 0xfab, 0xfac, 0xfad, 0xfae, 0xfaf, 0xfb0, 0xfb1, 0xfb2, 0xfb3, 0xfb4, 0xfb5, 0xfb6, 0xfb7, 0xfb8, 0xfb9, 0xfba, 0xfbb, 0xfbc, 0xfbd, 0xfbe, 0xfbf, 0xfc0, 0xfc1, 0xfc2, 0xfc3, 0xfc4, 0xfc5, 0xfc6, 0xfc7, 0xfc8, 0xfc9, 0xfca, 0xfcb, 0xfcc, 0xfcd, 0xfce, 0xfcf, 0xfd0, 0xfd1, 0xfd2, 0xfd3, 0xfd4, 0xfd5, 0xfd6, 0xfd7, 0xfd8, 0xfd9, 0xfda, 0xfdb, 0xfdc, 0xfdd, 0xfde, 0xfdf, 0xfe0, 0xfe1, 0xfe2, 0xfe3, 0xfe4, 0xfe5, 0xfe6, 0xfe7, 0xfe8, 0xfe9, 0xfea, 0xfeb, 0xfec, 0xfed, 0xfee, 0xfef, 0xff0, 0xff1, 0xff2, 0xff3, 0xff4, 0xff5, 0xff6, 0xff7, 0xff8, 0xff9, 0xffa, 0xffb, 0xffc, 0xffd, 0xffe, 0xfff] cryptol-2.8.0/bench/data/PreludeWithExtras.cry 0000755 0000000 0000000 00000031412 07346545000 017544 0 ustar 00 0000000 0000000 /*
* Copyright (c) 2013-2016 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/
module Cryptol where
/**
* The value corresponding to a numeric type.
*/
primitive number : {val, bits} (fin val, fin bits, bits >= width val) => [bits]
infixr 10 ||
infixr 20 &&
infix 30 ==, ===, !=, !==
infix 40 >, >=, <, <=
infixl 50 ^
infixr 60 #
infixl 70 <<, <<<, >>, >>>
infixl 80 +, -
infixl 90 *, /, %
infixr 95 ^^
infixl 100 @, @@, !, !!
/**
* Add two values.
* * For words, addition uses modulo arithmetic.
* * Structured values are added element-wise.
*/
primitive (+) : {a} (Arith a) => a -> a -> a
/**
* For words, subtraction uses modulo arithmetic.
* Structured values are subtracted element-wise. Defined as:
* a - b = a + negate b
* See also: `negate'.
*/
primitive (-) : {a} (Arith a) => a -> a -> a
/**
* For words, multiplies two words, modulus 2^^a.
* Structured values are multiplied element-wise.
*/
primitive (*) : {a} (Arith a) => a -> a -> a
/**
* For words, divides two words, modulus 2^^a.
* Structured values are divided element-wise.
*/
primitive (/) : {a} (Arith a) => a -> a -> a
/**
* For words, takes the modulus of two words, modulus 2^^a.
* Over structured values, operates element-wise.
* Be careful, as this will often give unexpected results due to interaction of
* the two moduli.
*/
primitive (%) : {a} (Arith a) => a -> a -> a
/**
* For words, takes the exponent of two words, modulus 2^^a.
* Over structured values, operates element-wise.
* Be careful, due to its fast-growing nature, exponentiation is prone to
* interacting poorly with defaulting.
*/
primitive (^^) : {a} (Arith a) => a -> a -> a
/**
* Log base two.
*
* For words, computes the ceiling of log, base 2, of a number.
* Over structured values, operates element-wise.
*/
primitive lg2 : {a} (Arith a) => a -> a
type Bool = Bit
/**
* The constant True. Corresponds to the bit value 1.
*/
primitive True : Bit
/**
* The constant False. Corresponds to the bit value 0.
*/
primitive False : Bit
/**
* Returns the twos complement of its argument.
* Over structured values, operates element-wise.
* negate a = ~a + 1
*/
primitive negate : {a} (Arith a) => a -> a
/**
* Binary complement.
*/
primitive complement : {a} a -> a
/**
* Operator form of binary complement.
*/
(~) : {a} a -> a
(~) = complement
/**
* Less-than. Only works on comparable arguments.
*/
primitive (<) : {a} (Cmp a) => a -> a -> Bit
/**
* Greater-than of two comparable arguments.
*/
primitive (>) : {a} (Cmp a) => a -> a -> Bit
/**
* Less-than or equal of two comparable arguments.
*/
primitive (<=) : {a} (Cmp a) => a -> a -> Bit
/**
* Greater-than or equal of two comparable arguments.
*/
primitive (>=) : {a} (Cmp a) => a -> a -> Bit
/**
* Compares any two values of the same type for equality.
*/
primitive (==) : {a} (Cmp a) => a -> a -> Bit
/**
* Compares any two values of the same type for inequality.
*/
primitive (!=) : {a} (Cmp a) => a -> a -> Bit
/**
* Compare the outputs of two functions for equality
*/
(===) : {a,b} (Cmp b) => (a -> b) -> (a -> b) -> (a -> Bit)
f === g = \ x -> f x == g x
/**
* Compare the outputs of two functions for inequality
*/
(!==) : {a,b} (Cmp b) => (a -> b) -> (a -> b) -> (a -> Bit)
f !== g = \x -> f x != g x
/**
* Returns the smaller of two comparable arguments.
*/
min : {a} (Cmp a) => a -> a -> a
min x y = if x < y then x else y
/**
* Returns the greater of two comparable arguments.
*/
max : {a} (Cmp a) => a -> a -> a
max x y = if x > y then x else y
/**
* Logical `and' over bits. Extends element-wise over sequences, tuples.
*/
primitive (&&) : {a} a -> a -> a
/**
* Logical `or' over bits. Extends element-wise over sequences, tuples.
*/
primitive (||) : {a} a -> a -> a
/**
* Logical `exclusive or' over bits. Extends element-wise over sequences, tuples.
*/
primitive (^) : {a} a -> a -> a
/**
* Gives an arbitrary shaped value whose bits are all False.
* ~zero likewise gives an arbitrary shaped value whose bits are all True.
*/
primitive zero : {a} a
/**
* Left shift. The first argument is the sequence to shift, the second is the
* number of positions to shift by.
*/
primitive (<<) : {a, b, c} (fin b) => [a]c -> [b] -> [a]c
/**
* Right shift. The first argument is the sequence to shift, the second is the
* number of positions to shift by.
*/
primitive (>>) : {a, b, c} (fin b) => [a]c -> [b] -> [a]c
/**
* Left rotate. The first argument is the sequence to rotate, the second is the
* number of positions to rotate by.
*/
primitive (<<<) : {a, b, c} (fin a, fin b) => [a]c -> [b] -> [a]c
/**
* Right rotate. The first argument is the sequence to rotate, the second is
* the number of positions to rotate by.
*/
primitive (>>>) : {a, b, c} (fin a, fin b) => [a]c -> [b] -> [a]c
primitive (#) : {front, back, a} (fin front) => [front]a -> [back]a
-> [front + back] a
/**
* Split a sequence into a tuple of sequences.
*/
primitive splitAt : {front, back, a} (fin front) => [front + back]a
-> ([front]a, [back]a)
/**
* Joins sequences.
*/
primitive join : {parts, each, a} (fin each) => [parts][each]a
-> [parts * each]a
/**
* Splits a sequence into 'parts' groups with 'each' elements.
*/
primitive split : {parts, each, a} (fin each) => [parts * each]a
-> [parts][each]a
/**
* Reverses the elements in a sequence.
*/
primitive reverse : {a, b} (fin a) => [a]b -> [a]b
/**
* Transposes an [a][b] matrix into a [b][a] matrix.
*/
primitive transpose : {a, b, c} [a][b]c -> [b][a]c
/**
* Index operator. The first argument is a sequence. The second argument is
* the zero-based index of the element to select from the sequence.
*/
primitive (@) : {a, b, c} (fin c) => [a]b -> [c] -> b
/**
* Bulk index operator. The first argument is a sequence. The second argument
* is a sequence of the zero-based indices of the elements to select.
*/
primitive (@@) : {a, b, c, d} (fin d) => [a]b -> [c][d] -> [c]b
/**
* Reverse index operator. The first argument is a finite sequence. The second
* argument is the zero-based index of the element to select, starting from the
* end of the sequence.
*/
primitive (!) : {a, b, c} (fin a, fin c) => [a]b -> [c] -> b
/**
* Bulk reverse index operator. The first argument is a finite sequence. The
* second argument is a sequence of the zero-based indices of the elements to
z select, starting from the end of the sequence.
*/
primitive (!!) : {a, b, c, d} (fin a, fin d) => [a]b -> [c][d] -> [c]b
primitive fromTo : {first, last, bits} (fin last, fin bits, last >= first,
bits >= width last) => [1 + (last - first)][bits]
primitive fromThenTo : {first, next, last, bits, len} (fin first, fin next,
fin last, fin bits, bits >= width first,
bits >= width next, bits >= width last,
lengthFromThenTo first next last == len) => [len][bits]
primitive infFrom : {bits} (fin bits) => [bits] -> [inf][bits]
primitive infFromThen : {bits} (fin bits) => [bits] -> [bits] -> [inf][bits]
primitive error : {at, len} (fin len) => [len][8] -> at
/**
* Performs multiplication of polynomials over GF(2).
*/
primitive pmult : {a, b} (fin a, fin b) => [a] -> [b] -> [max 1 (a + b) - 1]
/**
* Performs division of polynomials over GF(2).
*/
primitive pdiv : {a, b} (fin a, fin b) => [a] -> [b] -> [a]
/**
* Performs modulus of polynomials over GF(2).
*/
primitive pmod : {a, b} (fin a, fin b) => [a] -> [1 + b] -> [b]
/**
* Generates random values from a seed. When called with a function, currently
* generates a function that always returns zero.
*/
primitive random : {a} [256] -> a
type String n = [n][8]
type Word n = [n]
type Char = [8]
take : {front,back,elem} (fin front) => [front + back] elem -> [front] elem
take (x # _) = x
drop : {front,back,elem} (fin front) => [front + back] elem -> [back] elem
drop ((_ : [front] _) # y) = y
tail : {a, b} [1 + a]b -> [a]b
tail xs = drop`{1} xs
width : {bits,len,elem} (fin len, fin bits, bits >= width len) => [len] elem -> [bits]
width _ = `len
undefined : {a} a
undefined = error "undefined"
groupBy : {each,parts,elem} (fin each) =>
[parts * each] elem -> [parts][each]elem
groupBy = split`{parts=parts}
/**
* Define the base 2 logarithm function in terms of width
*/
type lg2 n = width (max n 1 - 1)
/**
* Debugging function for tracing. The first argument is a string,
* which is prepended to the printed value of the second argument.
* This combined string is then printed when the trace function is
* evaluated. The return value is equal to the third argument.
*
* The exact timing and number of times the trace message is printed
* depend on the internal details of the Cryptol evaluation order,
* which are unspecified. Thus, the output produced by this
* operation may be difficult to predict.
*/
primitive trace : {n, a, b} [n][8] -> a -> b -> b
/**
* Debugging function for tracing values. The first argument is a string,
* which is prepended to the printed value of the second argument.
* This combined string is then printed when the trace function is
* evaluated. The return value is equal to the second argument.
*
* The exact timing and number of times the trace message is printed
* depend on the internal details of the Cryptol evaluation order,
* which are unspecified. Thus, the output produced by this
* operation may be difficult to predict.
*/
traceVal : {n, a} [n][8] -> a -> a
traceVal msg x = trace msg x x
/*
* Copyright (c) 2016 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*
* This module contains definitions that we wish to eventually promote
* into the Prelude, but which currently cause typechecking of the
* Prelude to take too long (see #299)
*/
infixr 5 ==>
/**
* Logical implication
*/
(==>) : Bit -> Bit -> Bit
a ==> b = if a then b else True
/**
* Logical negation
*/
not : {a} a -> a
not a = ~ a
/**
* Conjunction
*/
and : {n} (fin n) => [n]Bit -> Bit
and xs = ~zero == xs
/**
* Disjunction
*/
or : {n} (fin n) => [n]Bit -> Bit
or xs = zero != xs
/**
* Conjunction after applying a predicate to all elements.
*/
all : {a,n} (fin n) => (a -> Bit) -> [n]a -> Bit
all f xs = and (map f xs)
/**
* Disjunction after applying a predicate to all elements.
*/
any : {a,n} (fin n) => (a -> Bit) -> [n]a -> Bit
any f xs = or (map f xs)
/**
* Map a function over an array.
*/
map : {a, b, n} (a -> b) -> [n]a -> [n]b
map f xs = [f x | x <- xs]
/**
* Functional left fold.
*
* foldl (+) 0 [1,2,3] = ((0 + 1) + 2) + 3
*/
foldl : {a, b, n} (fin n) => (a -> b -> a) -> a -> [n]b -> a
foldl f acc xs = ys ! 0
where ys = [acc] # [f a x | a <- ys | x <- xs]
/**
* Functional right fold.
*
* foldr (-) 0 [1,2,3] = 0 - (1 - (2 - 3))
*/
foldr : {a,b,n} (fin n) => (a -> b -> b) -> b -> [n]a -> b
foldr f acc xs = ys ! 0
where ys = [acc] # [f x a | a <- ys | x <- reverse xs]
/**
* Compute the sum of the words in the array.
*/
sum : {a,n} (fin n, Arith a) => [n]a -> a
sum xs = foldl (+) zero xs
/**
* Scan left is like a fold that emits the intermediate values.
*/
scanl : {b, a, n} (b -> a -> b) -> b -> [n]a -> [n+1]b
scanl f acc xs = ys
where
ys = [acc] # [f a x | a <- ys | x <- xs]
/**
* Scan right
*/
scanr : {a,b,n} (fin n) => (a -> b -> b) -> b -> [n]a -> [n+1]b
scanr f acc xs = reverse ys
where
ys = [acc] # [f x a | a <- ys | x <- reverse xs]
/**
* Zero extension
*/
extend : {total,n} (fin total, fin n, total >= n) => [n]Bit -> [total]Bit
extend n = zero # n
/**
* Signed extension. `extendSigned 0bwxyz : [8] == 0bwwwwwxyz`.
*/
extendSigned : {total,n} (fin total, fin n, n >= 1, total >= n+1) => [n]Bit -> [total]Bit
extendSigned xs = repeat (xs @ 0) # xs
/**
* Repeat a value.
*/
repeat : {n, a} a -> [n]a
repeat x = [ x | _ <- zero ]
/**
* `elem x xs` Returns true if x is equal to a value in xs.
*/
elem : {n,a} (fin n, Cmp a) => a -> [n]a -> Bit
elem a xs = any (\x -> x == a) xs
/**
* Create a list of tuples from two lists.
*/
zip : {a,b,n} [n]a -> [n]b -> [n](a,b)
zip xs ys = [(x,y) | x <- xs | y <- ys]
/**
* Create a list by applying the function to each pair of elements in the input.
* lists
*/
zipWith : {a,b,c,n} (a -> b -> c) -> [n]a -> [n]b -> [n]c
zipWith f xs ys = [f x y | x <- xs | y <- ys]
/**
* Transform a function into uncurried form.
*/
uncurry : {a,b,c} (a -> b -> c) -> (a,b) -> c
uncurry f = \(a,b) -> f a b
/**
* Transform a function into curried form.
*/
curry : {a,b,c} ((a, b) -> c) -> a -> b -> c
curry f = \a b -> f (a,b)
/**
* Map a function iteratively over a seed value, producing an infinite
* list of successive function applications.
*/
iterate : { a } (a -> a) -> a -> [inf]a
iterate f x = [x] # [ f v | v <- iterate f x ]
cryptol-2.8.0/bench/data/SHA512.cry 0000755 0000000 0000000 00000010054 07346545000 014763 0 ustar 00 0000000 0000000 // Provided by @sdwelle as a performance regression in issue #269
module SHA512 where
/*
sha512 : {b, a} (a*1024 == 128 + b + 1 + 1024 - (b+129) % 1024,
a*1024 % 1024 == 0,
a * 1024 - b >= 129,
2^^128 - 1 >= b,
fin (a + 1)) => [b] -> [512]
*/
sha512 M = result
where
M' = (pad M)
blocks = (groupBy`{1024} M')
hash = [H0] # [ processBlock b h | b <- blocks | h <- hash ]
result = (join (hash!0))
processBlock : [1024] -> [8][64] -> [8][64]
processBlock block Hprev = Hs
where
Mi = split block : [16][64]
Ws = (messageSch Mi)
round = [Hprev] # [ (step r (Ws@t) t) | t <- [0..79] | r <- round ]
Hs = [ (x + H) | x <- (round!0) | H <- Hprev ]
step : [8][64] -> [64] -> [8] -> [8][64]
step [a, b, c, d, e, f, g, h] Wt t = [a', b', c', d', e', f', g', h']
where
T1 = h + (SIGMA1 e) + (Ch e f g) + (K@t) + Wt
T2 = (SIGMA0 a) + (Maj a b c)
h' = g
g' = f
f' = e
e' = d + T1
d' = c
c' = b
b' = a
a' = T1 + T2
messageSch : [16][64] -> [80][64]
messageSch Mi = W
where
W = Mi # [ (sigma1 (W@(t-2))) + (W@(t-7)) + (sigma0 (W@(t-15))) + (W@(t-16)) | t <- [16..79] ]
pad : {l, k} (fin l,
l <= ((2^^128) - 1),
l >= 0,
fin k,
k - l >= 129,
k == 128 + l + 1 + 1024 - ((l+129)%1024),
k%1024 == 0) => [l] -> [k]
pad M = M # (1:[1]) # (0:[k-128-l-1]) # (`l:[128])
Ch : [64] -> [64] -> [64] -> [64]
Ch x y z = (x && y) ^ ((~x) && z)
Maj : [64] -> [64] -> [64] -> [64]
Maj x y z = (x && y) ^ (x && z) ^ (y && z)
SIGMA0 : [64] -> [64]
SIGMA0 x = (x >>> 28) ^ (x >>> 34) ^ (x >>> 39)
SIGMA1 : [64] -> [64]
SIGMA1 x = (x >>> 14) ^ (x >>> 18) ^ (x >>> 41)
sigma0 : [64] -> [64]
sigma0 x = (x >>> 1) ^ (x >>> 8) ^ (x >> 7)
sigma1 : [64] -> [64]
sigma1 x = (x >>> 19) ^ (x >>> 61) ^ (x >> 6)
H0 = [ 0x6a09e667f3bcc908, 0xbb67ae8584caa73b, 0x3c6ef372fe94f82b, 0xa54ff53a5f1d36f1,
0x510e527fade682d1, 0x9b05688c2b3e6c1f, 0x1f83d9abfb41bd6b, 0x5be0cd19137e2179 ]
K = [
0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f, 0xe9b5dba58189dbbc,
0x3956c25bf348b538, 0x59f111f1b605d019, 0x923f82a4af194f9b, 0xab1c5ed5da6d8118,
0xd807aa98a3030242, 0x12835b0145706fbe, 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2,
0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235, 0xc19bf174cf692694,
0xe49b69c19ef14ad2, 0xefbe4786384f25e3, 0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65,
0x2de92c6f592b0275, 0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5,
0x983e5152ee66dfab, 0xa831c66d2db43210, 0xb00327c898fb213f, 0xbf597fc7beef0ee4,
0xc6e00bf33da88fc2, 0xd5a79147930aa725, 0x06ca6351e003826f, 0x142929670a0e6e70,
0x27b70a8546d22ffc, 0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed, 0x53380d139d95b3df,
0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6, 0x92722c851482353b,
0xa2bfe8a14cf10364, 0xa81a664bbc423001, 0xc24b8b70d0f89791, 0xc76c51a30654be30,
0xd192e819d6ef5218, 0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8,
0x19a4c116b8d2d0c8, 0x1e376c085141ab53, 0x2748774cdf8eeb99, 0x34b0bcb5e19b48a8,
0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb, 0x5b9cca4f7763e373, 0x682e6ff3d6b2b8a3,
0x748f82ee5defb2fc, 0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec,
0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915, 0xc67178f2e372532b,
0xca273eceea26619c, 0xd186b8c721c0c207, 0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178,
0x06f067aa72176fba, 0x0a637dc5a2c898a6, 0x113f9804bef90dae, 0x1b710b35131c471b,
0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc, 0x431d67c49c100d4c,
0x4cc5d4becb3e42b6, 0x597f299cfc657e2a, 0x5fcb6fab3ad6faec, 0x6c44198c4a475817
]
property testVector1 x = sha512 0xfd2203e467574e834ab07c9097ae164532f24be1eb5d88f1af7748ceff0d2c67a21f4e4097f9d3bb4e9fbf97186e0db6db0100230a52b453d421f8ab9c9a6043aa3295ea20d2f06a2f37470d8a99075f1b8a8336f6228cf08b5942fc1fb4299c7d2480e8e82bce175540bdfad7752bc95b577f229515394f3ae5cec870a4b2f8 == 0xa21b1077d52b27ac545af63b32746c6e3c51cb0cb9f281eb9f3580a6d4996d5c9917d2a6e484627a9d5a06fa1b25327a9d710e027387fc3e07d7c4d14c6086cc
cryptol-2.8.0/bench/data/ZUC.cry 0000755 0000000 0000000 00000026663 07346545000 014576 0 ustar 00 0000000 0000000 // Copyright (c) 2011-2016 Galois, Inc.
// An implementation of ZUC, Version 1.5
// Version info: If the following variable is set to True, then we implement
// Version 1.5 of ZUC. Otherwise, version 1.4 is implemented. There are
// precisely two points in the implementation where the difference matters,
// search for occurrences of version1_5 to spot them.
// Note that the ZUC test vectors below will not work for version 1.4, as the
// old test vectors are no longer published.
version1_5 : Bit
version1_5 = False
// addition in GF(2^31-1) over a list of terms
add : {a} (fin a) => [a][31] -> [31]
add xs =
sums ! 0
where
sums =
[0] #
[plus (s, x) | s <- sums
| x <- xs]
// the binary addition specified in the note at the end of section 3.2
plus : ([31], [31]) -> [31]
plus (a, b) =
if sab @ 0 then sab' + 1 else sab'
where
sab : [32]
sab = ((zero : [1]) # a) + ((zero : [1]) # b)
sab' : [31]
sab' = drop sab
// The ZUC LFSR is 16 31-bit words
type LFSR = [16][31]
// Section 3.2
LFSRWithInitializationMode : ([31], LFSR) -> LFSR
LFSRWithInitializationMode (u, ss) =
ss @@ [1 .. 15] # [s16]
where
v = add [s <<< c | s <- ss @@ [15, 13, 10, 4, 0, 0]
| c <- [15, 17, 21, 20, 8, 0]]
vu = if version1_5 then add [v, u] else v ^ u
s16 = if vu == 0 then `0x7FFFFFFF else vu
// Section 3.2
LFSRWithWorkMode : LFSR -> LFSR
LFSRWithWorkMode ss =
ss @@ [1 .. 15] # [s16]
where
v = add [s <<< c | s <- ss @@ [15, 13, 10, 4, 0, 0]
| c <- [15, 17, 21, 20, 8, 0]]
s16 = if v == 0 then `0x7FFFFFFF else v
// Section 3.3
BitReorganization : LFSR -> [4][32]
BitReorganization ss =
[ hi s15 # lo s14
, lo s11 # hi s9
, lo s7 # hi s5
, lo s2 # hi s0]
where
lo : [31] -> [16]
hi : [31] -> [16]
lo x = x @@ [15 .. 30]
hi x = x @@ [0 .. 15]
[s0, s2, s5, s7, s9, s11, s14, s15] = ss @@ [0, 2, 5, 7, 9, 11, 14, 15]
// Section 3.4
F : ([3][32], [2][32]) -> ([32], [2][32])
F ([X0, X1, X2], [R1, R2]) =
(W, [R1', R2'])
where
W = (X0 ^ R1) + R2
W1 = R1 + X1
W2 = R2 ^ X2
[W1H, W1L] = split W1
[W2H, W2L] = split W2
R1' = S (L1 (W1L # W2H))
R2' = S (L2 (W2L # W1H))
// Section 3.4.1
S : [32] -> [32]
S X =
Y0 # Y1 # Y2 # Y3
where
[X0, X1, X2, X3] = split X
[Y0, Y1, Y2, Y3] = [S0 X0, S1 X1, S2 X2, S3 X3]
// Example 8
property example8 = S(0x12345678) == 0xF9C05A4E
S0 : [8] -> [8]
S1 : [8] -> [8]
S2 : [8] -> [8]
S3 : [8] -> [8]
S0 x = S0Table @ x
S1 x = S1Table @ x
S2 = S0
S3 = S1
// Table 3.1
S0Table : [256][8]
S0Table =
[0x3E, 0x72, 0x5B, 0x47, 0xCA, 0xE0, 0x00, 0x33, 0x04, 0xD1, 0x54,
0x98, 0x09, 0xB9, 0x6D, 0xCB, 0x7B, 0x1B, 0xF9, 0x32, 0xAF, 0x9D,
0x6A, 0xA5, 0xB8, 0x2D, 0xFC, 0x1D, 0x08, 0x53, 0x03, 0x90, 0x4D,
0x4E, 0x84, 0x99, 0xE4, 0xCE, 0xD9, 0x91, 0xDD, 0xB6, 0x85, 0x48,
0x8B, 0x29, 0x6E, 0xAC, 0xCD, 0xC1, 0xF8, 0x1E, 0x73, 0x43, 0x69,
0xC6, 0xB5, 0xBD, 0xFD, 0x39, 0x63, 0x20, 0xD4, 0x38, 0x76, 0x7D,
0xB2, 0xA7, 0xCF, 0xED, 0x57, 0xC5, 0xF3, 0x2C, 0xBB, 0x14, 0x21,
0x06, 0x55, 0x9B, 0xE3, 0xEF, 0x5E, 0x31, 0x4F, 0x7F, 0x5A, 0xA4,
0x0D, 0x82, 0x51, 0x49, 0x5F, 0xBA, 0x58, 0x1C, 0x4A, 0x16, 0xD5,
0x17, 0xA8, 0x92, 0x24, 0x1F, 0x8C, 0xFF, 0xD8, 0xAE, 0x2E, 0x01,
0xD3, 0xAD, 0x3B, 0x4B, 0xDA, 0x46, 0xEB, 0xC9, 0xDE, 0x9A, 0x8F,
0x87, 0xD7, 0x3A, 0x80, 0x6F, 0x2F, 0xC8, 0xB1, 0xB4, 0x37, 0xF7,
0x0A, 0x22, 0x13, 0x28, 0x7C, 0xCC, 0x3C, 0x89, 0xC7, 0xC3, 0x96,
0x56, 0x07, 0xBF, 0x7E, 0xF0, 0x0B, 0x2B, 0x97, 0x52, 0x35, 0x41,
0x79, 0x61, 0xA6, 0x4C, 0x10, 0xFE, 0xBC, 0x26, 0x95, 0x88, 0x8A,
0xB0, 0xA3, 0xFB, 0xC0, 0x18, 0x94, 0xF2, 0xE1, 0xE5, 0xE9, 0x5D,
0xD0, 0xDC, 0x11, 0x66, 0x64, 0x5C, 0xEC, 0x59, 0x42, 0x75, 0x12,
0xF5, 0x74, 0x9C, 0xAA, 0x23, 0x0E, 0x86, 0xAB, 0xBE, 0x2A, 0x02,
0xE7, 0x67, 0xE6, 0x44, 0xA2, 0x6C, 0xC2, 0x93, 0x9F, 0xF1, 0xF6,
0xFA, 0x36, 0xD2, 0x50, 0x68, 0x9E, 0x62, 0x71, 0x15, 0x3D, 0xD6,
0x40, 0xC4, 0xE2, 0x0F, 0x8E, 0x83, 0x77, 0x6B, 0x25, 0x05, 0x3F,
0x0C, 0x30, 0xEA, 0x70, 0xB7, 0xA1, 0xE8, 0xA9, 0x65, 0x8D, 0x27,
0x1A, 0xDB, 0x81, 0xB3, 0xA0, 0xF4, 0x45, 0x7A, 0x19, 0xDF, 0xEE,
0x78, 0x34, 0x60]
// Table 3.2
S1Table : [256][8]
S1Table =
[0x55, 0xC2, 0x63, 0x71, 0x3B, 0xC8, 0x47, 0x86, 0x9F, 0x3C, 0xDA,
0x5B, 0x29, 0xAA, 0xFD, 0x77, 0x8C, 0xC5, 0x94, 0x0C, 0xA6, 0x1A,
0x13, 0x00, 0xE3, 0xA8, 0x16, 0x72, 0x40, 0xF9, 0xF8, 0x42, 0x44,
0x26, 0x68, 0x96, 0x81, 0xD9, 0x45, 0x3E, 0x10, 0x76, 0xC6, 0xA7,
0x8B, 0x39, 0x43, 0xE1, 0x3A, 0xB5, 0x56, 0x2A, 0xC0, 0x6D, 0xB3,
0x05, 0x22, 0x66, 0xBF, 0xDC, 0x0B, 0xFA, 0x62, 0x48, 0xDD, 0x20,
0x11, 0x06, 0x36, 0xC9, 0xC1, 0xCF, 0xF6, 0x27, 0x52, 0xBB, 0x69,
0xF5, 0xD4, 0x87, 0x7F, 0x84, 0x4C, 0xD2, 0x9C, 0x57, 0xA4, 0xBC,
0x4F, 0x9A, 0xDF, 0xFE, 0xD6, 0x8D, 0x7A, 0xEB, 0x2B, 0x53, 0xD8,
0x5C, 0xA1, 0x14, 0x17, 0xFB, 0x23, 0xD5, 0x7D, 0x30, 0x67, 0x73,
0x08, 0x09, 0xEE, 0xB7, 0x70, 0x3F, 0x61, 0xB2, 0x19, 0x8E, 0x4E,
0xE5, 0x4B, 0x93, 0x8F, 0x5D, 0xDB, 0xA9, 0xAD, 0xF1, 0xAE, 0x2E,
0xCB, 0x0D, 0xFC, 0xF4, 0x2D, 0x46, 0x6E, 0x1D, 0x97, 0xE8, 0xD1,
0xE9, 0x4D, 0x37, 0xA5, 0x75, 0x5E, 0x83, 0x9E, 0xAB, 0x82, 0x9D,
0xB9, 0x1C, 0xE0, 0xCD, 0x49, 0x89, 0x01, 0xB6, 0xBD, 0x58, 0x24,
0xA2, 0x5F, 0x38, 0x78, 0x99, 0x15, 0x90, 0x50, 0xB8, 0x95, 0xE4,
0xD0, 0x91, 0xC7, 0xCE, 0xED, 0x0F, 0xB4, 0x6F, 0xA0, 0xCC, 0xF0,
0x02, 0x4A, 0x79, 0xC3, 0xDE, 0xA3, 0xEF, 0xEA, 0x51, 0xE6, 0x6B,
0x18, 0xEC, 0x1B, 0x2C, 0x80, 0xF7, 0x74, 0xE7, 0xFF, 0x21, 0x5A,
0x6A, 0x54, 0x1E, 0x41, 0x31, 0x92, 0x35, 0xC4, 0x33, 0x07, 0x0A,
0xBA, 0x7E, 0x0E, 0x34, 0x88, 0xB1, 0x98, 0x7C, 0xF3, 0x3D, 0x60,
0x6C, 0x7B, 0xCA, 0xD3, 0x1F, 0x32, 0x65, 0x04, 0x28, 0x64, 0xBE,
0x85, 0x9B, 0x2F, 0x59, 0x8A, 0xD7, 0xB0, 0x25, 0xAC, 0xAF, 0x12,
0x03, 0xE2, 0xF2]
// Section 3.4.2
L1 : [32] -> [32]
L1 X = X ^ X <<< 2 ^ X <<< 10 ^ X <<< 18 ^ X <<< 24
// Section 3.4.2
L2 : [32] -> [32]
L2 X = X ^ X <<< 8 ^ X <<< 14 ^ X <<< 22 ^ X <<< 30
// Section 3.5
LoadKey : ([128], [128]) -> LFSR
LoadKey (key, iv) =
[k # d # i | k <- ks
| i <- is
| d <- ds]
where
ks : [16][8]
ks = split key
is : [16][8]
is = split iv
ds : [16][15]
ds =
[ 0b100010011010111, 0b010011010111100
, 0b110001001101011, 0b001001101011110
, 0b101011110001001, 0b011010111100010
, 0b111000100110101, 0b000100110101111
, 0b100110101111000, 0b010111100010011
, 0b110101111000100, 0b001101011110001
, 0b101111000100110, 0b011110001001101
, 0b111100010011010, 0b100011110101100
]
type ZUC = (LFSR, [32], [32])
// Return an infinite sequence of ZUC states by applying the initialization step
// repeatedly. This is a generalization of section 3.6.1
InitializeZUC : ([128], [128]) -> [inf]ZUC
InitializeZUC (key, iv) =
outs
where
initLFSR = LoadKey (key, iv)
outs = [(initLFSR, 0, 0)] # [step out | out <- outs]
step (lfsr, R1, R2) =
(LFSRWithInitializationMode (drop (w >> 1), lfsr), R1', R2')
where
[X0, X1, X2, X3] = BitReorganization lfsr
(w', [R1', R2']) = F ([X0, X1, X2], [R1, R2])
w = if version1_5 then w' else w' ^ X3
// Section 3.6.2
WorkingStage : ZUC -> ZUC
WorkingStage (lfsr, R1, R2) =
(lfsr', R1', R2')
where
[X0, X1, X2, _] = BitReorganization lfsr
(_, [R1', R2']) = F ([X0, X1, X2], [R1, R2])
lfsr' = LFSRWithWorkMode lfsr
// Section 3.6.2
ProductionStage : ZUC -> ([32], ZUC)
ProductionStage (lfsr, R1, R2) =
(w ^ X3, (lfsr', R1', R2'))
where
[X0, X1, X2, X3] = BitReorganization lfsr
(w, [R1', R2']) = F ([X0, X1, X2], [R1, R2])
lfsr' = LFSRWithWorkMode lfsr
// ZUC API
ZUC : [128] -> [128] -> [inf][32]
ZUC key iv =
tail [w | (w, _) <- zucs]
where
initZuc = WorkingStage (InitializeZUC (key, iv) @ 32)
zucs = [(zero, initZuc)] # [ProductionStage zuc | (_, zuc) <- zucs]
// Test vectors
property ZUC_TestVectors =
t1 && t2 && t3 && t4
where
t1 = take (ZUC zero zero ) == [0x27BEDE74, 0x018082DA]
t2 = take (ZUC (~zero) (~zero)) == [0x0657CFA0, 0x7096398B]
t3 = take (ZUC (join [ 0x3D, 0x4C, 0x4B, 0xE9, 0x6A, 0x82, 0xFD, 0xAE
, 0xB5, 0x8F, 0x64, 0x1D, 0xB1, 0x7B, 0x45, 0x5B
])
(join [ 0x84, 0x31, 0x9A, 0xA8, 0xDE, 0x69, 0x15, 0xCA
, 0x1F, 0x6B, 0xDA, 0x6B, 0xFB, 0xD8, 0xC7, 0x66
])) == [0x14F1C272, 0x3279C419]
t4 = take ks # [ks @ 1999] == [0xED4400E7, 0x0633E5C5, 0x7A574CDB]
where
ks = ZUC (join [ 0x4D, 0x32, 0x0B, 0xFA, 0xD4, 0xC2, 0x85, 0xBF
, 0xD6, 0xB8, 0xBD, 0x00, 0xF3, 0x9D, 0x8B, 0x41
])
(join [ 0x52, 0x95, 0x9D, 0xAB, 0xA0, 0xBF, 0x17, 0x6E
, 0xCE, 0x2D, 0xC3, 0x15, 0x04, 0x9E, 0xB5, 0x74
])
// 3.3-3.6 of the implementor's test data document lists "LFSR-state at the
// beginning", which is immediately after running LoadKey.
property LoadKey_TestVectors =
[ LoadKey(k, iv) == lfsr0
| k <- ks
| iv <- ivs
| lfsr0 <- lfsr0s
] == ~0
where
ks = [ 0
, ~0
, 0x3d4c4be96a82fdaeb58f641db17b455b
, 0x4d320bfad4c285bfd6b8bd00f39d8b41
]
ivs = [ 0
, ~0
, 0x84319aa8de6915ca1f6bda6bfbd8c766
, 0x52959daba0bf176ece2dc315049eb574
]
lfsr0s = [ [ `0x0044d700, `0x0026bc00, `0x00626b00, `0x00135e00
, `0x00578900, `0x0035e200, `0x00713500, `0x0009af00
, `0x004d7800, `0x002f1300, `0x006bc400, `0x001af100
, `0x005e2600, `0x003c4d00, `0x00789a00, `0x0047ac00
]
, [ `0x7fc4d7ff, `0x7fa6bcff, `0x7fe26bff, `0x7f935eff
, `0x7fd789ff, `0x7fb5e2ff, `0x7ff135ff, `0x7f89afff
, `0x7fcd78ff, `0x7faf13ff, `0x7febc4ff, `0x7f9af1ff
, `0x7fde26ff, `0x7fbc4dff, `0x7ff89aff, `0x7fc7acff
]
, [ `0x1ec4d784, `0x2626bc31, `0x25e26b9a, `0x74935ea8
, `0x355789de, `0x4135e269, `0x7ef13515, `0x5709afca
, `0x5acd781f, `0x47af136b, `0x326bc4da, `0x0e9af16b
, `0x58de26fb, `0x3dbc4dd8, `0x22f89ac7, `0x2dc7ac66
]
, [ `0x26c4d752, `0x1926bc95, `0x05e26b9d, `0x7d135eab
, `0x6a5789a0, `0x6135e2bf, `0x42f13517, `0x5f89af6e
, `0x6b4d78ce, `0x5c2f132d, `0x5eebc4c3, `0x001af115
, `0x79de2604, `0x4ebc4d9e, `0x45f89ab5, `0x20c7ac74
]
]
// Collision attack on ZUC. Only version1.5 is resistant to it. Thus, the
// following theorem holds only when version1_5 is set to True.
//
// NB. We only compare the first output of the InitializeZUC sequence, as it
// cuts down on the problem size and is sufficient to ensure the iv's will be
// the same. That is, if this theorem fails, then so would the final iv's used
// by ZUC.
//
// Use a solver other than CVC4; Z3 and Boolector do it quickly.
property ZUC_isResistantToCollisionAttack k iv1 iv2 =
if iv1 != iv2
then InitializeZUC (k, iv1) @ 1 != InitializeZUC (k, iv2) @ 1
else True
cryptol-2.8.0/cryptol.cabal 0000644 0000000 0000000 00000024016 07346545000 014071 0 ustar 00 0000000 0000000 Name: cryptol
Version: 2.8.0
Synopsis: Cryptol: The Language of Cryptography
Description: Cryptol is a domain-specific language for specifying cryptographic algorithms. A Cryptol implementation of an algorithm resembles its mathematical specification more closely than an implementation in a general purpose language. For more, see .
License: BSD3
License-file: LICENSE
Author: Galois, Inc.
Maintainer: cryptol@galois.com
Homepage: http://www.cryptol.net/
Bug-reports: https://github.com/GaloisInc/cryptol/issues
Copyright: 2013-2019 Galois Inc.
Category: Language
Build-type: Simple
Cabal-version: 1.18
extra-source-files: bench/data/*.cry
CHANGES.md
data-files: *.cry *.z3
data-dir: lib
source-repository head
type: git
location: https://github.com/GaloisInc/cryptol.git
source-repository this
type: git
location: https://github.com/GaloisInc/cryptol.git
tag: 2.8.0
flag static
default: False
description: Create a statically-linked binary
flag relocatable
default: True
description: Don't use the Cabal-provided data directory for looking up Cryptol libraries. This is useful when the data directory can't be known ahead of time, like for a relocatable distribution.
-- Note: the Cryptol server needs to be updated to some new APIs.
--flag server
-- default: False
-- description: Build with the ZeroMQ/JSON cryptol-server executable
library
Default-language:
Haskell2010
Build-depends: base >= 4.8 && < 5,
base-compat >= 0.6 && < 0.11,
bytestring >= 0.10,
array >= 0.4,
containers >= 0.5,
cryptohash-sha1 >= 0.11 && < 0.12,
deepseq >= 1.3,
directory >= 1.2.2.0,
filepath >= 1.3,
gitrev >= 1.0,
GraphSCC >= 1.0.4,
heredoc >= 0.2,
monad-control >= 1.0,
monadLib >= 3.7.2,
pretty >= 1.1,
process >= 1.2,
random >= 1.0.1,
sbv >= 8.1,
simple-smt >= 0.7.1,
strict,
text >= 1.1,
tf-random >= 0.5,
transformers-base >= 0.4,
mtl >= 2.2.1,
time >= 1.6.0.1,
panic >= 0.3
Build-tools: alex, happy
hs-source-dirs: src
Exposed-modules: Cryptol.Prims.Eval,
Cryptol.Parser,
Cryptol.Parser.Lexer,
Cryptol.Parser.AST,
Cryptol.Parser.Fixity,
Cryptol.Parser.Position,
Cryptol.Parser.Names,
Cryptol.Parser.Name,
Cryptol.Parser.NoPat,
Cryptol.Parser.NoInclude,
Cryptol.Parser.Selector,
Cryptol.Parser.Utils,
Cryptol.Parser.Unlit,
Cryptol.Utils.Ident,
Cryptol.Utils.PP,
Cryptol.Utils.Panic,
Cryptol.Utils.Debug,
Cryptol.Utils.Misc,
Cryptol.Utils.Patterns,
Cryptol.Utils.Logger,
Cryptol.Version,
Cryptol.ModuleSystem,
Cryptol.ModuleSystem.Base,
Cryptol.ModuleSystem.Env,
Cryptol.ModuleSystem.Fingerprint,
Cryptol.ModuleSystem.Interface,
Cryptol.ModuleSystem.Monad,
Cryptol.ModuleSystem.Name,
Cryptol.ModuleSystem.NamingEnv,
Cryptol.ModuleSystem.Renamer,
Cryptol.ModuleSystem.Exports,
Cryptol.ModuleSystem.InstantiateModule,
Cryptol.TypeCheck,
Cryptol.TypeCheck.Type,
Cryptol.TypeCheck.TCon,
Cryptol.TypeCheck.TypePat,
Cryptol.TypeCheck.SimpType,
Cryptol.TypeCheck.AST,
Cryptol.TypeCheck.Parseable,
Cryptol.TypeCheck.Monad,
Cryptol.TypeCheck.Infer,
Cryptol.TypeCheck.CheckModuleInstance,
Cryptol.TypeCheck.InferTypes,
Cryptol.TypeCheck.Error,
Cryptol.TypeCheck.Kind,
Cryptol.TypeCheck.Subst,
Cryptol.TypeCheck.Instantiate,
Cryptol.TypeCheck.Unify,
Cryptol.TypeCheck.Depends,
Cryptol.TypeCheck.PP,
Cryptol.TypeCheck.Solve,
Cryptol.TypeCheck.Default,
Cryptol.TypeCheck.SimpleSolver,
Cryptol.TypeCheck.TypeMap,
Cryptol.TypeCheck.TypeOf,
Cryptol.TypeCheck.Sanity,
Cryptol.TypeCheck.Solver.Types,
Cryptol.TypeCheck.Solver.SMT,
Cryptol.TypeCheck.Solver.InfNat,
Cryptol.TypeCheck.Solver.Class,
Cryptol.TypeCheck.Solver.Selector,
Cryptol.TypeCheck.Solver.Utils,
Cryptol.TypeCheck.Solver.Numeric,
Cryptol.TypeCheck.Solver.Improve,
Cryptol.TypeCheck.Solver.Numeric.Fin,
Cryptol.TypeCheck.Solver.Numeric.Interval,
Cryptol.Transform.MonoValues,
Cryptol.Transform.Specialize,
Cryptol.Transform.AddModParams,
Cryptol.IR.FreeVars,
Cryptol.Eval,
Cryptol.Eval.Arch,
Cryptol.Eval.Env,
Cryptol.Eval.Monad,
Cryptol.Eval.Reference,
Cryptol.Eval.Type,
Cryptol.Eval.Value,
Cryptol.Testing.Concrete,
Cryptol.Testing.Random,
Cryptol.Symbolic,
Cryptol.Symbolic.Prims,
Cryptol.Symbolic.Value,
Cryptol.REPL.Command,
Cryptol.REPL.Monad,
Cryptol.REPL.Trie
Other-modules: Cryptol.Parser.LexerUtils,
Cryptol.Parser.ParserUtils,
Cryptol.Prelude,
Paths_cryptol,
GitRev
GHC-options: -Wall -fsimpl-tick-factor=140
if impl(ghc >= 8.0.1)
ghc-options: -Wno-redundant-constraints
if flag(relocatable)
cpp-options: -DRELOCATABLE
executable cryptol
Default-language:
Haskell2010
Main-is: Main.hs
hs-source-dirs: cryptol
Other-modules: OptParser,
REPL.Haskeline,
REPL.Logo,
Paths_cryptol
build-depends: ansi-terminal
, base
, base-compat
, containers
, cryptol
, directory
, filepath
, haskeline
, monad-control
, text
, transformers
GHC-options: -Wall -threaded -rtsopts "-with-rtsopts=-N1 -A64m"
if impl(ghc >= 8.0.1)
ghc-options: -Wno-redundant-constraints
if os(linux) && flag(static)
ld-options: -static -pthread
executable cryptol-html
Default-language:
Haskell2010
main-is: CryHtml.hs
hs-source-dirs: utils
build-depends: base, text, cryptol, blaze-html
GHC-options: -Wall
-- Note: the Cryptol server needs to be updated to some new APIs.
--executable cryptol-server
-- main-is: Main.hs
-- hs-source-dirs: cryptol-server
-- other-modules: Cryptol.Aeson
-- default-language: Haskell2010
-- default-extensions: OverloadedStrings
-- GHC-options: -Wall -threaded -rtsopts "-with-rtsopts=-N1 -A64m"
-- if impl(ghc >= 8.0.1)
-- ghc-options: -Wno-redundant-constraints
-- if os(linux) && flag(static)
-- ld-options: -static -pthread
-- if flag(server)
-- build-depends: aeson >= 0.10
-- , aeson-pretty >= 0.7
-- , base
-- , base-compat
-- , bytestring >= 0.10
-- , containers
-- , cryptol
-- , filepath
-- , monad-control
-- , optparse-applicative >= 0.12
-- , text
-- , transformers
-- , unix
-- , unordered-containers >= 0.2
-- , zeromq4-haskell >= 0.6
-- else
-- buildable: False
benchmark cryptol-bench
type: exitcode-stdio-1.0
main-is: Main.hs
hs-source-dirs: bench
default-language: Haskell2010
GHC-options: -Wall -threaded -rtsopts "-with-rtsopts=-N1 -A64m"
if impl(ghc >= 8.0.1)
ghc-options: -Wno-redundant-constraints
if os(linux) && flag(static)
ld-options: -static -pthread
build-depends: base
, criterion
, cryptol
, deepseq
, directory
, filepath
, sbv >= 8.1
, text
cryptol-2.8.0/cryptol/ 0000755 0000000 0000000 00000000000 07346545000 013102 5 ustar 00 0000000 0000000 cryptol-2.8.0/cryptol/Main.hs 0000644 0000000 0000000 00000023140 07346545000 014322 0 ustar 00 0000000 0000000 -- |
-- Module : Main
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import OptParser
import Cryptol.REPL.Command (loadCmd,loadPrelude,CommandExitCode(..))
import Cryptol.REPL.Monad (REPL,updateREPLTitle,setUpdateREPLTitle,
io,prependSearchPath,setSearchPath)
import qualified Cryptol.REPL.Monad as REPL
import Cryptol.ModuleSystem.Env(ModulePath(..))
import REPL.Haskeline
import REPL.Logo
import Cryptol.Utils.PP
import Cryptol.Version (commitHash, commitBranch, commitDirty)
import Paths_cryptol (version)
import Control.Monad (when)
import Data.Maybe (isJust)
import Data.Version (showVersion)
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import System.Console.GetOpt
(OptDescr(..),ArgOrder(..),ArgDescr(..),getOpt,usageInfo)
import System.Directory (getTemporaryDirectory, removeFile)
import System.Environment (getArgs, getProgName, lookupEnv)
import System.Exit (exitFailure,exitSuccess)
import System.FilePath (searchPathSeparator, splitSearchPath, takeDirectory)
import System.IO (hClose, hPutStr, openTempFile)
import Prelude ()
import Prelude.Compat
data ColorMode = AutoColor | NoColor | AlwaysColor
deriving (Show, Eq)
data Options = Options
{ optLoad :: [FilePath]
, optVersion :: Bool
, optHelp :: Bool
, optBatch :: Maybe FilePath
, optCommands :: [String]
, optColorMode :: ColorMode
, optCryptolrc :: Cryptolrc
, optCryptolPathOnly :: Bool
, optStopOnError :: Bool
} deriving (Show)
defaultOptions :: Options
defaultOptions = Options
{ optLoad = []
, optVersion = False
, optHelp = False
, optBatch = Nothing
, optCommands = []
, optColorMode = AutoColor
, optCryptolrc = CryrcDefault
, optCryptolPathOnly = False
, optStopOnError = False
}
options :: [OptDescr (OptParser Options)]
options =
[ Option "b" ["batch"] (ReqArg setBatchScript "FILE")
"run the script provided and exit"
, Option "e" ["stop-on-error"] (NoArg setStopOnError)
"stop script execution as soon as an error occurs."
, Option "c" ["command"] (ReqArg addCommand "COMMAND")
(concat [ "run the given command and then exit; if multiple --command "
, "arguments are given, run them in the order they appear "
, "on the command line (overrides --batch)"
])
, Option "" ["color"] (ReqArg setColorMode "MODE")
(concat [ "control the color output for the terminal, which may be "
, "'auto', 'none' or 'always' (default: 'auto')"
])
, Option "v" ["version"] (NoArg setVersion)
"display version number"
, Option "h" ["help"] (NoArg setHelp)
"display this message"
, Option "" ["ignore-cryptolrc"] (NoArg setCryrcDisabled)
"disable reading of .cryptolrc files"
, Option "" ["cryptolrc-script"] (ReqArg addCryrc "FILE")
"read additional .cryptolrc files"
, Option "" ["cryptolpath-only"] (NoArg setCryptolPathOnly)
"only look for .cry files in CRYPTOLPATH; don't use built-in locations"
]
-- | Set a single file to be loaded. This should be extended in the future, if
-- we ever plan to allow multiple files to be loaded at the same time.
addFile :: String -> OptParser Options
addFile path = modify $ \ opts -> opts { optLoad = [ path ] }
-- | Add a command to be run on interpreter startup.
addCommand :: String -> OptParser Options
addCommand cmd =
modify $ \ opts -> opts { optCommands = cmd : optCommands opts }
-- | Stop script (batch mode) execution on first error.
setStopOnError :: OptParser Options
setStopOnError = modify $ \opts -> opts { optStopOnError = True }
-- | Set a batch script to be run.
setBatchScript :: String -> OptParser Options
setBatchScript path = modify $ \ opts -> opts { optBatch = Just path }
-- | Set the color mode of the terminal output.
setColorMode :: String -> OptParser Options
setColorMode "auto" = modify $ \ opts -> opts { optColorMode = AutoColor }
setColorMode "none" = modify $ \ opts -> opts { optColorMode = NoColor }
setColorMode "always" = modify $ \ opts -> opts { optColorMode = AlwaysColor }
setColorMode x = OptFailure ["invalid color mode: " ++ x ++ "\n"]
-- | Signal that version should be displayed.
setVersion :: OptParser Options
setVersion = modify $ \ opts -> opts { optVersion = True }
-- | Signal that help should be displayed.
setHelp :: OptParser Options
setHelp = modify $ \ opts -> opts { optHelp = True }
-- | Disable .cryptolrc files entirely
setCryrcDisabled :: OptParser Options
setCryrcDisabled = modify $ \ opts -> opts { optCryptolrc = CryrcDisabled }
-- | Add another file to read as a @.cryptolrc@ file, unless @.cryptolrc@
-- files have been disabled
addCryrc :: String -> OptParser Options
addCryrc path = modify $ \ opts ->
case optCryptolrc opts of
CryrcDefault -> opts { optCryptolrc = CryrcFiles [path] }
CryrcDisabled -> opts
CryrcFiles xs -> opts { optCryptolrc = CryrcFiles (path:xs) }
setCryptolPathOnly :: OptParser Options
setCryptolPathOnly = modify $ \opts -> opts { optCryptolPathOnly = True }
-- | Parse arguments.
parseArgs :: [String] -> Either [String] Options
parseArgs args = case getOpt (ReturnInOrder addFile) options args of
(ps,[],[]) -> runOptParser defaultOptions (mconcat ps)
(_,_,errs) -> Left errs
displayVersion :: IO ()
displayVersion = do
let ver = showVersion version
putStrLn ("Cryptol " ++ ver)
putStrLn ("Git commit " ++ commitHash)
putStrLn (" branch " ++ commitBranch ++ dirtyLab)
where
dirtyLab | commitDirty = " (non-committed files present during build)"
| otherwise = ""
displayHelp :: [String] -> IO ()
displayHelp errs = do
prog <- getProgName
let banner = "Usage: " ++ prog ++ " [OPTIONS]"
paraLines = fsep . map text . words . unlines
ppEnv (varname, desc) = hang varname 4 (paraLines $ desc)
envs = [
( "CRYPTOLPATH"
, [ "A `" ++ [searchPathSeparator] ++ "`-separated"
, "list of directories to be searched for Cryptol modules in"
, "addition to the default locations"
]
)
, ( "SBV_{ABC,BOOLECTOR,CVC4,MATHSAT,YICES,Z3}_OPTIONS"
, [ "A string of command-line arguments to be passed to the"
, "corresponding solver invoked for `:sat` and `:prove`"
]
)
]
putStrLn (usageInfo (concat (errs ++ [banner])) options)
print $ hang "Influential environment variables:"
4 (vcat (map ppEnv envs))
main :: IO ()
main = do
setLocaleEncoding utf8
args <- getArgs
case parseArgs args of
Left errs -> do
displayHelp errs
exitFailure
Right opts
| optHelp opts -> displayHelp []
| optVersion opts -> displayVersion
| otherwise -> do
(opts', mCleanup) <- setupCmdScript opts
status <- repl (optCryptolrc opts')
(optBatch opts')
(optStopOnError opts')
(setupREPL opts')
case mCleanup of
Nothing -> return ()
Just cmdFile -> removeFile cmdFile
case status of
CommandError -> exitFailure
CommandOk -> exitSuccess
setupCmdScript :: Options -> IO (Options, Maybe FilePath)
setupCmdScript opts =
case optCommands opts of
[] -> return (opts, Nothing)
cmds -> do
tmpdir <- getTemporaryDirectory
(path, h) <- openTempFile tmpdir "cmds.icry"
hPutStr h (unlines cmds)
hClose h
when (isJust (optBatch opts)) $
putStrLn "[warning] --command argument specified; ignoring batch file"
return (opts { optBatch = Just path }, Just path)
setupREPL :: Options -> REPL ()
setupREPL opts = do
mCryptolPath <- io $ lookupEnv "CRYPTOLPATH"
case mCryptolPath of
Nothing -> return ()
Just path | optCryptolPathOnly opts -> setSearchPath path'
| otherwise -> prependSearchPath path'
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
-- Windows paths search from end to beginning
where path' = reverse (splitSearchPath path)
#else
where path' = splitSearchPath path
#endif
smoke <- REPL.smokeTest
case smoke of
[] -> return ()
_ -> io $ do
print (hang "Errors encountered on startup; exiting:"
4 (vcat (map pp smoke)))
exitFailure
color <- case optColorMode opts of
AlwaysColor -> return True
NoColor -> return False
AutoColor -> canDisplayColor
displayLogo color
setUpdateREPLTitle (shouldSetREPLTitle >>= \b -> when b setREPLTitle)
updateREPLTitle
case optBatch opts of
Nothing -> return ()
-- add the directory containing the batch file to the module search path
Just file -> prependSearchPath [ takeDirectory file ]
case optLoad opts of
[] -> loadPrelude `REPL.catch` \x -> io $ print $ pp x
[l] -> loadCmd l `REPL.catch` \x -> do
io $ print $ pp x
-- If the requested file fails to load, load the prelude instead...
loadPrelude `REPL.catch` \y -> do
io $ print $ pp y
-- ... but make sure the loaded module is set to the file
-- we tried, instead of the Prelude
REPL.setEditPath l
REPL.setLoadedMod REPL.LoadedModule
{ REPL.lName = Nothing
, REPL.lPath = InFile l
}
_ -> io $ putStrLn "Only one file may be loaded at the command line."
cryptol-2.8.0/cryptol/OptParser.hs 0000644 0000000 0000000 00000002036 07346545000 015356 0 ustar 00 0000000 0000000 -- |
-- Module : OptParser
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
module OptParser where
import Data.Monoid (Endo(..))
import Data.Semigroup
import Prelude ()
import Prelude.Compat
data OptParser opt
= OptSuccess (Endo opt)
| OptFailure [String]
instance Semigroup (OptParser opt) where
l <> r = case (l,r) of
(OptSuccess f,OptSuccess g) -> OptSuccess (f `mappend` g)
(OptFailure a,OptFailure b) -> OptFailure (a `mappend` b)
(OptFailure _,_) -> l
(_,OptFailure _) -> r
instance Monoid (OptParser opt) where
mempty = OptSuccess mempty
mappend = (<>)
runOptParser :: opt -> OptParser opt -> Either [String] opt
runOptParser def parse = case parse of
OptSuccess update -> Right (appEndo update def)
OptFailure msgs -> Left msgs
modify :: (opt -> opt) -> OptParser opt
modify f = OptSuccess (Endo f)
report :: String -> OptParser opt
report msg = OptFailure [msg]
cryptol-2.8.0/cryptol/REPL/ 0000755 0000000 0000000 00000000000 07346545000 013644 5 ustar 00 0000000 0000000 cryptol-2.8.0/cryptol/REPL/Haskeline.hs 0000644 0000000 0000000 00000026025 07346545000 016110 0 ustar 00 0000000 0000000 -- |
-- Module : REPL.Haskeline
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PatternGuards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module REPL.Haskeline where
import Cryptol.REPL.Command
import Cryptol.REPL.Monad
import Cryptol.REPL.Trie
import Cryptol.Utils.PP
import Cryptol.Utils.Logger(stdoutLogger)
import Cryptol.Utils.Ident(modNameToText, interactiveName)
import qualified Control.Exception as X
import Control.Monad (guard, join)
import qualified Control.Monad.Trans.Class as MTL
import Control.Monad.Trans.Control
import Data.Char (isAlphaNum, isSpace)
import Data.Maybe(isJust)
import Data.Function (on)
import Data.List (isPrefixOf,nub,sortBy,sort)
import qualified Data.Set as Set
import qualified Data.Text as T (unpack)
import System.IO (stdout)
import System.Console.ANSI (setTitle, hSupportsANSI)
import System.Console.Haskeline
import System.Directory ( doesFileExist
, getHomeDirectory
, getCurrentDirectory)
import System.FilePath ((>))
import Prelude ()
import Prelude.Compat
-- | One REPL invocation, either from a file or from the terminal.
crySession :: Maybe FilePath -> Bool -> REPL CommandExitCode
crySession mbBatch stopOnError =
do settings <- io (setHistoryFile (replSettings isBatch))
let act = runInputTBehavior behavior settings (withInterrupt loop)
if isBatch then asBatch act else act
where
(isBatch,behavior) = case mbBatch of
Nothing -> (False,defaultBehavior)
Just path -> (True,useFile path)
loop :: InputT REPL CommandExitCode
loop =
do ln <- getInputLines =<< MTL.lift getPrompt
case ln of
NoMoreLines -> return CommandOk
Interrupted
| isBatch && stopOnError -> return CommandError
| otherwise -> loop
NextLine line
| all isSpace line -> loop
| otherwise -> doCommand line
doCommand txt =
case parseCommand findCommandExact txt of
Nothing | isBatch && stopOnError -> return CommandError
| otherwise -> loop -- say somtething?
Just cmd -> join $ MTL.lift $
do status <- handleInterrupt (handleCtrlC CommandError) (runCommand cmd)
case status of
CommandError | isBatch && stopOnError -> return (return status)
_ -> do goOn <- shouldContinue
return (if goOn then loop else return status)
data NextLine = NextLine String | NoMoreLines | Interrupted
getInputLines :: String -> InputT REPL NextLine
getInputLines = handleInterrupt (MTL.lift (handleCtrlC Interrupted)) . loop []
where
loop ls prompt =
do mb <- getInputLine prompt
let newPropmpt = map (\_ -> ' ') prompt
case mb of
Nothing -> return NoMoreLines
Just l
| not (null l) && last l == '\\' -> loop (init l : ls) newPropmpt
| otherwise -> return $ NextLine $ unlines $ reverse $ l : ls
loadCryRC :: Cryptolrc -> REPL CommandExitCode
loadCryRC cryrc =
case cryrc of
CryrcDisabled -> return CommandOk
CryrcDefault -> check [ getCurrentDirectory, getHomeDirectory ]
CryrcFiles opts -> loadMany opts
where
check [] = return CommandOk
check (place : others) =
do dir <- io place
let file = dir > ".cryptolrc"
present <- io (doesFileExist file)
if present
then crySession (Just file) True
else check others
loadMany [] = return CommandOk
loadMany (f : fs) = do status <- crySession (Just f) True
case status of
CommandOk -> loadMany fs
_ -> return status
-- | Haskeline-specific repl implementation.
repl :: Cryptolrc -> Maybe FilePath -> Bool -> REPL () -> IO CommandExitCode
repl cryrc mbBatch stopOnError begin =
runREPL (isJust mbBatch) stdoutLogger $
do status <- loadCryRC cryrc
case status of
CommandOk -> begin >> crySession mbBatch stopOnError
_ -> return status
-- | Try to set the history file.
setHistoryFile :: Settings REPL -> IO (Settings REPL)
setHistoryFile ss =
do dir <- getHomeDirectory
return ss { historyFile = Just (dir > ".cryptol_history") }
`X.catch` \(SomeException {}) -> return ss
-- | Haskeline settings for the REPL.
replSettings :: Bool -> Settings REPL
replSettings isBatch = Settings
{ complete = cryptolCommand
, historyFile = Nothing
, autoAddHistory = not isBatch
}
-- .cryptolrc ------------------------------------------------------------------
-- | Configuration of @.cryptolrc@ file behavior. The default option
-- searches the following locations in order, and evaluates the first
-- file that exists in batch mode on interpreter startup:
--
-- 1. $PWD/.cryptolrc
-- 2. $HOME/.cryptolrc
--
-- If files are specified, they will all be evaluated, but none of the
-- default files will be (unless they are explicitly specified).
--
-- The disabled option inhibits any reading of any .cryptolrc files.
data Cryptolrc =
CryrcDefault
| CryrcDisabled
| CryrcFiles [FilePath]
deriving (Show)
-- Utilities -------------------------------------------------------------------
instance MonadException REPL where
controlIO f = join $ liftBaseWith $ \f' ->
f $ RunIO $ \m -> restoreM <$> (f' m)
-- Titles ----------------------------------------------------------------------
mkTitle :: Maybe LoadedModule -> String
mkTitle lm = maybe "" (\ m -> pretty m ++ " - ") (lName =<< lm)
++ "cryptol"
setREPLTitle :: REPL ()
setREPLTitle = do
lm <- getLoadedMod
io (setTitle (mkTitle lm))
-- | In certain environments like Emacs, we shouldn't set the terminal
-- title. Note: this does not imply we can't use color output. We can
-- use ANSI color sequences in places like Emacs, but not terminal
-- codes.
--
-- This checks that @'stdout'@ is a proper terminal handle, and that the
-- terminal mode is not @dumb@, which is set by Emacs and others.
shouldSetREPLTitle :: REPL Bool
shouldSetREPLTitle = io (hSupportsANSI stdout)
-- | Whether we can display color titles. This checks that @'stdout'@
-- is a proper terminal handle, and that the terminal mode is not
-- @dumb@, which is set by Emacs and others.
canDisplayColor :: REPL Bool
canDisplayColor = io (hSupportsANSI stdout)
-- Completion ------------------------------------------------------------------
-- | Completion for cryptol commands.
cryptolCommand :: CompletionFunc REPL
cryptolCommand cursor@(l,r)
| ":" `isPrefixOf` l'
, Just (cmd,rest) <- splitCommand l' = case nub (findCommand cmd) of
[c] | null rest && not (any isSpace l') -> do
return (l, cmdComp cmd c)
| otherwise -> do
(rest',cs) <- cmdArgument (cBody c) (reverse (sanitize rest),r)
return (unwords [rest', reverse cmd],cs)
cmds ->
return (l, concat [ cmdComp l' c | c <- cmds ])
-- Complete all : commands when the line is just a :
| ":" == l' = return (l, concat [ cmdComp l' c | c <- nub (findCommand ":") ])
| otherwise = completeExpr cursor
where
l' = sanitize (reverse l)
-- | Generate completions from a REPL command definition.
cmdComp :: String -> CommandDescr -> [Completion]
cmdComp prefix c = do
cName <- cNames c
guard (prefix `isPrefixOf` cName)
return $ nameComp prefix cName
-- | Dispatch to a completion function based on the kind of completion the
-- command is expecting.
cmdArgument :: CommandBody -> CompletionFunc REPL
cmdArgument ct cursor@(l,_) = case ct of
ExprArg _ -> completeExpr cursor
DeclsArg _ -> (completeExpr +++ completeType) cursor
ExprTypeArg _ -> (completeExpr +++ completeType) cursor
ModNameArg _ -> completeModName cursor
FilenameArg _ -> completeFilename cursor
ShellArg _ -> completeFilename cursor
OptionArg _ -> completeOption cursor
HelpArg _ -> completeHelp cursor
NoArg _ -> return (l,[])
FileExprArg _ -> completeExpr cursor
-- | Additional keywords to suggest in the REPL
-- autocompletion list.
keywords :: [String]
keywords =
[ "else"
, "if"
, "let"
, "then"
, "where"
]
-- | Complete a name from the expression environment.
completeExpr :: CompletionFunc REPL
completeExpr (l,_) = do
ns <- (keywords++) <$> getExprNames
let n = reverse (takeIdent l)
vars = sort $ filter (n `isPrefixOf`) ns
return (l,map (nameComp n) vars)
-- | Complete a name from the type synonym environment.
completeType :: CompletionFunc REPL
completeType (l,_) = do
ns <- getTypeNames
let n = reverse (takeIdent l)
vars = filter (n `isPrefixOf`) ns
return (l,map (nameComp n) vars)
-- | Complete a name for which we can show REPL help documentation.
completeHelp :: CompletionFunc REPL
completeHelp (l, _) = do
ns1 <- getExprNames
ns2 <- getTypeNames
let ns3 = concatMap cNames (nub (findCommand ":"))
let ns = Set.toAscList (Set.fromList (ns1 ++ ns2)) ++ ns3
let n = reverse l
case break isSpace n of
(":set", _ : n') ->
do let n'' = dropWhile isSpace n'
let vars = map optName (lookupTrie (dropWhile isSpace n') userOptions)
return (l, map (nameComp n'') vars)
_ ->
do let vars = filter (n `isPrefixOf`) ns
return (l, map (nameComp n) vars)
-- | Complete a name from the list of loaded modules.
completeModName :: CompletionFunc REPL
completeModName (l, _) = do
ms <- getModNames
let ns = map (T.unpack . modNameToText) (interactiveName : ms)
n = reverse (takeWhile (not . isSpace) l)
vars = filter (n `isPrefixOf`) ns
return (l, map (nameComp n) vars)
-- | Generate a completion from a prefix and a name.
nameComp :: String -> String -> Completion
nameComp prefix c = Completion
{ replacement = drop (length prefix) c
, display = c
, isFinished = True
}
-- | Return longest identifier (possibly a qualified name) that is a
-- prefix of the given string
takeIdent :: String -> String
takeIdent (c : cs) | isIdentChar c = c : takeIdent cs
takeIdent (':' : ':' : cs) = ':' : ':' : takeIdent cs
takeIdent _ = []
isIdentChar :: Char -> Bool
isIdentChar c = isAlphaNum c || c `elem` "_\'"
-- | Join two completion functions together, merging and sorting their results.
(+++) :: CompletionFunc REPL -> CompletionFunc REPL -> CompletionFunc REPL
(as +++ bs) cursor = do
(_,acs) <- as cursor
(_,bcs) <- bs cursor
return (fst cursor, sortBy (compare `on` replacement) (acs ++ bcs))
-- | Complete an option from the options environment.
--
-- XXX this can do better, as it has access to the expected form of the value
completeOption :: CompletionFunc REPL
completeOption cursor@(l,_) = return (fst cursor, map comp opts)
where
n = reverse l
opts = lookupTrie n userOptions
comp opt = Completion
{ replacement = drop (length n) (optName opt)
, display = optName opt
, isFinished = False
}
cryptol-2.8.0/cryptol/REPL/Logo.hs 0000644 0000000 0000000 00000003645 07346545000 015110 0 ustar 00 0000000 0000000 -- |
-- Module : REPL.Logo
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
module REPL.Logo where
import Cryptol.REPL.Monad
import Paths_cryptol (version)
import Cryptol.Version (commitShortHash,commitDirty)
import Data.Version (showVersion)
import System.Console.ANSI
type Version = String
type Logo = [String]
logo :: Bool -> (String -> [String]) -> Logo
logo useColor mk =
[ sgr [SetColor Foreground Dull White] ++ l | l <- ws ]
++ [ sgr [SetColor Foreground Vivid Blue ] ++ l | l <- vs ]
++ [ sgr [SetColor Foreground Dull Blue ] ++ l | l <- ds ]
++ [ sgr [Reset] ]
where
sgr | useColor = setSGRCode
| otherwise = const []
hashText | commitShortHash == "UNKNOWN" = ""
| otherwise = " (" ++ commitShortHash ++
(if commitDirty then ", modified)" else ")")
versionText = "version " ++ showVersion version ++ hashText
ver = sgr [SetColor Foreground Dull White]
++ replicate (lineLen - 20 - length versionText) ' '
++ versionText
ls = mk ver
slen = length ls `div` 3
(ws,rest) = splitAt slen ls
(vs,ds) = splitAt slen rest
lineLen = length (head ls)
displayLogo :: Bool -> REPL ()
displayLogo useColor = unlessBatch (io (mapM_ putStrLn (logo useColor logo2)))
logo1 :: String -> [String]
logo1 ver =
[ " _ _"
, " ___ _ __ _ _ _ __ | |_ ___ | |"
, " / __| \'__| | | | \'_ \\| __/ _ \\| |"
, " | (__| | | |_| | |_) | || (_) | |"
, " \\___|_| \\__, | .__/ \\__\\___/|_|"
, " |___/|_| " ++ ver
]
logo2 :: String -> [String]
logo2 ver =
[ "┏━╸┏━┓╻ ╻┏━┓╺┳╸┏━┓╻ "
, "┃ ┣┳┛┗┳┛┣━┛ ┃ ┃ ┃┃ "
, "┗━╸╹┗╸ ╹ ╹ ╹ ┗━┛┗━╸"
, ver
]
cryptol-2.8.0/lib/ 0000755 0000000 0000000 00000000000 07346545000 012154 5 ustar 00 0000000 0000000 cryptol-2.8.0/lib/Cryptol.cry 0000644 0000000 0000000 00000056357 07346545000 014347 0 ustar 00 0000000 0000000 /*
* Copyright (c) 2013-2016 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/
module Cryptol where
/**
* The value corresponding to a numeric type.
*/
primitive number : {val, rep} Literal val rep => rep
/**
* An alternative name for 'number', present for backward compatibility.
*/
demote : {val, rep} Literal val rep => rep
demote = number`{val}
infixr 5 ==>
infixr 10 \/
infixr 15 /\
infix 20 ==, ===, !=, !==
infix 30 >, >=, <, <=, <$, >$, <=$, >=$
infixr 40 ||
infixl 45 ^
infixr 50 &&
infixr 60 #
infixl 70 <<, <<<, >>, >>>, >>$
infixl 80 +, -
infixl 90 *, /, %, /$, %$, %^, /^
infixr 95 ^^
infixl 100 @, @@, !, !!
// -----------------------------------------------------------------------------
/** A numeric type representing infinity. */
primitive type inf : #
/** The type of boolean values. */
primitive type Bit : *
/** The type of unbounded integers. */
primitive type Integer : *
/** 'Z n' is the type of integers, modulo 'n'. */
primitive type {n : #} (fin n, n >= 1) => Z n : *
/** Assert that two numeric types are equal. */
primitive type (==) : # -> # -> Prop
/** Assert that two numeric types are different. */
primitive type (!=) : # -> # -> Prop
/** Assert that the first numeric type is larger than, or equal to the second.*/
primitive type (>=) : # -> # -> Prop
/** Assert that a numeric type is a proper natural number (not 'inf'). */
primitive type fin : * -> Prop
/** Value types that have a notion of 'zero'. */
primitive type Zero : * -> Prop
/** Value types that support logical operations. */
primitive type Logic : * -> Prop
/** Value types that support arithmetic. */
primitive type Arith : * -> Prop
/** Value types that support unsigned comparisons. */
primitive type Cmp : * -> Prop
/** Value types that support signed comparisons. */
primitive type SignedCmp : * -> Prop
/** 'Literal n a' asserts that type 'a' contains the number 'n'. */
primitive type Literal : # -> * -> Prop
/** Add numeric types. */
primitive type (+) : # -> # -> #
/** Subtract numeric types. */
primitive type
{m : #, n : # }
(fin n, m >= n) =>
m - n : #
/** Multiply numeric types. */
primitive type (*) : # -> # -> #
/** Divide numeric types, rounding down. */
primitive type
{ m : #, n : # }
(fin m, n >= 1) =>
m / n : #
/** Remainder of numeric type division. */
primitive type
{ m : #, n : # }
(fin m, n >= 1) =>
m % n : #
/** Exponentiate numeric types. */
primitive type (^^) : # -> # -> #
/** The number of bits required to represent the value of a numeric type. */
primitive type width : # -> #
/** The smaller of two numeric types. */
primitive type min : # -> # -> #
/** The larger of two numeric types. */
primitive type max : # -> # -> #
/** Divide numeric types, rounding up. */
primitive type
{ m : #, n : # }
(fin m, fin n, n >= 1) =>
m /^ n : #
/** How much we need to add to make a proper multiple of the second argument. */
primitive type
{ m : #, n : # }
(fin m, fin n, n >= 1) =>
m %^ n : #
/** The length of an enumeration. */
primitive type
{ start : #, next : #, last : # }
(fin start, fin next, fin last, start != next) =>
lengthFromThenTo start next last : #
// -----------------------------------------------------------------------------
/**
* Assert that the first numeric type is less than or equal to the second.
*/
type constraint i <= j = (j >= i)
/**
* Assert that the first numeric type is greater than the second.
*/
type constraint i > j = i >= j + 1
/**
* Assert that the first numeric type is less than the second.
*/
type constraint i < j = j >= i + 1
/**
* Add two values.
* * For type [n], addition is modulo 2^^n.
* * Structured values are added element-wise.
*/
primitive (+) : {a} (Arith a) => a -> a -> a
/**
* Subtract two values.
* * For type [n], subtraction is modulo 2^^n.
* * Structured values are subtracted element-wise.
* * Satisfies 'a - b = a + negate b'.
* See also: 'negate'.
*/
primitive (-) : {a} (Arith a) => a -> a -> a
/**
* Multiply two values.
* * For type [n], multiplication is modulo 2^^n.
* * Structured values are multiplied element-wise.
*/
primitive (*) : {a} (Arith a) => a -> a -> a
/**
* Divide two values, rounding down.
* * For type [n], the arguments are treated as unsigned.
* * Structured values are divided element-wise.
* * Division by zero is undefined.
*/
primitive (/) : {a} (Arith a) => a -> a -> a
/**
* Compute the remainder from dividing two values.
* * For type [n], the arguments are treated as unsigned.
* * Structured values are combined element-wise.
* * Remainder of division by zero is undefined.
* * Satisfies 'x % y == x - (x / y) * y'.
*/
primitive (%) : {a} (Arith a) => a -> a -> a
/**
* Compute the exponentiation of two values.
* * For type [n], the exponent is treated as unsigned,
* and the result is reduced modulo 2^^n.
* * For type Integer, negative powers are undefined.
* * Structured values are combined element-wise.
*/
primitive (^^) : {a} (Arith a) => a -> a -> a
/**
* Log base two.
*
* For words, computes the ceiling of log, base 2, of a number.
* Over structured values, operates element-wise.
*/
primitive lg2 : {a} (Arith a) => a -> a
type Bool = Bit
/**
* The constant True. Corresponds to the bit value 1.
*/
primitive True : Bit
/**
* The constant False. Corresponds to the bit value 0.
*/
primitive False : Bit
/**
* Returns the two's complement of its argument.
* Over structured values, operates element-wise.
* The prefix notation '- x' is syntactic sugar
* for 'negate x'.
* Satisfies 'negate a = ~a + 1'.
*/
primitive negate : {a} (Arith a) => a -> a
/**
* Bitwise complement. The prefix notation '~ x'
* is syntactic sugar for 'complement x'.
*/
primitive complement : {a} (Logic a) => a -> a
/**
* Less-than. Only works on comparable arguments.
*
* Bitvectors are compared using unsigned arithmetic.
*/
primitive (<) : {a} (Cmp a) => a -> a -> Bit
/**
* Greater-than of two comparable arguments.
*
* Bitvectors are compared using unsigned arithmetic.
*/
primitive (>) : {a} (Cmp a) => a -> a -> Bit
/**
* Less-than or equal of two comparable arguments.
*
* Bitvectors are compared using unsigned arithmetic.
*/
primitive (<=) : {a} (Cmp a) => a -> a -> Bit
/**
* Greater-than or equal of two comparable arguments.
*
* Bitvectors are compared using unsigned arithmetic.
*/
primitive (>=) : {a} (Cmp a) => a -> a -> Bit
/**
* Compares any two values of the same type for equality.
*/
primitive (==) : {a} (Cmp a) => a -> a -> Bit
/**
* Compares any two values of the same type for inequality.
*/
primitive (!=) : {a} (Cmp a) => a -> a -> Bit
/**
* Compare the outputs of two functions for equality.
*/
(===) : {a, b} (Cmp b) => (a -> b) -> (a -> b) -> (a -> Bit)
f === g = \ x -> f x == g x
/**
* Compare the outputs of two functions for inequality.
*/
(!==) : {a, b} (Cmp b) => (a -> b) -> (a -> b) -> (a -> Bit)
f !== g = \x -> f x != g x
/**
* Returns the smaller of two comparable arguments.
* Bitvectors are compared using unsigned arithmetic.
*/
min : {a} (Cmp a) => a -> a -> a
min x y = if x < y then x else y
/**
* Returns the greater of two comparable arguments.
* Bitvectors are compared using unsigned arithmetic.
*/
max : {a} (Cmp a) => a -> a -> a
max x y = if x > y then x else y
/**
* 2's complement signed less-than.
*/
primitive (<$) : {a} (SignedCmp a) => a -> a -> Bit
/**
* 2's complement signed greater-than.
*/
(>$) : {a} (SignedCmp a) => a -> a -> Bit
x >$ y = y <$ x
/**
* 2's complement signed less-than-or-equal.
*/
(<=$) : {a} (SignedCmp a) => a -> a -> Bit
x <=$ y = ~(y <$ x)
/**
* 2's complement signed greater-than-or-equal.
*/
(>=$) : {a} (SignedCmp a) => a -> a -> Bit
x >=$ y = ~(x <$ y)
/**
* 2's complement signed division. Division rounds toward 0.
*/
primitive (/$) : {a} (Arith a) => a -> a -> a
/**
* 2's complement signed remainder. Division rounds toward 0.
*/
primitive (%$) : {a} (Arith a) => a -> a -> a
/**
* Unsigned carry. Returns true if the unsigned addition of the given
* bitvector arguments would result in an unsigned overflow.
*/
primitive carry : {n} (fin n) => [n] -> [n] -> Bit
/**
* Signed carry. Returns true if the 2's complement signed addition of the
* given bitvector arguments would result in a signed overflow.
*/
primitive scarry : {n} (fin n, n >= 1) => [n] -> [n] -> Bit
/**
* Signed borrow. Returns true if the 2's complement signed subtraction of the
* given bitvector arguments would result in a signed overflow.
*/
sborrow : {n} (fin n, n >= 1) => [n] -> [n] -> Bit
sborrow x y = ( x <$ (x-y) ) ^ y@0
/**
* Zero extension of a bitvector.
*/
zext : {m, n} (fin m, m >= n) => [n] -> [m]
zext x = zero # x
/**
* Sign extension of a bitvector.
*/
sext : {m, n} (fin m, m >= n, n >= 1) => [n] -> [m]
sext x = newbits # x
where newbits = if x@0 then ~zero else zero
/**
* Short-cutting boolean conjunction function.
* If the first argument is False, the second argument
* is not evaluated.
*/
(/\) : Bit -> Bit -> Bit
x /\ y = if x then y else False
/**
* Short-cutting boolean disjunction function.
* If the first argument is True, the second argument
* is not evaluated.
*/
(\/) : Bit -> Bit -> Bit
x \/ y = if x then True else y
/**
* Short-cutting logical implication.
* If the first argument is False, the second argument is
* not evaluated.
*/
(==>) : Bit -> Bit -> Bit
a ==> b = if a then b else True
/**
* Logical 'and' over bits. Extends element-wise over sequences, tuples.
*/
primitive (&&) : {a} (Logic a) => a -> a -> a
/**
* Logical 'or' over bits. Extends element-wise over sequences, tuples.
*/
primitive (||) : {a} (Logic a) => a -> a -> a
/**
* Logical 'exclusive or' over bits. Extends element-wise over sequences, tuples.
*/
primitive (^) : {a} (Logic a) => a -> a -> a
/**
* Gives an arbitrary shaped value whose bits are all False.
* ~zero likewise gives an arbitrary shaped value whose bits are all True.
*/
primitive zero : {a} (Zero a) => a
/**
* Converts a bitvector to a non-negative integer in the range 0 to 2^^n-1.
*/
primitive toInteger : {bits} (fin bits) => [bits] -> Integer
/**
* Converts an unbounded integer to another arithmetic type. When converting
* to the bitvector type [n], the value is reduced modulo 2^^n.
*/
primitive fromInteger : {a} (Arith a) => Integer -> a
/**
* Converts an integer modulo n to an unbounded integer in the range 0 to n-1.
*/
primitive fromZ : {n} (fin n, n >= 1) => Z n -> Integer
/**
* Left shift. The first argument is the sequence to shift, the second is the
* number of positions to shift by.
*/
primitive (<<) : {n, ix, a} (fin ix, Zero a) => [n]a -> [ix] -> [n]a
/**
* Right shift. The first argument is the sequence to shift, the second is the
* number of positions to shift by.
*/
primitive (>>) : {n, ix, a} (fin ix, Zero a) => [n]a -> [ix] -> [n]a
/**
* Left rotate. The first argument is the sequence to rotate, the second is the
* number of positions to rotate by.
*/
primitive (<<<) : {n, ix, a} (fin n, fin ix) => [n]a -> [ix] -> [n]a
/**
* Right rotate. The first argument is the sequence to rotate, the second is
* the number of positions to rotate by.
*/
primitive (>>>) : {n, ix, a} (fin n, fin ix) => [n]a -> [ix] -> [n]a
/**
* 2's complement signed (arithmetic) right shift. The first argument
* is the sequence to shift (considered as a signed value),
* the second argument is the number of positions to shift
* by (considered as an unsigned value).
*/
primitive (>>$) : {n, ix} (fin n, n >= 1, fin ix) => [n] -> [ix] -> [n]
/**
* Concatenates two sequences. On bitvectors, the most-significant bits
* are in the left argument, and the least-significant bits are in the right.
*/
primitive (#) : {front, back, a} (fin front) => [front]a -> [back]a
-> [front + back] a
/**
* Splits a sequence into a pair of sequences.
* 'splitAt z = (x, y)' iff 'x # y = z'.
*/
primitive splitAt : {front, back, a} (fin front) => [front + back]a
-> ([front]a, [back]a)
/**
* Concatenates a list of sequences.
* 'join' is the inverse function to 'split'.
*/
primitive join : {parts, each, a} (fin each) => [parts][each]a
-> [parts * each]a
/**
* Splits a sequence into 'parts' groups with 'each' elements.
* 'split' is the inverse function to 'join'.
*/
primitive split : {parts, each, a} (fin each) => [parts * each]a
-> [parts][each]a
/**
* Reverses the elements in a sequence.
*/
primitive reverse : {n, a} (fin n) => [n]a -> [n]a
/**
* Transposes a matrix.
* Satisfies the property 'transpose m @ i @ j == m @ j @ i'.
*/
primitive transpose : {rows, cols, a} [rows][cols]a -> [cols][rows]a
/**
* Index operator. The first argument is a sequence. The second argument is
* the zero-based index of the element to select from the sequence.
*/
primitive (@) : {n, a, ix} (fin ix) => [n]a -> [ix] -> a
/**
* Bulk index operator. The first argument is a sequence. The second argument
* is a sequence of the zero-based indices of the elements to select.
*/
(@@) : {n, k, ix, a} (fin ix) => [n]a -> [k][ix] -> [k]a
xs @@ is = [ xs @ i | i <- is ]
/**
* Reverse index operator. The first argument is a finite sequence. The second
* argument is the zero-based index of the element to select, starting from the
* end of the sequence.
*/
primitive (!) : {n, a, ix} (fin n, fin ix) => [n]a -> [ix] -> a
/**
* Bulk reverse index operator. The first argument is a finite sequence. The
* second argument is a sequence of the zero-based indices of the elements to
* select, starting from the end of the sequence.
*/
(!!) : {n, k, ix, a} (fin n, fin ix) => [n]a -> [k][ix] -> [k]a
xs !! is = [ xs ! i | i <- is ]
/**
* Update the given sequence with new value at the given index position.
* The first argument is a sequence. The second argument is the zero-based
* index of the element to update, starting from the front of the sequence.
* The third argument is the new element. The return value is the
* initial sequence updated so that the indicated index has the given value.
*/
primitive update : {n, a, ix} (fin ix) => [n]a -> [ix] -> a -> [n]a
/**
* Update the given sequence with new value at the given index position.
* The first argument is a sequence. The second argument is the zero-based
* index of the element to update, starting from the end of the sequence.
* The third argument is the new element. The return value is the
* initial sequence updated so that the indicated index has the given value.
*/
primitive updateEnd : {n, a, ix} (fin n, fin ix) => [n]a -> [ix] -> a -> [n]a
/**
* Perform a series of updates to a sequence. The first argument is
* the initial sequence to update. The second argument is a sequence
* of indices, and the third argument is a sequence of values.
* This function applies the 'update' function in sequence with the
* given update pairs.
*/
updates : {n, k, ix, a} (fin ix, fin k) => [n]a -> [k][ix] -> [k]a -> [n]a
updates xs0 idxs vals = xss!0
where
xss = [ xs0 ] #
[ update xs i b
| xs <- xss
| i <- idxs
| b <- vals
]
/**
* Perform a series of updates to a sequence. The first argument is
* the initial sequence to update. The second argument is a sequence
* of indices, and the third argument is a sequence of values.
* This function applies the 'updateEnd' function in sequence with the
* given update pairs.
*/
updatesEnd : {n, k, ix, a} (fin n, fin ix, fin k) => [n]a -> [k][ix] -> [k]a -> [n]a
updatesEnd xs0 idxs vals = xss!0
where
xss = [ xs0 ] #
[ updateEnd xs i b
| xs <- xss
| i <- idxs
| b <- vals
]
/**
* A finite sequence counting up from 'first' to 'last'.
*
* '[a..b]' is syntactic sugar for 'fromTo`{first=a,last=b}'.
*/
primitive fromTo : {first, last, a} (fin last, last >= first, Literal last a) =>
[1 + (last - first)]a
/**
* A finite arithmetic sequence starting with 'first' and 'next',
* stopping when the values reach or would skip over 'last'.
*
* '[a,b..c]' is syntactic sugar for 'fromThenTo`{first=a,next=b,last=c}'.
*/
primitive fromThenTo : {first, next, last, a, len}
( fin first, fin next, fin last
, Literal first a, Literal next a, Literal last a
, first != next
, lengthFromThenTo first next last == len) => [len]a
/**
* An infinite sequence counting up from the given starting value.
* '[x...]' is syntactic sugar for 'infFrom x'.
*/
primitive infFrom : {a} (Arith a) => a -> [inf]a
/**
* An infinite arithmetic sequence starting with the given two values.
* '[x,y...]' is syntactic sugar for 'infFromThen x y'.
*/
primitive infFromThen : {a} (Arith a) => a -> a -> [inf]a
/**
* Produce a sequence using a generating function.
* Satisfies 'generate f @ i == f i' for all 'i' between '0' and 'n-1'.
*
* Declarations of the form 'x @ i = e' are syntactic sugar for
* 'x = generate (\i -> e)'.
*/
generate : {n, ix, a}
(fin ix, n >= 1, ix >= width (n - 1)) => ([ix] -> a) -> [n]a
generate f = [ f i | i <- [0 .. n-1] ]
primitive error : {a, len} (fin len) => [len][8] -> a
/**
* Performs multiplication of polynomials over GF(2).
*/
pmult : {u, v} (fin u, fin v) => [1 + u] -> [1 + v] -> [1 + u + v]
pmult x y = last zs
where
zs = [0] # [ (z << 1) ^ (if yi then 0 # x else 0) | yi <- y | z <- zs ]
/**
* Performs division of polynomials over GF(2).
*/
pdiv : {u, v} (fin u, fin v) => [u] -> [v] -> [u]
pdiv x y = [ z ! degree | z <- zs ]
where
degree : [width v]
degree = last (ds : [1 + v]_)
where ds = [0/0] # [if yi then i else d | yi <- reverse y | i <- [0..v] | d <- ds ]
reduce : [v] -> [v]
reduce u = if u ! degree then u ^ y else u
zs : [u][v]
zs = [ tail (reduce z # [xi]) | z <- [0] # zs | xi <- x ]
/**
* Performs modulus of polynomials over GF(2).
*/
pmod : {u, v} (fin u, fin v) => [u] -> [1 + v] -> [v]
pmod x y = if y == 0 then 0/0 else last zs
where
degree : [width v]
degree = last (ds : [2 + v]_)
where ds = [0/0] # [if yi then i else d | yi <- reverse y | i <- [0..v] | d <- ds ]
reduce : [1 + v] -> [1 + v]
reduce u = if u ! degree then u ^ y else u
powers : [inf][1 + v]
powers = [reduce 1] # [ reduce (p << 1) | p <- powers ]
zs = [0] # [ z ^ (if xi then tail p else 0) | xi <- reverse x | p <- powers | z <- zs ]
/**
* Generates random values from a seed. When called with a function, currently
* generates a function that always returns zero.
*/
primitive random : {a} [256] -> a
type String n = [n][8]
type Word n = [n]
type Char = [8]
take : {front, back, a} (fin front) => [front + back]a -> [front]a
take (x # _) = x
drop : {front, back, a} (fin front) => [front + back]a -> [back]a
drop ((_ : [front] _) # y) = y
tail : {n, a} [1 + n]a -> [n]a
tail xs = drop`{1} xs
/**
* Return the left-most element of a sequence.
*/
head : {n, a} [1 + n]a -> a
head xs = xs @ 0
/**
* Return the right-most element of a sequence.
*/
last : {n, a} (fin n) => [1 + n]a -> a
last xs = xs ! 0
/**
* Return the length of a sequence. Note that the result depends only
* on the type of the argument, not its value.
*/
length : {n, a, b} (fin n, Literal n b) => [n]a -> b
length _ = `n
undefined : {a} a
undefined = error "undefined"
groupBy : {each, parts, a} (fin each) => [parts * each]a -> [parts][each]a
groupBy = split`{parts=parts}
/**
* Define the base 2 logarithm function in terms of width
*/
type lg2 n = width (max n 1 - 1)
/**
* Debugging function for tracing. The first argument is a string,
* which is prepended to the printed value of the second argument.
* This combined string is then printed when the trace function is
* evaluated. The return value is equal to the third argument.
*
* The exact timing and number of times the trace message is printed
* depend on the internal details of the Cryptol evaluation order,
* which are unspecified. Thus, the output produced by this
* operation may be difficult to predict.
*/
primitive trace : {n, a, b} (fin n) => [n][8] -> a -> b -> b
/**
* Debugging function for tracing values. The first argument is a string,
* which is prepended to the printed value of the second argument.
* This combined string is then printed when the trace function is
* evaluated. The return value is equal to the second argument.
*
* The exact timing and number of times the trace message is printed
* depend on the internal details of the Cryptol evaluation order,
* which are unspecified. Thus, the output produced by this
* operation may be difficult to predict.
*/
traceVal : {n, a} (fin n) => [n][8] -> a -> a
traceVal msg x = trace msg x x
/* Functions previously in Cryptol::Extras */
/**
* Conjunction of all bits in a sequence.
*/
and : {n} (fin n) => [n]Bit -> Bit
and xs = ~zero == xs
/**
* Disjunction of all bits in a sequence.
*/
or : {n} (fin n) => [n]Bit -> Bit
or xs = zero != xs
/**
* Conjunction after applying a predicate to all elements.
*/
all : {n, a} (fin n) => (a -> Bit) -> [n]a -> Bit
all f xs = and (map f xs)
/**
* Disjunction after applying a predicate to all elements.
*/
any : {n, a} (fin n) => (a -> Bit) -> [n]a -> Bit
any f xs = or (map f xs)
/**
* Map a function over a sequence.
*/
map : {n, a, b} (a -> b) -> [n]a -> [n]b
map f xs = [f x | x <- xs]
/**
* Functional left fold.
*
* foldl (+) 0 [1,2,3] = ((0 + 1) + 2) + 3
*/
foldl : {n, a, b} (fin n) => (a -> b -> a) -> a -> [n]b -> a
foldl f acc xs = ys ! 0
where ys = [acc] # [f a x | a <- ys | x <- xs]
/**
* Functional right fold.
*
* foldr (-) 0 [1,2,3] = 0 - (1 - (2 - 3))
*/
foldr : {n, a, b} (fin n) => (a -> b -> b) -> b -> [n]a -> b
foldr f acc xs = ys ! 0
where ys = [acc] # [f x a | a <- ys | x <- reverse xs]
/**
* Compute the sum of the values in the sequence.
*/
sum : {n, a} (fin n, Arith a) => [n]a -> a
sum xs = foldl (+) (fromInteger 0) xs
/**
* Scan left is like a foldl that also emits the intermediate values.
*/
scanl : {n, b, a} (b -> a -> b) -> b -> [n]a -> [n+1]b
scanl f acc xs = ys
where ys = [acc] # [f a x | a <- ys | x <- xs]
/**
* Scan right is like a foldr that also emits the intermediate values.
*/
scanr : {n, a, b} (fin n) => (a -> b -> b) -> b -> [n]a -> [n+1]b
scanr f acc xs = reverse ys
where ys = [acc] # [f x a | a <- ys | x <- reverse xs]
/**
* Repeat a value.
*/
repeat : {n, a} a -> [n]a
repeat x = [ x | _ <- zero : [n] ]
/**
* 'elem x xs' returns true if x is equal to a value in xs.
*/
elem : {n, a} (fin n, Cmp a) => a -> [n]a -> Bit
elem a xs = any (\x -> x == a) xs
/**
* Create a list of tuples from two lists.
*/
zip : {n, a, b} [n]a -> [n]b -> [n](a, b)
zip xs ys = [(x,y) | x <- xs | y <- ys]
/**
* Create a list by applying the function to each pair of elements in the input.
*/
zipWith : {n, a, b, c} (a -> b -> c) -> [n]a -> [n]b -> [n]c
zipWith f xs ys = [f x y | x <- xs | y <- ys]
/**
* Transform a function into uncurried form.
*/
uncurry : {a, b, c} (a -> b -> c) -> (a, b) -> c
uncurry f = \(a, b) -> f a b
/**
* Transform a function into curried form.
*/
curry : {a, b, c} ((a, b) -> c) -> a -> b -> c
curry f = \a b -> f (a, b)
/**
* Map a function iteratively over a seed value, producing an infinite
* list of successive function applications.
*/
iterate : {a} (a -> a) -> a -> [inf]a
iterate f x = [x] # [ f v | v <- iterate f x ]
cryptol-2.8.0/lib/CryptolTC.z3 0000644 0000000 0000000 00000020367 07346545000 014325 0 ustar 00 0000000 0000000 ; ------------------------------------------------------------------------------
; Basic datatypes
(declare-datatypes ()
( (InfNat (mk-infnat (value Int) (isFin Bool) (isErr Bool)))
)
)
(declare-datatypes ()
( (MaybeBool (mk-mb (prop Bool) (isErrorProp Bool)))
)
)
(define-fun cryBool ((x Bool)) MaybeBool
(mk-mb x false)
)
(define-fun cryErrProp () MaybeBool
(mk-mb false true)
)
(define-fun cryInf () InfNat
(mk-infnat 0 false false)
)
(define-fun cryNat ((x Int)) InfNat
(mk-infnat x true false)
)
(define-fun cryErr () InfNat
(mk-infnat 0 false true)
)
; ------------------------------------------------------------------------------
; Cryptol version of logic
(define-fun cryEq ((x InfNat) (y InfNat)) MaybeBool
(ite (or (isErr x) (isErr y)) cryErrProp (cryBool
(ite (isFin x)
(ite (isFin y) (= (value x) (value y)) false)
(not (isFin y))
)))
)
(define-fun cryNeq ((x InfNat) (y InfNat)) MaybeBool
(ite (or (isErr x) (isErr y)) cryErrProp (cryBool
(ite (isFin x)
(ite (isFin y) (not (= (value x) (value y))) true)
(isFin y)
)))
)
(define-fun cryFin ((x InfNat)) MaybeBool
(ite (isErr x) cryErrProp (cryBool
(isFin x)))
)
(define-fun cryGeq ((x InfNat) (y InfNat)) MaybeBool
(ite (or (isErr x) (isErr y)) cryErrProp (cryBool
(ite (isFin x)
(ite (isFin y) (>= (value x) (value y)) false)
true
)))
)
(define-fun cryAnd ((x MaybeBool) (y MaybeBool)) MaybeBool
(ite (or (isErrorProp x) (isErrorProp y)) cryErrProp
(cryBool (and (prop x) (prop y)))
)
)
(define-fun cryTrue () MaybeBool
(cryBool true)
)
; ------------------------------------------------------------------------------
; Basic Cryptol assume/assert
(define-fun cryVar ((x InfNat)) Bool
(and (not (isErr x)) (>= (value x) 0))
)
(define-fun cryAssume ((x MaybeBool)) Bool
(ite (isErrorProp x) true (prop x))
)
(declare-fun cryUnknown () Bool)
(define-fun cryProve ((x MaybeBool)) Bool
(ite (isErrorProp x) cryUnknown (not (prop x)))
)
; ------------------------------------------------------------------------------
; Arithmetic
(define-fun cryAdd ((x InfNat) (y InfNat)) InfNat
(ite (or (isErr x) (isErr y)) cryErr
(ite (isFin x)
(ite (isFin y) (cryNat (+ (value x) (value y))) cryInf)
cryInf
))
)
(define-fun crySub ((x InfNat) (y InfNat)) InfNat
(ite (or (isErr x) (isErr y) (not (isFin y))) cryErr
(ite (isFin x)
(ite (>= (value x) (value y)) (cryNat (- (value x) (value y))) cryErr)
cryInf
))
)
(define-fun cryMul ((x InfNat) (y InfNat)) InfNat
(ite (or (isErr x) (isErr y)) cryErr
(ite (isFin x)
(ite (isFin y) (cryNat (* (value x) (value y)))
(ite (= (value x) 0) (cryNat 0) cryInf))
(ite (and (isFin y) (= (value y) 0)) (cryNat 0) cryInf)
))
)
(define-fun cryDiv ((x InfNat) (y InfNat)) InfNat
(ite (or (isErr x) (isErr y) (not (isFin x))) cryErr
(ite (isFin y)
(ite (= (value y) 0) cryErr (cryNat (div (value x) (value y))))
(cryNat 0)
))
)
(define-fun cryMod ((x InfNat) (y InfNat)) InfNat
(ite (or (isErr x) (isErr y) (not (isFin x))) cryErr
(ite (isFin y)
(ite (= (value y) 0) cryErr (cryNat (mod (value x) (value y))))
x
))
)
(define-fun cryMin ((x InfNat) (y InfNat)) InfNat
(ite (or (isErr x) (isErr y)) cryErr
(ite (isFin x)
(ite (isFin y)
(ite (<= (value x) (value y)) x y)
x)
y
))
)
(define-fun cryMax ((x InfNat) (y InfNat)) InfNat
(ite (or (isErr x) (isErr y)) cryErr
(ite (isFin x)
(ite (isFin y)
(ite (<= (value x) (value y)) y x)
y)
x
))
)
(declare-fun cryWidthUnknown (Int) Int)
; Some axioms about cryWidthUnknown
(define-fun k_2_to_64 () Int 18446744073709551616)
(define-fun k_2_to_65 () Int 36893488147419103232)
(assert (forall ((x Int)) (or (> (cryWidthUnknown x) 64) (< x k_2_to_64))))
(assert (forall ((x Int)) (or (> x (cryWidthUnknown x)) (< x k_2_to_64))))
; This helps the #548 property
(assert (forall ((x Int)) (or (>= 65 (cryWidthUnknown x)) (>= x k_2_to_65))))
(assert (forall ((x Int) (y Int))
(=> (>= x y)
(>= (cryWidthUnknown x) (cryWidthUnknown y)))))
; this helps #548. It seems to be quite slow, however.
; (assert (forall ((x Int) (y Int))
; (=>
; (> y (cryWidthUnknown x))
; (>= y (cryWidthUnknown (* 2 x)))
; )
; ))
(define-fun cryWidthTable ((x Int)) Int
(ite (< x 1) 0
(ite (< x 2) 1
(ite (< x 4) 2
(ite (< x 8) 3
(ite (< x 16) 4
(ite (< x 32) 5
(ite (< x 64) 6
(ite (< x 128) 7
(ite (< x 256) 8
(ite (< x 512) 9
(ite (< x 1024) 10
(ite (< x 2048) 11
(ite (< x 4096) 12
(ite (< x 8192) 13
(ite (< x 16384) 14
(ite (< x 32768) 15
(ite (< x 65536) 16
(ite (< x 131072) 17
(ite (< x 262144) 18
(ite (< x 524288) 19
(ite (< x 1048576) 20
(ite (< x 2097152) 21
(ite (< x 4194304) 22
(ite (< x 8388608) 23
(ite (< x 16777216) 24
(ite (< x 33554432) 25
(ite (< x 67108864) 26
(ite (< x 134217728) 27
(ite (< x 268435456) 28
(ite (< x 536870912) 29
(ite (< x 1073741824) 30
(ite (< x 2147483648) 31
(ite (< x 4294967296) 32
(ite (< x 8589934592) 33
(ite (< x 17179869184) 34
(ite (< x 34359738368) 35
(ite (< x 68719476736) 36
(ite (< x 137438953472) 37
(ite (< x 274877906944) 38
(ite (< x 549755813888) 39
(ite (< x 1099511627776) 40
(ite (< x 2199023255552) 41
(ite (< x 4398046511104) 42
(ite (< x 8796093022208) 43
(ite (< x 17592186044416) 44
(ite (< x 35184372088832) 45
(ite (< x 70368744177664) 46
(ite (< x 140737488355328) 47
(ite (< x 281474976710656) 48
(ite (< x 562949953421312) 49
(ite (< x 1125899906842624) 50
(ite (< x 2251799813685248) 51
(ite (< x 4503599627370496) 52
(ite (< x 9007199254740992) 53
(ite (< x 18014398509481984) 54
(ite (< x 36028797018963968) 55
(ite (< x 72057594037927936) 56
(ite (< x 144115188075855872) 57
(ite (< x 288230376151711744) 58
(ite (< x 576460752303423488) 59
(ite (< x 1152921504606846976) 60
(ite (< x 2305843009213693952) 61
(ite (< x 4611686018427387904) 62
(ite (< x 9223372036854775808) 63
(ite (< x 18446744073709551616) 64
(cryWidthUnknown x))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
)
(define-fun cryWidth ((x InfNat)) InfNat
(ite (isErr x) cryErr
(ite (isFin x) (cryNat (cryWidthTable (value x)))
cryInf
))
)
(declare-fun cryExpUnknown (Int Int) Int)
(define-fun cryExpTable ((x Int) (y Int)) Int
(ite (= y 0) 1
(ite (= y 1) x
(ite (= x 0) 0
(cryExpUnknown x y))))
)
(define-fun cryExp ((x InfNat) (y InfNat)) InfNat
(ite (or (isErr x) (isErr y)) cryErr
(ite (isFin x)
(ite (isFin y)
(cryNat (cryExpTable (value x) (value y)))
(ite (< (value x) 2) x cryInf))
(ite (isFin y)
(ite (= (value y) 0) (cryNat 1) cryInf)
cryInf)
))
)
(define-fun cryCeilDiv ((x InfNat) (y InfNat)) InfNat
(ite (or (isErr x) (isErr y) (not (isFin x)) (not (isFin y))) cryErr
(ite (= (value y) 0) cryErr (cryNat (- (div (- (value x)) (value y)))))
)
)
(define-fun cryCeilMod ((x InfNat) (y InfNat)) InfNat
(ite (or (isErr x) (isErr y) (not (isFin x)) (not (isFin y))) cryErr
(ite (= (value y) 0) cryErr (cryNat (mod (- (value x)) (value y))))
)
)
(define-fun cryLenFromThenTo ((x InfNat) (y InfNat) (z InfNat)) InfNat
(ite (or (isErr x) (not (isFin x))
(isErr y) (not (isFin y))
(isErr z) (not (isFin z))
(= (value x) (value y))) cryErr (cryNat
(ite (> (value x) (value y))
(ite (> (value z) (value x)) 0 (+ (div (- (value x) (value z))
(- (value x) (value y))) 1))
(ite (< (value z) (value x)) 0 (+ (div (- (value z) (value x))
(- (value y) (value x))) 1))
)))
)
; ---
; (declare-fun L () InfNat)
; (declare-fun w () InfNat)
;
; (assert (cryVar L))
; (assert (cryVar w))
;
; (assert (cryAssume (cryFin w)))
; (assert (cryAssume (cryGeq w (cryNat 1))))
; (assert (cryAssume (cryGeq (cryMul (cryNat 2) w) (cryWidth L))))
;
; (assert (cryProve
; (cryGeq
; (cryMul
; (cryCeilDiv
; (cryAdd (cryNat 1) (cryAdd L (cryMul (cryNat 2) w)))
; (cryMul (cryNat 16) w))
; (cryMul (cryNat 16) w))
; (cryAdd (cryNat 1) (cryAdd L (cryMul (cryNat 2) w))))))
;
; (check-sat)
cryptol-2.8.0/src/Cryptol/ 0000755 0000000 0000000 00000000000 07346545000 013631 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/Eval.hs 0000644 0000000 0000000 00000054316 07346545000 015065 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Eval
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE PatternGuards #-}
module Cryptol.Eval (
moduleEnv
, runEval
, EvalOpts(..)
, PPOpts(..)
, defaultPPOpts
, Eval
, EvalEnv
, emptyEnv
, evalExpr
, evalDecls
, evalSel
, evalSetSel
, EvalError(..)
, forceValue
) where
import Cryptol.Eval.Env
import Cryptol.Eval.Monad
import Cryptol.Eval.Type
import Cryptol.Eval.Value
import Cryptol.Parser.Selector(ppSelector)
import Cryptol.ModuleSystem.Name
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.PP
import Control.Monad
import qualified Data.Sequence as Seq
import Data.List
import Data.Maybe
import qualified Data.Map.Strict as Map
import Data.Semigroup
import Prelude ()
import Prelude.Compat
type EvalEnv = GenEvalEnv Bool BV Integer
-- Expression Evaluation -------------------------------------------------------
-- | Extend the given evaluation environment with all the declarations
-- contained in the given module.
moduleEnv :: EvalPrims b w i
=> Module -- ^ Module containing declarations to evaluate
-> GenEvalEnv b w i -- ^ Environment to extend
-> Eval (GenEvalEnv b w i)
moduleEnv m env = evalDecls (mDecls m) =<< evalNewtypes (mNewtypes m) env
-- | Evaluate a Cryptol expression to a value. This evaluator is parameterized
-- by the `EvalPrims` class, which defines the behavior of bits and words, in
-- addition to providing implementations for all the primitives.
evalExpr :: EvalPrims b w i
=> GenEvalEnv b w i -- ^ Evaluation environment
-> Expr -- ^ Expression to evaluate
-> Eval (GenValue b w i)
evalExpr env expr = case expr of
-- Try to detect when the user has directly written a finite sequence of
-- literal bit values and pack these into a word.
EList es ty
-- NB, even if the list cannot be packed, we must use `VWord`
-- when the element type is `Bit`.
| isTBit tyv -> {-# SCC "evalExpr->Elist/bit" #-}
return $ VWord len $
case tryFromBits vs of
Just w -> return $ WordVal w
Nothing -> do xs <- mapM (delay Nothing) vs
return $ BitsVal $ Seq.fromList $ map (fromVBit <$>) xs
| otherwise -> {-# SCC "evalExpr->EList" #-} do
xs <- mapM (delay Nothing) vs
return $ VSeq len $ finiteSeqMap xs
where
tyv = evalValType (envTypes env) ty
vs = map (evalExpr env) es
len = genericLength es
ETuple es -> {-# SCC "evalExpr->ETuple" #-} do
xs <- mapM (delay Nothing . eval) es
return $ VTuple xs
ERec fields -> {-# SCC "evalExpr->ERec" #-} do
xs <- sequence [ do thk <- delay Nothing (eval e)
return (f, thk)
| (f, e) <- fields
]
return $ VRecord xs
ESel e sel -> {-# SCC "evalExpr->ESel" #-} do
x <- eval e
evalSel x sel
ESet e sel v -> {-# SCC "evalExpr->ESet" #-}
do x <- eval e
evalSetSel x sel (eval v)
EIf c t f -> {-# SCC "evalExpr->EIf" #-} do
b <- fromVBit <$> eval c
iteValue b (eval t) (eval f)
EComp n t h gs -> {-# SCC "evalExpr->EComp" #-} do
let len = evalNumType (envTypes env) n
let elty = evalValType (envTypes env) t
evalComp env len elty h gs
EVar n -> {-# SCC "evalExpr->EVar" #-} do
case lookupVar n env of
Just val -> val
Nothing -> do
envdoc <- ppEnv defaultPPOpts env
panic "[Eval] evalExpr"
["var `" ++ show (pp n) ++ "` is not defined"
, show envdoc
]
ETAbs tv b -> {-# SCC "evalExpr->ETAbs" #-}
case tpKind tv of
KType -> return $ VPoly $ \ty -> evalExpr (bindType (tpVar tv) (Right ty) env) b
KNum -> return $ VNumPoly $ \n -> evalExpr (bindType (tpVar tv) (Left n) env) b
k -> panic "[Eval] evalExpr" ["invalid kind on type abstraction", show k]
ETApp e ty -> {-# SCC "evalExpr->ETApp" #-} do
eval e >>= \case
VPoly f -> f $! (evalValType (envTypes env) ty)
VNumPoly f -> f $! (evalNumType (envTypes env) ty)
val -> do vdoc <- ppV val
panic "[Eval] evalExpr"
["expected a polymorphic value"
, show vdoc, show (pp e), show (pp ty)
]
EApp f x -> {-# SCC "evalExpr->EApp" #-} do
eval f >>= \case
VFun f' -> f' (eval x)
it -> do itdoc <- ppV it
panic "[Eval] evalExpr" ["not a function", show itdoc ]
EAbs n _ty b -> {-# SCC "evalExpr->EAbs" #-}
return $ VFun (\v -> do env' <- bindVar n v env
evalExpr env' b)
-- XXX these will likely change once there is an evidence value
EProofAbs _ e -> evalExpr env e
EProofApp e -> evalExpr env e
EWhere e ds -> {-# SCC "evalExpr->EWhere" #-} do
env' <- evalDecls ds env
evalExpr env' e
where
{-# INLINE eval #-}
eval = evalExpr env
ppV = ppValue defaultPPOpts
-- Newtypes --------------------------------------------------------------------
evalNewtypes :: EvalPrims b w i
=> Map.Map Name Newtype
-> GenEvalEnv b w i
-> Eval (GenEvalEnv b w i)
evalNewtypes nts env = foldM (flip evalNewtype) env $ Map.elems nts
-- | Introduce the constructor function for a newtype.
evalNewtype :: EvalPrims b w i
=> Newtype
-> GenEvalEnv b w i
-> Eval (GenEvalEnv b w i)
evalNewtype nt = bindVar (ntName nt) (return (foldr tabs con (ntParams nt)))
where
tabs _tp body = tlam (\ _ -> body)
con = VFun id
-- Declarations ----------------------------------------------------------------
-- | Extend the given evaluation environment with the result of evaluating the
-- given collection of declaration groups.
evalDecls :: EvalPrims b w i
=> [DeclGroup] -- ^ Declaration groups to evaluate
-> GenEvalEnv b w i -- ^ Environment to extend
-> Eval (GenEvalEnv b w i)
evalDecls dgs env = foldM evalDeclGroup env dgs
evalDeclGroup :: EvalPrims b w i
=> GenEvalEnv b w i
-> DeclGroup
-> Eval (GenEvalEnv b w i)
evalDeclGroup env dg = do
case dg of
Recursive ds -> do
-- declare a "hole" for each declaration
-- and extend the evaluation environment
holes <- mapM declHole ds
let holeEnv = Map.fromList $ [ (nm,h) | (nm,_,h,_) <- holes ]
let env' = env `mappend` emptyEnv{ envVars = holeEnv }
-- evaluate the declaration bodies, building a new evaluation environment
env'' <- foldM (evalDecl env') env ds
-- now backfill the holes we declared earlier using the definitions
-- calculated in the previous step
mapM_ (fillHole env'') holes
-- return the map containing the holes
return env'
NonRecursive d -> do
evalDecl env env d
-- | This operation is used to complete the process of setting up recursive declaration
-- groups. It 'backfills' previously-allocated thunk values with the actual evaluation
-- procedure for the body of recursive definitions.
--
-- In order to faithfully evaluate the nonstrict semantics of Cryptol, we have to take some
-- care in this process. In particular, we need to ensure that every recursive definition
-- binding is indistinguishable from its eta-expanded form. The straightforward solution
-- to this is to force an eta-expansion procedure on all recursive definitions.
-- However, for the so-called 'Value' types we can instead optimistically use the 'delayFill'
-- operation and only fall back on full eta expansion if the thunk is double-forced.
fillHole :: BitWord b w i
=> GenEvalEnv b w i
-> (Name, Schema, Eval (GenValue b w i), Eval (GenValue b w i) -> Eval ())
-> Eval ()
fillHole env (nm, sch, _, fill) = do
case lookupVar nm env of
Nothing -> evalPanic "fillHole" ["Recursive definition not completed", show (ppLocName nm)]
Just x
| isValueType env sch -> fill =<< delayFill x (etaDelay (show (ppLocName nm)) env sch x)
| otherwise -> fill (etaDelay (show (ppLocName nm)) env sch x)
-- | 'Value' types are non-polymorphic types recursive constructed from
-- bits, finite sequences, tuples and records. Types of this form can
-- be implemented rather more efficently than general types because we can
-- rely on the 'delayFill' operation to build a thunk that falls back on performing
-- eta-expansion rather than doing it eagerly.
isValueType :: GenEvalEnv b w i -> Schema -> Bool
isValueType env Forall{ sVars = [], sProps = [], sType = t0 }
= go (evalValType (envTypes env) t0)
where
go TVBit = True
go (TVSeq _ x) = go x
go (TVTuple xs) = and (map go xs)
go (TVRec xs) = and (map (go . snd) xs)
go _ = False
isValueType _ _ = False
-- | Eta-expand a word value. This forces an unpacked word representation.
etaWord :: BitWord b w i
=> Integer
-> Eval (GenValue b w i)
-> Eval (WordValue b w i)
etaWord n x = do
w <- delay Nothing (fromWordVal "during eta-expansion" =<< x)
return $ BitsVal $ Seq.fromFunction (fromInteger n) $ \i ->
do w' <- w; indexWordValue w' (toInteger i)
-- | Given a simulator value and its type, fully eta-expand the value. This
-- is a type-directed pass that always produces a canonical value of the
-- expected shape. Eta expansion of values is sometimes necessary to ensure
-- the correct evaluation semantics of recursive definitions. Otherwise,
-- expressions that should be expected to produce well-defined values in the
-- denotational semantics will fail to terminate instead.
etaDelay :: BitWord b w i
=> String
-> GenEvalEnv b w i
-> Schema
-> Eval (GenValue b w i)
-> Eval (GenValue b w i)
etaDelay msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0
where
goTpVars env [] x = go (evalValType (envTypes env) tp0) x
goTpVars env (v:vs) x =
case tpKind v of
KType -> return $ VPoly $ \t ->
goTpVars (bindType (tpVar v) (Right t) env) vs ( ($t) . fromVPoly =<< x )
KNum -> return $ VNumPoly $ \n ->
goTpVars (bindType (tpVar v) (Left n) env) vs ( ($n) . fromVNumPoly =<< x )
k -> panic "[Eval] etaDelay" ["invalid kind on type abstraction", show k]
go tp (Ready x) =
case x of
VBit _ -> return x
VInteger _ -> return x
VWord _ _ -> return x
VSeq n xs
| TVSeq _nt el <- tp
-> return $ VSeq n $ IndexSeqMap $ \i -> go el (lookupSeqMap xs i)
VStream xs
| TVStream el <- tp
-> return $ VStream $ IndexSeqMap $ \i -> go el (lookupSeqMap xs i)
VTuple xs
| TVTuple ts <- tp
-> return $ VTuple (zipWith go ts xs)
VRecord fs
| TVRec fts <- tp
-> return $ VRecord $
let err f = evalPanic "expected record value with field" [show f] in
[ (f, go (fromMaybe (err f) (lookup f fts)) y)
| (f, y) <- fs
]
VFun f
| TVFun _t1 t2 <- tp
-> return $ VFun $ \a -> go t2 (f a)
_ -> evalPanic "type mismatch during eta-expansion" []
go tp x =
case tp of
TVBit -> x
TVInteger -> x
TVIntMod _ -> x
TVSeq n TVBit ->
do w <- delayFill (fromWordVal "during eta-expansion" =<< x) (etaWord n x)
return $ VWord n w
TVSeq n el ->
do x' <- delay (Just msg) (fromSeq "during eta-expansion" =<< x)
return $ VSeq n $ IndexSeqMap $ \i -> do
go el (flip lookupSeqMap i =<< x')
TVStream el ->
do x' <- delay (Just msg) (fromSeq "during eta-expansion" =<< x)
return $ VStream $ IndexSeqMap $ \i ->
go el (flip lookupSeqMap i =<< x')
TVFun _t1 t2 ->
do x' <- delay (Just msg) (fromVFun <$> x)
return $ VFun $ \a -> go t2 ( ($a) =<< x' )
TVTuple ts ->
do let n = length ts
x' <- delay (Just msg) (fromVTuple <$> x)
return $ VTuple $
[ go t =<< (flip genericIndex i <$> x')
| i <- [0..(n-1)]
| t <- ts
]
TVRec fs ->
do x' <- delay (Just msg) (fromVRecord <$> x)
let err f = evalPanic "expected record value with field" [show f]
return $ VRecord $
[ (f, go t =<< (fromMaybe (err f) . lookup f <$> x'))
| (f,t) <- fs
]
TVAbstract {} -> x
declHole :: Decl
-> Eval (Name, Schema, Eval (GenValue b w i), Eval (GenValue b w i) -> Eval ())
declHole d =
case dDefinition d of
DPrim -> evalPanic "Unexpected primitive declaration in recursive group"
[show (ppLocName nm)]
DExpr _ -> do
(hole, fill) <- blackhole msg
return (nm, sch, hole, fill)
where
nm = dName d
sch = dSignature d
msg = unwords ["<> while evaluating", show (pp nm)]
-- | Evaluate a declaration, extending the evaluation environment.
-- Two input environments are given: the first is an environment
-- to use when evaluating the body of the declaration; the second
-- is the environment to extend. There are two environments to
-- handle the subtle name-binding issues that arise from recursive
-- definitions. The 'read only' environment is used to bring recursive
-- names into scope while we are still defining them.
evalDecl :: EvalPrims b w i
=> GenEvalEnv b w i -- ^ A 'read only' environment for use in declaration bodies
-> GenEvalEnv b w i -- ^ An evaluation environment to extend with the given declaration
-> Decl -- ^ The declaration to evaluate
-> Eval (GenEvalEnv b w i)
evalDecl renv env d =
case dDefinition d of
DPrim -> case evalPrim d of
Just v -> pure (bindVarDirect (dName d) v env)
Nothing -> bindVar (dName d) (cryNoPrimError (dName d)) env
DExpr e -> bindVar (dName d) (evalExpr renv e) env
-- Selectors -------------------------------------------------------------------
-- | Apply the the given "selector" form to the given value. This function pushes
-- tuple and record selections pointwise down into other value constructs
-- (e.g., streams and functions).
evalSel :: forall b w i
. EvalPrims b w i
=> GenValue b w i
-> Selector
-> Eval (GenValue b w i)
evalSel val sel = case sel of
TupleSel n _ -> tupleSel n val
RecordSel n _ -> recordSel n val
ListSel ix _ -> listSel ix val
where
tupleSel n v =
case v of
VTuple vs -> vs !! n
_ -> do vdoc <- ppValue defaultPPOpts v
evalPanic "Cryptol.Eval.evalSel"
[ "Unexpected value in tuple selection"
, show vdoc ]
recordSel n v =
case v of
VRecord {} -> lookupRecord n v
_ -> do vdoc <- ppValue defaultPPOpts v
evalPanic "Cryptol.Eval.evalSel"
[ "Unexpected value in record selection"
, show vdoc ]
listSel n v =
case v of
VSeq _ vs -> lookupSeqMap vs (toInteger n)
VStream vs -> lookupSeqMap vs (toInteger n)
VWord _ wv -> VBit <$> (flip indexWordValue (toInteger n) =<< wv)
_ -> do vdoc <- ppValue defaultPPOpts val
evalPanic "Cryptol.Eval.evalSel"
[ "Unexpected value in list selection"
, show vdoc ]
evalSetSel :: forall b w i. EvalPrims b w i =>
GenValue b w i -> Selector -> Eval (GenValue b w i) -> Eval (GenValue b w i)
evalSetSel e x v =
case x of
TupleSel n _ -> setTuple n
RecordSel n _ -> setRecord n
ListSel ix _ -> setList (toInteger ix)
where
bad msg =
do ed <- ppValue defaultPPOpts e
evalPanic "Cryptol.Eval.evalSetSel"
[ msg
, "Selector: " ++ show (ppSelector x)
, "Value: " ++ show ed
]
setTuple n =
case e of
VTuple xs ->
case splitAt n xs of
(as, _: bs) -> pure (VTuple (as ++ v : bs))
_ -> bad "Tuple update out of bounds."
_ -> bad "Tuple update on a non-tuple."
setRecord n =
case e of
VRecord xs ->
case break ((n ==) . fst) xs of
(as, (i,_) : bs) -> pure (VRecord (as ++ (i,v) : bs))
_ -> bad "Missing field in record update."
_ -> bad "Record update on a non-record."
setList n =
case e of
VSeq i mp -> pure $ VSeq i $ updateSeqMap mp n v
VStream mp -> pure $ VStream $ updateSeqMap mp n v
VWord i m -> pure $ VWord i $ do m1 <- m
updateWordValue m1 n asBit
_ -> bad "Sequence update on a non-sequence."
asBit = do res <- v
case res of
VBit b -> pure b
_ -> bad "Expected a bit, but got something else"
-- List Comprehension Environments ---------------------------------------------
-- | Evaluation environments for list comprehensions: Each variable
-- name is bound to a list of values, one for each element in the list
-- comprehension.
data ListEnv b w i = ListEnv
{ leVars :: !(Map.Map Name (Integer -> Eval (GenValue b w i)))
-- ^ Bindings whose values vary by position
, leStatic :: !(Map.Map Name (Eval (GenValue b w i)))
-- ^ Bindings whose values are constant
, leTypes :: !TypeEnv
}
instance Semigroup (ListEnv b w i) where
l <> r = ListEnv
{ leVars = Map.union (leVars l) (leVars r)
, leStatic = Map.union (leStatic l) (leStatic r)
, leTypes = Map.union (leTypes l) (leTypes r)
}
instance Monoid (ListEnv b w i) where
mempty = ListEnv
{ leVars = Map.empty
, leStatic = Map.empty
, leTypes = Map.empty
}
mappend l r = l <> r
toListEnv :: GenEvalEnv b w i -> ListEnv b w i
toListEnv e =
ListEnv
{ leVars = mempty
, leStatic = envVars e
, leTypes = envTypes e
}
-- | Evaluate a list environment at a position.
-- This choses a particular value for the varying
-- locations.
evalListEnv :: ListEnv b w i -> Integer -> GenEvalEnv b w i
evalListEnv (ListEnv vm st tm) i =
let v = fmap ($i) vm
in EvalEnv{ envVars = Map.union v st
, envTypes = tm
}
bindVarList :: Name
-> (Integer -> Eval (GenValue b w i))
-> ListEnv b w i
-> ListEnv b w i
bindVarList n vs lenv = lenv { leVars = Map.insert n vs (leVars lenv) }
-- List Comprehensions ---------------------------------------------------------
-- | Evaluate a comprehension.
evalComp :: EvalPrims b w i
=> GenEvalEnv b w i -- ^ Starting evaluation environment
-> Nat' -- ^ Length of the comprehension
-> TValue -- ^ Type of the comprehension elements
-> Expr -- ^ Head expression of the comprehension
-> [[Match]] -- ^ List of parallel comprehension branches
-> Eval (GenValue b w i)
evalComp env len elty body ms =
do lenv <- mconcat <$> mapM (branchEnvs (toListEnv env)) ms
mkSeq len elty <$> memoMap (IndexSeqMap $ \i -> do
evalExpr (evalListEnv lenv i) body)
-- | Turn a list of matches into the final environments for each iteration of
-- the branch.
branchEnvs :: EvalPrims b w i
=> ListEnv b w i
-> [Match]
-> Eval (ListEnv b w i)
branchEnvs env matches = foldM evalMatch env matches
-- | Turn a match into the list of environments it represents.
evalMatch :: EvalPrims b w i
=> ListEnv b w i
-> Match
-> Eval (ListEnv b w i)
evalMatch lenv m = case m of
-- many envs
From n l _ty expr ->
case len of
-- Select from a sequence of finite length. This causes us to 'stutter'
-- through our previous choices `nLen` times.
Nat nLen -> do
vss <- memoMap $ IndexSeqMap $ \i -> evalExpr (evalListEnv lenv i) expr
let stutter xs = \i -> xs (i `div` nLen)
let lenv' = lenv { leVars = fmap stutter (leVars lenv) }
let vs i = do let (q, r) = i `divMod` nLen
lookupSeqMap vss q >>= \case
VWord _ w -> VBit <$> (flip indexWordValue r =<< w)
VSeq _ xs' -> lookupSeqMap xs' r
VStream xs' -> lookupSeqMap xs' r
_ -> evalPanic "evalMatch" ["Not a list value"]
return $ bindVarList n vs lenv'
-- Select from a sequence of infinite length. Note that this means we
-- will never need to backtrack into previous branches. Thus, we can convert
-- `leVars` elements of the comprehension environment into `leStatic` elements
-- by selecting out the 0th element.
Inf -> do
let allvars = Map.union (fmap ($0) (leVars lenv)) (leStatic lenv)
let lenv' = lenv { leVars = Map.empty
, leStatic = allvars
}
let env = EvalEnv allvars (leTypes lenv)
xs <- evalExpr env expr
let vs i = case xs of
VWord _ w -> VBit <$> (flip indexWordValue i =<< w)
VSeq _ xs' -> lookupSeqMap xs' i
VStream xs' -> lookupSeqMap xs' i
_ -> evalPanic "evalMatch" ["Not a list value"]
return $ bindVarList n vs lenv'
where
len = evalNumType (leTypes lenv) l
-- XXX we don't currently evaluate these as though they could be recursive, as
-- they are typechecked that way; the read environment to evalExpr is the same
-- as the environment to bind a new name in.
Let d -> return $ bindVarList (dName d) (\i -> f (evalListEnv lenv i)) lenv
where
f env =
case dDefinition d of
DPrim -> evalPanic "evalMatch" ["Unexpected local primitive"]
DExpr e -> evalExpr env e
cryptol-2.8.0/src/Cryptol/Eval/ 0000755 0000000 0000000 00000000000 07346545000 014520 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/Eval/Arch.hs 0000644 0000000 0000000 00000002155 07346545000 015734 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Eval.Arch
-- Copyright : (c) 2014-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- Architecture-specific parts of the concrete evaluator go here.
{-# LANGUAGE CPP #-}
module Cryptol.Eval.Arch where
-- | This is the widest word we can have before gmp will fail to
-- allocate and bring down the whole program. According to
--
-- the sizes are 2^32-1 for 32-bit, and 2^37 for 64-bit, however
-- experiments show that it's somewhere under 2^37 at least on 64-bit
-- Mac OS X.
maxBigIntWidth :: Integer
#if i386_HOST_ARCH
maxBigIntWidth = 2^(32 :: Integer) - 0x1
#elif x86_64_HOST_ARCH
maxBigIntWidth = 2^(37 :: Integer) - 0x100
#else
-- Because GHC doesn't seem to define a CPP macro that will portably
-- tell us the bit width we're compiling for, fall back on a safe choice
-- for other architectures. If we care about large words on another
-- architecture, we can add a special case for it.
maxBigIntWidth = 2^(32 :: Integer) - 0x1
#endif
cryptol-2.8.0/src/Cryptol/Eval/Env.hs 0000644 0000000 0000000 00000005476 07346545000 015620 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Eval.Env
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.Eval.Env where
import Cryptol.Eval.Monad( Eval, delay, ready, PPOpts )
import Cryptol.Eval.Type
import Cryptol.Eval.Value
import Cryptol.ModuleSystem.Name
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat
import Cryptol.Utils.PP
import qualified Data.Map.Strict as Map
import Data.Semigroup
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
-- Evaluation Environment ------------------------------------------------------
data GenEvalEnv b w i = EvalEnv
{ envVars :: !(Map.Map Name (Eval (GenValue b w i)))
, envTypes :: !TypeEnv
} deriving (Generic, NFData)
instance Semigroup (GenEvalEnv b w i) where
l <> r = EvalEnv
{ envVars = Map.union (envVars l) (envVars r)
, envTypes = Map.union (envTypes l) (envTypes r)
}
instance Monoid (GenEvalEnv b w i) where
mempty = EvalEnv
{ envVars = Map.empty
, envTypes = Map.empty
}
mappend l r = l <> r
ppEnv :: BitWord b w i => PPOpts -> GenEvalEnv b w i -> Eval Doc
ppEnv opts env = brackets . fsep <$> mapM bind (Map.toList (envVars env))
where
bind (k,v) = do vdoc <- ppValue opts =<< v
return (pp k <+> text "->" <+> vdoc)
-- | Evaluation environment with no bindings
emptyEnv :: GenEvalEnv b w i
emptyEnv = mempty
-- | Bind a variable in the evaluation environment.
bindVar :: Name
-> Eval (GenValue b w i)
-> GenEvalEnv b w i
-> Eval (GenEvalEnv b w i)
bindVar n val env = do
let nm = show $ ppLocName n
val' <- delay (Just nm) val
return $ env{ envVars = Map.insert n val' (envVars env) }
-- | Bind a variable to a value in the evaluation environment, without
-- creating a thunk.
bindVarDirect :: Name
-> GenValue b w i
-> GenEvalEnv b w i
-> GenEvalEnv b w i
bindVarDirect n val env = do
env{ envVars = Map.insert n (ready val) (envVars env) }
-- | Lookup a variable in the environment.
{-# INLINE lookupVar #-}
lookupVar :: Name -> GenEvalEnv b w i -> Maybe (Eval (GenValue b w i))
lookupVar n env = Map.lookup n (envVars env)
-- | Bind a type variable of kind *.
{-# INLINE bindType #-}
bindType :: TVar -> Either Nat' TValue -> GenEvalEnv b w i -> GenEvalEnv b w i
bindType p ty env = env { envTypes = Map.insert p ty (envTypes env) }
-- | Lookup a type variable.
{-# INLINE lookupType #-}
lookupType :: TVar -> GenEvalEnv b w i -> Maybe (Either Nat' TValue)
lookupType p env = Map.lookup p (envTypes env)
cryptol-2.8.0/src/Cryptol/Eval/Monad.hs 0000644 0000000 0000000 00000017241 07346545000 016117 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Eval.Monad
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
module Cryptol.Eval.Monad
( -- * Evaluation monad
Eval(..)
, runEval
, EvalOpts(..)
, getEvalOpts
, PPOpts(..)
, io
, delay
, delayFill
, ready
, blackhole
-- * Error reporting
, EvalError(..)
, evalPanic
, typeCannotBeDemoted
, divideByZero
, negativeExponent
, logNegative
, wordTooWide
, cryUserError
, cryLoopError
, cryNoPrimError
, invalidIndex
) where
import Control.DeepSeq
import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import Data.IORef
import Data.Typeable (Typeable)
import qualified Control.Exception as X
import Cryptol.Utils.Panic
import Cryptol.Utils.PP
import Cryptol.Utils.Logger(Logger)
import Cryptol.TypeCheck.AST(Type,Name)
-- | A computation that returns an already-evaluated value.
ready :: a -> Eval a
ready a = Ready a
-- | How to pretty print things when evaluating
data PPOpts = PPOpts
{ useAscii :: Bool
, useBase :: Int
, useInfLength :: Int
}
-- | Some options for evalutaion
data EvalOpts = EvalOpts
{ evalLogger :: Logger -- ^ Where to print stuff (e.g., for @trace@)
, evalPPOpts :: PPOpts -- ^ How to pretty print things.
}
-- | The monad for Cryptol evaluation.
data Eval a
= Ready !a
| Thunk !(EvalOpts -> IO a)
data ThunkState a
= Unforced -- ^ This thunk has not yet been forced
| BlackHole -- ^ This thunk is currently being evaluated
| Forced !(Either EvalError a)
-- ^ This thunk has previously been forced,
-- and has the given value, or evaluation resulted in an error.
-- | Access the evaluation options.
getEvalOpts :: Eval EvalOpts
getEvalOpts = Thunk return
{-# INLINE delay #-}
-- | Delay the given evaluation computation, returning a thunk
-- which will run the computation when forced. Raise a loop
-- error if the resulting thunk is forced during its own evaluation.
delay :: Maybe String -- ^ Optional name to print if a loop is detected
-> Eval a -- ^ Computation to delay
-> Eval (Eval a)
delay _ (Ready a) = Ready (Ready a)
delay msg (Thunk x) = Thunk $ \opts -> do
let msg' = maybe "" ("while evaluating "++) msg
let retry = cryLoopError msg'
r <- newIORef Unforced
return $ unDelay retry r (x opts)
{-# INLINE delayFill #-}
-- | Delay the given evaluation computation, returning a thunk
-- which will run the computation when forced. Run the 'retry'
-- computation instead if the resulting thunk is forced during
-- its own evaluation.
delayFill :: Eval a -- ^ Computation to delay
-> Eval a -- ^ Backup computation to run if a tight loop is detected
-> Eval (Eval a)
delayFill (Ready x) _ = Ready (Ready x)
delayFill (Thunk x) retry = Thunk $ \opts -> do
r <- newIORef Unforced
return $ unDelay retry r (x opts)
-- | Produce a thunk value which can be filled with its associated computation
-- after the fact. A preallocated thunk is returned, along with an operation to
-- fill the thunk with the associated computation.
-- This is used to implement recursive declaration groups.
blackhole :: String -- ^ A name to associate with this thunk.
-> Eval (Eval a, Eval a -> Eval ())
blackhole msg = do
r <- io $ newIORef (fail msg)
let get = join (io $ readIORef r)
let set = io . writeIORef r
return (get, set)
unDelay :: Eval a -> IORef (ThunkState a) -> IO a -> Eval a
unDelay retry r x = do
rval <- io $ readIORef r
case rval of
Forced val -> io (toVal val)
BlackHole ->
retry
Unforced -> io $ do
writeIORef r BlackHole
val <- X.try x
writeIORef r (Forced val)
toVal val
where
toVal mbV = case mbV of
Right a -> pure a
Left e -> X.throwIO e
-- | Execute the given evaluation action.
runEval :: EvalOpts -> Eval a -> IO a
runEval _ (Ready a) = return a
runEval opts (Thunk x) = x opts
{-# INLINE evalBind #-}
evalBind :: Eval a -> (a -> Eval b) -> Eval b
evalBind (Ready a) f = f a
evalBind (Thunk x) f = Thunk $ \opts -> x opts >>= runEval opts . f
instance Functor Eval where
fmap f (Ready x) = Ready (f x)
fmap f (Thunk m) = Thunk $ \opts -> f <$> m opts
{-# INLINE fmap #-}
instance Applicative Eval where
pure = return
(<*>) = ap
{-# INLINE pure #-}
{-# INLINE (<*>) #-}
instance Monad Eval where
return = Ready
fail x = Thunk (\_ -> fail x)
(>>=) = evalBind
{-# INLINE return #-}
{-# INLINE (>>=) #-}
instance MonadIO Eval where
liftIO = io
instance NFData a => NFData (Eval a) where
rnf (Ready a) = rnf a
rnf (Thunk _) = ()
instance MonadFix Eval where
mfix f = Thunk $ \opts -> mfix (\x -> runEval opts (f x))
-- | Lift an 'IO' computation into the 'Eval' monad.
io :: IO a -> Eval a
io m = Thunk (\_ -> m)
{-# INLINE io #-}
-- Errors ----------------------------------------------------------------------
-- | Panic from an @Eval@ context.
evalPanic :: HasCallStack => String -> [String] -> a
evalPanic cxt = panic ("[Eval] " ++ cxt)
-- | Data type describing errors that can occur during evaluation.
data EvalError
= InvalidIndex Integer -- ^ Out-of-bounds index
| TypeCannotBeDemoted Type -- ^ Non-numeric type passed to @number@ function
| DivideByZero -- ^ Division or modulus by 0
| NegativeExponent -- ^ Exponentiation by negative integer
| LogNegative -- ^ Logarithm of a negative integer
| WordTooWide Integer -- ^ Bitvector too large
| UserError String -- ^ Call to the Cryptol @error@ primitive
| LoopError String -- ^ Detectable nontermination
| NoPrim Name -- ^ Primitive with no implementation
deriving (Typeable,Show)
instance PP EvalError where
ppPrec _ e = case e of
InvalidIndex i -> text "invalid sequence index:" <+> integer i
TypeCannotBeDemoted t -> text "type cannot be demoted:" <+> pp t
DivideByZero -> text "division by 0"
NegativeExponent -> text "negative exponent"
LogNegative -> text "logarithm of negative"
WordTooWide w ->
text "word too wide for memory:" <+> integer w <+> text "bits"
UserError x -> text "Run-time error:" <+> text x
LoopError x -> text "<>" <+> text x
NoPrim x -> text "unimplemented primitive:" <+> pp x
instance X.Exception EvalError
-- | For things like @`(inf)@ or @`(0-1)@.
typeCannotBeDemoted :: Type -> a
typeCannotBeDemoted t = X.throw (TypeCannotBeDemoted t)
-- | For division by 0.
divideByZero :: Eval a
divideByZero = io (X.throwIO DivideByZero)
-- | For exponentiation by a negative integer.
negativeExponent :: Eval a
negativeExponent = io (X.throwIO NegativeExponent)
-- | For logarithm of a negative integer.
logNegative :: Eval a
logNegative = io (X.throwIO LogNegative)
-- | For when we know that a word is too wide and will exceed gmp's
-- limits (though words approaching this size will probably cause the
-- system to crash anyway due to lack of memory).
wordTooWide :: Integer -> a
wordTooWide w = X.throw (WordTooWide w)
-- | For the Cryptol @error@ function.
cryUserError :: String -> Eval a
cryUserError msg = io (X.throwIO (UserError msg))
cryNoPrimError :: Name -> Eval a
cryNoPrimError x = io (X.throwIO (NoPrim x))
-- | For cases where we can detect tight loops.
cryLoopError :: String -> Eval a
cryLoopError msg = io (X.throwIO (LoopError msg))
-- | A sequencing operation has gotten an invalid index.
invalidIndex :: Integer -> Eval a
invalidIndex i = io (X.throwIO (InvalidIndex i))
cryptol-2.8.0/src/Cryptol/Eval/Reference.lhs 0000644 0000000 0000000 00000133140 07346545000 017130 0 ustar 00 0000000 0000000 > -- |
> -- Module : Cryptol.Eval.Reference
> -- Description : The reference implementation of the Cryptol evaluation semantics.
> -- Copyright : (c) 2013-2016 Galois, Inc.
> -- License : BSD3
> -- Maintainer : cryptol@galois.com
> -- Stability : provisional
> -- Portability : portable
>
> {-# LANGUAGE PatternGuards #-}
>
> module Cryptol.Eval.Reference
> ( Value(..)
> , evaluate
> , ppValue
> ) where
>
> import Control.Applicative (liftA2)
> import Data.Bits
> import Data.List
> (genericDrop, genericIndex, genericLength, genericReplicate, genericSplitAt,
> genericTake, sortBy)
> import Data.Ord (comparing)
> import Data.Map (Map)
> import qualified Data.Map as Map
> import Data.Semigroup (Semigroup(..))
> import qualified Data.Text as T (pack)
>
> import Cryptol.ModuleSystem.Name (asPrim)
> import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), nAdd, nMin, nMul)
> import Cryptol.TypeCheck.AST
> import Cryptol.Eval.Monad (EvalError(..), PPOpts(..))
> import Cryptol.Eval.Type (TValue(..), isTBit, evalValType, evalNumType, tvSeq)
> import Cryptol.Eval.Value (mkBv, ppBV)
> import Cryptol.Prims.Eval (lg2)
> import Cryptol.Utils.Ident (Ident, mkIdent)
> import Cryptol.Utils.Panic (panic)
> import Cryptol.Utils.PP
>
> import qualified Cryptol.ModuleSystem as M
> import qualified Cryptol.ModuleSystem.Env as M (loadedModules)
Overview
========
This file describes the semantics of the explicitly-typed Cryptol
language (i.e., terms after type checking). Issues related to type
inference, type functions, and type constraints are beyond the scope
of this document.
Cryptol Types
-------------
Cryptol types come in two kinds: numeric types (kind `#`) and value
types (kind `*`). While value types are inhabited by well-typed
Cryptol expressions, numeric types are only used as parameters to
other types; they have no inhabitants. In this implementation we
represent numeric types as values of the Haskell type `Nat'` of
natural numbers with infinity; value types are represented as values
of type `TValue`.
The value types of Cryptol, along with their Haskell representations,
are as follows:
| Cryptol type | Description | `TValue` representation |
|:----------------- |:-------------- |:--------------------------- |
| `Bit` | booleans | `TVBit` |
| `Integer` | integers | `TVInteger` |
| `[n]a` | finite lists | `TVSeq n a` |
| `[inf]a` | infinite lists | `TVStream a` |
| `(a, b, c)` | tuples | `TVTuple [a,b,c]` |
| `{x:a, y:b, z:c}` | records | `TVRec [(x,a),(y,b),(z,c)]` |
| `a -> b` | functions | `TVFun a b` |
We model each Cryptol value type `t` as a complete partial order (cpo)
*M*(`t`). To each Cryptol expression `e : t` we assign a meaning
*M*(`e`) in *M*(`t`); in particular, recursive Cryptol programs of
type `t` are modeled as least fixed points in *M*(`t`). In other words,
this is a domain-theoretic denotational semantics.
Evaluating a Cryptol expression of type `Bit` may result in:
- a defined value `True` or `False`
- a run-time error, or
- non-termination.
Accordingly, *M*(`Bit`) is a flat cpo with values for `True`,
`False`, run-time errors of type `EvalError`, and $\bot$; we
represent it with the Haskell type `Either EvalError Bool`.
Similarly, *M*(`Integer`) is a flat cpo with values for integers,
run-time errors, and $\bot$; we represent it with the Haskell type
`Either EvalError Integer`.
The cpos for lists, tuples, and records are cartesian products. The
cpo ordering is pointwise, and the bottom element $\bot$ is the
list/tuple/record whose elements are all $\bot$. Trivial types `[0]t`,
`()` and `{}` denote single-element cpos where the unique value
`[]`/`()`/`{}` *is* the bottom element $\bot$. *M*(`a -> b`) is the
continuous function space *M*(`a`) $\to$ *M*(`b`).
Type schemas of the form `{a1 ... an} (p1 ... pk) => t` classify
polymorphic values in Cryptol. These are represented with the Haskell
type `Schema`. The meaning of a schema is cpo whose elements are
functions: For each valid instantiation `t1 ... tn` of the type
parameters `a1 ... an` that satisfies the constraints `p1 ... pk`, the
function returns a value in *M*(`t[t1/a1 ... tn/an]`).
Values
------
The Haskell code in this module defines the semantics of typed Cryptol
terms by providing an evaluator to an appropriate `Value` type.
> -- | Value type for the reference evaluator.
> data Value
> = VBit (Either EvalError Bool) -- ^ @ Bit @ booleans
> | VInteger (Either EvalError Integer) -- ^ @ Integer @ integers
> | VList Nat' [Value] -- ^ @ [n]a @ finite or infinite lists
> | VTuple [Value] -- ^ @ ( .. ) @ tuples
> | VRecord [(Ident, Value)] -- ^ @ { .. } @ records
> | VFun (Value -> Value) -- ^ functions
> | VPoly (TValue -> Value) -- ^ polymorphic values (kind *)
> | VNumPoly (Nat' -> Value) -- ^ polymorphic values (kind #)
Invariant: Undefinedness and run-time exceptions are only allowed
inside the argument of a `VBit` or `VInteger` constructor. All other
`Value` and list constructors should evaluate without error. For
example, a non-terminating computation at type `(Bit,Bit)` must be
represented as `VTuple [VBit undefined, VBit undefined]`, and not
simply as `undefined`. Similarly, an expression like `1/0:[2]` that
raises a run-time error must be encoded as `VList (Nat 2) [VBit (Left
e), VBit (Left e)]` where `e = DivideByZero`.
Copy Functions
--------------
Functions `copyBySchema` and `copyByTValue` make a copy of the given
value, building the spine based only on the type without forcing the
value argument. This ensures that undefinedness appears inside `VBit`
and `VInteger` values only, and never on any constructors of the
`Value` type. In turn, this gives the appropriate semantics to
recursive definitions: The bottom value for a compound type is equal
to a value of the same type where every individual bit is bottom.
For each Cryptol type `t`, the cpo *M*(`t`) can be represented as a
subset of values of type `Value` that satisfy the datatype invariant.
This subset consists precisely of the output range of `copyByTValue
t`. Similarly, the range of output values of `copyBySchema` yields the
cpo that represents any given schema.
> copyBySchema :: Env -> Schema -> Value -> Value
> copyBySchema env0 (Forall params _props ty) = go params env0
> where
> go :: [TParam] -> Env -> Value -> Value
> go [] env v = copyByTValue (evalValType (envTypes env) ty) v
> go (p : ps) env v =
> case v of
> VPoly f -> VPoly $ \t -> go ps (bindType (tpVar p) (Right t) env) (f t)
> VNumPoly f -> VNumPoly $ \n -> go ps (bindType (tpVar p) (Left n) env) (f n)
> _ -> evalPanic "copyBySchema" ["Expected polymorphic value"]
>
> copyByTValue :: TValue -> Value -> Value
> copyByTValue = go
> where
> go :: TValue -> Value -> Value
> go ty val =
> case ty of
> TVBit -> VBit (fromVBit val)
> TVInteger -> VInteger (fromVInteger val)
> TVIntMod _ -> VInteger (fromVInteger val)
> TVSeq w ety -> VList (Nat w) (map (go ety) (copyList w (fromVList val)))
> TVStream ety -> VList Inf (map (go ety) (copyStream (fromVList val)))
> TVTuple etys -> VTuple (zipWith go etys (copyList (genericLength etys) (fromVTuple val)))
> TVRec fields -> VRecord [ (f, go fty (lookupRecord f val)) | (f, fty) <- fields ]
> TVFun _ bty -> VFun (\v -> go bty (fromVFun val v))
> TVAbstract {} -> val
>
> copyStream :: [a] -> [a]
> copyStream xs = head xs : copyStream (tail xs)
>
> copyList :: Integer -> [a] -> [a]
> copyList 0 _ = []
> copyList n xs = head xs : copyList (n - 1) (tail xs)
Operations on Values
--------------------
> -- | Destructor for @VBit@.
> fromVBit :: Value -> Either EvalError Bool
> fromVBit (VBit b) = b
> fromVBit _ = evalPanic "fromVBit" ["Expected a bit"]
>
> -- | Destructor for @VInteger@.
> fromVInteger :: Value -> Either EvalError Integer
> fromVInteger (VInteger i) = i
> fromVInteger _ = evalPanic "fromVInteger" ["Expected an integer"]
>
> -- | Destructor for @VList@.
> fromVList :: Value -> [Value]
> fromVList (VList _ vs) = vs
> fromVList _ = evalPanic "fromVList" ["Expected a list"]
>
> -- | Destructor for @VTuple@.
> fromVTuple :: Value -> [Value]
> fromVTuple (VTuple vs) = vs
> fromVTuple _ = evalPanic "fromVTuple" ["Expected a tuple"]
>
> -- | Destructor for @VRecord@.
> fromVRecord :: Value -> [(Ident, Value)]
> fromVRecord (VRecord fs) = fs
> fromVRecord _ = evalPanic "fromVRecord" ["Expected a record"]
>
> -- | Destructor for @VFun@.
> fromVFun :: Value -> (Value -> Value)
> fromVFun (VFun f) = f
> fromVFun _ = evalPanic "fromVFun" ["Expected a function"]
>
> -- | Destructor for @VPoly@.
> fromVPoly :: Value -> (TValue -> Value)
> fromVPoly (VPoly f) = f
> fromVPoly _ = evalPanic "fromVPoly" ["Expected a polymorphic value"]
>
> -- | Destructor for @VNumPoly@.
> fromVNumPoly :: Value -> (Nat' -> Value)
> fromVNumPoly (VNumPoly f) = f
> fromVNumPoly _ = evalPanic "fromVNumPoly" ["Expected a polymorphic value"]
>
> -- | Look up a field in a record.
> lookupRecord :: Ident -> Value -> Value
> lookupRecord f v =
> case lookup f (fromVRecord v) of
> Just val -> val
> Nothing -> evalPanic "lookupRecord" ["Malformed record"]
>
> -- | Polymorphic function values that expect a finite numeric type.
> vFinPoly :: (Integer -> Value) -> Value
> vFinPoly f = VNumPoly g
> where
> g (Nat n) = f n
> g Inf = evalPanic "vFinPoly" ["Expected finite numeric type"]
Environments
------------
An evaluation environment keeps track of the values of term variables
and type variables that are in scope at any point.
> data Env = Env
> { envVars :: !(Map Name Value)
> , envTypes :: !(Map TVar (Either Nat' TValue))
> }
>
> instance Semigroup Env where
> l <> r = Env
> { envVars = Map.union (envVars l) (envVars r)
> , envTypes = Map.union (envTypes l) (envTypes r)
> }
>
> instance Monoid Env where
> mempty = Env
> { envVars = Map.empty
> , envTypes = Map.empty
> }
> mappend l r = l <> r
>
> -- | Bind a variable in the evaluation environment.
> bindVar :: (Name, Value) -> Env -> Env
> bindVar (n, val) env = env { envVars = Map.insert n val (envVars env) }
>
> -- | Bind a type variable of kind # or *.
> bindType :: TVar -> Either Nat' TValue -> Env -> Env
> bindType p ty env = env { envTypes = Map.insert p ty (envTypes env) }
Evaluation
==========
The meaning *M*(`expr`) of a Cryptol expression `expr` is defined by
recursion over its structure. For an expression that contains free
variables, the meaning also depends on the environment `env`, which
assigns values to those variables.
> evalExpr :: Env -- ^ Evaluation environment
> -> Expr -- ^ Expression to evaluate
> -> Value
> evalExpr env expr =
> case expr of
>
> EList es _ty -> VList (Nat (genericLength es)) [ evalExpr env e | e <- es ]
> ETuple es -> VTuple [ evalExpr env e | e <- es ]
> ERec fields -> VRecord [ (f, evalExpr env e) | (f, e) <- fields ]
> ESel e sel -> evalSel (evalExpr env e) sel
> ESet e sel v -> evalSet (evalExpr env e) sel (evalExpr env v)
>
> EIf c t f ->
> condValue (fromVBit (evalExpr env c)) (evalExpr env t) (evalExpr env f)
>
> EComp _n _ty e branches ->
> evalComp env e branches
>
> EVar n ->
> case Map.lookup n (envVars env) of
> Just val -> val
> Nothing -> evalPanic "evalExpr" ["var `" ++ show (pp n) ++ "` is not defined" ]
>
> ETAbs tv b ->
> case tpKind tv of
> KType -> VPoly $ \ty -> evalExpr (bindType (tpVar tv) (Right ty) env) b
> KNum -> VNumPoly $ \n -> evalExpr (bindType (tpVar tv) (Left n) env) b
> k -> evalPanic "evalExpr" ["Invalid kind on type abstraction", show k]
>
> ETApp e ty ->
> case evalExpr env e of
> VPoly f -> f $! (evalValType (envTypes env) ty)
> VNumPoly f -> f $! (evalNumType (envTypes env) ty)
> _ -> evalPanic "evalExpr" ["Expected a polymorphic value"]
>
> EApp e1 e2 -> fromVFun (evalExpr env e1) (evalExpr env e2)
> EAbs n _ty b -> VFun (\v -> evalExpr (bindVar (n, v) env) b)
> EProofAbs _ e -> evalExpr env e
> EProofApp e -> evalExpr env e
> EWhere e dgs -> evalExpr (foldl evalDeclGroup env dgs) e
Selectors
---------
Apply the the given selector form to the given value.
> evalSel :: Value -> Selector -> Value
> evalSel val sel =
> case sel of
> TupleSel n _ -> tupleSel n val
> RecordSel n _ -> recordSel n val
> ListSel n _ -> listSel n val
> where
> tupleSel n v =
> case v of
> VTuple vs -> vs !! n
> _ -> evalPanic "evalSel"
> ["Unexpected value in tuple selection."]
> recordSel n v =
> case v of
> VRecord _ -> lookupRecord n v
> _ -> evalPanic "evalSel"
> ["Unexpected value in record selection."]
> listSel n v =
> case v of
> VList _ vs -> vs !! n
> _ -> evalPanic "evalSel"
> ["Unexpected value in list selection."]
Update the given value using the given selector and new value.
> evalSet :: Value -> Selector -> Value -> Value
> evalSet val sel fval =
> case sel of
> TupleSel n _ -> updTupleAt n
> RecordSel n _ -> updRecAt n
> ListSel n _ -> updSeqAt n
> where
> updTupleAt n =
> case val of
> VTuple vs | (as,_:bs) <- splitAt n vs ->
> VTuple (as ++ fval : bs)
> _ -> bad "Invalid tuple upldate."
>
> updRecAt n =
> case val of
> VRecord vs | (as, (i,_) : bs) <- break ((n==) . fst) vs ->
> VRecord (as ++ (i,fval) : bs)
> _ -> bad "Invalid record update."
>
> updSeqAt n =
> case val of
> VList i vs | (as, _ : bs) <- splitAt n vs ->
> VList i (as ++ fval : bs)
> _ -> bad "Invalid sequence update."
>
> bad msg = evalPanic "evalSet" [msg]
Conditionals
------------
We evaluate conditionals on larger types by pushing the conditionals
down to the individual bits.
> condValue :: Either EvalError Bool -> Value -> Value -> Value
> condValue c l r =
> case l of
> VBit b -> VBit (condBit c b (fromVBit r))
> VInteger i -> VInteger (condBit c i (fromVInteger r))
> VList n vs -> VList n (zipWith (condValue c) vs (fromVList r))
> VTuple vs -> VTuple (zipWith (condValue c) vs (fromVTuple r))
> VRecord fs -> VRecord [ (f, condValue c v (lookupRecord f r)) | (f, v) <- fs ]
> VFun f -> VFun (\v -> condValue c (f v) (fromVFun r v))
> VPoly f -> VPoly (\t -> condValue c (f t) (fromVPoly r t))
> VNumPoly f -> VNumPoly (\n -> condValue c (f n) (fromVNumPoly r n))
Conditionals are explicitly lazy: Run-time errors in an untaken branch
are ignored.
> condBit :: Either e Bool -> Either e a -> Either e a -> Either e a
> condBit (Left e) _ _ = Left e
> condBit (Right b) x y = if b then x else y
List Comprehensions
-------------------
Cryptol list comprehensions consist of one or more parallel branches;
each branch has one or more matches that bind values to variables.
The result of evaluating a match in an initial environment is a list
of extended environments. Each new environment binds the same single
variable to a different element of the match's list.
> evalMatch :: Env -> Match -> [Env]
> evalMatch env m =
> case m of
> Let d ->
> [ bindVar (evalDecl env d) env ]
> From n _l _ty expr ->
> [ bindVar (n, v) env | v <- fromVList (evalExpr env expr) ]
> lenMatch :: Env -> Match -> Nat'
> lenMatch env m =
> case m of
> Let _ -> Nat 1
> From _ len _ _ -> evalNumType (envTypes env) len
The result of of evaluating a branch in an initial environment is a
list of extended environments, each of which extends the initial
environment with the same set of new variables. The length of the list
is equal to the product of the lengths of the lists in the matches.
> evalBranch :: Env -> [Match] -> [Env]
> evalBranch env [] = [env]
> evalBranch env (match : matches) =
> [ env'' | env' <- evalMatch env match
> , env'' <- evalBranch env' matches ]
> lenBranch :: Env -> [Match] -> Nat'
> lenBranch _env [] = Nat 1
> lenBranch env (match : matches) =
> nMul (lenMatch env match) (lenBranch env matches)
The head expression of the comprehension can refer to any variable
bound in any of the parallel branches. So to evaluate the
comprehension, we zip and merge together the lists of extended
environments from each branch. The head expression is then evaluated
separately in each merged environment. The length of the resulting
list is equal to the minimum length over all parallel branches.
> evalComp :: Env -- ^ Starting evaluation environment
> -> Expr -- ^ Head expression of the comprehension
> -> [[Match]] -- ^ List of parallel comprehension branches
> -> Value
> evalComp env expr branches = VList len [ evalExpr e expr | e <- envs ]
> where
> -- Generate a new environment for each iteration of each
> -- parallel branch.
> benvs :: [[Env]]
> benvs = map (evalBranch env) branches
>
> -- Zip together the lists of environments from each branch,
> -- producing a list of merged environments. Longer branches get
> -- truncated to the length of the shortest branch.
> envs :: [Env]
> envs = foldr1 (zipWith mappend) benvs
>
> len :: Nat'
> len = foldr1 nMin (map (lenBranch env) branches)
Declarations
------------
Function `evalDeclGroup` extends the given evaluation environment with
the result of evaluating the given declaration group. In the case of a
recursive declaration group, we tie the recursive knot by evaluating
each declaration in the extended environment `env'` that includes all
the new bindings.
> evalDeclGroup :: Env -> DeclGroup -> Env
> evalDeclGroup env dg = do
> case dg of
> NonRecursive d ->
> bindVar (evalDecl env d) env
> Recursive ds ->
> let env' = foldr bindVar env bindings
> bindings = map (evalDeclRecursive env') ds
> in env'
To evaluate a declaration in a non-recursive context, we need only
evaluate the expression on the right-hand side or look up the
appropriate primitive.
> evalDecl :: Env -> Decl -> (Name, Value)
> evalDecl env d =
> case dDefinition d of
> DPrim -> (dName d, evalPrim (dName d))
> DExpr e -> (dName d, evalExpr env e)
To evaluate a declaration in a recursive context, we must perform a
type-directed copy to build the spine of the value. This ensures that
the definedness invariant for type `Value` will be maintained.
> evalDeclRecursive :: Env -> Decl -> (Name, Value)
> evalDeclRecursive env d =
> case dDefinition d of
> DPrim -> (dName d, evalPrim (dName d))
> DExpr e -> (dName d, copyBySchema env (dSignature d) (evalExpr env e))
Primitives
==========
To evaluate a primitive, we look up its implementation by name in a table.
> evalPrim :: Name -> Value
> evalPrim n
> | Just i <- asPrim n, Just v <- Map.lookup i primTable = v
> | otherwise = evalPanic "evalPrim" ["Unimplemented primitive", show n]
Cryptol primitives fall into several groups:
* Logic: `&&`, `||`, `^`, `complement`, `zero`, `True`, `False`
* Arithmetic: `+`, `-`, `*`, `/`, `%`, `^^`, `lg2`, `negate`, `number`
* Comparison: `<`, `>`, `<=`, `>=`, `==`, `!=`
* Sequences: `#`, `join`, `split`, `splitAt`, `reverse`, `transpose`
* Shifting: `<<`, `>>`, `<<<`, `>>>`
* Indexing: `@`, `@@`, `!`, `!!`, `update`, `updateEnd`
* Enumerations: `fromTo`, `fromThenTo`, `infFrom`, `infFromThen`
* Polynomials: `pmult`, `pdiv`, `pmod`
* Miscellaneous: `error`, `random`, `trace`
> primTable :: Map Ident Value
> primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
>
> -- Logic (bitwise):
> [ ("&&" , binary (logicBinary (&&)))
> , ("||" , binary (logicBinary (||)))
> , ("^" , binary (logicBinary (/=)))
> , ("complement" , unary (logicUnary not))
> , ("zero" , VPoly (logicNullary (Right False)))
> , ("True" , VBit (Right True))
> , ("False" , VBit (Right False))
>
> -- Arithmetic:
> , ("+" , binary (arithBinary (\x y -> Right (x + y))))
> , ("-" , binary (arithBinary (\x y -> Right (x - y))))
> , ("*" , binary (arithBinary (\x y -> Right (x * y))))
> , ("/" , binary (arithBinary divWrap))
> , ("%" , binary (arithBinary modWrap))
> , ("/$" , binary (signedArithBinary divWrap))
> , ("%$" , binary (signedArithBinary modWrap))
> , ("^^" , binary (arithBinary expWrap))
> , ("lg2" , unary (arithUnary lg2Wrap))
> , ("negate" , unary (arithUnary (\x -> Right (- x))))
> , ("number" , vFinPoly $ \val ->
> VPoly $ \a ->
> arithNullary (Right val) a)
> , ("toInteger" , vFinPoly $ \_bits ->
> VFun $ \x ->
> VInteger (fromVWord x))
> , ("fromInteger", VPoly $ \a ->
> VFun $ \x ->
> arithNullary (fromVInteger x) a)
>
> -- Comparison:
> , ("<" , binary (cmpOrder (\o -> o == LT)))
> , (">" , binary (cmpOrder (\o -> o == GT)))
> , ("<=" , binary (cmpOrder (\o -> o /= GT)))
> , (">=" , binary (cmpOrder (\o -> o /= LT)))
> , ("==" , binary (cmpOrder (\o -> o == EQ)))
> , ("!=" , binary (cmpOrder (\o -> o /= EQ)))
> , ("<$" , binary signedLessThan)
>
> -- Sequences:
> , ("#" , VNumPoly $ \front ->
> VNumPoly $ \back ->
> VPoly $ \_elty ->
> VFun $ \l ->
> VFun $ \r ->
> VList (nAdd front back) (fromVList l ++ fromVList r))
>
> , ("join" , VNumPoly $ \parts ->
> VNumPoly $ \each ->
> VPoly $ \_a ->
> VFun $ \xss ->
> case each of
> -- special case when the inner sequences are of length 0
> Nat 0 -> VList (Nat 0) []
> _ -> VList (nMul parts each)
> (concat (map fromVList (fromVList xss))))
>
> , ("split" , VNumPoly $ \parts ->
> vFinPoly $ \each ->
> VPoly $ \_a ->
> VFun $ \val ->
> VList parts (splitV parts each (fromVList val)))
>
> , ("splitAt" , vFinPoly $ \front ->
> VNumPoly $ \back ->
> VPoly $ \_a ->
> VFun $ \v ->
> let (xs, ys) = genericSplitAt front (fromVList v)
> in VTuple [VList (Nat front) xs, VList back ys])
>
> , ("reverse" , VNumPoly $ \n ->
> VPoly $ \_a ->
> VFun $ \v ->
> VList n (reverse (fromVList v)))
>
> , ("transpose" , VNumPoly $ \rows ->
> VNumPoly $ \cols ->
> VPoly $ \_a ->
> VFun $ \v ->
> VList cols
> (map (VList rows) (transposeV cols (map fromVList (fromVList v)))))
>
> -- Shifting:
> , ("<<" , shiftV shiftLV)
> , (">>" , shiftV shiftRV)
> , ("<<<" , rotateV rotateLV)
> , (">>>" , rotateV rotateRV)
> , (">>$" , signedShiftRV)
>
> -- Indexing:
> , ("@" , indexPrimOne indexFront)
> , ("!" , indexPrimOne indexBack)
> , ("update" , updatePrim updateFront)
> , ("updateEnd" , updatePrim updateBack)
>
> -- Enumerations:
> , ("fromTo" , vFinPoly $ \first ->
> vFinPoly $ \lst ->
> VPoly $ \ty ->
> let f i = arithNullary (Right i) ty
> in VList (Nat (1 + lst - first)) (map f [first .. lst]))
>
> , ("fromThenTo" , vFinPoly $ \first ->
> vFinPoly $ \next ->
> vFinPoly $ \_lst ->
> VPoly $ \ty ->
> vFinPoly $ \len ->
> let f i = arithNullary (Right i) ty
> in VList (Nat len) (map f (genericTake len [first, next ..])))
>
> , ("infFrom" , VPoly $ \ty ->
> VFun $ \first ->
> let f i = arithUnary (\x -> Right (x + i)) ty first
> in VList Inf (map f [0 ..]))
>
> , ("infFromThen", VPoly $ \ty ->
> VFun $ \first ->
> VFun $ \next ->
> let f i = arithBinary (\x y -> Right (x + (y - x) * i)) ty first next
> in VList Inf (map f [0 ..]))
>
> -- Miscellaneous:
> , ("error" , VPoly $ \a ->
> VNumPoly $ \_ ->
> VFun $ \_s -> logicNullary (Left (UserError "error")) a)
> -- TODO: obtain error string from argument s
>
> , ("random" , VPoly $ \a ->
> VFun $ \_seed ->
> logicNullary (Left (UserError "random: unimplemented")) a)
>
> , ("trace" , VNumPoly $ \_n ->
> VPoly $ \_a ->
> VPoly $ \_b ->
> VFun $ \_s ->
> VFun $ \_x ->
> VFun $ \y -> y)
> ]
>
> unary :: (TValue -> Value -> Value) -> Value
> unary f = VPoly $ \ty -> VFun $ \x -> f ty x
>
> binary :: (TValue -> Value -> Value -> Value) -> Value
> binary f = VPoly $ \ty -> VFun $ \x -> VFun $ \y -> f ty x y
Word operations
---------------
Many Cryptol primitives take numeric arguments in the form of
bitvectors. For such operations, any output bit that depends on the
numeric value is strict in *all* bits of the numeric argument. This is
implemented in function `fromVWord`, which converts a value from a
big-endian binary format to an integer. The result is an evaluation
error if any of the input bits contain an evaluation error.
> fromVWord :: Value -> Either EvalError Integer
> fromVWord v = fmap bitsToInteger (mapM fromVBit (fromVList v))
>
> -- | Convert a list of booleans in big-endian format to an integer.
> bitsToInteger :: [Bool] -> Integer
> bitsToInteger bs = foldl f 0 bs
> where f x b = if b then 2 * x + 1 else 2 * x
> fromSignedVWord :: Value -> Either EvalError Integer
> fromSignedVWord v = fmap signedBitsToInteger (mapM fromVBit (fromVList v))
>
> -- | Convert a list of booleans in signed big-endian format to an integer.
> signedBitsToInteger :: [Bool] -> Integer
> signedBitsToInteger [] = evalPanic "signedBitsToInteger" ["Bitvector has zero length"]
> signedBitsToInteger (b0 : bs) = foldl f (if b0 then -1 else 0) bs
> where f x b = if b then 2 * x + 1 else 2 * x
Function `vWord` converts an integer back to the big-endian bitvector
representation. If an integer-producing function raises a run-time
exception, then the output bitvector will contain the exception in all
bit positions.
> vWord :: Integer -> Either EvalError Integer -> Value
> vWord w e = VList (Nat w) [ VBit (fmap (test i) e) | i <- [w-1, w-2 .. 0] ]
> where test i x = testBit x (fromInteger i)
Logic
-----
Bitwise logic primitives are defined by recursion over the type
structure. On type `Bit`, we use `fmap` and `liftA2` to make these
operations strict in all arguments. For example, `True || error "foo"`
does not evaluate to `True`, but yields a run-time exception. On other
types, run-time exceptions on input bits only affect the output bits
at the same positions.
> logicNullary :: Either EvalError Bool -> TValue -> Value
> logicNullary b = go
> where
> go TVBit = VBit b
> go TVInteger = VInteger (fmap (\c -> if c then -1 else 0) b)
> go (TVIntMod _) = VInteger (fmap (const 0) b)
> go (TVSeq n ety) = VList (Nat n) (genericReplicate n (go ety))
> go (TVStream ety) = VList Inf (repeat (go ety))
> go (TVTuple tys) = VTuple (map go tys)
> go (TVRec fields) = VRecord [ (f, go fty) | (f, fty) <- fields ]
> go (TVFun _ bty) = VFun (\_ -> go bty)
> go (TVAbstract {}) =
> evalPanic "logicUnary" ["Abstract type not in `Logic`"]
>
> logicUnary :: (Bool -> Bool) -> TValue -> Value -> Value
> logicUnary op = go
> where
> go :: TValue -> Value -> Value
> go ty val =
> case ty of
> TVBit -> VBit (fmap op (fromVBit val))
> TVInteger -> evalPanic "logicUnary" ["Integer not in class Logic"]
> TVIntMod _ -> evalPanic "logicUnary" ["Z not in class Logic"]
> TVSeq w ety -> VList (Nat w) (map (go ety) (fromVList val))
> TVStream ety -> VList Inf (map (go ety) (fromVList val))
> TVTuple etys -> VTuple (zipWith go etys (fromVTuple val))
> TVRec fields -> VRecord [ (f, go fty (lookupRecord f val)) | (f, fty) <- fields ]
> TVFun _ bty -> VFun (\v -> go bty (fromVFun val v))
> TVAbstract {} ->
> evalPanic "logicUnary" ["Abstract type not in `Logic`"]
>
> logicBinary :: (Bool -> Bool -> Bool) -> TValue -> Value -> Value -> Value
> logicBinary op = go
> where
> go :: TValue -> Value -> Value -> Value
> go ty l r =
> case ty of
> TVBit -> VBit (liftA2 op (fromVBit l) (fromVBit r))
> TVInteger -> evalPanic "logicBinary" ["Integer not in class Logic"]
> TVIntMod _ -> evalPanic "logicBinary" ["Z not in class Logic"]
> TVSeq w ety -> VList (Nat w) (zipWith (go ety) (fromVList l) (fromVList r))
> TVStream ety -> VList Inf (zipWith (go ety) (fromVList l) (fromVList r))
> TVTuple etys -> VTuple (zipWith3 go etys (fromVTuple l) (fromVTuple r))
> TVRec fields -> VRecord [ (f, go fty (lookupRecord f l) (lookupRecord f r))
> | (f, fty) <- fields ]
> TVFun _ bty -> VFun (\v -> go bty (fromVFun l v) (fromVFun r v))
> TVAbstract {} ->
> evalPanic "logicBinary" ["Abstract type not in `Logic`"]
Arithmetic
----------
Arithmetic primitives may be applied to any type that is made up of
finite bitvectors. On type `[n]`, arithmetic operators are strict in
all input bits, as indicated by the definition of `fromVWord`. For
example, `[error "foo", True] * 2` does not evaluate to `[True,
False]`, but to `[error "foo", error "foo"]`.
Signed arithmetic primitives may be applied to any type that is made
up of non-empty finite bitvectors.
> arithNullary :: Either EvalError Integer -> TValue -> Value
> arithNullary i = go
> where
> go :: TValue -> Value
> go ty =
> case ty of
> TVBit ->
> evalPanic "arithNullary" ["Bit not in class Arith"]
> TVInteger ->
> VInteger i
> TVIntMod n ->
> VInteger (flip mod n <$> i)
> TVSeq w a
> | isTBit a -> vWord w i
> | otherwise -> VList (Nat w) (genericReplicate w (go a))
> TVStream a ->
> VList Inf (repeat (go a))
> TVFun _ ety ->
> VFun (const (go ety))
> TVTuple tys ->
> VTuple (map go tys)
> TVRec fs ->
> VRecord [ (f, go fty) | (f, fty) <- fs ]
> TVAbstract {} ->
> evalPanic "arithNullary" ["Absrat type not in `Arith`"]
>
> arithUnary :: (Integer -> Either EvalError Integer)
> -> TValue -> Value -> Value
> arithUnary op = go
> where
> go :: TValue -> Value -> Value
> go ty val =
> case ty of
> TVBit ->
> evalPanic "arithUnary" ["Bit not in class Arith"]
> TVInteger ->
> VInteger $
> case fromVInteger val of
> Left e -> Left e
> Right i -> op i
> TVIntMod n ->
> VInteger $
> case fromVInteger val of
> Left e -> Left e
> Right i -> flip mod n <$> op i
> TVSeq w a
> | isTBit a -> vWord w (op =<< fromVWord val)
> | otherwise -> VList (Nat w) (map (go a) (fromVList val))
> TVStream a ->
> VList Inf (map (go a) (fromVList val))
> TVFun _ ety ->
> VFun (\x -> go ety (fromVFun val x))
> TVTuple tys ->
> VTuple (zipWith go tys (fromVTuple val))
> TVRec fs ->
> VRecord [ (f, go fty (lookupRecord f val)) | (f, fty) <- fs ]
> TVAbstract {} ->
> evalPanic "arithUnary" ["Absrat type not in `Arith`"]
>
> arithBinary :: (Integer -> Integer -> Either EvalError Integer)
> -> TValue -> Value -> Value -> Value
> arithBinary = arithBinaryGeneric fromVWord
>
> signedArithBinary :: (Integer -> Integer -> Either EvalError Integer)
> -> TValue -> Value -> Value -> Value
> signedArithBinary = arithBinaryGeneric fromSignedVWord
>
> arithBinaryGeneric :: (Value -> Either EvalError Integer)
> -> (Integer -> Integer -> Either EvalError Integer)
> -> TValue -> Value -> Value -> Value
> arithBinaryGeneric fromWord op = go
> where
> go :: TValue -> Value -> Value -> Value
> go ty l r =
> case ty of
> TVBit ->
> evalPanic "arithBinary" ["Bit not in class Arith"]
> TVInteger ->
> VInteger $
> case fromVInteger l of
> Left e -> Left e
> Right i ->
> case fromVInteger r of
> Left e -> Left e
> Right j -> op i j
> TVIntMod n ->
> VInteger $
> case fromVInteger l of
> Left e -> Left e
> Right i ->
> case fromVInteger r of
> Left e -> Left e
> Right j -> flip mod n <$> op i j
> TVSeq w a
> | isTBit a -> vWord w $
> case fromWord l of
> Left e -> Left e
> Right i ->
> case fromWord r of
> Left e -> Left e
> Right j -> op i j
> | otherwise -> VList (Nat w) (zipWith (go a) (fromVList l) (fromVList r))
> TVStream a ->
> VList Inf (zipWith (go a) (fromVList l) (fromVList r))
> TVFun _ ety ->
> VFun (\x -> go ety (fromVFun l x) (fromVFun r x))
> TVTuple tys ->
> VTuple (zipWith3 go tys (fromVTuple l) (fromVTuple r))
> TVRec fs ->
> VRecord [ (f, go fty (lookupRecord f l) (lookupRecord f r)) | (f, fty) <- fs ]
> TVAbstract {} ->
> evalPanic "arithBinary" ["Abstract type not in class `Arith`"]
Signed bitvector division (`/$`) and remainder (`%$`) are defined so
that division rounds toward zero, and the remainder `x %$ y` has the
same sign as `x`. Accordingly, they are implemented with Haskell's
`quot` and `rem` operations.
> divWrap :: Integer -> Integer -> Either EvalError Integer
> divWrap _ 0 = Left DivideByZero
> divWrap x y = Right (x `quot` y)
>
> modWrap :: Integer -> Integer -> Either EvalError Integer
> modWrap _ 0 = Left DivideByZero
> modWrap x y = Right (x `rem` y)
>
> expWrap :: Integer -> Integer -> Either EvalError Integer
> expWrap x y = if y < 0 then Left NegativeExponent else Right (x ^ y)
>
> lg2Wrap :: Integer -> Either EvalError Integer
> lg2Wrap x = if x < 0 then Left LogNegative else Right (lg2 x)
Comparison
----------
Comparison primitives may be applied to any type that contains a
finite number of bits. All such types are compared using a
lexicographic ordering on bits, where `False` < `True`. Lists and
tuples are compared left-to-right, and record fields are compared in
alphabetical order.
Comparisons on type `Bit` are strict in both arguments. Comparisons on
larger types have short-circuiting behavior: A comparison involving an
error/undefined element will only yield an error if all corresponding
bits to the *left* of that position are equal.
> -- | Process two elements based on their lexicographic ordering.
> cmpOrder :: (Ordering -> Bool) -> TValue -> Value -> Value -> Value
> cmpOrder p ty l r = VBit (fmap p (lexCompare ty l r))
>
> -- | Lexicographic ordering on two values.
> lexCompare :: TValue -> Value -> Value -> Either EvalError Ordering
> lexCompare ty l r =
> case ty of
> TVBit ->
> compare <$> fromVBit l <*> fromVBit r
> TVInteger ->
> compare <$> fromVInteger l <*> fromVInteger r
> TVIntMod _ ->
> compare <$> fromVInteger l <*> fromVInteger r
> TVSeq _w ety ->
> lexList (zipWith (lexCompare ety) (fromVList l) (fromVList r))
> TVStream _ ->
> evalPanic "lexCompare" ["invalid type"]
> TVFun _ _ ->
> evalPanic "lexCompare" ["invalid type"]
> TVTuple etys ->
> lexList (zipWith3 lexCompare etys (fromVTuple l) (fromVTuple r))
> TVRec fields ->
> let tys = map snd (sortBy (comparing fst) fields)
> ls = map snd (sortBy (comparing fst) (fromVRecord l))
> rs = map snd (sortBy (comparing fst) (fromVRecord r))
> in lexList (zipWith3 lexCompare tys ls rs)
> TVAbstract {} ->
> evalPanic "lexCompare" ["Abstract type not in `Cmp`"]
>
> lexList :: [Either EvalError Ordering] -> Either EvalError Ordering
> lexList [] = Right EQ
> lexList (e : es) =
> case e of
> Left err -> Left err
> Right LT -> Right LT
> Right EQ -> lexList es
> Right GT -> Right GT
Signed comparisons may be applied to any type made up of non-empty
bitvectors. All such types are compared using a lexicographic
ordering: Lists and tuples are compared left-to-right, and record
fields are compared in alphabetical order.
> signedLessThan :: TValue -> Value -> Value -> Value
> signedLessThan ty l r = VBit (fmap (== LT) (lexSignedCompare ty l r))
>
> -- | Lexicographic ordering on two signed values.
> lexSignedCompare :: TValue -> Value -> Value -> Either EvalError Ordering
> lexSignedCompare ty l r =
> case ty of
> TVBit ->
> evalPanic "lexSignedCompare" ["invalid type"]
> TVInteger ->
> evalPanic "lexSignedCompare" ["invalid type"]
> TVIntMod _ ->
> evalPanic "lexSignedCompare" ["invalid type"]
> TVSeq _w ety
> | isTBit ety ->
> case fromSignedVWord l of
> Left e -> Left e
> Right i ->
> case fromSignedVWord r of
> Left e -> Left e
> Right j -> Right (compare i j)
> | otherwise ->
> lexList (zipWith (lexSignedCompare ety) (fromVList l) (fromVList r))
> TVStream _ ->
> evalPanic "lexSignedCompare" ["invalid type"]
> TVFun _ _ ->
> evalPanic "lexSignedCompare" ["invalid type"]
> TVTuple etys ->
> lexList (zipWith3 lexSignedCompare etys (fromVTuple l) (fromVTuple r))
> TVRec fields ->
> let tys = map snd (sortBy (comparing fst) fields)
> ls = map snd (sortBy (comparing fst) (fromVRecord l))
> rs = map snd (sortBy (comparing fst) (fromVRecord r))
> in lexList (zipWith3 lexSignedCompare tys ls rs)
> TVAbstract {} ->
> evalPanic "lexSignedCompare" ["Abstract type not in `Cmp`"]
Sequences
---------
> -- | Split a list into 'w' pieces, each of length 'k'.
> splitV :: Nat' -> Integer -> [Value] -> [Value]
> splitV w k xs =
> case w of
> Nat 0 -> []
> Nat n -> VList (Nat k) ys : splitV (Nat (n - 1)) k zs
> Inf -> VList (Nat k) ys : splitV Inf k zs
> where
> (ys, zs) = genericSplitAt k xs
>
> -- | Transpose a list of length-'w' lists into 'w' lists.
> transposeV :: Nat' -> [[Value]] -> [[Value]]
> transposeV w xss =
> case w of
> Nat 0 -> []
> Nat n -> heads : transposeV (Nat (n - 1)) tails
> Inf -> heads : transposeV Inf tails
> where
> (heads, tails) = dest xss
>
> -- Split a list of non-empty lists into
> -- a list of heads and a list of tails
> dest :: [[Value]] -> ([Value], [[Value]])
> dest [] = ([], [])
> dest ([] : _) = evalPanic "transposeV" ["Expected non-empty list"]
> dest ((y : ys) : yss) = (y : zs, ys : zss)
> where (zs, zss) = dest yss
Shifting
--------
Shift and rotate operations are strict in all bits of the shift/rotate
amount, but as lazy as possible in the list values.
> shiftV :: (Nat' -> Value -> [Value] -> Integer -> [Value]) -> Value
> shiftV op =
> VNumPoly $ \n ->
> VNumPoly $ \_ix ->
> VPoly $ \a ->
> VFun $ \v ->
> VFun $ \x ->
> copyByTValue (tvSeq n a) $
> case fromVWord x of
> Left e -> logicNullary (Left e) (tvSeq n a)
> Right i -> VList n (op n (logicNullary (Right False) a) (fromVList v) i)
>
> shiftLV :: Nat' -> Value -> [Value] -> Integer -> [Value]
> shiftLV w z vs i =
> case w of
> Nat n -> genericDrop (min n i) vs ++ genericReplicate (min n i) z
> Inf -> genericDrop i vs
>
> shiftRV :: Nat' -> Value -> [Value] -> Integer -> [Value]
> shiftRV w z vs i =
> case w of
> Nat n -> genericReplicate (min n i) z ++ genericTake (n - min n i) vs
> Inf -> genericReplicate i z ++ vs
>
> rotateV :: (Integer -> [Value] -> Integer -> [Value]) -> Value
> rotateV op =
> vFinPoly $ \n ->
> VNumPoly $ \_ix ->
> VPoly $ \a ->
> VFun $ \v ->
> VFun $ \x ->
> copyByTValue (TVSeq n a) $
> case fromVWord x of
> Left e -> VList (Nat n) (genericReplicate n (logicNullary (Left e) a))
> Right i -> VList (Nat n) (op n (fromVList v) i)
>
> rotateLV :: Integer -> [Value] -> Integer -> [Value]
> rotateLV 0 vs _ = vs
> rotateLV w vs i = ys ++ xs
> where (xs, ys) = genericSplitAt (i `mod` w) vs
>
> rotateRV :: Integer -> [Value] -> Integer -> [Value]
> rotateRV 0 vs _ = vs
> rotateRV w vs i = ys ++ xs
> where (xs, ys) = genericSplitAt ((w - i) `mod` w) vs
>
> signedShiftRV :: Value
> signedShiftRV =
> VNumPoly $ \n ->
> VNumPoly $ \_ix ->
> VFun $ \v ->
> VFun $ \x ->
> copyByTValue (tvSeq n TVBit) $
> case fromVWord x of
> Left e -> logicNullary (Left e) (tvSeq n TVBit)
> Right i -> VList n $
> let vs = fromVList v
> z = head vs in
> case n of
> Nat m -> genericReplicate (min m i) z ++ genericTake (m - min m i) vs
> Inf -> genericReplicate i z ++ vs
Indexing
--------
Indexing operations are strict in all index bits, but as lazy as
possible in the list values. An index greater than or equal to the
length of the list produces a run-time error.
> -- | Indexing operations that return one element.
> indexPrimOne :: (Nat' -> TValue -> [Value] -> Integer -> Value) -> Value
> indexPrimOne op =
> VNumPoly $ \n ->
> VPoly $ \a ->
> VNumPoly $ \_w ->
> VFun $ \l ->
> VFun $ \r ->
> copyByTValue a $
> case fromVWord r of
> Left e -> logicNullary (Left e) a
> Right i -> op n a (fromVList l) i
>
> indexFront :: Nat' -> TValue -> [Value] -> Integer -> Value
> indexFront w a vs ix =
> case w of
> Nat n | n <= ix -> logicNullary (Left (InvalidIndex ix)) a
> _ -> genericIndex vs ix
>
> indexBack :: Nat' -> TValue -> [Value] -> Integer -> Value
> indexBack w a vs ix =
> case w of
> Nat n | n > ix -> genericIndex vs (n - ix - 1)
> | otherwise -> logicNullary (Left (InvalidIndex ix)) a
> Inf -> evalPanic "indexBack" ["unexpected infinite sequence"]
>
> updatePrim :: (Nat' -> [Value] -> Integer -> Value -> [Value]) -> Value
> updatePrim op =
> VNumPoly $ \len ->
> VPoly $ \eltTy ->
> VNumPoly $ \_idxLen ->
> VFun $ \xs ->
> VFun $ \idx ->
> VFun $ \val ->
> copyByTValue (tvSeq len eltTy) $
> case fromVWord idx of
> Left e -> logicNullary (Left e) (tvSeq len eltTy)
> Right i
> | Nat i < len -> VList len (op len (fromVList xs) i val)
> | otherwise -> logicNullary (Left (InvalidIndex i)) (tvSeq len eltTy)
>
> updateFront :: Nat' -> [Value] -> Integer -> Value -> [Value]
> updateFront _ vs i x = updateAt vs i x
>
> updateBack :: Nat' -> [Value] -> Integer -> Value -> [Value]
> updateBack Inf _vs _i _x = evalPanic "Unexpected infinite sequence in updateEnd" []
> updateBack (Nat n) vs i x = updateAt vs (n - i - 1) x
>
> updateAt :: [a] -> Integer -> a -> [a]
> updateAt [] _ _ = []
> updateAt (_ : xs) 0 y = y : xs
> updateAt (x : xs) i y = x : updateAt xs (i - 1) y
Error Handling
--------------
The `evalPanic` function is only called if an internal data invariant
is violated, such as an expression that is not well-typed. Panics
should (hopefully) never occur in practice; a panic message indicates
a bug in Cryptol.
> evalPanic :: String -> [String] -> a
> evalPanic cxt = panic ("[Reference Evaluator]" ++ cxt)
Pretty Printing
---------------
> ppValue :: PPOpts -> Value -> Doc
> ppValue opts val =
> case val of
> VBit b -> text (either show show b)
> VInteger i -> text (either show show i)
> VList l vs ->
> case l of
> Inf -> ppList (map (ppValue opts) (take (useInfLength opts) vs) ++ [text "..."])
> Nat n ->
> -- For lists of defined bits, print the value as a numeral.
> case traverse isBit vs of
> Just bs -> ppBV opts (mkBv n (bitsToInteger bs))
> Nothing -> ppList (map (ppValue opts) vs)
> where ppList docs = brackets (fsep (punctuate comma docs))
> isBit v = case v of VBit (Right b) -> Just b
> _ -> Nothing
> VTuple vs -> parens (sep (punctuate comma (map (ppValue opts) vs)))
> VRecord fs -> braces (sep (punctuate comma (map ppField fs)))
> where ppField (f,r) = pp f <+> char '=' <+> ppValue opts r
> VFun _ -> text ""
> VPoly _ -> text ""
> VNumPoly _ -> text ""
Module Command
--------------
This module implements the core functionality of the `:eval
` command for the Cryptol REPL, which prints the result of
running the reference evaluator on an expression.
> evaluate :: Expr -> M.ModuleCmd Value
> evaluate expr (_,modEnv) = return (Right (evalExpr env expr, modEnv), [])
> where
> extDgs = concatMap mDecls (M.loadedModules modEnv)
> env = foldl evalDeclGroup mempty extDgs
cryptol-2.8.0/src/Cryptol/Eval/Type.hs 0000644 0000000 0000000 00000013376 07346545000 016007 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Eval.Type
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe, PatternGuards #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.Eval.Type where
import Cryptol.Eval.Monad
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.PP(pp)
import Cryptol.TypeCheck.Solver.InfNat
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.Ident (Ident)
import Data.Maybe(fromMaybe)
import qualified Data.Map.Strict as Map
import GHC.Generics (Generic)
import GHC.Stack(HasCallStack)
import Control.DeepSeq
-- | An evaluated type of kind *.
-- These types do not contain type variables, type synonyms, or type functions.
data TValue
= TVBit -- ^ @ Bit @
| TVInteger -- ^ @ Integer @
| TVIntMod Integer -- ^ @ Z n @
| TVSeq Integer TValue -- ^ @ [n]a @
| TVStream TValue -- ^ @ [inf]t @
| TVTuple [TValue] -- ^ @ (a, b, c )@
| TVRec [(Ident, TValue)] -- ^ @ { x : a, y : b, z : c } @
| TVFun TValue TValue -- ^ @ a -> b @
| TVAbstract UserTC [Either Nat' TValue] -- ^ an abstract type
deriving (Generic, NFData)
-- | Convert a type value back into a regular type
tValTy :: TValue -> Type
tValTy tv =
case tv of
TVBit -> tBit
TVInteger -> tInteger
TVIntMod n -> tIntMod (tNum n)
TVSeq n t -> tSeq (tNum n) (tValTy t)
TVStream t -> tSeq tInf (tValTy t)
TVTuple ts -> tTuple (map tValTy ts)
TVRec fs -> tRec [ (f, tValTy t) | (f, t) <- fs ]
TVFun t1 t2 -> tFun (tValTy t1) (tValTy t2)
TVAbstract u vs -> tAbstract u (map arg vs)
where arg x = case x of
Left Inf -> tInf
Left (Nat n) -> tNum n
Right v -> tValTy v
instance Show TValue where
showsPrec p v = showsPrec p (tValTy v)
-- Utilities -------------------------------------------------------------------
-- | True if the evaluated value is @Bit@
isTBit :: TValue -> Bool
isTBit TVBit = True
isTBit _ = False
-- | Produce a sequence type value
tvSeq :: Nat' -> TValue -> TValue
tvSeq (Nat n) t = TVSeq n t
tvSeq Inf t = TVStream t
-- | Coerce an extended natural into an integer,
-- for values known to be finite
finNat' :: Nat' -> Integer
finNat' n' =
case n' of
Nat x -> x
Inf -> panic "Cryptol.Eval.Value.finNat'" [ "Unexpected `inf`" ]
-- Type Evaluation -------------------------------------------------------------
type TypeEnv = Map.Map TVar (Either Nat' TValue)
-- | Evaluation for types (kind * or #).
evalType :: HasCallStack => TypeEnv -> Type -> Either Nat' TValue
evalType env ty =
case ty of
TVar tv ->
case Map.lookup tv env of
Just v -> v
Nothing -> evalPanic "evalType" ["type variable not bound", show tv]
TUser _ _ ty' -> evalType env ty'
TRec fields -> Right $ TVRec [ (f, val t) | (f, t) <- fields ]
TCon (TC c) ts ->
case (c, ts) of
(TCBit, []) -> Right $ TVBit
(TCInteger, []) -> Right $ TVInteger
(TCIntMod, [n]) -> case num n of
Inf -> evalPanic "evalType" ["invalid type Z inf"]
Nat m -> Right $ TVIntMod m
(TCSeq, [n, t]) -> Right $ tvSeq (num n) (val t)
(TCFun, [a, b]) -> Right $ TVFun (val a) (val b)
(TCTuple _, _) -> Right $ TVTuple (map val ts)
(TCNum n, []) -> Left $ Nat n
(TCInf, []) -> Left $ Inf
(TCAbstract u,vs) ->
case kindOf ty of
KType -> Right $ TVAbstract u (map (evalType env) vs)
k -> evalPanic "evalType"
[ "Unsupported"
, "*** Abstract type of kind: " ++ show (pp k)
, "*** Name: " ++ show (pp u)
]
-- FIXME: What about TCNewtype?
_ -> evalPanic "evalType" ["not a value type", show ty]
TCon (TF f) ts -> Left $ evalTF f (map num ts)
TCon (PC p) _ -> evalPanic "evalType" ["invalid predicate symbol", show p]
TCon (TError _ x) _ -> evalPanic "evalType"
["Lingering typer error", show (pp x)]
where
val = evalValType env
num = evalNumType env
-- | Evaluation for value types (kind *).
evalValType :: HasCallStack => TypeEnv -> Type -> TValue
evalValType env ty =
case evalType env ty of
Left _ -> evalPanic "evalValType" ["expected value type, found numeric type"]
Right t -> t
-- | Evaluation for number types (kind #).
evalNumType :: HasCallStack => TypeEnv -> Type -> Nat'
evalNumType env ty =
case evalType env ty of
Left n -> n
Right _ -> evalPanic "evalValType" ["expected numeric type, found value type"]
-- | Reduce type functions, raising an exception for undefined values.
evalTF :: HasCallStack => TFun -> [Nat'] -> Nat'
evalTF f vs
| TCAdd <- f, [x,y] <- vs = nAdd x y
| TCSub <- f, [x,y] <- vs = mb $ nSub x y
| TCMul <- f, [x,y] <- vs = nMul x y
| TCDiv <- f, [x,y] <- vs = mb $ nDiv x y
| TCMod <- f, [x,y] <- vs = mb $ nMod x y
| TCWidth <- f, [x] <- vs = nWidth x
| TCExp <- f, [x,y] <- vs = nExp x y
| TCMin <- f, [x,y] <- vs = nMin x y
| TCMax <- f, [x,y] <- vs = nMax x y
| TCCeilDiv <- f, [x,y] <- vs = mb $ nCeilDiv x y
| TCCeilMod <- f, [x,y] <- vs = mb $ nCeilMod x y
| TCLenFromThenTo <- f, [x,y,z] <- vs = mb $ nLenFromThenTo x y z
| otherwise = evalPanic "evalTF"
["Unexpected type function:", show ty]
where mb = fromMaybe (typeCannotBeDemoted ty)
ty = TCon (TF f) (map tNat' vs)
cryptol-2.8.0/src/Cryptol/Eval/Value.hs 0000644 0000000 0000000 00000074666 07346545000 016153 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Eval.Value
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Cryptol.Eval.Value where
import Data.Bits
import Data.IORef
import qualified Data.Sequence as Seq
import qualified Data.Foldable as Fold
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import MonadLib
import qualified Cryptol.Eval.Arch as Arch
import Cryptol.Eval.Monad
import Cryptol.Eval.Type
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
import Cryptol.Utils.Ident (Ident,mkIdent)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic(panic)
import Data.List(genericLength, genericIndex, genericDrop)
import qualified Data.Text as T
import Numeric (showIntAtBase)
import GHC.Generics (Generic)
import Control.DeepSeq
-- Values ----------------------------------------------------------------------
-- | Concrete bitvector values: width, value
-- Invariant: The value must be within the range 0 .. 2^width-1
data BV = BV !Integer !Integer deriving (Generic, NFData)
instance Show BV where
show = show . bvVal
-- | Apply an integer function to the values of bitvectors.
-- This function assumes both bitvectors are the same width.
binBV :: (Integer -> Integer -> Integer) -> BV -> BV -> BV
binBV f (BV w x) (BV _ y) = mkBv w (f x y)
-- | Apply an integer function to the values of a bitvector.
-- This function assumes the function will not require masking.
unaryBV :: (Integer -> Integer) -> BV -> BV
unaryBV f (BV w x) = mkBv w $ f x
bvVal :: BV -> Integer
bvVal (BV _w x) = x
-- | Smart constructor for 'BV's that checks for the width limit
mkBv :: Integer -> Integer -> BV
mkBv w i = BV w (mask w i)
-- | A sequence map represents a mapping from nonnegative integer indices
-- to values. These are used to represent both finite and infinite sequences.
data SeqMap b w i
= IndexSeqMap !(Integer -> Eval (GenValue b w i))
| UpdateSeqMap !(Map Integer (Eval (GenValue b w i)))
!(Integer -> Eval (GenValue b w i))
lookupSeqMap :: SeqMap b w i -> Integer -> Eval (GenValue b w i)
lookupSeqMap (IndexSeqMap f) i = f i
lookupSeqMap (UpdateSeqMap m f) i =
case Map.lookup i m of
Just x -> x
Nothing -> f i
type SeqValMap = SeqMap Bool BV Integer
instance NFData (SeqMap b w i) where
rnf x = seq x ()
-- | Generate a finite sequence map from a list of values
finiteSeqMap :: [Eval (GenValue b w i)] -> SeqMap b w i
finiteSeqMap xs =
UpdateSeqMap
(Map.fromList (zip [0..] xs))
invalidIndex
-- | Generate an infinite sequence map from a stream of values
infiniteSeqMap :: [Eval (GenValue b w i)] -> Eval (SeqMap b w i)
infiniteSeqMap xs =
-- TODO: use an int-trie?
memoMap (IndexSeqMap $ \i -> genericIndex xs i)
-- | Create a finite list of length `n` of the values from [0..n-1] in
-- the given the sequence emap.
enumerateSeqMap :: (Integral n) => n -> SeqMap b w i -> [Eval (GenValue b w i)]
enumerateSeqMap n m = [ lookupSeqMap m i | i <- [0 .. (toInteger n)-1] ]
-- | Create an infinite stream of all the values in a sequence map
streamSeqMap :: SeqMap b w i -> [Eval (GenValue b w i)]
streamSeqMap m = [ lookupSeqMap m i | i <- [0..] ]
-- | Reverse the order of a finite sequence map
reverseSeqMap :: Integer -- ^ Size of the sequence map
-> SeqMap b w i
-> SeqMap b w i
reverseSeqMap n vals = IndexSeqMap $ \i -> lookupSeqMap vals (n - 1 - i)
updateSeqMap :: SeqMap b w i -> Integer -> Eval (GenValue b w i) -> SeqMap b w i
updateSeqMap (UpdateSeqMap m sm) i x = UpdateSeqMap (Map.insert i x m) sm
updateSeqMap (IndexSeqMap f) i x = UpdateSeqMap (Map.singleton i x) f
-- | Concatenate the first `n` values of the first sequence map onto the
-- beginning of the second sequence map.
concatSeqMap :: Integer -> SeqMap b w i -> SeqMap b w i -> SeqMap b w i
concatSeqMap n x y =
IndexSeqMap $ \i ->
if i < n
then lookupSeqMap x i
else lookupSeqMap y (i-n)
-- | Given a number `n` and a sequence map, return two new sequence maps:
-- the first containing the values from `[0..n-1]` and the next containing
-- the values from `n` onward.
splitSeqMap :: Integer -> SeqMap b w i -> (SeqMap b w i, SeqMap b w i)
splitSeqMap n xs = (hd,tl)
where
hd = xs
tl = IndexSeqMap $ \i -> lookupSeqMap xs (i+n)
-- | Drop the first @n@ elements of the given @SeqMap@.
dropSeqMap :: Integer -> SeqMap b w i -> SeqMap b w i
dropSeqMap 0 xs = xs
dropSeqMap n xs = IndexSeqMap $ \i -> lookupSeqMap xs (i+n)
-- | Given a sequence map, return a new sequence map that is memoized using
-- a finite map memo table.
memoMap :: SeqMap b w i -> Eval (SeqMap b w i)
memoMap x = do
cache <- io $ newIORef $ Map.empty
return $ IndexSeqMap (memo cache)
where
memo cache i = do
mz <- io (Map.lookup i <$> readIORef cache)
case mz of
Just z -> return z
Nothing -> doEval cache i
doEval cache i = do
v <- lookupSeqMap x i
io $ modifyIORef' cache (Map.insert i v)
return v
-- | Apply the given evaluation function pointwise to the two given
-- sequence maps.
zipSeqMap :: (GenValue b w i -> GenValue b w i -> Eval (GenValue b w i))
-> SeqMap b w i
-> SeqMap b w i
-> Eval (SeqMap b w i)
zipSeqMap f x y =
memoMap (IndexSeqMap $ \i -> join (f <$> lookupSeqMap x i <*> lookupSeqMap y i))
-- | Apply the given function to each value in the given sequence map
mapSeqMap :: (GenValue b w i -> Eval (GenValue b w i))
-> SeqMap b w i -> Eval (SeqMap b w i)
mapSeqMap f x =
memoMap (IndexSeqMap $ \i -> f =<< lookupSeqMap x i)
-- | For efficiency reasons, we handle finite sequences of bits as special cases
-- in the evaluator. In cases where we know it is safe to do so, we prefer to
-- used a "packed word" representation of bit sequences. This allows us to rely
-- directly on Integer types (in the concrete evaluator) and SBV's Word types (in
-- the symbolic simulator).
--
-- However, if we cannot be sure all the bits of the sequence
-- will eventually be forced, we must instead rely on an explicit sequence of bits
-- representation.
data WordValue b w i
= WordVal !w -- ^ Packed word representation for bit sequences.
| BitsVal !(Seq.Seq (Eval b)) -- ^ Sequence of thunks representing bits.
| LargeBitsVal !Integer !(SeqMap b w i ) -- ^ A large bitvector sequence, represented as a
-- @SeqMap@ of bits.
deriving (Generic, NFData)
-- | An arbitrarily-chosen number of elements where we switch from a dense
-- sequence representation of bit-level words to @SeqMap@ representation.
largeBitSize :: Integer
largeBitSize = 1 `shiftL` 16
-- | Force a word value into packed word form
asWordVal :: BitWord b w i => WordValue b w i -> Eval w
asWordVal (WordVal w) = return w
asWordVal (BitsVal bs) = packWord <$> sequence (Fold.toList bs)
asWordVal (LargeBitsVal n xs) = packWord <$> traverse (fromBit =<<) (enumerateSeqMap n xs)
-- | Force a word value into a sequence of bits
asBitsMap :: BitWord b w i => WordValue b w i -> SeqMap b w i
asBitsMap (WordVal w) = IndexSeqMap $ \i -> ready $ VBit $ wordBit w i
asBitsMap (BitsVal bs) = IndexSeqMap $ \i -> VBit <$> join (checkedSeqIndex bs i)
asBitsMap (LargeBitsVal _ xs) = xs
-- | Turn a word value into a sequence of bits, forcing each bit.
-- The sequence is returned in big-endian order.
enumerateWordValue :: BitWord b w i => WordValue b w i -> Eval [b]
enumerateWordValue (WordVal w) = return $ unpackWord w
enumerateWordValue (BitsVal bs) = sequence (Fold.toList bs)
enumerateWordValue (LargeBitsVal n xs) = traverse (fromBit =<<) (enumerateSeqMap n xs)
-- | Turn a word value into a sequence of bits, forcing each bit.
-- The sequence is returned in reverse of the usual order, which is little-endian order.
enumerateWordValueRev :: BitWord b w i => WordValue b w i -> Eval [b]
enumerateWordValueRev (WordVal w) = return $ reverse $ unpackWord w
enumerateWordValueRev (BitsVal bs) = sequence (Fold.toList $ Seq.reverse bs)
enumerateWordValueRev (LargeBitsVal n xs) = traverse (fromBit =<<) (enumerateSeqMap n (reverseSeqMap n xs))
-- | Compute the size of a word value
wordValueSize :: BitWord b w i => WordValue b w i -> Integer
wordValueSize (WordVal w) = wordLen w
wordValueSize (BitsVal bs) = toInteger $ Seq.length bs
wordValueSize (LargeBitsVal n _) = n
checkedSeqIndex :: Seq.Seq a -> Integer -> Eval a
checkedSeqIndex xs i =
case Seq.viewl (Seq.drop (fromInteger i) xs) of
x Seq.:< _ -> return x
Seq.EmptyL -> invalidIndex i
checkedIndex :: [a] -> Integer -> Eval a
checkedIndex xs i =
case genericDrop i xs of
(x:_) -> return x
_ -> invalidIndex i
-- | Select an individual bit from a word value
indexWordValue :: BitWord b w i => WordValue b w i -> Integer -> Eval b
indexWordValue (WordVal w) idx
| idx < wordLen w = return $ wordBit w idx
| otherwise = invalidIndex idx
indexWordValue (BitsVal bs) idx = join (checkedSeqIndex bs idx)
indexWordValue (LargeBitsVal n xs) idx
| idx < n = fromBit =<< lookupSeqMap xs idx
| otherwise = invalidIndex idx
-- | Produce a new @WordValue@ from the one given by updating the @i@th bit with the
-- given bit value.
updateWordValue :: BitWord b w i => WordValue b w i -> Integer -> Eval b -> Eval (WordValue b w i)
updateWordValue (WordVal w) idx (Ready b)
| idx < wordLen w = return $ WordVal $ wordUpdate w idx b
| otherwise = invalidIndex idx
updateWordValue (WordVal w) idx b
| idx < wordLen w = return $ BitsVal $ Seq.update (fromInteger idx) b $ Seq.fromList $ map ready $ unpackWord w
| otherwise = invalidIndex idx
updateWordValue (BitsVal bs) idx b
| idx < toInteger (Seq.length bs) = return $ BitsVal $ Seq.update (fromInteger idx) b bs
| otherwise = invalidIndex idx
updateWordValue (LargeBitsVal n xs) idx b
| idx < n = return $ LargeBitsVal n $ updateSeqMap xs idx (VBit <$> b)
| otherwise = invalidIndex idx
-- | Generic value type, parameterized by bit and word types.
--
-- NOTE: we maintain an important invariant regarding sequence types.
-- `VSeq` must never be used for finite sequences of bits.
-- Always use the `VWord` constructor instead! Infinite sequences of bits
-- are handled by the `VStream` constructor, just as for other types.
data GenValue b w i
= VRecord ![(Ident, Eval (GenValue b w i))] -- ^ @ { .. } @
| VTuple ![Eval (GenValue b w i)] -- ^ @ ( .. ) @
| VBit !b -- ^ @ Bit @
| VInteger !i -- ^ @ Integer @ or @ Z n @
| VSeq !Integer !(SeqMap b w i) -- ^ @ [n]a @
-- Invariant: VSeq is never a sequence of bits
| VWord !Integer !(Eval (WordValue b w i)) -- ^ @ [n]Bit @
| VStream !(SeqMap b w i) -- ^ @ [inf]a @
| VFun (Eval (GenValue b w i) -> Eval (GenValue b w i)) -- ^ functions
| VPoly (TValue -> Eval (GenValue b w i)) -- ^ polymorphic values (kind *)
| VNumPoly (Nat' -> Eval (GenValue b w i)) -- ^ polymorphic values (kind #)
deriving (Generic, NFData)
-- | Force the evaluation of a word value
forceWordValue :: WordValue b w i -> Eval ()
forceWordValue (WordVal _w) = return ()
forceWordValue (BitsVal bs) = mapM_ (\b -> const () <$> b) bs
forceWordValue (LargeBitsVal n xs) = mapM_ (\x -> const () <$> x) (enumerateSeqMap n xs)
-- | Force the evaluation of a value
forceValue :: GenValue b w i -> Eval ()
forceValue v = case v of
VRecord fs -> mapM_ (\x -> forceValue =<< snd x) fs
VTuple xs -> mapM_ (forceValue =<<) xs
VSeq n xs -> mapM_ (forceValue =<<) (enumerateSeqMap n xs)
VBit _b -> return ()
VInteger _i -> return ()
VWord _ wv -> forceWordValue =<< wv
VStream _ -> return ()
VFun _ -> return ()
VPoly _ -> return ()
VNumPoly _ -> return ()
instance (Show b, Show w, Show i) => Show (GenValue b w i) where
show v = case v of
VRecord fs -> "record:" ++ show (map fst fs)
VTuple xs -> "tuple:" ++ show (length xs)
VBit b -> show b
VInteger i -> show i
VSeq n _ -> "seq:" ++ show n
VWord n _ -> "word:" ++ show n
VStream _ -> "stream"
VFun _ -> "fun"
VPoly _ -> "poly"
VNumPoly _ -> "numpoly"
type Value = GenValue Bool BV Integer
-- Pretty Printing -------------------------------------------------------------
defaultPPOpts :: PPOpts
defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5 }
atFst :: Functor f => (a -> f b) -> (a, c) -> f (b, c)
atFst f (x,y) = fmap (,y) $ f x
atSnd :: Functor f => (a -> f b) -> (c, a) -> f (c, b)
atSnd f (x,y) = fmap (x,) $ f y
ppValue :: forall b w i
. BitWord b w i
=> PPOpts
-> GenValue b w i
-> Eval Doc
ppValue opts = loop
where
loop :: GenValue b w i -> Eval Doc
loop val = case val of
VRecord fs -> do fs' <- traverse (atSnd (>>=loop)) $ fs
return $ braces (sep (punctuate comma (map ppField fs')))
where
ppField (f,r) = pp f <+> char '=' <+> r
VTuple vals -> do vals' <- traverse (>>=loop) vals
return $ parens (sep (punctuate comma vals'))
VBit b -> return $ ppBit b
VInteger i -> return $ ppInteger opts i
VSeq sz vals -> ppWordSeq sz vals
VWord _ wv -> ppWordVal =<< wv
VStream vals -> do vals' <- traverse (>>=loop) $ enumerateSeqMap (useInfLength opts) vals
return $ brackets $ fsep
$ punctuate comma
( vals' ++ [text "..."]
)
VFun _ -> return $ text ""
VPoly _ -> return $ text ""
VNumPoly _ -> return $ text ""
ppWordVal :: WordValue b w i -> Eval Doc
ppWordVal w = ppWord opts <$> asWordVal w
ppWordSeq :: Integer -> SeqMap b w i -> Eval Doc
ppWordSeq sz vals = do
ws <- sequence (enumerateSeqMap sz vals)
case ws of
w : _
| Just l <- vWordLen w
, asciiMode opts l
-> do vs <- traverse (fromVWord "ppWordSeq") ws
case traverse wordAsChar vs of
Just str -> return $ text (show str)
_ -> return $ brackets (fsep (punctuate comma $ map (ppWord opts) vs))
_ -> do ws' <- traverse loop ws
return $ brackets (fsep (punctuate comma ws'))
asciiMode :: PPOpts -> Integer -> Bool
asciiMode opts width = useAscii opts && (width == 7 || width == 8)
integerToChar :: Integer -> Char
integerToChar = toEnum . fromInteger
ppBV :: PPOpts -> BV -> Doc
ppBV opts (BV width i)
| base > 36 = integer i -- not sure how to rule this out
| asciiMode opts width = text (show (toEnum (fromInteger i) :: Char))
| otherwise = prefix <.> text value
where
base = useBase opts
padding bitsPerDigit = text (replicate padLen '0')
where
padLen | m > 0 = d + 1
| otherwise = d
(d,m) = (fromInteger width - (length value * bitsPerDigit))
`divMod` bitsPerDigit
prefix = case base of
2 -> text "0b" <.> padding 1
8 -> text "0o" <.> padding 3
10 -> empty
16 -> text "0x" <.> padding 4
_ -> text "0" <.> char '<' <.> int base <.> char '>'
value = showIntAtBase (toInteger base) (digits !!) i ""
digits = "0123456789abcdefghijklmnopqrstuvwxyz"
-- | This type class defines a collection of operations on bits and words that
-- are necessary to define generic evaluator primitives that operate on both concrete
-- and symbolic values uniformly.
class BitWord b w i | b -> w, w -> i, i -> b where
-- | Pretty-print an individual bit
ppBit :: b -> Doc
-- | Pretty-print a word value
ppWord :: PPOpts -> w -> Doc
-- | Pretty-print an integer value
ppInteger :: PPOpts -> i -> Doc
-- | Attempt to render a word value as an ASCII character. Return `Nothing`
-- if the character value is unknown (e.g., for symbolic values).
wordAsChar :: w -> Maybe Char
-- | The number of bits in a word value.
wordLen :: w -> Integer
-- | Construct a literal bit value from a boolean.
bitLit :: Bool -> b
-- | Construct a literal word value given a bit width and a value.
wordLit :: Integer -- ^ Width
-> Integer -- ^ Value
-> w
-- | Construct a literal integer value from the given integer.
integerLit :: Integer -- ^ Value
-> i
-- | Extract the numbered bit from the word.
--
-- NOTE: this assumes that the sequence of bits is big-endian and finite, so the
-- bit numbered 0 is the most significant bit.
wordBit :: w -> Integer -> b
-- | Update the numbered bit in the word.
--
-- NOTE: this assumes that the sequence of bits is big-endian and finite, so the
-- bit numbered 0 is the most significant bit.
wordUpdate :: w -> Integer -> b -> w
-- | Construct a word value from a finite sequence of bits.
-- NOTE: this assumes that the sequence of bits is big-endian and finite, so the
-- first element of the list will be the most significant bit.
packWord :: [b] -> w
-- | Deconstruct a packed word value in to a finite sequence of bits.
-- NOTE: this produces a list of bits that represent a big-endian word, so
-- the most significant bit is the first element of the list.
unpackWord :: w -> [b]
-- | Concatenate the two given word values.
-- NOTE: the first argument represents the more-significant bits
joinWord :: w -> w -> w
-- | Take the most-significant bits, and return
-- those bits and the remainder. The first element
-- of the pair is the most significant bits.
-- The two integer sizes must sum to the length of the given word value.
splitWord :: Integer -- ^ left width
-> Integer -- ^ right width
-> w
-> (w, w)
-- | Extract a subsequence of bits from a packed word value.
-- The first integer argument is the number of bits in the
-- resulting word. The second integer argument is the
-- number of less-significant digits to discard. Stated another
-- way, the operation `extractWord n i w` is equivalent to
-- first shifting `w` right by `i` bits, and then truncating to
-- `n` bits.
extractWord :: Integer -- ^ Number of bits to take
-> Integer -- ^ starting bit
-> w
-> w
-- | 2's complement addition of packed words. The arguments must have
-- equal bit width, and the result is of the same width. Overflow is silently
-- discarded.
wordPlus :: w -> w -> w
-- | 2's complement subtraction of packed words. The arguments must have
-- equal bit width, and the result is of the same width. Overflow is silently
-- discarded.
wordMinus :: w -> w -> w
-- | 2's complement multiplication of packed words. The arguments must have
-- equal bit width, and the result is of the same width. The high bits of the
-- multiplication are silently discarded.
wordMult :: w -> w -> w
-- | Construct an integer value from the given packed word.
wordToInt :: w -> i
-- | Addition of unbounded integers.
intPlus :: i -> i -> i
-- | Subtraction of unbounded integers.
intMinus :: i -> i -> i
-- | Multiplication of unbounded integers.
intMult :: i -> i -> i
-- | Addition of integers modulo n, for a concrete positive integer n.
intModPlus :: Integer -> i -> i -> i
-- | Subtraction of integers modulo n, for a concrete positive integer n.
intModMinus :: Integer -> i -> i -> i
-- | Multiplication of integers modulo n, for a concrete positive integer n.
intModMult :: Integer -> i -> i -> i
-- | Construct a packed word of the specified width from an integer value.
wordFromInt :: Integer -> i -> w
-- | This class defines additional operations necessary to define generic evaluation
-- functions.
class BitWord b w i => EvalPrims b w i where
-- | Eval prim binds primitive declarations to the primitive values that implement them. Returns 'Nothing' for abstract primitives (i.e., once that are
-- not implemented by this backend).
evalPrim :: Decl -> Maybe (GenValue b w i)
-- | if/then/else operation. Choose either the 'then' value or the 'else' value depending
-- on the value of the test bit.
iteValue :: b -- ^ Test bit
-> Eval (GenValue b w i) -- ^ 'then' value
-> Eval (GenValue b w i) -- ^ 'else' value
-> Eval (GenValue b w i)
-- Concrete Big-endian Words ------------------------------------------------------------
mask :: Integer -- ^ Bit-width
-> Integer -- ^ Value
-> Integer -- ^ Masked result
mask w i | w >= Arch.maxBigIntWidth = wordTooWide w
| otherwise = i .&. ((1 `shiftL` fromInteger w) - 1)
instance BitWord Bool BV Integer where
wordLen (BV w _) = w
wordAsChar (BV _ x) = Just $ integerToChar x
wordBit (BV w x) idx = testBit x (fromInteger (w - 1 - idx))
wordUpdate (BV w x) idx True = BV w (setBit x (fromInteger (w - 1 - idx)))
wordUpdate (BV w x) idx False = BV w (clearBit x (fromInteger (w - 1 - idx)))
ppBit b | b = text "True"
| otherwise = text "False"
ppWord = ppBV
ppInteger _opts i = integer i
bitLit b = b
wordLit = mkBv
integerLit i = i
packWord bits = BV (toInteger w) a
where
w = case length bits of
len | toInteger len >= Arch.maxBigIntWidth -> wordTooWide (toInteger len)
| otherwise -> len
a = foldl setb 0 (zip [w - 1, w - 2 .. 0] bits)
setb acc (n,b) | b = setBit acc n
| otherwise = acc
unpackWord (BV w a) = [ testBit a n | n <- [w' - 1, w' - 2 .. 0] ]
where
w' = fromInteger w
joinWord (BV i x) (BV j y) =
BV (i + j) (shiftL x (fromInteger j) + y)
splitWord leftW rightW (BV _ x) =
( BV leftW (x `shiftR` (fromInteger rightW)), mkBv rightW x )
extractWord n i (BV _ x) = mkBv n (x `shiftR` (fromInteger i))
wordPlus (BV i x) (BV j y)
| i == j = mkBv i (x+y)
| otherwise = panic "Attempt to add words of different sizes: wordPlus" []
wordMinus (BV i x) (BV j y)
| i == j = mkBv i (x-y)
| otherwise = panic "Attempt to subtract words of different sizes: wordMinus" []
wordMult (BV i x) (BV j y)
| i == j = mkBv i (x*y)
| otherwise = panic "Attempt to multiply words of different sizes: wordMult" []
intPlus x y = x + y
intMinus x y = x - y
intMult x y = x * y
intModPlus m x y = (x + y) `mod` m
intModMinus m x y = (x - y) `mod` m
intModMult m x y = (x * y) `mod` m
wordToInt (BV _ x) = x
wordFromInt w x = mkBv w x
-- Value Constructors ----------------------------------------------------------
-- | Create a packed word of n bits.
word :: BitWord b w i => Integer -> Integer -> GenValue b w i
word n i
| n >= Arch.maxBigIntWidth = wordTooWide n
| otherwise = VWord n $ ready $ WordVal $ wordLit n i
lam :: (Eval (GenValue b w i) -> Eval (GenValue b w i)) -> GenValue b w i
lam = VFun
-- | Functions that assume word inputs
wlam :: BitWord b w i => (w -> Eval (GenValue b w i)) -> GenValue b w i
wlam f = VFun (\x -> x >>= fromVWord "wlam" >>= f)
-- | A type lambda that expects a @Type@.
tlam :: (TValue -> GenValue b w i) -> GenValue b w i
tlam f = VPoly (return . f)
-- | A type lambda that expects a @Type@ of kind #.
nlam :: (Nat' -> GenValue b w i) -> GenValue b w i
nlam f = VNumPoly (return . f)
-- | Generate a stream.
toStream :: [GenValue b w i] -> Eval (GenValue b w i)
toStream vs =
VStream <$> infiniteSeqMap (map ready vs)
toFinSeq :: BitWord b w i
=> Integer -> TValue -> [GenValue b w i] -> GenValue b w i
toFinSeq len elty vs
| isTBit elty = VWord len $ ready $ WordVal $ packWord $ map fromVBit vs
| otherwise = VSeq len $ finiteSeqMap (map ready vs)
-- | This is strict!
boolToWord :: [Bool] -> Value
boolToWord bs = VWord (genericLength bs) $ ready $ WordVal $ packWord bs
-- | Construct either a finite sequence, or a stream. In the finite case,
-- record whether or not the elements were bits, to aid pretty-printing.
toSeq :: BitWord b w i
=> Nat' -> TValue -> [GenValue b w i] -> Eval (GenValue b w i)
toSeq len elty vals = case len of
Nat n -> return $ toFinSeq n elty vals
Inf -> toStream vals
-- | Construct either a finite sequence, or a stream. In the finite case,
-- record whether or not the elements were bits, to aid pretty-printing.
mkSeq :: Nat' -> TValue -> SeqMap b w i -> GenValue b w i
mkSeq len elty vals = case len of
Nat n
| isTBit elty -> VWord n $ return $ BitsVal $ Seq.fromFunction (fromInteger n) $ \i ->
fromVBit <$> lookupSeqMap vals (toInteger i)
| otherwise -> VSeq n vals
Inf -> VStream vals
-- Value Destructors -----------------------------------------------------------
-- | Extract a bit value.
fromVBit :: GenValue b w i -> b
fromVBit val = case val of
VBit b -> b
_ -> evalPanic "fromVBit" ["not a Bit"]
-- | Extract an integer value.
fromVInteger :: GenValue b w i -> i
fromVInteger val = case val of
VInteger i -> i
_ -> evalPanic "fromVInteger" ["not an Integer"]
-- | Extract a finite sequence value.
fromVSeq :: GenValue b w i -> SeqMap b w i
fromVSeq val = case val of
VSeq _ vs -> vs
_ -> evalPanic "fromVSeq" ["not a sequence"]
-- | Extract a sequence.
fromSeq :: forall b w i. BitWord b w i => String -> GenValue b w i -> Eval (SeqMap b w i)
fromSeq msg val = case val of
VSeq _ vs -> return vs
VStream vs -> return vs
_ -> evalPanic "fromSeq" ["not a sequence", msg]
fromStr :: Value -> Eval String
fromStr (VSeq n vals) =
traverse (\x -> toEnum . fromInteger <$> (fromWord "fromStr" =<< x)) (enumerateSeqMap n vals)
fromStr _ = evalPanic "fromStr" ["Not a finite sequence"]
fromBit :: GenValue b w i -> Eval b
fromBit (VBit b) = return b
fromBit _ = evalPanic "fromBit" ["Not a bit value"]
fromWordVal :: String -> GenValue b w i -> Eval (WordValue b w i)
fromWordVal _msg (VWord _ wval) = wval
fromWordVal msg _ = evalPanic "fromWordVal" ["not a word value", msg]
-- | Extract a packed word.
fromVWord :: BitWord b w i => String -> GenValue b w i -> Eval w
fromVWord _msg (VWord _ wval) = wval >>= asWordVal
fromVWord msg _ = evalPanic "fromVWord" ["not a word", msg]
vWordLen :: BitWord b w i => GenValue b w i -> Maybe Integer
vWordLen val = case val of
VWord n _wv -> Just n
_ -> Nothing
-- | If the given list of values are all fully-evaluated thunks
-- containing bits, return a packed word built from the same bits.
-- However, if any value is not a fully-evaluated bit, return `Nothing`.
tryFromBits :: BitWord b w i => [Eval (GenValue b w i)] -> Maybe w
tryFromBits = go id
where
go f [] = Just (packWord (f []))
go f (Ready (VBit b) : vs) = go (f . (b :)) vs
go _ (_ : _) = Nothing
-- | Turn a value into an integer represented by w bits.
fromWord :: String -> Value -> Eval Integer
fromWord msg val = bvVal <$> fromVWord msg val
-- | Extract a function from a value.
fromVFun :: GenValue b w i -> (Eval (GenValue b w i) -> Eval (GenValue b w i))
fromVFun val = case val of
VFun f -> f
_ -> evalPanic "fromVFun" ["not a function"]
-- | Extract a polymorphic function from a value.
fromVPoly :: GenValue b w i -> (TValue -> Eval (GenValue b w i))
fromVPoly val = case val of
VPoly f -> f
_ -> evalPanic "fromVPoly" ["not a polymorphic value"]
-- | Extract a polymorphic function from a value.
fromVNumPoly :: GenValue b w i -> (Nat' -> Eval (GenValue b w i))
fromVNumPoly val = case val of
VNumPoly f -> f
_ -> evalPanic "fromVNumPoly" ["not a polymorphic value"]
-- | Extract a tuple from a value.
fromVTuple :: GenValue b w i -> [Eval (GenValue b w i)]
fromVTuple val = case val of
VTuple vs -> vs
_ -> evalPanic "fromVTuple" ["not a tuple"]
-- | Extract a record from a value.
fromVRecord :: GenValue b w i -> [(Ident, Eval (GenValue b w i))]
fromVRecord val = case val of
VRecord fs -> fs
_ -> evalPanic "fromVRecord" ["not a record"]
-- | Lookup a field in a record.
lookupRecord :: Ident -> GenValue b w i -> Eval (GenValue b w i)
lookupRecord f rec = case lookup f (fromVRecord rec) of
Just val -> val
Nothing -> evalPanic "lookupRecord" ["malformed record"]
-- Value to Expression conversion ----------------------------------------------
-- | Given an expected type, returns an expression that evaluates to
-- this value, if we can determine it.
--
-- XXX: View patterns would probably clean up this definition a lot.
toExpr :: PrimMap -> Type -> Value -> Eval (Maybe Expr)
toExpr prims t0 v0 = findOne (go t0 v0)
where
prim n = ePrim prims (mkIdent (T.pack n))
go :: Type -> Value -> ChoiceT Eval Expr
go ty val = case (tNoUser ty, val) of
(TRec tfs, VRecord vfs) -> do
let fns = map fst vfs
guard (map fst tfs == fns)
fes <- zipWithM go (map snd tfs) =<< lift (traverse snd vfs)
return $ ERec (zip fns fes)
(TCon (TC (TCTuple tl)) ts, VTuple tvs) -> do
guard (tl == (length tvs))
ETuple `fmap` (zipWithM go ts =<< lift (sequence tvs))
(TCon (TC TCBit) [], VBit True ) -> return (prim "True")
(TCon (TC TCBit) [], VBit False) -> return (prim "False")
(TCon (TC TCInteger) [], VInteger i) ->
return $ ETApp (ETApp (prim "number") (tNum i)) ty
(TCon (TC TCIntMod) [_n], VInteger i) ->
return $ ETApp (ETApp (prim "number") (tNum i)) ty
(TCon (TC TCSeq) [a,b], VSeq 0 _) -> do
guard (a == tZero)
return $ EList [] b
(TCon (TC TCSeq) [a,b], VSeq n svs) -> do
guard (a == tNum n)
ses <- mapM (go b) =<< lift (sequence (enumerateSeqMap n svs))
return $ EList ses b
(TCon (TC TCSeq) [a,(TCon (TC TCBit) [])], VWord _ wval) -> do
BV w v <- lift (asWordVal =<< wval)
guard (a == tNum w)
return $ ETApp (ETApp (prim "number") (tNum v)) ty
(_, VStream _) -> fail "cannot construct infinite expressions"
(_, VFun _) -> fail "cannot convert function values to expressions"
(_, VPoly _) -> fail "cannot convert polymorphic values to expressions"
_ -> do doc <- lift (ppValue defaultPPOpts val)
panic "Cryptol.Eval.Value.toExpr"
["type mismatch:"
, pretty ty
, render doc
]
cryptol-2.8.0/src/Cryptol/IR/ 0000755 0000000 0000000 00000000000 07346545000 014143 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/IR/FreeVars.hs 0000644 0000000 0000000 00000012264 07346545000 016221 0 ustar 00 0000000 0000000 module Cryptol.IR.FreeVars
( FreeVars(..)
, Deps(..)
, Defs(..)
, moduleDeps, transDeps
) where
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Semigroup (Semigroup(..))
import Cryptol.TypeCheck.AST
data Deps = Deps { valDeps :: Set Name
-- ^ Undefined value names
, tyDeps :: Set Name
-- ^ Undefined type names (from newtype)
, tyParams :: Set TParam
-- ^ Undefined type params (e.d. mod params)
} deriving Eq
instance Semigroup Deps where
d1 <> d2 = mconcat [d1,d2]
instance Monoid Deps where
mempty = Deps { valDeps = Set.empty
, tyDeps = Set.empty
, tyParams = Set.empty
}
mappend d1 d2 = d1 <> d2
mconcat ds = Deps { valDeps = Set.unions (map valDeps ds)
, tyDeps = Set.unions (map tyDeps ds)
, tyParams = Set.unions (map tyParams ds)
}
rmTParam :: TParam -> Deps -> Deps
rmTParam p x = x { tyParams = Set.delete p (tyParams x) }
rmVal :: Name -> Deps -> Deps
rmVal p x = x { valDeps = Set.delete p (valDeps x) }
rmVals :: Set Name -> Deps -> Deps
rmVals p x = x { valDeps = Set.difference (valDeps x) p }
-- | Compute the transitive closure of the given dependencies.
transDeps :: Map Name Deps -> Map Name Deps
transDeps mp0 = fst
$ head
$ dropWhile (uncurry (/=))
$ zip steps (tail steps)
where
step1 mp d = mconcat [ Map.findWithDefault
mempty { valDeps = Set.singleton x }
x mp | x <- Set.toList (valDeps d) ]
step mp = fmap (step1 mp) mp
steps = iterate step mp0
-- | Dependencies of top-level declarations in a module.
-- These are dependencies on module parameters or things
-- defined outside the module.
moduleDeps :: Module -> Map Name Deps
moduleDeps = transDeps . Map.unions . map fromDG . mDecls
where
fromDG dg = let vs = freeVars dg
in Map.fromList [ (x,vs) | x <- Set.toList (defs dg) ]
class FreeVars e where
freeVars :: e -> Deps
instance FreeVars e => FreeVars [e] where
freeVars = mconcat . map freeVars
instance FreeVars DeclGroup where
freeVars dg = case dg of
NonRecursive d -> freeVars d
Recursive ds -> rmVals (defs ds) (freeVars ds)
instance FreeVars Decl where
freeVars d = freeVars (dDefinition d) <> freeVars (dSignature d)
instance FreeVars DeclDef where
freeVars d = case d of
DPrim -> mempty
DExpr e -> freeVars e
instance FreeVars Expr where
freeVars expr =
case expr of
EList es t -> freeVars es <> freeVars t
ETuple es -> freeVars es
ERec fs -> freeVars (map snd fs)
ESel e _ -> freeVars e
ESet e _ v -> freeVars [e,v]
EIf e1 e2 e3 -> freeVars [e1,e2,e3]
EComp t1 t2 e mss -> freeVars [t1,t2] <> rmVals (defs mss) (freeVars e)
<> mconcat (map fvsArm mss)
where
fvsArm = foldr mat mempty
mat x rest = freeVars x <> rmVals (defs x) rest
EVar x -> mempty { valDeps = Set.singleton x }
ETAbs a e -> rmTParam a (freeVars e)
ETApp e t -> freeVars e <> freeVars t
EApp e1 e2 -> freeVars [e1,e2]
EAbs x t e -> freeVars t <> rmVal x (freeVars e)
EProofAbs p e -> freeVars p <> freeVars e
EProofApp e -> freeVars e
EWhere e ds -> freeVars ds <> rmVals (defs ds) (freeVars e)
instance FreeVars Match where
freeVars m = case m of
From _ t1 t2 e -> freeVars t1 <> freeVars t2 <> freeVars e
Let d -> freeVars d
instance FreeVars Schema where
freeVars s = foldr rmTParam (freeVars (sProps s) <> freeVars (sType s))
(sVars s)
instance FreeVars Type where
freeVars ty =
case ty of
TCon tc ts -> freeVars tc <> freeVars ts
TVar tv -> freeVars tv
TUser _ _ t -> freeVars t
TRec fs -> freeVars (map snd fs)
instance FreeVars TVar where
freeVars tv = case tv of
TVBound p -> mempty { tyParams = Set.singleton p }
_ -> mempty
instance FreeVars TCon where
freeVars tc =
case tc of
TC (TCNewtype (UserTC n _)) -> mempty { tyDeps = Set.singleton n }
_ -> mempty
instance FreeVars Newtype where
freeVars nt = foldr rmTParam base (ntParams nt)
where base = freeVars (ntConstraints nt) <> freeVars (map snd (ntFields nt))
--------------------------------------------------------------------------------
class Defs d where
defs :: d -> Set Name
instance Defs a => Defs [a] where
defs = Set.unions . map defs
instance Defs DeclGroup where
defs dg = case dg of
Recursive ds -> defs ds
NonRecursive d -> defs d
instance Defs Decl where
defs d = Set.singleton (dName d)
instance Defs Match where
defs m = case m of
From x _ _ _ -> Set.singleton x
Let d -> defs d
cryptol-2.8.0/src/Cryptol/ModuleSystem.hs 0000644 0000000 0000000 00000007516 07346545000 016630 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.ModuleSystem
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE FlexibleContexts #-}
module Cryptol.ModuleSystem (
-- * Module System
ModuleEnv(..), initialModuleEnv
, DynamicEnv(..)
, ModuleError(..), ModuleWarning(..)
, ModuleCmd, ModuleRes
, findModule
, loadModuleByPath
, loadModuleByName
, checkExpr
, evalExpr
, checkDecls
, evalDecls
, noPat
, focusedEnv
, getPrimMap
, renameVar
, renameType
-- * Interfaces
, Iface(..), IfaceParams(..), IfaceDecls(..), genIface
, IfaceTySyn, IfaceDecl(..)
) where
import qualified Cryptol.Eval as E
import qualified Cryptol.Eval.Value as E
import Cryptol.ModuleSystem.Env
import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Monad
import Cryptol.ModuleSystem.Name (Name,PrimMap)
import qualified Cryptol.ModuleSystem.Renamer as R
import qualified Cryptol.ModuleSystem.Base as Base
import qualified Cryptol.Parser.AST as P
import Cryptol.Parser.Name (PName)
import Cryptol.Parser.NoPat (RemovePatterns)
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.Utils.Ident as M
-- Public Interface ------------------------------------------------------------
type ModuleCmd a = (E.EvalOpts,ModuleEnv) -> IO (ModuleRes a)
type ModuleRes a = (Either ModuleError (a,ModuleEnv), [ModuleWarning])
getPrimMap :: ModuleCmd PrimMap
getPrimMap me = runModuleM me Base.getPrimMap
-- | Find the file associated with a module name in the module search path.
findModule :: P.ModName -> ModuleCmd ModulePath
findModule n env = runModuleM env (Base.findModule n)
-- | Load the module contained in the given file.
loadModuleByPath :: FilePath -> ModuleCmd (ModulePath,T.Module)
loadModuleByPath path (evo,env) = runModuleM (evo,resetModuleEnv env) $ do
unloadModule ((InFile path ==) . lmFilePath)
m <- Base.loadModuleByPath path
setFocusedModule (T.mName m)
return (InFile path,m)
-- | Load the given parsed module.
loadModuleByName :: P.ModName -> ModuleCmd (ModulePath,T.Module)
loadModuleByName n env = runModuleM env $ do
unloadModule ((n ==) . lmName)
(path,m') <- Base.loadModuleFrom (FromModule n)
setFocusedModule (T.mName m')
return (path,m')
-- Extended Environments -------------------------------------------------------
-- These functions are particularly useful for interactive modes, as
-- they allow for expressions to be evaluated in an environment that
-- can extend dynamically outside of the context of a module.
-- | Check the type of an expression. Give back the renamed expression, the
-- core expression, and its type schema.
checkExpr :: P.Expr PName -> ModuleCmd (P.Expr Name,T.Expr,T.Schema)
checkExpr e env = runModuleM env (interactive (Base.checkExpr e))
-- | Evaluate an expression.
evalExpr :: T.Expr -> ModuleCmd E.Value
evalExpr e env = runModuleM env (interactive (Base.evalExpr e))
-- | Typecheck top-level declarations.
checkDecls :: [P.TopDecl PName] -> ModuleCmd (R.NamingEnv,[T.DeclGroup])
checkDecls ds env = runModuleM env
$ interactive
$ Base.checkDecls ds
-- | Evaluate declarations and add them to the extended environment.
evalDecls :: [T.DeclGroup] -> ModuleCmd ()
evalDecls dgs env = runModuleM env (interactive (Base.evalDecls dgs))
noPat :: RemovePatterns a => a -> ModuleCmd a
noPat a env = runModuleM env (interactive (Base.noPat a))
renameVar :: R.NamingEnv -> PName -> ModuleCmd Name
renameVar names n env = runModuleM env $ interactive $
Base.rename M.interactiveName names (R.renameVar n)
renameType :: R.NamingEnv -> PName -> ModuleCmd Name
renameType names n env = runModuleM env $ interactive $
Base.rename M.interactiveName names (R.renameType n)
cryptol-2.8.0/src/Cryptol/ModuleSystem/ 0000755 0000000 0000000 00000000000 07346545000 016263 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/ModuleSystem/Base.hs 0000644 0000000 0000000 00000044115 07346545000 017476 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.ModuleSystem.Base
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- This is the main driver---it provides entry points for the
-- various passes.
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
module Cryptol.ModuleSystem.Base where
import Cryptol.ModuleSystem.Env (DynamicEnv(..), deIfaceDecls)
import Cryptol.ModuleSystem.Fingerprint
import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Monad
import Cryptol.ModuleSystem.Name (Name,liftSupply,PrimMap)
import Cryptol.ModuleSystem.Env (lookupModule
, LoadedModule(..)
, meCoreLint, CoreLint(..)
, ModulePath(..), modulePathLabel)
import qualified Cryptol.Eval as E
import qualified Cryptol.Eval.Value as E
import Cryptol.Prims.Eval ()
import qualified Cryptol.ModuleSystem.NamingEnv as R
import qualified Cryptol.ModuleSystem.Renamer as R
import qualified Cryptol.Parser as P
import qualified Cryptol.Parser.Unlit as P
import Cryptol.Parser.AST as P
import Cryptol.Parser.NoPat (RemovePatterns(removePatterns))
import Cryptol.Parser.NoInclude (removeIncludesModule)
import Cryptol.Parser.Position (HasLoc(..), Range, emptyRange)
import qualified Cryptol.TypeCheck as T
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.TypeCheck.PP as T
import qualified Cryptol.TypeCheck.Sanity as TcSanity
import Cryptol.Transform.AddModParams (addModParams)
import Cryptol.Utils.Ident (preludeName, interactiveName
, modNameChunks, notParamInstModName
, isParamInstModName )
import Cryptol.Utils.PP (pretty)
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.Logger(logPutStrLn, logPrint)
import Cryptol.Prelude (preludeContents)
import Cryptol.Transform.MonoValues (rewModule)
import qualified Control.Exception as X
import Control.Monad (unless,when)
import qualified Data.ByteString as B
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Text.Encoding (decodeUtf8')
import System.Directory (doesFileExist, canonicalizePath)
import System.FilePath ( addExtension
, isAbsolute
, joinPath
, (>)
, takeDirectory
, takeFileName
)
import qualified System.IO.Error as IOE
import qualified Data.Map as Map
import Prelude ()
import Prelude.Compat hiding ( (<>) )
-- Renaming --------------------------------------------------------------------
rename :: ModName -> R.NamingEnv -> R.RenameM a -> ModuleM a
rename modName env m = do
(res,ws) <- liftSupply $ \ supply ->
case R.runRenamer supply modName env m of
(Right (a,supply'),ws) -> ((Right a,ws),supply')
(Left errs,ws) -> ((Left errs,ws),supply)
renamerWarnings ws
case res of
Right r -> return r
Left errs -> renamerErrors errs
-- | Rename a module in the context of its imported modules.
renameModule :: P.Module PName
-> ModuleM (IfaceDecls,R.NamingEnv,P.Module Name)
renameModule m = do
(decls,menv) <- importIfaces (map thing (P.mImports m))
(declsEnv,rm) <- rename (thing (mName m)) menv (R.renameModule m)
return (decls,declsEnv,rm)
-- NoPat -----------------------------------------------------------------------
-- | Run the noPat pass.
noPat :: RemovePatterns a => a -> ModuleM a
noPat a = do
let (a',errs) = removePatterns a
unless (null errs) (noPatErrors errs)
return a'
-- Parsing ---------------------------------------------------------------------
parseModule :: ModulePath -> ModuleM (Fingerprint, P.Module PName)
parseModule path = do
bytesRes <- case path of
InFile p -> io (X.try (B.readFile p))
InMem _ bs -> pure (Right bs)
bytes <- case bytesRes of
Right bytes -> return bytes
Left exn ->
case path of
InFile p
| IOE.isDoesNotExistError exn -> cantFindFile p
| otherwise -> otherIOError p exn
InMem p _ -> panic "parseModule"
[ "IOError for in-memory contetns???"
, "Label: " ++ show p
, "Exception: " ++ show exn ]
txt <- case decodeUtf8' bytes of
Right txt -> return txt
Left e -> badUtf8 path e
let cfg = P.defaultConfig
{ P.cfgSource = case path of
InFile p -> p
InMem l _ -> l
, P.cfgPreProc = P.guessPreProc (modulePathLabel path)
}
case P.parseModule cfg txt of
Right pm -> let fp = fingerprint bytes
in fp `seq` return (fp, pm)
Left err -> moduleParseError path err
-- Modules ---------------------------------------------------------------------
-- | Load a module by its path.
loadModuleByPath :: FilePath -> ModuleM T.Module
loadModuleByPath path = withPrependedSearchPath [ takeDirectory path ] $ do
let fileName = takeFileName path
foundPath <- findFile fileName
(fp, pm) <- parseModule (InFile foundPath)
let n = thing (P.mName pm)
-- Check whether this module name has already been loaded from a different file
env <- getModuleEnv
-- path' is the resolved, absolute path, used only for checking
-- whether it's already been loaded
path' <- io (canonicalizePath foundPath)
case lookupModule n env of
-- loadModule will calculate the canonical path again
Nothing -> doLoadModule (FromModule n) (InFile foundPath) fp pm
Just lm
| path' == loaded -> return (lmModule lm)
| otherwise -> duplicateModuleName n path' loaded
where loaded = lmModuleId lm
-- | Load a module, unless it was previously loaded.
loadModuleFrom :: ImportSource -> ModuleM (ModulePath,T.Module)
loadModuleFrom isrc =
do let n = importedModule isrc
mb <- getLoadedMaybe n
case mb of
Just m -> return (lmFilePath m, lmModule m)
Nothing ->
do path <- findModule n
errorInFile path $
do (fp, pm) <- parseModule path
m <- doLoadModule isrc path fp pm
return (path,m)
-- | Load dependencies, typecheck, and add to the eval environment.
doLoadModule ::
ImportSource ->
ModulePath ->
Fingerprint ->
P.Module PName ->
ModuleM T.Module
doLoadModule isrc path fp pm0 =
loading isrc $
do let pm = addPrelude pm0
loadDeps pm
withLogger logPutStrLn
("Loading module " ++ pretty (P.thing (P.mName pm)))
tcm <- optionalInstantiate =<< checkModule isrc path pm
-- extend the eval env, unless a functor.
unless (T.isParametrizedModule tcm) $ modifyEvalEnv (E.moduleEnv tcm)
loadedModule path fp tcm
return tcm
where
optionalInstantiate tcm
| isParamInstModName (importedModule isrc) =
if T.isParametrizedModule tcm then
case addModParams tcm of
Right tcm1 -> return tcm1
Left xs -> failedToParameterizeModDefs (T.mName tcm) xs
else notAParameterizedModule (T.mName tcm)
| otherwise = return tcm
-- | Rewrite an import declaration to be of the form:
--
-- > import foo as foo [ [hiding] (a,b,c) ]
fullyQualified :: P.Import -> P.Import
fullyQualified i = i { iAs = Just (iModule i) }
-- | Find the interface referenced by an import, and generate the naming
-- environment that it describes.
importIface :: P.Import -> ModuleM (IfaceDecls,R.NamingEnv)
importIface imp =
do Iface { .. } <- getIface (T.iModule imp)
return (ifPublic, R.interpImport imp ifPublic)
-- | Load a series of interfaces, merging their public interfaces.
importIfaces :: [P.Import] -> ModuleM (IfaceDecls,R.NamingEnv)
importIfaces is = mconcat `fmap` mapM importIface is
moduleFile :: ModName -> String -> FilePath
moduleFile n = addExtension (joinPath (modNameChunks n))
-- | Discover a module.
findModule :: ModName -> ModuleM ModulePath
findModule n = do
paths <- getSearchPath
loop (possibleFiles paths)
where
loop paths = case paths of
path:rest -> do
b <- io (doesFileExist path)
if b then return (InFile path) else loop rest
[] -> handleNotFound
handleNotFound =
case n of
m | m == preludeName -> pure (InMem "Cryptol" preludeContents)
_ -> moduleNotFound n =<< getSearchPath
-- generate all possible search paths
possibleFiles paths = do
path <- paths
ext <- P.knownExts
return (path > moduleFile n ext)
-- | Discover a file. This is distinct from 'findModule' in that we
-- assume we've already been given a particular file name.
findFile :: FilePath -> ModuleM FilePath
findFile path | isAbsolute path = do
-- No search path checking for absolute paths
b <- io (doesFileExist path)
if b then return path else cantFindFile path
findFile path = do
paths <- getSearchPath
loop (possibleFiles paths)
where
loop paths = case paths of
path':rest -> do
b <- io (doesFileExist path')
if b then return path' else loop rest
[] -> cantFindFile path
possibleFiles paths = map (> path) paths
-- | Add the prelude to the import list if it's not already mentioned.
addPrelude :: P.Module PName -> P.Module PName
addPrelude m
| preludeName == P.thing (P.mName m) = m
| preludeName `elem` importedMods = m
| otherwise = m { mImports = importPrelude : mImports m }
where
importedMods = map (P.iModule . P.thing) (P.mImports m)
importPrelude = P.Located
{ P.srcRange = emptyRange
, P.thing = P.Import
{ iModule = preludeName
, iAs = Nothing
, iSpec = Nothing
}
}
-- | Load the dependencies of a module into the environment.
loadDeps :: P.Module name -> ModuleM ()
loadDeps m =
do mapM_ loadI (P.mImports m)
mapM_ loadF (P.mInstance m)
where
loadI i = do (_,m1) <- loadModuleFrom (FromImport i)
when (T.isParametrizedModule m1) $ importParamModule $ T.mName m1
loadF f = do _ <- loadModuleFrom (FromModuleInstance f)
return ()
-- Type Checking ---------------------------------------------------------------
-- | Load the local environment, which consists of the environment for the
-- currently opened module, shadowed by the dynamic environment.
getLocalEnv :: ModuleM (IfaceParams,IfaceDecls,R.NamingEnv)
getLocalEnv =
do (params,decls,fNames,_) <- getFocusedEnv
denv <- getDynEnv
let dynDecls = deIfaceDecls denv
return (params,dynDecls `mappend` decls, deNames denv `R.shadowing` fNames)
-- | Typecheck a single expression, yielding a renamed parsed expression,
-- typechecked core expression, and a type schema.
checkExpr :: P.Expr PName -> ModuleM (P.Expr Name,T.Expr,T.Schema)
checkExpr e = do
(params,decls,names) <- getLocalEnv
-- run NoPat
npe <- noPat e
-- rename the expression with dynamic names shadowing the opened environment
re <- rename interactiveName names (R.rename npe)
-- merge the dynamic and opened environments for typechecking
prims <- getPrimMap
let act = TCAction { tcAction = T.tcExpr, tcLinter = exprLinter
, tcPrims = prims }
(te,s) <- typecheck act re params decls
return (re,te,s)
-- | Typecheck a group of declarations.
--
-- INVARIANT: This assumes that NoPat has already been run on the declarations.
checkDecls :: [P.TopDecl PName] -> ModuleM (R.NamingEnv,[T.DeclGroup])
checkDecls ds = do
(params,decls,names) <- getLocalEnv
-- introduce names for the declarations before renaming them
declsEnv <- liftSupply (R.namingEnv' (map (R.InModule interactiveName) ds))
rds <- rename interactiveName (declsEnv `R.shadowing` names)
(traverse R.rename ds)
prims <- getPrimMap
let act = TCAction { tcAction = T.tcDecls, tcLinter = declsLinter
, tcPrims = prims }
ds' <- typecheck act rds params decls
return (declsEnv,ds')
-- | Generate the primitive map. If the prelude is currently being loaded, this
-- should be generated directly from the naming environment given to the renamer
-- instead.
getPrimMap :: ModuleM PrimMap
getPrimMap =
do env <- getModuleEnv
case lookupModule preludeName env of
Just lm -> return (ifacePrimMap (lmInterface lm))
Nothing -> panic "Cryptol.ModuleSystem.Base.getPrimMap"
[ "Unable to find the prelude" ]
-- | Load a module, be it a normal module or a functor instantiation.
checkModule :: ImportSource -> ModulePath -> P.Module PName -> ModuleM T.Module
checkModule isrc path m =
case P.mInstance m of
Nothing -> checkSingleModule T.tcModule isrc path m
Just fmName -> do tf <- getLoaded (thing fmName)
checkSingleModule (T.tcModuleInst tf) isrc path m
-- | Typecheck a single module. If the module is an instantiation
-- of a functor, then this just type-checks the instantiating parameters.
-- See 'checkModule'
checkSingleModule ::
Act (P.Module Name) T.Module {- ^ how to check -} ->
ImportSource {- ^ why are we loading this -} ->
ModulePath {- path -} ->
P.Module PName {- ^ module to check -} ->
ModuleM T.Module
checkSingleModule how isrc path m = do
-- check that the name of the module matches expectations
let nm = importedModule isrc
unless (notParamInstModName nm == thing (P.mName m))
(moduleNameMismatch nm (mName m))
-- remove includes first; we only do this for actual files.
-- it is less clear what should happen for in-memory things, and since
-- this is a more-or-less obsolete feature, we are just not doing
-- ot for now.
e <- case path of
InFile p -> io (removeIncludesModule p m)
InMem {} -> pure (Right m)
nim <- case e of
Right nim -> return nim
Left ierrs -> noIncludeErrors ierrs
-- remove pattern bindings
npm <- noPat nim
-- rename everything
(tcEnv,declsEnv,scm) <- renameModule npm
-- when generating the prim map for the typechecker, if we're checking the
-- prelude, we have to generate the map from the renaming environment, as we
-- don't have the interface yet.
prims <- if thing (mName m) == preludeName
then return (R.toPrimMap declsEnv)
else getPrimMap
-- typecheck
let act = TCAction { tcAction = how
, tcLinter = moduleLinter (P.thing (P.mName m))
, tcPrims = prims }
tcm0 <- typecheck act scm noIfaceParams tcEnv
let tcm = tcm0 -- fromMaybe tcm0 (addModParams tcm0)
liftSupply (`rewModule` tcm)
data TCLinter o = TCLinter
{ lintCheck ::
o -> T.InferInput -> Either TcSanity.Error [TcSanity.ProofObligation]
, lintModule :: Maybe P.ModName
}
exprLinter :: TCLinter (T.Expr, T.Schema)
exprLinter = TCLinter
{ lintCheck = \(e',s) i ->
case TcSanity.tcExpr i e' of
Left err -> Left err
Right (s1,os)
| TcSanity.same s s1 -> Right os
| otherwise -> Left (TcSanity.TypeMismatch "exprLinter" s s1)
, lintModule = Nothing
}
declsLinter :: TCLinter [ T.DeclGroup ]
declsLinter = TCLinter
{ lintCheck = \ds' i -> case TcSanity.tcDecls i ds' of
Left err -> Left err
Right os -> Right os
, lintModule = Nothing
}
moduleLinter :: P.ModName -> TCLinter T.Module
moduleLinter m = TCLinter
{ lintCheck = \m' i -> case TcSanity.tcModule i m' of
Left err -> Left err
Right os -> Right os
, lintModule = Just m
}
type Act i o = i -> T.InferInput -> IO (T.InferOutput o)
data TCAction i o = TCAction
{ tcAction :: Act i o
, tcLinter :: TCLinter o
, tcPrims :: PrimMap
}
typecheck ::
(Show i, Show o, HasLoc i) => TCAction i o -> i ->
IfaceParams -> IfaceDecls -> ModuleM o
typecheck act i params env = do
let range = fromMaybe emptyRange (getLoc i)
input <- genInferInput range (tcPrims act) params env
out <- io (tcAction act i input)
case out of
T.InferOK warns seeds supply' o ->
do setNameSeeds seeds
setSupply supply'
typeCheckWarnings warns
menv <- getModuleEnv
case meCoreLint menv of
NoCoreLint -> return ()
CoreLint -> case lintCheck (tcLinter act) o input of
Right as ->
let ppIt l = mapM_ (logPrint l . T.pp)
in withLogger ppIt as
Left err -> panic "Core lint failed:" [show err]
return o
T.InferFailed warns errs ->
do typeCheckWarnings warns
typeCheckingFailed errs
-- | Generate input for the typechecker.
genInferInput :: Range -> PrimMap ->
IfaceParams -> IfaceDecls -> ModuleM T.InferInput
genInferInput r prims params env = do
seeds <- getNameSeeds
monoBinds <- getMonoBinds
cfg <- getSolverConfig
supply <- getSupply
searchPath <- getSearchPath
-- TODO: include the environment needed by the module
return T.InferInput
{ T.inpRange = r
, T.inpVars = Map.map ifDeclSig (ifDecls env)
, T.inpTSyns = ifTySyns env
, T.inpNewtypes = ifNewtypes env
, T.inpAbstractTypes = ifAbstractTypes env
, T.inpNameSeeds = seeds
, T.inpMonoBinds = monoBinds
, T.inpSolverConfig = cfg
, T.inpSearchPath = searchPath
, T.inpSupply = supply
, T.inpPrimNames = prims
, T.inpParamTypes = ifParamTypes params
, T.inpParamConstraints = ifParamConstraints params
, T.inpParamFuns = ifParamFuns params
}
-- Evaluation ------------------------------------------------------------------
evalExpr :: T.Expr -> ModuleM E.Value
evalExpr e = do
env <- getEvalEnv
denv <- getDynEnv
evopts <- getEvalOpts
io $ E.runEval evopts $ (E.evalExpr (env <> deEnv denv) e)
evalDecls :: [T.DeclGroup] -> ModuleM ()
evalDecls dgs = do
env <- getEvalEnv
denv <- getDynEnv
evOpts <- getEvalOpts
let env' = env <> deEnv denv
deEnv' <- io $ E.runEval evOpts $ E.evalDecls dgs env'
let denv' = denv { deDecls = deDecls denv ++ dgs
, deEnv = deEnv'
}
setDynEnv denv'
cryptol-2.8.0/src/Cryptol/ModuleSystem/Env.hs 0000644 0000000 0000000 00000031306 07346545000 017352 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.ModuleSystem.Env
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.ModuleSystem.Env where
#ifndef RELOCATABLE
import Paths_cryptol (getDataDir)
#endif
import Cryptol.Eval (EvalEnv)
import Cryptol.ModuleSystem.Fingerprint
import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Name (Supply,emptySupply)
import qualified Cryptol.ModuleSystem.NamingEnv as R
import Cryptol.Parser.AST
import qualified Cryptol.TypeCheck as T
import qualified Cryptol.TypeCheck.AST as T
import Cryptol.Utils.PP (PP(..),text,parens,NameDisp)
import Data.ByteString(ByteString)
import Control.Monad (guard,mplus)
import qualified Control.Exception as X
import Data.Function (on)
import qualified Data.Map as Map
import Data.Maybe(fromMaybe)
import Data.Semigroup
import System.Directory (getAppUserDataDirectory, getCurrentDirectory)
import System.Environment(getExecutablePath)
import System.FilePath ((>), normalise, joinPath, splitPath, takeDirectory)
import qualified Data.List as List
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
-- Module Environment ----------------------------------------------------------
-- | This is the current state of the interpreter.
data ModuleEnv = ModuleEnv
{ meLoadedModules :: LoadedModules
-- ^ Information about all loaded modules. See 'LoadedModule'.
-- Contains information such as the file where the module was loaded
-- from, as well as the module's interface, used for type checking.
, meNameSeeds :: T.NameSeeds
-- ^ A source of new names for the type checker.
, meSolverConfig :: T.SolverConfig
-- ^ Configuration settings for the SMT solver used for type-checking.
, meEvalEnv :: EvalEnv
-- ^ The evaluation environment. Contains the values for all loaded
-- modules, both public and private.
, meCoreLint :: CoreLint
-- ^ Should we run the linter to ensure sanity.
, meMonoBinds :: !Bool
-- ^ Are we assuming that local bindings are monomorphic.
-- XXX: We should probably remove this flag, and set it to 'True'.
, meFocusedModule :: Maybe ModName
-- ^ The "current" module. Used to decide how to print names, for example.
, meSearchPath :: [FilePath]
-- ^ Where we look for things.
, meDynEnv :: DynamicEnv
-- ^ This contains additional definitions that were made at the command
-- line, and so they don't reside in any module.
, meSupply :: !Supply
-- ^ Name source for the renamer
} deriving Generic
instance NFData ModuleEnv
-- | Should we run the linter?
data CoreLint = NoCoreLint -- ^ Don't run core lint
| CoreLint -- ^ Run core lint
deriving (Generic, NFData)
resetModuleEnv :: ModuleEnv -> ModuleEnv
resetModuleEnv env = env
{ meLoadedModules = mempty
, meNameSeeds = T.nameSeeds
, meEvalEnv = mempty
, meFocusedModule = Nothing
, meDynEnv = mempty
}
initialModuleEnv :: IO ModuleEnv
initialModuleEnv = do
curDir <- getCurrentDirectory
#ifndef RELOCATABLE
dataDir <- getDataDir
#endif
binDir <- takeDirectory `fmap` getExecutablePath
let instDir = normalise . joinPath . init . splitPath $ binDir
-- looking up this directory can fail if no HOME is set, as in some
-- CI settings
let handle :: X.IOException -> IO String
handle _e = return ""
userDir <- X.catch (getAppUserDataDirectory "cryptol") handle
let searchPath = [ curDir
-- something like $HOME/.cryptol
, userDir
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
-- ../cryptol on win32
, instDir > "cryptol"
#else
-- ../share/cryptol on others
, instDir > "share" > "cryptol"
#endif
#ifndef RELOCATABLE
-- Cabal-defined data directory. Since this
-- is usually a global location like
-- /usr/local, search this one last in case
-- someone has multiple Cryptols
, dataDir
#endif
]
return ModuleEnv
{ meLoadedModules = mempty
, meNameSeeds = T.nameSeeds
, meEvalEnv = mempty
, meFocusedModule = Nothing
-- we search these in order, taking the first match
, meSearchPath = searchPath
, meDynEnv = mempty
, meMonoBinds = True
, meSolverConfig = T.SolverConfig
{ T.solverPath = "z3"
, T.solverArgs = [ "-smt2", "-in" ]
, T.solverVerbose = 0
, T.solverPreludePath = searchPath
}
, meCoreLint = NoCoreLint
, meSupply = emptySupply
}
-- | Try to focus a loaded module in the module environment.
focusModule :: ModName -> ModuleEnv -> Maybe ModuleEnv
focusModule n me = do
guard (isLoaded n (meLoadedModules me))
return me { meFocusedModule = Just n }
-- | Get a list of all the loaded modules. Each module in the
-- resulting list depends only on other modules that precede it.
-- Note that this includes parameterized modules.
loadedModules :: ModuleEnv -> [T.Module]
loadedModules = map lmModule . getLoadedModules . meLoadedModules
-- | Get a list of all the loaded non-parameterized modules.
-- These are the modules that can be used for evaluation, proving etc.
loadedNonParamModules :: ModuleEnv -> [T.Module]
loadedNonParamModules = map lmModule . lmLoadedModules . meLoadedModules
-- | Are any parameterized modules loaded?
hasParamModules :: ModuleEnv -> Bool
hasParamModules = not . null . lmLoadedParamModules . meLoadedModules
-- | Produce an ifaceDecls that represents the focused environment of the module
-- system, as well as a 'NameDisp' for pretty-printing names according to the
-- imports.
--
-- XXX This could really do with some better error handling, just returning
-- mempty when one of the imports fails isn't really desirable.
--
-- XXX: This is not quite right. For example, it does not take into
-- account *how* things were imported in a module (e.g., qualified).
-- It would be simpler to simply store the naming environment that was
-- actually used when we renamed the module.
focusedEnv :: ModuleEnv -> (IfaceParams,IfaceDecls,R.NamingEnv,NameDisp)
focusedEnv me =
fromMaybe (noIfaceParams, mempty, mempty, mempty) $
do fm <- meFocusedModule me
lm <- lookupModule fm me
deps <- mapM loadImport (T.mImports (lmModule lm))
let (ifaces,names) = unzip deps
Iface { .. } = lmInterface lm
localDecls = ifPublic `mappend` ifPrivate
localNames = R.unqualifiedEnv localDecls `mappend`
R.modParamsNamingEnv ifParams
namingEnv = localNames `R.shadowing` mconcat names
return ( ifParams
, mconcat (localDecls:ifaces)
, namingEnv
, R.toNameDisp namingEnv)
where
loadImport imp =
do lm <- lookupModule (iModule imp) me
let decls = ifPublic (lmInterface lm)
return (decls,R.interpImport imp decls)
-- | The unqualified declarations and name environment for the dynamic
-- environment.
dynamicEnv :: ModuleEnv -> (IfaceDecls,R.NamingEnv,NameDisp)
dynamicEnv me = (decls,names,R.toNameDisp names)
where
decls = deIfaceDecls (meDynEnv me)
names = R.unqualifiedEnv decls
-- Loaded Modules --------------------------------------------------------------
-- | The location of a module
data ModulePath = InFile FilePath
| InMem String ByteString -- ^ Label, content
deriving (Show, Generic, NFData)
-- | In-memory things are compared by label.
instance Eq ModulePath where
p1 == p2 =
case (p1,p2) of
(InFile x, InFile y) -> x == y
(InMem a _, InMem b _) -> a == b
_ -> False
instance PP ModulePath where
ppPrec _ e =
case e of
InFile p -> text p
InMem l _ -> parens (text l)
-- | The name of the content---either the file path, or the provided label.
modulePathLabel :: ModulePath -> String
modulePathLabel p =
case p of
InFile path -> path
InMem lab _ -> lab
data LoadedModules = LoadedModules
{ lmLoadedModules :: [LoadedModule]
-- ^ Invariants:
-- 1) All the dependencies of any module `m` must precede `m` in the list.
-- 2) Does not contain any parameterized modules.
, lmLoadedParamModules :: [LoadedModule]
-- ^ Loaded parameterized modules.
} deriving (Show, Generic, NFData)
getLoadedModules :: LoadedModules -> [LoadedModule]
getLoadedModules x = lmLoadedParamModules x ++ lmLoadedModules x
instance Semigroup LoadedModules where
l <> r = LoadedModules
{ lmLoadedModules = List.unionBy ((==) `on` lmName)
(lmLoadedModules l) (lmLoadedModules r)
, lmLoadedParamModules = lmLoadedParamModules l ++ lmLoadedParamModules r }
instance Monoid LoadedModules where
mempty = LoadedModules { lmLoadedModules = []
, lmLoadedParamModules = []
}
mappend l r = l <> r
data LoadedModule = LoadedModule
{ lmName :: ModName
, lmFilePath :: ModulePath
-- ^ The file path used to load this module (may not be canonical)
, lmModuleId :: String
-- ^ An identifier used to identify the source of the bytes for the module.
-- For files we just use the cononical path, for in memory things we
-- use their label.
, lmInterface :: Iface
, lmModule :: T.Module
, lmFingerprint :: Fingerprint
} deriving (Show, Generic, NFData)
-- | Has this module been loaded already.
isLoaded :: ModName -> LoadedModules -> Bool
isLoaded mn lm = any ((mn ==) . lmName) (getLoadedModules lm)
-- | Is this a loaded parameterized module.
isLoadedParamMod :: ModName -> LoadedModules -> Bool
isLoadedParamMod mn ln = any ((mn ==) . lmName) (lmLoadedParamModules ln)
-- | Try to find a previously loaded module
lookupModule :: ModName -> ModuleEnv -> Maybe LoadedModule
lookupModule mn me = search lmLoadedModules `mplus` search lmLoadedParamModules
where
search how = List.find ((mn ==) . lmName) (how (meLoadedModules me))
-- | Add a freshly loaded module. If it was previously loaded, then
-- the new version is ignored.
addLoadedModule ::
ModulePath -> String -> Fingerprint -> T.Module -> LoadedModules -> LoadedModules
addLoadedModule path ident fp tm lm
| isLoaded (T.mName tm) lm = lm
| T.isParametrizedModule tm = lm { lmLoadedParamModules = loaded :
lmLoadedParamModules lm }
| otherwise = lm { lmLoadedModules =
lmLoadedModules lm ++ [loaded] }
where
loaded = LoadedModule
{ lmName = T.mName tm
, lmFilePath = path
, lmModuleId = ident
, lmInterface = genIface tm
, lmModule = tm
, lmFingerprint = fp
}
-- | Remove a previously loaded module.
removeLoadedModule :: (LoadedModule -> Bool) -> LoadedModules -> LoadedModules
removeLoadedModule rm lm =
LoadedModules
{ lmLoadedModules = filter (not . rm) (lmLoadedModules lm)
, lmLoadedParamModules = filter (not . rm) (lmLoadedParamModules lm)
}
-- Dynamic Environments --------------------------------------------------------
-- | Extra information we need to carry around to dynamically extend
-- an environment outside the context of a single module. Particularly
-- useful when dealing with interactive declarations as in @:let@ or
-- @it@.
data DynamicEnv = DEnv
{ deNames :: R.NamingEnv
, deDecls :: [T.DeclGroup]
, deEnv :: EvalEnv
} deriving (Generic, NFData)
instance Semigroup DynamicEnv where
de1 <> de2 = DEnv
{ deNames = deNames de1 <> deNames de2
, deDecls = deDecls de1 <> deDecls de2
, deEnv = deEnv de1 <> deEnv de2
}
instance Monoid DynamicEnv where
mempty = DEnv
{ deNames = mempty
, deDecls = mempty
, deEnv = mempty
}
mappend de1 de2 = de1 <> de2
-- | Build 'IfaceDecls' that correspond to all of the bindings in the
-- dynamic environment.
--
-- XXX: if we ever add type synonyms or newtypes at the REPL, revisit
-- this.
deIfaceDecls :: DynamicEnv -> IfaceDecls
deIfaceDecls DEnv { deDecls = dgs } =
mconcat [ IfaceDecls
{ ifTySyns = Map.empty
, ifNewtypes = Map.empty
, ifAbstractTypes = Map.empty
, ifDecls = Map.singleton (ifDeclName ifd) ifd
}
| decl <- concatMap T.groupDecls dgs
, let ifd = mkIfaceDecl decl
]
cryptol-2.8.0/src/Cryptol/ModuleSystem/Exports.hs 0000644 0000000 0000000 00000004372 07346545000 020271 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveGeneric #-}
module Cryptol.ModuleSystem.Exports where
import Data.Set(Set)
import qualified Data.Set as Set
import Data.Foldable(fold)
import Data.Semigroup (Semigroup(..))
import Control.DeepSeq(NFData)
import GHC.Generics (Generic)
import Cryptol.Parser.AST
import Cryptol.Parser.Names
modExports :: Ord name => Module name -> ExportSpec name
modExports m = fold (concat [ exportedNames d | d <- mDecls m ])
where
names by td = [ td { tlValue = thing n } | n <- fst (by (tlValue td)) ]
exportedNames (Decl td) = map exportBind (names namesD td)
++ map exportType (names tnamesD td)
exportedNames (DPrimType t) = [ exportType (thing . primTName <$> t) ]
exportedNames (TDNewtype nt) = map exportType (names tnamesNT nt)
exportedNames (Include {}) = []
exportedNames (DParameterFun {}) = []
exportedNames (DParameterType {}) = []
exportedNames (DParameterConstraint {}) = []
data ExportSpec name = ExportSpec { eTypes :: Set name
, eBinds :: Set name
} deriving (Show, Generic)
instance NFData name => NFData (ExportSpec name)
instance Ord name => Semigroup (ExportSpec name) where
l <> r = ExportSpec { eTypes = eTypes l <> eTypes r
, eBinds = eBinds l <> eBinds r
}
instance Ord name => Monoid (ExportSpec name) where
mempty = ExportSpec { eTypes = mempty, eBinds = mempty }
mappend = (<>)
-- | Add a binding name to the export list, if it should be exported.
exportBind :: Ord name => TopLevel name -> ExportSpec name
exportBind n
| tlExport n == Public = mempty { eBinds = Set.singleton (tlValue n) }
| otherwise = mempty
-- | Add a type synonym name to the export list, if it should be exported.
exportType :: Ord name => TopLevel name -> ExportSpec name
exportType n
| tlExport n == Public = mempty { eTypes = Set.singleton (tlValue n) }
| otherwise = mempty
-- | Check to see if a binding is exported.
isExportedBind :: Ord name => name -> ExportSpec name -> Bool
isExportedBind n = Set.member n . eBinds
-- | Check to see if a type synonym is exported.
isExportedType :: Ord name => name -> ExportSpec name -> Bool
isExportedType n = Set.member n . eTypes
cryptol-2.8.0/src/Cryptol/ModuleSystem/Fingerprint.hs 0000644 0000000 0000000 00000002237 07346545000 021112 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.ModuleSystem.Fingerprint
-- Copyright : (c) 2019 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
module Cryptol.ModuleSystem.Fingerprint
( Fingerprint
, fingerprint
, fingerprintFile
) where
import Control.DeepSeq (NFData (rnf))
import Crypto.Hash.SHA1 (hash)
import Data.ByteString (ByteString)
import System.IO.Error (IOError)
import Control.Exception (try)
import qualified Data.ByteString as B
newtype Fingerprint = Fingerprint ByteString
deriving (Eq, Show)
instance NFData Fingerprint where
rnf (Fingerprint fp) = rnf fp
-- | Compute a fingerprint for a bytestring.
fingerprint :: ByteString -> Fingerprint
fingerprint = Fingerprint . hash
-- | Attempt to compute the fingerprint of the file at the given path.
-- Returns 'Nothing' in the case of an error.
fingerprintFile :: FilePath -> IO (Maybe Fingerprint)
fingerprintFile path =
do res <- try (B.readFile path)
return $!
case res :: Either IOError ByteString of
Left{} -> Nothing
Right b -> Just $! fingerprint b
cryptol-2.8.0/src/Cryptol/ModuleSystem/InstantiateModule.hs 0000644 0000000 0000000 00000024255 07346545000 022260 0 ustar 00 0000000 0000000 {-# Language FlexibleInstances, PatternGuards #-}
-- | Assumes that local names do not shadow top level names.
module Cryptol.ModuleSystem.InstantiateModule
( instantiateModule
) where
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import MonadLib(ReaderT,runReaderT,ask)
import Cryptol.Parser.Position(Located(..))
import Cryptol.ModuleSystem.Name
import Cryptol.ModuleSystem.Exports(ExportSpec(..))
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Subst(listParamSubst, apSubst)
import Cryptol.Utils.Ident(ModName,modParamIdent)
{-
XXX: Should we simplify constraints in the instantiated modules?
If so, we also need to adjust the constraint parameters on terms appropriately,
especially when working with dictionaries.
-}
-- | Convert a module instantiation into a partial module.
-- The resulting module is incomplete because it is missing the definitions
-- from the instantiation.
instantiateModule :: FreshM m =>
Module {- ^ Parametrized module -} ->
ModName {- ^ Name of the new module -} ->
Map TParam Type {- ^ Type params -} ->
Map Name Expr {- ^ Value parameters -} ->
m ([Located Prop], Module)
-- ^ Instantiated constraints, fresh module, new supply
instantiateModule func newName tpMap vpMap =
runReaderT newName $
do let oldVpNames = Map.keys vpMap
newVpNames <- mapM freshParamName (Map.keys vpMap)
let vpNames = Map.fromList (zip oldVpNames newVpNames)
env <- computeEnv func tpMap vpNames
let rnMp :: Inst a => (a -> Name) -> Map Name a -> Map Name a
rnMp f m = Map.fromList [ (f x, x) | a <- Map.elems m
, let x = inst env a ]
renamedExports = inst env (mExports func)
renamedTySyns = rnMp tsName (mTySyns func)
renamedNewtypes = rnMp ntName (mNewtypes func)
renamedPrimTys = rnMp atName (mPrimTypes func)
su = listParamSubst (Map.toList (tyParamMap env))
goals = map (fmap (apSubst su)) (mParamConstraints func)
-- Constraints to discharge about the type instances
let renamedDecls = inst env (mDecls func)
paramDecls = map (mkParamDecl su vpNames) (Map.toList vpMap)
return ( goals
, Module
{ mName = newName
, mExports = renamedExports
, mImports = mImports func
, mTySyns = renamedTySyns
, mNewtypes = renamedNewtypes
, mPrimTypes = renamedPrimTys
, mParamTypes = Map.empty
, mParamConstraints = []
, mParamFuns = Map.empty
, mDecls = paramDecls ++ renamedDecls
} )
where
mkParamDecl su vpNames (x,e) =
NonRecursive Decl
{ dName = Map.findWithDefault (error "OOPS") x vpNames
, dSignature = apSubst su
$ mvpType
$ Map.findWithDefault (error "UUPS") x (mParamFuns func)
, dDefinition = DExpr e
, dPragmas = [] -- XXX: which if any pragmas?
, dInfix = False -- XXX: get from parameter?
, dFixity = Nothing -- XXX: get from parameter
, dDoc = Nothing -- XXX: get from parametr(or instance?)
}
--------------------------------------------------------------------------------
-- Things that need to be renamed
class Defines t where
defines :: t -> Set Name
instance Defines t => Defines [t] where
defines = Set.unions . map defines
instance Defines Decl where
defines = Set.singleton . dName
instance Defines DeclGroup where
defines d =
case d of
NonRecursive x -> defines x
Recursive x -> defines x
--------------------------------------------------------------------------------
type InstM = ReaderT ModName
-- | Generate a new instance of a declared name.
freshenName :: FreshM m => Name -> InstM m Name
freshenName x =
do m <- ask
let sys = case nameInfo x of
Declared _ s -> s
_ -> UserName
liftSupply (mkDeclared m sys (nameIdent x) (nameFixity x) (nameLoc x))
freshParamName :: FreshM m => Name -> InstM m Name
freshParamName x =
do m <- ask
let newName = modParamIdent (nameIdent x)
liftSupply (mkDeclared m UserName newName (nameFixity x) (nameLoc x))
-- | Compute renaming environment from a module instantiation.
-- computeEnv :: ModInst -> InstM Env
computeEnv :: FreshM m =>
Module {- ^ Functor being instantiated -} ->
Map TParam Type {- replace type params by type -} ->
Map Name Name {- replace value parameters by other names -} ->
InstM m Env
computeEnv m tpMap vpMap =
do tss <- mapM freshTy (Map.toList (mTySyns m))
nts <- mapM freshTy (Map.toList (mNewtypes m))
let tnMap = Map.fromList (tss ++ nts)
defHere <- mapM mkVParam (Set.toList (defines (mDecls m)))
let fnMap = Map.union vpMap (Map.fromList defHere)
return Env { funNameMap = fnMap
, tyNameMap = tnMap
, tyParamMap = tpMap
}
where
freshTy (x,_) = do y <- freshenName x
return (x,y)
mkVParam x = do y <- freshenName x
return (x,y)
--------------------------------------------------------------------------------
-- Do the renaming
data Env = Env
{ funNameMap :: Map Name Name
, tyNameMap :: Map Name Name
, tyParamMap :: Map TParam Type
} deriving Show
class Inst t where
inst :: Env -> t -> t
instance Inst a => Inst [a] where
inst env = map (inst env)
instance Inst Expr where
inst env = go
where
go expr =
case expr of
EVar x -> case Map.lookup x (funNameMap env) of
Just y -> EVar y
_ -> expr
EList xs t -> EList (inst env xs) (inst env t)
ETuple es -> ETuple (inst env es)
ERec xs -> ERec [ (f,go e) | (f,e) <- xs ]
ESel e s -> ESel (go e) s
ESet e x v -> ESet (go e) x (go v)
EIf e1 e2 e3 -> EIf (go e1) (go e2) (go e3)
EComp t1 t2 e mss -> EComp (inst env t1) (inst env t2)
(go e)
(inst env mss)
ETAbs t e -> ETAbs t (go e)
ETApp e t -> ETApp (go e) (inst env t)
EApp e1 e2 -> EApp (go e1) (go e2)
EAbs x t e -> EAbs x (inst env t) (go e)
EProofAbs p e -> EProofAbs (inst env p) (go e)
EProofApp e -> EProofApp (go e)
EWhere e ds -> EWhere (go e) (inst env ds)
instance Inst DeclGroup where
inst env dg =
case dg of
NonRecursive d -> NonRecursive (inst env d)
Recursive ds -> Recursive (inst env ds)
instance Inst DeclDef where
inst env d =
case d of
DPrim -> DPrim
DExpr e -> DExpr (inst env e)
instance Inst Decl where
inst env d = d { dSignature = inst env (dSignature d)
, dDefinition = inst env (dDefinition d)
, dName = Map.findWithDefault (dName d) (dName d)
(funNameMap env)
}
instance Inst Match where
inst env m =
case m of
From x t1 t2 e -> From x (inst env t1) (inst env t2) (inst env e)
Let d -> Let (inst env d)
instance Inst Schema where
inst env s = s { sProps = inst env (sProps s)
, sType = inst env (sType s)
}
instance Inst Type where
inst env ty =
case ty of
TCon tc ts -> TCon (inst env tc) (inst env ts)
TVar tv ->
case tv of
TVBound tp | Just t <- Map.lookup tp (tyParamMap env) -> t
_ -> ty
TUser x ts t -> TUser y (inst env ts) (inst env t)
where y = Map.findWithDefault x x (tyNameMap env)
TRec fs -> TRec [ (f, inst env t) | (f,t) <- fs ]
instance Inst TCon where
inst env tc =
case tc of
TC x -> TC (inst env x)
_ -> tc
instance Inst TC where
inst env tc =
case tc of
TCNewtype x -> TCNewtype (inst env x)
TCAbstract x -> TCAbstract (inst env x)
_ -> tc
instance Inst UserTC where
inst env (UserTC x t) = UserTC y t
where y = Map.findWithDefault x x (tyNameMap env)
instance Inst (ExportSpec Name) where
inst env es = ExportSpec { eTypes = Set.map instT (eTypes es)
, eBinds = Set.map instV (eBinds es)
}
where instT x = Map.findWithDefault x x (tyNameMap env)
instV x = Map.findWithDefault x x (funNameMap env)
instance Inst TySyn where
inst env ts = TySyn { tsName = instTyName env x
, tsParams = tsParams ts
, tsConstraints = inst env (tsConstraints ts)
, tsDef = inst env (tsDef ts)
, tsDoc = tsDoc ts
}
where x = tsName ts
instance Inst Newtype where
inst env nt = Newtype { ntName = instTyName env x
, ntParams = ntParams nt
, ntConstraints = inst env (ntConstraints nt)
, ntFields = [ (f,inst env t) | (f,t) <- ntFields nt ]
, ntDoc = ntDoc nt
}
where x = ntName nt
instance Inst AbstractType where
inst env a = AbstractType { atName = instTyName env (atName a)
, atKind = atKind a
, atCtrs = case atCtrs a of
(xs,ps) -> (xs, inst env ps)
, atFixitiy = atFixitiy a
, atDoc = atDoc a
}
instTyName :: Env -> Name -> Name
instTyName env x = Map.findWithDefault x x (tyNameMap env)
cryptol-2.8.0/src/Cryptol/ModuleSystem/Interface.hs 0000644 0000000 0000000 00000012554 07346545000 020526 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.ModuleSystem.Interface
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.ModuleSystem.Interface (
Iface(..)
, IfaceDecls(..)
, IfaceTySyn, ifTySynName
, IfaceNewtype
, IfaceDecl(..), mkIfaceDecl
, IfaceParams(..)
, genIface
, ifacePrimMap
, noIfaceParams
) where
import Cryptol.ModuleSystem.Name
import Cryptol.TypeCheck.AST
import Cryptol.Utils.Ident (ModName)
import Cryptol.Parser.Position(Located)
import qualified Data.Map as Map
import Data.Semigroup
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
-- | The resulting interface generated by a module that has been typechecked.
data Iface = Iface
{ ifModName :: !ModName -- ^ Module name
, ifPublic :: IfaceDecls -- ^ Exported definitions
, ifPrivate :: IfaceDecls -- ^ Private defintiions
, ifParams :: IfaceParams -- ^ Uninterpreted constants (aka module params)
} deriving (Show, Generic, NFData)
data IfaceParams = IfaceParams
{ ifParamTypes :: Map.Map Name ModTParam
, ifParamConstraints :: [Located Prop] -- ^ Constraints on param. types
, ifParamFuns :: Map.Map Name ModVParam
} deriving (Show, Generic, NFData)
noIfaceParams :: IfaceParams
noIfaceParams = IfaceParams
{ ifParamTypes = Map.empty
, ifParamConstraints = []
, ifParamFuns = Map.empty
}
data IfaceDecls = IfaceDecls
{ ifTySyns :: Map.Map Name IfaceTySyn
, ifNewtypes :: Map.Map Name IfaceNewtype
, ifAbstractTypes :: Map.Map Name IfaceAbstractType
, ifDecls :: Map.Map Name IfaceDecl
} deriving (Show, Generic, NFData)
instance Semigroup IfaceDecls where
l <> r = IfaceDecls
{ ifTySyns = Map.union (ifTySyns l) (ifTySyns r)
, ifNewtypes = Map.union (ifNewtypes l) (ifNewtypes r)
, ifAbstractTypes = Map.union (ifAbstractTypes l) (ifAbstractTypes r)
, ifDecls = Map.union (ifDecls l) (ifDecls r)
}
instance Monoid IfaceDecls where
mempty = IfaceDecls Map.empty Map.empty Map.empty Map.empty
mappend l r = l <> r
mconcat ds = IfaceDecls
{ ifTySyns = Map.unions (map ifTySyns ds)
, ifNewtypes = Map.unions (map ifNewtypes ds)
, ifAbstractTypes = Map.unions (map ifAbstractTypes ds)
, ifDecls = Map.unions (map ifDecls ds)
}
type IfaceTySyn = TySyn
ifTySynName :: TySyn -> Name
ifTySynName = tsName
type IfaceNewtype = Newtype
type IfaceAbstractType = AbstractType
data IfaceDecl = IfaceDecl
{ ifDeclName :: !Name -- ^ Name of thing
, ifDeclSig :: Schema -- ^ Type
, ifDeclPragmas :: [Pragma] -- ^ Pragmas
, ifDeclInfix :: Bool -- ^ Is this an infix thing
, ifDeclFixity :: Maybe Fixity -- ^ Fixity information
, ifDeclDoc :: Maybe String -- ^ Documentation
} deriving (Show, Generic, NFData)
mkIfaceDecl :: Decl -> IfaceDecl
mkIfaceDecl d = IfaceDecl
{ ifDeclName = dName d
, ifDeclSig = dSignature d
, ifDeclPragmas = dPragmas d
, ifDeclInfix = dInfix d
, ifDeclFixity = dFixity d
, ifDeclDoc = dDoc d
}
-- | Generate an Iface from a typechecked module.
genIface :: Module -> Iface
genIface m = Iface
{ ifModName = mName m
, ifPublic = IfaceDecls
{ ifTySyns = tsPub
, ifNewtypes = ntPub
, ifAbstractTypes = atPub
, ifDecls = dPub
}
, ifPrivate = IfaceDecls
{ ifTySyns = tsPriv
, ifNewtypes = ntPriv
, ifAbstractTypes = atPriv
, ifDecls = dPriv
}
, ifParams = IfaceParams
{ ifParamTypes = mParamTypes m
, ifParamConstraints = mParamConstraints m
, ifParamFuns = mParamFuns m
}
}
where
(tsPub,tsPriv) =
Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m )
(mTySyns m)
(ntPub,ntPriv) =
Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m )
(mNewtypes m)
(atPub,atPriv) =
Map.partitionWithKey (\qn _ -> qn `isExportedType` mExports m)
(mPrimTypes m)
(dPub,dPriv) =
Map.partitionWithKey (\ qn _ -> qn `isExportedBind` mExports m)
$ Map.fromList [ (qn,mkIfaceDecl d) | dg <- mDecls m
, d <- groupDecls dg
, let qn = dName d
]
-- | Produce a PrimMap from an interface.
--
-- NOTE: the map will expose /both/ public and private names.
ifacePrimMap :: Iface -> PrimMap
ifacePrimMap Iface { .. } =
PrimMap { primDecls = merge primDecls
, primTypes = merge primTypes }
where
merge f = Map.union (f public) (f private)
public = ifaceDeclsPrimMap ifPublic
private = ifaceDeclsPrimMap ifPrivate
ifaceDeclsPrimMap :: IfaceDecls -> PrimMap
ifaceDeclsPrimMap IfaceDecls { .. } =
PrimMap { primDecls = Map.fromList (newtypes ++ exprs)
, primTypes = Map.fromList (newtypes ++ types)
}
where
exprs = [ (nameIdent n, n) | n <- Map.keys ifDecls ]
newtypes = [ (nameIdent n, n) | n <- Map.keys ifNewtypes ]
types = [ (nameIdent n, n) | n <- Map.keys ifTySyns ]
cryptol-2.8.0/src/Cryptol/ModuleSystem/Monad.hs 0000644 0000000 0000000 00000042317 07346545000 017664 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.ModuleSystem.Monad
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.ModuleSystem.Monad where
import Cryptol.Eval (EvalEnv,EvalOpts(..))
import qualified Cryptol.Eval.Monad as E
import Cryptol.ModuleSystem.Env
import Cryptol.ModuleSystem.Fingerprint
import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Name (FreshM(..),Supply)
import Cryptol.ModuleSystem.Renamer
(RenamerError(),RenamerWarning(),NamingEnv)
import qualified Cryptol.Parser as Parser
import qualified Cryptol.Parser.AST as P
import Cryptol.Parser.Position (Located)
import Cryptol.Utils.Panic (panic)
import qualified Cryptol.Parser.NoPat as NoPat
import qualified Cryptol.Parser.NoInclude as NoInc
import qualified Cryptol.TypeCheck as T
import qualified Cryptol.TypeCheck.AST as T
import Cryptol.Parser.Position (Range)
import Cryptol.Utils.Ident (interactiveName, noModuleName)
import Cryptol.Utils.PP
import Cryptol.Utils.Logger(Logger)
import Control.Monad.IO.Class
import Control.Exception (IOException)
import Data.Function (on)
import Data.Maybe (isJust)
import Data.Text.Encoding.Error (UnicodeException)
import MonadLib
import System.Directory (canonicalizePath)
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
-- Errors ----------------------------------------------------------------------
data ImportSource
= FromModule P.ModName
| FromImport (Located P.Import)
| FromModuleInstance (Located P.ModName)
deriving (Show, Generic, NFData)
instance Eq ImportSource where
(==) = (==) `on` importedModule
instance PP ImportSource where
ppPrec _ is = case is of
FromModule n -> text "module name" <+> pp n
FromImport li -> text "import of module" <+> pp (P.iModule (P.thing li))
FromModuleInstance l ->
text "instantiation of module" <+> pp (P.thing l)
importedModule :: ImportSource -> P.ModName
importedModule is =
case is of
FromModule n -> n
FromImport li -> P.iModule (P.thing li)
FromModuleInstance l -> P.thing l
data ModuleError
= ModuleNotFound P.ModName [FilePath]
-- ^ Unable to find the module given, tried looking in these paths
| CantFindFile FilePath
-- ^ Unable to open a file
| BadUtf8 ModulePath UnicodeException
-- ^ Bad UTF-8 encoding in while decoding this file
| OtherIOError FilePath IOException
-- ^ Some other IO error occurred while reading this file
| ModuleParseError ModulePath Parser.ParseError
-- ^ Generated this parse error when parsing the file for module m
| RecursiveModules [ImportSource]
-- ^ Recursive module group discovered
| RenamerErrors ImportSource [RenamerError]
-- ^ Problems during the renaming phase
| NoPatErrors ImportSource [NoPat.Error]
-- ^ Problems during the NoPat phase
| NoIncludeErrors ImportSource [NoInc.IncludeError]
-- ^ Problems during the NoInclude phase
| TypeCheckingFailed ImportSource [(Range,T.Error)]
-- ^ Problems during type checking
| OtherFailure String
-- ^ Problems after type checking, eg. specialization
| ModuleNameMismatch P.ModName (Located P.ModName)
-- ^ Module loaded by 'import' statement has the wrong module name
| DuplicateModuleName P.ModName FilePath FilePath
-- ^ Two modules loaded from different files have the same module name
| ImportedParamModule P.ModName
-- ^ Attempt to import a parametrized module that was not instantiated.
| FailedToParameterizeModDefs P.ModName [T.Name]
-- ^ Failed to add the module parameters to all definitions in a module.
| NotAParameterizedModule P.ModName
| ErrorInFile ModulePath ModuleError
-- ^ This is just a tag on the error, indicating the file containing it.
-- It is convenient when we had to look for the module, and we'd like
-- to communicate the location of pthe problematic module to the handler.
deriving (Show)
instance NFData ModuleError where
rnf e = case e of
ModuleNotFound src path -> src `deepseq` path `deepseq` ()
CantFindFile path -> path `deepseq` ()
BadUtf8 path ue -> rnf (path, ue)
OtherIOError path exn -> path `deepseq` exn `seq` ()
ModuleParseError source err -> source `deepseq` err `deepseq` ()
RecursiveModules mods -> mods `deepseq` ()
RenamerErrors src errs -> src `deepseq` errs `deepseq` ()
NoPatErrors src errs -> src `deepseq` errs `deepseq` ()
NoIncludeErrors src errs -> src `deepseq` errs `deepseq` ()
TypeCheckingFailed src errs -> src `deepseq` errs `deepseq` ()
ModuleNameMismatch expected found ->
expected `deepseq` found `deepseq` ()
DuplicateModuleName name path1 path2 ->
name `deepseq` path1 `deepseq` path2 `deepseq` ()
OtherFailure x -> x `deepseq` ()
ImportedParamModule x -> x `deepseq` ()
FailedToParameterizeModDefs x xs -> x `deepseq` xs `deepseq` ()
NotAParameterizedModule x -> x `deepseq` ()
ErrorInFile x y -> x `deepseq` y `deepseq` ()
instance PP ModuleError where
ppPrec prec e = case e of
ModuleNotFound src path ->
text "[error]" <+>
text "Could not find module" <+> pp src
$$
hang (text "Searched paths:")
4 (vcat (map text path))
$$
text "Set the CRYPTOLPATH environment variable to search more directories"
CantFindFile path ->
text "[error]" <+>
text "can't find file:" <+> text path
BadUtf8 path _ue ->
text "[error]" <+>
text "bad utf-8 encoding:" <+> pp path
OtherIOError path exn ->
hang (text "[error]" <+>
text "IO error while loading file:" <+> text path <.> colon)
4 (text (show exn))
ModuleParseError _source err -> Parser.ppError err
RecursiveModules mods ->
hang (text "[error] module imports form a cycle:")
4 (vcat (map pp (reverse mods)))
RenamerErrors _src errs -> vcat (map pp errs)
NoPatErrors _src errs -> vcat (map pp errs)
NoIncludeErrors _src errs -> vcat (map NoInc.ppIncludeError errs)
TypeCheckingFailed _src errs -> vcat (map T.ppError errs)
ModuleNameMismatch expected found ->
hang (text "[error]" <+> pp (P.srcRange found) <.> char ':')
4 (vcat [ text "File name does not match module name:"
, text "Saw:" <+> pp (P.thing found)
, text "Expected:" <+> pp expected
])
DuplicateModuleName name path1 path2 ->
hang (text "[error] module" <+> pp name <+>
text "is defined in multiple files:")
4 (vcat [text path1, text path2])
OtherFailure x -> text x
ImportedParamModule p ->
text "[error] Import of a non-instantiated parameterized module:" <+> pp p
FailedToParameterizeModDefs x xs ->
hang (text "[error] Parameterized module" <+> pp x <+>
text "has polymorphic parameters:")
4 (hsep $ punctuate comma $ map pp xs)
NotAParameterizedModule x ->
text "[error] Module" <+> pp x <+> text "does not have parameters."
ErrorInFile _ x -> ppPrec prec x
moduleNotFound :: P.ModName -> [FilePath] -> ModuleM a
moduleNotFound name paths = ModuleT (raise (ModuleNotFound name paths))
cantFindFile :: FilePath -> ModuleM a
cantFindFile path = ModuleT (raise (CantFindFile path))
badUtf8 :: ModulePath -> UnicodeException -> ModuleM a
badUtf8 path ue = ModuleT (raise (BadUtf8 path ue))
otherIOError :: FilePath -> IOException -> ModuleM a
otherIOError path exn = ModuleT (raise (OtherIOError path exn))
moduleParseError :: ModulePath -> Parser.ParseError -> ModuleM a
moduleParseError path err =
ModuleT (raise (ModuleParseError path err))
recursiveModules :: [ImportSource] -> ModuleM a
recursiveModules loaded = ModuleT (raise (RecursiveModules loaded))
renamerErrors :: [RenamerError] -> ModuleM a
renamerErrors errs = do
src <- getImportSource
ModuleT (raise (RenamerErrors src errs))
noPatErrors :: [NoPat.Error] -> ModuleM a
noPatErrors errs = do
src <- getImportSource
ModuleT (raise (NoPatErrors src errs))
noIncludeErrors :: [NoInc.IncludeError] -> ModuleM a
noIncludeErrors errs = do
src <- getImportSource
ModuleT (raise (NoIncludeErrors src errs))
typeCheckingFailed :: [(Range,T.Error)] -> ModuleM a
typeCheckingFailed errs = do
src <- getImportSource
ModuleT (raise (TypeCheckingFailed src errs))
moduleNameMismatch :: P.ModName -> Located P.ModName -> ModuleM a
moduleNameMismatch expected found =
ModuleT (raise (ModuleNameMismatch expected found))
duplicateModuleName :: P.ModName -> FilePath -> FilePath -> ModuleM a
duplicateModuleName name path1 path2 =
ModuleT (raise (DuplicateModuleName name path1 path2))
importParamModule :: P.ModName -> ModuleM a
importParamModule x = ModuleT (raise (ImportedParamModule x))
failedToParameterizeModDefs :: P.ModName -> [T.Name] -> ModuleM a
failedToParameterizeModDefs x xs =
ModuleT (raise (FailedToParameterizeModDefs x xs))
notAParameterizedModule :: P.ModName -> ModuleM a
notAParameterizedModule x = ModuleT (raise (NotAParameterizedModule x))
-- | Run the computation, and if it caused and error, tag the error
-- with the given file.
errorInFile :: ModulePath -> ModuleM a -> ModuleM a
errorInFile file (ModuleT m) = ModuleT (m `handle` h)
where h e = raise $ case e of
ErrorInFile {} -> e
_ -> ErrorInFile file e
-- Warnings --------------------------------------------------------------------
data ModuleWarning
= TypeCheckWarnings [(Range,T.Warning)]
| RenamerWarnings [RenamerWarning]
deriving (Show, Generic, NFData)
instance PP ModuleWarning where
ppPrec _ w = case w of
TypeCheckWarnings ws -> vcat (map T.ppWarning ws)
RenamerWarnings ws -> vcat (map pp ws)
warn :: [ModuleWarning] -> ModuleM ()
warn = ModuleT . put
typeCheckWarnings :: [(Range,T.Warning)] -> ModuleM ()
typeCheckWarnings ws
| null ws = return ()
| otherwise = warn [TypeCheckWarnings ws]
renamerWarnings :: [RenamerWarning] -> ModuleM ()
renamerWarnings ws
| null ws = return ()
| otherwise = warn [RenamerWarnings ws]
-- Module System Monad ---------------------------------------------------------
data RO = RO { roLoading :: [ImportSource]
, roEvalOpts :: EvalOpts
}
emptyRO :: EvalOpts -> RO
emptyRO ev = RO { roLoading = [], roEvalOpts = ev }
newtype ModuleT m a = ModuleT
{ unModuleT :: ReaderT RO (StateT ModuleEnv
(ExceptionT ModuleError (WriterT [ModuleWarning] m))) a
}
instance Monad m => Functor (ModuleT m) where
{-# INLINE fmap #-}
fmap f m = ModuleT (fmap f (unModuleT m))
instance Monad m => Applicative (ModuleT m) where
{-# INLINE pure #-}
pure x = ModuleT (pure x)
{-# INLINE (<*>) #-}
l <*> r = ModuleT (unModuleT l <*> unModuleT r)
instance Monad m => Monad (ModuleT m) where
{-# INLINE return #-}
return x = ModuleT (return x)
{-# INLINE (>>=) #-}
m >>= f = ModuleT (unModuleT m >>= unModuleT . f)
{-# INLINE fail #-}
fail = ModuleT . raise . OtherFailure
instance MonadT ModuleT where
{-# INLINE lift #-}
lift = ModuleT . lift . lift . lift . lift
instance Monad m => FreshM (ModuleT m) where
liftSupply f = ModuleT $
do me <- get
let (a,s') = f (meSupply me)
set $! me { meSupply = s' }
return a
instance MonadIO m => MonadIO (ModuleT m) where
liftIO m = lift $ liftIO m
runModuleT :: Monad m
=> (EvalOpts,ModuleEnv)
-> ModuleT m a
-> m (Either ModuleError (a, ModuleEnv), [ModuleWarning])
runModuleT (ev,env) m =
runWriterT
$ runExceptionT
$ runStateT env
$ runReaderT (emptyRO ev)
$ unModuleT m
type ModuleM = ModuleT IO
runModuleM :: (EvalOpts, ModuleEnv) -> ModuleM a
-> IO (Either ModuleError (a,ModuleEnv),[ModuleWarning])
runModuleM = runModuleT
io :: BaseM m IO => IO a -> ModuleT m a
io m = ModuleT (inBase m)
getModuleEnv :: Monad m => ModuleT m ModuleEnv
getModuleEnv = ModuleT get
setModuleEnv :: Monad m => ModuleEnv -> ModuleT m ()
setModuleEnv = ModuleT . set
modifyModuleEnv :: Monad m => (ModuleEnv -> ModuleEnv) -> ModuleT m ()
modifyModuleEnv f = ModuleT $ do
env <- get
set $! f env
getLoadedMaybe :: P.ModName -> ModuleM (Maybe LoadedModule)
getLoadedMaybe mn = ModuleT $
do env <- get
return (lookupModule mn env)
isLoaded :: P.ModName -> ModuleM Bool
isLoaded mn = isJust <$> getLoadedMaybe mn
loadingImport :: Located P.Import -> ModuleM a -> ModuleM a
loadingImport = loading . FromImport
loadingModule :: P.ModName -> ModuleM a -> ModuleM a
loadingModule = loading . FromModule
loadingModInstance :: Located P.ModName -> ModuleM a -> ModuleM a
loadingModInstance = loading . FromModuleInstance
-- | Push an "interactive" context onto the loading stack. A bit of a hack, as
-- it uses a faked module name
interactive :: ModuleM a -> ModuleM a
interactive = loadingModule interactiveName
loading :: ImportSource -> ModuleM a -> ModuleM a
loading src m = ModuleT $ do
ro <- ask
let ro' = ro { roLoading = src : roLoading ro }
-- check for recursive modules
when (src `elem` roLoading ro) (raise (RecursiveModules (roLoading ro')))
local ro' (unModuleT m)
-- | Get the currently focused import source.
getImportSource :: ModuleM ImportSource
getImportSource = ModuleT $ do
ro <- ask
case roLoading ro of
is : _ -> return is
_ -> return (FromModule noModuleName)
getIface :: P.ModName -> ModuleM Iface
getIface mn =
do env <- ModuleT get
case lookupModule mn env of
Just lm -> return (lmInterface lm)
Nothing -> panic "ModuleSystem" ["Interface not available", show (pp mn)]
getLoaded :: P.ModName -> ModuleM T.Module
getLoaded mn = ModuleT $
do env <- get
case lookupModule mn env of
Just lm -> return (lmModule lm)
Nothing -> panic "ModuleSystem" ["Module not available", show (pp mn) ]
getNameSeeds :: ModuleM T.NameSeeds
getNameSeeds = ModuleT (meNameSeeds `fmap` get)
getSupply :: ModuleM Supply
getSupply = ModuleT (meSupply `fmap` get)
getMonoBinds :: ModuleM Bool
getMonoBinds = ModuleT (meMonoBinds `fmap` get)
setMonoBinds :: Bool -> ModuleM ()
setMonoBinds b = ModuleT $ do
env <- get
set $! env { meMonoBinds = b }
setNameSeeds :: T.NameSeeds -> ModuleM ()
setNameSeeds seeds = ModuleT $ do
env <- get
set $! env { meNameSeeds = seeds }
setSupply :: Supply -> ModuleM ()
setSupply supply = ModuleT $
do env <- get
set $! env { meSupply = supply }
unloadModule :: (LoadedModule -> Bool) -> ModuleM ()
unloadModule rm = ModuleT $ do
env <- get
set $! env { meLoadedModules = removeLoadedModule rm (meLoadedModules env) }
loadedModule :: ModulePath -> Fingerprint -> T.Module -> ModuleM ()
loadedModule path fp m = ModuleT $ do
env <- get
ident <- case path of
InFile p -> unModuleT $ io (canonicalizePath p)
InMem l _ -> pure l
set $! env { meLoadedModules = addLoadedModule path ident fp m (meLoadedModules env) }
modifyEvalEnv :: (EvalEnv -> E.Eval EvalEnv) -> ModuleM ()
modifyEvalEnv f = ModuleT $ do
env <- get
let evalEnv = meEvalEnv env
evOpts <- unModuleT getEvalOpts
evalEnv' <- inBase $ E.runEval evOpts (f evalEnv)
set $! env { meEvalEnv = evalEnv' }
getEvalEnv :: ModuleM EvalEnv
getEvalEnv = ModuleT (meEvalEnv `fmap` get)
getEvalOpts :: ModuleM EvalOpts
getEvalOpts = ModuleT (roEvalOpts `fmap` ask)
getFocusedModule :: ModuleM (Maybe P.ModName)
getFocusedModule = ModuleT (meFocusedModule `fmap` get)
setFocusedModule :: P.ModName -> ModuleM ()
setFocusedModule n = ModuleT $ do
me <- get
set $! me { meFocusedModule = Just n }
getSearchPath :: ModuleM [FilePath]
getSearchPath = ModuleT (meSearchPath `fmap` get)
-- | Run a 'ModuleM' action in a context with a prepended search
-- path. Useful for temporarily looking in other places while
-- resolving imports, for example.
withPrependedSearchPath :: [FilePath] -> ModuleM a -> ModuleM a
withPrependedSearchPath fps m = ModuleT $ do
env0 <- get
let fps0 = meSearchPath env0
set $! env0 { meSearchPath = fps ++ fps0 }
x <- unModuleT m
env <- get
set $! env { meSearchPath = fps0 }
return x
-- XXX improve error handling here
getFocusedEnv :: ModuleM (IfaceParams,IfaceDecls,NamingEnv,NameDisp)
getFocusedEnv = ModuleT (focusedEnv `fmap` get)
getDynEnv :: ModuleM DynamicEnv
getDynEnv = ModuleT (meDynEnv `fmap` get)
setDynEnv :: DynamicEnv -> ModuleM ()
setDynEnv denv = ModuleT $ do
me <- get
set $! me { meDynEnv = denv }
setSolver :: T.SolverConfig -> ModuleM ()
setSolver cfg = ModuleT $ do
me <- get
set $! me { meSolverConfig = cfg }
getSolverConfig :: ModuleM T.SolverConfig
getSolverConfig = ModuleT $ do
me <- get
return (meSolverConfig me)
-- | Usefule for logging. For example: @withLogger logPutStrLn "Hello"@
withLogger :: (Logger -> a -> IO b) -> a -> ModuleM b
withLogger f a = do l <- getEvalOpts
io (f (evalLogger l) a)
cryptol-2.8.0/src/Cryptol/ModuleSystem/Name.hs 0000644 0000000 0000000 00000026124 07346545000 017504 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.ModuleSystem.Name
-- Copyright : (c) 2015-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
-- for the instances of RunM and BaseM
{-# LANGUAGE UndecidableInstances #-}
module Cryptol.ModuleSystem.Name (
-- * Names
Name(), NameInfo(..)
, NameSource(..)
, nameUnique
, nameIdent
, nameInfo
, nameLoc
, nameFixity
, asPrim
, cmpNameLexical
, cmpNameDisplay
, ppLocName
-- ** Creation
, mkDeclared
, mkParameter
, toParamInstName
, asParamName
, paramModRecParam
-- ** Unique Supply
, FreshM(..), nextUniqueM
, SupplyT(), runSupplyT
, Supply(), emptySupply, nextUnique
-- ** PrimMap
, PrimMap(..)
, lookupPrimDecl
, lookupPrimType
) where
import Cryptol.Parser.Fixity
import Cryptol.Parser.Position (Range,Located(..),emptyRange)
import Cryptol.Utils.Ident
import Cryptol.Utils.Panic
import Cryptol.Utils.PP
import Control.DeepSeq
import Control.Monad.Fix (MonadFix(mfix))
import qualified Data.Map as Map
import qualified Data.Monoid as M
import Data.Ord (comparing)
import qualified Data.Text as Text
import Data.Char(isAlpha,toUpper)
import GHC.Generics (Generic)
import MonadLib
import Prelude ()
import Prelude.Compat
-- Names -----------------------------------------------------------------------
-- | Information about the binding site of the name.
data NameInfo = Declared !ModName !NameSource
-- ^ This name refers to a declaration from this module
| Parameter
-- ^ This name is a parameter (function or type)
deriving (Eq, Show, Generic, NFData)
data Name = Name { nUnique :: {-# UNPACK #-} !Int
-- ^ INVARIANT: this field uniquely identifies a name for one
-- session with the Cryptol library. Names are unique to
-- their binding site.
, nInfo :: !NameInfo
-- ^ Information about the origin of this name.
, nIdent :: !Ident
-- ^ The name of the identifier
, nFixity :: !(Maybe Fixity)
-- ^ The associativity and precedence level of
-- infix operators. 'Nothing' indicates an
-- ordinary prefix operator.
, nLoc :: !Range
-- ^ Where this name was defined
} deriving (Generic, NFData, Show)
data NameSource = SystemName | UserName
deriving (Generic, NFData, Show, Eq)
instance Eq Name where
a == b = compare a b == EQ
a /= b = compare a b /= EQ
instance Ord Name where
compare a b = compare (nUnique a) (nUnique b)
-- | Compare two names lexically.
cmpNameLexical :: Name -> Name -> Ordering
cmpNameLexical l r =
case (nameInfo l, nameInfo r) of
(Declared nsl _,Declared nsr _) ->
case compare nsl nsr of
EQ -> comparing nameIdent l r
cmp -> cmp
(Parameter,Parameter) -> comparing nameIdent l r
(Declared nsl _,Parameter) -> compare (modNameToText nsl)
(identText (nameIdent r))
(Parameter,Declared nsr _) -> compare (identText (nameIdent l))
(modNameToText nsr)
-- | Compare two names by the way they would be displayed.
cmpNameDisplay :: NameDisp -> Name -> Name -> Ordering
cmpNameDisplay disp l r =
case (nameInfo l, nameInfo r) of
(Declared nsl _, Declared nsr _) -> -- XXX: uses system name info?
let pfxl = fmtModName nsl (getNameFormat nsl (nameIdent l) disp)
pfxr = fmtModName nsr (getNameFormat nsr (nameIdent r) disp)
in case cmpText pfxl pfxr of
EQ -> cmpName l r
cmp -> cmp
(Parameter,Parameter) -> cmpName l r
(Declared nsl _,Parameter) ->
let pfxl = fmtModName nsl (getNameFormat nsl (nameIdent l) disp)
in case cmpText pfxl (identText (nameIdent r)) of
EQ -> GT
cmp -> cmp
(Parameter,Declared nsr _) ->
let pfxr = fmtModName nsr (getNameFormat nsr (nameIdent r) disp)
in case cmpText (identText (nameIdent l)) pfxr of
EQ -> LT
cmp -> cmp
where
cmpName xs ys = cmpIdent (nameIdent xs) (nameIdent ys)
cmpIdent xs ys = cmpText (identText xs) (identText ys)
-- Note that this assumes that `xs` is `l` and `ys` is `r`
cmpText xs ys =
case (Text.null xs, Text.null ys) of
(True,True) -> EQ
(True,False) -> LT
(False,True) -> GT
(False,False) -> compare (cmp (fx l) xs) (cmp (fx r) ys)
where
fx a = fLevel <$> nameFixity a
cmp a cs = (ordC (Text.index cs 0), a, cs)
ordC a | isAlpha a = fromEnum (toUpper a)
| a == '_' = 1
| otherwise = 0
-- | Figure out how the name should be displayed, by referencing the display
-- function in the environment. NOTE: this function doesn't take into account
-- the need for parenthesis.
ppName :: Name -> Doc
ppName Name { .. } =
case nInfo of
Declared m _ -> withNameDisp $ \disp ->
case getNameFormat m nIdent disp of
Qualified m' -> pp m' <.> text "::" <.> pp nIdent
UnQualified -> pp nIdent
NotInScope -> pp m <.> text "::" <.> pp nIdent
Parameter -> pp nIdent
instance PP Name where
ppPrec _ = ppPrefixName
instance PPName Name where
ppNameFixity n = fmap (\(Fixity a i) -> (a,i)) $ nameFixity n
ppInfixName n @ Name { .. }
| isInfixIdent nIdent = ppName n
| otherwise = panic "Name" [ "Non-infix name used infix"
, show nIdent ]
ppPrefixName n @ Name { .. } = optParens (isInfixIdent nIdent) (ppName n)
-- | Pretty-print a name with its source location information.
ppLocName :: Name -> Doc
ppLocName n = pp Located { srcRange = nameLoc n, thing = n }
nameUnique :: Name -> Int
nameUnique = nUnique
nameIdent :: Name -> Ident
nameIdent = nIdent
nameInfo :: Name -> NameInfo
nameInfo = nInfo
nameLoc :: Name -> Range
nameLoc = nLoc
nameFixity :: Name -> Maybe Fixity
nameFixity = nFixity
asPrim :: Name -> Maybe Ident
asPrim Name { .. } =
case nInfo of
Declared p _ | p == preludeName -> Just nIdent
_ -> Nothing
toParamInstName :: Name -> Name
toParamInstName n =
case nInfo n of
Declared m s -> n { nInfo = Declared (paramInstModName m) s }
Parameter -> n
asParamName :: Name -> Name
asParamName n = n { nInfo = Parameter }
-- Name Supply -----------------------------------------------------------------
class Monad m => FreshM m where
liftSupply :: (Supply -> (a,Supply)) -> m a
instance FreshM m => FreshM (ExceptionT i m) where
liftSupply f = lift (liftSupply f)
instance (M.Monoid i, FreshM m) => FreshM (WriterT i m) where
liftSupply f = lift (liftSupply f)
instance FreshM m => FreshM (ReaderT i m) where
liftSupply f = lift (liftSupply f)
instance FreshM m => FreshM (StateT i m) where
liftSupply f = lift (liftSupply f)
instance Monad m => FreshM (SupplyT m) where
liftSupply f = SupplyT $
do s <- get
let (a,s') = f s
set $! s'
return a
-- | A monad for easing the use of the supply.
newtype SupplyT m a = SupplyT { unSupply :: StateT Supply m a }
runSupplyT :: Monad m => Supply -> SupplyT m a -> m (a,Supply)
runSupplyT s (SupplyT m) = runStateT s m
instance Monad m => Functor (SupplyT m) where
fmap f (SupplyT m) = SupplyT (fmap f m)
{-# INLINE fmap #-}
instance Monad m => Applicative (SupplyT m) where
pure x = SupplyT (pure x)
{-# INLINE pure #-}
f <*> g = SupplyT (unSupply f <*> unSupply g)
{-# INLINE (<*>) #-}
instance Monad m => Monad (SupplyT m) where
return = pure
{-# INLINE return #-}
m >>= f = SupplyT (unSupply m >>= unSupply . f)
{-# INLINE (>>=) #-}
instance MonadT SupplyT where
lift m = SupplyT (lift m)
instance BaseM m n => BaseM (SupplyT m) n where
inBase m = SupplyT (inBase m)
{-# INLINE inBase #-}
instance RunM m (a,Supply) r => RunM (SupplyT m) a (Supply -> r) where
runM (SupplyT m) s = runM m s
{-# INLINE runM #-}
instance MonadFix m => MonadFix (SupplyT m) where
mfix f = SupplyT (mfix (unSupply . f))
-- | Retrieve the next unique from the supply.
nextUniqueM :: FreshM m => m Int
nextUniqueM = liftSupply nextUnique
data Supply = Supply !Int
deriving (Show, Generic, NFData)
-- | This should only be used once at library initialization, and threaded
-- through the rest of the session. The supply is started at 0x1000 to leave us
-- plenty of room for names that the compiler needs to know about (wired-in
-- constants).
emptySupply :: Supply
emptySupply = Supply 0x1000
-- For one such name, see paramModRecParam
-- XXX: perhaps we should simply not have such things, but that's the way
-- for now.
nextUnique :: Supply -> (Int,Supply)
nextUnique (Supply n) = s' `seq` (n,s')
where
s' = Supply (n + 1)
-- Name Construction -----------------------------------------------------------
-- | Make a new name for a declaration.
mkDeclared :: ModName -> NameSource -> Ident -> Maybe Fixity -> Range -> Supply -> (Name,Supply)
mkDeclared m sys nIdent nFixity nLoc s =
let (nUnique,s') = nextUnique s
nInfo = Declared m sys
in (Name { .. }, s')
-- | Make a new parameter name.
mkParameter :: Ident -> Range -> Supply -> (Name,Supply)
mkParameter nIdent nLoc s =
let (nUnique,s') = nextUnique s
nFixity = Nothing
in (Name { nInfo = Parameter, .. }, s')
paramModRecParam :: Name
paramModRecParam = Name { nInfo = Parameter
, nFixity = Nothing
, nIdent = packIdent "$modParams"
, nLoc = emptyRange
, nUnique = 0x01
}
-- Prim Maps -------------------------------------------------------------------
-- | A mapping from an identifier defined in some module to its real name.
data PrimMap = PrimMap { primDecls :: Map.Map Ident Name
, primTypes :: Map.Map Ident Name
} deriving (Show, Generic, NFData)
lookupPrimDecl, lookupPrimType :: Ident -> PrimMap -> Name
-- | It's assumed that we're looking things up that we know already exist, so
-- this will panic if it doesn't find the name.
lookupPrimDecl name PrimMap { .. } = Map.findWithDefault err name primDecls
where
err = panic "Cryptol.ModuleSystem.Name.lookupPrimDecl"
[ "Unknown declaration: " ++ show name
, show primDecls ]
-- | It's assumed that we're looking things up that we know already exist, so
-- this will panic if it doesn't find the name.
lookupPrimType name PrimMap { .. } = Map.findWithDefault err name primTypes
where
err = panic "Cryptol.ModuleSystem.Name.lookupPrimType"
[ "Unknown type: " ++ show name
, show primTypes ]
cryptol-2.8.0/src/Cryptol/ModuleSystem/NamingEnv.hs 0000644 0000000 0000000 00000032464 07346545000 020512 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.ModuleSystem.NamingEnv
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.ModuleSystem.NamingEnv where
import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Name
import Cryptol.Parser.AST
import Cryptol.Parser.Name(isGeneratedName)
import Cryptol.Parser.Position
import qualified Cryptol.TypeCheck.AST as T
import Cryptol.Utils.PP
import Cryptol.Utils.Panic (panic)
import Data.List (nub)
import Data.Maybe (fromMaybe)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Semigroup
import MonadLib (runId,Id)
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
-- Naming Environment ----------------------------------------------------------
-- XXX The fixity environment should be removed, and Name should include fixity
-- information.
data NamingEnv = NamingEnv { neExprs :: !(Map.Map PName [Name])
-- ^ Expr renaming environment
, neTypes :: !(Map.Map PName [Name])
-- ^ Type renaming environment
} deriving (Show, Generic, NFData)
-- | Return a list of value-level names to which this parsed name may refer.
lookupValNames :: PName -> NamingEnv -> [Name]
lookupValNames qn ro = Map.findWithDefault [] qn (neExprs ro)
-- | Return a list of type-level names to which this parsed name may refer.
lookupTypeNames :: PName -> NamingEnv -> [Name]
lookupTypeNames qn ro = Map.findWithDefault [] qn (neTypes ro)
instance Semigroup NamingEnv where
l <> r =
NamingEnv { neExprs = Map.unionWith merge (neExprs l) (neExprs r)
, neTypes = Map.unionWith merge (neTypes l) (neTypes r) }
instance Monoid NamingEnv where
mempty =
NamingEnv { neExprs = Map.empty
, neTypes = Map.empty }
mappend l r = l <> r
mconcat envs =
NamingEnv { neExprs = Map.unionsWith merge (map neExprs envs)
, neTypes = Map.unionsWith merge (map neTypes envs) }
{-# INLINE mempty #-}
{-# INLINE mappend #-}
{-# INLINE mconcat #-}
-- | Merge two name maps, collapsing cases where the entries are the same, and
-- producing conflicts otherwise.
merge :: [Name] -> [Name] -> [Name]
merge xs ys | xs == ys = xs
| otherwise = nub (xs ++ ys)
-- | Generate a mapping from 'Ident' to 'Name' for a given naming environment.
toPrimMap :: NamingEnv -> PrimMap
toPrimMap NamingEnv { .. } = PrimMap { .. }
where
primDecls = Map.fromList [ (nameIdent n,n) | ns <- Map.elems neExprs
, n <- ns ]
primTypes = Map.fromList [ (nameIdent n,n) | ns <- Map.elems neTypes
, n <- ns ]
-- | Generate a display format based on a naming environment.
toNameDisp :: NamingEnv -> NameDisp
toNameDisp NamingEnv { .. } = NameDisp display
where
display mn ident = Map.lookup (mn,ident) names
-- only format declared names, as parameters don't need any special
-- formatting.
names = Map.fromList
$ [ mkEntry pn mn (nameIdent n) | (pn,ns) <- Map.toList neExprs
, n <- ns
, Declared mn _ <- [nameInfo n] ]
++ [ mkEntry pn mn (nameIdent n) | (pn,ns) <- Map.toList neTypes
, n <- ns
, Declared mn _ <- [nameInfo n] ]
mkEntry pn mn i = ((mn,i),fmt)
where
fmt = case getModName pn of
Just ns -> Qualified ns
Nothing -> UnQualified
-- | Produce sets of visible names for types and declarations.
--
-- NOTE: if entries in the NamingEnv would have produced a name clash, they will
-- be omitted from the resulting sets.
visibleNames :: NamingEnv -> ({- types -} Set.Set Name
,{- decls -} Set.Set Name)
visibleNames NamingEnv { .. } = (types,decls)
where
types = Set.fromList [ n | [n] <- Map.elems neTypes ]
decls = Set.fromList [ n | [n] <- Map.elems neExprs ]
-- | Qualify all symbols in a 'NamingEnv' with the given prefix.
qualify :: ModName -> NamingEnv -> NamingEnv
qualify pfx NamingEnv { .. } =
NamingEnv { neExprs = Map.mapKeys toQual neExprs
, neTypes = Map.mapKeys toQual neTypes
, .. }
where
-- XXX we don't currently qualify fresh names
toQual (Qual _ n) = Qual pfx n
toQual (UnQual n) = Qual pfx n
toQual n@NewName{} = n
filterNames :: (PName -> Bool) -> NamingEnv -> NamingEnv
filterNames p NamingEnv { .. } =
NamingEnv { neExprs = Map.filterWithKey check neExprs
, neTypes = Map.filterWithKey check neTypes
, .. }
where
check :: PName -> a -> Bool
check n _ = p n
-- | Singleton type renaming environment.
singletonT :: PName -> Name -> NamingEnv
singletonT qn tn = mempty { neTypes = Map.singleton qn [tn] }
-- | Singleton expression renaming environment.
singletonE :: PName -> Name -> NamingEnv
singletonE qn en = mempty { neExprs = Map.singleton qn [en] }
-- | Like mappend, but when merging, prefer values on the lhs.
shadowing :: NamingEnv -> NamingEnv -> NamingEnv
shadowing l r = NamingEnv
{ neExprs = Map.union (neExprs l) (neExprs r)
, neTypes = Map.union (neTypes l) (neTypes r) }
travNamingEnv :: Applicative f => (Name -> f Name) -> NamingEnv -> f NamingEnv
travNamingEnv f ne = NamingEnv <$> neExprs' <*> neTypes'
where
neExprs' = traverse (traverse f) (neExprs ne)
neTypes' = traverse (traverse f) (neTypes ne)
data InModule a = InModule !ModName a
deriving (Functor,Traversable,Foldable,Show)
-- | Generate a 'NamingEnv' using an explicit supply.
namingEnv' :: BindsNames a => a -> Supply -> (NamingEnv,Supply)
namingEnv' a supply = runId (runSupplyT supply (runBuild (namingEnv a)))
newTop :: FreshM m => ModName -> PName -> Maybe Fixity -> Range -> m Name
newTop ns thing fx rng = liftSupply (mkDeclared ns src (getIdent thing) fx rng)
where src = if isGeneratedName thing then SystemName else UserName
newLocal :: FreshM m => PName -> Range -> m Name
newLocal thing rng = liftSupply (mkParameter (getIdent thing) rng)
newtype BuildNamingEnv = BuildNamingEnv { runBuild :: SupplyT Id NamingEnv }
instance Semigroup BuildNamingEnv where
BuildNamingEnv a <> BuildNamingEnv b = BuildNamingEnv $
do x <- a
y <- b
return (mappend x y)
instance Monoid BuildNamingEnv where
mempty = BuildNamingEnv (pure mempty)
mappend = (<>)
mconcat bs = BuildNamingEnv $
do ns <- sequence (map runBuild bs)
return (mconcat ns)
-- | Things that define exported names.
class BindsNames a where
namingEnv :: a -> BuildNamingEnv
instance BindsNames NamingEnv where
namingEnv env = BuildNamingEnv (return env)
{-# INLINE namingEnv #-}
instance BindsNames a => BindsNames (Maybe a) where
namingEnv = foldMap namingEnv
{-# INLINE namingEnv #-}
instance BindsNames a => BindsNames [a] where
namingEnv = foldMap namingEnv
{-# INLINE namingEnv #-}
-- | Generate a type renaming environment from the parameters that are bound by
-- this schema.
instance BindsNames (Schema PName) where
namingEnv (Forall ps _ _ _) = foldMap namingEnv ps
{-# INLINE namingEnv #-}
-- | Interpret an import in the context of an interface, to produce a name
-- environment for the renamer, and a 'NameDisp' for pretty-printing.
interpImport :: Import -> IfaceDecls -> NamingEnv
interpImport imp publicDecls = qualified
where
-- optionally qualify names based on the import
qualified | Just pfx <- iAs imp = qualify pfx restricted
| otherwise = restricted
-- restrict or hide imported symbols
restricted
| Just (Hiding ns) <- iSpec imp =
filterNames (\qn -> not (getIdent qn `elem` ns)) public
| Just (Only ns) <- iSpec imp =
filterNames (\qn -> getIdent qn `elem` ns) public
| otherwise = public
-- generate the initial environment from the public interface, where no names
-- are qualified
public = unqualifiedEnv publicDecls
-- | Generate a naming environment from a declaration interface, where none of
-- the names are qualified.
unqualifiedEnv :: IfaceDecls -> NamingEnv
unqualifiedEnv IfaceDecls { .. } =
mconcat [ exprs, tySyns, ntTypes, absTys, ntExprs ]
where
toPName n = mkUnqual (nameIdent n)
exprs = mconcat [ singletonE (toPName n) n | n <- Map.keys ifDecls ]
tySyns = mconcat [ singletonT (toPName n) n | n <- Map.keys ifTySyns ]
ntTypes = mconcat [ singletonT (toPName n) n | n <- Map.keys ifNewtypes ]
absTys = mconcat [ singletonT (toPName n) n | n <- Map.keys ifAbstractTypes ]
ntExprs = mconcat [ singletonE (toPName n) n | n <- Map.keys ifNewtypes ]
-- | Compute an unqualified naming environment, containing the various module
-- parameters.
modParamsNamingEnv :: IfaceParams -> NamingEnv
modParamsNamingEnv IfaceParams { .. } =
NamingEnv { neExprs = Map.fromList $ map fromFu $ Map.keys ifParamFuns
, neTypes = Map.fromList $ map fromTy $ Map.elems ifParamTypes
}
where
toPName n = mkUnqual (nameIdent n)
fromTy tp = let nm = T.mtpName tp
in (toPName nm, [nm])
fromFu f = (toPName f, [f])
data ImportIface = ImportIface Import Iface
-- | Produce a naming environment from an interface file, that contains a
-- mapping only from unqualified names to qualified ones.
instance BindsNames ImportIface where
namingEnv (ImportIface imp Iface { .. }) = BuildNamingEnv $
return (interpImport imp ifPublic)
{-# INLINE namingEnv #-}
-- | Introduce the name
instance BindsNames (InModule (Bind PName)) where
namingEnv (InModule ns b) = BuildNamingEnv $
do let Located { .. } = bName b
n <- newTop ns thing (bFixity b) srcRange
return (singletonE thing n)
-- | Generate the naming environment for a type parameter.
instance BindsNames (TParam PName) where
namingEnv TParam { .. } = BuildNamingEnv $
do let range = fromMaybe emptyRange tpRange
n <- newLocal tpName range
return (singletonT tpName n)
-- | The naming environment for a single module. This is the mapping from
-- unqualified names to fully qualified names with uniques.
instance BindsNames (Module PName) where
namingEnv Module { .. } = foldMap (namingEnv . InModule ns) mDecls
where
ns = thing mName
instance BindsNames (InModule (TopDecl PName)) where
namingEnv (InModule ns td) =
case td of
Decl d -> namingEnv (InModule ns (tlValue d))
DPrimType d -> namingEnv (InModule ns (tlValue d))
TDNewtype d -> namingEnv (InModule ns (tlValue d))
DParameterType d -> namingEnv (InModule ns d)
DParameterConstraint {} -> mempty
DParameterFun d -> namingEnv (InModule ns d)
Include _ -> mempty
instance BindsNames (InModule (PrimType PName)) where
namingEnv (InModule ns PrimType { .. }) =
BuildNamingEnv $
do let Located { .. } = primTName
nm <- newTop ns thing primTFixity srcRange
pure (singletonT thing nm)
instance BindsNames (InModule (ParameterFun PName)) where
namingEnv (InModule ns ParameterFun { .. }) = BuildNamingEnv $
do let Located { .. } = pfName
ntName <- newTop ns thing pfFixity srcRange
return (singletonE thing ntName)
instance BindsNames (InModule (ParameterType PName)) where
namingEnv (InModule ns ParameterType { .. }) = BuildNamingEnv $
-- XXX: we don't seem to have a fixity environment at the type level
do let Located { .. } = ptName
ntName <- newTop ns thing Nothing srcRange
return (singletonT thing ntName)
-- NOTE: we use the same name at the type and expression level, as there's only
-- ever one name introduced in the declaration. The names are only ever used in
-- different namespaces, so there's no ambiguity.
instance BindsNames (InModule (Newtype PName)) where
namingEnv (InModule ns Newtype { .. }) = BuildNamingEnv $
do let Located { .. } = nName
ntName <- newTop ns thing Nothing srcRange
return (singletonT thing ntName `mappend` singletonE thing ntName)
-- | The naming environment for a single declaration.
instance BindsNames (InModule (Decl PName)) where
namingEnv (InModule pfx d) = case d of
DBind b -> BuildNamingEnv $
do n <- mkName (bName b) (bFixity b)
return (singletonE (thing (bName b)) n)
DSignature ns _sig -> foldMap qualBind ns
DPragma ns _p -> foldMap qualBind ns
DType syn -> qualType (tsName syn) (tsFixity syn)
DProp syn -> qualType (psName syn) (psFixity syn)
DLocated d' _ -> namingEnv (InModule pfx d')
DPatBind _pat _e -> panic "ModuleSystem" ["Unexpected pattern binding"]
DFixity{} -> panic "ModuleSystem" ["Unexpected fixity declaration"]
where
mkName ln fx = newTop pfx (thing ln) fx (srcRange ln)
qualBind ln = BuildNamingEnv $
do n <- mkName ln Nothing
return (singletonE (thing ln) n)
qualType ln f = BuildNamingEnv $
do n <- mkName ln f
return (singletonT (thing ln) n)
cryptol-2.8.0/src/Cryptol/ModuleSystem/Renamer.hs 0000644 0000000 0000000 00000100711 07346545000 020210 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.ModuleSystem.Renamer
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.ModuleSystem.Renamer (
NamingEnv(), shadowing
, BindsNames(..), InModule(..), namingEnv'
, checkNamingEnv
, shadowNames
, Rename(..), runRenamer, RenameM()
, RenamerError(..)
, RenamerWarning(..)
, renameVar
, renameType
, renameModule
) where
import Cryptol.ModuleSystem.Name
import Cryptol.ModuleSystem.NamingEnv
import Cryptol.ModuleSystem.Exports
import Cryptol.Parser.AST
import Cryptol.Parser.Position
import Cryptol.Parser.Selector(ppNestedSels,selName)
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.PP
import Data.List(find)
import Data.Maybe (fromMaybe)
import qualified Data.Foldable as F
import Data.Map.Strict ( Map )
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Semigroup as S
import qualified Data.Set as Set
import MonadLib hiding (mapM, mapM_)
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
-- Errors ----------------------------------------------------------------------
data RenamerError
= MultipleSyms (Located PName) [Name] NameDisp
-- ^ Multiple imported symbols contain this name
| UnboundExpr (Located PName) NameDisp
-- ^ Expression name is not bound to any definition
| UnboundType (Located PName) NameDisp
-- ^ Type name is not bound to any definition
| OverlappingSyms [Name] NameDisp
-- ^ An environment has produced multiple overlapping symbols
| ExpectedValue (Located PName) NameDisp
-- ^ When a value is expected from the naming environment, but one or more
-- types exist instead.
| ExpectedType (Located PName) NameDisp
-- ^ When a type is missing from the naming environment, but one or more
-- values exist with the same name.
| FixityError (Located Name) Fixity (Located Name) Fixity NameDisp
-- ^ When the fixity of two operators conflict
| InvalidConstraint (Type PName) NameDisp
-- ^ When it's not possible to produce a Prop from a Type.
| MalformedBuiltin (Type PName) PName NameDisp
-- ^ When a builtin type/type-function is used incorrectly.
| BoundReservedType PName (Maybe Range) Doc NameDisp
-- ^ When a builtin type is named in a binder.
| OverlappingRecordUpdate (Located [Selector]) (Located [Selector]) NameDisp
-- ^ When record updates overlap (e.g., @{ r | x = e1, x.y = e2 }@)
deriving (Show, Generic, NFData)
instance PP RenamerError where
ppPrec _ e = case e of
MultipleSyms lqn qns disp -> fixNameDisp disp $
hang (text "[error] at" <+> pp (srcRange lqn))
4 $ (text "Multiple definitions for symbol:" <+> pp (thing lqn))
$$ vcat (map ppLocName qns)
UnboundExpr lqn disp -> fixNameDisp disp $
hang (text "[error] at" <+> pp (srcRange lqn))
4 (text "Value not in scope:" <+> pp (thing lqn))
UnboundType lqn disp -> fixNameDisp disp $
hang (text "[error] at" <+> pp (srcRange lqn))
4 (text "Type not in scope:" <+> pp (thing lqn))
OverlappingSyms qns disp -> fixNameDisp disp $
hang (text "[error]")
4 $ text "Overlapping symbols defined:"
$$ vcat (map ppLocName qns)
ExpectedValue lqn disp -> fixNameDisp disp $
hang (text "[error] at" <+> pp (srcRange lqn))
4 (fsep [ text "Expected a value named", quotes (pp (thing lqn))
, text "but found a type instead"
, text "Did you mean `(" <.> pp (thing lqn) <.> text")?" ])
ExpectedType lqn disp -> fixNameDisp disp $
hang (text "[error] at" <+> pp (srcRange lqn))
4 (fsep [ text "Expected a type named", quotes (pp (thing lqn))
, text "but found a value instead" ])
FixityError o1 f1 o2 f2 disp -> fixNameDisp disp $
hang (text "[error] at" <+> pp (srcRange o1) <+> text "and" <+> pp (srcRange o2))
4 (fsep [ text "The fixities of"
, nest 2 $ vcat
[ "•" <+> pp (thing o1) <+> parens (pp f1)
, "•" <+> pp (thing o2) <+> parens (pp f2) ]
, text "are not compatible."
, text "You may use explicit parentheses to disambiguate." ])
InvalidConstraint ty disp -> fixNameDisp disp $
hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) (getLoc ty))
4 (fsep [ pp ty, text "is not a valid constraint" ])
MalformedBuiltin ty pn disp -> fixNameDisp disp $
hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) (getLoc ty))
4 (fsep [ text "invalid use of built-in type", pp pn
, text "in type", pp ty ])
BoundReservedType n loc src disp -> fixNameDisp disp $
hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) loc)
4 (fsep [ text "built-in type", quotes (pp n), text "shadowed in", src ])
OverlappingRecordUpdate xs ys disp -> fixNameDisp disp $
hang "[error] Overlapping record updates:"
4 (vcat [ ppLab xs, ppLab ys ])
where
ppLab as = ppNestedSels (thing as) <+> "at" <+> pp (srcRange as)
-- Warnings --------------------------------------------------------------------
data RenamerWarning
= SymbolShadowed Name [Name] NameDisp
| UnusedName Name NameDisp
deriving (Show, Generic, NFData)
instance PP RenamerWarning where
ppPrec _ (SymbolShadowed new originals disp) = fixNameDisp disp $
hang (text "[warning] at" <+> loc)
4 $ fsep [ text "This binding for" <+> backticks sym
, text "shadows the existing binding" <.> plural <+>
text "at" ]
$$ vcat (map (pp . nameLoc) originals)
where
plural | length originals > 1 = char 's'
| otherwise = empty
loc = pp (nameLoc new)
sym = pp new
ppPrec _ (UnusedName x disp) = fixNameDisp disp $
hang (text "[warning] at" <+> pp (nameLoc x))
4 (text "Unused name:" <+> pp x)
-- Renaming Monad --------------------------------------------------------------
data RO = RO
{ roLoc :: Range
, roMod :: !ModName
, roNames :: NamingEnv
, roDisp :: !NameDisp
}
data RW = RW
{ rwWarnings :: !(Seq.Seq RenamerWarning)
, rwErrors :: !(Seq.Seq RenamerError)
, rwSupply :: !Supply
, rwNameUseCount :: !(Map Name Int)
-- ^ How many times did we refer to each name.
-- Used to generate warnings for unused definitions.
}
newtype RenameM a = RenameM
{ unRenameM :: ReaderT RO (StateT RW Lift) a }
instance S.Semigroup a => S.Semigroup (RenameM a) where
{-# INLINE (<>) #-}
a <> b =
do x <- a
y <- b
return (x S.<> y)
instance (S.Semigroup a, Monoid a) => Monoid (RenameM a) where
{-# INLINE mempty #-}
mempty = return mempty
{-# INLINE mappend #-}
mappend = (S.<>)
instance Functor RenameM where
{-# INLINE fmap #-}
fmap f m = RenameM (fmap f (unRenameM m))
instance Applicative RenameM where
{-# INLINE pure #-}
pure x = RenameM (pure x)
{-# INLINE (<*>) #-}
l <*> r = RenameM (unRenameM l <*> unRenameM r)
instance Monad RenameM where
{-# INLINE return #-}
return x = RenameM (return x)
{-# INLINE (>>=) #-}
m >>= k = RenameM (unRenameM m >>= unRenameM . k)
instance FreshM RenameM where
liftSupply f = RenameM $ sets $ \ RW { .. } ->
let (a,s') = f rwSupply
rw' = RW { rwSupply = s', .. }
in a `seq` rw' `seq` (a, rw')
runRenamer :: Supply -> ModName -> NamingEnv -> RenameM a
-> (Either [RenamerError] (a,Supply),[RenamerWarning])
runRenamer s ns env m = (res, warnUnused ns env ro rw ++ F.toList (rwWarnings rw))
where
(a,rw) = runM (unRenameM m) ro
RW { rwErrors = Seq.empty
, rwWarnings = Seq.empty
, rwSupply = s
, rwNameUseCount = Map.empty
}
ro = RO { roLoc = emptyRange
, roNames = env
, roMod = ns
, roDisp = neverQualifyMod ns `mappend` toNameDisp env
}
res | Seq.null (rwErrors rw) = Right (a,rwSupply rw)
| otherwise = Left (F.toList (rwErrors rw))
-- | Record an error. XXX: use a better name
record :: (NameDisp -> RenamerError) -> RenameM ()
record f = RenameM $
do RO { .. } <- ask
RW { .. } <- get
set RW { rwErrors = rwErrors Seq.|> f roDisp, .. }
-- | Get the source range for wahtever we are currently renaming.
curLoc :: RenameM Range
curLoc = RenameM (roLoc `fmap` ask)
-- | Annotate something with the current range.
located :: a -> RenameM (Located a)
located thing =
do srcRange <- curLoc
return Located { .. }
-- | Do the given computation using the source code range from `loc` if any.
withLoc :: HasLoc loc => loc -> RenameM a -> RenameM a
withLoc loc m = RenameM $ case getLoc loc of
Just range -> do
ro <- ask
local ro { roLoc = range } (unRenameM m)
Nothing -> unRenameM m
-- | Retrieve the name of the current module.
getNS :: RenameM ModName
getNS = RenameM (roMod `fmap` ask)
-- | Shadow the current naming environment with some more names.
shadowNames :: BindsNames env => env -> RenameM a -> RenameM a
shadowNames = shadowNames' CheckAll
data EnvCheck = CheckAll -- ^ Check for overlap and shadowing
| CheckOverlap -- ^ Only check for overlap
| CheckNone -- ^ Don't check the environment
deriving (Eq,Show)
-- | Shadow the current naming environment with some more names. The boolean
-- parameter indicates whether or not to check for shadowing.
shadowNames' :: BindsNames env => EnvCheck -> env -> RenameM a -> RenameM a
shadowNames' check names m = do
do env <- liftSupply (namingEnv' names)
RenameM $
do ro <- ask
env' <- sets (checkEnv (roDisp ro) check env (roNames ro))
let ro' = ro { roNames = env' `shadowing` roNames ro }
local ro' (unRenameM m)
shadowNamesNS :: BindsNames (InModule env) => env -> RenameM a -> RenameM a
shadowNamesNS names m =
do ns <- getNS
shadowNames (InModule ns names) m
-- | Generate warnings when the left environment shadows things defined in
-- the right. Additionally, generate errors when two names overlap in the
-- left environment.
checkEnv :: NameDisp -> EnvCheck -> NamingEnv -> NamingEnv -> RW -> (NamingEnv,RW)
checkEnv disp check l r rw
| check == CheckNone = (l',rw)
| otherwise = (l',rw'')
where
l' = l { neExprs = es, neTypes = ts }
(rw',es) = Map.mapAccumWithKey (step neExprs) rw (neExprs l)
(rw'',ts) = Map.mapAccumWithKey (step neTypes) rw' (neTypes l)
step prj acc k ns = (acc', [head ns])
where
acc' = acc
{ rwWarnings =
if check == CheckAll
then case Map.lookup k (prj r) of
Nothing -> rwWarnings acc
Just os -> rwWarnings acc Seq.|> SymbolShadowed (head ns) os disp
else rwWarnings acc
, rwErrors = rwErrors acc Seq.>< containsOverlap disp ns
}
-- | Check the RHS of a single name rewrite for conflicting sources.
containsOverlap :: NameDisp -> [Name] -> Seq.Seq RenamerError
containsOverlap _ [_] = Seq.empty
containsOverlap _ [] = panic "Renamer" ["Invalid naming environment"]
containsOverlap disp ns = Seq.singleton (OverlappingSyms ns disp)
-- | Throw errors for any names that overlap in a rewrite environment.
checkNamingEnv :: NamingEnv -> ([RenamerError],[RenamerWarning])
checkNamingEnv env = (F.toList out, [])
where
out = Map.foldr check outTys (neExprs env)
outTys = Map.foldr check mempty (neTypes env)
disp = toNameDisp env
check ns acc = containsOverlap disp ns Seq.>< acc
recordUse :: Name -> RenameM ()
recordUse x = RenameM $ sets_ $ \rw ->
rw { rwNameUseCount = Map.insertWith (+) x 1 (rwNameUseCount rw) }
warnUnused :: ModName -> NamingEnv -> RO -> RW -> [RenamerWarning]
warnUnused m0 env ro rw =
map warn
$ Map.keys
$ Map.filterWithKey keep
$ rwNameUseCount rw
where
warn x = UnusedName x (roDisp ro)
keep k n = n == 1 && isLocal k
oldNames = fst (visibleNames env)
isLocal nm = case nameInfo nm of
Declared m sys -> sys == UserName &&
m == m0 && nm `Set.notMember` oldNames
Parameter -> True
-- Renaming --------------------------------------------------------------------
class Rename f where
rename :: f PName -> RenameM (f Name)
renameModule :: Module PName -> RenameM (NamingEnv,Module Name)
renameModule m =
do env <- liftSupply (namingEnv' m)
-- NOTE: we explicitly hide shadowing errors here, by using shadowNames'
decls' <- shadowNames' CheckOverlap env (traverse rename (mDecls m))
let m1 = m { mDecls = decls' }
exports = modExports m1
mapM_ recordUse (eTypes exports)
return (env,m1)
instance Rename TopDecl where
rename td = case td of
Decl d -> Decl <$> traverse rename d
DPrimType d -> DPrimType <$> traverse rename d
TDNewtype n -> TDNewtype <$> traverse rename n
Include n -> return (Include n)
DParameterFun f -> DParameterFun <$> rename f
DParameterType f -> DParameterType <$> rename f
DParameterConstraint d -> DParameterConstraint <$> mapM renameLocated d
renameLocated :: Rename f => Located (f PName) -> RenameM (Located (f Name))
renameLocated x =
do y <- rename (thing x)
return x { thing = y }
instance Rename PrimType where
rename pt =
do x <- rnLocated renameType (primTName pt)
let (as,ps) = primTCts pt
(_,cts) <- renameQual as ps $ \as' ps' -> pure (as',ps')
pure pt { primTCts = cts, primTName = x }
instance Rename ParameterType where
rename a =
do n' <- rnLocated renameType (ptName a)
return a { ptName = n' }
instance Rename ParameterFun where
rename a =
do n' <- rnLocated renameVar (pfName a)
sig' <- renameSchema (pfSchema a)
return a { pfName = n', pfSchema = snd sig' }
rnLocated :: (a -> RenameM b) -> Located a -> RenameM (Located b)
rnLocated f loc = withLoc loc $
do a' <- f (thing loc)
return loc { thing = a' }
instance Rename Decl where
rename d = case d of
DSignature ns sig -> DSignature <$> traverse (rnLocated renameVar) ns
<*> rename sig
DPragma ns p -> DPragma <$> traverse (rnLocated renameVar) ns
<*> pure p
DBind b -> DBind <$> rename b
-- XXX we probably shouldn't see these at this point...
DPatBind pat e -> do (pe,pat') <- renamePat pat
shadowNames pe (DPatBind pat' <$> rename e)
DType syn -> DType <$> rename syn
DProp syn -> DProp <$> rename syn
DLocated d' r -> withLoc r
$ DLocated <$> rename d' <*> pure r
DFixity{} -> panic "Renamer" ["Unexpected fixity declaration"
, show d]
instance Rename Newtype where
rename n = do
name' <- rnLocated renameType (nName n)
shadowNames (nParams n) $
do ps' <- traverse rename (nParams n)
body' <- traverse (rnNamed rename) (nBody n)
return Newtype { nName = name'
, nParams = ps'
, nBody = body' }
renameVar :: PName -> RenameM Name
renameVar qn = do
ro <- RenameM ask
case Map.lookup qn (neExprs (roNames ro)) of
Just [n] -> return n
Just [] -> panic "Renamer" ["Invalid expression renaming environment"]
Just syms ->
do n <- located qn
record (MultipleSyms n syms)
return (head syms)
-- This is an unbound value. Record an error and invent a bogus real name
-- for it.
Nothing ->
do n <- located qn
case Map.lookup qn (neTypes (roNames ro)) of
-- types existed with the name of the value expected
Just _ -> record (ExpectedValue n)
-- the value is just missing
Nothing -> record (UnboundExpr n)
mkFakeName qn
-- | Produce a name if one exists. Note that this includes situations where
-- overlap exists, as it's just a query about anything being in scope. In the
-- event that overlap does exist, an error will be recorded.
typeExists :: PName -> RenameM (Maybe Name)
typeExists pn =
do ro <- RenameM ask
case Map.lookup pn (neTypes (roNames ro)) of
Just [n] -> recordUse n >> return (Just n)
Just [] -> panic "Renamer" ["Invalid type renaming environment"]
Just syms -> do n <- located pn
mapM_ recordUse syms
record (MultipleSyms n syms)
return (Just (head syms))
Nothing -> return Nothing
renameType :: PName -> RenameM Name
renameType pn =
do mb <- typeExists pn
case mb of
Just n -> return n
-- This is an unbound value. Record an error and invent a bogus real name
-- for it.
Nothing ->
do ro <- RenameM ask
let n = Located { srcRange = roLoc ro, thing = pn }
case Map.lookup pn (neExprs (roNames ro)) of
-- values exist with the same name, so throw a different error
Just _ -> record (ExpectedType n)
-- no terms with the same name, so the type is just unbound
Nothing -> record (UnboundType n)
mkFakeName pn
-- | Assuming an error has been recorded already, construct a fake name that's
-- not expected to make it out of the renamer.
mkFakeName :: PName -> RenameM Name
mkFakeName pn =
do ro <- RenameM ask
liftSupply (mkParameter (getIdent pn) (roLoc ro))
-- | Rename a schema, assuming that none of its type variables are already in
-- scope.
instance Rename Schema where
rename s = snd `fmap` renameSchema s
-- | Rename a schema, assuming that the type variables have already been brought
-- into scope.
renameSchema :: Schema PName -> RenameM (NamingEnv,Schema Name)
renameSchema (Forall ps p ty loc) =
renameQual ps p $ \ps' p' ->
do ty' <- rename ty
pure (Forall ps' p' ty' loc)
-- | Rename a qualified thing.
renameQual :: [TParam PName] -> [Prop PName] ->
([TParam Name] -> [Prop Name] -> RenameM a) ->
RenameM (NamingEnv, a)
renameQual as ps k =
do env <- liftSupply (namingEnv' as)
res <- shadowNames env $ do as' <- traverse rename as
ps' <- traverse rename ps
k as' ps'
pure (env,res)
instance Rename TParam where
rename TParam { .. } =
do n <- renameType tpName
return TParam { tpName = n, .. }
instance Rename Prop where
rename (CType t) = CType <$> rename t
-- | Resolve fixity, then rename the resulting type.
instance Rename Type where
rename ty0 = go =<< resolveTypeFixity ty0
where
go :: Type PName -> RenameM (Type Name)
go (TFun a b) = TFun <$> go a <*> go b
go (TSeq n a) = TSeq <$> go n <*> go a
go TBit = return TBit
go (TNum c) = return (TNum c)
go (TChar c) = return (TChar c)
go (TUser qn ps) = TUser <$> renameType qn <*> traverse go ps
go (TRecord fs) = TRecord <$> traverse (rnNamed go) fs
go (TTuple fs) = TTuple <$> traverse go fs
go TWild = return TWild
go (TLocated t' r) = withLoc r (TLocated <$> go t' <*> pure r)
go (TParens t') = TParens <$> go t'
-- at this point, the fixity is correct, and we just need to perform
-- renaming.
go (TInfix a o f b) = TInfix <$> rename a
<*> rnLocated renameType o
<*> pure f
<*> rename b
resolveTypeFixity :: Type PName -> RenameM (Type PName)
resolveTypeFixity = go
where
go t = case t of
TFun a b -> TFun <$> go a <*> go b
TSeq n a -> TSeq <$> go n <*> go a
TUser pn ps -> TUser pn <$> traverse go ps
TRecord fs -> TRecord <$> traverse (traverse go) fs
TTuple fs -> TTuple <$> traverse go fs
TLocated t' r-> withLoc r (TLocated <$> go t' <*> pure r)
TParens t' -> TParens <$> go t'
TInfix a o _ b ->
do op <- lookupFixity o
a' <- go a
b' <- go b
mkTInfix a' op b'
TBit -> return t
TNum _ -> return t
TChar _ -> return t
TWild -> return t
type TOp = Type PName -> Type PName -> Type PName
mkTInfix :: Type PName -> (TOp,Fixity) -> Type PName -> RenameM (Type PName)
mkTInfix t op@(o2,f2) z =
case t of
TLocated t1 _ -> mkTInfix t1 op z
TInfix x ln f1 y ->
doFixity (\a b -> TInfix a ln f1 b) f1 x y
_ -> return (o2 t z)
where
doFixity mk f1 x y =
case compareFixity f1 f2 of
FCLeft -> return (o2 t z)
FCRight -> do r <- mkTInfix y op z
return (mk x r)
-- As the fixity table is known, and this is a case where the fixity came
-- from that table, it's a real error if the fixities didn't work out.
FCError -> panic "Renamer" [ "fixity problem for type operators"
, show (o2 t z) ]
-- | When possible, rewrite the type operator to a known constructor, otherwise
-- return a 'TOp' that reconstructs the original term, and a default fixity.
lookupFixity :: Located PName -> RenameM (TOp, Fixity)
lookupFixity op =
do n <- renameType sym
let fi = fromMaybe defaultFixity (nameFixity n)
return (\x y -> TInfix x op fi y, fi)
where
sym = thing op
-- | Rename a binding.
instance Rename Bind where
rename b = do
n' <- rnLocated renameVar (bName b)
mbSig <- traverse renameSchema (bSignature b)
shadowNames (fst `fmap` mbSig) $
do (patEnv,pats') <- renamePats (bParams b)
-- NOTE: renamePats will generate warnings, so we don't need to trigger
-- them again here.
e' <- shadowNames' CheckNone patEnv (rnLocated rename (bDef b))
return b { bName = n'
, bParams = pats'
, bDef = e'
, bSignature = snd `fmap` mbSig
, bPragmas = bPragmas b
}
instance Rename BindDef where
rename DPrim = return DPrim
rename (DExpr e) = DExpr <$> rename e
-- NOTE: this only renames types within the pattern.
instance Rename Pattern where
rename p = case p of
PVar lv -> PVar <$> rnLocated renameVar lv
PWild -> pure PWild
PTuple ps -> PTuple <$> traverse rename ps
PRecord nps -> PRecord <$> traverse (rnNamed rename) nps
PList elems -> PList <$> traverse rename elems
PTyped p' t -> PTyped <$> rename p' <*> rename t
PSplit l r -> PSplit <$> rename l <*> rename r
PLocated p' loc -> withLoc loc
$ PLocated <$> rename p' <*> pure loc
-- | Note that after this point the @->@ updates have an explicit function
-- and there are no more nested updates.
instance Rename UpdField where
rename (UpdField h ls e) =
-- The plan:
-- x = e ~~~> x = e
-- x -> e ~~~> x -> \x -> e
-- x.y = e ~~~> x -> { _ | y = e }
-- x.y -> e ~~~> x -> { _ | y -> e }
case ls of
l : more ->
case more of
[] -> case h of
UpdSet -> UpdField UpdSet [l] <$> rename e
UpdFun -> UpdField UpdFun [l] <$> rename (EFun [PVar p] e)
where
p = UnQual . selName <$> last ls
_ -> UpdField UpdFun [l] <$> rename (EUpd Nothing [ UpdField h more e])
[] -> panic "rename@UpdField" [ "Empty label list." ]
instance Rename Expr where
rename expr = case expr of
EVar n -> EVar <$> renameVar n
ELit l -> return (ELit l)
ENeg e -> ENeg <$> rename e
EComplement e -> EComplement
<$> rename e
EGenerate e -> EGenerate
<$> rename e
ETuple es -> ETuple <$> traverse rename es
ERecord fs -> ERecord <$> traverse (rnNamed rename) fs
ESel e' s -> ESel <$> rename e' <*> pure s
EUpd mb fs -> do checkLabels fs
EUpd <$> traverse rename mb <*> traverse rename fs
EList es -> EList <$> traverse rename es
EFromTo s n e t -> EFromTo <$> rename s
<*> traverse rename n
<*> rename e
<*> traverse rename t
EInfFrom a b -> EInfFrom<$> rename a <*> traverse rename b
EComp e' bs -> do arms' <- traverse renameArm bs
let (envs,bs') = unzip arms'
-- NOTE: renameArm will generate shadowing warnings; we only
-- need to check for repeated names across multiple arms
shadowNames' CheckOverlap envs (EComp <$> rename e' <*> pure bs')
EApp f x -> EApp <$> rename f <*> rename x
EAppT f ti -> EAppT <$> rename f <*> traverse rename ti
EIf b t f -> EIf <$> rename b <*> rename t <*> rename f
EWhere e' ds -> do ns <- getNS
shadowNames (map (InModule ns) ds) $
EWhere <$> rename e' <*> traverse rename ds
ETyped e' ty -> ETyped <$> rename e' <*> rename ty
ETypeVal ty -> ETypeVal<$> rename ty
EFun ps e' -> do (env,ps') <- renamePats ps
-- NOTE: renamePats will generate warnings, so we don't
-- need to duplicate them here
shadowNames' CheckNone env (EFun ps' <$> rename e')
ELocated e' r -> withLoc r
$ ELocated <$> rename e' <*> pure r
ESplit e -> ESplit <$> rename e
EParens p -> EParens <$> rename p
EInfix x y _ z -> do op <- renameOp y
x' <- rename x
z' <- rename z
mkEInfix x' op z'
checkLabels :: [UpdField PName] -> RenameM ()
checkLabels = foldM_ check [] . map labs
where
labs (UpdField _ ls _) = ls
check done l =
do case find (overlap l) done of
Just l' -> record (OverlappingRecordUpdate (reLoc l) (reLoc l'))
Nothing -> pure ()
pure (l : done)
overlap xs ys =
case (xs,ys) of
([],_) -> True
(_, []) -> True
(x : xs', y : ys') -> same x y && overlap xs' ys'
same x y =
case (thing x, thing y) of
(TupleSel a _, TupleSel b _) -> a == b
(ListSel a _, ListSel b _) -> a == b
(RecordSel a _, RecordSel b _) -> a == b
_ -> False
reLoc xs = (head xs) { thing = map thing xs }
mkEInfix :: Expr Name -- ^ May contain infix expressions
-> (Located Name,Fixity) -- ^ The operator to use
-> Expr Name -- ^ Will not contain infix expressions
-> RenameM (Expr Name)
mkEInfix e@(EInfix x o1 f1 y) op@(o2,f2) z =
case compareFixity f1 f2 of
FCLeft -> return (EInfix e o2 f2 z)
FCRight -> do r <- mkEInfix y op z
return (EInfix x o1 f1 r)
FCError -> do record (FixityError o1 f1 o2 f2)
return (EInfix e o2 f2 z)
mkEInfix (ELocated e' _) op z =
mkEInfix e' op z
mkEInfix e (o,f) z =
return (EInfix e o f z)
renameOp :: Located PName -> RenameM (Located Name,Fixity)
renameOp ln = withLoc ln $
do n <- renameVar (thing ln)
case nameFixity n of
Just fixity -> return (ln { thing = n },fixity)
Nothing -> return (ln { thing = n },defaultFixity)
instance Rename TypeInst where
rename ti = case ti of
NamedInst nty -> NamedInst <$> traverse rename nty
PosInst ty -> PosInst <$> rename ty
renameArm :: [Match PName] -> RenameM (NamingEnv,[Match Name])
renameArm (m:ms) =
do (me,m') <- renameMatch m
-- NOTE: renameMatch will generate warnings, so we don't
-- need to duplicate them here
shadowNames' CheckNone me $
do (env,rest) <- renameArm ms
-- NOTE: the inner environment shadows the outer one, for examples
-- like this:
--
-- [ x | x <- xs, let x = 10 ]
return (env `shadowing` me, m':rest)
renameArm [] =
return (mempty,[])
-- | The name environment generated by a single match.
renameMatch :: Match PName -> RenameM (NamingEnv,Match Name)
renameMatch (Match p e) =
do (pe,p') <- renamePat p
e' <- rename e
return (pe,Match p' e')
renameMatch (MatchLet b) =
do ns <- getNS
be <- liftSupply (namingEnv' (InModule ns b))
b' <- shadowNames be (rename b)
return (be,MatchLet b')
-- | Rename patterns, and collect the new environment that they introduce.
renamePat :: Pattern PName -> RenameM (NamingEnv, Pattern Name)
renamePat p =
do pe <- patternEnv p
p' <- shadowNames pe (rename p)
return (pe, p')
-- | Rename patterns, and collect the new environment that they introduce.
renamePats :: [Pattern PName] -> RenameM (NamingEnv,[Pattern Name])
renamePats = loop
where
loop ps = case ps of
p:rest -> do
pe <- patternEnv p
shadowNames pe $
do p' <- rename p
(env',rest') <- loop rest
return (pe `mappend` env', p':rest')
[] -> return (mempty, [])
patternEnv :: Pattern PName -> RenameM NamingEnv
patternEnv = go
where
go (PVar Located { .. }) =
do n <- liftSupply (mkParameter (getIdent thing) srcRange)
return (singletonE thing n)
go PWild = return mempty
go (PTuple ps) = bindVars ps
go (PRecord fs) = bindVars (map value fs)
go (PList ps) = foldMap go ps
go (PTyped p ty) = go p `mappend` typeEnv ty
go (PSplit a b) = go a `mappend` go b
go (PLocated p loc) = withLoc loc (go p)
bindVars [] = return mempty
bindVars (p:ps) =
do env <- go p
shadowNames env $
do rest <- bindVars ps
return (env `mappend` rest)
typeEnv (TFun a b) = bindTypes [a,b]
typeEnv (TSeq a b) = bindTypes [a,b]
typeEnv TBit = return mempty
typeEnv TNum{} = return mempty
typeEnv TChar{} = return mempty
typeEnv (TUser pn ps) =
do mb <- typeExists pn
case mb of
-- The type is already bound, don't introduce anything.
Just _ -> bindTypes ps
Nothing
-- The type isn't bound, and has no parameters, so it names a portion
-- of the type of the pattern.
| null ps ->
do loc <- curLoc
n <- liftSupply (mkParameter (getIdent pn) loc)
return (singletonT pn n)
-- This references a type synonym that's not in scope. Record an
-- error and continue with a made up name.
| otherwise ->
do loc <- curLoc
record (UnboundType (Located loc pn))
n <- liftSupply (mkParameter (getIdent pn) loc)
return (singletonT pn n)
typeEnv (TRecord fs) = bindTypes (map value fs)
typeEnv (TTuple ts) = bindTypes ts
typeEnv TWild = return mempty
typeEnv (TLocated ty loc) = withLoc loc (typeEnv ty)
typeEnv (TParens ty) = typeEnv ty
typeEnv (TInfix a _ _ b) = bindTypes [a,b]
bindTypes [] = return mempty
bindTypes (t:ts) =
do env' <- typeEnv t
shadowNames env' $
do res <- bindTypes ts
return (env' `mappend` res)
instance Rename Match where
rename m = case m of
Match p e -> Match <$> rename p <*> rename e
MatchLet b -> shadowNamesNS b (MatchLet <$> rename b)
instance Rename TySyn where
rename (TySyn n f ps ty) =
shadowNames ps $ TySyn <$> rnLocated renameType n
<*> pure f
<*> traverse rename ps
<*> rename ty
instance Rename PropSyn where
rename (PropSyn n f ps cs) =
shadowNames ps $ PropSyn <$> rnLocated renameType n
<*> pure f
<*> traverse rename ps
<*> traverse rename cs
-- Utilities -------------------------------------------------------------------
rnNamed :: (a -> RenameM b) -> Named a -> RenameM (Named b)
rnNamed = traverse
{-# INLINE rnNamed #-}
cryptol-2.8.0/src/Cryptol/Parser.y 0000644 0000000 0000000 00000105367 07346545000 015273 0 ustar 00 0000000 0000000 {
-- |
-- Module : Cryptol.Parser
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Trustworthy #-}
module Cryptol.Parser
( parseModule
, parseProgram, parseProgramWith
, parseExpr, parseExprWith
, parseDecl, parseDeclWith
, parseDecls, parseDeclsWith
, parseLetDecl, parseLetDeclWith
, parseRepl, parseReplWith
, parseSchema, parseSchemaWith
, parseModName, parseHelpName
, ParseError(..), ppError
, Layout(..)
, Config(..), defaultConfig
, guessPreProc, PreProc(..)
) where
import Control.Applicative as A
import Data.Maybe(fromMaybe)
import Data.Text(Text)
import qualified Data.Text as T
import Control.Monad(liftM2,msum)
import Cryptol.Parser.AST
import Cryptol.Parser.Position
import Cryptol.Parser.LexerUtils hiding (mkIdent)
import Cryptol.Parser.ParserUtils
import Cryptol.Parser.Unlit(PreProc(..), guessPreProc)
import Cryptol.Utils.Ident(paramInstModName)
import Paths_cryptol
}
{- state 196 contains 1 shift/reduce conflicts.
`_` identifier conflicts with `_` in record update.
We have `_` as an identifier for the cases where we parse types as
expressions, for example `[ 12 .. _ ]`.
-}
%expect 1
%token
NUM { $$@(Located _ (Token (Num {}) _))}
STRLIT { $$@(Located _ (Token (StrLit {}) _))}
CHARLIT { $$@(Located _ (Token (ChrLit {}) _))}
IDENT { $$@(Located _ (Token (Ident [] _) _))}
QIDENT { $$@(Located _ (Token Ident{} _))}
'include' { Located $$ (Token (KW KW_include) _)}
'import' { Located $$ (Token (KW KW_import) _)}
'as' { Located $$ (Token (KW KW_as) _)}
'hiding' { Located $$ (Token (KW KW_hiding) _)}
'private' { Located $$ (Token (KW KW_private) _)}
'parameter' { Located $$ (Token (KW KW_parameter) _)}
'property' { Located $$ (Token (KW KW_property) _)}
'infix' { Located $$ (Token (KW KW_infix) _)}
'infixl' { Located $$ (Token (KW KW_infixl) _)}
'infixr' { Located $$ (Token (KW KW_infixr) _)}
'type' { Located $$ (Token (KW KW_type ) _)}
'newtype' { Located $$ (Token (KW KW_newtype) _)}
'module' { Located $$ (Token (KW KW_module ) _)}
'where' { Located $$ (Token (KW KW_where ) _)}
'let' { Located $$ (Token (KW KW_let ) _)}
'if' { Located $$ (Token (KW KW_if ) _)}
'then' { Located $$ (Token (KW KW_then ) _)}
'else' { Located $$ (Token (KW KW_else ) _)}
'x' { Located $$ (Token (KW KW_x) _)}
'primitive' { Located $$ (Token (KW KW_primitive) _)}
'constraint'{ Located $$ (Token (KW KW_constraint) _)}
'Prop' { Located $$ (Token (KW KW_Prop) _)}
'[' { Located $$ (Token (Sym BracketL) _)}
']' { Located $$ (Token (Sym BracketR) _)}
'<-' { Located $$ (Token (Sym ArrL ) _)}
'..' { Located $$ (Token (Sym DotDot ) _)}
'...' { Located $$ (Token (Sym DotDotDot) _)}
'|' { Located $$ (Token (Sym Bar ) _)}
'(' { Located $$ (Token (Sym ParenL ) _)}
')' { Located $$ (Token (Sym ParenR ) _)}
',' { Located $$ (Token (Sym Comma ) _)}
';' { Located $$ (Token (Sym Semi ) _)}
'.' { Located $$ (Token (Sym Dot ) _)}
'{' { Located $$ (Token (Sym CurlyL ) _)}
'}' { Located $$ (Token (Sym CurlyR ) _)}
'<|' { Located $$ (Token (Sym TriL ) _)}
'|>' { Located $$ (Token (Sym TriR ) _)}
'=' { Located $$ (Token (Sym EqDef ) _)}
'`' { Located $$ (Token (Sym BackTick) _)}
':' { Located $$ (Token (Sym Colon ) _)}
'->' { Located $$ (Token (Sym ArrR ) _)}
'=>' { Located $$ (Token (Sym FatArrR ) _)}
'\\' { Located $$ (Token (Sym Lambda ) _)}
'_' { Located $$ (Token (Sym Underscore ) _)}
'v{' { Located $$ (Token (Virt VCurlyL) _)}
'v}' { Located $$ (Token (Virt VCurlyR) _)}
'v;' { Located $$ (Token (Virt VSemi) _)}
'+' { Located $$ (Token (Op Plus) _)}
'*' { Located $$ (Token (Op Mul) _)}
'^^' { Located $$ (Token (Op Exp) _)}
'-' { Located $$ (Token (Op Minus) _)}
'~' { Located $$ (Token (Op Complement) _)}
'#' { Located $$ (Token (Op Hash) _)}
'@' { Located $$ (Token (Op At) _)}
OP { $$@(Located _ (Token (Op (Other [] _)) _))}
QOP { $$@(Located _ (Token (Op Other{} ) _))}
DOC { $$@(Located _ (Token (White DocStr) _)) }
%name vmodule vmodule
%name program program
%name programLayout program_layout
%name expr expr
%name decl decl
%name decls decls
%name declsLayout decls_layout
%name letDecl let_decl
%name repl repl
%name schema schema
%name modName modName
%name helpName help_name
%tokentype { Located Token }
%monad { ParseM }
%lexer { lexerP } { Located _ (Token EOF _) }
{- If you add additional operators, please update the corresponding
tables in the pretty printer. -}
%right '->'
%right '#'
%%
vmodule :: { Module PName }
: 'module' modName 'where' 'v{' vmod_body 'v}' { mkModule $2 $5 }
| 'module' modName '=' modName 'where' 'v{' vmod_body 'v}'
{ mkModuleInstance $2 $4 $7 }
| 'v{' vmod_body 'v}' { mkAnonymousModule $2 }
vmod_body :: { ([Located Import], [TopDecl PName]) }
: vimports 'v;' vtop_decls { (reverse $1, reverse $3) }
| vimports ';' vtop_decls { (reverse $1, reverse $3) }
| vimports { (reverse $1, []) }
| vtop_decls { ([], reverse $1) }
| {- empty -} { ([], []) }
vimports :: { [Located Import] }
: vimports 'v;' import { $3 : $1 }
| vimports ';' import { $3 : $1 }
| import { [$1] }
-- XXX replace rComb with uses of at
import :: { Located Import }
: 'import' modName mbAs mbImportSpec
{ Located { srcRange = rComb $1
$ fromMaybe (srcRange $2)
$ msum [ fmap srcRange $4
, fmap srcRange $3
]
, thing = Import
{ iModule = thing $2
, iAs = fmap thing $3
, iSpec = fmap thing $4
}
} }
mbAs :: { Maybe (Located ModName) }
: 'as' modName { Just $2 }
| {- empty -} { Nothing }
mbImportSpec :: { Maybe (Located ImportSpec) }
: mbHiding '(' name_list ')'{ Just Located
{ srcRange = case $3 of
{ [] -> emptyRange
; xs -> rCombs (map srcRange xs) }
, thing = $1 (reverse (map thing $3))
} }
| {- empty -} { Nothing }
name_list :: { [LIdent] }
: name_list ',' ident { $3 : $1 }
| ident { [$1] }
| {- empty -} { [] }
mbHiding :: { [Ident] -> ImportSpec }
: 'hiding' { Hiding }
| {- empty -} { Only }
program :: { Program PName }
: top_decls { Program (reverse $1) }
| {- empty -} { Program [] }
program_layout :: { Program PName }
: 'v{' vtop_decls 'v}' { Program (reverse $2) }
| 'v{''v}' { Program [] }
top_decls :: { [TopDecl PName] }
: top_decl ';' { $1 }
| top_decls top_decl ';' { $2 ++ $1 }
vtop_decls :: { [TopDecl PName] }
: vtop_decl { $1 }
| vtop_decls 'v;' vtop_decl { $3 ++ $1 }
| vtop_decls ';' vtop_decl { $3 ++ $1 }
vtop_decl :: { [TopDecl PName] }
: decl { [exportDecl Nothing Public $1] }
| doc decl { [exportDecl (Just $1) Public $2] }
| mbDoc 'include' STRLIT {% (return . Include) `fmap` fromStrLit $3 }
| mbDoc 'property' name apats '=' expr
{ [exportDecl $1 Public (mkProperty $3 $4 $6)] }
| mbDoc 'property' name '=' expr
{ [exportDecl $1 Public (mkProperty $3 [] $5)] }
| mbDoc newtype { [exportNewtype Public $1 $2] }
| prim_bind { $1 }
| private_decls { $1 }
| parameter_decls { $1 }
top_decl :: { [TopDecl PName] }
: decl { [Decl (TopLevel {tlExport = Public, tlValue = $1 })] }
| 'include' STRLIT {% (return . Include) `fmap` fromStrLit $2 }
| prim_bind { $1 }
private_decls :: { [TopDecl PName] }
: 'private' 'v{' vtop_decls 'v}'
{ changeExport Private (reverse $3) }
| doc 'private' 'v{' vtop_decls 'v}'
{ changeExport Private (reverse $4) }
prim_bind :: { [TopDecl PName] }
: mbDoc 'primitive' name ':' schema { mkPrimDecl $1 $3 $5 }
| mbDoc 'primitive' '(' op ')' ':' schema { mkPrimDecl $1 $4 $7 }
| mbDoc 'primitive' 'type' schema ':' kind {% mkPrimTypeDecl $1 $4 $6 }
parameter_decls :: { [TopDecl PName] }
: 'parameter' 'v{' par_decls 'v}' { reverse $3 }
| doc 'parameter' 'v{' par_decls 'v}' { reverse $4 }
-- Reversed
par_decls :: { [TopDecl PName] }
: par_decl { [$1] }
| par_decls ';' par_decl { $3 : $1 }
| par_decls 'v;' par_decl { $3 : $1 }
par_decl :: { TopDecl PName }
: mbDoc name ':' schema { mkParFun $1 $2 $4 }
| mbDoc 'type' name ':' kind {% mkParType $1 $3 $5 }
| mbDoc 'type' 'constraint' type {% fmap (DParameterConstraint . distrLoc)
(mkProp $4) }
doc :: { Located String }
: DOC { mkDoc (fmap tokenText $1) }
mbDoc :: { Maybe (Located String) }
: doc { Just $1 }
| {- empty -} { Nothing }
decl :: { Decl PName }
: vars_comma ':' schema { at (head $1,$3) $ DSignature (reverse $1) $3 }
| ipat '=' expr { at ($1,$3) $ DPatBind $1 $3 }
| '(' op ')' '=' expr { at ($1,$5) $ DPatBind (PVar $2) $5 }
| var apats_indices '=' expr
{ at ($1,$4) $ mkIndexedDecl $1 $2 $4 }
| apat pat_op apat '=' expr
{ at ($1,$5) $
DBind $ Bind { bName = $2
, bParams = [$1,$3]
, bDef = at $5 (Located emptyRange (DExpr $5))
, bSignature = Nothing
, bPragmas = []
, bMono = False
, bInfix = True
, bFixity = Nothing
, bDoc = Nothing
} }
| 'type' name '=' type {% at ($1,$4) `fmap` mkTySyn $2 [] $4 }
| 'type' name tysyn_params '=' type
{% at ($1,$5) `fmap` mkTySyn $2 (reverse $3) $5 }
| 'type' tysyn_param op tysyn_param '=' type
{% at ($1,$6) `fmap` mkTySyn $3 [$2, $4] $6 }
| 'type' 'constraint' name '=' type
{% at ($2,$5) `fmap` mkPropSyn $3 [] $5 }
| 'type' 'constraint' name tysyn_params '=' type
{% at ($2,$6) `fmap` mkPropSyn $3 (reverse $4) $6 }
| 'type' 'constraint' tysyn_param op tysyn_param '=' type
{% at ($2,$7) `fmap` mkPropSyn $4 [$3, $5] $7 }
| 'infixl' NUM ops {% mkFixity LeftAssoc $2 (reverse $3) }
| 'infixr' NUM ops {% mkFixity RightAssoc $2 (reverse $3) }
| 'infix' NUM ops {% mkFixity NonAssoc $2 (reverse $3) }
| error {% expected "a declaration" }
let_decl :: { Decl PName }
: 'let' ipat '=' expr { at ($2,$4) $ DPatBind $2 $4 }
| 'let' name apats_indices '=' expr { at ($2,$5) $ mkIndexedDecl $2 $3 $5 }
newtype :: { Newtype PName }
: 'newtype' qname '=' newtype_body
{ Newtype { nName = $2, nParams = [], nBody = $4 } }
| 'newtype' qname tysyn_params '=' newtype_body
{ Newtype { nName = $2, nParams = $3, nBody = $5 } }
newtype_body :: { [Named (Type PName)] }
: '{' '}' { [] }
| '{' field_types '}' { $2 }
vars_comma :: { [ LPName ] }
: var { [ $1] }
| vars_comma ',' var { $3 : $1 }
var :: { LPName }
: name { $1 }
| '(' op ')' { $2 }
apats :: { [Pattern PName] }
: apat { [$1] }
| apats apat { $2 : $1 }
indices :: { [Pattern PName] }
: '@' indices1 { $2 }
| {- empty -} { [] }
indices1 :: { [Pattern PName] }
: apat { [$1] }
| indices1 '@' apat { $3 : $1 }
apats_indices :: { ([Pattern PName], [Pattern PName]) }
: apats indices { ($1, $2) }
| '@' indices1 { ([], $2) }
decls :: { [Decl PName] }
: decl ';' { [$1] }
| decls decl ';' { $2 : $1 }
vdecls :: { [Decl PName] }
: decl { [$1] }
| vdecls 'v;' decl { $3 : $1 }
| vdecls ';' decl { $3 : $1 }
decls_layout :: { [Decl PName] }
: 'v{' vdecls 'v}' { $2 }
| 'v{' 'v}' { [] }
repl :: { ReplInput PName }
: expr { ExprInput $1 }
| let_decl { LetInput $1 }
--------------------------------------------------------------------------------
-- Operators
qop :: { LPName }
: op { $1 }
| QOP { let Token (Op (Other ns i)) _ = thing $1
in mkQual (mkModName ns) (mkInfix i) A.<$ $1 }
op :: { LPName }
: pat_op { $1 }
| '#' { Located $1 $ mkUnqual $ mkInfix "#" }
| '@' { Located $1 $ mkUnqual $ mkInfix "@" }
pat_op :: { LPName }
: other_op { $1 }
-- special cases for operators that are re-used elsewhere
| '*' { Located $1 $ mkUnqual $ mkInfix "*" }
| '+' { Located $1 $ mkUnqual $ mkInfix "+" }
| '-' { Located $1 $ mkUnqual $ mkInfix "-" }
| '~' { Located $1 $ mkUnqual $ mkInfix "~" }
| '^^' { Located $1 $ mkUnqual $ mkInfix "^^" }
other_op :: { LPName }
: OP { let Token (Op (Other [] str)) _ = thing $1
in mkUnqual (mkInfix str) A.<$ $1 }
ops :: { [LPName] }
: op { [$1] }
| ops ',' op { $3 : $1 }
--------------------------------------------------------------------------------
-- Expressions
expr :: { Expr PName }
: exprNoWhere { $1 }
| expr 'where' whereClause { at ($1,$3) (EWhere $1 (thing $3)) }
-- | An expression without a `where` clause
exprNoWhere :: { Expr PName }
: simpleExpr qop longRHS { at ($1,$3) (binOp $1 $2 $3) }
| longRHS { $1 }
| typedExpr { $1 }
whereClause :: { Located [Decl PName] }
: '{' '}' { Located (rComb $1 $2) [] }
| '{' decls '}' { Located (rComb $1 $3) (reverse $2) }
| 'v{' 'v}' { Located (rComb $1 $2) [] }
| 'v{' vdecls 'v}' { let l2 = fromMaybe $3 (getLoc $2)
in Located (rComb $1 l2) (reverse $2) }
-- An expression with a type annotation
typedExpr :: { Expr PName }
: simpleExpr ':' type { at ($1,$3) (ETyped $1 $3) }
-- A possibly infix expression (no where, no long application, no type annot)
simpleExpr :: { Expr PName }
: simpleExpr qop simpleRHS { at ($1,$3) (binOp $1 $2 $3) }
| simpleRHS { $1 }
-- An expression without an obvious end marker
longExpr :: { Expr PName }
: 'if' ifBranches 'else' exprNoWhere { at ($1,$4) $ mkIf (reverse $2) $4 }
| '\\' apats '->' exprNoWhere { at ($1,$4) $ EFun (reverse $2) $4 }
ifBranches :: { [(Expr PName, Expr PName)] }
: ifBranch { [$1] }
| ifBranches '|' ifBranch { $3 : $1 }
ifBranch :: { (Expr PName, Expr PName) }
: expr 'then' expr { ($1, $3) }
simpleRHS :: { Expr PName }
: '-' simpleApp { at ($1,$2) (ENeg $2) }
| '~' simpleApp { at ($1,$2) (EComplement $2) }
| simpleApp { $1 }
longRHS :: { Expr PName }
: '-' longApp { at ($1,$2) (ENeg $2) }
| '~' longApp { at ($1,$2) (EComplement $2) }
| longApp { $1 }
-- Prefix application expression, ends with an atom.
simpleApp :: { Expr PName }
: aexprs { mkEApp $1 }
-- Prefix application expression, may end with a long expression
longApp :: { Expr PName }
: simpleApp longExpr { at ($1,$2) (EApp $1 $2) }
| longExpr { $1 }
| simpleApp { $1 }
aexprs :: { [Expr PName] }
: aexpr { [$1] }
| aexprs aexpr { $2 : $1 }
-- Expression atom (needs no parens)
aexpr :: { Expr PName }
: no_sel_aexpr { $1 }
| sel_expr { $1 }
no_sel_aexpr :: { Expr PName }
: qname { at $1 $ EVar (thing $1) }
| NUM { at $1 $ numLit (tokenType (thing $1)) }
| STRLIT { at $1 $ ELit $ ECString $ getStr $1 }
| CHARLIT { at $1 $ ELit $ ECNum (getNum $1) CharLit }
| '_' { at $1 $ EVar $ mkUnqual $ mkIdent "_" }
| '(' expr ')' { at ($1,$3) $ EParens $2 }
| '(' tuple_exprs ')' { at ($1,$3) $ ETuple (reverse $2) }
| '(' ')' { at ($1,$2) $ ETuple [] }
| '{' '}' { at ($1,$2) $ ERecord [] }
| '{' rec_expr '}' { at ($1,$3) $2 }
| '[' ']' { at ($1,$2) $ EList [] }
| '[' list_expr ']' { at ($1,$3) $2 }
| '`' tick_ty { at ($1,$2) $ ETypeVal $2 }
| '(' qop ')' { at ($1,$3) $ EVar $ thing $2 }
| '<|' '|>' {% mkPoly (rComb $1 $2) [] }
| '<|' poly_terms '|>' {% mkPoly (rComb $1 $3) $2 }
sel_expr :: { Expr PName }
: no_sel_aexpr '.' selector { at ($1,$3) $ ESel $1 (thing $3) }
| sel_expr '.' selector { at ($1,$3) $ ESel $1 (thing $3) }
poly_terms :: { [(Bool, Integer)] }
: poly_term { [$1] }
| poly_terms '+' poly_term { $3 : $1 }
poly_term :: { (Bool, Integer) }
: NUM {% polyTerm (srcRange $1) (getNum $1) 0 }
| 'x' {% polyTerm $1 1 1 }
| 'x' '^^' NUM {% polyTerm (rComb $1 (srcRange $3))
1 (getNum $3) }
selector :: { Located Selector }
: ident { fmap (`RecordSel` Nothing) $1 }
| NUM {% mkTupleSel (srcRange $1) (getNum $1) }
tuple_exprs :: { [Expr PName] }
: expr ',' expr { [ $3, $1] }
| tuple_exprs ',' expr { $3 : $1 }
rec_expr :: { Expr PName }
: aexpr '|' field_exprs { EUpd (Just $1) (reverse $3) }
| '_' '|' field_exprs { EUpd Nothing (reverse $3) }
| field_exprs {% do { xs <- mapM ufToNamed $1;
pure (ERecord (reverse xs)) } }
field_expr :: { UpdField PName }
: selector field_how expr { UpdField $2 [$1] $3 }
| sels field_how expr { UpdField $2 $1 $3 }
| sels apats_indices field_how expr
{ UpdField $3 $1 (mkIndexedExpr $2 $4) }
| selector apats_indices field_how expr
{ UpdField $3 [$1] (mkIndexedExpr $2 $4) }
field_how :: { UpdHow }
: '=' { UpdSet }
| '->' { UpdFun }
sels :: { [ Located Selector ] }
: sel_expr {% selExprToSels $1 }
field_exprs :: { [UpdField PName] }
: field_expr { [$1] }
| field_exprs ',' field_expr { $3 : $1 }
list_expr :: { Expr PName }
: expr '|' list_alts { EComp $1 (reverse $3) }
| expr { EList [$1] }
| tuple_exprs { EList (reverse $1) }
{- The `expr` in the four productions that follow should be `type`.
This, however, leads to ambiguity because the syntax for types and
expressions overlaps and we need more than 1 look-ahead to resolve what
is being parsed. For this reason, we use `expr` temporarily and
then convert it to the corresponding type in the AST. -}
| expr '..' expr {% eFromTo $2 $1 Nothing $3 }
| expr ',' expr '..' expr {% eFromTo $4 $1 (Just $3) $5 }
| expr '...' { EInfFrom $1 Nothing }
| expr ',' expr '...' { EInfFrom $1 (Just $3) }
list_alts :: { [[Match PName]] }
: matches { [ reverse $1 ] }
| list_alts '|' matches { reverse $3 : $1 }
matches :: { [Match PName] }
: match { [$1] }
| matches ',' match { $3 : $1 }
match :: { Match PName }
: pat '<-' expr { Match $1 $3 }
--------------------------------------------------------------------------------
pat :: { Pattern PName }
: ipat ':' type { at ($1,$3) $ PTyped $1 $3 }
| ipat { $1 }
ipat :: { Pattern PName }
: ipat '#' ipat { at ($1,$3) $ PSplit $1 $3 }
| apat { $1 }
apat :: { Pattern PName }
: name { PVar $1 }
| '_' { at $1 $ PWild }
| '(' ')' { at ($1,$2) $ PTuple [] }
| '(' pat ')' { at ($1,$3) $2 }
| '(' tuple_pats ')' { at ($1,$3) $ PTuple (reverse $2) }
| '[' ']' { at ($1,$2) $ PList [] }
| '[' pat ']' { at ($1,$3) $ PList [$2] }
| '[' tuple_pats ']' { at ($1,$3) $ PList (reverse $2) }
| '{' '}' { at ($1,$2) $ PRecord [] }
| '{' field_pats '}' { at ($1,$3) $ PRecord (reverse $2) }
tuple_pats :: { [Pattern PName] }
: pat ',' pat { [$3, $1] }
| tuple_pats ',' pat { $3 : $1 }
field_pat :: { Named (Pattern PName) }
: ident '=' pat { Named { name = $1, value = $3 } }
field_pats :: { [Named (Pattern PName)] }
: field_pat { [$1] }
| field_pats ',' field_pat { $3 : $1 }
--------------------------------------------------------------------------------
schema :: { Schema PName }
: type { at $1 $ mkSchema [] [] $1 }
| schema_vars type { at ($1,$2) $ mkSchema (thing $1) [] $2 }
| schema_quals type { at ($1,$2) $ mkSchema [] (thing $1) $2 }
| schema_vars schema_quals type { at ($1,$3) $ mkSchema (thing $1)
(thing $2) $3 }
schema_vars :: { Located [TParam PName] }
: '{' '}' { Located (rComb $1 $2) [] }
| '{' schema_params '}' { Located (rComb $1 $3) (reverse $2) }
schema_quals :: { Located [Prop PName] }
: schema_quals schema_qual { at ($1,$2) $ fmap (++ thing $2) $1 }
| schema_qual { $1 }
schema_qual :: { Located [Prop PName] }
: type '=>' {% fmap (\x -> at (x,$2) x) (mkProp $1) }
kind :: { Located Kind }
: '#' { Located $1 KNum }
| '*' { Located $1 KType }
| 'Prop' { Located $1 KProp }
| kind '->' kind { combLoc KFun $1 $3 }
schema_param :: { TParam PName }
: ident {% mkTParam $1 Nothing }
| ident ':' kind {% mkTParam (at ($1,$3) $1) (Just (thing $3)) }
schema_params :: { [TParam PName] }
: schema_param { [$1] }
| schema_params ',' schema_param { $3 : $1 }
tysyn_param :: { TParam PName }
: ident {% mkTParam $1 Nothing }
| '(' ident ':' kind ')' {% mkTParam (at ($1,$5) $2) (Just (thing $4)) }
tysyn_params :: { [TParam PName] }
: tysyn_param { [$1] }
| tysyn_params tysyn_param { $2 : $1 }
type :: { Type PName }
: infix_type '->' type { at ($1,$3) $ TFun $1 $3 }
| infix_type { $1 }
infix_type :: { Type PName }
: infix_type op app_type { at ($1,$3) $ TInfix $1 $2 defaultFixity $3 }
| app_type { $1 }
app_type :: { Type PName }
: dimensions atype { at ($1,$2) $ foldr TSeq $2 (reverse (thing $1)) }
| qname atypes { at ($1,head $2)
$ TUser (thing $1) (reverse $2) }
| atype { $1 }
atype :: { Type PName }
: qname { at $1 $ TUser (thing $1) [] }
| '(' qop ')' { at $1 $ TUser (thing $2) [] }
| NUM { at $1 $ TNum (getNum $1) }
| CHARLIT { at $1 $ TChar (toEnum $ fromInteger
$ getNum $1) }
| '[' type ']' { at ($1,$3) $ TSeq $2 TBit }
| '(' type ')' { at ($1,$3) $ TParens $2 }
| '(' ')' { at ($1,$2) $ TTuple [] }
| '(' tuple_types ')' { at ($1,$3) $ TTuple (reverse $2) }
| '{' '}' { at ($1,$2) $ TRecord [] }
| '{' field_types '}' { at ($1,$3) $ TRecord (reverse $2) }
| '_' { at $1 TWild }
atypes :: { [ Type PName ] }
: atype { [ $1 ] }
| atypes atype { $2 : $1 }
dimensions :: { Located [Type PName] }
: '[' type ']' { Located (rComb $1 $3) [ $2 ] }
| dimensions '[' type ']' { at ($1,$4) (fmap ($3 :) $1) }
tuple_types :: { [Type PName] }
: type ',' type { [ $3, $1] }
| tuple_types ',' type { $3 : $1 }
field_type :: { Named (Type PName) }
: ident ':' type { Named { name = $1, value = $3 } }
field_types :: { [Named (Type PName)] }
: field_type { [$1] }
| field_types ',' field_type { $3 : $1 }
ident :: { Located Ident }
: IDENT { let Token (Ident _ str) _ = thing $1
in $1 { thing = mkIdent str } }
| 'x' { Located { srcRange = $1, thing = mkIdent "x" } }
| 'private' { Located { srcRange = $1, thing = mkIdent "private" } }
| 'as' { Located { srcRange = $1, thing = mkIdent "as" } }
| 'hiding' { Located { srcRange = $1, thing = mkIdent "hiding" } }
name :: { LPName }
: ident { fmap mkUnqual $1 }
smodName :: { Located ModName }
: ident { fmap (mkModName . (:[]) . identText) $1 }
| QIDENT { let Token (Ident ns i) _ = thing $1
in mkModName (ns ++ [i]) A.<$ $1 }
modName :: { Located ModName }
: smodName { $1 }
| '`' smodName { fmap paramInstModName $2 }
qname :: { Located PName }
: name { $1 }
| QIDENT { let Token (Ident ns i) _ = thing $1
in mkQual (mkModName ns) (mkIdent i) A.<$ $1 }
help_name :: { Located PName }
: qname { $1 }
| qop { $1 }
| '(' qop ')' { $2 }
{- The types that can come after a back-tick: either a type demotion,
or an explicit type application. Explicit type applications are converted
to records, which cannot be demoted. -}
tick_ty :: { Type PName }
: qname { at $1 $ TUser (thing $1) [] }
| NUM { at $1 $ TNum (getNum $1) }
| '(' type ')' {% validDemotedType (rComb $1 $3) $2 }
| '{' '}' { at ($1,$2) (TRecord []) }
| '{' field_ty_vals '}' { at ($1,$3) (TRecord (reverse $2)) }
| '{' type '}' { anonRecord (getLoc ($1,$3)) [$2] }
| '{' tuple_types '}' { anonRecord (getLoc ($1,$3)) (reverse $2) }
-- This for explicit type applications (e.g., f ` { front = 3 })
field_ty_val :: { Named (Type PName) }
: ident '=' type { Named { name = $1, value = $3 } }
field_ty_vals :: { [Named (Type PName)] }
: field_ty_val { [$1] }
| field_ty_vals ',' field_ty_val { $3 : $1 }
{
parseModName :: String -> Maybe ModName
parseModName txt =
case parseString defaultConfig { cfgModuleScope = False } modName txt of
Right a -> Just (thing a)
Left _ -> Nothing
parseHelpName :: String -> Maybe PName
parseHelpName txt =
case parseString defaultConfig { cfgModuleScope = False } helpName txt of
Right a -> Just (thing a)
Left _ -> Nothing
addImplicitIncludes :: Config -> Program PName -> Program PName
addImplicitIncludes cfg (Program ds) =
Program $ map path (cfgAutoInclude cfg) ++ ds
where path p = Include Located { srcRange = rng, thing = p }
rng = Range { source = cfgSource cfg, from = start, to = start }
parseProgramWith :: Config -> Text -> Either ParseError (Program PName)
parseProgramWith cfg s = case res s of
Left err -> Left err
Right a -> Right (addImplicitIncludes cfg a)
where
res = parse cfg $ case cfgLayout cfg of
Layout -> programLayout
NoLayout -> program
parseModule :: Config -> Text -> Either ParseError (Module PName)
parseModule cfg = parse cfg { cfgModuleScope = True } vmodule
parseProgram :: Layout -> Text -> Either ParseError (Program PName)
parseProgram l = parseProgramWith defaultConfig { cfgLayout = l }
parseExprWith :: Config -> Text -> Either ParseError (Expr PName)
parseExprWith cfg = parse cfg { cfgModuleScope = False } expr
parseExpr :: Text -> Either ParseError (Expr PName)
parseExpr = parseExprWith defaultConfig
parseDeclWith :: Config -> Text -> Either ParseError (Decl PName)
parseDeclWith cfg = parse cfg { cfgModuleScope = False } decl
parseDecl :: Text -> Either ParseError (Decl PName)
parseDecl = parseDeclWith defaultConfig
parseDeclsWith :: Config -> Text -> Either ParseError [Decl PName]
parseDeclsWith cfg = parse cfg { cfgModuleScope = ms } decls'
where (ms, decls') = case cfgLayout cfg of
Layout -> (True, declsLayout)
NoLayout -> (False, decls)
parseDecls :: Text -> Either ParseError [Decl PName]
parseDecls = parseDeclsWith defaultConfig
parseLetDeclWith :: Config -> Text -> Either ParseError (Decl PName)
parseLetDeclWith cfg = parse cfg { cfgModuleScope = False } letDecl
parseLetDecl :: Text -> Either ParseError (Decl PName)
parseLetDecl = parseLetDeclWith defaultConfig
parseReplWith :: Config -> Text -> Either ParseError (ReplInput PName)
parseReplWith cfg = parse cfg { cfgModuleScope = False } repl
parseRepl :: Text -> Either ParseError (ReplInput PName)
parseRepl = parseReplWith defaultConfig
parseSchemaWith :: Config -> Text -> Either ParseError (Schema PName)
parseSchemaWith cfg = parse cfg { cfgModuleScope = False } schema
parseSchema :: Text -> Either ParseError (Schema PName)
parseSchema = parseSchemaWith defaultConfig
-- vim: ft=haskell
}
cryptol-2.8.0/src/Cryptol/Parser/ 0000755 0000000 0000000 00000000000 07346545000 015065 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/Parser/AST.hs 0000644 0000000 0000000 00000105112 07346545000 016050 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Parser.AST
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Parser.AST
( -- * Names
Ident, mkIdent, mkInfix, isInfixIdent, nullIdent, identText
, ModName, modRange
, PName(..), getModName, getIdent, mkUnqual, mkQual
, Named(..)
, Pass(..)
, Assoc(..)
-- * Types
, Schema(..)
, TParam(..)
, Kind(..)
, Type(..)
, Prop(..)
, tsName
, psName
, tsFixity
, psFixity
-- * Declarations
, Module(..)
, Program(..)
, TopDecl(..)
, Decl(..)
, Fixity(..), defaultFixity
, FixityCmp(..), compareFixity
, TySyn(..)
, PropSyn(..)
, Bind(..)
, BindDef(..), LBindDef
, Pragma(..)
, ExportType(..)
, TopLevel(..)
, Import(..), ImportSpec(..)
, Newtype(..)
, PrimType(..)
, ParameterType(..)
, ParameterFun(..)
-- * Interactive
, ReplInput(..)
-- * Expressions
, Expr(..)
, Literal(..), NumInfo(..)
, Match(..)
, Pattern(..)
, Selector(..)
, TypeInst(..)
, UpdField(..)
, UpdHow(..)
-- * Positions
, Located(..)
, LPName, LString, LIdent
, NoPos(..)
-- * Pretty-printing
, cppKind, ppSelector
) where
import Cryptol.Parser.Fixity
import Cryptol.Parser.Name
import Cryptol.Parser.Position
import Cryptol.Parser.Selector
import Cryptol.Utils.Ident
import Cryptol.Utils.PP
import Data.List(intersperse)
import Data.Bits(shiftR)
import Data.Maybe (catMaybes)
import Numeric(showIntAtBase)
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
-- AST -------------------------------------------------------------------------
-- | A name with location information.
type LPName = Located PName
-- | An identifier with location information.
type LIdent = Located Ident
-- | A string with location information.
type LString = Located String
newtype Program name = Program [TopDecl name]
deriving (Show)
-- | A parsed module.
data Module name = Module
{ mName :: Located ModName -- ^ Name of the module
, mInstance :: !(Maybe (Located ModName)) -- ^ Functor to instantiate
-- (if this is a functor instnaces)
, mImports :: [Located Import] -- ^ Imports for the module
, mDecls :: [TopDecl name] -- ^ Declartions for the module
} deriving (Show, Generic, NFData)
modRange :: Module name -> Range
modRange m = rCombs $ catMaybes
[ getLoc (mName m)
, getLoc (mImports m)
, getLoc (mDecls m)
, Just (Range { from = start, to = start, source = "" })
]
data TopDecl name =
Decl (TopLevel (Decl name))
| DPrimType (TopLevel (PrimType name))
| TDNewtype (TopLevel (Newtype name)) -- ^ @newtype T as = t
| Include (Located FilePath) -- ^ @include File@
| DParameterType (ParameterType name) -- ^ @parameter type T : #@
| DParameterConstraint [Located (Prop name)]
-- ^ @parameter type constraint (fin T)@
| DParameterFun (ParameterFun name) -- ^ @parameter someVal : [256]@
deriving (Show, Generic, NFData)
data Decl name = DSignature [Located name] (Schema name)
| DFixity !Fixity [Located name]
| DPragma [Located name] Pragma
| DBind (Bind name)
| DPatBind (Pattern name) (Expr name)
| DType (TySyn name)
| DProp (PropSyn name)
| DLocated (Decl name) Range
deriving (Eq, Show, Generic, NFData, Functor)
-- | A type parameter
data ParameterType name = ParameterType
{ ptName :: Located name -- ^ name of type parameter
, ptKind :: Kind -- ^ kind of parameter
, ptDoc :: Maybe String -- ^ optional documentation
, ptFixity :: Maybe Fixity -- ^ info for infix use
, ptNumber :: !Int -- ^ number of the parameter
} deriving (Eq,Show,Generic,NFData)
-- | A value parameter
data ParameterFun name = ParameterFun
{ pfName :: Located name -- ^ name of value parameter
, pfSchema :: Schema name -- ^ schema for parameter
, pfDoc :: Maybe String -- ^ optional documentation
, pfFixity :: Maybe Fixity -- ^ info for infix use
} deriving (Eq,Show,Generic,NFData)
-- | An import declaration.
data Import = Import { iModule :: !ModName
, iAs :: Maybe ModName
, iSpec :: Maybe ImportSpec
} deriving (Eq, Show, Generic, NFData)
-- | The list of names following an import.
--
-- INVARIANT: All of the 'Name' entries in the list are expected to be
-- unqualified names; the 'QName' or 'NewName' constructors should not be
-- present.
data ImportSpec = Hiding [Ident]
| Only [Ident]
deriving (Eq, Show, Generic, NFData)
-- The 'Maybe Fixity' field is filled in by the NoPat pass.
data TySyn n = TySyn (Located n) (Maybe Fixity) [TParam n] (Type n)
deriving (Eq, Show, Generic, NFData, Functor)
-- The 'Maybe Fixity' field is filled in by the NoPat pass.
data PropSyn n = PropSyn (Located n) (Maybe Fixity) [TParam n] [Prop n]
deriving (Eq, Show, Generic, NFData, Functor)
tsName :: TySyn name -> Located name
tsName (TySyn lqn _ _ _) = lqn
psName :: PropSyn name -> Located name
psName (PropSyn lqn _ _ _) = lqn
tsFixity :: TySyn name -> Maybe Fixity
tsFixity (TySyn _ f _ _) = f
psFixity :: PropSyn name -> Maybe Fixity
psFixity (PropSyn _ f _ _) = f
{- | Bindings. Notes:
* The parser does not associate type signatures and pragmas with
their bindings: this is done in a separate pass, after de-sugaring
pattern bindings. In this way we can associate pragmas and type
signatures with the variables defined by pattern bindings as well.
* Currently, there is no surface syntax for defining monomorphic
bindings (i.e., bindings that will not be automatically generalized
by the type checker. However, they are useful when de-sugaring
patterns.
-}
data Bind name = Bind
{ bName :: Located name -- ^ Defined thing
, bParams :: [Pattern name] -- ^ Parameters
, bDef :: Located (BindDef name) -- ^ Definition
, bSignature :: Maybe (Schema name) -- ^ Optional type sig
, bInfix :: Bool -- ^ Infix operator?
, bFixity :: Maybe Fixity -- ^ Optional fixity info
, bPragmas :: [Pragma] -- ^ Optional pragmas
, bMono :: Bool -- ^ Is this a monomorphic binding
, bDoc :: Maybe String -- ^ Optional doc string
} deriving (Eq, Generic, NFData, Functor, Show)
type LBindDef = Located (BindDef PName)
data BindDef name = DPrim
| DExpr (Expr name)
deriving (Eq, Show, Generic, NFData, Functor)
data Pragma = PragmaNote String
| PragmaProperty
deriving (Eq, Show, Generic, NFData)
data Newtype name = Newtype { nName :: Located name -- ^ Type name
, nParams :: [TParam name] -- ^ Type params
, nBody :: [Named (Type name)] -- ^ Constructor
} deriving (Eq, Show, Generic, NFData)
-- | A declaration for a type with no implementation.
data PrimType name = PrimType { primTName :: Located name
, primTKind :: Located Kind
, primTCts :: ([TParam name], [Prop name])
-- ^ parameters are in the order used
-- by the type constructor.
, primTFixity :: Maybe Fixity
} deriving (Show,Generic,NFData)
-- | Input at the REPL, which can either be an expression or a @let@
-- statement.
data ReplInput name = ExprInput (Expr name)
| LetInput (Decl name)
deriving (Eq, Show)
-- | Export information for a declaration.
data ExportType = Public
| Private
deriving (Eq, Show, Ord, Generic, NFData)
-- | A top-level module declaration.
data TopLevel a = TopLevel { tlExport :: ExportType
, tlDoc :: Maybe (Located String)
, tlValue :: a
}
deriving (Show, Generic, NFData, Functor, Foldable, Traversable)
-- | Infromation about the representation of a numeric constant.
data NumInfo = BinLit Int -- ^ n-digit binary literal
| OctLit Int -- ^ n-digit octal literal
| DecLit -- ^ overloaded decimal literal
| HexLit Int -- ^ n-digit hex literal
| CharLit -- ^ character literal
| PolyLit Int -- ^ polynomial literal
deriving (Eq, Show, Generic, NFData)
-- | Literals.
data Literal = ECNum Integer NumInfo -- ^ @0x10@ (HexLit 2)
| ECString String -- ^ @\"hello\"@
deriving (Eq, Show, Generic, NFData)
data Expr n = EVar n -- ^ @ x @
| ELit Literal -- ^ @ 0x10 @
| ENeg (Expr n) -- ^ @ -1 @
| EComplement (Expr n) -- ^ @ ~1 @
| EGenerate (Expr n) -- ^ @ generate f @
| ETuple [Expr n] -- ^ @ (1,2,3) @
| ERecord [Named (Expr n)] -- ^ @ { x = 1, y = 2 } @
| ESel (Expr n) Selector -- ^ @ e.l @
| EUpd (Maybe (Expr n)) [ UpdField n ] -- ^ @ { r | x = e } @
| EList [Expr n] -- ^ @ [1,2,3] @
| EFromTo (Type n) (Maybe (Type n)) (Type n) (Maybe (Type n))
-- ^ @ [1, 5 .. 117 : t] @
| EInfFrom (Expr n) (Maybe (Expr n))-- ^ @ [1, 3 ...] @
| EComp (Expr n) [[Match n]] -- ^ @ [ 1 | x <- xs ] @
| EApp (Expr n) (Expr n) -- ^ @ f x @
| EAppT (Expr n) [(TypeInst n)] -- ^ @ f `{x = 8}, f`{8} @
| EIf (Expr n) (Expr n) (Expr n) -- ^ @ if ok then e1 else e2 @
| EWhere (Expr n) [Decl n] -- ^ @ 1 + x where { x = 2 } @
| ETyped (Expr n) (Type n) -- ^ @ 1 : [8] @
| ETypeVal (Type n) -- ^ @ `(x + 1)@, @x@ is a type
| EFun [Pattern n] (Expr n) -- ^ @ \\x y -> x @
| ELocated (Expr n) Range -- ^ position annotation
| ESplit (Expr n) -- ^ @ splitAt x @ (Introduced by NoPat)
| EParens (Expr n) -- ^ @ (e) @ (Removed by Fixity)
| EInfix (Expr n) (Located n) Fixity (Expr n)-- ^ @ a + b @ (Removed by Fixity)
deriving (Eq, Show, Generic, NFData, Functor)
data UpdField n = UpdField UpdHow [Located Selector] (Expr n)
-- ^ non-empty list @ x.y = e@
deriving (Eq, Show, Generic, NFData, Functor)
data UpdHow = UpdSet | UpdFun -- ^ Are we setting or updating a field.
deriving (Eq, Show, Generic, NFData)
data TypeInst name = NamedInst (Named (Type name))
| PosInst (Type name)
deriving (Eq, Show, Generic, NFData, Functor)
data Match name = Match (Pattern name) (Expr name) -- ^ p <- e
| MatchLet (Bind name)
deriving (Eq, Show, Generic, NFData, Functor)
data Pattern n = PVar (Located n) -- ^ @ x @
| PWild -- ^ @ _ @
| PTuple [Pattern n] -- ^ @ (x,y,z) @
| PRecord [ Named (Pattern n) ] -- ^ @ { x = (a,b,c), y = z } @
| PList [ Pattern n ] -- ^ @ [ x, y, z ] @
| PTyped (Pattern n) (Type n) -- ^ @ x : [8] @
| PSplit (Pattern n) (Pattern n)-- ^ @ (x # y) @
| PLocated (Pattern n) Range -- ^ Location information
deriving (Eq, Show, Generic, NFData, Functor)
data Named a = Named { name :: Located Ident, value :: a }
deriving (Eq, Show, Foldable, Traversable, Generic, NFData, Functor)
data Schema n = Forall [TParam n] [Prop n] (Type n) (Maybe Range)
deriving (Eq, Show, Generic, NFData, Functor)
data Kind = KProp | KNum | KType | KFun Kind Kind
deriving (Eq, Show, Generic, NFData)
data TParam n = TParam { tpName :: n
, tpKind :: Maybe Kind
, tpRange :: Maybe Range
}
deriving (Eq, Show, Generic, NFData, Functor)
data Type n = TFun (Type n) (Type n) -- ^ @[8] -> [8]@
| TSeq (Type n) (Type n) -- ^ @[8] a@
| TBit -- ^ @Bit@
| TNum Integer -- ^ @10@
| TChar Char -- ^ @'a'@
| TUser n [Type n] -- ^ A type variable or synonym
| TRecord [Named (Type n)]-- ^ @{ x : [8], y : [32] }@
| TTuple [Type n] -- ^ @([8], [32])@
| TWild -- ^ @_@, just some type.
| TLocated (Type n) Range -- ^ Location information
| TParens (Type n) -- ^ @ (ty) @
| TInfix (Type n) (Located n) Fixity (Type n) -- ^ @ ty + ty @
deriving (Eq, Show, Generic, NFData, Functor)
-- | A 'Prop' is a 'Type' that represents a type constraint.
newtype Prop n = CType (Type n)
deriving (Eq, Show, Generic, NFData, Functor)
--------------------------------------------------------------------------------
-- Note: When an explicit location is missing, we could use the sub-components
-- to try to estimate a location...
instance AddLoc (Expr n) where
addLoc = ELocated
dropLoc (ELocated e _) = dropLoc e
dropLoc e = e
instance HasLoc (Expr name) where
getLoc (ELocated _ r) = Just r
getLoc _ = Nothing
instance HasLoc (TParam name) where
getLoc (TParam _ _ r) = r
instance AddLoc (TParam name) where
addLoc (TParam a b _) l = TParam a b (Just l)
dropLoc (TParam a b _) = TParam a b Nothing
instance HasLoc (Type name) where
getLoc (TLocated _ r) = Just r
getLoc _ = Nothing
instance AddLoc (Type name) where
addLoc = TLocated
dropLoc (TLocated e _) = dropLoc e
dropLoc e = e
instance AddLoc (Pattern name) where
addLoc = PLocated
dropLoc (PLocated e _) = dropLoc e
dropLoc e = e
instance HasLoc (Pattern name) where
getLoc (PLocated _ r) = Just r
getLoc (PTyped r _) = getLoc r
getLoc (PVar x) = getLoc x
getLoc _ = Nothing
instance HasLoc (Bind name) where
getLoc b = getLoc (bName b, bDef b)
instance HasLoc (Match name) where
getLoc (Match p e) = getLoc (p,e)
getLoc (MatchLet b) = getLoc b
instance HasLoc a => HasLoc (Named a) where
getLoc l = getLoc (name l, value l)
instance HasLoc (Schema name) where
getLoc (Forall _ _ _ r) = r
instance AddLoc (Schema name) where
addLoc (Forall xs ps t _) r = Forall xs ps t (Just r)
dropLoc (Forall xs ps t _) = Forall xs ps t Nothing
instance HasLoc (Decl name) where
getLoc (DLocated _ r) = Just r
getLoc _ = Nothing
instance AddLoc (Decl name) where
addLoc d r = DLocated d r
dropLoc (DLocated d _) = dropLoc d
dropLoc d = d
instance HasLoc a => HasLoc (TopLevel a) where
getLoc = getLoc . tlValue
instance HasLoc (TopDecl name) where
getLoc td = case td of
Decl tld -> getLoc tld
DPrimType pt -> getLoc pt
TDNewtype n -> getLoc n
Include lfp -> getLoc lfp
DParameterType d -> getLoc d
DParameterFun d -> getLoc d
DParameterConstraint d -> getLoc d
instance HasLoc (PrimType name) where
getLoc pt = Just (rComb (srcRange (primTName pt)) (srcRange (primTKind pt)))
instance HasLoc (ParameterType name) where
getLoc a = getLoc (ptName a)
instance HasLoc (ParameterFun name) where
getLoc a = getLoc (pfName a)
instance HasLoc (Module name) where
getLoc m
| null locs = Nothing
| otherwise = Just (rCombs locs)
where
locs = catMaybes [ getLoc (mName m)
, getLoc (mImports m)
, getLoc (mDecls m)
]
instance HasLoc (Newtype name) where
getLoc n
| null locs = Nothing
| otherwise = Just (rCombs locs)
where
locs = catMaybes [ getLoc (nName n), getLoc (nBody n) ]
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- Pretty printing
ppL :: PP a => Located a -> Doc
ppL = pp . thing
ppNamed :: PP a => String -> Named a -> Doc
ppNamed s x = ppL (name x) <+> text s <+> pp (value x)
instance (Show name, PPName name) => PP (Module name) where
ppPrec _ m = text "module" <+> ppL (mName m) <+> text "where"
$$ vcat (map ppL (mImports m))
$$ vcat (map pp (mDecls m))
instance (Show name, PPName name) => PP (Program name) where
ppPrec _ (Program ds) = vcat (map pp ds)
instance (Show name, PPName name) => PP (TopDecl name) where
ppPrec _ top_decl =
case top_decl of
Decl d -> pp d
DPrimType p -> pp p
TDNewtype n -> pp n
Include l -> text "include" <+> text (show (thing l))
DParameterFun d -> pp d
DParameterType d -> pp d
DParameterConstraint d ->
"parameter" <+> "type" <+> "constraint" <+> prop
where prop = case map pp d of
[x] -> x
[] -> "()"
xs -> parens (hsep (punctuate comma xs))
instance (Show name, PPName name) => PP (PrimType name) where
ppPrec _ pt =
"primitive" <+> "type" <+> pp (primTName pt) <+> ":" <+> pp (primTKind pt)
instance (Show name, PPName name) => PP (ParameterType name) where
ppPrec _ a = text "parameter" <+> text "type" <+>
ppPrefixName (ptName a) <+> text ":" <+> pp (ptKind a)
instance (Show name, PPName name) => PP (ParameterFun name) where
ppPrec _ a = text "parameter" <+> ppPrefixName (pfName a) <+> text ":"
<+> pp (pfSchema a)
instance (Show name, PPName name) => PP (Decl name) where
ppPrec n decl =
case decl of
DSignature xs s -> commaSep (map ppL xs) <+> text ":" <+> pp s
DPatBind p e -> pp p <+> text "=" <+> pp e
DBind b -> ppPrec n b
DFixity f ns -> ppFixity f ns
DPragma xs p -> ppPragma xs p
DType ts -> ppPrec n ts
DProp ps -> ppPrec n ps
DLocated d _ -> ppPrec n d
ppFixity :: PPName name => Fixity -> [Located name] -> Doc
ppFixity (Fixity LeftAssoc i) ns = text "infixl" <+> int i <+> commaSep (map pp ns)
ppFixity (Fixity RightAssoc i) ns = text "infixr" <+> int i <+> commaSep (map pp ns)
ppFixity (Fixity NonAssoc i) ns = text "infix" <+> int i <+> commaSep (map pp ns)
instance PPName name => PP (Newtype name) where
ppPrec _ nt = hsep
[ text "newtype", ppL (nName nt), hsep (map pp (nParams nt)), char '='
, braces (commaSep (map (ppNamed ":") (nBody nt))) ]
instance PP Import where
ppPrec _ d = text "import" <+> sep [ pp (iModule d), mbAs, mbSpec ]
where
mbAs = maybe empty (\ name -> text "as" <+> pp name ) (iAs d)
mbSpec = maybe empty pp (iSpec d)
instance PP ImportSpec where
ppPrec _ s = case s of
Hiding names -> text "hiding" <+> parens (commaSep (map pp names))
Only names -> parens (commaSep (map pp names))
-- TODO: come up with a good way of showing the export specification here
instance PP a => PP (TopLevel a) where
ppPrec _ tl = pp (tlValue tl)
instance PP Pragma where
ppPrec _ (PragmaNote x) = text x
ppPrec _ PragmaProperty = text "property"
ppPragma :: PPName name => [Located name] -> Pragma -> Doc
ppPragma xs p =
text "/*" <+> text "pragma" <+> commaSep (map ppL xs) <+> text ":" <+> pp p
<+> text "*/"
instance (Show name, PPName name) => PP (Bind name) where
ppPrec _ b = sig $$ vcat [ ppPragma [f] p | p <- bPragmas b ] $$
hang (def <+> eq) 4 (pp (thing (bDef b)))
where def | bInfix b = lhsOp
| otherwise = lhs
f = bName b
sig = case bSignature b of
Nothing -> empty
Just s -> pp (DSignature [f] s)
eq = if bMono b then text ":=" else text "="
lhs = ppL f <+> fsep (map (ppPrec 3) (bParams b))
lhsOp = case bParams b of
[x,y] -> pp x <+> ppL f <+> pp y
xs -> parens (parens (ppL f) <+> fsep (map (ppPrec 0) xs))
-- _ -> panic "AST" [ "Malformed infix operator", show b ]
instance (Show name, PPName name) => PP (BindDef name) where
ppPrec _ DPrim = text ""
ppPrec p (DExpr e) = ppPrec p e
instance PPName name => PP (TySyn name) where
ppPrec _ (TySyn x _ xs t) =
text "type" <+> ppL x <+> fsep (map (ppPrec 1) xs)
<+> text "=" <+> pp t
instance PPName name => PP (PropSyn name) where
ppPrec _ (PropSyn x _ xs ps) =
text "constraint" <+> ppL x <+> fsep (map (ppPrec 1) xs)
<+> text "=" <+> parens (commaSep (map pp ps))
instance PP Literal where
ppPrec _ lit =
case lit of
ECNum n i -> ppNumLit n i
ECString s -> text (show s)
ppNumLit :: Integer -> NumInfo -> Doc
ppNumLit n info =
case info of
DecLit -> integer n
CharLit -> text (show (toEnum (fromInteger n) :: Char))
BinLit w -> pad 2 "0b" w
OctLit w -> pad 8 "0o" w
HexLit w -> pad 16 "0x" w
PolyLit w -> text "<|" <+> poly w <+> text "|>"
where
pad base pref w =
let txt = showIntAtBase base ("0123456789abcdef" !!) n ""
in text pref <.> text (replicate (w - length txt) '0') <.> text txt
poly w = let (res,deg) = bits Nothing [] 0 n
z | w == 0 = []
| Just d <- deg, d + 1 == w = []
| otherwise = [polyTerm0 (w-1)]
in fsep $ intersperse (text "+") $ z ++ map polyTerm res
polyTerm 0 = text "1"
polyTerm 1 = text "x"
polyTerm p = text "x" <.> text "^^" <.> int p
polyTerm0 0 = text "0"
polyTerm0 p = text "0" <.> text "*" <.> polyTerm p
bits d res p num
| num == 0 = (res,d)
| even num = bits d res (p + 1) (num `shiftR` 1)
| otherwise = bits (Just p) (p : res) (p + 1) (num `shiftR` 1)
wrap :: Int -> Int -> Doc -> Doc
wrap contextPrec myPrec doc = if myPrec < contextPrec then parens doc else doc
isEApp :: Expr n -> Maybe (Expr n, Expr n)
isEApp (ELocated e _) = isEApp e
isEApp (EApp e1 e2) = Just (e1,e2)
isEApp _ = Nothing
asEApps :: Expr n -> (Expr n, [Expr n])
asEApps expr = go expr []
where go e es = case isEApp e of
Nothing -> (e, es)
Just (e1, e2) -> go e1 (e2 : es)
instance PPName name => PP (TypeInst name) where
ppPrec _ (PosInst t) = pp t
ppPrec _ (NamedInst x) = ppNamed "=" x
{- Precedences:
0: lambda, if, where, type annotation
2: infix expression (separate precedence table)
3: application, prefix expressions
-}
instance (Show name, PPName name) => PP (Expr name) where
-- Wrap if top level operator in expression is less than `n`
ppPrec n expr =
case expr of
-- atoms
EVar x -> ppPrefixName x
ELit x -> pp x
ENeg x -> wrap n 3 (text "-" <.> ppPrec 4 x)
EComplement x -> wrap n 3 (text "~" <.> ppPrec 4 x)
EGenerate x -> wrap n 3 (text "generate" <+> ppPrec 4 x)
ETuple es -> parens (commaSep (map pp es))
ERecord fs -> braces (commaSep (map (ppNamed "=") fs))
EList es -> brackets (commaSep (map pp es))
EFromTo e1 e2 e3 t1 -> brackets (pp e1 <.> step <+> text ".." <+> end)
where step = maybe empty (\e -> comma <+> pp e) e2
end = maybe (pp e3) (\t -> pp e3 <+> colon <+> pp t) t1
EInfFrom e1 e2 -> brackets (pp e1 <.> step <+> text "...")
where step = maybe empty (\e -> comma <+> pp e) e2
EComp e mss -> brackets (pp e <+> vcat (map arm mss))
where arm ms = text "|" <+> commaSep (map pp ms)
EUpd mb fs -> braces (hd <+> "|" <+> commaSep (map pp fs))
where hd = maybe "_" pp mb
ETypeVal t -> text "`" <.> ppPrec 5 t -- XXX
EAppT e ts -> ppPrec 4 e <.> text "`" <.> braces (commaSep (map pp ts))
ESel e l -> ppPrec 4 e <.> text "." <.> pp l
-- low prec
EFun xs e -> wrap n 0 ((text "\\" <.> hsep (map (ppPrec 3) xs)) <+>
text "->" <+> pp e)
EIf e1 e2 e3 -> wrap n 0 $ sep [ text "if" <+> pp e1
, text "then" <+> pp e2
, text "else" <+> pp e3 ]
ETyped e t -> wrap n 0 (ppPrec 2 e <+> text ":" <+> pp t)
EWhere e ds -> wrap n 0 (pp e
$$ text "where"
$$ nest 2 (vcat (map pp ds))
$$ text "")
-- infix applications
_ | Just ifix <- isInfix expr ->
optParens (n > 2)
$ ppInfix 2 isInfix ifix
EApp _ _ -> let (e, es) = asEApps expr in
wrap n 3 (ppPrec 3 e <+> fsep (map (ppPrec 4) es))
ELocated e _ -> ppPrec n e
ESplit e -> wrap n 3 (text "splitAt" <+> ppPrec 4 e)
EParens e -> parens (pp e)
EInfix e1 op _ e2 -> wrap n 0 (pp e1 <+> ppInfixName (thing op) <+> pp e2)
where
isInfix (EApp (EApp (EVar ieOp) ieLeft) ieRight) = do
(ieAssoc,iePrec) <- ppNameFixity ieOp
return Infix { .. }
isInfix _ = Nothing
instance (Show name, PPName name) => PP (UpdField name) where
ppPrec _ (UpdField h xs e) = ppNestedSels (map thing xs) <+> pp h <+> pp e
instance PP UpdHow where
ppPrec _ h = case h of
UpdSet -> "="
UpdFun -> "->"
instance PPName name => PP (Pattern name) where
ppPrec n pat =
case pat of
PVar x -> pp (thing x)
PWild -> char '_'
PTuple ps -> parens (commaSep (map pp ps))
PRecord fs -> braces (commaSep (map (ppNamed "=") fs))
PList ps -> brackets (commaSep (map pp ps))
PTyped p t -> wrap n 0 (ppPrec 1 p <+> text ":" <+> pp t)
PSplit p1 p2 -> wrap n 1 (ppPrec 1 p1 <+> text "#" <+> ppPrec 1 p2)
PLocated p _ -> ppPrec n p
instance (Show name, PPName name) => PP (Match name) where
ppPrec _ (Match p e) = pp p <+> text "<-" <+> pp e
ppPrec _ (MatchLet b) = pp b
instance PPName name => PP (Schema name) where
ppPrec _ (Forall xs ps t _) = sep [vars <+> preds, pp t]
where vars = case xs of
[] -> empty
_ -> braces (commaSep (map pp xs))
preds = case ps of
[] -> empty
_ -> parens (commaSep (map pp ps)) <+> text "=>"
instance PP Kind where
ppPrec _ KType = text "*"
ppPrec _ KNum = text "#"
ppPrec _ KProp = text "@"
ppPrec n (KFun k1 k2) = wrap n 1 (ppPrec 1 k1 <+> "->" <+> ppPrec 0 k2)
-- | "Conversational" printing of kinds (e.g., to use in error messages)
cppKind :: Kind -> Doc
cppKind KType = text "a value type"
cppKind KNum = text "a numeric type"
cppKind KProp = text "a constraint type"
cppKind (KFun {}) = text "a type-constructor type"
instance PPName name => PP (TParam name) where
ppPrec n (TParam p Nothing _) = ppPrec n p
ppPrec n (TParam p (Just k) _) = wrap n 1 (pp p <+> text ":" <+> pp k)
-- 4: atomic type expression
-- 3: [_]t or application
-- 2: infix type
-- 1: function type
instance PPName name => PP (Type name) where
ppPrec n ty =
case ty of
TWild -> text "_"
TTuple ts -> parens $ commaSep $ map pp ts
TRecord fs -> braces $ commaSep $ map (ppNamed ":") fs
TBit -> text "Bit"
TNum x -> integer x
TChar x -> text (show x)
TSeq t1 TBit -> brackets (pp t1)
TSeq t1 t2 -> optParens (n > 3)
$ brackets (pp t1) <.> ppPrec 3 t2
TUser f [] -> ppPrefixName f
TUser f ts -> optParens (n > 3)
$ ppPrefixName f <+> fsep (map (ppPrec 4) ts)
TFun t1 t2 -> optParens (n > 1)
$ sep [ppPrec 2 t1 <+> text "->", ppPrec 1 t2]
TLocated t _ -> ppPrec n t
TParens t -> parens (pp t)
TInfix t1 o _ t2 -> optParens (n > 2)
$ sep [ppPrec 2 t1 <+> ppInfixName o, ppPrec 3 t2]
instance PPName name => PP (Prop name) where
ppPrec n (CType t) = ppPrec n t
--------------------------------------------------------------------------------
-- Drop all position information, so equality reflects program structure
class NoPos t where
noPos :: t -> t
-- WARNING: This does not call `noPos` on the `thing` inside
instance NoPos (Located t) where
noPos x = x { srcRange = rng }
where rng = Range { from = Position 0 0, to = Position 0 0, source = "" }
instance NoPos t => NoPos (Named t) where
noPos t = Named { name = noPos (name t), value = noPos (value t) }
instance NoPos t => NoPos [t] where noPos = fmap noPos
instance NoPos t => NoPos (Maybe t) where noPos = fmap noPos
instance NoPos (Program name) where
noPos (Program x) = Program (noPos x)
instance NoPos (Module name) where
noPos m = Module { mName = mName m
, mInstance = mInstance m
, mImports = noPos (mImports m)
, mDecls = noPos (mDecls m)
}
instance NoPos (TopDecl name) where
noPos decl =
case decl of
Decl x -> Decl (noPos x)
DPrimType t -> DPrimType (noPos t)
TDNewtype n -> TDNewtype(noPos n)
Include x -> Include (noPos x)
DParameterFun d -> DParameterFun (noPos d)
DParameterType d -> DParameterType (noPos d)
DParameterConstraint d -> DParameterConstraint (noPos d)
instance NoPos (PrimType name) where
noPos x = x
instance NoPos (ParameterType name) where
noPos a = a
instance NoPos (ParameterFun x) where
noPos x = x { pfSchema = noPos (pfSchema x) }
instance NoPos a => NoPos (TopLevel a) where
noPos tl = tl { tlValue = noPos (tlValue tl) }
instance NoPos (Decl name) where
noPos decl =
case decl of
DSignature x y -> DSignature (noPos x) (noPos y)
DPragma x y -> DPragma (noPos x) (noPos y)
DPatBind x y -> DPatBind (noPos x) (noPos y)
DFixity f ns -> DFixity f (noPos ns)
DBind x -> DBind (noPos x)
DType x -> DType (noPos x)
DProp x -> DProp (noPos x)
DLocated x _ -> noPos x
instance NoPos (Newtype name) where
noPos n = Newtype { nName = noPos (nName n)
, nParams = nParams n
, nBody = noPos (nBody n)
}
instance NoPos (Bind name) where
noPos x = Bind { bName = noPos (bName x)
, bParams = noPos (bParams x)
, bDef = noPos (bDef x)
, bSignature = noPos (bSignature x)
, bInfix = bInfix x
, bFixity = bFixity x
, bPragmas = noPos (bPragmas x)
, bMono = bMono x
, bDoc = bDoc x
}
instance NoPos Pragma where
noPos p@(PragmaNote {}) = p
noPos p@(PragmaProperty) = p
instance NoPos (TySyn name) where
noPos (TySyn x f y z) = TySyn (noPos x) f (noPos y) (noPos z)
instance NoPos (PropSyn name) where
noPos (PropSyn x f y z) = PropSyn (noPos x) f (noPos y) (noPos z)
instance NoPos (Expr name) where
noPos expr =
case expr of
EVar x -> EVar x
ELit x -> ELit x
ENeg x -> ENeg (noPos x)
EComplement x -> EComplement (noPos x)
EGenerate x -> EGenerate (noPos x)
ETuple x -> ETuple (noPos x)
ERecord x -> ERecord (noPos x)
ESel x y -> ESel (noPos x) y
EUpd x y -> EUpd (noPos x) (noPos y)
EList x -> EList (noPos x)
EFromTo x y z t -> EFromTo (noPos x) (noPos y) (noPos z) (noPos t)
EInfFrom x y -> EInfFrom (noPos x) (noPos y)
EComp x y -> EComp (noPos x) (noPos y)
EApp x y -> EApp (noPos x) (noPos y)
EAppT x y -> EAppT (noPos x) (noPos y)
EIf x y z -> EIf (noPos x) (noPos y) (noPos z)
EWhere x y -> EWhere (noPos x) (noPos y)
ETyped x y -> ETyped (noPos x) (noPos y)
ETypeVal x -> ETypeVal (noPos x)
EFun x y -> EFun (noPos x) (noPos y)
ELocated x _ -> noPos x
ESplit x -> ESplit (noPos x)
EParens e -> EParens (noPos e)
EInfix x y f z -> EInfix (noPos x) y f (noPos z)
instance NoPos (UpdField name) where
noPos (UpdField h xs e) = UpdField h xs (noPos e)
instance NoPos (TypeInst name) where
noPos (PosInst ts) = PosInst (noPos ts)
noPos (NamedInst fs) = NamedInst (noPos fs)
instance NoPos (Match name) where
noPos (Match x y) = Match (noPos x) (noPos y)
noPos (MatchLet b) = MatchLet (noPos b)
instance NoPos (Pattern name) where
noPos pat =
case pat of
PVar x -> PVar (noPos x)
PWild -> PWild
PTuple x -> PTuple (noPos x)
PRecord x -> PRecord (noPos x)
PList x -> PList (noPos x)
PTyped x y -> PTyped (noPos x) (noPos y)
PSplit x y -> PSplit (noPos x) (noPos y)
PLocated x _ -> noPos x
instance NoPos (Schema name) where
noPos (Forall x y z _) = Forall (noPos x) (noPos y) (noPos z) Nothing
instance NoPos (TParam name) where
noPos (TParam x y _) = TParam x y Nothing
instance NoPos (Type name) where
noPos ty =
case ty of
TWild -> TWild
TUser x y -> TUser x (noPos y)
TRecord x -> TRecord (noPos x)
TTuple x -> TTuple (noPos x)
TFun x y -> TFun (noPos x) (noPos y)
TSeq x y -> TSeq (noPos x) (noPos y)
TBit -> TBit
TNum n -> TNum n
TChar n -> TChar n
TLocated x _ -> noPos x
TParens x -> TParens (noPos x)
TInfix x y f z-> TInfix (noPos x) y f (noPos z)
instance NoPos (Prop name) where
noPos (CType t) = CType (noPos t)
cryptol-2.8.0/src/Cryptol/Parser/Fixity.hs 0000644 0000000 0000000 00000002400 07346545000 016671 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Parser.Fixity
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.Parser.Fixity
( Fixity(..)
, defaultFixity
, FixityCmp(..)
, compareFixity
) where
import Cryptol.Utils.PP
import GHC.Generics (Generic)
import Control.DeepSeq
data Fixity = Fixity { fAssoc :: !Assoc
, fLevel :: !Int
} deriving (Eq, Generic, NFData, Show)
data FixityCmp = FCError
| FCLeft
| FCRight
deriving (Show, Eq)
compareFixity :: Fixity -> Fixity -> FixityCmp
compareFixity (Fixity a1 p1) (Fixity a2 p2) =
case compare p1 p2 of
GT -> FCLeft
LT -> FCRight
EQ -> case (a1, a2) of
(LeftAssoc, LeftAssoc) -> FCLeft
(RightAssoc, RightAssoc) -> FCRight
_ -> FCError
-- | The fixity used when none is provided.
defaultFixity :: Fixity
defaultFixity = Fixity LeftAssoc 100
instance PP Fixity where
ppPrec _ (Fixity assoc level) =
text "precedence" <+> int level <.> comma <+> pp assoc
cryptol-2.8.0/src/Cryptol/Parser/Lexer.x 0000644 0000000 0000000 00000020125 07346545000 016335 0 ustar 00 0000000 0000000 {
-- |
-- Module : Cryptol.Parser.Lexer
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- At present Alex generates code with too many warnings.
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -w #-}
module Cryptol.Parser.Lexer
( primLexer, lexer, Layout(..)
, Token(..), TokenT(..)
, TokenV(..), TokenKW(..), TokenErr(..), TokenSym(..), TokenW(..)
, Located(..)
, Config(..)
, defaultConfig
) where
import Cryptol.Parser.Position
import Cryptol.Parser.LexerUtils
import Cryptol.Parser.Unlit(unLit)
import Data.Text (Text)
import qualified Data.Text as Text
}
$uniupper = \x1
$unilower = \x2
$unidigit = \x3
$unisymbol = \x4
$unispace = \x5
$uniother = \x6
$unitick = \x7
@id_first = [a-zA-Z_] | $unilower | $uniupper
@id_next = [a-zA-Z0-9_'] | $unilower | $uniupper | $unidigit | $unitick
@id = @id_first @id_next*
@op = ([\!\#\$\%\&\*\+\-\.\/\:\<\=\>\?\@\\\^\|\~] | $unisymbol)+
@qual = (@id ::)+
@qual_id = @qual @id
@qual_op = @qual @op
@num2 = "0b" (_*[0-1])+
@num8 = "0o" (_*[0-7])+
@num10 = [0-9](_*[0-9])*
@num16 = "0x" (_*[0-9A-Fa-f])+
@strPart = [^\\\"]+
@chrPart = [^\\\']+
:-
<0,comment> {
\/\* { startComment False }
\/\*\* { startComment True }
\/\*\*\*+ { startComment False }
\/\*+\/ { startEndComment }
}
{
\*+\/ { endComment }
[^\*\/]+ { addToComment }
\* { addToComment }
\/ { addToComment }
\n { addToComment }
}
{
@strPart { addToString }
\" { endString }
\\. { addToString }
\n { endString }
}
{
@chrPart { addToChar }
\' { endChar }
\\. { addToChar }
\n { endChar }
}
<0> {
$white+ { emit $ White Space }
"//" .* { emit $ White LineComment }
@qual_id { mkQualIdent }
@qual_op { mkQualOp }
-- Please update the docs, if you add new entries.
"else" { emit $ KW KW_else }
"extern" { emit $ KW KW_extern }
"if" { emit $ KW KW_if }
"private" { emit $ KW KW_private }
"include" { emit $ KW KW_include }
"module" { emit $ KW KW_module }
"newtype" { emit $ KW KW_newtype }
"pragma" { emit $ KW KW_pragma }
"property" { emit $ KW KW_property }
"then" { emit $ KW KW_then }
"type" { emit $ KW KW_type }
"where" { emit $ KW KW_where }
"let" { emit $ KW KW_let }
"x" { emit $ KW KW_x }
"import" { emit $ KW KW_import }
"as" { emit $ KW KW_as }
"hiding" { emit $ KW KW_hiding }
"newtype" { emit $ KW KW_newtype }
"infixl" { emit $ KW KW_infixl }
"infixr" { emit $ KW KW_infixr }
"infix" { emit $ KW KW_infix }
"primitive" { emit $ KW KW_primitive }
"parameter" { emit $ KW KW_parameter }
"constraint" { emit $ KW KW_constraint }
"Prop" { emit $ KW KW_Prop }
@num2 { emitS (numToken 2 . Text.drop 2) }
@num8 { emitS (numToken 8 . Text.drop 2) }
@num10 { emitS (numToken 10 . Text.drop 0) }
@num16 { emitS (numToken 16 . Text.drop 2) }
"_" { emit $ Sym Underscore }
@id { mkIdent }
"\" { emit $ Sym Lambda }
"->" { emit $ Sym ArrR }
"<-" { emit $ Sym ArrL }
"=>" { emit $ Sym FatArrR }
"=" { emit $ Sym EqDef }
"," { emit $ Sym Comma }
";" { emit $ Sym Semi }
"." { emit $ Sym Dot }
":" { emit $ Sym Colon }
"`" { emit $ Sym BackTick }
".." { emit $ Sym DotDot }
"..." { emit $ Sym DotDotDot }
"|" { emit $ Sym Bar }
"(" { emit $ Sym ParenL }
")" { emit $ Sym ParenR }
"[" { emit $ Sym BracketL }
"]" { emit $ Sym BracketR }
"{" { emit $ Sym CurlyL }
"}" { emit $ Sym CurlyR }
"<|" { emit $ Sym TriL }
"|>" { emit $ Sym TriR }
\" { startString }
\' { startChar }
-- special cases for types and kinds
"+" { emit (Op Plus ) }
"-" { emit (Op Minus) }
"*" { emit (Op Mul ) }
"^^" { emit (Op Exp ) }
-- hash is used as a kind, and as a pattern
"#" { emit (Op Hash ) }
-- at-sign is used in declaration bindings
"@" { emit (Op At ) }
-- ~ is used for unary complement
"~" { emit (Op Complement) }
-- all other operators
@op { emitS (Op . Other []) }
}
{
-- This code is here because it depends on `comment`, which is defined
-- in this file.
stateToInt :: LexS -> Int
stateToInt Normal = 0
stateToInt (InComment {}) = comment
stateToInt (InString {}) = string
stateToInt (InChar {}) = char
-- | Returns the tokens in the last position of the input that we processed.
-- White space is removed, and layout processing is done as requested.
-- This stream is fed to the parser.
lexer :: Config -> Text -> ([Located Token], Position)
lexer cfg cs = ( case cfgLayout cfg of
Layout -> layout cfg lexemes
NoLayout -> lexemes
, finalPos
)
where (lex0, finalPos) = primLexer cfg cs
lexemes = dropWhite lex0
-- | Returns the tokens and the last position of the input that we processed.
-- The tokens include whte space tokens.
primLexer :: Config -> Text -> ([Located Token], Position)
primLexer cfg cs = run inp Normal
where
inp = Inp { alexPos = start
, alexInputPrevChar = '\n'
, input = unLit (cfgPreProc cfg) cs }
singleR p = Range p p (cfgSource cfg)
eofR p = Range p' p' (cfgSource cfg)
where
p' = Position { line = line p + 1, col = 0 }
run i s =
case alexScan i (stateToInt s) of
AlexEOF ->
case s of
Normal -> ([ Located (eofR $ alexPos i) (Token EOF "end of file") ]
, alexPos i
)
InComment _ p _ _ ->
( [ Located (singleR p)
$ Token (Err UnterminatedComment) "unterminated comment"
]
, alexPos i)
InString p _ ->
( [ Located (singleR p)
$ Token (Err UnterminatedString) "unterminated string"
]
, alexPos i)
InChar p _ ->
( [ Located (singleR p)
$ Token (Err UnterminatedChar) "unterminated character"
]
, alexPos i)
AlexError i' ->
let bad = Text.take 1 (input i)
in
( [ Located (Range (alexPos i) (alexPos i') (cfgSource cfg))
$ Token (Err LexicalError) bad ]
, alexPos i')
AlexSkip i' _ -> run i' s
AlexToken i' l act ->
let txt = Text.take l (input i)
(mtok,s') = act cfg (alexPos i) txt s
(rest,pos) = run i' $! s'
in case mtok of
Nothing -> (rest, pos)
Just t -> (t : rest, pos)
-- vim: ft=haskell
}
cryptol-2.8.0/src/Cryptol/Parser/LexerUtils.hs 0000644 0000000 0000000 00000041531 07346545000 017525 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Parser.LexerUtils
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
module Cryptol.Parser.LexerUtils where
import Cryptol.Parser.Position
import Cryptol.Parser.Unlit(PreProc(None))
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
import Data.Char(toLower,generalCategory,isAscii,ord,isSpace)
import qualified Data.Char as Char
import Data.Text(Text)
import qualified Data.Text as T
import Data.Word(Word8)
import GHC.Generics (Generic)
import Control.DeepSeq
data Config = Config
{ cfgSource :: !FilePath -- ^ File that we are working on
, cfgLayout :: !Layout -- ^ Settings for layout processing
, cfgPreProc :: PreProc -- ^ Preprocessor settings
, cfgAutoInclude :: [FilePath] -- ^ Implicit includes
, cfgModuleScope :: Bool -- ^ When we do layout processing
-- should we add a vCurly (i.e., are
-- we parsing a list of things).
}
defaultConfig :: Config
defaultConfig = Config
{ cfgSource = ""
, cfgLayout = Layout
, cfgPreProc = None
, cfgAutoInclude = []
, cfgModuleScope = True
}
type Action = Config -> Position -> Text -> LexS
-> (Maybe (Located Token), LexS)
data LexS = Normal
| InComment Bool Position ![Position] [Text]
| InString Position Text
| InChar Position Text
startComment :: Bool -> Action
startComment isDoc _ p txt s = (Nothing, InComment d p stack chunks)
where (d,stack,chunks) = case s of
Normal -> (isDoc, [], [txt])
InComment doc q qs cs -> (doc, q : qs, txt : cs)
_ -> panic "[Lexer] startComment" ["in a string"]
endComment :: Action
endComment cfg p txt s =
case s of
InComment d f [] cs -> (Just (mkToken d f cs), Normal)
InComment d _ (q:qs) cs -> (Nothing, InComment d q qs (txt : cs))
_ -> panic "[Lexer] endComment" ["outside comment"]
where
mkToken isDoc f cs =
let r = Range { from = f, to = moves p txt, source = cfgSource cfg }
str = T.concat $ reverse $ txt : cs
tok = if isDoc then DocStr else BlockComment
in Located { srcRange = r, thing = Token (White tok) str }
addToComment :: Action
addToComment _ _ txt s = (Nothing, InComment doc p stack (txt : chunks))
where
(doc, p, stack, chunks) =
case s of
InComment d q qs cs -> (d,q,qs,cs)
_ -> panic "[Lexer] addToComment" ["outside comment"]
startEndComment :: Action
startEndComment cfg p txt s =
case s of
Normal -> (Just tok, Normal)
where tok = Located
{ srcRange = Range { from = p
, to = moves p txt
, source = cfgSource cfg
}
, thing = Token (White BlockComment) txt
}
InComment d p1 ps cs -> (Nothing, InComment d p1 ps (txt : cs))
_ -> panic "[Lexer] startEndComment" ["in string or char?"]
startString :: Action
startString _ p txt _ = (Nothing,InString p txt)
endString :: Action
endString cfg pe txt s = case s of
InString ps str -> (Just (mkToken ps str), Normal)
_ -> panic "[Lexer] endString" ["outside string"]
where
parseStr s1 = case reads s1 of
[(cs, "")] -> StrLit cs
_ -> Err InvalidString
mkToken ps str = Located { srcRange = Range
{ from = ps
, to = moves pe txt
, source = cfgSource cfg
}
, thing = Token
{ tokenType = parseStr (T.unpack tokStr)
, tokenText = tokStr
}
}
where
tokStr = str `T.append` txt
addToString :: Action
addToString _ _ txt s = case s of
InString p str -> (Nothing,InString p (str `T.append` txt))
_ -> panic "[Lexer] addToString" ["outside string"]
startChar :: Action
startChar _ p txt _ = (Nothing,InChar p txt)
endChar :: Action
endChar cfg pe txt s =
case s of
InChar ps str -> (Just (mkToken ps str), Normal)
_ -> panic "[Lexer] endString" ["outside character"]
where
parseChar s1 = case reads s1 of
[(cs, "")] -> ChrLit cs
_ -> Err InvalidChar
mkToken ps str = Located { srcRange = Range
{ from = ps
, to = moves pe txt
, source = cfgSource cfg
}
, thing = Token
{ tokenType = parseChar (T.unpack tokStr)
, tokenText = tokStr
}
}
where
tokStr = str `T.append` txt
addToChar :: Action
addToChar _ _ txt s = case s of
InChar p str -> (Nothing,InChar p (str `T.append` txt))
_ -> panic "[Lexer] addToChar" ["outside character"]
mkIdent :: Action
mkIdent cfg p s z = (Just Located { srcRange = r, thing = Token t s }, z)
where
r = Range { from = p, to = moves p s, source = cfgSource cfg }
t = Ident [] s
mkQualIdent :: Action
mkQualIdent cfg p s z = (Just Located { srcRange = r, thing = Token t s}, z)
where
r = Range { from = p, to = moves p s, source = cfgSource cfg }
t = Ident ns i
(ns,i) = splitQual s
mkQualOp :: Action
mkQualOp cfg p s z = (Just Located { srcRange = r, thing = Token t s}, z)
where
r = Range { from = p, to = moves p s, source = cfgSource cfg }
t = Op (Other ns i)
(ns,i) = splitQual s
emit :: TokenT -> Action
emit t cfg p s z = (Just Located { srcRange = r, thing = Token t s }, z)
where r = Range { from = p, to = moves p s, source = cfgSource cfg }
emitS :: (Text -> TokenT) -> Action
emitS t cfg p s z = emit (t s) cfg p s z
-- | Split out the prefix and name part of an identifier/operator.
splitQual :: T.Text -> ([T.Text], T.Text)
splitQual t =
case splitNS (T.filter (not . isSpace) t) of
[] -> panic "[Lexer] mkQualIdent" ["invalid qualified name", show t]
[i] -> ([], i)
xs -> (init xs, last xs)
where
-- split on the namespace separator, `::`
splitNS s =
case T.breakOn "::" s of
(l,r) | T.null r -> [l]
| otherwise -> l : splitNS (T.drop 2 r)
--------------------------------------------------------------------------------
numToken :: Integer -> Text -> TokenT
numToken rad ds = Num (toVal ds') (fromInteger rad) (T.length ds')
where
ds' = T.filter (/= '_') ds
toVal = T.foldl' (\x c -> rad * x + fromDigit c) 0
fromDigit :: Char -> Integer
fromDigit x'
| 'a' <= x && x <= 'z' = toInteger (10 + fromEnum x - fromEnum 'a')
| otherwise = toInteger (fromEnum x - fromEnum '0')
where x = toLower x'
-------------------------------------------------------------------------------
data AlexInput = Inp { alexPos :: !Position
, alexInputPrevChar :: !Char
, input :: !Text
} deriving Show
alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
alexGetByte i =
do (c,rest) <- T.uncons (input i)
let i' = i { alexPos = move (alexPos i) c, input = rest }
b = byteForChar c
return (b,i')
data Layout = Layout | NoLayout
--------------------------------------------------------------------------------
-- | Drop white-space tokens from the input.
dropWhite :: [Located Token] -> [Located Token]
dropWhite = filter (notWhite . tokenType . thing)
where notWhite (White w) = w == DocStr
notWhite _ = True
data Block = Virtual Int -- ^ Virtual layout block
| Explicit TokenT -- ^ An explicit layout block, expecting this ending
-- token.
deriving (Show)
isExplicit :: Block -> Bool
isExplicit Explicit{} = True
isExplicit Virtual{} = False
startsLayout :: TokenT -> Bool
startsLayout (KW KW_where) = True
startsLayout (KW KW_private) = True
startsLayout (KW KW_parameter) = True
startsLayout _ = False
-- Add separators computed from layout
layout :: Config -> [Located Token] -> [Located Token]
layout cfg ts0 = loop False implicitScope [] ts0
where
(_pos0,implicitScope) = case ts0 of
t : _ -> (from (srcRange t), cfgModuleScope cfg && tokenType (thing t) /= KW KW_module)
_ -> (start,False)
loop :: Bool -> Bool -> [Block] -> [Located Token] -> [Located Token]
loop afterDoc startBlock stack (t : ts)
| startsLayout ty = toks ++ loop False True stack' ts
-- We don't do layout within these delimeters
| Sym ParenL <- ty = toks ++ loop False False (Explicit (Sym ParenR) : stack') ts
| Sym CurlyL <- ty = toks ++ loop False False (Explicit (Sym CurlyR) : stack') ts
| Sym BracketL <- ty = toks ++ loop False False (Explicit (Sym BracketR) : stack') ts
| EOF <- ty = toks
| White DocStr <- ty = toks ++ loop True False stack' ts
| otherwise = toks ++ loop False False stack' ts
where
ty = tokenType (thing t)
pos = srcRange t
(toks,offStack)
| afterDoc = ([t], stack)
| otherwise = offsides startToks t stack
-- add any block start tokens, and push a level on the stack
(startToks,stack')
| startBlock && ty == EOF = ( [ virt cfg (to pos) VCurlyR
, virt cfg (to pos) VCurlyL ]
, offStack )
| startBlock = ( [ virt cfg (to pos) VCurlyL ], Virtual (col (from pos)) : offStack )
| otherwise = ( [], offStack )
loop _ _ _ [] = panic "[Lexer] layout" ["Missing EOF token"]
offsides :: [Located Token] -> Located Token -> [Block] -> ([Located Token], [Block])
offsides startToks t = go startToks
where
go virts stack = case stack of
-- delimit or close a layout block
Virtual c : rest
-- commas only close to an explicit marker, so if there is none, the
-- comma doesn't close anything
| Sym Comma == ty ->
if any isExplicit rest
then go (virt cfg (to pos) VCurlyR : virts) rest
else done virts stack
| closingToken -> go (virt cfg (to pos) VCurlyR : virts) rest
| col (from pos) == c -> done (virt cfg (to pos) VSemi : virts) stack
| col (from pos) < c -> go (virt cfg (to pos) VCurlyR : virts) rest
-- close an explicit block
Explicit close : rest | close == ty -> done virts rest
| Sym Comma == ty -> done virts stack
_ -> done virts stack
ty = tokenType (thing t)
pos = srcRange t
done ts s = (reverse (t:ts), s)
closingToken = ty `elem` [ Sym ParenR, Sym BracketR, Sym CurlyR ]
virt :: Config -> Position -> TokenV -> Located Token
virt cfg pos x = Located { srcRange = Range
{ from = pos
, to = pos
, source = cfgSource cfg
}
, thing = t }
where t = Token (Virt x) $ case x of
VCurlyL -> "beginning of layout block"
VCurlyR -> "end of layout block"
VSemi -> "layout block separator"
--------------------------------------------------------------------------------
data Token = Token { tokenType :: !TokenT, tokenText :: !Text }
deriving (Show, Generic, NFData)
-- | Virtual tokens, inserted by layout processing.
data TokenV = VCurlyL| VCurlyR | VSemi
deriving (Eq, Show, Generic, NFData)
data TokenW = BlockComment | LineComment | Space | DocStr
deriving (Eq, Show, Generic, NFData)
data TokenKW = KW_else
| KW_extern
| KW_fin
| KW_if
| KW_private
| KW_include
| KW_inf
| KW_lg2
| KW_lengthFromThen
| KW_lengthFromThenTo
| KW_max
| KW_min
| KW_module
| KW_newtype
| KW_pragma
| KW_property
| KW_then
| KW_type
| KW_where
| KW_let
| KW_x
| KW_import
| KW_as
| KW_hiding
| KW_infixl
| KW_infixr
| KW_infix
| KW_primitive
| KW_parameter
| KW_constraint
| KW_Prop
deriving (Eq, Show, Generic, NFData)
-- | The named operators are a special case for parsing types, and 'Other' is
-- used for all other cases that lexed as an operator.
data TokenOp = Plus | Minus | Mul | Div | Exp | Mod
| Equal | LEQ | GEQ
| Complement | Hash | At
| Other [T.Text] T.Text
deriving (Eq, Show, Generic, NFData)
data TokenSym = Bar
| ArrL | ArrR | FatArrR
| Lambda
| EqDef
| Comma
| Semi
| Dot
| DotDot
| DotDotDot
| Colon
| BackTick
| ParenL | ParenR
| BracketL | BracketR
| CurlyL | CurlyR
| TriL | TriR
| Underscore
deriving (Eq, Show, Generic, NFData)
data TokenErr = UnterminatedComment
| UnterminatedString
| UnterminatedChar
| InvalidString
| InvalidChar
| LexicalError
deriving (Eq, Show, Generic, NFData)
data TokenT = Num !Integer !Int !Int -- ^ value, base, number of digits
| ChrLit !Char -- ^ character literal
| Ident ![T.Text] !T.Text -- ^ (qualified) identifier
| StrLit !String -- ^ string literal
| KW !TokenKW -- ^ keyword
| Op !TokenOp -- ^ operator
| Sym !TokenSym -- ^ symbol
| Virt !TokenV -- ^ virtual token (for layout)
| White !TokenW -- ^ white space token
| Err !TokenErr -- ^ error token
| EOF
deriving (Eq, Show, Generic, NFData)
instance PP Token where
ppPrec _ (Token _ s) = text (T.unpack s)
-- | Collapse characters into a single Word8, identifying ASCII, and classes of
-- unicode. This came from:
--
-- https://github.com/glguy/config-value/blob/master/src/Config/LexerUtils.hs
--
-- Which adapted:
--
-- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x
byteForChar :: Char -> Word8
byteForChar c
| c <= '\6' = non_graphic
| isAscii c = fromIntegral (ord c)
| otherwise = case generalCategory c of
Char.LowercaseLetter -> lower
Char.OtherLetter -> lower
Char.UppercaseLetter -> upper
Char.TitlecaseLetter -> upper
Char.DecimalNumber -> digit
Char.OtherNumber -> digit
Char.ConnectorPunctuation -> symbol
Char.DashPunctuation -> symbol
Char.OtherPunctuation -> symbol
Char.MathSymbol -> symbol
Char.CurrencySymbol -> symbol
Char.ModifierSymbol -> symbol
Char.OtherSymbol -> symbol
Char.Space -> sp
Char.ModifierLetter -> other
Char.NonSpacingMark -> other
Char.SpacingCombiningMark -> other
Char.EnclosingMark -> other
Char.LetterNumber -> other
Char.OpenPunctuation -> other
Char.ClosePunctuation -> other
Char.InitialQuote -> other
Char.FinalQuote -> tick
_ -> non_graphic
where
non_graphic = 0
upper = 1
lower = 2
digit = 3
symbol = 4
sp = 5
other = 6
tick = 7
cryptol-2.8.0/src/Cryptol/Parser/Name.hs 0000644 0000000 0000000 00000004320 07346545000 016300 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Parser.Name
-- Copyright : (c) 2015-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.Parser.Name where
import Cryptol.Utils.Ident
import Cryptol.Utils.PP
import Cryptol.Utils.Panic (panic)
import Control.DeepSeq
import GHC.Generics (Generic)
-- Names -----------------------------------------------------------------------
-- | Names that originate in the parser.
data PName = UnQual !Ident
-- ^ Unqualified names like @x@, @Foo@, or @+@.
| Qual !ModName !Ident
-- ^ Qualified names like @Foo::bar@ or @module::!@.
| NewName !Pass !Int
-- ^ Fresh names generated by a pass.
deriving (Eq,Ord,Show,Generic)
-- | Passes that can generate fresh names.
data Pass = NoPat
| MonoValues
deriving (Eq,Ord,Show,Generic)
instance NFData PName
instance NFData Pass
mkUnqual :: Ident -> PName
mkUnqual = UnQual
mkQual :: ModName -> Ident -> PName
mkQual = Qual
getModName :: PName -> Maybe ModName
getModName (Qual ns _) = Just ns
getModName _ = Nothing
getIdent :: PName -> Ident
getIdent (UnQual n) = n
getIdent (Qual _ n) = n
getIdent (NewName p i) = packIdent ("__" ++ pass ++ show i)
where
pass = case p of
NoPat -> "p"
MonoValues -> "mv"
isGeneratedName :: PName -> Bool
isGeneratedName x =
case x of
NewName {} -> True
_ -> False
instance PP PName where
ppPrec _ = ppPrefixName
instance PPName PName where
ppNameFixity n
| isInfixIdent i = Just (NonAssoc, 0) -- FIXME?
| otherwise = Nothing
where
i = getIdent n
ppPrefixName n = optParens (isInfixIdent i) (pfx <.> pp i)
where
i = getIdent n
pfx = case getModName n of
Just ns -> pp ns <.> text "::"
Nothing -> empty
ppInfixName n
| isInfixIdent i = pfx <.> pp i
| otherwise = panic "AST" [ "non-symbol infix name:" ++ show n ]
where
i = getIdent n
pfx = case getModName n of
Just ns -> pp ns <.> text "::"
Nothing -> empty
cryptol-2.8.0/src/Cryptol/Parser/Names.hs 0000644 0000000 0000000 00000023747 07346545000 016501 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Parser.Names
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- This module defines the scoping rules for value- and type-level
-- names in Cryptol.
module Cryptol.Parser.Names where
import Cryptol.Parser.AST
import Data.Set (Set)
import qualified Data.Set as Set
-- | The names defined by a newtype.
tnamesNT :: Newtype name -> ([Located name], ())
tnamesNT x = ([ nName x ], ())
-- | The names defined and used by a group of mutually recursive declarations.
namesDs :: Ord name => [Decl name] -> ([Located name], Set name)
namesDs ds = (defs, boundLNames defs (Set.unions frees))
where
defs = concat defss
(defss,frees) = unzip (map namesD ds)
-- | The names defined and used by a single declarations.
namesD :: Ord name => Decl name -> ([Located name], Set name)
namesD decl =
case decl of
DBind b -> namesB b
DPatBind p e -> (namesP p, namesE e)
DSignature {} -> ([],Set.empty)
DFixity{} -> ([],Set.empty)
DPragma {} -> ([],Set.empty)
DType {} -> ([],Set.empty)
DProp {} -> ([],Set.empty)
DLocated d _ -> namesD d
-- | The names defined and used by a single declarations in such a way
-- that they cannot be duplicated in a file. For example, it is fine
-- to use @x@ on the RHS of two bindings, but not on the LHS of two
-- type signatures.
allNamesD :: Ord name => Decl name -> [Located name]
allNamesD decl =
case decl of
DBind b -> fst (namesB b)
DPatBind p _ -> namesP p
DSignature ns _ -> ns
DFixity _ ns -> ns
DPragma ns _ -> ns
DType ts -> [tsName ts]
DProp ps -> [psName ps]
DLocated d _ -> allNamesD d
-- | The names defined and used by a single binding.
namesB :: Ord name => Bind name -> ([Located name], Set name)
namesB b = ([bName b], boundLNames (namesPs (bParams b)) (namesDef (thing (bDef b))))
namesDef :: Ord name => BindDef name -> Set name
namesDef DPrim = Set.empty
namesDef (DExpr e) = namesE e
-- | The names used by an expression.
namesE :: Ord name => Expr name -> Set name
namesE expr =
case expr of
EVar x -> Set.singleton x
ELit _ -> Set.empty
ENeg e -> namesE e
EComplement e -> namesE e
EGenerate e -> namesE e
ETuple es -> Set.unions (map namesE es)
ERecord fs -> Set.unions (map (namesE . value) fs)
ESel e _ -> namesE e
EUpd mb fs -> let e = maybe Set.empty namesE mb
in Set.unions (e : map namesUF fs)
EList es -> Set.unions (map namesE es)
EFromTo{} -> Set.empty
EInfFrom e e' -> Set.union (namesE e) (maybe Set.empty namesE e')
EComp e arms -> let (dss,uss) = unzip (map namesArm arms)
in Set.union (boundLNames (concat dss) (namesE e))
(Set.unions uss)
EApp e1 e2 -> Set.union (namesE e1) (namesE e2)
EAppT e _ -> namesE e
EIf e1 e2 e3 -> Set.union (namesE e1) (Set.union (namesE e2) (namesE e3))
EWhere e ds -> let (bs,xs) = namesDs ds
in Set.union (boundLNames bs (namesE e)) xs
ETyped e _ -> namesE e
ETypeVal _ -> Set.empty
EFun ps e -> boundLNames (namesPs ps) (namesE e)
ELocated e _ -> namesE e
ESplit e -> namesE e
EParens e -> namesE e
EInfix a o _ b-> Set.insert (thing o) (Set.union (namesE a) (namesE b))
namesUF :: Ord name => UpdField name -> Set name
namesUF (UpdField _ _ e) = namesE e
-- | The names defined by a group of patterns.
namesPs :: [Pattern name] -> [Located name]
namesPs = concatMap namesP
-- | The names defined by a pattern. These will always be unqualified names.
namesP :: Pattern name -> [Located name]
namesP pat =
case pat of
PVar x -> [x]
PWild -> []
PTuple ps -> namesPs ps
PRecord fs -> namesPs (map value fs)
PList ps -> namesPs ps
PTyped p _ -> namesP p
PSplit p1 p2 -> namesPs [p1,p2]
PLocated p _ -> namesP p
-- | The names defined and used by a match.
namesM :: Ord name => Match name -> ([Located name], Set name)
namesM (Match p e) = (namesP p, namesE e)
namesM (MatchLet b) = namesB b
-- | The names defined and used by an arm of alist comprehension.
namesArm :: Ord name => [Match name] -> ([Located name], Set name)
namesArm = foldr combine ([],Set.empty) . map namesM
where combine (ds1,fs1) (ds2,fs2) =
( filter ((`notElem` map thing ds2) . thing) ds1 ++ ds2
, Set.union fs1 (boundLNames ds1 fs2)
)
-- | Remove some defined variables from a set of free variables.
boundLNames :: Ord name => [Located name] -> Set name -> Set name
boundLNames = boundNames . map thing
-- | Remove some defined variables from a set of free variables.
boundNames :: Ord name => [name] -> Set name -> Set name
boundNames = boundNamesSet . Set.fromList
-- | Remove some defined variables from a set of free variables.
boundNamesSet :: Ord name => Set name -> Set name -> Set name
boundNamesSet bs xs = Set.difference xs bs
-- | The type names defined and used by a group of mutually recursive declarations.
tnamesDs :: Ord name => [Decl name] -> ([Located name], Set name)
tnamesDs ds = (defs, boundLNames defs (Set.unions frees))
where
defs = concat defss
(defss,frees) = unzip (map tnamesD ds)
-- | The type names defined and used by a single declaration.
tnamesD :: Ord name => Decl name -> ([Located name], Set name)
tnamesD decl =
case decl of
DSignature _ s -> ([], tnamesS s)
DFixity {} -> ([], Set.empty)
DPragma {} -> ([], Set.empty)
DBind b -> ([], tnamesB b)
DPatBind _ e -> ([], tnamesE e)
DLocated d _ -> tnamesD d
DType (TySyn n _ ps t)
-> ([n], Set.difference (tnamesT t)
(Set.fromList (map tpName ps)))
DProp (PropSyn n _ ps cs)
-> ([n], Set.difference (Set.unions (map tnamesC cs))
(Set.fromList (map tpName ps)))
-- | The type names used by a single binding.
tnamesB :: Ord name => Bind name -> Set name
tnamesB b = Set.unions [setS, setP, setE]
where
setS = maybe Set.empty tnamesS (bSignature b)
setP = Set.unions (map tnamesP (bParams b))
setE = tnamesDef (thing (bDef b))
tnamesDef :: Ord name => BindDef name -> Set name
tnamesDef DPrim = Set.empty
tnamesDef (DExpr e) = tnamesE e
-- | The type names used by an expression.
tnamesE :: Ord name => Expr name -> Set name
tnamesE expr =
case expr of
EVar _ -> Set.empty
ELit _ -> Set.empty
ENeg e -> tnamesE e
EComplement e -> tnamesE e
EGenerate e -> tnamesE e
ETuple es -> Set.unions (map tnamesE es)
ERecord fs -> Set.unions (map (tnamesE . value) fs)
ESel e _ -> tnamesE e
EUpd mb fs -> let e = maybe Set.empty tnamesE mb
in Set.unions (e : map tnamesUF fs)
EList es -> Set.unions (map tnamesE es)
EFromTo a b c t -> tnamesT a
`Set.union` maybe Set.empty tnamesT b
`Set.union` tnamesT c
`Set.union` maybe Set.empty tnamesT t
EInfFrom e e' -> Set.union (tnamesE e) (maybe Set.empty tnamesE e')
EComp e mss -> Set.union (tnamesE e) (Set.unions (map tnamesM (concat mss)))
EApp e1 e2 -> Set.union (tnamesE e1) (tnamesE e2)
EAppT e fs -> Set.union (tnamesE e) (Set.unions (map tnamesTI fs))
EIf e1 e2 e3 -> Set.union (tnamesE e1) (Set.union (tnamesE e2) (tnamesE e3))
EWhere e ds -> let (bs,xs) = tnamesDs ds
in Set.union (boundLNames bs (tnamesE e)) xs
ETyped e t -> Set.union (tnamesE e) (tnamesT t)
ETypeVal t -> tnamesT t
EFun ps e -> Set.union (Set.unions (map tnamesP ps)) (tnamesE e)
ELocated e _ -> tnamesE e
ESplit e -> tnamesE e
EParens e -> tnamesE e
EInfix a _ _ b -> Set.union (tnamesE a) (tnamesE b)
tnamesUF :: Ord name => UpdField name -> Set name
tnamesUF (UpdField _ _ e) = tnamesE e
tnamesTI :: Ord name => TypeInst name -> Set name
tnamesTI (NamedInst f) = tnamesT (value f)
tnamesTI (PosInst t) = tnamesT t
-- | The type names used by a pattern.
tnamesP :: Ord name => Pattern name -> Set name
tnamesP pat =
case pat of
PVar _ -> Set.empty
PWild -> Set.empty
PTuple ps -> Set.unions (map tnamesP ps)
PRecord fs -> Set.unions (map (tnamesP . value) fs)
PList ps -> Set.unions (map tnamesP ps)
PTyped p t -> Set.union (tnamesP p) (tnamesT t)
PSplit p1 p2 -> Set.union (tnamesP p1) (tnamesP p2)
PLocated p _ -> tnamesP p
-- | The type names used by a match.
tnamesM :: Ord name => Match name -> Set name
tnamesM (Match p e) = Set.union (tnamesP p) (tnamesE e)
tnamesM (MatchLet b) = tnamesB b
-- | The type names used by a type schema.
tnamesS :: Ord name => Schema name -> Set name
tnamesS (Forall params props ty _) =
Set.difference (Set.union (Set.unions (map tnamesC props)) (tnamesT ty))
(Set.fromList (map tpName params))
-- | The type names used by a prop.
tnamesC :: Ord name => Prop name -> Set name
tnamesC prop =
case prop of
CType t -> tnamesT t
-- | Compute the type synonyms/type variables used by a type.
tnamesT :: Ord name => Type name -> Set name
tnamesT ty =
case ty of
TWild -> Set.empty
TFun t1 t2 -> Set.union (tnamesT t1) (tnamesT t2)
TSeq t1 t2 -> Set.union (tnamesT t1) (tnamesT t2)
TBit -> Set.empty
TNum _ -> Set.empty
TChar __ -> Set.empty
TTuple ts -> Set.unions (map tnamesT ts)
TRecord fs -> Set.unions (map (tnamesT . value) fs)
TLocated t _ -> tnamesT t
TUser x ts -> Set.insert x (Set.unions (map tnamesT ts))
TParens t -> tnamesT t
TInfix a x _ c-> Set.insert (thing x)
(Set.union (tnamesT a) (tnamesT c))
cryptol-2.8.0/src/Cryptol/Parser/NoInclude.hs 0000644 0000000 0000000 00000013625 07346545000 017310 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Parser.NoInclude
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.Parser.NoInclude
( removeIncludesModule
, IncludeError(..), ppIncludeError
) where
import qualified Control.Applicative as A
import Control.DeepSeq
import qualified Control.Exception as X
import Data.Either (partitionEithers)
import Data.Text(Text)
import qualified Data.Text.IO as T
import GHC.Generics (Generic)
import MonadLib
import System.Directory (makeAbsolute)
import System.FilePath (takeDirectory,(>),isAbsolute)
import Cryptol.Parser (parseProgramWith)
import Cryptol.Parser.AST
import Cryptol.Parser.LexerUtils (Config(..),defaultConfig)
import Cryptol.Parser.ParserUtils
import Cryptol.Parser.Unlit (guessPreProc)
import Cryptol.Utils.PP
removeIncludesModule :: FilePath -> Module PName -> IO (Either [IncludeError] (Module PName))
removeIncludesModule modPath m = runNoIncM modPath (noIncludeModule m)
data IncludeError
= IncludeFailed (Located FilePath)
| IncludeParseError ParseError
| IncludeCycle [Located FilePath]
deriving (Show, Generic, NFData)
ppIncludeError :: IncludeError -> Doc
ppIncludeError ie = case ie of
IncludeFailed lp -> (char '`' <.> text (thing lp) <.> char '`')
<+> text "included at"
<+> pp (srcRange lp)
<+> text "was not found"
IncludeParseError pe -> ppError pe
IncludeCycle is -> text "includes form a cycle:"
$$ nest 2 (vcat (map (pp . srcRange) is))
newtype NoIncM a = M
{ unM :: ReaderT Env (ExceptionT [IncludeError] IO) a }
data Env = Env { envSeen :: [Located FilePath]
-- ^ Files that have been loaded
, envIncPath :: FilePath
-- ^ The path that includes are relative to
}
runNoIncM :: FilePath -> NoIncM a -> IO (Either [IncludeError] a)
runNoIncM sourcePath m =
do incPath <- getIncPath sourcePath
runM (unM m) Env { envSeen = [], envIncPath = incPath }
tryNoIncM :: NoIncM a -> NoIncM (Either [IncludeError] a)
tryNoIncM m = M (try (unM m))
-- | Get the absolute directory name of a file that contains cryptol source.
getIncPath :: FilePath -> IO FilePath
getIncPath file = makeAbsolute (takeDirectory file)
-- | Run a 'NoIncM' action with a different include path. The argument is
-- expected to be the path of a file that contains cryptol source, and will be
-- adjusted with getIncPath.
withIncPath :: FilePath -> NoIncM a -> NoIncM a
withIncPath path (M body) = M $
do incPath <- inBase (getIncPath path)
env <- ask
local env { envIncPath = incPath } body
-- | Adjust an included file with the current include path.
fromIncPath :: FilePath -> NoIncM FilePath
fromIncPath path
| isAbsolute path = return path
| otherwise = M $
do Env { .. } <- ask
return (envIncPath > path)
instance Functor NoIncM where
fmap = liftM
instance A.Applicative NoIncM where
pure = return
(<*>) = ap
instance Monad NoIncM where
return x = M (return x)
m >>= f = M (unM m >>= unM . f)
fail x = M (fail x)
-- | Raise an 'IncludeFailed' error.
includeFailed :: Located FilePath -> NoIncM a
includeFailed path = M (raise [IncludeFailed path])
-- | Push a path on the stack of included files, and run an action. If the path
-- is already on the stack, an include cycle has happened, and an error is
-- raised.
pushPath :: Located FilePath -> NoIncM a -> NoIncM a
pushPath path m = M $ do
Env { .. } <- ask
let alreadyIncluded l = thing path == thing l
when (any alreadyIncluded envSeen) (raise [IncludeCycle envSeen])
local Env { envSeen = path:envSeen, .. } (unM m)
-- | Lift an IO operation, with a way to handle the exception that it might
-- throw.
failsWith :: X.Exception e => IO a -> (e -> NoIncM a) -> NoIncM a
failsWith m k = M $ do
e <- inBase (X.try m)
case e of
Right a -> return a
Left exn -> unM (k exn)
-- | Like 'mapM', but tries to collect as many errors as possible before
-- failing.
collectErrors :: (a -> NoIncM b) -> [a] -> NoIncM [b]
collectErrors f ts = do
es <- mapM (tryNoIncM . f) ts
let (ls,rs) = partitionEithers es
errs = concat ls
unless (null errs) (M (raise errs))
return rs
-- | Remove includes from a module.
noIncludeModule :: Module PName -> NoIncM (Module PName)
noIncludeModule m = update `fmap` collectErrors noIncTopDecl (mDecls m)
where
update tds = m { mDecls = concat tds }
-- | Remove includes from a program.
noIncludeProgram :: Program PName -> NoIncM (Program PName)
noIncludeProgram (Program tds) =
(Program . concat) `fmap` collectErrors noIncTopDecl tds
-- | Substitute top-level includes with the declarations from the files they
-- reference.
noIncTopDecl :: TopDecl PName -> NoIncM [TopDecl PName]
noIncTopDecl td = case td of
Decl _ -> return [td]
DPrimType {} -> pure [td]
TDNewtype _-> return [td]
DParameterType {} -> return [td]
DParameterConstraint {} -> return [td]
DParameterFun {} -> return [td]
Include lf -> resolveInclude lf
-- | Resolve the file referenced by a include into a list of top-level
-- declarations.
resolveInclude :: Located FilePath -> NoIncM [TopDecl PName]
resolveInclude lf = pushPath lf $ do
source <- readInclude lf
case parseProgramWith (defaultConfig { cfgSource = thing lf, cfgPreProc = guessPreProc (thing lf) }) source of
Right prog -> do
Program ds <- withIncPath (thing lf) (noIncludeProgram prog)
return ds
Left err -> M (raise [IncludeParseError err])
-- | Read a file referenced by an include.
readInclude :: Located FilePath -> NoIncM Text
readInclude path = do
file <- fromIncPath (thing path)
source <- T.readFile file `failsWith` handler
return source
where
handler :: X.IOException -> NoIncM a
handler _ = includeFailed path
cryptol-2.8.0/src/Cryptol/Parser/NoPat.hs 0000644 0000000 0000000 00000051564 07346545000 016455 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Parser.NoPat
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- The purpose of this module is to convert all patterns to variable
-- patterns. It also eliminates pattern bindings by de-sugaring them
-- into `Bind`. Furthermore, here we associate signatures and pragmas
-- with the names to which they belong.
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.Parser.NoPat (RemovePatterns(..),Error(..)) where
import Cryptol.Parser.AST
import Cryptol.Parser.Position(Range(..),emptyRange,start,at)
import Cryptol.Parser.Names (namesP)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic(panic)
import MonadLib hiding (mapM)
import Data.Maybe(maybeToList)
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
class RemovePatterns t where
-- | Eliminate all patterns in a program.
removePatterns :: t -> (t, [Error])
instance RemovePatterns (Program PName) where
removePatterns p = runNoPatM (noPatProg p)
instance RemovePatterns (Expr PName) where
removePatterns e = runNoPatM (noPatE e)
instance RemovePatterns (Module PName) where
removePatterns m = runNoPatM (noPatModule m)
instance RemovePatterns [Decl PName] where
removePatterns ds = runNoPatM (noPatDs ds)
simpleBind :: Located PName -> Expr PName -> Bind PName
simpleBind x e = Bind { bName = x, bParams = []
, bDef = at e (Located emptyRange (DExpr e))
, bSignature = Nothing, bPragmas = []
, bMono = True, bInfix = False, bFixity = Nothing
, bDoc = Nothing
}
sel :: Pattern PName -> PName -> Selector -> Bind PName
sel p x s = let (a,ts) = splitSimpleP p
in simpleBind a (foldl ETyped (ESel (EVar x) s) ts)
-- | Given a pattern, transform it into a simple pattern and a set of bindings.
-- Simple patterns may only contain variables and type annotations.
-- XXX: We can replace the types in the selectors with annotations on the bindings.
noPat :: Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat pat =
case pat of
PVar x -> return (PVar x, [])
PWild ->
do x <- newName
r <- getRange
return (pVar r x, [])
PTuple ps ->
do (as,dss) <- unzip `fmap` mapM noPat ps
x <- newName
r <- getRange
let len = length ps
ty = TTuple (replicate len TWild)
getN a n = sel a x (TupleSel n (Just len))
return (pTy r x ty, zipWith getN as [0..] ++ concat dss)
PList [] ->
do x <- newName
r <- getRange
return (pTy r x (TSeq (TNum 0) TWild), [])
PList ps ->
do (as,dss) <- unzip `fmap` mapM noPat ps
x <- newName
r <- getRange
let len = length ps
ty = TSeq (TNum (toInteger len)) TWild
getN a n = sel a x (ListSel n (Just len))
return (pTy r x ty, zipWith getN as [0..] ++ concat dss)
PRecord fs ->
do (as,dss) <- unzip `fmap` mapM (noPat . value) fs
x <- newName
r <- getRange
let shape = map (thing . name) fs
ty = TRecord (map (fmap (\_ -> TWild)) fs)
getN a n = sel a x (RecordSel n (Just shape))
return (pTy r x ty, zipWith getN as shape ++ concat dss)
PTyped p t ->
do (a,ds) <- noPat p
return (PTyped a t, ds)
-- XXX: We can do more with type annotations here
PSplit p1 p2 ->
do (a1,ds1) <- noPat p1
(a2,ds2) <- noPat p2
x <- newName
tmp <- newName
r <- getRange
let bTmp = simpleBind (Located r tmp) (ESplit (EVar x))
b1 = sel a1 tmp (TupleSel 0 (Just 2))
b2 = sel a2 tmp (TupleSel 1 (Just 2))
return (pVar r x, bTmp : b1 : b2 : ds1 ++ ds2)
PLocated p r1 -> inRange r1 (noPat p)
where
pVar r x = PVar (Located r x)
pTy r x t = PTyped (PVar (Located r x)) t
splitSimpleP :: Pattern PName -> (Located PName, [Type PName])
splitSimpleP (PVar x) = (x, [])
splitSimpleP (PTyped p t) = let (x,ts) = splitSimpleP p
in (x, t:ts)
splitSimpleP p = panic "splitSimpleP"
[ "Non-simple pattern", show p ]
--------------------------------------------------------------------------------
noPatE :: Expr PName -> NoPatM (Expr PName)
noPatE expr =
case expr of
EVar {} -> return expr
ELit {} -> return expr
ENeg e -> ENeg <$> noPatE e
EComplement e -> EComplement <$> noPatE e
EGenerate e -> EGenerate <$> noPatE e
ETuple es -> ETuple <$> mapM noPatE es
ERecord es -> ERecord <$> mapM noPatF es
ESel e s -> ESel <$> noPatE e <*> return s
EUpd mb fs -> EUpd <$> traverse noPatE mb <*> traverse noPatUF fs
EList es -> EList <$> mapM noPatE es
EFromTo {} -> return expr
EInfFrom e e' -> EInfFrom <$> noPatE e <*> traverse noPatE e'
EComp e mss -> EComp <$> noPatE e <*> mapM noPatArm mss
EApp e1 e2 -> EApp <$> noPatE e1 <*> noPatE e2
EAppT e ts -> EAppT <$> noPatE e <*> return ts
EIf e1 e2 e3 -> EIf <$> noPatE e1 <*> noPatE e2 <*> noPatE e3
EWhere e ds -> EWhere <$> noPatE e <*> noPatDs ds
ETyped e t -> ETyped <$> noPatE e <*> return t
ETypeVal {} -> return expr
EFun ps e -> do (ps1,e1) <- noPatFun ps e
return (EFun ps1 e1)
ELocated e r1 -> ELocated <$> inRange r1 (noPatE e) <*> return r1
ESplit e -> ESplit <$> noPatE e
EParens e -> EParens <$> noPatE e
EInfix x y f z-> EInfix <$> noPatE x <*> pure y <*> pure f <*> noPatE z
where noPatF x = do e <- noPatE (value x)
return x { value = e }
noPatUF :: UpdField PName -> NoPatM (UpdField PName)
noPatUF (UpdField h ls e) = UpdField h ls <$> noPatE e
noPatFun :: [Pattern PName] -> Expr PName -> NoPatM ([Pattern PName], Expr PName)
noPatFun ps e =
do (xs,bs) <- unzip <$> mapM noPat ps
e1 <- noPatE e
let body = case concat bs of
[] -> e1
ds -> EWhere e1 $ map DBind ds
return (xs, body)
noPatArm :: [Match PName] -> NoPatM [Match PName]
noPatArm ms = concat <$> mapM noPatM ms
noPatM :: Match PName -> NoPatM [Match PName]
noPatM (Match p e) =
do (x,bs) <- noPat p
e1 <- noPatE e
return (Match x e1 : map MatchLet bs)
noPatM (MatchLet b) = (return . MatchLet) <$> noMatchB b
noMatchB :: Bind PName -> NoPatM (Bind PName)
noMatchB b =
case thing (bDef b) of
DPrim | null (bParams b) -> return b
| otherwise -> panic "NoPat" [ "noMatchB: primitive with params"
, show b ]
DExpr e ->
do (ps,e') <- noPatFun (bParams b) e
return b { bParams = ps, bDef = DExpr e' <$ bDef b }
noMatchD :: Decl PName -> NoPatM [Decl PName]
noMatchD decl =
case decl of
DSignature {} -> return [decl]
DPragma {} -> return [decl]
DFixity{} -> return [decl]
DBind b -> do b1 <- noMatchB b
return [DBind b1]
DPatBind p e -> do (p',bs) <- noPat p
let (x,ts) = splitSimpleP p'
e1 <- noPatE e
let e2 = foldl ETyped e1 ts
return $ DBind Bind { bName = x
, bParams = []
, bDef = at e (Located emptyRange (DExpr e2))
, bSignature = Nothing
, bPragmas = []
, bMono = False
, bInfix = False
, bFixity = Nothing
, bDoc = Nothing
} : map DBind bs
DType {} -> return [decl]
DProp {} -> return [decl]
DLocated d r1 -> do bs <- inRange r1 $ noMatchD d
return $ map (`DLocated` r1) bs
noPatDs :: [Decl PName] -> NoPatM [Decl PName]
noPatDs ds =
do ds1 <- concat <$> mapM noMatchD ds
let fixes = Map.fromListWith (++) $ concatMap toFixity ds1
amap = AnnotMap
{ annPragmas = Map.fromListWith (++) $ concatMap toPragma ds1
, annSigs = Map.fromListWith (++) $ concatMap toSig ds1
, annValueFs = fixes
, annTypeFs = fixes
, annDocs = Map.empty
}
(ds2, AnnotMap { .. }) <- runStateT amap (annotDs ds1)
forM_ (Map.toList annPragmas) $ \(n,ps) ->
forM_ ps $ \p -> recordError $ PragmaNoBind (p { thing = n }) (thing p)
forM_ (Map.toList annSigs) $ \(n,ss) ->
do _ <- checkSigs n ss
forM_ ss $ \s -> recordError $ SignatureNoBind (s { thing = n })
(thing s)
-- Generate an error if a fixity declaration is not used for
-- either a value-level or type-level operator.
forM_ (Map.toList (Map.intersection annValueFs annTypeFs)) $ \(n,fs) ->
forM_ fs $ \f -> recordError $ FixityNoBind f { thing = n }
return ds2
noPatTopDs :: [TopDecl PName] -> NoPatM [TopDecl PName]
noPatTopDs tds =
do desugared <- concat <$> mapM desugar tds
let allDecls = map tlValue (decls desugared)
fixes = Map.fromListWith (++) $ concatMap toFixity allDecls
let ann = AnnotMap
{ annPragmas = Map.fromListWith (++) $ concatMap toPragma allDecls
, annSigs = Map.fromListWith (++) $ concatMap toSig allDecls
, annValueFs = fixes
, annTypeFs = fixes
, annDocs = Map.fromListWith (++) $ concatMap toDocs $ decls tds
}
(tds', AnnotMap { .. }) <- runStateT ann (annotTopDs desugared)
forM_ (Map.toList annPragmas) $ \(n,ps) ->
forM_ ps $ \p -> recordError $ PragmaNoBind (p { thing = n }) (thing p)
forM_ (Map.toList annSigs) $ \(n,ss) ->
do _ <- checkSigs n ss
forM_ ss $ \s -> recordError $ SignatureNoBind (s { thing = n })
(thing s)
-- Generate an error if a fixity declaration is not used for
-- either a value-level or type-level operator.
forM_ (Map.toList (Map.intersection annValueFs annTypeFs)) $ \(n,fs) ->
forM_ fs $ \f -> recordError $ FixityNoBind f { thing = n }
return tds'
where
decls xs = [ d | Decl d <- xs ]
desugar d =
case d of
Decl tl -> do ds <- noMatchD (tlValue tl)
return [ Decl tl { tlValue = d1 } | d1 <- ds ]
x -> return [x]
noPatProg :: Program PName -> NoPatM (Program PName)
noPatProg (Program topDs) = Program <$> noPatTopDs topDs
noPatModule :: Module PName -> NoPatM (Module PName)
noPatModule m =
do ds1 <- noPatTopDs (mDecls m)
return m { mDecls = ds1 }
--------------------------------------------------------------------------------
data AnnotMap = AnnotMap
{ annPragmas :: Map.Map PName [Located Pragma ]
, annSigs :: Map.Map PName [Located (Schema PName)]
, annValueFs :: Map.Map PName [Located Fixity ]
, annTypeFs :: Map.Map PName [Located Fixity ]
, annDocs :: Map.Map PName [Located String ]
}
type Annotates a = a -> StateT AnnotMap NoPatM a
-- | Add annotations to exported declaration groups.
--
-- XXX: This isn't quite right: if a signature and binding have different
-- export specifications, this will favor the specification of the binding.
-- This is most likely the intended behavior, so it's probably fine, but it does
-- smell a bit.
annotTopDs :: Annotates [TopDecl PName]
annotTopDs tds =
case tds of
d : ds ->
case d of
Decl d1 ->
do ignore <- runExceptionT (annotD (tlValue d1))
case ignore of
Left _ -> annotTopDs ds
Right d2 -> (Decl (d1 { tlValue = d2 }) :) <$> annotTopDs ds
DPrimType tl ->
do pt <- annotPrimType (tlValue tl)
let d1 = DPrimType tl { tlValue = pt }
(d1 :) <$> annotTopDs ds
DParameterType p ->
do p1 <- annotParameterType p
(DParameterType p1 :) <$> annotTopDs ds
DParameterConstraint {} -> (d :) <$> annotTopDs ds
DParameterFun p ->
do AnnotMap { .. } <- get
let rm _ _ = Nothing
name = thing (pfName p)
case Map.updateLookupWithKey rm name annValueFs of
(Nothing,_) -> (d :) <$> annotTopDs ds
(Just f,fs1) ->
do mbF <- lift (checkFixs name f)
set AnnotMap { annValueFs = fs1, .. }
let p1 = p { pfFixity = mbF }
(DParameterFun p1 :) <$> annotTopDs ds
-- XXX: we may want to add pragmas to newtypes?
TDNewtype {} -> (d :) <$> annotTopDs ds
Include {} -> (d :) <$> annotTopDs ds
[] -> return []
-- | Add annotations, keeping track of which annotations are not yet used up.
annotDs :: Annotates [Decl PName]
annotDs (d : ds) =
do ignore <- runExceptionT (annotD d)
case ignore of
Left () -> annotDs ds
Right d1 -> (d1 :) <$> annotDs ds
annotDs [] = return []
-- | Add annotations, keeping track of which annotations are not yet used up.
-- The exception indicates which declarations are no longer needed.
annotD :: Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
annotD decl =
case decl of
DBind b -> DBind <$> lift (annotB b)
DSignature {} -> raise ()
DFixity{} -> raise ()
DPragma {} -> raise ()
DPatBind {} -> raise ()
DType tysyn -> DType <$> lift (annotTySyn tysyn)
DProp propsyn -> DProp <$> lift (annotPropSyn propsyn)
DLocated d r -> (`DLocated` r) <$> annotD d
-- | Add pragma/signature annotations to a binding.
annotB :: Annotates (Bind PName)
annotB Bind { .. } =
do AnnotMap { .. } <- get
let name = thing bName
remove _ _ = Nothing
(thisPs , ps') = Map.updateLookupWithKey remove name annPragmas
(thisSigs , ss') = Map.updateLookupWithKey remove name annSigs
(thisFixes , fs') = Map.updateLookupWithKey remove name annValueFs
(thisDocs , ds') = Map.updateLookupWithKey remove name annDocs
s <- lift $ checkSigs name $ jn thisSigs
f <- lift $ checkFixs name $ jn thisFixes
d <- lift $ checkDocs name $ jn thisDocs
set AnnotMap { annPragmas = ps'
, annSigs = ss'
, annValueFs = fs'
, annDocs = ds'
, ..
}
return Bind { bSignature = s
, bPragmas = map thing (jn thisPs) ++ bPragmas
, bFixity = f
, bDoc = d
, ..
}
where jn x = concat (maybeToList x)
annotTyThing :: PName -> StateT AnnotMap NoPatM (Maybe Fixity)
annotTyThing name =
do AnnotMap { .. } <- get
let remove _ _ = Nothing
(thisFixes, ts') = Map.updateLookupWithKey remove name annTypeFs
f <- lift $ checkFixs name $ concat $ maybeToList thisFixes
set AnnotMap { annTypeFs = ts', .. }
pure f
-- | Add fixity annotations to a type synonym binding.
annotTySyn :: Annotates (TySyn PName)
annotTySyn (TySyn ln _ params rhs) =
do f <- annotTyThing (thing ln)
pure (TySyn ln f params rhs)
-- | Add fixity annotations to a constraint synonym binding.
annotPropSyn :: Annotates (PropSyn PName)
annotPropSyn (PropSyn ln _ params rhs) =
do f <- annotTyThing (thing ln)
pure (PropSyn ln f params rhs)
-- | Annotate a primitive type declaration.
annotPrimType :: Annotates (PrimType PName)
annotPrimType pt =
do f <- annotTyThing (thing (primTName pt))
pure pt { primTFixity = f }
-- | Annotate a module's type parameter.
annotParameterType :: Annotates (ParameterType PName)
annotParameterType pt =
do f <- annotTyThing (thing (ptName pt))
pure pt { ptFixity = f }
-- | Check for multiple signatures.
checkSigs :: PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
checkSigs _ [] = return Nothing
checkSigs _ [s] = return (Just (thing s))
checkSigs f xs@(s : _ : _) = do recordError $ MultipleSignatures f xs
return (Just (thing s))
checkFixs :: PName -> [Located Fixity] -> NoPatM (Maybe Fixity)
checkFixs _ [] = return Nothing
checkFixs _ [f] = return (Just (thing f))
checkFixs f fs@(x:_) = do recordError $ MultipleFixities f $ map srcRange fs
return (Just (thing x))
checkDocs :: PName -> [Located String] -> NoPatM (Maybe String)
checkDocs _ [] = return Nothing
checkDocs _ [d] = return (Just (thing d))
checkDocs f ds@(d:_) = do recordError $ MultipleDocs f (map srcRange ds)
return (Just (thing d))
-- | Does this declaration provide some signatures?
toSig :: Decl PName -> [(PName, [Located (Schema PName)])]
toSig (DLocated d _) = toSig d
toSig (DSignature xs s) = [ (thing x,[Located (srcRange x) s]) | x <- xs ]
toSig _ = []
-- | Does this declaration provide some signatures?
toPragma :: Decl PName -> [(PName, [Located Pragma])]
toPragma (DLocated d _) = toPragma d
toPragma (DPragma xs s) = [ (thing x,[Located (srcRange x) s]) | x <- xs ]
toPragma _ = []
-- | Does this declaration provide fixity information?
toFixity :: Decl PName -> [(PName, [Located Fixity])]
toFixity (DFixity f ns) = [ (thing n, [Located (srcRange n) f]) | n <- ns ]
toFixity _ = []
-- | Does this top-level declaration provide a documentation string?
toDocs :: TopLevel (Decl PName) -> [(PName, [Located String])]
toDocs TopLevel { .. }
| Just txt <- tlDoc = go txt tlValue
| otherwise = []
where
go txt decl =
case decl of
DSignature ns _ -> [ (thing n, [txt]) | n <- ns ]
DFixity _ ns -> [ (thing n, [txt]) | n <- ns ]
DBind b -> [ (thing (bName b), [txt]) ]
DLocated d _ -> go txt d
DPatBind p _ -> [ (thing n, [txt]) | n <- namesP p ]
-- XXX revisit these
DPragma _ _ -> []
DType _ -> []
DProp _ -> []
--------------------------------------------------------------------------------
newtype NoPatM a = M { unM :: ReaderT Range (StateT RW Id) a }
data RW = RW { names :: !Int, errors :: [Error] }
data Error = MultipleSignatures PName [Located (Schema PName)]
| SignatureNoBind (Located PName) (Schema PName)
| PragmaNoBind (Located PName) Pragma
| MultipleFixities PName [Range]
| FixityNoBind (Located PName)
| MultipleDocs PName [Range]
deriving (Show,Generic, NFData)
instance Functor NoPatM where fmap = liftM
instance Applicative NoPatM where pure = return; (<*>) = ap
instance Monad NoPatM where
return x = M (return x)
fail x = M (fail x)
M x >>= k = M (x >>= unM . k)
-- | Pick a new name, to be used when desugaring patterns.
newName :: NoPatM PName
newName = M $ sets $ \s -> let x = names s
in (NewName NoPat x, s { names = x + 1 })
-- | Record an error.
recordError :: Error -> NoPatM ()
recordError e = M $ sets_ $ \s -> s { errors = e : errors s }
getRange :: NoPatM Range
getRange = M ask
inRange :: Range -> NoPatM a -> NoPatM a
inRange r m = M $ local r $ unM m
runNoPatM :: NoPatM a -> (a, [Error])
runNoPatM m
= getErrs
$ runId
$ runStateT RW { names = 0, errors = [] }
$ runReaderT (Range start start "") -- hm
$ unM m
where getErrs (a,rw) = (a, errors rw)
--------------------------------------------------------------------------------
instance PP Error where
ppPrec _ err =
case err of
MultipleSignatures x ss ->
text "Multiple type signatures for" <+> quotes (pp x)
$$ nest 2 (vcat (map pp ss))
SignatureNoBind x s ->
text "At" <+> pp (srcRange x) <.> colon <+>
text "Type signature without a matching binding:"
$$ nest 2 (pp (thing x) <+> colon <+> pp s)
PragmaNoBind x s ->
text "At" <+> pp (srcRange x) <.> colon <+>
text "Pragma without a matching binding:"
$$ nest 2 (pp s)
MultipleFixities n locs ->
text "Multiple fixity declarations for" <+> quotes (pp n)
$$ nest 2 (vcat (map pp locs))
FixityNoBind n ->
text "At" <+> pp (srcRange n) <.> colon <+>
text "Fixity declaration without a matching binding for:" <+>
pp (thing n)
MultipleDocs n locs ->
text "Multiple documentation blocks given for:" <+> pp n
$$ nest 2 (vcat (map pp locs))
cryptol-2.8.0/src/Cryptol/Parser/ParserUtils.hs 0000644 0000000 0000000 00000057640 07346545000 017712 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Parser.ParserUtils
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Parser.ParserUtils where
import Data.Maybe(fromMaybe)
import Data.Bits(testBit,setBit)
import Control.Monad(liftM,ap,unless,guard)
import Data.Text(Text)
import qualified Data.Text as T
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
import Cryptol.Parser.AST
import Cryptol.Parser.Lexer
import Cryptol.Parser.Position
import Cryptol.Parser.Utils (translateExprToNumT,widthIdent)
import Cryptol.Utils.Ident(packModName)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
parseString :: Config -> ParseM a -> String -> Either ParseError a
parseString cfg p cs = parse cfg p (T.pack cs)
parse :: Config -> ParseM a -> Text -> Either ParseError a
parse cfg p cs = case unP p cfg eofPos S { sPrevTok = Nothing
, sTokens = toks
, sNextTyParamNum = 0
} of
Left err -> Left err
Right (a,_) -> Right a
where (toks,eofPos) = lexer cfg cs
{- The parser is parameterized by the pozition of the final token. -}
newtype ParseM a =
P { unP :: Config -> Position -> S -> Either ParseError (a,S) }
lexerP :: (Located Token -> ParseM a) -> ParseM a
lexerP k = P $ \cfg p s ->
case sTokens s of
t : _ | Err e <- tokenType it ->
Left $ HappyErrorMsg (srcRange t) $
case e of
UnterminatedComment -> "unterminated comment"
UnterminatedString -> "unterminated string"
UnterminatedChar -> "unterminated character"
InvalidString -> "invalid string literal:" ++
T.unpack (tokenText it)
InvalidChar -> "invalid character literal:" ++
T.unpack (tokenText it)
LexicalError -> "unrecognized character:" ++
T.unpack (tokenText it)
where it = thing t
t : more -> unP (k t) cfg p s { sPrevTok = Just t, sTokens = more }
[] -> Left (HappyOutOfTokens (cfgSource cfg) p)
data ParseError = HappyError FilePath {- Name of source file -}
(Located Token) {- Offending token -}
| HappyErrorMsg Range String
| HappyUnexpected FilePath (Maybe (Located Token)) String
| HappyOutOfTokens FilePath Position
deriving (Show, Generic, NFData)
data S = S { sPrevTok :: Maybe (Located Token)
, sTokens :: [Located Token]
, sNextTyParamNum :: !Int
-- ^ Keep track of the type parameters as they appear in the input
}
ppError :: ParseError -> Doc
ppError (HappyError path ltok)
| Err _ <- tokenType tok =
text "Parse error at" <+>
text path <.> char ':' <.> pp pos <.> comma <+>
pp tok
| White DocStr <- tokenType tok =
"Unexpected documentation (/**) comment at" <+>
text path <.> char ':' <.> pp pos <.> colon $$
nest 2
"Documentation comments need to be followed by something to document."
| otherwise =
text "Parse error at" <+>
text path <.> char ':' <.> pp pos <.> comma $$
nest 2 (text "unexpected:" <+> pp tok)
where
pos = from (srcRange ltok)
tok = thing ltok
ppError (HappyOutOfTokens path pos) =
text "Unexpected end of file at:" <+>
text path <.> char ':' <.> pp pos
ppError (HappyErrorMsg p x) = text "Parse error at" <+> pp p $$ nest 2 (text x)
ppError (HappyUnexpected path ltok e) =
text "Parse error at" <+>
text path <.> char ':' <.> pp pos <.> comma $$
nest 2 unexp $$
nest 2 ("expected:" <+> text e)
where
(unexp,pos) =
case ltok of
Nothing -> (empty,start)
Just t -> ( "unexpected:" <+> text (T.unpack (tokenText (thing t)))
, from (srcRange t)
)
instance Functor ParseM where
fmap = liftM
instance Applicative ParseM where
pure = return
(<*>) = ap
instance Monad ParseM where
return a = P (\_ _ s -> Right (a,s))
fail s = panic "[Parser] fail" [s]
m >>= k = P (\cfg p s1 -> case unP m cfg p s1 of
Left e -> Left e
Right (a,s2) -> unP (k a) cfg p s2)
happyError :: ParseM a
happyError = P $ \cfg _ s ->
case sPrevTok s of
Just t -> Left (HappyError (cfgSource cfg) t)
Nothing ->
Left (HappyErrorMsg emptyRange "Parse error at the beginning of the file")
errorMessage :: Range -> String -> ParseM a
errorMessage r x = P $ \_ _ _ -> Left (HappyErrorMsg r x)
customError :: String -> Located Token -> ParseM a
customError x t = P $ \_ _ _ -> Left (HappyErrorMsg (srcRange t) x)
expected :: String -> ParseM a
expected x = P $ \cfg _ s ->
Left (HappyUnexpected (cfgSource cfg) (sPrevTok s) x)
mkModName :: [Text] -> ModName
mkModName = packModName
-- Note that type variables are not resolved at this point: they are tcons.
mkSchema :: [TParam PName] -> [Prop PName] -> Type PName -> Schema PName
mkSchema xs ps t = Forall xs ps t Nothing
getName :: Located Token -> PName
getName l = case thing l of
Token (Ident [] x) _ -> mkUnqual (mkIdent x)
_ -> panic "[Parser] getName" ["not an Ident:", show l]
getNum :: Located Token -> Integer
getNum l = case thing l of
Token (Num x _ _) _ -> x
Token (ChrLit x) _ -> toInteger (fromEnum x)
_ -> panic "[Parser] getNum" ["not a number:", show l]
getStr :: Located Token -> String
getStr l = case thing l of
Token (StrLit x) _ -> x
_ -> panic "[Parser] getStr" ["not a string:", show l]
numLit :: TokenT -> Expr PName
numLit (Num x base digs)
| base == 2 = ELit $ ECNum x (BinLit digs)
| base == 8 = ELit $ ECNum x (OctLit digs)
| base == 10 = ELit $ ECNum x DecLit
| base == 16 = ELit $ ECNum x (HexLit digs)
numLit x = panic "[Parser] numLit" ["invalid numeric literal", show x]
intVal :: Located Token -> ParseM Integer
intVal tok =
case tokenType (thing tok) of
Num x _ _ -> return x
_ -> errorMessage (srcRange tok) "Expected an integer"
mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
mkFixity assoc tok qns =
do l <- intVal tok
unless (l >= 1 && l <= 100)
(errorMessage (srcRange tok) "Fixity levels must be between 1 and 100")
return (DFixity (Fixity assoc (fromInteger l)) qns)
mkTupleSel :: Range -> Integer -> ParseM (Located Selector)
mkTupleSel pos n
| n < 0 = errorMessage pos
(show n ++ " is not a valid tuple selector (they start from 0).")
| toInteger asInt /= n = errorMessage pos "Tuple selector is too large."
| otherwise = return $ Located pos $ TupleSel asInt Nothing
where asInt = fromInteger n
fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit loc = case tokenType (thing loc) of
StrLit str -> return loc { thing = str }
_ -> errorMessage (srcRange loc) "Expected a string literal"
validDemotedType :: Range -> Type PName -> ParseM (Type PName)
validDemotedType rng ty =
case ty of
TLocated t r -> validDemotedType r t
TRecord {} -> bad "Record types"
TTuple {} -> bad "Tuple types"
TFun {} -> bad "Function types"
TSeq {} -> bad "Sequence types"
TBit -> bad "Type bit"
TNum {} -> ok
TChar {} -> ok
TWild -> bad "Wildcard types"
TUser {} -> ok
TParens t -> validDemotedType rng t
TInfix{} -> ok
where bad x = errorMessage rng (x ++ " cannot be demoted.")
ok = return $ at rng ty
-- | Input expression are reversed
mkEApp :: [Expr PName] -> Expr PName
mkEApp es@(eLast : _) = at (eFirst,eLast) $ foldl EApp f xs
where
eFirst : rest = reverse es
f : xs = cvtTypeParams eFirst rest
{- Type applications are parsed as `ETypeVal (TRecord fs)` expressions.
Here we associate them with their corresponding functions,
converting them into `EAppT` constructs. For example:
[ f, x, `{ a = 2 }, y ]
becomes
[ f, x ` { a = 2 }, y ]
-}
cvtTypeParams e [] = [e]
cvtTypeParams e (p : ps) =
case toTypeParam p of
Just fs -> cvtTypeParams (EAppT e fs) ps
Nothing -> e : cvtTypeParams p ps
toTypeParam e =
case dropLoc e of
ETypeVal t -> case dropLoc t of
TRecord fs -> Just (map mkTypeInst fs)
_ -> Nothing
_ -> Nothing
mkEApp es = panic "[Parser] mkEApp" ["Unexpected:", show es]
unOp :: Expr PName -> Expr PName -> Expr PName
unOp f x = at (f,x) $ EApp f x
-- Use defaultFixity as a placeholder, it will be fixed during renaming.
binOp :: Expr PName -> Located PName -> Expr PName -> Expr PName
binOp x f y = at (x,y) $ EInfix x f defaultFixity y
-- An element type ascription is allowed to appear on one of the arguments.
eFromTo :: Range -> Expr PName -> Maybe (Expr PName) -> Expr PName -> ParseM (Expr PName)
eFromTo r e1 e2 e3 =
case (asETyped e1, asETyped =<< e2, asETyped e3) of
(Just (e1', t), Nothing, Nothing) -> eFromToType r e1' e2 e3 (Just t)
(Nothing, Just (e2', t), Nothing) -> eFromToType r e1 (Just e2') e3 (Just t)
(Nothing, Nothing, Just (e3', t)) -> eFromToType r e1 e2 e3' (Just t)
(Nothing, Nothing, Nothing) -> eFromToType r e1 e2 e3 Nothing
_ -> errorMessage r "A sequence enumeration may have at most one element type annotation."
where
asETyped (ELocated e _) = asETyped e
asETyped (ETyped e t) = Just (e, t)
asETyped _ = Nothing
eFromToType ::
Range -> Expr PName -> Maybe (Expr PName) -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
eFromToType r e1 e2 e3 t =
EFromTo <$> exprToNumT r e1
<*> mapM (exprToNumT r) e2
<*> exprToNumT r e3
<*> pure t
exprToNumT :: Range -> Expr PName -> ParseM (Type PName)
exprToNumT r expr =
case translateExprToNumT expr of
Just t -> return t
Nothing -> bad
where
bad = errorMessage (fromMaybe r (getLoc expr)) $ unlines
[ "The boundaries of .. sequences should be valid numeric types."
, "The expression `" ++ show expr ++ "` is not."
]
-- | WARNING: This is a bit of a hack.
-- It is used to represent anonymous type applications.
anonRecord :: Maybe Range -> [Type PName] -> Type PName
anonRecord ~(Just r) ts = TRecord (map toField ts)
where noName = Located { srcRange = r, thing = mkIdent (T.pack "") }
toField t = Named { name = noName, value = t }
exportDecl :: Maybe (Located String) -> ExportType -> Decl PName -> TopDecl PName
exportDecl mbDoc e d = Decl TopLevel { tlExport = e
, tlDoc = mbDoc
, tlValue = d }
exportNewtype :: ExportType -> Maybe (Located String) -> Newtype PName ->
TopDecl PName
exportNewtype e d n = TDNewtype TopLevel { tlExport = e
, tlDoc = d
, tlValue = n }
mkParFun :: Maybe (Located String) ->
Located PName ->
Schema PName ->
TopDecl PName
mkParFun mbDoc n s = DParameterFun ParameterFun { pfName = n
, pfSchema = s
, pfDoc = thing <$> mbDoc
, pfFixity = Nothing
}
mkParType :: Maybe (Located String) ->
Located PName ->
Located Kind ->
ParseM (TopDecl PName)
mkParType mbDoc n k =
do num <- P $ \_ _ s -> let nu = sNextTyParamNum s
in Right (nu, s { sNextTyParamNum = nu + 1 })
return (DParameterType
ParameterType { ptName = n
, ptKind = thing k
, ptDoc = thing <$> mbDoc
, ptFixity = Nothing
, ptNumber = num
})
changeExport :: ExportType -> [TopDecl PName] -> [TopDecl PName]
changeExport e = map change
where
change (Decl d) = Decl d { tlExport = e }
change (DPrimType t) = DPrimType t { tlExport = e }
change (TDNewtype n) = TDNewtype n { tlExport = e }
change td@Include{} = td
change (DParameterType {}) = panic "changeExport" ["private type parameter?"]
change (DParameterFun {}) = panic "changeExport" ["private value parameter?"]
change (DParameterConstraint {}) =
panic "changeExport" ["private type constraint parameter?"]
mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst x | nullIdent (thing (name x)) = PosInst (value x)
| otherwise = NamedInst x
mkTParam :: Located Ident -> Maybe Kind -> ParseM (TParam PName)
mkTParam Located { srcRange = rng, thing = n } k
| n == widthIdent = errorMessage rng "`width` is not a valid type parameter name."
| otherwise = return (TParam (mkUnqual n) k (Just rng))
mkTySyn :: Located PName -> [TParam PName] -> Type PName -> ParseM (Decl PName)
mkTySyn ln ps b
| getIdent (thing ln) == widthIdent =
errorMessage (srcRange ln) "`width` is not a valid type synonym name."
| otherwise =
return $ DType $ TySyn ln Nothing ps b
mkPropSyn :: Located PName -> [TParam PName] -> Type PName -> ParseM (Decl PName)
mkPropSyn ln ps b
| getIdent (thing ln) == widthIdent =
errorMessage (srcRange ln) "`width` is not a valid constraint synonym name."
| otherwise =
DProp . PropSyn ln Nothing ps . thing <$> mkProp b
polyTerm :: Range -> Integer -> Integer -> ParseM (Bool, Integer)
polyTerm rng k p
| k == 0 = return (False, p)
| k == 1 = return (True, p)
| otherwise = errorMessage rng "Invalid polynomial coefficient"
mkPoly :: Range -> [ (Bool,Integer) ] -> ParseM (Expr PName)
mkPoly rng terms = mk 0 (map fromInteger bits)
where
w = case terms of
[] -> 0
_ -> 1 + maximum (map (fromInteger . snd) terms)
bits = [ n | (True,n) <- terms ]
mk res [] = return $ ELit $ ECNum res (PolyLit w)
mk res (n : ns)
| testBit res n = errorMessage rng
("Polynomial contains multiple terms with exponent "
++ show n)
| otherwise = mk (setBit res n) ns
-- NOTE: The list of patterns is reversed!
mkProperty :: LPName -> [Pattern PName] -> Expr PName -> Decl PName
mkProperty f ps e = DBind Bind { bName = f
, bParams = reverse ps
, bDef = at e (Located emptyRange (DExpr e))
, bSignature = Nothing
, bPragmas = [PragmaProperty]
, bMono = False
, bInfix = False
, bFixity = Nothing
, bDoc = Nothing
}
-- NOTE: The lists of patterns are reversed!
mkIndexedDecl ::
LPName -> ([Pattern PName], [Pattern PName]) -> Expr PName -> Decl PName
mkIndexedDecl f (ps, ixs) e =
DBind Bind { bName = f
, bParams = reverse ps
, bDef = at e (Located emptyRange (DExpr rhs))
, bSignature = Nothing
, bPragmas = []
, bMono = False
, bInfix = False
, bFixity = Nothing
, bDoc = Nothing
}
where
rhs :: Expr PName
rhs = mkGenerate (reverse ixs) e
-- NOTE: The lists of patterns are reversed!
mkIndexedExpr :: ([Pattern PName], [Pattern PName]) -> Expr PName -> Expr PName
mkIndexedExpr (ps, ixs) body
| null ps = mkGenerate (reverse ixs) body
| otherwise = EFun (reverse ps) (mkGenerate (reverse ixs) body)
mkGenerate :: [Pattern PName] -> Expr PName -> Expr PName
mkGenerate pats body =
foldr (\pat e -> EGenerate (EFun [pat] e)) body pats
mkIf :: [(Expr PName, Expr PName)] -> Expr PName -> Expr PName
mkIf ifThens theElse = foldr addIfThen theElse ifThens
where
addIfThen (cond, doexpr) elseExpr = EIf cond doexpr elseExpr
-- | Generate a signature and a primitive binding. The reason for generating
-- both instead of just adding the signature at this point is that it means the
-- primitive declarations don't need to be treated differently in the noPat
-- pass. This is also the reason we add the doc to the TopLevel constructor,
-- instead of just place it on the binding directly. A better solution might be
-- to just have a different constructor for primitives.
mkPrimDecl ::
Maybe (Located String) -> LPName -> Schema PName -> [TopDecl PName]
mkPrimDecl mbDoc ln sig =
[ exportDecl mbDoc Public
$ DBind Bind { bName = ln
, bParams = []
, bDef = at sig (Located emptyRange DPrim)
, bSignature = Nothing
, bPragmas = []
, bMono = False
, bInfix = isInfixIdent (getIdent (thing ln))
, bFixity = Nothing
, bDoc = Nothing
}
, exportDecl Nothing Public
$ DSignature [ln] sig
]
mkPrimTypeDecl ::
Maybe (Located String) ->
Schema PName ->
Located Kind ->
ParseM [TopDecl PName]
mkPrimTypeDecl mbDoc (Forall as qs st ~(Just schema_rng)) finK =
case splitT schema_rng st of
Just (n,xs) ->
do vs <- mapM tpK as
unless (distinct (map fst vs)) $
errorMessage schema_rng "Repeated parameterms."
let kindMap = Map.fromList vs
lkp v = case Map.lookup (thing v) kindMap of
Just (k,tp) -> pure (k,tp)
Nothing ->
errorMessage
(srcRange v)
("Undefined parameter: " ++ show (pp (thing v)))
(as',ins) <- unzip <$> mapM lkp xs
unless (length vs == length xs) $
errorMessage schema_rng "All parameters should appear in the type."
let ki = finK { thing = foldr KFun (thing finK) ins }
pure [ DPrimType TopLevel
{ tlExport = Public
, tlDoc = mbDoc
, tlValue = PrimType { primTName = n
, primTKind = ki
, primTCts = (as',qs)
, primTFixity = Nothing
}
}
]
Nothing -> errorMessage schema_rng "Invalid primitive signature"
where
splitT r ty = case ty of
TLocated t r1 -> splitT r1 t
TUser n ts -> mkT r Located { srcRange = r, thing = n } ts
TInfix t1 n _ t2 -> mkT r n [t1,t2]
_ -> Nothing
mkT r n ts = do ts1 <- mapM (isVar r) ts
guard (distinct (map thing ts1))
pure (n,ts1)
isVar r ty = case ty of
TLocated t r1 -> isVar r1 t
TUser n [] -> Just Located { srcRange = r, thing = n }
_ -> Nothing
-- inefficient, but the lists should be small
distinct xs = case xs of
[] -> True
x : ys -> not (x `elem` ys) && distinct ys
tpK tp = case tpKind tp of
Just k -> pure (tpName tp, (tp,k))
Nothing ->
case tpRange tp of
Just r -> errorMessage r "Parameters need a kind annotation"
Nothing -> panic "mkPrimTypeDecl"
[ "Missing range on schema parameter." ]
-- | Fix-up the documentation strings by removing the comment delimiters on each
-- end, and stripping out common prefixes on all the remaining lines.
mkDoc :: Located Text -> Located String
mkDoc ltxt = ltxt { thing = docStr }
where
docStr = unlines
$ map T.unpack
$ dropPrefix
$ trimFront
$ T.lines
$ T.dropWhileEnd commentChar
$ thing ltxt
commentChar :: Char -> Bool
commentChar x = x `elem` ("/* \r\n\t" :: String)
prefixDroppable x = x `elem` ("* \r\n\t" :: String)
trimFront [] = []
trimFront (l:ls)
| T.all commentChar l = ls
| otherwise = T.dropWhile commentChar l : ls
dropPrefix [] = []
dropPrefix [t] = [T.dropWhile commentChar t]
dropPrefix ts@(l:ls) =
case T.uncons l of
Just (c,_) | prefixDroppable c &&
all (commonPrefix c) ls -> dropPrefix (map (T.drop 1) ts)
_ -> ts
where
commonPrefix c t =
case T.uncons t of
Just (c',_) -> c == c'
Nothing -> False
distrLoc :: Located [a] -> [Located a]
distrLoc x = [ Located { srcRange = r, thing = a } | a <- thing x ]
where r = srcRange x
mkProp :: Type PName -> ParseM (Located [Prop PName])
mkProp ty =
case ty of
TLocated t r -> Located r `fmap` props r t
_ -> panic "Parser" [ "Invalid type given to mkProp"
, "expected a location"
, show ty ]
where
props r t =
case t of
TInfix{} -> return [CType t]
TUser{} -> return [CType t]
TTuple ts -> concat `fmap` mapM (props r) ts
TParens t' -> props r t'
TLocated t' r' -> props r' t'
TFun{} -> err
TSeq{} -> err
TBit{} -> err
TNum{} -> err
TChar{} -> err
TWild -> err
TRecord{} -> err
where
err = errorMessage r "Invalid constraint"
-- | Make an ordinary module
mkModule :: Located ModName ->
([Located Import], [TopDecl PName]) ->
Module PName
mkModule nm (is,ds) = Module { mName = nm
, mInstance = Nothing
, mImports = is
, mDecls = ds
}
-- | Make an unnamed module---gets the name @Main@.
mkAnonymousModule :: ([Located Import], [TopDecl PName]) ->
Module PName
mkAnonymousModule = mkModule Located { srcRange = emptyRange
, thing = mkModName [T.pack "Main"]
}
-- | Make a module which defines a functor instance.
mkModuleInstance :: Located ModName ->
Located ModName ->
([Located Import], [TopDecl PName]) ->
Module PName
mkModuleInstance nm fun (is,ds) =
Module { mName = nm
, mInstance = Just fun
, mImports = is
, mDecls = ds
}
ufToNamed :: UpdField PName -> ParseM (Named (Expr PName))
ufToNamed (UpdField h ls e) =
case (h,ls) of
(UpdSet, [l]) | RecordSel i Nothing <- thing l ->
pure Named { name = l { thing = i }, value = e }
_ -> errorMessage (srcRange (head ls))
"Invalid record field. Perhaps you meant to update a record?"
selExprToSels :: Expr PName -> ParseM [Located Selector]
selExprToSels e0 = reverse <$> go noLoc e0
where
noLoc = panic "selExprToSels" ["Missing location?"]
go loc expr =
case expr of
ELocated e1 r -> go r e1
ESel e2 s ->
do ls <- go loc e2
let rng = loc { from = to (srcRange (head ls)) }
pure (Located { thing = s, srcRange = rng } : ls)
EVar (UnQual l) ->
pure [ Located { thing = RecordSel l Nothing, srcRange = loc } ]
ELit (ECNum n _) ->
pure [ Located { thing = TupleSel (fromInteger n) Nothing
, srcRange = loc } ]
_ -> errorMessage loc "Invalid label in record update."
cryptol-2.8.0/src/Cryptol/Parser/Position.hs 0000644 0000000 0000000 00000007215 07346545000 017232 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Parser.Position
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.Parser.Position where
import Data.Text(Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Control.DeepSeq
import Cryptol.Utils.PP
data Located a = Located { srcRange :: !Range, thing :: !a }
deriving (Eq, Show, Generic, NFData)
data Position = Position { line :: !Int, col :: !Int }
deriving (Eq, Ord, Show, Generic, NFData)
data Range = Range { from :: !Position
, to :: !Position
, source :: FilePath }
deriving (Eq, Show, Generic, NFData)
-- | An empty range.
--
-- Caution: using this on the LHS of a use of rComb will cause the empty source
-- to propagate.
emptyRange :: Range
emptyRange = Range { from = start, to = start, source = "" }
start :: Position
start = Position { line = 1, col = 1 }
move :: Position -> Char -> Position
move p c = case c of
'\t' -> p { col = ((col p + 7) `div` 8) * 8 + 1 }
'\n' -> p { col = 1, line = 1 + line p }
_ -> p { col = 1 + col p }
moves :: Position -> Text -> Position
moves p cs = T.foldl' move p cs
rComb :: Range -> Range -> Range
rComb r1 r2 = Range { from = rFrom, to = rTo, source = source r1 }
where rFrom = min (from r1) (from r2)
rTo = max (to r1) (to r2)
rCombs :: [Range] -> Range
rCombs = foldl1 rComb
instance Functor Located where
fmap f l = l { thing = f (thing l) }
--------------------------------------------------------------------------------
instance PP Position where
ppPrec _ p = int (line p) <.> colon <.> int (col p)
instance PP Range where
ppPrec _ r = text (source r) <.> char ':'
<.> pp (from r) <.> text "--" <.> pp (to r)
instance PP a => PP (Located a) where
ppPrec _ l = parens (text "at" <+> pp (srcRange l) <.> comma <+> pp (thing l))
instance PPName a => PPName (Located a) where
ppNameFixity Located { .. } = ppNameFixity thing
ppPrefixName Located { .. } = ppPrefixName thing
ppInfixName Located { .. } = ppInfixName thing
--------------------------------------------------------------------------------
class HasLoc t where
getLoc :: t -> Maybe Range
instance HasLoc Range where
getLoc r = Just r
instance HasLoc (Located a) where
getLoc r = Just (srcRange r)
instance (HasLoc a, HasLoc b) => HasLoc (a,b) where
getLoc (f,t) = case getLoc f of
Nothing -> getLoc t
Just l ->
case getLoc t of
Nothing -> return l
Just l1 -> return (rComb l l1)
instance HasLoc a => HasLoc [a] where
getLoc = go Nothing
where
go x [] = x
go Nothing (x : xs) = go (getLoc x) xs
go (Just l) (x : xs) = case getLoc x of
Nothing -> go (Just l) xs
Just l1 -> go (Just (rComb l l1)) xs
class HasLoc t => AddLoc t where
addLoc :: t -> Range -> t
dropLoc :: t -> t
instance AddLoc (Located a) where
addLoc t r = t { srcRange = r }
dropLoc r = r
at :: (HasLoc l, AddLoc t) => l -> t -> t
at l e = maybe e (addLoc e) (getLoc l)
combLoc :: (a -> b -> c) -> Located a -> Located b -> Located c
combLoc f l1 l2 = Located { srcRange = rComb (srcRange l1) (srcRange l2)
, thing = f (thing l1) (thing l2)
}
cryptol-2.8.0/src/Cryptol/Parser/Selector.hs 0000644 0000000 0000000 00000005111 07346545000 017177 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Parser.Selector
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Parser.Selector
( Selector(..)
, ppSelector
, ppNestedSels
, selName
) where
import GHC.Generics (Generic)
import Control.DeepSeq
import Data.List(intersperse)
import Cryptol.Utils.Ident
import Cryptol.Utils.PP
{- | Selectors are used for projecting from various components.
Each selector has an option spec to specify the shape of the thing
that is being selected. Currently, there is no surface syntax for
list selectors, but they are used during the desugaring of patterns.
-}
data Selector = TupleSel Int (Maybe Int)
-- ^ Zero-based tuple selection.
-- Optionally specifies the shape of the tuple (one-based).
| RecordSel Ident (Maybe [Ident])
-- ^ Record selection.
-- Optionally specifies the shape of the record.
| ListSel Int (Maybe Int)
-- ^ List selection.
-- Optionally specifies the length of the list.
deriving (Eq, Show, Ord, Generic, NFData)
instance PP Selector where
ppPrec _ sel =
case sel of
TupleSel x sig -> int x <+> ppSig tupleSig sig
RecordSel x sig -> pp x <+> ppSig recordSig sig
ListSel x sig -> int x <+> ppSig listSig sig
where
tupleSig n = int n
recordSig xs = braces $ fsep $ punctuate comma $ map pp xs
listSig n = int n
ppSig f = maybe empty (\x -> text "/* of" <+> f x <+> text "*/")
-- | Display the thing selected by the selector, nicely.
ppSelector :: Selector -> Doc
ppSelector sel =
case sel of
TupleSel x _ -> ordinal (x+1) <+> text "field"
RecordSel x _ -> text "field" <+> pp x
ListSel x _ -> ordinal x <+> text "element"
-- | The name of a selector (e.g., used in update code)
selName :: Selector -> Ident
selName s =
case s of
RecordSel i _ -> i
TupleSel n _ -> packIdent ("_" ++ show n)
ListSel n _ -> packIdent ("__" ++ show n)
-- | Show a list of selectors as they appear in a nested selector in an update.
ppNestedSels :: [Selector] -> Doc
ppNestedSels = hcat . intersperse "." . map ppS
where ppS s = case s of
RecordSel i _ -> text (unpackIdent i)
TupleSel n _ -> int n
ListSel n _ -> brackets (int n) -- not in source
cryptol-2.8.0/src/Cryptol/Parser/Unlit.hs 0000644 0000000 0000000 00000007570 07346545000 016525 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Parser.Unlit
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- Convert a literate source file into an ordinary source file.
{-# LANGUAGE OverloadedStrings, Safe, PatternGuards #-}
module Cryptol.Parser.Unlit
( unLit, PreProc(..), guessPreProc, knownExts
) where
import Data.Text(Text)
import qualified Data.Text as Text
import Data.Char(isSpace)
import System.FilePath(takeExtension)
import Cryptol.Utils.Panic
data PreProc = None | Markdown | LaTeX
knownExts :: [String]
knownExts =
[ "cry"
, "tex"
, "markdown"
, "md"
]
guessPreProc :: FilePath -> PreProc
guessPreProc file = case takeExtension file of
".tex" -> LaTeX
".markdown" -> Markdown
".md" -> Markdown
_ -> None
unLit :: PreProc -> Text -> Text
unLit None = id
unLit proc = Text.unlines . concatMap toCryptol . preProc proc . Text.lines
preProc :: PreProc -> [Text] -> [Block]
preProc p =
case p of
None -> return . Code
Markdown -> markdown
LaTeX -> latex
data Block = Code [Text] | Comment [Text]
toCryptol :: Block -> [Text]
toCryptol (Code xs) = xs
toCryptol (Comment ls) =
case ls of
[] -> []
[l] -> [ "/* " `Text.append` l `Text.append` " */" ]
l1 : rest -> let (more, l) = splitLast rest
in "/* " `Text.append` l1 : more ++ [ l `Text.append` " */" ]
where
splitLast [] = panic "Cryptol.Parser.Unlit.toCryptol" [ "splitLast []" ]
splitLast [x] = ([], x)
splitLast (x : xs) = let (ys,y) = splitLast xs
in (x:ys,y)
mk :: ([Text] -> Block) -> [Text] -> [Block]
mk _ [] = []
mk c ls = [ c (reverse ls) ]
-- | The preprocessor for `markdown`
markdown :: [Text] -> [Block]
markdown = blanks []
where
comment current [] = mk Comment current
comment current (l : ls)
| isBlank l = blanks (l : current) ls
| otherwise = comment (l : current) ls
blanks current [] = mk Comment current
blanks current (l : ls)
| isCodeLine l = mk Comment current ++ code [l] ls
| Just op <- isOpenFence l = mk Comment (l : current) ++ fenced op [] ls
| isBlank l = blanks (l : current) ls
| otherwise = comment (l : current) ls
code current [] = mk Code current
code current (l : ls)
| isCodeLine l = code (l : current) ls
| otherwise = mk Code current ++ comment [] (l : ls)
fenced op current [] = mk op current -- XXX should this be an error?
fenced op current (l : ls)
| isCloseFence l = mk op current ++ comment [l] ls
| otherwise = fenced op (l : current) ls
isOpenFence l
| "```" `Text.isPrefixOf` l' =
Just $ case Text.drop 3 l' of
l'' | "cryptol" `Text.isPrefixOf` l'' -> Code
| isBlank l'' -> Code
| otherwise -> Comment
| otherwise = Nothing
where
l' = Text.dropWhile isSpace l
isCloseFence l = "```" `Text.isPrefixOf` l
isBlank l = Text.all isSpace l
isCodeLine l = "\t" `Text.isPrefixOf` l || " " `Text.isPrefixOf` l
-- | The preprocessor for `latex`
latex :: [Text] -> [Block]
latex = comment []
where
comment current [] = mk Comment current
comment current (l : ls)
| isBeginCode l = mk Comment (l : current) ++ code [] ls
| otherwise = comment (l : current) ls
code current [] = mk Code current
code current (l : ls)
| isEndCode l = mk Code current ++ comment [l] ls
| otherwise = code (l : current) ls
isBeginCode l = "\\begin{code}" `Text.isPrefixOf` l
isEndCode l = "\\end{code}" `Text.isPrefixOf` l
cryptol-2.8.0/src/Cryptol/Parser/Utils.hs 0000644 0000000 0000000 00000003152 07346545000 016522 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Parser.Utils
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- Utility functions that are also useful for translating programs
-- from previous Cryptol versions.
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Parser.Utils
( translateExprToNumT
, widthIdent
) where
import Cryptol.Parser.AST
widthIdent :: Ident
widthIdent = mkIdent "width"
underIdent :: Ident
underIdent = mkIdent "_"
translateExprToNumT :: Expr PName -> Maybe (Type PName)
translateExprToNumT expr =
case expr of
ELocated e r -> (`TLocated` r) `fmap` translateExprToNumT e
EVar n | getIdent n == widthIdent -> pure (TUser n [])
| getIdent n == underIdent -> pure TWild
EVar x -> return (TUser x [])
ELit x -> cvtLit x
EApp e1 e2 -> do t1 <- translateExprToNumT e1
t2 <- translateExprToNumT e2
tApp t1 t2
EInfix a o f b -> do e1 <- translateExprToNumT a
e2 <- translateExprToNumT b
return (TInfix e1 o f e2)
EParens e -> do t <- translateExprToNumT e
return (TParens t)
_ -> Nothing
where
tApp ty t =
case ty of
TLocated t1 r -> (`TLocated` r) `fmap` tApp t1 t
TUser f ts -> return (TUser f (ts ++ [t]))
_ -> Nothing
cvtLit (ECNum n CharLit) = return (TChar $ toEnum $ fromInteger n)
cvtLit (ECNum n _) = return (TNum n)
cvtLit (ECString _) = Nothing
cryptol-2.8.0/src/Cryptol/Prelude.hs 0000644 0000000 0000000 00000001301 07346545000 015560 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Prelude
-- Copyright : (c) 2015-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- Compile the prelude into the executable as a last resort
{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Prelude (preludeContents,cryptolTcContents) where
import Data.ByteString(ByteString)
import qualified Data.ByteString.Char8 as B
import Text.Heredoc (there)
preludeContents :: ByteString
preludeContents = B.pack [there|lib/Cryptol.cry|]
cryptolTcContents :: String
cryptolTcContents = [there|lib/CryptolTC.z3|]
cryptol-2.8.0/src/Cryptol/Prims/ 0000755 0000000 0000000 00000000000 07346545000 014723 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/Prims/Eval.hs 0000644 0000000 0000000 00000146174 07346545000 016163 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Prims.Eval
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Cryptol.Prims.Eval where
import Control.Monad (join, unless)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..),fromNat,genLog, nMul)
import Cryptol.Eval.Monad
import Cryptol.Eval.Type
import Cryptol.Eval.Value
import Cryptol.Testing.Random (randomValue)
import Cryptol.Utils.Panic (panic)
import Cryptol.ModuleSystem.Name (asPrim)
import Cryptol.Utils.Ident (Ident,mkIdent)
import Cryptol.Utils.PP
import Cryptol.Utils.Logger(logPrint)
import qualified Data.Foldable as Fold
import Data.List (sortBy)
import qualified Data.Sequence as Seq
import Data.Ord (comparing)
import Data.Bits (Bits(..))
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import System.Random.TF.Gen (seedTFGen)
-- Primitives ------------------------------------------------------------------
instance EvalPrims Bool BV Integer where
evalPrim Decl { dName = n, .. } =
do prim <- asPrim n
Map.lookup prim primTable
iteValue b t f = if b then t else f
primTable :: Map.Map Ident Value
primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
[ ("+" , {-# SCC "Prelude::(+)" #-}
binary (arithBinary (liftBinArith (+)) (liftBinInteger (+))
(liftBinIntMod (+))))
, ("-" , {-# SCC "Prelude::(-)" #-}
binary (arithBinary (liftBinArith (-)) (liftBinInteger (-))
(liftBinIntMod (-))))
, ("*" , {-# SCC "Prelude::(*)" #-}
binary (arithBinary (liftBinArith (*)) (liftBinInteger (*))
(liftBinIntMod (*))))
, ("/" , {-# SCC "Prelude::(/)" #-}
binary (arithBinary (liftDivArith div) (liftDivInteger div)
(const (liftDivInteger div))))
, ("%" , {-# SCC "Prelude::(%)" #-}
binary (arithBinary (liftDivArith mod) (liftDivInteger mod)
(const (liftDivInteger mod))))
, ("^^" , {-# SCC "Prelude::(^^)" #-}
binary (arithBinary modExp integerExp intModExp))
, ("lg2" , {-# SCC "Prelude::lg2" #-}
unary (arithUnary (liftUnaryArith lg2) integerLg2 (const integerLg2)))
, ("negate" , {-# SCC "Prelude::negate" #-}
unary (arithUnary (liftUnaryArith negate) integerNeg intModNeg))
, ("<" , {-# SCC "Prelude::(<)" #-}
binary (cmpOrder "<" (\o -> o == LT )))
, (">" , {-# SCC "Prelude::(>)" #-}
binary (cmpOrder ">" (\o -> o == GT )))
, ("<=" , {-# SCC "Prelude::(<=)" #-}
binary (cmpOrder "<=" (\o -> o == LT || o == EQ)))
, (">=" , {-# SCC "Prelude::(>=)" #-}
binary (cmpOrder ">=" (\o -> o == GT || o == EQ)))
, ("==" , {-# SCC "Prelude::(==)" #-}
binary (cmpOrder "==" (\o -> o == EQ)))
, ("!=" , {-# SCC "Prelude::(!=)" #-}
binary (cmpOrder "!=" (\o -> o /= EQ)))
, ("<$" , {-# SCC "Prelude::(<$)" #-}
binary (signedCmpOrder "<$" (\o -> o == LT)))
, ("/$" , {-# SCC "Prelude::(/$)" #-}
binary (arithBinary (liftSigned bvSdiv) (liftDivInteger div)
(const (liftDivInteger div))))
, ("%$" , {-# SCC "Prelude::(%$)" #-}
binary (arithBinary (liftSigned bvSrem) (liftDivInteger mod)
(const (liftDivInteger mod))))
, (">>$" , {-# SCC "Prelude::(>>$)" #-}
sshrV)
, ("&&" , {-# SCC "Prelude::(&&)" #-}
binary (logicBinary (.&.) (binBV (.&.))))
, ("||" , {-# SCC "Prelude::(||)" #-}
binary (logicBinary (.|.) (binBV (.|.))))
, ("^" , {-# SCC "Prelude::(^)" #-}
binary (logicBinary xor (binBV xor)))
, ("complement" , {-# SCC "Prelude::complement" #-}
unary (logicUnary complement (unaryBV complement)))
, ("toInteger" , ecToIntegerV)
, ("fromInteger", ecFromIntegerV (flip mod))
, ("fromZ" , {-# SCC "Prelude::fromZ" #-}
nlam $ \ _modulus ->
lam $ \ x -> x)
, ("<<" , {-# SCC "Prelude::(<<)" #-}
logicShift shiftLW shiftLB shiftLS)
, (">>" , {-# SCC "Prelude::(>>)" #-}
logicShift shiftRW shiftRB shiftRS)
, ("<<<" , {-# SCC "Prelude::(<<<)" #-}
logicShift rotateLW rotateLB rotateLS)
, (">>>" , {-# SCC "Prelude::(>>>)" #-}
logicShift rotateRW rotateRB rotateRS)
, ("True" , VBit True)
, ("False" , VBit False)
, ("carry" , {-# SCC "Prelude::carry" #-}
carryV)
, ("scarry" , {-# SCC "Prelude::scarry" #-}
scarryV)
, ("number" , {-# SCC "Prelude::number" #-}
ecNumberV)
, ("#" , {-# SCC "Prelude::(#)" #-}
nlam $ \ front ->
nlam $ \ back ->
tlam $ \ elty ->
lam $ \ l -> return $
lam $ \ r -> join (ccatV front back elty <$> l <*> r))
, ("@" , {-# SCC "Prelude::(@)" #-}
indexPrim indexFront_bits indexFront)
, ("!" , {-# SCC "Prelude::(!)" #-}
indexPrim indexBack_bits indexBack)
, ("update" , {-# SCC "Prelude::update" #-}
updatePrim updateFront_word updateFront)
, ("updateEnd" , {-# SCC "Prelude::updateEnd" #-}
updatePrim updateBack_word updateBack)
, ("zero" , {-# SCC "Prelude::zero" #-}
tlam zeroV)
, ("join" , {-# SCC "Prelude::join" #-}
nlam $ \ parts ->
nlam $ \ (finNat' -> each) ->
tlam $ \ a ->
lam $ \ x ->
joinV parts each a =<< x)
, ("split" , {-# SCC "Prelude::split" #-}
ecSplitV)
, ("splitAt" , {-# SCC "Prelude::splitAt" #-}
nlam $ \ front ->
nlam $ \ back ->
tlam $ \ a ->
lam $ \ x ->
splitAtV front back a =<< x)
, ("fromTo" , {-# SCC "Prelude::fromTo" #-}
fromToV)
, ("fromThenTo" , {-# SCC "Prelude::fromThenTo" #-}
fromThenToV)
, ("infFrom" , {-# SCC "Prelude::infFrom" #-}
infFromV)
, ("infFromThen", {-# SCC "Prelude::infFromThen" #-}
infFromThenV)
, ("error" , {-# SCC "Prelude::error" #-}
tlam $ \a ->
nlam $ \_ ->
lam $ \s -> errorV a =<< (fromStr =<< s))
, ("reverse" , {-# SCC "Prelude::reverse" #-}
nlam $ \_a ->
tlam $ \_b ->
lam $ \xs -> reverseV =<< xs)
, ("transpose" , {-# SCC "Prelude::transpose" #-}
nlam $ \a ->
nlam $ \b ->
tlam $ \c ->
lam $ \xs -> transposeV a b c =<< xs)
, ("random" , {-# SCC "Prelude::random" #-}
tlam $ \a ->
wlam $ \(bvVal -> x) -> return $ randomV a x)
, ("trace" , {-# SCC "Prelude::trace" #-}
nlam $ \_n ->
tlam $ \_a ->
tlam $ \_b ->
lam $ \s -> return $
lam $ \x -> return $
lam $ \y -> do
msg <- fromStr =<< s
EvalOpts { evalPPOpts, evalLogger } <- getEvalOpts
doc <- ppValue evalPPOpts =<< x
yv <- y
io $ logPrint evalLogger
$ if null msg then doc else text msg <+> doc
return yv)
]
-- | Make a numeric literal value at the given type.
mkLit :: BitWord b w i => TValue -> Integer -> GenValue b w i
mkLit ty =
case ty of
TVInteger -> VInteger . integerLit
TVIntMod _ -> VInteger . integerLit
TVSeq w TVBit -> word w
_ -> evalPanic "Cryptol.Eval.Prim.evalConst"
[ "Invalid type for number" ]
-- | Make a numeric constant.
ecNumberV :: BitWord b w i => GenValue b w i
ecNumberV = nlam $ \valT ->
tlam $ \ty ->
case valT of
Nat v -> mkLit ty v
_ -> evalPanic "Cryptol.Eval.Prim.evalConst"
["Unexpected Inf in constant."
, show valT
, show ty
]
-- | Convert a word to a non-negative integer.
ecToIntegerV :: BitWord b w i => GenValue b w i
ecToIntegerV =
nlam $ \ _ ->
wlam $ \ w -> return $ VInteger (wordToInt w)
-- | Convert an unbounded integer to a packed bitvector.
ecFromIntegerV :: BitWord b w i => (Integer -> i -> i) -> GenValue b w i
ecFromIntegerV opz =
tlam $ \ a ->
lam $ \ x ->
do i <- fromVInteger <$> x
return $ arithNullary (flip wordFromInt i) i (flip opz i) a
--------------------------------------------------------------------------------
-- | Create a packed word
modExp :: Integer -- ^ bit size of the resulting word
-> BV -- ^ base
-> BV -- ^ exponent
-> Eval BV
modExp bits (BV _ base) (BV _ e)
| bits == 0 = ready $ BV bits 0
| base < 0 || bits < 0 = evalPanic "modExp"
[ "bad args: "
, " base = " ++ show base
, " e = " ++ show e
, " bits = " ++ show modulus
]
| otherwise = ready $ mkBv bits $ doubleAndAdd base e modulus
where
modulus = 0 `setBit` fromInteger bits
intModExp :: Integer -> Integer -> Integer -> Eval Integer
intModExp modulus base e
| modulus > 0 = ready $ doubleAndAdd base e modulus
| modulus == 0 = integerExp base e
| otherwise = evalPanic "intModExp" [ "negative modulus: " ++ show modulus ]
integerExp :: Integer -> Integer -> Eval Integer
integerExp x y
| y < 0 = negativeExponent
| otherwise = ready $ x ^ y
integerLg2 :: Integer -> Eval Integer
integerLg2 x
| x < 0 = logNegative
| otherwise = ready $ lg2 x
integerNeg :: Integer -> Eval Integer
integerNeg x = ready $ negate x
intModNeg :: Integer -> Integer -> Eval Integer
intModNeg modulus x = ready $ negate x `mod` modulus
doubleAndAdd :: Integer -- ^ base
-> Integer -- ^ exponent mask
-> Integer -- ^ modulus
-> Integer
doubleAndAdd base0 expMask modulus = go 1 base0 expMask
where
go acc base k
| k > 0 = acc' `seq` base' `seq` go acc' base' (k `shiftR` 1)
| otherwise = acc
where
acc' | k `testBit` 0 = acc `modMul` base
| otherwise = acc
base' = base `modMul` base
modMul x y = (x * y) `mod` modulus
-- Operation Lifting -----------------------------------------------------------
type Binary b w i = TValue -> GenValue b w i -> GenValue b w i -> Eval (GenValue b w i)
binary :: Binary b w i -> GenValue b w i
binary f = tlam $ \ ty ->
lam $ \ a -> return $
lam $ \ b -> do
--io $ putStrLn "Entering a binary function"
join (f ty <$> a <*> b)
type Unary b w i = TValue -> GenValue b w i -> Eval (GenValue b w i)
unary :: Unary b w i -> GenValue b w i
unary f = tlam $ \ ty ->
lam $ \ a -> f ty =<< a
-- Arith -----------------------------------------------------------------------
-- | Turn a normal binop on Integers into one that can also deal with a bitsize.
-- However, if the bitvector size is 0, always return the 0
-- bitvector.
liftBinArith :: (Integer -> Integer -> Integer) -> BinArith BV
liftBinArith _ 0 _ _ = ready $ mkBv 0 0
liftBinArith op w (BV _ x) (BV _ y) = ready $ mkBv w $ op x y
-- | Turn a normal binop on Integers into one that can also deal with a bitsize.
-- Generate a thunk that throws a divide by 0 error when forced if the second
-- argument is 0. However, if the bitvector size is 0, always return the 0
-- bitvector.
liftDivArith :: (Integer -> Integer -> Integer) -> BinArith BV
liftDivArith _ 0 _ _ = ready $ mkBv 0 0
liftDivArith _ _ _ (BV _ 0) = divideByZero
liftDivArith op w (BV _ x) (BV _ y) = ready $ mkBv w $ op x y
type BinArith w = Integer -> w -> w -> Eval w
liftBinInteger :: (Integer -> Integer -> Integer) -> Integer -> Integer -> Eval Integer
liftBinInteger op x y = ready $ op x y
liftBinIntMod ::
(Integer -> Integer -> Integer) -> Integer -> Integer -> Integer -> Eval Integer
liftBinIntMod op m x y
| m == 0 = ready $ op x y
| otherwise = ready $ (op x y) `mod` m
liftDivInteger :: (Integer -> Integer -> Integer) -> Integer -> Integer -> Eval Integer
liftDivInteger _ _ 0 = divideByZero
liftDivInteger op x y = ready $ op x y
modWrap :: Integral a => a -> a -> Eval a
modWrap _ 0 = divideByZero
modWrap x y = return (x `mod` y)
arithBinary :: forall b w i
. BitWord b w i
=> BinArith w
-> (i -> i -> Eval i)
-> (Integer -> i -> i -> Eval i)
-> Binary b w i
arithBinary opw opi opz = loop
where
loop' :: TValue
-> Eval (GenValue b w i)
-> Eval (GenValue b w i)
-> Eval (GenValue b w i)
loop' ty l r = join (loop ty <$> l <*> r)
loop :: TValue
-> GenValue b w i
-> GenValue b w i
-> Eval (GenValue b w i)
loop ty l r = case ty of
TVBit ->
evalPanic "arithBinary" ["Bit not in class Arith"]
TVInteger ->
VInteger <$> opi (fromVInteger l) (fromVInteger r)
TVIntMod n ->
VInteger <$> opz n (fromVInteger l) (fromVInteger r)
TVSeq w a
-- words and finite sequences
| isTBit a -> do
lw <- fromVWord "arithLeft" l
rw <- fromVWord "arithRight" r
return $ VWord w (WordVal <$> opw w lw rw)
| otherwise -> VSeq w <$> (join (zipSeqMap (loop a) <$>
(fromSeq "arithBinary left" l) <*>
(fromSeq "arithBinary right" r)))
TVStream a ->
-- streams
VStream <$> (join (zipSeqMap (loop a) <$>
(fromSeq "arithBinary left" l) <*>
(fromSeq "arithBinary right" r)))
-- functions
TVFun _ ety ->
return $ lam $ \ x -> loop' ety (fromVFun l x) (fromVFun r x)
-- tuples
TVTuple tys ->
do ls <- mapM (delay Nothing) (fromVTuple l)
rs <- mapM (delay Nothing) (fromVTuple r)
return $ VTuple (zipWith3 loop' tys ls rs)
-- records
TVRec fs ->
do fs' <- sequence
[ (f,) <$> delay Nothing (loop' fty (lookupRecord f l) (lookupRecord f r))
| (f,fty) <- fs
]
return $ VRecord fs'
TVAbstract {} ->
evalPanic "arithBinary" ["Abstract type not in `Arith`"]
type UnaryArith w = Integer -> w -> Eval w
liftUnaryArith :: (Integer -> Integer) -> UnaryArith BV
liftUnaryArith op w (BV _ x) = ready $ mkBv w $ op x
arithUnary :: forall b w i
. BitWord b w i
=> UnaryArith w
-> (i -> Eval i)
-> (Integer -> i -> Eval i)
-> Unary b w i
arithUnary opw opi opz = loop
where
loop' :: TValue -> Eval (GenValue b w i) -> Eval (GenValue b w i)
loop' ty x = loop ty =<< x
loop :: TValue -> GenValue b w i -> Eval (GenValue b w i)
loop ty x = case ty of
TVBit ->
evalPanic "arithUnary" ["Bit not in class Arith"]
TVInteger ->
VInteger <$> opi (fromVInteger x)
TVIntMod n ->
VInteger <$> opz n (fromVInteger x)
TVSeq w a
-- words and finite sequences
| isTBit a -> do
wx <- fromVWord "arithUnary" x
return $ VWord w (WordVal <$> opw w wx)
| otherwise -> VSeq w <$> (mapSeqMap (loop a) =<< fromSeq "arithUnary" x)
TVStream a ->
VStream <$> (mapSeqMap (loop a) =<< fromSeq "arithUnary" x)
-- functions
TVFun _ ety ->
return $ lam $ \ y -> loop' ety (fromVFun x y)
-- tuples
TVTuple tys ->
do as <- mapM (delay Nothing) (fromVTuple x)
return $ VTuple (zipWith loop' tys as)
-- records
TVRec fs ->
do fs' <- sequence
[ (f,) <$> delay Nothing (loop' fty (lookupRecord f x))
| (f,fty) <- fs
]
return $ VRecord fs'
TVAbstract {} -> evalPanic "arithUnary" ["Abstract type not in `Arith`"]
arithNullary ::
forall b w i.
BitWord b w i =>
(Integer -> w) ->
i ->
(Integer -> i) ->
TValue -> GenValue b w i
arithNullary opw opi opz = loop
where
loop :: TValue -> GenValue b w i
loop ty =
case ty of
TVBit -> evalPanic "arithNullary" ["Bit not in class Arith"]
TVInteger -> VInteger opi
TVIntMod n -> VInteger (opz n)
TVSeq w a
-- words and finite sequences
| isTBit a -> VWord w $ ready $ WordVal $ opw w
| otherwise -> VSeq w $ IndexSeqMap $ const $ ready $ loop a
TVStream a -> VStream $ IndexSeqMap $ const $ ready $ loop a
TVFun _ b -> lam $ const $ ready $ loop b
TVTuple tys -> VTuple $ map (ready . loop) tys
TVRec fs -> VRecord [ (f, ready (loop a)) | (f, a) <- fs ]
TVAbstract {} ->
evalPanic "arithNullary" ["Abstract type not in `Arith`"]
lg2 :: Integer -> Integer
lg2 i = case genLog i 2 of
Just (i',isExact) | isExact -> i'
| otherwise -> i' + 1
Nothing -> 0
addV :: BitWord b w i => Binary b w i
addV = arithBinary opw opi opz
where
opw _w x y = ready $ wordPlus x y
opi x y = ready $ intPlus x y
opz m x y = ready $ intModPlus m x y
subV :: BitWord b w i => Binary b w i
subV = arithBinary opw opi opz
where
opw _w x y = ready $ wordMinus x y
opi x y = ready $ intMinus x y
opz m x y = ready $ intModMinus m x y
mulV :: BitWord b w i => Binary b w i
mulV = arithBinary opw opi opz
where
opw _w x y = ready $ wordMult x y
opi x y = ready $ intMult x y
opz m x y = ready $ intModMult m x y
intV :: BitWord b w i => i -> TValue -> GenValue b w i
intV i = arithNullary (flip wordFromInt i) i (const i)
-- Cmp -------------------------------------------------------------------------
cmpValue :: BitWord b w i
=> (b -> b -> Eval a -> Eval a)
-> (w -> w -> Eval a -> Eval a)
-> (i -> i -> Eval a -> Eval a)
-> (Integer -> i -> i -> Eval a -> Eval a)
-> (TValue -> GenValue b w i -> GenValue b w i -> Eval a -> Eval a)
cmpValue fb fw fi fz = cmp
where
cmp ty v1 v2 k =
case ty of
TVBit -> fb (fromVBit v1) (fromVBit v2) k
TVInteger -> fi (fromVInteger v1) (fromVInteger v2) k
TVIntMod n -> fz n (fromVInteger v1) (fromVInteger v2) k
TVSeq n t
| isTBit t -> do w1 <- fromVWord "cmpValue" v1
w2 <- fromVWord "cmpValue" v2
fw w1 w2 k
| otherwise -> cmpValues (repeat t)
(enumerateSeqMap n (fromVSeq v1))
(enumerateSeqMap n (fromVSeq v2)) k
TVStream _ -> panic "Cryptol.Prims.Value.cmpValue"
[ "Infinite streams are not comparable" ]
TVFun _ _ -> panic "Cryptol.Prims.Value.cmpValue"
[ "Functions are not comparable" ]
TVTuple tys -> cmpValues tys (fromVTuple v1) (fromVTuple v2) k
TVRec fields -> do let vals = map snd . sortBy (comparing fst)
let tys = vals fields
cmpValues tys
(vals (fromVRecord v1))
(vals (fromVRecord v2)) k
TVAbstract {} -> evalPanic "cmpValue"
[ "Abstract type not in `Cmp`" ]
cmpValues (t : ts) (x1 : xs1) (x2 : xs2) k =
do x1' <- x1
x2' <- x2
cmp t x1' x2' (cmpValues ts xs1 xs2 k)
cmpValues _ _ _ k = k
lexCompare :: TValue -> Value -> Value -> Eval Ordering
lexCompare ty a b = cmpValue op opw op (const op) ty a b (return EQ)
where
opw :: BV -> BV -> Eval Ordering -> Eval Ordering
opw x y k = op (bvVal x) (bvVal y) k
op :: Ord a => a -> a -> Eval Ordering -> Eval Ordering
op x y k = case compare x y of
EQ -> k
cmp -> return cmp
signedLexCompare :: TValue -> Value -> Value -> Eval Ordering
signedLexCompare ty a b = cmpValue opb opw opi (const opi) ty a b (return EQ)
where
opb :: Bool -> Bool -> Eval Ordering -> Eval Ordering
opb _x _y _k = panic "signedLexCompare"
["Attempted to perform signed comparisons on bare Bit type"]
opw :: BV -> BV -> Eval Ordering -> Eval Ordering
opw x y k = case compare (signedBV x) (signedBV y) of
EQ -> k
cmp -> return cmp
opi :: Integer -> Integer -> Eval Ordering -> Eval Ordering
opi _x _y _k = panic "signedLexCompare"
["Attempted to perform signed comparisons on Integer type"]
-- | Process two elements based on their lexicographic ordering.
cmpOrder :: String -> (Ordering -> Bool) -> Binary Bool BV Integer
cmpOrder _nm op ty l r = VBit . op <$> lexCompare ty l r
-- | Process two elements based on their lexicographic ordering, using signed comparisons
signedCmpOrder :: String -> (Ordering -> Bool) -> Binary Bool BV Integer
signedCmpOrder _nm op ty l r = VBit . op <$> signedLexCompare ty l r
-- Signed arithmetic -----------------------------------------------------------
-- | Lifted operation on finite bitsequences. Used
-- for signed comparisons and arithemtic.
liftWord :: BitWord b w i
=> (w -> w -> Eval (GenValue b w i))
-> GenValue b w i
liftWord op =
nlam $ \_n ->
wlam $ \w1 -> return $
wlam $ \w2 -> op w1 w2
liftSigned :: (Integer -> Integer -> Integer -> Eval BV)
-> BinArith BV
liftSigned _ 0 = \_ _ -> return $ mkBv 0 0
liftSigned op size = f
where
f (BV i x) (BV j y)
| i == j && size == i = op size sx sy
| otherwise = evalPanic "liftSigned" ["Attempt to compute with words of different sizes"]
where sx = signedValue i x
sy = signedValue j y
signedBV :: BV -> Integer
signedBV (BV i x) = signedValue i x
signedValue :: Integer -> Integer -> Integer
signedValue i x = if testBit x (fromInteger (i-1)) then x - (1 `shiftL` (fromInteger i)) else x
bvSlt :: Integer -> Integer -> Integer -> Eval Value
bvSlt _sz x y = return . VBit $! (x < y)
bvSdiv :: Integer -> Integer -> Integer -> Eval BV
bvSdiv _ _ 0 = divideByZero
bvSdiv sz x y = return $! mkBv sz (x `quot` y)
bvSrem :: Integer -> Integer -> Integer -> Eval BV
bvSrem _ _ 0 = divideByZero
bvSrem sz x y = return $! mkBv sz (x `rem` y)
sshrV :: Value
sshrV =
nlam $ \_n ->
nlam $ \_k ->
wlam $ \(BV i x) -> return $
wlam $ \y ->
let signx = testBit x (fromInteger (i-1))
amt = fromInteger (bvVal y)
negv = (((-1) `shiftL` amt) .|. x) `shiftR` amt
posv = x `shiftR` amt
in return . VWord i . ready . WordVal . mkBv i $! if signx then negv else posv
-- | Signed carry bit.
scarryV :: Value
scarryV =
nlam $ \_n ->
wlam $ \(BV i x) -> return $
wlam $ \(BV j y) ->
if i == j
then let z = x + y
xsign = testBit x (fromInteger i - 1)
ysign = testBit y (fromInteger i - 1)
zsign = testBit z (fromInteger i - 1)
sc = (xsign == ysign) && (xsign /= zsign)
in return $ VBit sc
else evalPanic "scarryV" ["Attempted to compute with words of different sizes"]
-- | Unsigned carry bit.
carryV :: Value
carryV =
nlam $ \_n ->
wlam $ \(BV i x) -> return $
wlam $ \(BV j y) ->
if i == j
then return . VBit $! testBit (x + y) (fromInteger i)
else evalPanic "carryV" ["Attempted to compute with words of different sizes"]
-- Logic -----------------------------------------------------------------------
zeroV :: forall b w i
. BitWord b w i
=> TValue
-> GenValue b w i
zeroV ty = case ty of
-- bits
TVBit ->
VBit (bitLit False)
-- integers
TVInteger ->
VInteger (integerLit 0)
-- integers mod n
TVIntMod _ ->
VInteger (integerLit 0)
-- sequences
TVSeq w ety
| isTBit ety -> word w 0
| otherwise -> VSeq w (IndexSeqMap $ \_ -> ready $ zeroV ety)
TVStream ety ->
VStream (IndexSeqMap $ \_ -> ready $ zeroV ety)
-- functions
TVFun _ bty ->
lam (\ _ -> ready (zeroV bty))
-- tuples
TVTuple tys ->
VTuple (map (ready . zeroV) tys)
-- records
TVRec fields ->
VRecord [ (f,ready $ zeroV fty) | (f,fty) <- fields ]
TVAbstract {} -> evalPanic "zeroV" [ "Abstract type not in `Zero`" ]
-- | otherwise = evalPanic "zeroV" ["invalid type for zero"]
joinWordVal :: BitWord b w i =>
WordValue b w i -> WordValue b w i -> WordValue b w i
joinWordVal (WordVal w1) (WordVal w2)
| wordLen w1 + wordLen w2 < largeBitSize
= WordVal $ joinWord w1 w2
joinWordVal (BitsVal xs) (WordVal w2)
| toInteger (Seq.length xs) + wordLen w2 < largeBitSize
= BitsVal (xs Seq.>< Seq.fromList (map ready $ unpackWord w2))
joinWordVal (WordVal w1) (BitsVal ys)
| wordLen w1 + toInteger (Seq.length ys) < largeBitSize
= BitsVal (Seq.fromList (map ready $ unpackWord w1) Seq.>< ys)
joinWordVal (BitsVal xs) (BitsVal ys)
| toInteger (Seq.length xs) + toInteger (Seq.length ys) < largeBitSize
= BitsVal (xs Seq.>< ys)
joinWordVal w1 w2
= LargeBitsVal (n1+n2) (concatSeqMap n1 (asBitsMap w1) (asBitsMap w2))
where n1 = wordValueSize w1
n2 = wordValueSize w2
joinWords :: forall b w i
. BitWord b w i
=> Integer
-> Integer
-> SeqMap b w i
-> Eval (GenValue b w i)
joinWords nParts nEach xs =
loop (ready $ WordVal (wordLit 0 0)) (enumerateSeqMap nParts xs)
where
loop :: Eval (WordValue b w i) -> [Eval (GenValue b w i)] -> Eval (GenValue b w i)
loop !wv [] = return $ VWord (nParts * nEach) wv
loop !wv (w : ws) = do
w >>= \case
VWord _ w' -> loop (joinWordVal <$> wv <*> w') ws
_ -> evalPanic "joinWords: expected word value" []
joinSeq :: BitWord b w i
=> Nat'
-> Integer
-> TValue
-> SeqMap b w i
-> Eval (GenValue b w i)
-- Special case for 0 length inner sequences.
joinSeq _parts 0 a _xs
= return $ zeroV (TVSeq 0 a)
-- finite sequence of words
joinSeq (Nat parts) each TVBit xs
| parts * each < largeBitSize
= joinWords parts each xs
| otherwise
= do let zs = IndexSeqMap $ \i ->
do let (q,r) = divMod i each
ys <- fromWordVal "join seq" =<< lookupSeqMap xs q
VBit <$> indexWordValue ys (fromInteger r)
return $ VWord (parts * each) $ ready $ LargeBitsVal (parts * each) zs
-- infinite sequence of words
joinSeq Inf each TVBit xs
= return $ VStream $ IndexSeqMap $ \i ->
do let (q,r) = divMod i each
ys <- fromWordVal "join seq" =<< lookupSeqMap xs q
VBit <$> indexWordValue ys (fromInteger r)
-- finite or infinite sequence of non-words
joinSeq parts each _a xs
= return $ vSeq $ IndexSeqMap $ \i -> do
let (q,r) = divMod i each
ys <- fromSeq "join seq" =<< lookupSeqMap xs q
lookupSeqMap ys r
where
len = parts `nMul` (Nat each)
vSeq = case len of
Inf -> VStream
Nat n -> VSeq n
-- | Join a sequence of sequences into a single sequence.
joinV :: BitWord b w i
=> Nat'
-> Integer
-> TValue
-> GenValue b w i
-> Eval (GenValue b w i)
joinV parts each a val = joinSeq parts each a =<< fromSeq "joinV" val
splitWordVal :: BitWord b w i
=> Integer
-> Integer
-> WordValue b w i
-> (WordValue b w i, WordValue b w i)
splitWordVal leftWidth rightWidth (WordVal w) =
let (lw, rw) = splitWord leftWidth rightWidth w
in (WordVal lw, WordVal rw)
splitWordVal leftWidth _rightWidth (BitsVal bs) =
let (lbs, rbs) = Seq.splitAt (fromInteger leftWidth) bs
in (BitsVal lbs, BitsVal rbs)
splitWordVal leftWidth rightWidth (LargeBitsVal _n xs) =
let (lxs, rxs) = splitSeqMap leftWidth xs
in (LargeBitsVal leftWidth lxs, LargeBitsVal rightWidth rxs)
splitAtV :: BitWord b w i
=> Nat'
-> Nat'
-> TValue
-> GenValue b w i
-> Eval (GenValue b w i)
splitAtV front back a val =
case back of
Nat rightWidth | aBit -> do
ws <- delay Nothing (splitWordVal leftWidth rightWidth <$> fromWordVal "splitAtV" val)
return $ VTuple
[ VWord leftWidth . ready . fst <$> ws
, VWord rightWidth . ready . snd <$> ws
]
Inf | aBit -> do
vs <- delay Nothing (fromSeq "splitAtV" val)
ls <- delay Nothing (do m <- fst . splitSeqMap leftWidth <$> vs
let ms = map (fromVBit <$>) (enumerateSeqMap leftWidth m)
return $ Seq.fromList $ ms)
rs <- delay Nothing (snd . splitSeqMap leftWidth <$> vs)
return $ VTuple [ return $ VWord leftWidth (BitsVal <$> ls)
, VStream <$> rs
]
_ -> do
vs <- delay Nothing (fromSeq "splitAtV" val)
ls <- delay Nothing (fst . splitSeqMap leftWidth <$> vs)
rs <- delay Nothing (snd . splitSeqMap leftWidth <$> vs)
return $ VTuple [ VSeq leftWidth <$> ls
, mkSeq back a <$> rs
]
where
aBit = isTBit a
leftWidth = case front of
Nat n -> n
_ -> evalPanic "splitAtV" ["invalid `front` len"]
-- | Extract a subsequence of bits from a @WordValue@.
-- The first integer argument is the number of bits in the
-- resulting word. The second integer argument is the
-- number of less-significant digits to discard. Stated another
-- way, the operation `extractWordVal n i w` is equivalent to
-- first shifting `w` right by `i` bits, and then truncating to
-- `n` bits.
extractWordVal :: BitWord b w i
=> Integer
-> Integer
-> WordValue b w i
-> WordValue b w i
extractWordVal len start (WordVal w) =
WordVal $ extractWord len start w
extractWordVal len start (BitsVal bs) =
BitsVal $ Seq.take (fromInteger len) $
Seq.drop (Seq.length bs - fromInteger start - fromInteger len) bs
extractWordVal len start (LargeBitsVal n xs) =
let xs' = dropSeqMap (n - start - len) xs
in LargeBitsVal len xs'
-- | Split implementation.
ecSplitV :: BitWord b w i
=> GenValue b w i
ecSplitV =
nlam $ \ parts ->
nlam $ \ each ->
tlam $ \ a ->
lam $ \ val ->
case (parts, each) of
(Nat p, Nat e) | isTBit a -> do
~(VWord _ val') <- val
return $ VSeq p $ IndexSeqMap $ \i -> do
return $ VWord e (extractWordVal e ((p-i-1)*e) <$> val')
(Inf, Nat e) | isTBit a -> do
val' <- delay Nothing (fromSeq "ecSplitV" =<< val)
return $ VStream $ IndexSeqMap $ \i ->
return $ VWord e $ return $ BitsVal $ Seq.fromFunction (fromInteger e) $ \j ->
let idx = i*e + toInteger j
in idx `seq` do
xs <- val'
fromVBit <$> lookupSeqMap xs idx
(Nat p, Nat e) -> do
val' <- delay Nothing (fromSeq "ecSplitV" =<< val)
return $ VSeq p $ IndexSeqMap $ \i ->
return $ VSeq e $ IndexSeqMap $ \j -> do
xs <- val'
lookupSeqMap xs (e * i + j)
(Inf , Nat e) -> do
val' <- delay Nothing (fromSeq "ecSplitV" =<< val)
return $ VStream $ IndexSeqMap $ \i ->
return $ VSeq e $ IndexSeqMap $ \j -> do
xs <- val'
lookupSeqMap xs (e * i + j)
_ -> evalPanic "splitV" ["invalid type arguments to split"]
reverseV :: forall b w i
. BitWord b w i
=> GenValue b w i
-> Eval (GenValue b w i)
reverseV (VSeq n xs) =
return $ VSeq n $ reverseSeqMap n xs
reverseV (VWord n wv) = return (VWord n (revword <$> wv))
where
revword (WordVal w) = BitsVal $ Seq.reverse $ Seq.fromList $ map ready $ unpackWord w
revword (BitsVal bs) = BitsVal $ Seq.reverse bs
revword (LargeBitsVal m xs) = LargeBitsVal m $ reverseSeqMap m xs
reverseV _ =
evalPanic "reverseV" ["Not a finite sequence"]
transposeV :: BitWord b w i
=> Nat'
-> Nat'
-> TValue
-> GenValue b w i
-> Eval (GenValue b w i)
transposeV a b c xs
| isTBit c, Nat na <- a = -- Fin a => [a][b]Bit -> [b][a]Bit
return $ bseq $ IndexSeqMap $ \bi ->
return $ VWord na $ return $ BitsVal $
Seq.fromFunction (fromInteger na) $ \ai -> do
ys <- flip lookupSeqMap (toInteger ai) =<< fromSeq "transposeV" xs
case ys of
VStream ys' -> fromVBit <$> lookupSeqMap ys' bi
VWord _ wv -> flip indexWordValue bi =<< wv
_ -> evalPanic "transpose" ["expected sequence of bits"]
| isTBit c, Inf <- a = -- [inf][b]Bit -> [b][inf]Bit
return $ bseq $ IndexSeqMap $ \bi ->
return $ VStream $ IndexSeqMap $ \ai ->
do ys <- flip lookupSeqMap ai =<< fromSeq "transposeV" xs
case ys of
VStream ys' -> VBit . fromVBit <$> lookupSeqMap ys' bi
VWord _ wv -> VBit <$> (flip indexWordValue bi =<< wv)
_ -> evalPanic "transpose" ["expected sequence of bits"]
| otherwise = -- [a][b]c -> [b][a]c
return $ bseq $ IndexSeqMap $ \bi ->
return $ aseq $ IndexSeqMap $ \ai -> do
ys <- flip lookupSeqMap ai =<< fromSeq "transposeV 1" xs
z <- flip lookupSeqMap bi =<< fromSeq "transposeV 2" ys
return z
where
bseq =
case b of
Nat nb -> VSeq nb
Inf -> VStream
aseq =
case a of
Nat na -> VSeq na
Inf -> VStream
ccatV :: (Show b, Show w, BitWord b w i)
=> Nat'
-> Nat'
-> TValue
-> (GenValue b w i)
-> (GenValue b w i)
-> Eval (GenValue b w i)
ccatV _front _back _elty (VWord m l) (VWord n r) =
return $ VWord (m+n) (joinWordVal <$> l <*> r)
ccatV _front _back _elty (VWord m l) (VStream r) = do
l' <- delay Nothing l
return $ VStream $ IndexSeqMap $ \i ->
if i < m then
VBit <$> (flip indexWordValue i =<< l')
else
lookupSeqMap r (i-m)
ccatV front back elty l r = do
l'' <- delay Nothing (fromSeq "ccatV left" l)
r'' <- delay Nothing (fromSeq "ccatV right" r)
let Nat n = front
mkSeq (evalTF TCAdd [front,back]) elty <$> return (IndexSeqMap $ \i ->
if i < n then do
ls <- l''
lookupSeqMap ls i
else do
rs <- r''
lookupSeqMap rs (i-n))
wordValLogicOp :: BitWord b w i
=> (b -> b -> b)
-> (w -> w -> w)
-> WordValue b w i
-> WordValue b w i
-> Eval (WordValue b w i)
wordValLogicOp _ wop (WordVal w1) (WordVal w2) = return $ WordVal (wop w1 w2)
wordValLogicOp bop _ (BitsVal xs) (BitsVal ys) =
BitsVal <$> sequence (Seq.zipWith (\x y -> delay Nothing (bop <$> x <*> y)) xs ys)
wordValLogicOp bop _ (WordVal w1) (BitsVal ys) =
ready $ BitsVal $ Seq.zipWith (\x y -> bop <$> x <*> y) (Seq.fromList $ map ready $ unpackWord w1) ys
wordValLogicOp bop _ (BitsVal xs) (WordVal w2) =
ready $ BitsVal $ Seq.zipWith (\x y -> bop <$> x <*> y) xs (Seq.fromList $ map ready $ unpackWord w2)
wordValLogicOp bop _ w1 w2 = LargeBitsVal (wordValueSize w1) <$> zs
where zs = memoMap $ IndexSeqMap $ \i -> op <$> (lookupSeqMap xs i) <*> (lookupSeqMap ys i)
xs = asBitsMap w1
ys = asBitsMap w2
op x y = VBit (bop (fromVBit x) (fromVBit y))
-- | Merge two values given a binop. This is used for and, or and xor.
logicBinary :: forall b w i
. BitWord b w i
=> (b -> b -> b)
-> (w -> w -> w)
-> Binary b w i
logicBinary opb opw = loop
where
loop' :: TValue
-> Eval (GenValue b w i)
-> Eval (GenValue b w i)
-> Eval (GenValue b w i)
loop' ty l r = join (loop ty <$> l <*> r)
loop :: TValue
-> GenValue b w i
-> GenValue b w i
-> Eval (GenValue b w i)
loop ty l r = case ty of
TVBit -> return $ VBit (opb (fromVBit l) (fromVBit r))
TVInteger -> evalPanic "logicBinary" ["Integer not in class Logic"]
TVIntMod _ -> evalPanic "logicBinary" ["Z not in class Logic"]
TVSeq w aty
-- words
| isTBit aty
-> do v <- delay Nothing $ join
(wordValLogicOp opb opw <$>
fromWordVal "logicBinary l" l <*>
fromWordVal "logicBinary r" r)
return $ VWord w v
-- finite sequences
| otherwise -> VSeq w <$>
(join (zipSeqMap (loop aty) <$>
(fromSeq "logicBinary left" l)
<*> (fromSeq "logicBinary right" r)))
TVStream aty ->
VStream <$> (join (zipSeqMap (loop aty) <$>
(fromSeq "logicBinary left" l) <*>
(fromSeq "logicBinary right" r)))
TVTuple etys -> do
ls <- mapM (delay Nothing) (fromVTuple l)
rs <- mapM (delay Nothing) (fromVTuple r)
return $ VTuple $ zipWith3 loop' etys ls rs
TVFun _ bty ->
return $ lam $ \ a -> loop' bty (fromVFun l a) (fromVFun r a)
TVRec fields ->
do fs <- sequence
[ (f,) <$> delay Nothing (loop' fty a b)
| (f,fty) <- fields
, let a = lookupRecord f l
b = lookupRecord f r
]
return $ VRecord fs
TVAbstract {} -> evalPanic "logicBinary"
[ "Abstract type not in `Logic`" ]
wordValUnaryOp :: BitWord b w i
=> (b -> b)
-> (w -> w)
-> WordValue b w i
-> Eval (WordValue b w i)
wordValUnaryOp _ wop (WordVal w) = return $ WordVal (wop w)
wordValUnaryOp bop _ (BitsVal bs) = return $ BitsVal (fmap (bop <$>) bs)
wordValUnaryOp bop _ (LargeBitsVal n xs) = LargeBitsVal n <$> mapSeqMap f xs
where f x = VBit . bop <$> fromBit x
logicUnary :: forall b w i
. BitWord b w i
=> (b -> b)
-> (w -> w)
-> Unary b w i
logicUnary opb opw = loop
where
loop' :: TValue -> Eval (GenValue b w i) -> Eval (GenValue b w i)
loop' ty val = loop ty =<< val
loop :: TValue -> GenValue b w i -> Eval (GenValue b w i)
loop ty val = case ty of
TVBit -> return . VBit . opb $ fromVBit val
TVInteger -> evalPanic "logicUnary" ["Integer not in class Logic"]
TVIntMod _ -> evalPanic "logicUnary" ["Z not in class Logic"]
TVSeq w ety
-- words
| isTBit ety
-> do v <- delay Nothing (wordValUnaryOp opb opw =<< fromWordVal "logicUnary" val)
return $ VWord w v
-- finite sequences
| otherwise
-> VSeq w <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val)
-- streams
TVStream ety ->
VStream <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val)
TVTuple etys ->
do as <- mapM (delay Nothing) (fromVTuple val)
return $ VTuple (zipWith loop' etys as)
TVFun _ bty ->
return $ lam $ \ a -> loop' bty (fromVFun val a)
TVRec fields ->
do fs <- sequence
[ (f,) <$> delay Nothing (loop' fty a)
| (f,fty) <- fields, let a = lookupRecord f val
]
return $ VRecord fs
TVAbstract {} -> evalPanic "logicUnary" [ "Abstract type not in `Logic`" ]
logicShift :: (Integer -> Integer -> Integer -> Integer)
-- ^ The function may assume its arguments are masked.
-- It is responsible for masking its result if needed.
-> (Integer -> Seq.Seq (Eval Bool) -> Integer -> Seq.Seq (Eval Bool))
-> (Nat' -> TValue -> SeqValMap -> Integer -> SeqValMap)
-> Value
logicShift opW obB opS
= nlam $ \ a ->
nlam $ \ _ ->
tlam $ \ c ->
lam $ \ l -> return $
lam $ \ r -> do
BV _ i <- fromVWord "logicShift amount" =<< r
l >>= \case
VWord w wv -> return $ VWord w $ wv >>= \case
WordVal (BV _ x) -> return $ WordVal (BV w (opW w x i))
BitsVal bs -> return $ BitsVal (obB w bs i)
LargeBitsVal n xs -> return $ LargeBitsVal n $ opS (Nat n) c xs i
_ -> mkSeq a c <$> (opS a c <$> (fromSeq "logicShift" =<< l) <*> return i)
-- Left shift for words.
shiftLW :: Integer -> Integer -> Integer -> Integer
shiftLW w ival by
| by >= w = 0
| otherwise = mask w (shiftL ival (fromInteger by))
shiftLB :: Integer -> Seq.Seq (Eval Bool) -> Integer -> Seq.Seq (Eval Bool)
shiftLB w bs by =
Seq.drop (fromInteger (min w by)) bs
Seq.><
Seq.replicate (fromInteger (min w by)) (ready False)
shiftLS :: Nat' -> TValue -> SeqValMap -> Integer -> SeqValMap
shiftLS w ety vs by = IndexSeqMap $ \i ->
case w of
Nat len
| i+by < len -> lookupSeqMap vs (i+by)
| i < len -> return $ zeroV ety
| otherwise -> evalPanic "shiftLS" ["Index out of bounds"]
Inf -> lookupSeqMap vs (i+by)
shiftRW :: Integer -> Integer -> Integer -> Integer
shiftRW w i by
| by >= w = 0
| otherwise = shiftR i (fromInteger by)
shiftRB :: Integer -> Seq.Seq (Eval Bool) -> Integer -> Seq.Seq (Eval Bool)
shiftRB w bs by =
Seq.replicate (fromInteger (min w by)) (ready False)
Seq.><
Seq.take (fromInteger (w - min w by)) bs
shiftRS :: Nat' -> TValue -> SeqValMap -> Integer -> SeqValMap
shiftRS w ety vs by = IndexSeqMap $ \i ->
case w of
Nat len
| i >= by -> lookupSeqMap vs (i-by)
| i < len -> return $ zeroV ety
| otherwise -> evalPanic "shiftLS" ["Index out of bounds"]
Inf
| i >= by -> lookupSeqMap vs (i-by)
| otherwise -> return $ zeroV ety
-- XXX integer doesn't implement rotateL, as there's no bit bound
rotateLW :: Integer -> Integer -> Integer -> Integer
rotateLW 0 i _ = i
rotateLW w i by = mask w $ (i `shiftL` b) .|. (i `shiftR` (fromInteger w - b))
where b = fromInteger (by `mod` w)
rotateLB :: Integer -> Seq.Seq (Eval Bool) -> Integer -> Seq.Seq (Eval Bool)
rotateLB w bs by =
let (hd,tl) = Seq.splitAt (fromInteger (by `mod` w)) bs
in tl Seq.>< hd
rotateLS :: Nat' -> TValue -> SeqValMap -> Integer -> SeqValMap
rotateLS w _ vs by = IndexSeqMap $ \i ->
case w of
Nat len -> lookupSeqMap vs ((by + i) `mod` len)
_ -> panic "Cryptol.Eval.Prim.rotateLS" [ "unexpected infinite sequence" ]
-- XXX integer doesn't implement rotateR, as there's no bit bound
rotateRW :: Integer -> Integer -> Integer -> Integer
rotateRW 0 i _ = i
rotateRW w i by = mask w $ (i `shiftR` b) .|. (i `shiftL` (fromInteger w - b))
where b = fromInteger (by `mod` w)
rotateRB :: Integer -> Seq.Seq (Eval Bool) -> Integer -> Seq.Seq (Eval Bool)
rotateRB w bs by =
let (hd,tl) = Seq.splitAt (fromInteger (w - (by `mod` w))) bs
in tl Seq.>< hd
rotateRS :: Nat' -> TValue -> SeqValMap -> Integer -> SeqValMap
rotateRS w _ vs by = IndexSeqMap $ \i ->
case w of
Nat len -> lookupSeqMap vs ((len - by + i) `mod` len)
_ -> panic "Cryptol.Eval.Prim.rotateRS" [ "unexpected infinite sequence" ]
-- Sequence Primitives ---------------------------------------------------------
-- | Indexing operations.
indexPrim :: BitWord b w i
=> (Maybe Integer -> TValue -> SeqMap b w i -> Seq.Seq b -> Eval (GenValue b w i))
-> (Maybe Integer -> TValue -> SeqMap b w i -> w -> Eval (GenValue b w i))
-> GenValue b w i
indexPrim bits_op word_op =
nlam $ \ n ->
tlam $ \ a ->
nlam $ \ _i ->
lam $ \ l -> return $
lam $ \ r -> do
vs <- l >>= \case
VWord _ w -> w >>= \w' -> return $ IndexSeqMap (\i -> VBit <$> indexWordValue w' i)
VSeq _ vs -> return vs
VStream vs -> return vs
_ -> evalPanic "Expected sequence value" ["indexPrim"]
r >>= \case
VWord _ w -> w >>= \case
WordVal w' -> word_op (fromNat n) a vs w'
BitsVal bs -> bits_op (fromNat n) a vs =<< sequence bs
LargeBitsVal m xs -> bits_op (fromNat n) a vs . Seq.fromList =<< traverse (fromBit =<<) (enumerateSeqMap m xs)
_ -> evalPanic "Expected word value" ["indexPrim"]
indexFront :: Maybe Integer -> TValue -> SeqValMap -> BV -> Eval Value
indexFront mblen _a vs (bvVal -> ix) =
case mblen of
Just len | len <= ix -> invalidIndex ix
_ -> lookupSeqMap vs ix
indexFront_bits :: Maybe Integer -> TValue -> SeqValMap -> Seq.Seq Bool -> Eval Value
indexFront_bits mblen a vs = indexFront mblen a vs . packWord . Fold.toList
indexBack :: Maybe Integer -> TValue -> SeqValMap -> BV -> Eval Value
indexBack mblen _a vs (bvVal -> ix) =
case mblen of
Just len | len > ix -> lookupSeqMap vs (len - ix - 1)
| otherwise -> invalidIndex ix
Nothing -> evalPanic "indexBack"
["unexpected infinite sequence"]
indexBack_bits :: Maybe Integer -> TValue -> SeqValMap -> Seq.Seq Bool -> Eval Value
indexBack_bits mblen a vs = indexBack mblen a vs . packWord . Fold.toList
updateFront
:: Nat'
-> TValue
-> SeqMap Bool BV Integer
-> WordValue Bool BV Integer
-> Eval (GenValue Bool BV Integer)
-> Eval (SeqMap Bool BV Integer)
updateFront len _eltTy vs w val = do
idx <- bvVal <$> asWordVal w
case len of
Inf -> return ()
Nat n -> unless (idx < n) (invalidIndex idx)
return $ updateSeqMap vs idx val
updateFront_word
:: Nat'
-> TValue
-> WordValue Bool BV Integer
-> WordValue Bool BV Integer
-> Eval (GenValue Bool BV Integer)
-> Eval (WordValue Bool BV Integer)
updateFront_word _len _eltTy bs w val = do
idx <- bvVal <$> asWordVal w
updateWordValue bs idx (fromBit =<< val)
updateBack
:: Nat'
-> TValue
-> SeqMap Bool BV Integer
-> WordValue Bool BV Integer
-> Eval (GenValue Bool BV Integer)
-> Eval (SeqMap Bool BV Integer)
updateBack Inf _eltTy _vs _w _val =
evalPanic "Unexpected infinite sequence in updateEnd" []
updateBack (Nat n) _eltTy vs w val = do
idx <- bvVal <$> asWordVal w
unless (idx < n) (invalidIndex idx)
return $ updateSeqMap vs (n - idx - 1) val
updateBack_word
:: Nat'
-> TValue
-> WordValue Bool BV Integer
-> WordValue Bool BV Integer
-> Eval (GenValue Bool BV Integer)
-> Eval (WordValue Bool BV Integer)
updateBack_word Inf _eltTy _bs _w _val =
evalPanic "Unexpected infinite sequence in updateEnd" []
updateBack_word (Nat n) _eltTy bs w val = do
idx <- bvVal <$> asWordVal w
updateWordValue bs (n - idx - 1) (fromBit =<< val)
{-
idx <- bvVal <$> asWordVal w
unless (idx < n) (invalidIndex idx)
let idx' = n - idx - 1
return $! Seq.update (fromInteger idx') (fromVBit <$> val) bs
-}
updatePrim
:: BitWord b w i
=> (Nat' -> TValue -> WordValue b w i -> WordValue b w i -> Eval (GenValue b w i) -> Eval (WordValue b w i))
-> (Nat' -> TValue -> SeqMap b w i -> WordValue b w i -> Eval (GenValue b w i) -> Eval (SeqMap b w i))
-> GenValue b w i
updatePrim updateWord updateSeq =
nlam $ \len ->
tlam $ \eltTy ->
nlam $ \_idxLen ->
lam $ \xs -> return $
lam $ \idx -> return $
lam $ \val -> do
idx' <- fromWordVal "update" =<< idx
xs >>= \case
VWord l w -> do w' <- delay Nothing w
return $ VWord l (w' >>= \w'' -> updateWord len eltTy w'' idx' val)
VSeq l vs -> VSeq l <$> updateSeq len eltTy vs idx' val
VStream vs -> VStream <$> updateSeq len eltTy vs idx' val
_ -> evalPanic "Expected sequence value" ["updatePrim"]
-- @[ 0 .. 10 ]@
fromToV :: BitWord b w i
=> GenValue b w i
fromToV =
nlam $ \ first ->
nlam $ \ lst ->
tlam $ \ ty ->
let !f = mkLit ty in
case (first, lst) of
(Nat first', Nat lst') ->
let len = 1 + (lst' - first')
in VSeq len $ IndexSeqMap $ \i -> ready $ f (first' + i)
_ -> evalPanic "fromToV" ["invalid arguments"]
-- @[ 0, 1 .. 10 ]@
fromThenToV :: BitWord b w i
=> GenValue b w i
fromThenToV =
nlam $ \ first ->
nlam $ \ next ->
nlam $ \ lst ->
tlam $ \ ty ->
nlam $ \ len ->
let !f = mkLit ty in
case (first, next, lst, len) of
(Nat first', Nat next', Nat _lst', Nat len') ->
let diff = next' - first'
in VSeq len' $ IndexSeqMap $ \i -> ready $ f (first' + i*diff)
_ -> evalPanic "fromThenToV" ["invalid arguments"]
infFromV :: BitWord b w i => GenValue b w i
infFromV =
tlam $ \ ty ->
lam $ \ x' ->
return $ VStream $ IndexSeqMap $ \i ->
do x <- x'
addV ty x (intV (integerLit i) ty)
infFromThenV :: BitWord b w i => GenValue b w i
infFromThenV =
tlam $ \ ty ->
lam $ \ first -> return $
lam $ \ next ->
do x <- first
y <- next
d <- subV ty y x
return $ VStream $ IndexSeqMap $ \i ->
addV ty x =<< mulV ty d (intV (integerLit i) ty)
-- Random Values ---------------------------------------------------------------
-- | Produce a random value with the given seed. If we do not support
-- making values of the given type, return zero of that type.
-- TODO: do better than returning zero
randomV :: BitWord b w i => TValue -> Integer -> GenValue b w i
randomV ty seed =
case randomValue (tValTy ty) of
Nothing -> zeroV ty
Just gen ->
-- unpack the seed into four Word64s
let mask64 = 0xFFFFFFFFFFFFFFFF
unpack s = fromInteger (s .&. mask64) : unpack (s `shiftR` 64)
[a, b, c, d] = take 4 (unpack seed)
in fst $ gen 100 $ seedTFGen (a, b, c, d)
-- Miscellaneous ---------------------------------------------------------------
errorV :: forall b w i
. BitWord b w i
=> TValue
-> String
-> Eval (GenValue b w i)
errorV ty msg = case ty of
-- bits
TVBit -> cryUserError msg
TVInteger -> cryUserError msg
TVIntMod _ -> cryUserError msg
-- sequences
TVSeq w ety
| isTBit ety -> return $ VWord w $ return $ BitsVal $
Seq.replicate (fromInteger w) (cryUserError msg)
| otherwise -> return $ VSeq w (IndexSeqMap $ \_ -> errorV ety msg)
TVStream ety ->
return $ VStream (IndexSeqMap $ \_ -> errorV ety msg)
-- functions
TVFun _ bty ->
return $ lam (\ _ -> errorV bty msg)
-- tuples
TVTuple tys ->
return $ VTuple (map (flip errorV msg) tys)
-- records
TVRec fields ->
return $ VRecord [ (f,errorV fty msg) | (f,fty) <- fields ]
TVAbstract {} -> cryUserError msg
cryptol-2.8.0/src/Cryptol/REPL/ 0000755 0000000 0000000 00000000000 07346545000 014373 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/REPL/Command.hs 0000644 0000000 0000000 00000151220 07346545000 016306 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.REPL.Command
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.REPL.Command (
-- * Commands
Command(..), CommandDescr(..), CommandBody(..), CommandExitCode(..)
, parseCommand
, runCommand
, splitCommand
, findCommand
, findCommandExact
, findNbCommand
, commandList
, moduleCmd, loadCmd, loadPrelude, setOptionCmd
-- Parsing
, interactiveConfig
, replParseExpr
-- Evaluation and Typechecking
, replEvalExpr
, replCheckExpr
-- Check, SAT, and prove
, qcCmd, QCMode(..)
, satCmd
, proveCmd
, onlineProveSat
, offlineProveSat
-- Misc utilities
, handleCtrlC
, sanitize
-- To support Notebook interface (might need to refactor)
, replParse
, liftModuleCmd
, moduleCmdResult
) where
import Cryptol.REPL.Monad
import Cryptol.REPL.Trie
import qualified Cryptol.ModuleSystem as M
import qualified Cryptol.ModuleSystem.Name as M
import qualified Cryptol.ModuleSystem.NamingEnv as M
import qualified Cryptol.ModuleSystem.Renamer as M (RenamerWarning(SymbolShadowed))
import qualified Cryptol.Utils.Ident as M
import qualified Cryptol.ModuleSystem.Env as M
import qualified Cryptol.Eval.Monad as E
import qualified Cryptol.Eval.Value as E
import qualified Cryptol.Eval.Reference as R
import Cryptol.Testing.Concrete
import qualified Cryptol.Testing.Random as TestR
import Cryptol.Parser
(parseExprWith,parseReplWith,ParseError(),Config(..),defaultConfig
,parseModName,parseHelpName)
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.TypeCheck.Error as T
import qualified Cryptol.TypeCheck.Parseable as T
import qualified Cryptol.TypeCheck.Subst as T
import Cryptol.TypeCheck.Solve(defaultReplExpr)
import qualified Cryptol.TypeCheck.Solver.SMT as SMT
import Cryptol.TypeCheck.PP (dump,ppWithNames,emptyNameMap,backticks)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic(panic)
import qualified Cryptol.Parser.AST as P
import qualified Cryptol.Transform.Specialize as S
import Cryptol.Symbolic (ProverCommand(..), QueryType(..), SatNum(..),ProverStats)
import qualified Cryptol.Symbolic as Symbolic
import qualified Control.Exception as X
import Control.Monad hiding (mapM, mapM)
import Control.Monad.IO.Class(liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Bits ((.&.))
import Data.Char (isSpace,isPunctuation,isSymbol,isAlphaNum,isAscii)
import Data.Function (on)
import Data.List (intercalate, nub, sortBy, partition, isPrefixOf,intersperse)
import Data.Maybe (fromMaybe,mapMaybe,isNothing)
import System.Environment (lookupEnv)
import System.Exit (ExitCode(ExitSuccess))
import System.Process (shell,createProcess,waitForProcess)
import qualified System.Process as Process(runCommand)
import System.FilePath((>), isPathSeparator)
import System.Directory(getHomeDirectory,setCurrentDirectory,doesDirectoryExist
,getTemporaryDirectory,setPermissions,removeFile
,emptyPermissions,setOwnerReadable)
import qualified Data.Map as Map
import qualified Data.Set as Set
import System.IO(hFlush,stdout,openTempFile,hClose)
import System.Random.TF(newTFGen)
import Numeric (showFFloat)
import qualified Data.Text as T
import Data.IORef(newIORef,readIORef)
import GHC.Float (log1p, expm1)
import Prelude ()
import Prelude.Compat
import qualified Data.SBV as SBV (Solver)
import qualified Data.SBV.Internals as SBV (showTDiff)
-- Commands --------------------------------------------------------------------
-- | Commands.
data Command
= Command (REPL ()) -- ^ Successfully parsed command
| Ambiguous String [String] -- ^ Ambiguous command, list of conflicting
-- commands
| Unknown String -- ^ The unknown command
-- | Command builder.
data CommandDescr = CommandDescr
{ cNames :: [String]
, cArgs :: [String]
, cBody :: CommandBody
, cHelp :: String
}
instance Show CommandDescr where
show = show . cNames
instance Eq CommandDescr where
(==) = (==) `on` cNames
instance Ord CommandDescr where
compare = compare `on` cNames
data CommandBody
= ExprArg (String -> REPL ())
| FileExprArg (FilePath -> String -> REPL ())
| DeclsArg (String -> REPL ())
| ExprTypeArg (String -> REPL ())
| ModNameArg (String -> REPL ())
| FilenameArg (FilePath -> REPL ())
| OptionArg (String -> REPL ())
| ShellArg (String -> REPL ())
| HelpArg (String -> REPL ())
| NoArg (REPL ())
data CommandExitCode = CommandOk
| CommandError -- XXX: More?
-- | REPL command parsing.
commands :: CommandMap
commands = foldl insert emptyTrie commandList
where
insert m d = foldl (insertOne d) m (cNames d)
insertOne d m name = insertTrie name d m
-- | Notebook command parsing.
nbCommands :: CommandMap
nbCommands = foldl insert emptyTrie nbCommandList
where
insert m d = foldl (insertOne d) m (cNames d)
insertOne d m name = insertTrie name d m
-- | A subset of commands safe for Notebook execution
nbCommandList :: [CommandDescr]
nbCommandList =
[ CommandDescr [ ":t", ":type" ] ["EXPR"] (ExprArg typeOfCmd)
"Check the type of an expression."
, CommandDescr [ ":b", ":browse" ] ["[ MODULE ]"] (ModNameArg browseCmd)
"Display environment for all loaded modules, or for a specific module."
, CommandDescr [ ":?", ":help" ] ["[ TOPIC ]"] (HelpArg helpCmd)
"Display a brief description of a function, type, or command."
, CommandDescr [ ":s", ":set" ] ["[ OPTION [ = VALUE ] ]"] (OptionArg setOptionCmd)
"Set an environmental option (:set on its own displays current values)."
, CommandDescr [ ":check" ] ["[ EXPR ]"] (ExprArg (void . qcCmd QCRandom))
"Use random testing to check that the argument always returns true.\n(If no argument, check all properties.)"
, CommandDescr [ ":exhaust" ] ["[ EXPR ]"] (ExprArg (void . qcCmd QCExhaust))
"Use exhaustive testing to prove that the argument always returns\ntrue. (If no argument, check all properties.)"
, CommandDescr [ ":prove" ] ["[ EXPR ]"] (ExprArg proveCmd)
"Use an external solver to prove that the argument always returns\ntrue. (If no argument, check all properties.)"
, CommandDescr [ ":sat" ] ["[ EXPR ]"] (ExprArg satCmd)
"Use a solver to find a satisfying assignment for which the argument\nreturns true. (If no argument, find an assignment for all properties.)"
, CommandDescr [ ":debug_specialize" ] ["EXPR"](ExprArg specializeCmd)
"Do type specialization on a closed expression."
, CommandDescr [ ":eval" ] ["EXPR"] (ExprArg refEvalCmd)
"Evaluate an expression with the reference evaluator."
, CommandDescr [ ":ast" ] ["EXPR"] (ExprArg astOfCmd)
"Print out the pre-typechecked AST of a given term."
, CommandDescr [ ":extract-coq" ] [] (NoArg allTerms)
"Print out the post-typechecked AST of all currently defined terms,\nin a Coq-parseable format."
]
commandList :: [CommandDescr]
commandList =
nbCommandList ++
[ CommandDescr [ ":q", ":quit" ] [] (NoArg quitCmd)
"Exit the REPL."
, CommandDescr [ ":l", ":load" ] ["FILE"] (FilenameArg loadCmd)
"Load a module by filename."
, CommandDescr [ ":r", ":reload" ] [] (NoArg reloadCmd)
"Reload the currently loaded module."
, CommandDescr [ ":e", ":edit" ] ["[ FILE ]"] (FilenameArg editCmd)
"Edit FILE or the currently loaded module."
, CommandDescr [ ":!" ] ["COMMAND"] (ShellArg runShellCmd)
"Execute a command in the shell."
, CommandDescr [ ":cd" ] ["DIR"] (FilenameArg cdCmd)
"Set the current working directory."
, CommandDescr [ ":m", ":module" ] ["[ MODULE ]"] (FilenameArg moduleCmd)
"Load a module by its name."
, CommandDescr [ ":w", ":writeByteArray" ] ["FILE", "EXPR"] (FileExprArg writeFileCmd)
"Write data of type 'fin n => [n][8]' to a file."
, CommandDescr [ ":readByteArray" ] ["FILE"] (FilenameArg readFileCmd)
"Read data from a file as type 'fin n => [n][8]', binding\nthe value to variable 'it'."
, CommandDescr [ ":dumptests" ] ["FILE", "EXPR"] (FileExprArg dumpTestsCmd)
(unlines [ "Dump a tab-separated collection of tests for the given"
, "expression into a file. The first column in each line is"
, "the expected output, and the remainder are the inputs. The"
, "number of tests is determined by the \"tests\" option."
])
]
genHelp :: [CommandDescr] -> [String]
genHelp cs = map cmdHelp cs
where
cmdHelp cmd = concat $ [ " ", cmdNames cmd, pad (cmdNames cmd),
intercalate ("\n " ++ pad []) (lines (cHelp cmd)) ]
cmdNames cmd = intercalate ", " (cNames cmd)
padding = 2 + maximum (map (length . cmdNames) cs)
pad n = replicate (max 0 (padding - length n)) ' '
-- Command Evaluation ----------------------------------------------------------
-- | Run a command.
runCommand :: Command -> REPL CommandExitCode
runCommand c = case c of
Command cmd -> (cmd >> return CommandOk) `Cryptol.REPL.Monad.catch` handler
where
handler re = rPutStrLn "" >> rPrint (pp re) >> return CommandError
Unknown cmd -> do rPutStrLn ("Unknown command: " ++ cmd)
return CommandError
Ambiguous cmd cmds -> do
rPutStrLn (cmd ++ " is ambiguous, it could mean one of:")
rPutStrLn ("\t" ++ intercalate ", " cmds)
return CommandError
-- Get the setting we should use for displaying values.
getPPValOpts :: REPL E.PPOpts
getPPValOpts =
do base <- getKnownUser "base"
ascii <- getKnownUser "ascii"
infLength <- getKnownUser "infLength"
return E.PPOpts { E.useBase = base
, E.useAscii = ascii
, E.useInfLength = infLength
}
getEvalOpts :: REPL E.EvalOpts
getEvalOpts =
do ppOpts <- getPPValOpts
l <- getLogger
return E.EvalOpts { E.evalPPOpts = ppOpts, E.evalLogger = l }
evalCmd :: String -> REPL ()
evalCmd str = do
letEnabled <- getLetEnabled
ri <- if letEnabled
then replParseInput str
else P.ExprInput <$> replParseExpr str
case ri of
P.ExprInput expr -> do
(val,_ty) <- replEvalExpr expr
ppOpts <- getPPValOpts
valDoc <- rEvalRethrow (E.ppValue ppOpts val)
-- This is the point where the value gets forced. We deepseq the
-- pretty-printed representation of it, rather than the value
-- itself, leaving it up to the pretty-printer to determine how
-- much of the value to force
--out <- io $ rethrowEvalError
-- $ return $!! show $ pp $ E.WithBase ppOpts val
rPutStrLn (show valDoc)
P.LetInput decl -> do
-- explicitly make this a top-level declaration, so that it will
-- be generalized if mono-binds is enabled
replEvalDecl decl
printCounterexample :: Bool -> P.Expr P.PName -> [E.Value] -> REPL ()
printCounterexample isSat pexpr vs =
do ppOpts <- getPPValOpts
docs <- mapM (rEval . E.ppValue ppOpts) vs
let doc = ppPrec 3 pexpr -- function application has precedence 3
rPrint $ hang doc 2 (sep docs) <+>
text (if isSat then "= True" else "= False")
dumpTestsCmd :: FilePath -> String -> REPL ()
dumpTestsCmd outFile str =
do expr <- replParseExpr str
(val, ty) <- replEvalExpr expr
evo <- getEvalOpts
ppopts <- getPPValOpts
testNum <- getKnownUser "tests" :: REPL Int
g <- io newTFGen
gens <-
case TestR.dumpableType ty of
Nothing -> raise (TypeNotTestable ty)
Just gens -> return gens
tests <- io $ TestR.returnTests g evo gens val testNum
out <- forM tests $
\(args, x) ->
do argOut <- mapM (rEval . E.ppValue ppopts) args
resOut <- rEval (E.ppValue ppopts x)
return (renderOneLine resOut ++ "\t" ++ intercalate "\t" (map renderOneLine argOut) ++ "\n")
io $ writeFile outFile (concat out) `X.catch` handler
where
handler :: X.SomeException -> IO ()
handler e = putStrLn (X.displayException e)
data QCMode = QCRandom | QCExhaust deriving (Eq, Show)
-- | Randomly test a property, or exhaustively check it if the number
-- of values in the type under test is smaller than the @tests@
-- environment variable, or we specify exhaustive testing.
qcCmd :: QCMode -> String -> REPL [TestReport]
qcCmd qcMode "" =
do (xs,disp) <- getPropertyNames
let nameStr x = show (fixNameDisp disp (pp x))
if null xs
then rPutStrLn "There are no properties in scope." *> return []
else concat <$> (forM xs $ \x ->
do let str = nameStr x
rPutStr $ "property " ++ str ++ " "
qcCmd qcMode str)
qcCmd qcMode str =
do expr <- replParseExpr str
(val,ty) <- replEvalExpr expr
testNum <- getKnownUser "tests"
case testableType ty of
Just (Just sz,tys,vss) | qcMode == QCExhaust || sz <= toInteger testNum -> do
rPutStrLn "Using exhaustive testing."
let f _ [] = panic "Cryptol.REPL.Command"
["Exhaustive testing ran out of test cases"]
f _ (vs : vss1) = do
evo <- getEvalOpts
result <- io $ runOneTest evo val vs
return (result, vss1)
testSpec = TestSpec {
testFn = f
, testProp = str
, testTotal = sz
, testPossible = Just sz
, testRptProgress = ppProgress
, testClrProgress = delProgress
, testRptFailure = ppFailure tys expr
, testRptSuccess = do
delTesting
prtLn $ "Passed " ++ show sz ++ " tests."
rPutStrLn "Q.E.D."
}
prt testingMsg
report <- runTests testSpec vss
return [report]
Just (sz,tys,_) | qcMode == QCRandom ->
case TestR.testableType ty of
Nothing -> raise (TypeNotTestable ty)
Just gens -> do
rPutStrLn "Using random testing."
evo <- getEvalOpts
let testSpec = TestSpec {
testFn = \sz' g ->
io $ TestR.runOneTest evo val gens sz' g
, testProp = str
, testTotal = toInteger testNum
, testPossible = sz
, testRptProgress = ppProgress
, testClrProgress = delProgress
, testRptFailure = ppFailure tys expr
, testRptSuccess = do
delTesting
prtLn $ "Passed " ++ show testNum ++ " tests."
}
prt testingMsg
g <- io newTFGen
report <- runTests testSpec g
when (isPass (reportResult report)) $
case sz of
Nothing -> return ()
Just n -> rPutStrLn $ coverageString testNum n
return [report]
_ -> raise (TypeNotTestable ty)
where
testingMsg = "Testing... "
coverageString testNum sz =
let (percent, expectedUnique) = expectedCoverage testNum sz
showValNum
| sz > 2 ^ (20::Integer) =
"2^^" ++ show (lg2 sz)
| otherwise = show sz
in "Expected test coverage: "
++ showFFloat (Just 2) percent "% ("
++ showFFloat (Just 0) expectedUnique " of "
++ showValNum
++ " values)"
totProgressWidth = 4 -- 100%
lg2 :: Integer -> Integer
lg2 x | x >= 2^(1024::Int) = 1024 + lg2 (x `div` 2^(1024::Int))
| x == 0 = 0
| otherwise = let valNumD = fromInteger x :: Double
in round $ logBase 2 valNumD :: Integer
prt msg = rPutStr msg >> io (hFlush stdout)
prtLn msg = rPutStrLn msg >> io (hFlush stdout)
ppProgress this tot = unlessBatch $
let percent = show (div (100 * this) tot) ++ "%"
width = length percent
pad = replicate (totProgressWidth - width) ' '
in prt (pad ++ percent)
del n = unlessBatch
$ prt (replicate n '\BS' ++ replicate n ' ' ++ replicate n '\BS')
delTesting = del (length testingMsg)
delProgress = del totProgressWidth
ppFailure tys pexpr failure = do
delTesting
opts <- getPPValOpts
case failure of
FailFalse vs -> do
let isSat = False
printCounterexample isSat pexpr vs
case (tys,vs) of
([t],[v]) -> bindItVariableVal t v
_ -> let fs = [ M.packIdent ("arg" ++ show (i::Int)) | i <- [ 1 .. ] ]
t = T.TRec (zip fs tys)
v = E.VRecord (zip fs (map return vs))
in bindItVariableVal t v
FailError err [] -> do
prtLn "ERROR"
rPrint (pp err)
FailError err vs -> do
prtLn "ERROR for the following inputs:"
mapM_ (\v -> rPrint =<< (rEval $ E.ppValue opts v)) vs
rPrint (pp err)
Pass -> panic "Cryptol.REPL.Command" ["unexpected Test.Pass"]
-- | This function computes the expected coverage percentage and
-- expected number of unique test vectors when using random testing.
--
-- The expected test coverage proportion is:
-- @1 - ((n-1)/n)^k@
--
-- This formula takes into account the fact that test vectors are chosen
-- uniformly at random _with replacement_, and thus the same vectors
-- may be generated multiple times. If the test vectors were chosen
-- randomly without replacement, the proportion would instead be @k/n@.
--
-- We compute raising to the @k@ power in the log domain to improve
-- numerical precision. The equivalant comptutation is:
-- @-expm1( k * log1p (-1/n) )@
--
-- Where @expm1(x) = exp(x) - 1@ and @log1p(x) = log(1 + x)@.
--
-- However, if @sz@ is large enough, even carefully preserving
-- precision may not be enough to get sensible results. In such
-- situations, we expect the naive approximation @k/n@ to be very
-- close to accurate and the expected number of unique values is
-- essentially equal to the number of tests.
expectedCoverage :: Int -> Integer -> (Double, Double)
expectedCoverage testNum sz =
-- If the Double computation has enough precision, use the
-- "with replacement" formula.
if testNum > 0 && proportion > 0 then
(100.0 * proportion, szD * proportion)
else
(100.0 * naiveProportion, numD)
where
szD :: Double
szD = fromInteger sz
numD :: Double
numD = fromIntegral testNum
naiveProportion = numD / szD
proportion = negate (expm1 (numD * log1p (negate (recip szD))))
satCmd, proveCmd :: String -> REPL ()
satCmd = cmdProveSat True
proveCmd = cmdProveSat False
showProverStats :: Maybe SBV.Solver -> ProverStats -> REPL ()
showProverStats mprover stat = rPutStrLn msg
where
msg = "(Total Elapsed Time: " ++ SBV.showTDiff stat ++
maybe "" (\p -> ", using " ++ show p) mprover ++ ")"
rethrowErrorCall :: REPL a -> REPL a
rethrowErrorCall m = REPL (\r -> unREPL m r `X.catch` handler)
where
handler (X.ErrorCallWithLocation s _) = X.throwIO (SBVError s)
-- | Console-specific version of 'proveSat'. Prints output to the
-- console, and binds the @it@ variable to a record whose form depends
-- on the expression given. See ticket #66 for a discussion of this
-- design.
cmdProveSat :: Bool -> String -> REPL ()
cmdProveSat isSat "" =
do (xs,disp) <- getPropertyNames
let nameStr x = show (fixNameDisp disp (pp x))
if null xs
then rPutStrLn "There are no properties in scope."
else forM_ xs $ \x ->
do let str = nameStr x
if isSat
then rPutStr $ ":sat " ++ str ++ "\n\t"
else rPutStr $ ":prove " ++ str ++ "\n\t"
cmdProveSat isSat str
cmdProveSat isSat str = do
let cexStr | isSat = "satisfying assignment"
| otherwise = "counterexample"
proverName <- getKnownUser "prover"
fileName <- getKnownUser "smtfile"
let mfile = if fileName == "-" then Nothing else Just fileName
case proverName :: String of
"offline" -> do
result <- offlineProveSat isSat str mfile
case result of
Left msg -> rPutStrLn msg
Right smtlib -> do
let filename = fromMaybe "standard output" mfile
let satWord | isSat = "satisfiability"
| otherwise = "validity"
rPutStrLn $
"Writing to SMT-Lib file " ++ filename ++ "..."
rPutStrLn $
"To determine the " ++ satWord ++
" of the expression, use an external SMT solver."
case mfile of
Just path -> io $ writeFile path smtlib
Nothing -> rPutStr smtlib
_ -> do
(firstProver,result,stats) <- rethrowErrorCall (onlineProveSat isSat str mfile)
case result of
Symbolic.EmptyResult ->
panic "REPL.Command" [ "got EmptyResult for online prover query" ]
Symbolic.ProverError msg -> rPutStrLn msg
Symbolic.ThmResult ts -> do
rPutStrLn (if isSat then "Unsatisfiable" else "Q.E.D.")
(t, e) <- mkSolverResult cexStr (not isSat) (Left ts)
bindItVariable t e
Symbolic.AllSatResult tevss -> do
let tess = map (map $ \(t,e,_) -> (t,e)) tevss
vss = map (map $ \(_,_,v) -> v) tevss
resultRecs <- mapM (mkSolverResult cexStr isSat . Right) tess
let collectTes tes = (t, es)
where
(ts, es) = unzip tes
t = case nub ts of
[t'] -> t'
_ -> panic "REPL.Command.onlineProveSat"
[ "satisfying assignments with different types" ]
(ty, exprs) =
case resultRecs of
[] -> panic "REPL.Command.onlineProveSat"
[ "no satisfying assignments after mkSolverResult" ]
[(t, e)] -> (t, [e])
_ -> collectTes resultRecs
pexpr <- replParseExpr str
~(EnvBool yes) <- getUser "show-examples"
when yes $ forM_ vss (printCounterexample isSat pexpr)
case (ty, exprs) of
(t, [e]) -> bindItVariable t e
(t, es ) -> bindItVariables t es
seeStats <- getUserShowProverStats
when seeStats (showProverStats firstProver stats)
onlineProveSat :: Bool
-> String -> Maybe FilePath
-> REPL (Maybe SBV.Solver,Symbolic.ProverResult,ProverStats)
onlineProveSat isSat str mfile = do
proverName <- getKnownUser "prover"
verbose <- getKnownUser "debug"
satNum <- getUserSatNum
modelValidate <- getUserProverValidate
parseExpr <- replParseExpr str
(_, expr, schema) <- replCheckExpr parseExpr
validEvalContext expr
validEvalContext schema
decls <- fmap M.deDecls getDynEnv
timing <- io (newIORef 0)
let cmd = Symbolic.ProverCommand {
pcQueryType = if isSat then SatQuery satNum else ProveQuery
, pcProverName = proverName
, pcVerbose = verbose
, pcValidate = modelValidate
, pcProverStats = timing
, pcExtraDecls = decls
, pcSmtFile = mfile
, pcExpr = expr
, pcSchema = schema
}
(firstProver, res) <- liftModuleCmd $ Symbolic.satProve cmd
stas <- io (readIORef timing)
return (firstProver,res,stas)
offlineProveSat :: Bool -> String -> Maybe FilePath -> REPL (Either String String)
offlineProveSat isSat str mfile = do
verbose <- getKnownUser "debug"
modelValidate <- getUserProverValidate
parseExpr <- replParseExpr str
(_, expr, schema) <- replCheckExpr parseExpr
decls <- fmap M.deDecls getDynEnv
timing <- io (newIORef 0)
let cmd = Symbolic.ProverCommand {
pcQueryType = if isSat then SatQuery (SomeSat 0) else ProveQuery
, pcProverName = "offline"
, pcVerbose = verbose
, pcValidate = modelValidate
, pcProverStats = timing
, pcExtraDecls = decls
, pcSmtFile = mfile
, pcExpr = expr
, pcSchema = schema
}
liftModuleCmd $ Symbolic.satProveOffline cmd
rIdent :: M.Ident
rIdent = M.packIdent "result"
-- | Make a type/expression pair that is suitable for binding to @it@
-- after running @:sat@ or @:prove@
mkSolverResult :: String
-> Bool
-> Either [T.Type] [(T.Type, T.Expr)]
-> REPL (T.Type, T.Expr)
mkSolverResult thing result earg =
do prims <- getPrimMap
let addError t = (t, T.eError prims t ("no " ++ thing ++ " available"))
argF = case earg of
Left ts -> mkArgs (map addError ts)
Right tes -> mkArgs tes
eTrue = T.ePrim prims (M.packIdent "True")
eFalse = T.ePrim prims (M.packIdent "False")
resultE = if result then eTrue else eFalse
rty = T.TRec $ [(rIdent, T.tBit )] ++ map fst argF
re = T.ERec $ [(rIdent, resultE)] ++ map snd argF
return (rty, re)
where
mkArgs tes = zipWith mkArg [1 :: Int ..] tes
where
mkArg n (t,e) =
let argName = M.packIdent ("arg" ++ show n)
in ((argName,t),(argName,e))
specializeCmd :: String -> REPL ()
specializeCmd str = do
parseExpr <- replParseExpr str
(_, expr, schema) <- replCheckExpr parseExpr
spexpr <- replSpecExpr expr
rPutStrLn "Expression type:"
rPrint $ pp schema
rPutStrLn "Original expression:"
rPutStrLn $ dump expr
rPutStrLn "Specialized expression:"
rPutStrLn $ dump spexpr
refEvalCmd :: String -> REPL ()
refEvalCmd str = do
parseExpr <- replParseExpr str
(_, expr, schema) <- replCheckExpr parseExpr
validEvalContext expr
validEvalContext schema
val <- liftModuleCmd (rethrowEvalError . R.evaluate expr)
opts <- getPPValOpts
rPrint $ R.ppValue opts val
astOfCmd :: String -> REPL ()
astOfCmd str = do
expr <- replParseExpr str
(re,_,_) <- replCheckExpr (P.noPos expr)
rPrint (fmap M.nameUnique re)
allTerms :: REPL ()
allTerms = do
me <- getModuleEnv
rPrint $ T.showParseable $ concatMap T.mDecls $ M.loadedModules me
typeOfCmd :: String -> REPL ()
typeOfCmd str = do
expr <- replParseExpr str
(_re,def,sig) <- replCheckExpr expr
-- XXX need more warnings from the module system
whenDebug (rPutStrLn (dump def))
(_,_,_,names) <- getFocusedEnv
-- type annotation ':' has precedence 2
rPrint $ runDoc names $ ppPrec 2 expr <+> text ":" <+> pp sig
readFileCmd :: FilePath -> REPL ()
readFileCmd fp = do
bytes <- replReadFile fp (\err -> rPutStrLn (show err) >> return Nothing)
case bytes of
Nothing -> return ()
Just bs ->
do pm <- getPrimMap
let expr = T.eString pm (map (toEnum . fromIntegral) (BS.unpack bs))
ty = T.tString (BS.length bs)
bindItVariable ty expr
writeFileCmd :: FilePath -> String -> REPL ()
writeFileCmd file str = do
expr <- replParseExpr str
(val,ty) <- replEvalExpr expr
if not (tIsByteSeq ty)
then rPrint $ "Cannot write expression of types other than [n][8]."
<+> "Type was: " <+> pp ty
else wf file =<< serializeValue val
where
wf fp bytes = replWriteFile fp bytes (rPutStrLn . show)
tIsByteSeq x = maybe False
(tIsByte . snd)
(T.tIsSeq x)
tIsByte x = maybe False
(\(n,b) -> T.tIsBit b && T.tIsNum n == Just 8)
(T.tIsSeq x)
serializeValue (E.VSeq n vs) = do
ws <- rEval
(mapM (>>=E.fromVWord "serializeValue") $ E.enumerateSeqMap n vs)
return $ BS.pack $ map serializeByte ws
serializeValue _ =
panic "Cryptol.REPL.Command.writeFileCmd"
["Impossible: Non-VSeq value of type [n][8]."]
serializeByte (E.BV _ v) = fromIntegral (v .&. 0xFF)
rEval :: E.Eval a -> REPL a
rEval m = do ev <- getEvalOpts
io (E.runEval ev m)
rEvalRethrow :: E.Eval a -> REPL a
rEvalRethrow m = do ev <- getEvalOpts
io $ rethrowEvalError $ E.runEval ev m
reloadCmd :: REPL ()
reloadCmd = do
mb <- getLoadedMod
case mb of
Just lm ->
case lName lm of
Just m | M.isParamInstModName m -> loadHelper (M.loadModuleByName m)
_ -> case lPath lm of
M.InFile f -> loadCmd f
_ -> return ()
Nothing -> return ()
editCmd :: String -> REPL ()
editCmd path =
do mbE <- getEditPath
mbL <- getLoadedMod
if not (null path)
then do when (isNothing mbL)
$ setLoadedMod LoadedModule { lName = Nothing
, lPath = M.InFile path }
doEdit path
else case msum [ M.InFile <$> mbE, lPath <$> mbL ] of
Nothing -> rPutStrLn "No filed to edit."
Just p ->
case p of
M.InFile f -> doEdit f
M.InMem l bs -> withROTempFile l bs replEdit >> pure ()
where
doEdit p =
do setEditPath p
_ <- replEdit p
reloadCmd
withROTempFile :: String -> ByteString -> (FilePath -> REPL a) -> REPL a
withROTempFile name cnt k =
do (path,h) <- mkTmp
do mkFile path h
k path
`finally` liftIO (do hClose h
removeFile path)
where
mkTmp =
liftIO $
do tmp <- getTemporaryDirectory
let esc c = if isAscii c && isAlphaNum c then c else '_'
openTempFile tmp (map esc name ++ ".cry")
mkFile path h =
liftIO $
do BS8.hPutStrLn h cnt
hFlush h
setPermissions path (setOwnerReadable True emptyPermissions)
moduleCmd :: String -> REPL ()
moduleCmd modString
| null modString = return ()
| otherwise = do
case parseModName modString of
Just m -> loadHelper (M.loadModuleByName m)
Nothing -> rPutStrLn "Invalid module name."
loadPrelude :: REPL ()
loadPrelude = moduleCmd $ show $ pp M.preludeName
loadCmd :: FilePath -> REPL ()
loadCmd path
| null path = return ()
-- when `:load`, the edit and focused paths become the parameter
| otherwise = do setEditPath path
setLoadedMod LoadedModule { lName = Nothing
, lPath = M.InFile path
}
loadHelper (M.loadModuleByPath path)
loadHelper :: M.ModuleCmd (M.ModulePath,T.Module) -> REPL ()
loadHelper how =
do clearLoadedMod
(path,m) <- liftModuleCmd how
whenDebug (rPutStrLn (dump m))
setLoadedMod LoadedModule
{ lName = Just (T.mName m)
, lPath = path
}
-- after a successful load, the current module becomes the edit target
case path of
M.InFile f -> setEditPath f
M.InMem {} -> clearEditPath
setDynEnv mempty
quitCmd :: REPL ()
quitCmd = stop
browseCmd :: String -> REPL ()
browseCmd input = do
(params, iface, fNames, disp) <- getFocusedEnv
denv <- getDynEnv
let names = M.deNames denv `M.shadowing` fNames
let mnames = map (M.textToModName . T.pack) (words input)
validModNames <- (:) M.interactiveName <$> getModNames
let checkModName m =
unless (m `elem` validModNames) $
rPutStrLn ("error: " ++ show m ++ " is not a loaded module.")
mapM_ checkModName mnames
let f &&& g = \x -> f x && g x
isUser x = case M.nameInfo x of
M.Declared _ M.SystemName -> False
_ -> True
inSet s x = x `Set.member` s
let (visibleTypes,visibleDecls) = M.visibleNames names
restricted = if null mnames then const True else hasAnyModName mnames
visibleType = isUser &&& restricted &&& inSet visibleTypes
visibleDecl = isUser &&& restricted &&& inSet visibleDecls
browseMParams visibleType visibleDecl params disp
browseTSyns visibleType iface disp
browsePrimTys visibleType iface disp
browseNewtypes visibleType iface disp
browseVars visibleDecl iface disp
browseMParams :: (M.Name -> Bool) -> (M.Name -> Bool) ->
M.IfaceParams-> NameDisp -> REPL ()
browseMParams visT visD M.IfaceParams { .. } names =
do ppBlock names ppParamTy "Type Parameters"
(sorted visT T.mtpName ifParamTypes)
ppBlock names ppParamFu "Value Parameters"
(sorted visD T.mvpName ifParamFuns)
where
ppParamTy T.ModTParam { .. } = hang ("type" <+> pp mtpName <+> ":")
2 (pp mtpKind)
ppParamFu T.ModVParam { .. } = hang (pp mvpName <+> ":") 2 (pp mvpType)
sorted vis nm mp = sortBy (M.cmpNameDisplay names `on` nm)
$ filter (vis . nm) $ Map.elems mp
browsePrimTys :: (M.Name -> Bool) -> M.IfaceDecls -> NameDisp -> REPL ()
browsePrimTys isVisible M.IfaceDecls { .. } names =
do let pts = sortBy (M.cmpNameDisplay names `on` T.atName)
[ ts | ts <- Map.elems ifAbstractTypes, isVisible (T.atName ts) ]
ppBlock names ppA "Primitive Types" pts
where
ppA a = pp (T.atName a) <+> ":" <+> pp (T.atKind a)
browseTSyns :: (M.Name -> Bool) -> M.IfaceDecls -> NameDisp -> REPL ()
browseTSyns isVisible M.IfaceDecls { .. } names = do
let tsyns = sortBy (M.cmpNameDisplay names `on` T.tsName)
[ ts | ts <- Map.elems ifTySyns, isVisible (T.tsName ts) ]
(cts,tss) = partition isCtrait tsyns
ppBlock names pp "Type Synonyms" tss
ppBlock names pp "Constraint Synonyms" cts
where
isCtrait t = T.kindResult (T.kindOf (T.tsDef t)) == T.KProp
browseNewtypes :: (M.Name -> Bool) -> M.IfaceDecls -> NameDisp -> REPL ()
browseNewtypes isVisible M.IfaceDecls { .. } names = do
let nts = sortBy (M.cmpNameDisplay names `on` T.ntName)
[ nt | nt <- Map.elems ifNewtypes, isVisible (T.ntName nt) ]
unless (null nts) $ do
rPutStrLn "Newtypes"
rPutStrLn "========"
rPrint (runDoc names (nest 4 (vcat (map T.ppNewtypeShort nts))))
rPutStrLn ""
browseVars :: (M.Name -> Bool) -> M.IfaceDecls -> NameDisp -> REPL ()
browseVars isVisible M.IfaceDecls { .. } names = do
let vars = sortBy (M.cmpNameDisplay names `on` M.ifDeclName)
[ d | d <- Map.elems ifDecls, isVisible (M.ifDeclName d) ]
let isProp p = T.PragmaProperty `elem` (M.ifDeclPragmas p)
(props,syms) = partition isProp vars
let ppVar M.IfaceDecl { .. } = hang (pp ifDeclName <+> char ':')
2 (pp ifDeclSig)
ppBlock names ppVar "Properties" props
ppBlock names ppVar "Symbols" syms
ppBlock :: NameDisp -> (a -> Doc) -> String -> [a] -> REPL ()
ppBlock names ppFun name xs = unless (null xs) $
do rPutStrLn name
rPutStrLn (replicate (length name) '=')
rPrint (runDoc names (nest 4 (vcat (map ppFun xs))))
rPutStrLn ""
setOptionCmd :: String -> REPL ()
setOptionCmd str
| Just value <- mbValue = setUser key value
| null key = mapM_ (describe . optName) (leaves userOptions)
| otherwise = describe key
where
(before,after) = break (== '=') str
key = trim before
mbValue = case after of
_ : stuff -> Just (trim stuff)
_ -> Nothing
describe k = do
ev <- tryGetUser k
case ev of
Just v -> rPutStrLn (k ++ " = " ++ showEnvVal v)
Nothing -> do rPutStrLn ("Unknown user option: `" ++ k ++ "`")
when (any isSpace k) $ do
let (k1, k2) = break isSpace k
rPutStrLn ("Did you mean: `:set " ++ k1 ++ " =" ++ k2 ++ "`?")
showEnvVal :: EnvVal -> String
showEnvVal ev =
case ev of
EnvString s -> s
EnvProg p as -> intercalate " " (p:as)
EnvNum n -> show n
EnvBool True -> "on"
EnvBool False -> "off"
-- XXX at the moment, this can only look at declarations.
helpCmd :: String -> REPL ()
helpCmd cmd
| null cmd = mapM_ rPutStrLn (genHelp commandList)
| cmd0 : args <- words cmd, ":" `isPrefixOf` cmd0 =
case findCommandExact cmd0 of
[] -> void $ runCommand (Unknown cmd0)
[c] -> showCmdHelp c args
cs -> void $ runCommand (Ambiguous cmd0 (concatMap cNames cs))
| otherwise =
case parseHelpName cmd of
Just qname ->
do (params,env,rnEnv,nameEnv) <- getFocusedEnv
let vNames = M.lookupValNames qname rnEnv
tNames = M.lookupTypeNames qname rnEnv
let helps = map (showTypeHelp params env nameEnv) tNames ++
map (showValHelp params env nameEnv qname) vNames
separ = rPutStrLn " ~~~ * ~~~"
sequence_ (intersperse separ helps)
when (null (vNames ++ tNames)) $
rPrint $ "Undefined name:" <+> pp qname
Nothing ->
rPutStrLn ("Unable to parse name: " ++ cmd)
where
noInfo nameEnv name =
case M.nameInfo name of
M.Declared m _ ->
rPrint $runDoc nameEnv ("Name defined in module" <+> pp m)
M.Parameter -> rPutStrLn "// No documentation is available."
showTypeHelp params env nameEnv name =
fromMaybe (noInfo nameEnv name) $
msum [ fromTySyn, fromPrimType, fromNewtype, fromTyParam ]
where
fromTySyn =
do ts <- Map.lookup name (M.ifTySyns env)
return (doShowTyHelp nameEnv (pp ts) (T.tsDoc ts))
fromNewtype =
do nt <- Map.lookup name (M.ifNewtypes env)
let decl = pp nt $$ (pp name <+> text ":" <+> pp (T.newtypeConType nt))
return $ doShowTyHelp nameEnv decl (T.ntDoc nt)
fromPrimType =
do a <- Map.lookup name (M.ifAbstractTypes env)
pure $ do rPutStrLn ""
rPrint $ runDoc nameEnv $ nest 4
$ "primitive type" <+> pp (T.atName a)
<+> ":" <+> pp (T.atKind a)
let (vs,cs) = T.atCtrs a
unless (null cs) $
do let example = T.TCon (T.abstractTypeTC a)
(map (T.TVar . T.tpVar) vs)
ns = T.addTNames vs emptyNameMap
rs = [ "•" <+> ppWithNames ns c | c <- cs ]
rPutStrLn ""
rPrint $ runDoc nameEnv $ nest 4 $
backticks (ppWithNames ns example) <+>
"requires:" $$ nest 2 (vcat rs)
doShowFix (T.atFixitiy a)
case T.atDoc a of
Nothing -> pure ()
Just d -> do rPutStrLn ""
rPutStrLn d
fromTyParam =
do p <- Map.lookup name (M.ifParamTypes params)
let uses c = T.TVBound (T.mtpParam p) `Set.member` T.fvs c
ctrs = filter uses (map P.thing (M.ifParamConstraints params))
ctrDoc = case ctrs of
[] -> empty
[x] -> pp x
xs -> parens $ hsep $ punctuate comma $ map pp xs
decl = text "parameter" <+> pp name <+> text ":"
<+> pp (T.mtpKind p)
$$ ctrDoc
return $ doShowTyHelp nameEnv decl (T.mtpDoc p)
doShowTyHelp nameEnv decl doc =
do rPutStrLn ""
rPrint (runDoc nameEnv (nest 4 decl))
case doc of
Nothing -> return ()
Just d -> rPutStrLn "" >> rPutStrLn d
doShowFix fx =
case fx of
Just f ->
let msg = "Precedence " ++ show (P.fLevel f) ++ ", " ++
(case P.fAssoc f of
P.LeftAssoc -> "associates to the left."
P.RightAssoc -> "associates to the right."
P.NonAssoc -> "does not associate.")
in rPutStrLn ('\n' : msg)
Nothing -> return ()
showValHelp params env nameEnv qname name =
fromMaybe (noInfo nameEnv name)
(msum [ fromDecl, fromNewtype, fromParameter ])
where
fromDecl =
do M.IfaceDecl { .. } <- Map.lookup name (M.ifDecls env)
return $
do rPutStrLn ""
let property
| P.PragmaProperty `elem` ifDeclPragmas = text "property"
| otherwise = empty
rPrint $ runDoc nameEnv
$ nest 4
$ property
<+> pp qname
<+> colon
<+> pp (ifDeclSig)
doShowFix $ ifDeclFixity `mplus`
(guard ifDeclInfix >> return P.defaultFixity)
case ifDeclDoc of
Just str -> rPutStrLn ('\n' : str)
Nothing -> return ()
fromNewtype =
do _ <- Map.lookup name (M.ifNewtypes env)
return $ return ()
fromParameter =
do p <- Map.lookup name (M.ifParamFuns params)
return $
do rPutStrLn ""
rPrint $ runDoc nameEnv
$ nest 4
$ text "parameter" <+> pp qname
<+> colon
<+> pp (T.mvpType p)
doShowFix (T.mvpFixity p)
case T.mvpDoc p of
Just str -> rPutStrLn ('\n' : str)
Nothing -> return ()
showCmdHelp c [arg] | ":set" `elem` cNames c = showOptionHelp arg
showCmdHelp c _args =
do rPutStrLn ("\n " ++ intercalate ", " (cNames c) ++ " " ++ intercalate " " (cArgs c))
rPutStrLn ""
rPutStrLn (cHelp c)
rPutStrLn ""
showOptionHelp arg =
case lookupTrieExact arg userOptions of
[opt] ->
do let k = optName opt
ev <- tryGetUser k
rPutStrLn $ "\n " ++ k ++ " = " ++ maybe "???" showEnvVal ev
rPutStrLn ""
rPutStrLn ("Default value: " ++ showEnvVal (optDefault opt))
rPutStrLn ""
rPutStrLn (optHelp opt)
rPutStrLn ""
[] -> rPutStrLn ("Unknown setting name `" ++ arg ++ "`")
_ -> rPutStrLn ("Ambiguous setting name `" ++ arg ++ "`")
runShellCmd :: String -> REPL ()
runShellCmd cmd
= io $ do h <- Process.runCommand cmd
_ <- waitForProcess h
return ()
cdCmd :: FilePath -> REPL ()
cdCmd f | null f = rPutStrLn $ "[error] :cd requires a path argument"
| otherwise = do
exists <- io $ doesDirectoryExist f
if exists
then io $ setCurrentDirectory f
else raise $ DirectoryNotFound f
-- C-c Handlings ---------------------------------------------------------------
-- XXX this should probably do something a bit more specific.
handleCtrlC :: a -> REPL a
handleCtrlC a = do rPutStrLn "Ctrl-C"
return a
-- Utilities -------------------------------------------------------------------
hasAnyModName :: [M.ModName] -> M.Name -> Bool
hasAnyModName mnames n =
case M.nameInfo n of
M.Declared m _ -> m `elem` mnames
M.Parameter -> False
-- | Lift a parsing action into the REPL monad.
replParse :: (String -> Either ParseError a) -> String -> REPL a
replParse parse str = case parse str of
Right a -> return a
Left e -> raise (ParseError e)
replParseInput :: String -> REPL (P.ReplInput P.PName)
replParseInput = replParse (parseReplWith interactiveConfig . T.pack)
replParseExpr :: String -> REPL (P.Expr P.PName)
replParseExpr = replParse (parseExprWith interactiveConfig . T.pack)
interactiveConfig :: Config
interactiveConfig = defaultConfig { cfgSource = "" }
getPrimMap :: REPL M.PrimMap
getPrimMap = liftModuleCmd M.getPrimMap
liftModuleCmd :: M.ModuleCmd a -> REPL a
liftModuleCmd cmd =
do evo <- getEvalOpts
env <- getModuleEnv
moduleCmdResult =<< io (cmd (evo,env))
moduleCmdResult :: M.ModuleRes a -> REPL a
moduleCmdResult (res,ws0) = do
warnDefaulting <- getKnownUser "warnDefaulting"
warnShadowing <- getKnownUser "warnShadowing"
-- XXX: let's generalize this pattern
let isDefaultWarn (T.DefaultingTo _ _) = True
isDefaultWarn _ = False
filterDefaults w | warnDefaulting = Just w
filterDefaults (M.TypeCheckWarnings xs) =
case filter (not . isDefaultWarn . snd) xs of
[] -> Nothing
ys -> Just (M.TypeCheckWarnings ys)
filterDefaults w = Just w
isShadowWarn (M.SymbolShadowed {}) = True
isShadowWarn _ = False
filterShadowing w | warnShadowing = Just w
filterShadowing (M.RenamerWarnings xs) =
case filter (not . isShadowWarn) xs of
[] -> Nothing
ys -> Just (M.RenamerWarnings ys)
filterShadowing w = Just w
let ws = mapMaybe filterDefaults . mapMaybe filterShadowing $ ws0
(_,_,_,names) <- getFocusedEnv
mapM_ (rPrint . runDoc names . pp) ws
case res of
Right (a,me') -> setModuleEnv me' >> return a
Left err ->
do e <- case err of
M.ErrorInFile (M.InFile file) e ->
-- on error, the file with the error becomes the edit
-- target. Note, however, that the focused module is not
-- changed.
do setEditPath file
return e
_ -> return err
raise (ModuleSystemError names e)
replCheckExpr :: P.Expr P.PName -> REPL (P.Expr M.Name,T.Expr,T.Schema)
replCheckExpr e = liftModuleCmd $ M.checkExpr e
-- | Check declarations as though they were defined at the top-level.
replCheckDecls :: [P.Decl P.PName] -> REPL [T.DeclGroup]
replCheckDecls ds = do
-- check the decls
npds <- liftModuleCmd (M.noPat ds)
let mkTop d = P.Decl P.TopLevel { P.tlExport = P.Public
, P.tlDoc = Nothing
, P.tlValue = d }
(names,ds') <- liftModuleCmd (M.checkDecls (map mkTop npds))
-- extend the naming env
denv <- getDynEnv
setDynEnv denv { M.deNames = names `M.shadowing` M.deNames denv }
return ds'
replSpecExpr :: T.Expr -> REPL T.Expr
replSpecExpr e = liftModuleCmd $ S.specialize e
replEvalExpr :: P.Expr P.PName -> REPL (E.Value, T.Type)
replEvalExpr expr =
do (_,def,sig) <- replCheckExpr expr
validEvalContext def
validEvalContext sig
me <- getModuleEnv
let cfg = M.meSolverConfig me
mbDef <- io $ SMT.withSolver cfg (\s -> defaultReplExpr s def sig)
(def1,ty) <-
case mbDef of
Nothing -> raise (EvalPolyError sig)
Just (tys,def1) ->
do warnDefaults tys
let su = T.listParamSubst tys
return (def1, T.apSubst su (T.sType sig))
val <- liftModuleCmd (rethrowEvalError . M.evalExpr def1)
whenDebug (rPutStrLn (dump def1))
-- add "it" to the namespace
bindItVariable ty def1
return (val,ty)
where
warnDefaults ts =
case ts of
[] -> return ()
_ ->
do warnDefaulting <- getKnownUser "warnDefaulting"
when warnDefaulting $
do rPutStrLn "Showing a specific instance of polymorphic result:"
mapM_ warnDefault ts
warnDefault (x,t) =
rPrint (" *" <+> nest 2 ("Using" <+> quotes (pp t) <+> "for" <+>
pp (T.tvarDesc (T.tpInfo x))))
itIdent :: M.Ident
itIdent = M.packIdent "it"
replWriteFile :: FilePath -> BS.ByteString -> (X.SomeException -> REPL ()) -> REPL ()
replWriteFile fp bytes handler =
do x <- io $ X.catch (BS.writeFile fp bytes >> return Nothing) (return . Just)
maybe (return ()) handler x
replReadFile :: FilePath -> (X.SomeException -> REPL (Maybe BS.ByteString)) -> REPL (Maybe BS.ByteString)
replReadFile fp handler =
do x <- io $ X.catch (Right `fmap` BS.readFile fp) (\e -> return $ Left e)
either handler (return . Just) x
-- | Creates a fresh binding of "it" to the expression given, and adds
-- it to the current dynamic environment
bindItVariable :: T.Type -> T.Expr -> REPL ()
bindItVariable ty expr = do
freshIt <- freshName itIdent M.UserName
let schema = T.Forall { T.sVars = []
, T.sProps = []
, T.sType = ty
}
decl = T.Decl { T.dName = freshIt
, T.dSignature = schema
, T.dDefinition = T.DExpr expr
, T.dPragmas = []
, T.dInfix = False
, T.dFixity = Nothing
, T.dDoc = Nothing
}
liftModuleCmd (M.evalDecls [T.NonRecursive decl])
denv <- getDynEnv
let nenv' = M.singletonE (P.UnQual itIdent) freshIt
`M.shadowing` M.deNames denv
setDynEnv $ denv { M.deNames = nenv' }
-- | Extend the dynamic environment with a fresh binding for "it",
-- as defined by the given value. If we cannot determine the definition
-- of the value, then we don't bind `it`.
bindItVariableVal :: T.Type -> E.Value -> REPL ()
bindItVariableVal ty val =
do prims <- getPrimMap
mb <- rEval (E.toExpr prims ty val)
case mb of
Nothing -> return ()
Just expr -> bindItVariable ty expr
-- | Creates a fresh binding of "it" to a finite sequence of
-- expressions of the same type, and adds that sequence to the current
-- dynamic environment
bindItVariables :: T.Type -> [T.Expr] -> REPL ()
bindItVariables ty exprs = bindItVariable seqTy seqExpr
where
len = length exprs
seqTy = T.tSeq (T.tNum len) ty
seqExpr = T.EList exprs ty
replEvalDecl :: P.Decl P.PName -> REPL ()
replEvalDecl decl = do
dgs <- replCheckDecls [decl]
validEvalContext dgs
whenDebug (mapM_ (\dg -> (rPutStrLn (dump dg))) dgs)
liftModuleCmd (M.evalDecls dgs)
replEdit :: String -> REPL Bool
replEdit file = do
mb <- io (lookupEnv "EDITOR")
let editor = fromMaybe "vim" mb
io $ do
(_,_,_,ph) <- createProcess (shell (unwords [editor, file]))
exit <- waitForProcess ph
return (exit == ExitSuccess)
type CommandMap = Trie CommandDescr
-- Command Parsing -------------------------------------------------------------
-- | Strip leading space.
sanitize :: String -> String
sanitize = dropWhile isSpace
-- | Strip trailing space.
sanitizeEnd :: String -> String
sanitizeEnd = reverse . sanitize . reverse
trim :: String -> String
trim = sanitizeEnd . sanitize
-- | Split at the first word boundary.
splitCommand :: String -> Maybe (String,String)
splitCommand txt =
case sanitize txt of
':' : more
| (as,bs) <- span (\x -> isPunctuation x || isSymbol x) more
, not (null as) -> Just (':' : as, sanitize bs)
| (as,bs) <- break isSpace more
, not (null as) -> Just (':' : as, sanitize bs)
| otherwise -> Nothing
expr -> guard (not (null expr)) >> return (expr,[])
-- | Uncons a list.
uncons :: [a] -> Maybe (a,[a])
uncons as = case as of
a:rest -> Just (a,rest)
_ -> Nothing
-- | Lookup a string in the command list.
findCommand :: String -> [CommandDescr]
findCommand str = lookupTrie str commands
-- | Lookup a string in the command list, returning an exact match
-- even if it's the prefix of another command.
findCommandExact :: String -> [CommandDescr]
findCommandExact str = lookupTrieExact str commands
-- | Lookup a string in the notebook-safe command list.
findNbCommand :: Bool -> String -> [CommandDescr]
findNbCommand True str = lookupTrieExact str nbCommands
findNbCommand False str = lookupTrie str nbCommands
-- | Parse a line as a command.
parseCommand :: (String -> [CommandDescr]) -> String -> Maybe Command
parseCommand findCmd line = do
(cmd,args) <- splitCommand line
let args' = sanitizeEnd args
case findCmd cmd of
[c] -> case cBody c of
ExprArg body -> Just (Command (body args'))
DeclsArg body -> Just (Command (body args'))
ExprTypeArg body -> Just (Command (body args'))
ModNameArg body -> Just (Command (body args'))
FilenameArg body -> Just (Command (body =<< expandHome args'))
OptionArg body -> Just (Command (body args'))
ShellArg body -> Just (Command (body args'))
HelpArg body -> Just (Command (body args'))
NoArg body -> Just (Command body)
FileExprArg body ->
case extractFilePath args' of
Just (fp,expr) -> Just (Command (expandHome fp >>= flip body expr))
Nothing -> Nothing
[] -> case uncons cmd of
Just (':',_) -> Just (Unknown cmd)
Just _ -> Just (Command (evalCmd line))
_ -> Nothing
cs -> Just (Ambiguous cmd (concatMap cNames cs))
where
expandHome path =
case path of
'~' : c : more | isPathSeparator c -> do dir <- io getHomeDirectory
return (dir > more)
_ -> return path
extractFilePath ipt =
let quoted q = (\(a,b) -> (a, drop 1 b)) . break (== q)
in case ipt of
"" -> Nothing
'\'':rest -> Just $ quoted '\'' rest
'"':rest -> Just $ quoted '"' rest
_ -> Just $ break isSpace ipt
cryptol-2.8.0/src/Cryptol/REPL/Monad.hs 0000644 0000000 0000000 00000066127 07346545000 016001 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.REPL.Monad
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
module Cryptol.REPL.Monad (
-- * REPL Monad
REPL(..), runREPL
, io
, raise
, stop
, catch
, finally
, rPutStrLn
, rPutStr
, rPrint
-- ** Errors
, REPLException(..)
, rethrowEvalError
-- ** Environment
, getFocusedEnv
, getModuleEnv, setModuleEnv
, getDynEnv, setDynEnv
, uniqify, freshName
, getTSyns, getNewtypes, getVars
, whenDebug
, getExprNames
, getTypeNames
, getPropertyNames
, getModNames
, LoadedModule(..), getLoadedMod, setLoadedMod, clearLoadedMod
, setEditPath, getEditPath, clearEditPath
, setSearchPath, prependSearchPath
, getPrompt
, shouldContinue
, unlessBatch
, asBatch
, disableLet
, enableLet
, getLetEnabled
, validEvalContext
, updateREPLTitle
, setUpdateREPLTitle
-- ** Config Options
, EnvVal(..)
, OptionDescr(..)
, setUser, getUser, getKnownUser, tryGetUser
, userOptions
, getUserSatNum
, getUserShowProverStats
, getUserProverValidate
-- ** Configurable Output
, getPutStr
, getLogger
, setPutStr
-- ** Smoke Test
, smokeTest
, Smoke(..)
) where
import Cryptol.REPL.Trie
import Cryptol.Eval (EvalError)
import qualified Cryptol.ModuleSystem as M
import qualified Cryptol.ModuleSystem.Env as M
import qualified Cryptol.ModuleSystem.Name as M
import qualified Cryptol.ModuleSystem.NamingEnv as M
import Cryptol.Parser (ParseError,ppError)
import Cryptol.Parser.NoInclude (IncludeError,ppIncludeError)
import Cryptol.Parser.NoPat (Error)
import Cryptol.Parser.Position (emptyRange, Range(from))
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.TypeCheck as T
import qualified Cryptol.IR.FreeVars as T
import qualified Cryptol.Utils.Ident as I
import Cryptol.Utils.PP
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.Logger(Logger, logPutStr, funLogger)
import qualified Cryptol.Parser.AST as P
import Cryptol.Symbolic (proverNames, lookupProver, SatNum(..))
import Control.Monad (ap,unless,when)
import Control.Monad.Base
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Data.Char (isSpace)
import Data.IORef
(IORef,newIORef,readIORef,modifyIORef,atomicModifyIORef)
import Data.List (intercalate, isPrefixOf, unfoldr, sortBy)
import Data.Maybe (catMaybes)
import Data.Ord (comparing)
import Data.Typeable (Typeable)
import System.Directory (findExecutable)
import qualified Control.Exception as X
import qualified Data.Map as Map
import qualified Data.Set as Set
import Text.Read (readMaybe)
import Data.SBV.Dynamic (sbvCheckSolverInstallation)
import Prelude ()
import Prelude.Compat
-- REPL Environment ------------------------------------------------------------
-- | This indicates what the user would like to work on.
data LoadedModule = LoadedModule
{ lName :: Maybe P.ModName -- ^ Working on this module.
, lPath :: M.ModulePath -- ^ Working on this file.
}
-- | REPL RW Environment.
data RW = RW
{ eLoadedMod :: Maybe LoadedModule
-- ^ This is the name of the currently "focused" module.
-- This is what we reload (:r)
, eEditFile :: Maybe FilePath
-- ^ This is what we edit (:e)
, eContinue :: Bool
-- ^ Should we keep going when we encounter an error, or give up.
, eIsBatch :: Bool
-- ^ Are we in batch mode.
, eModuleEnv :: M.ModuleEnv
-- ^ The current environment of all things loaded.
, eUserEnv :: UserEnv
-- ^ User settings
, eLogger :: Logger
-- ^ Use this to send messages to the user
, eLetEnabled :: Bool
-- ^ Should we allow `let` on the command line
, eUpdateTitle :: REPL ()
-- ^ Execute this every time we load a module.
-- This is used to change the title of terminal when loading a module.
}
-- | Initial, empty environment.
defaultRW :: Bool -> Logger -> IO RW
defaultRW isBatch l = do
env <- M.initialModuleEnv
return RW
{ eLoadedMod = Nothing
, eEditFile = Nothing
, eContinue = True
, eIsBatch = isBatch
, eModuleEnv = env
, eUserEnv = mkUserEnv userOptions
, eLogger = l
, eLetEnabled = True
, eUpdateTitle = return ()
}
-- | Build up the prompt for the REPL.
mkPrompt :: RW -> String
mkPrompt rw
| eIsBatch rw = ""
| detailedPrompt = withEdit ++ "> "
| otherwise = modLn ++ "> "
where
detailedPrompt = False
modLn =
case lName =<< eLoadedMod rw of
Nothing -> show (pp I.preludeName)
Just m
| M.isLoadedParamMod m (M.meLoadedModules (eModuleEnv rw)) ->
modName ++ "(parameterized)"
| otherwise -> modName
where modName = pretty m
withFocus =
case eLoadedMod rw of
Nothing -> modLn
Just m ->
case (lName m, lPath m) of
(Nothing, M.InFile f) -> ":r to reload " ++ show f ++ "\n" ++ modLn
_ -> modLn
withEdit =
case eEditFile rw of
Nothing -> withFocus
Just e
| Just (M.InFile f) <- lPath <$> eLoadedMod rw
, f == e -> withFocus
| otherwise -> ":e to edit " ++ e ++ "\n" ++ withFocus
-- REPL Monad ------------------------------------------------------------------
-- | REPL_ context with InputT handling.
newtype REPL a = REPL { unREPL :: IORef RW -> IO a }
-- | Run a REPL action with a fresh environment.
runREPL :: Bool -> Logger -> REPL a -> IO a
runREPL isBatch l m = do
ref <- newIORef =<< defaultRW isBatch l
unREPL m ref
instance Functor REPL where
{-# INLINE fmap #-}
fmap f m = REPL (\ ref -> fmap f (unREPL m ref))
instance Applicative REPL where
{-# INLINE pure #-}
pure = return
{-# INLINE (<*>) #-}
(<*>) = ap
instance Monad REPL where
{-# INLINE return #-}
return x = REPL (\_ -> return x)
{-# INLINE (>>=) #-}
m >>= f = REPL $ \ref -> do
x <- unREPL m ref
unREPL (f x) ref
instance MonadIO REPL where
liftIO = io
instance MonadBase IO REPL where
liftBase = liftIO
instance MonadBaseControl IO REPL where
type StM REPL a = a
liftBaseWith f = REPL $ \ref ->
f $ \m -> unREPL m ref
restoreM x = return x
instance M.FreshM REPL where
liftSupply f = modifyRW $ \ RW { .. } ->
let (a,s') = f (M.meSupply eModuleEnv)
in (RW { eModuleEnv = eModuleEnv { M.meSupply = s' }, .. },a)
-- Exceptions ------------------------------------------------------------------
-- | REPL exceptions.
data REPLException
= ParseError ParseError
| FileNotFound FilePath
| DirectoryNotFound FilePath
| NoPatError [Error]
| NoIncludeError [IncludeError]
| EvalError EvalError
| ModuleSystemError NameDisp M.ModuleError
| EvalPolyError T.Schema
| TypeNotTestable T.Type
| EvalInParamModule [M.Name]
| SBVError String
deriving (Show,Typeable)
instance X.Exception REPLException
instance PP REPLException where
ppPrec _ re = case re of
ParseError e -> ppError e
FileNotFound path -> sep [ text "File"
, text ("`" ++ path ++ "'")
, text"not found"
]
DirectoryNotFound path -> sep [ text "Directory"
, text ("`" ++ path ++ "'")
, text"not found or not a directory"
]
NoPatError es -> vcat (map pp es)
NoIncludeError es -> vcat (map ppIncludeError es)
ModuleSystemError ns me -> fixNameDisp ns (pp me)
EvalError e -> pp e
EvalPolyError s -> text "Cannot evaluate polymorphic value."
$$ text "Type:" <+> pp s
TypeNotTestable t -> text "The expression is not of a testable type."
$$ text "Type:" <+> pp t
EvalInParamModule xs ->
text "Expression depends on definitions from a parameterized module:"
$$ nest 2 (vcat (map pp xs))
SBVError s -> text "SBV error:" $$ text s
-- | Raise an exception.
raise :: REPLException -> REPL a
raise exn = io (X.throwIO exn)
catch :: REPL a -> (REPLException -> REPL a) -> REPL a
catch m k = REPL (\ ref -> rethrowEvalError (unREPL m ref) `X.catch` \ e -> unREPL (k e) ref)
finally :: REPL a -> REPL b -> REPL a
finally m1 m2 = REPL (\ref -> unREPL m1 ref `X.finally` unREPL m2 ref)
rethrowEvalError :: IO a -> IO a
rethrowEvalError m = run `X.catch` rethrow
where
run = do
a <- m
return $! a
rethrow :: EvalError -> IO a
rethrow exn = X.throwIO (EvalError exn)
-- Primitives ------------------------------------------------------------------
io :: IO a -> REPL a
io m = REPL (\ _ -> m)
getRW :: REPL RW
getRW = REPL readIORef
modifyRW :: (RW -> (RW,a)) -> REPL a
modifyRW f = REPL (\ ref -> atomicModifyIORef ref f)
modifyRW_ :: (RW -> RW) -> REPL ()
modifyRW_ f = REPL (\ ref -> modifyIORef ref f)
-- | Construct the prompt for the current environment.
getPrompt :: REPL String
getPrompt = mkPrompt `fmap` getRW
clearLoadedMod :: REPL ()
clearLoadedMod = do modifyRW_ (\rw -> rw { eLoadedMod = upd <$> eLoadedMod rw })
updateREPLTitle
where upd x = x { lName = Nothing }
-- | Set the name of the currently focused file, loaded via @:r@.
setLoadedMod :: LoadedModule -> REPL ()
setLoadedMod n = do
modifyRW_ (\ rw -> rw { eLoadedMod = Just n })
updateREPLTitle
getLoadedMod :: REPL (Maybe LoadedModule)
getLoadedMod = eLoadedMod `fmap` getRW
-- | Set the path for the ':e' command.
-- Note that this does not change the focused module (i.e., what ":r" reloads)
setEditPath :: FilePath -> REPL ()
setEditPath p = modifyRW_ $ \rw -> rw { eEditFile = Just p }
getEditPath :: REPL (Maybe FilePath)
getEditPath = eEditFile <$> getRW
clearEditPath :: REPL ()
clearEditPath = modifyRW_ $ \rw -> rw { eEditFile = Nothing }
setSearchPath :: [FilePath] -> REPL ()
setSearchPath path = do
me <- getModuleEnv
setModuleEnv $ me { M.meSearchPath = path }
prependSearchPath :: [FilePath] -> REPL ()
prependSearchPath path = do
me <- getModuleEnv
setModuleEnv $ me { M.meSearchPath = path ++ M.meSearchPath me }
shouldContinue :: REPL Bool
shouldContinue = eContinue `fmap` getRW
stop :: REPL ()
stop = modifyRW_ (\ rw -> rw { eContinue = False })
unlessBatch :: REPL () -> REPL ()
unlessBatch body = do
rw <- getRW
unless (eIsBatch rw) body
-- | Run a computation in batch mode, restoring the previous isBatch
-- flag afterwards
asBatch :: REPL a -> REPL a
asBatch body = do
wasBatch <- eIsBatch `fmap` getRW
modifyRW_ $ (\ rw -> rw { eIsBatch = True })
a <- body
modifyRW_ $ (\ rw -> rw { eIsBatch = wasBatch })
return a
disableLet :: REPL ()
disableLet = modifyRW_ (\ rw -> rw { eLetEnabled = False })
enableLet :: REPL ()
enableLet = modifyRW_ (\ rw -> rw { eLetEnabled = True })
-- | Are let-bindings enabled in this REPL?
getLetEnabled :: REPL Bool
getLetEnabled = fmap eLetEnabled getRW
-- | Is evaluation enabled. If the currently focused module is
-- parameterized, then we cannot evalute.
validEvalContext :: T.FreeVars a => a -> REPL ()
validEvalContext a =
do me <- eModuleEnv <$> getRW
let ds = T.freeVars a
badVals = foldr badName Set.empty (T.valDeps ds)
bad = foldr badName badVals (T.tyDeps ds)
badName nm bs =
case M.nameInfo nm of
M.Declared m _
| M.isLoadedParamMod m (M.meLoadedModules me) -> Set.insert nm bs
_ -> bs
unless (Set.null bad) $
raise (EvalInParamModule (Set.toList bad))
-- | Update the title
updateREPLTitle :: REPL ()
updateREPLTitle = unlessBatch $ do
rw <- getRW
eUpdateTitle rw
-- | Set the function that will be called when updating the title
setUpdateREPLTitle :: REPL () -> REPL ()
setUpdateREPLTitle m = modifyRW_ (\rw -> rw { eUpdateTitle = m })
-- | Set the REPL's string-printer
setPutStr :: (String -> IO ()) -> REPL ()
setPutStr fn = modifyRW_ $ \rw -> rw { eLogger = funLogger fn }
-- | Get the REPL's string-printer
getPutStr :: REPL (String -> IO ())
getPutStr =
do rw <- getRW
return (logPutStr (eLogger rw))
getLogger :: REPL Logger
getLogger = eLogger <$> getRW
-- | Use the configured output action to print a string
rPutStr :: String -> REPL ()
rPutStr str = do
f <- getPutStr
io (f str)
-- | Use the configured output action to print a string with a trailing newline
rPutStrLn :: String -> REPL ()
rPutStrLn str = rPutStr $ str ++ "\n"
-- | Use the configured output action to print something using its Show instance
rPrint :: Show a => a -> REPL ()
rPrint x = rPutStrLn (show x)
getFocusedEnv :: REPL (M.IfaceParams,M.IfaceDecls,M.NamingEnv,NameDisp)
getFocusedEnv = do
me <- getModuleEnv
-- dyNames is a NameEnv that removes the #Uniq prefix from interactively-bound
-- variables.
let (dyDecls,dyNames,dyDisp) = M.dynamicEnv me
let (fParams,fDecls,fNames,fDisp) = M.focusedEnv me
return ( fParams
, dyDecls `mappend` fDecls
, dyNames `M.shadowing` fNames
, dyDisp `mappend` fDisp)
-- -- the subtle part here is removing the #Uniq prefix from
-- -- interactively-bound variables, and also excluding any that are
-- -- shadowed and thus can no longer be referenced
-- let (fDecls,fNames,fDisp) = M.focusedEnv me
-- edecls = M.ifDecls dyDecls
-- -- is this QName something the user might actually type?
-- isShadowed (qn@(P.QName (Just (P.unModName -> ['#':_])) name), _) =
-- case Map.lookup localName neExprs of
-- Nothing -> False
-- Just uniqueNames -> isNamed uniqueNames
-- where localName = P.QName Nothing name
-- isNamed us = any (== qn) (map M.qname us)
-- neExprs = M.neExprs (M.deNames (M.meDynEnv me))
-- isShadowed _ = False
-- unqual ((P.QName _ name), ifds) = (P.QName Nothing name, ifds)
-- edecls' = Map.fromList
-- . map unqual
-- . filter isShadowed
-- $ Map.toList edecls
-- return (decls `mappend` mempty { M.ifDecls = edecls' }, names `mappend` dyNames)
getVars :: REPL (Map.Map M.Name M.IfaceDecl)
getVars = do
(_,decls,_,_) <- getFocusedEnv
return (M.ifDecls decls)
getTSyns :: REPL (Map.Map M.Name T.TySyn)
getTSyns = do
(_,decls,_,_) <- getFocusedEnv
return (M.ifTySyns decls)
getNewtypes :: REPL (Map.Map M.Name T.Newtype)
getNewtypes = do
(_,decls,_,_) <- getFocusedEnv
return (M.ifNewtypes decls)
-- | Get visible variable names.
getExprNames :: REPL [String]
getExprNames =
do (_,_, fNames, _) <- getFocusedEnv
return (map (show . pp) (Map.keys (M.neExprs fNames)))
-- | Get visible type signature names.
getTypeNames :: REPL [String]
getTypeNames =
do (_,_, fNames, _) <- getFocusedEnv
return (map (show . pp) (Map.keys (M.neTypes fNames)))
-- | Return a list of property names, sorted by position in the file.
getPropertyNames :: REPL ([M.Name],NameDisp)
getPropertyNames =
do (_,decls,_,names) <- getFocusedEnv
let xs = M.ifDecls decls
ps = sortBy (comparing (from . M.nameLoc))
$ [ x | (x,d) <- Map.toList xs, T.PragmaProperty `elem` M.ifDeclPragmas d ]
return (ps, names)
getModNames :: REPL [I.ModName]
getModNames =
do me <- getModuleEnv
return (map T.mName (M.loadedModules me))
getModuleEnv :: REPL M.ModuleEnv
getModuleEnv = eModuleEnv `fmap` getRW
setModuleEnv :: M.ModuleEnv -> REPL ()
setModuleEnv me = modifyRW_ (\rw -> rw { eModuleEnv = me })
getDynEnv :: REPL M.DynamicEnv
getDynEnv = (M.meDynEnv . eModuleEnv) `fmap` getRW
setDynEnv :: M.DynamicEnv -> REPL ()
setDynEnv denv = do
me <- getModuleEnv
setModuleEnv (me { M.meDynEnv = denv })
-- | Given an existing qualified name, prefix it with a
-- relatively-unique string. We make it unique by prefixing with a
-- character @#@ that is not lexically valid in a module name.
uniqify :: M.Name -> REPL M.Name
uniqify name =
case M.nameInfo name of
M.Declared ns s ->
M.liftSupply (M.mkDeclared ns s (M.nameIdent name) (M.nameFixity name) (M.nameLoc name))
M.Parameter ->
panic "[REPL] uniqify" ["tried to uniqify a parameter: " ++ pretty name]
-- uniqify (P.QName Nothing name) = do
-- i <- eNameSupply `fmap` getRW
-- modifyRW_ (\rw -> rw { eNameSupply = i+1 })
-- let modname' = P.mkModName [ '#' : ("Uniq_" ++ show i) ]
-- return (P.QName (Just modname') name)
-- uniqify qn =
-- panic "[REPL] uniqify" ["tried to uniqify a qualified name: " ++ pretty qn]
-- | Generate a fresh name using the given index. The name will reside within
-- the "" namespace.
freshName :: I.Ident -> M.NameSource -> REPL M.Name
freshName i sys =
M.liftSupply (M.mkDeclared I.interactiveName sys i Nothing emptyRange)
-- User Environment Interaction ------------------------------------------------
-- | User modifiable environment, for things like numeric base.
type UserEnv = Map.Map String EnvVal
data EnvVal
= EnvString String
| EnvProg String [String]
| EnvNum !Int
| EnvBool Bool
deriving (Show)
-- | Generate a UserEnv from a description of the options map.
mkUserEnv :: OptionMap -> UserEnv
mkUserEnv opts = Map.fromList $ do
opt <- leaves opts
return (optName opt, optDefault opt)
-- | Set a user option.
setUser :: String -> String -> REPL ()
setUser name val = case lookupTrieExact name userOptions of
[opt] -> setUserOpt opt
[] -> rPutStrLn ("Unknown env value `" ++ name ++ "`")
_ -> rPutStrLn ("Ambiguous env value `" ++ name ++ "`")
where
setUserOpt opt = case optDefault opt of
EnvString _ -> doCheck (EnvString val)
EnvProg _ _ ->
case splitOptArgs val of
prog:args -> doCheck (EnvProg prog args)
[] -> rPutStrLn ("Failed to parse command for field, `" ++ name ++ "`")
EnvNum _ -> case reads val of
[(x,_)] -> doCheck (EnvNum x)
_ -> rPutStrLn ("Failed to parse number for field, `" ++ name ++ "`")
EnvBool _
| any (`isPrefixOf` val) ["enable", "on", "yes", "true"] ->
writeEnv (EnvBool True)
| any (`isPrefixOf` val) ["disable", "off", "no", "false"] ->
writeEnv (EnvBool False)
| otherwise ->
rPutStrLn ("Failed to parse boolean for field, `" ++ name ++ "`")
where
doCheck v = do (r,ws) <- io (optCheck opt v)
case r of
Just err -> rPutStrLn err
Nothing -> do mapM_ rPutStrLn ws
writeEnv v
writeEnv ev =
do optEff opt ev
modifyRW_ (\rw -> rw { eUserEnv = Map.insert (optName opt) ev (eUserEnv rw) })
splitOptArgs :: String -> [String]
splitOptArgs = unfoldr (parse "")
where
parse acc (c:cs) | isQuote c = quoted (c:acc) cs
| not (isSpace c) = parse (c:acc) cs
| otherwise = result acc cs
parse acc [] = result acc []
quoted acc (c:cs) | isQuote c = parse (c:acc) cs
| otherwise = quoted (c:acc) cs
quoted acc [] = result acc []
result [] [] = Nothing
result [] cs = parse [] (dropWhile isSpace cs)
result acc cs = Just (reverse acc, dropWhile isSpace cs)
isQuote :: Char -> Bool
isQuote c = c `elem` ("'\"" :: String)
-- | Get a user option, using Maybe for failure.
tryGetUser :: String -> REPL (Maybe EnvVal)
tryGetUser name = do
rw <- getRW
return (Map.lookup name (eUserEnv rw))
-- | Get a user option, when it's known to exist. Fail with panic when it
-- doesn't.
getUser :: String -> REPL EnvVal
getUser name = do
mb <- tryGetUser name
case mb of
Just ev -> return ev
Nothing -> panic "[REPL] getUser" ["option `" ++ name ++ "` does not exist"]
getKnownUser :: IsEnvVal a => String -> REPL a
getKnownUser x = fromEnvVal <$> getUser x
class IsEnvVal a where
fromEnvVal :: EnvVal -> a
instance IsEnvVal Bool where
fromEnvVal x = case x of
EnvBool b -> b
_ -> badIsEnv "Bool"
instance IsEnvVal Int where
fromEnvVal x = case x of
EnvNum b -> b
_ -> badIsEnv "Num"
instance IsEnvVal (String,[String]) where
fromEnvVal x = case x of
EnvProg b bs -> (b,bs)
_ -> badIsEnv "Prog"
instance IsEnvVal String where
fromEnvVal x = case x of
EnvString b -> b
_ -> badIsEnv "String"
badIsEnv :: String -> a
badIsEnv x = panic "fromEnvVal" [ "[REPL] Expected a `" ++ x ++ "` value." ]
getUserShowProverStats :: REPL Bool
getUserShowProverStats = getKnownUser "prover-stats"
getUserProverValidate :: REPL Bool
getUserProverValidate = getKnownUser "prover-validate"
-- Environment Options ---------------------------------------------------------
type OptionMap = Trie OptionDescr
mkOptionMap :: [OptionDescr] -> OptionMap
mkOptionMap = foldl insert emptyTrie
where
insert m d = insertTrie (optName d) d m
-- | Returns maybe an error, and some warnings
type Checker = EnvVal -> IO (Maybe String, [String])
noCheck :: Checker
noCheck _ = return (Nothing, [])
noWarns :: Maybe String -> IO (Maybe String, [String])
noWarns mb = return (mb, [])
data OptionDescr = OptionDescr
{ optName :: String
, optDefault :: EnvVal
, optCheck :: Checker
, optHelp :: String
, optEff :: EnvVal -> REPL ()
}
simpleOpt :: String -> EnvVal -> Checker -> String -> OptionDescr
simpleOpt optName optDefault optCheck optHelp =
OptionDescr { optEff = \ _ -> return (), .. }
userOptions :: OptionMap
userOptions = mkOptionMap
[ simpleOpt "base" (EnvNum 16) checkBase
"The base to display words at (2, 8, 10, or 16)."
, simpleOpt "debug" (EnvBool False) noCheck
"Enable debugging output."
, simpleOpt "ascii" (EnvBool False) noCheck
"Whether to display 7- or 8-bit words using ASCII notation."
, simpleOpt "infLength" (EnvNum 5) checkInfLength
"The number of elements to display for infinite sequences."
, simpleOpt "tests" (EnvNum 100) noCheck
"The number of random tests to try with ':check'."
, simpleOpt "satNum" (EnvString "1") checkSatNum
"The maximum number of :sat solutions to display (\"all\" for no limit)."
, simpleOpt "prover" (EnvString "z3") checkProver $
"The external SMT solver for ':prove' and ':sat'\n(" ++ proverListString ++ ")."
, simpleOpt "warnDefaulting" (EnvBool True) noCheck
"Choose whether to display warnings when defaulting."
, simpleOpt "warnShadowing" (EnvBool True) noCheck
"Choose whether to display warnings when shadowing symbols."
, simpleOpt "smtfile" (EnvString "-") noCheck
"The file to use for SMT-Lib scripts (for debugging or offline proving).\nUse \"-\" for stdout."
, OptionDescr "mono-binds" (EnvBool True) noCheck
"Whether or not to generalize bindings in a 'where' clause." $
\case EnvBool b -> do me <- getModuleEnv
setModuleEnv me { M.meMonoBinds = b }
_ -> return ()
, OptionDescr "tc-solver" (EnvProg "z3" [ "-smt2", "-in" ])
noCheck -- TODO: check for the program in the path
"The solver that will be used by the type checker." $
\case EnvProg prog args -> do me <- getModuleEnv
let cfg = M.meSolverConfig me
setModuleEnv me { M.meSolverConfig =
cfg { T.solverPath = prog
, T.solverArgs = args } }
_ -> return ()
, OptionDescr "tc-debug" (EnvNum 0)
noCheck
"Enable type-checker debugging output." $
\case EnvNum n -> do me <- getModuleEnv
let cfg = M.meSolverConfig me
setModuleEnv me { M.meSolverConfig = cfg{ T.solverVerbose = n } }
_ -> return ()
, OptionDescr "core-lint" (EnvBool False)
noCheck
"Enable sanity checking of type-checker." $
let setIt x = do me <- getModuleEnv
setModuleEnv me { M.meCoreLint = x }
in \case EnvBool True -> setIt M.CoreLint
EnvBool False -> setIt M.NoCoreLint
_ -> return ()
, simpleOpt "prover-stats" (EnvBool True) noCheck
"Enable prover timing statistics."
, simpleOpt "prover-validate" (EnvBool False) noCheck
"Validate :sat examples and :prove counter-examples for correctness."
, simpleOpt "show-examples" (EnvBool True) noCheck
"Print the (counter) example after :sat or :prove"
]
-- | Check the value to the `base` option.
checkBase :: Checker
checkBase val = case val of
EnvNum n
| n `elem` [2,8,10,16] -> noWarns Nothing
| otherwise -> noWarns $ Just "base must be 2, 8, 10, or 16"
_ -> noWarns $ Just "unable to parse a value for base"
checkInfLength :: Checker
checkInfLength val = case val of
EnvNum n
| n >= 0 -> noWarns Nothing
| otherwise -> noWarns $ Just "the number of elements should be positive"
_ -> noWarns $ Just "unable to parse a value for infLength"
checkProver :: Checker
checkProver val = case val of
EnvString s
| s `notElem` proverNames ->
noWarns $ Just $ "Prover must be " ++ proverListString
| s `elem` ["offline", "any"] -> noWarns Nothing
| otherwise ->
do let prover = lookupProver s
available <- sbvCheckSolverInstallation prover
let ws = if available
then []
else ["Warning: " ++ s ++ " installation not found"]
return (Nothing, ws)
_ -> noWarns $ Just "unable to parse a value for prover"
proverListString :: String
proverListString = concatMap (++ ", ") (init proverNames) ++ "or " ++ last proverNames
checkSatNum :: Checker
checkSatNum val = case val of
EnvString "all" -> noWarns Nothing
EnvString s ->
case readMaybe s :: Maybe Int of
Just n | n >= 1 -> noWarns Nothing
_ -> noWarns $ Just "must be an integer > 0 or \"all\""
_ -> noWarns $ Just "unable to parse a value for satNum"
getUserSatNum :: REPL SatNum
getUserSatNum = do
s <- getKnownUser "satNum"
case s of
"all" -> return AllSat
_ | Just n <- readMaybe s -> return (SomeSat n)
_ -> panic "REPL.Monad.getUserSatNum"
[ "invalid satNum option" ]
-- Environment Utilities -------------------------------------------------------
whenDebug :: REPL () -> REPL ()
whenDebug m = do
b <- getKnownUser "debug"
when b m
-- Smoke Testing ---------------------------------------------------------------
smokeTest :: REPL [Smoke]
smokeTest = catMaybes <$> sequence tests
where
tests = [ z3exists ]
type SmokeTest = REPL (Maybe Smoke)
data Smoke
= Z3NotFound
deriving (Show, Eq)
instance PP Smoke where
ppPrec _ smoke =
case smoke of
Z3NotFound -> text . intercalate " " $ [
"[error] z3 is required to run Cryptol, but was not found in the"
, "system path. See the Cryptol README for more on how to install z3."
]
z3exists :: SmokeTest
z3exists = do
mPath <- io $ findExecutable "z3"
case mPath of
Nothing -> return (Just Z3NotFound)
Just _ -> return Nothing
cryptol-2.8.0/src/Cryptol/REPL/Trie.hs 0000644 0000000 0000000 00000003316 07346545000 015635 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.REPL.Trie
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
module Cryptol.REPL.Trie where
import Cryptol.Utils.Panic (panic)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe,maybeToList)
-- | Maps string names to values, allowing for partial key matches and querying.
data Trie a = Node (Map.Map Char (Trie a)) (Maybe a)
deriving (Show)
emptyTrie :: Trie a
emptyTrie = Node Map.empty Nothing
-- | Insert a value into the Trie. Will call `panic` if a value already exists
-- with that key.
insertTrie :: String -> a -> Trie a -> Trie a
insertTrie k a = loop k
where
loop key (Node m mb) = case key of
c:cs -> Node (Map.alter (Just . loop cs . fromMaybe emptyTrie) c m) mb
[] -> case mb of
Nothing -> Node m (Just a)
Just _ -> panic "[REPL] Trie" ["key already exists:", "\t" ++ k]
-- | Return all matches with the given prefix.
lookupTrie :: String -> Trie a -> [a]
lookupTrie key t@(Node mp _) = case key of
c:cs -> case Map.lookup c mp of
Just m' -> lookupTrie cs m'
Nothing -> []
[] -> leaves t
-- | Given a key, return either an exact match for that key, or all
-- matches with the given prefix.
lookupTrieExact :: String -> Trie a -> [a]
lookupTrieExact [] (Node _ (Just x)) = return x
lookupTrieExact [] t = leaves t
lookupTrieExact (c:cs) (Node mp _) =
case Map.lookup c mp of
Just m' -> lookupTrieExact cs m'
Nothing -> []
-- | Return all of the values from a Trie.
leaves :: Trie a -> [a]
leaves (Node mp mb) = maybeToList mb ++ concatMap leaves (Map.elems mp)
cryptol-2.8.0/src/Cryptol/Symbolic.hs 0000644 0000000 0000000 00000036522 07346545000 015756 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Symbolic
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module Cryptol.Symbolic where
import Control.Monad.IO.Class
import Control.Monad (replicateM, when, zipWithM, foldM)
import Control.Monad.Writer (WriterT, runWriterT, tell, lift)
import Data.List (intercalate, genericLength)
import Data.IORef(IORef)
import qualified Control.Exception as X
import qualified Data.SBV.Dynamic as SBV
import Data.SBV (Timing(SaveTiming))
import Data.SBV.Internals (showTDiff)
import qualified Cryptol.ModuleSystem as M hiding (getPrimMap)
import qualified Cryptol.ModuleSystem.Env as M
import qualified Cryptol.ModuleSystem.Base as M
import qualified Cryptol.ModuleSystem.Monad as M
import Cryptol.Symbolic.Prims
import Cryptol.Symbolic.Value
import qualified Cryptol.Eval as Eval
import qualified Cryptol.Eval.Monad as Eval
import qualified Cryptol.Eval.Type as Eval
import qualified Cryptol.Eval.Value as Eval
import Cryptol.Eval.Env (GenEvalEnv(..))
import Cryptol.TypeCheck.AST
import Cryptol.Utils.Ident (Ident)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.Logger(logPutStrLn)
import Prelude ()
import Prelude.Compat
import Data.Time (NominalDiffTime)
type EvalEnv = GenEvalEnv SBool SWord
-- External interface ----------------------------------------------------------
proverConfigs :: [(String, SBV.SMTConfig)]
proverConfigs =
[ ("cvc4" , SBV.cvc4 )
, ("yices" , SBV.yices )
, ("z3" , SBV.z3 )
, ("boolector", SBV.boolector)
, ("mathsat" , SBV.mathSAT )
, ("abc" , SBV.abc )
, ("offline" , SBV.defaultSMTCfg )
, ("any" , SBV.defaultSMTCfg )
]
proverNames :: [String]
proverNames = map fst proverConfigs
lookupProver :: String -> SBV.SMTConfig
lookupProver s =
case lookup s proverConfigs of
Just cfg -> cfg
-- should be caught by UI for setting prover user variable
Nothing -> panic "Cryptol.Symbolic" [ "invalid prover: " ++ s ]
type SatResult = [(Type, Expr, Eval.Value)]
data SatNum = AllSat | SomeSat Int
deriving (Show)
data QueryType = SatQuery SatNum | ProveQuery
deriving (Show)
data ProverCommand = ProverCommand {
pcQueryType :: QueryType
-- ^ The type of query to run
, pcProverName :: String
-- ^ Which prover to use (one of the strings in 'proverConfigs')
, pcVerbose :: Bool
-- ^ Verbosity flag passed to SBV
, pcValidate :: Bool
-- ^ Model validation flag passed to SBV
, pcProverStats :: !(IORef ProverStats)
-- ^ Record timing information here
, pcExtraDecls :: [DeclGroup]
-- ^ Extra declarations to bring into scope for symbolic
-- simulation
, pcSmtFile :: Maybe FilePath
-- ^ Optionally output the SMTLIB query to a file
, pcExpr :: Expr
-- ^ The typechecked expression to evaluate
, pcSchema :: Schema
-- ^ The 'Schema' of @pcExpr@
}
type ProverStats = NominalDiffTime
-- | A prover result is either an error message, an empty result (eg
-- for the offline prover), a counterexample or a lazy list of
-- satisfying assignments.
data ProverResult = AllSatResult [SatResult] -- LAZY
| ThmResult [Type]
| EmptyResult
| ProverError String
satSMTResults :: SBV.SatResult -> [SBV.SMTResult]
satSMTResults (SBV.SatResult r) = [r]
allSatSMTResults :: SBV.AllSatResult -> [SBV.SMTResult]
allSatSMTResults (SBV.AllSatResult (_, _, _, rs)) = rs
thmSMTResults :: SBV.ThmResult -> [SBV.SMTResult]
thmSMTResults (SBV.ThmResult r) = [r]
proverError :: String -> M.ModuleCmd (Maybe SBV.Solver, ProverResult)
proverError msg (_,modEnv) =
return (Right ((Nothing, ProverError msg), modEnv), [])
satProve :: ProverCommand -> M.ModuleCmd (Maybe SBV.Solver, ProverResult)
satProve ProverCommand {..} =
protectStack proverError $ \(evo,modEnv) ->
M.runModuleM (evo,modEnv) $ do
let (isSat, mSatNum) = case pcQueryType of
ProveQuery -> (False, Nothing)
SatQuery sn -> case sn of
SomeSat n -> (True, Just n)
AllSat -> (True, Nothing)
let extDgs = allDeclGroups modEnv ++ pcExtraDecls
provers <-
case pcProverName of
"any" -> M.io SBV.sbvAvailableSolvers
_ -> return [(lookupProver pcProverName) { SBV.transcript = pcSmtFile
, SBV.allSatMaxModelCount = mSatNum
}]
let provers' = [ p { SBV.timing = SaveTiming pcProverStats
, SBV.verbose = pcVerbose
, SBV.validateModel = pcValidate
} | p <- provers ]
let tyFn = if isSat then existsFinType else forallFinType
let lPutStrLn = M.withLogger logPutStrLn
let doEval :: MonadIO m => Eval.Eval a -> m a
doEval m = liftIO $ Eval.runEval evo m
let runProver fn tag e = do
case provers of
[prover] -> do
when pcVerbose $
lPutStrLn $ "Trying proof with " ++
show (SBV.name (SBV.solver prover))
res <- M.io (fn prover e)
when pcVerbose $
lPutStrLn $ "Got result from " ++
show (SBV.name (SBV.solver prover))
return (Just (SBV.name (SBV.solver prover)), tag res)
_ ->
return ( Nothing
, [ SBV.ProofError
prover
[":sat with option prover=any requires option satNum=1"]
Nothing
| prover <- provers ]
)
runProvers fn tag e = do
when pcVerbose $
lPutStrLn $ "Trying proof with " ++
intercalate ", " (map (show . SBV.name . SBV.solver) provers)
(firstProver, timeElapsed, res) <- M.io (fn provers' e)
when pcVerbose $
lPutStrLn $ "Got result from " ++ show firstProver ++
", time: " ++ showTDiff timeElapsed
return (Just firstProver, tag res)
let runFn = case pcQueryType of
ProveQuery -> runProvers SBV.proveWithAny thmSMTResults
SatQuery sn -> case sn of
SomeSat 1 -> runProvers SBV.satWithAny satSMTResults
_ -> runProver SBV.allSatWith allSatSMTResults
let addAsm = case pcQueryType of
ProveQuery -> \x y -> SBV.svOr (SBV.svNot x) y
SatQuery _ -> \x y -> SBV.svAnd x y
case predArgTypes pcSchema of
Left msg -> return (Nothing, ProverError msg)
Right ts -> do when pcVerbose $ lPutStrLn "Simulating..."
v <- doEval $ do env <- Eval.evalDecls extDgs mempty
Eval.evalExpr env pcExpr
prims <- M.getPrimMap
runRes <- runFn $ do
(args, asms) <- runWriterT (mapM tyFn ts)
b <- doEval (fromVBit <$>
foldM fromVFun v (map Eval.ready args))
return (foldr addAsm b asms)
let (firstProver, results) = runRes
esatexprs <- case results of
-- allSat can return more than one as long as
-- they're satisfiable
(SBV.Satisfiable {} : _) -> do
tevss <- mapM mkTevs results
return $ AllSatResult tevss
where
mkTevs result = do
let Right (_, cvs) = SBV.getModelAssignment result
(vs, _) = parseValues ts cvs
sattys = unFinType <$> ts
satexprs <-
doEval (zipWithM (Eval.toExpr prims) sattys vs)
case zip3 sattys <$> (sequence satexprs) <*> pure vs of
Nothing ->
panic "Cryptol.Symbolic.sat"
[ "unable to make assignment into expression" ]
Just tevs -> return $ tevs
-- prove returns only one
[SBV.Unsatisfiable {}] ->
return $ ThmResult (unFinType <$> ts)
-- unsat returns empty
[] -> return $ ThmResult (unFinType <$> ts)
-- otherwise something is wrong
_ -> return $ ProverError (rshow results)
where rshow | isSat = show . SBV.AllSatResult . (False,False,False,)
| otherwise = show . SBV.ThmResult . head
return (firstProver, esatexprs)
satProveOffline :: ProverCommand -> M.ModuleCmd (Either String String)
satProveOffline ProverCommand {..} =
protectStack (\msg (_,modEnv) -> return (Right (Left msg, modEnv), [])) $
\(evOpts,modEnv) -> do
let isSat = case pcQueryType of
ProveQuery -> False
SatQuery _ -> True
let extDgs = allDeclGroups modEnv ++ pcExtraDecls
let tyFn = if isSat then existsFinType else forallFinType
let addAsm = if isSat then SBV.svAnd else \x y -> SBV.svOr (SBV.svNot x) y
case predArgTypes pcSchema of
Left msg -> return (Right (Left msg, modEnv), [])
Right ts ->
do when pcVerbose $ logPutStrLn (Eval.evalLogger evOpts) "Simulating..."
v <- liftIO $ Eval.runEval evOpts $
do env <- Eval.evalDecls extDgs mempty
Eval.evalExpr env pcExpr
smtlib <- SBV.generateSMTBenchmark isSat $ do
(args, asms) <- runWriterT (mapM tyFn ts)
b <- liftIO $ Eval.runEval evOpts
(fromVBit <$> foldM fromVFun v (map Eval.ready args))
return (foldr addAsm b asms)
return (Right (Right smtlib, modEnv), [])
protectStack :: (String -> M.ModuleCmd a)
-> M.ModuleCmd a
-> M.ModuleCmd a
protectStack mkErr cmd modEnv =
X.catchJust isOverflow (cmd modEnv) handler
where isOverflow X.StackOverflow = Just ()
isOverflow _ = Nothing
msg = "Symbolic evaluation failed to terminate."
handler () = mkErr msg modEnv
parseValues :: [FinType] -> [SBV.CV] -> ([Eval.Value], [SBV.CV])
parseValues [] cvs = ([], cvs)
parseValues (t : ts) cvs = (v : vs, cvs'')
where (v, cvs') = parseValue t cvs
(vs, cvs'') = parseValues ts cvs'
parseValue :: FinType -> [SBV.CV] -> (Eval.Value, [SBV.CV])
parseValue FTBit [] = panic "Cryptol.Symbolic.parseValue" [ "empty FTBit" ]
parseValue FTBit (cv : cvs) = (Eval.VBit (SBV.cvToBool cv), cvs)
parseValue FTInteger cvs =
case SBV.genParse SBV.KUnbounded cvs of
Just (x, cvs') -> (Eval.VInteger x, cvs')
Nothing -> panic "Cryptol.Symbolic.parseValue" [ "no integer" ]
parseValue (FTIntMod _) cvs = parseValue FTInteger cvs
parseValue (FTSeq 0 FTBit) cvs = (Eval.word 0 0, cvs)
parseValue (FTSeq n FTBit) cvs =
case SBV.genParse (SBV.KBounded False n) cvs of
Just (x, cvs') -> (Eval.word (toInteger n) x, cvs')
Nothing -> (VWord (genericLength vs) $ return $ Eval.WordVal $
Eval.packWord (map fromVBit vs), cvs')
where (vs, cvs') = parseValues (replicate n FTBit) cvs
parseValue (FTSeq n t) cvs =
(Eval.VSeq (toInteger n) $ Eval.finiteSeqMap (map Eval.ready vs)
, cvs'
)
where (vs, cvs') = parseValues (replicate n t) cvs
parseValue (FTTuple ts) cvs = (Eval.VTuple (map Eval.ready vs), cvs')
where (vs, cvs') = parseValues ts cvs
parseValue (FTRecord fs) cvs = (Eval.VRecord (zip ns (map Eval.ready vs)), cvs')
where (ns, ts) = unzip fs
(vs, cvs') = parseValues ts cvs
allDeclGroups :: M.ModuleEnv -> [DeclGroup]
allDeclGroups = concatMap mDecls . M.loadedNonParamModules
data FinType
= FTBit
| FTInteger
| FTIntMod Integer
| FTSeq Int FinType
| FTTuple [FinType]
| FTRecord [(Ident, FinType)]
numType :: Integer -> Maybe Int
numType n
| 0 <= n && n <= toInteger (maxBound :: Int) = Just (fromInteger n)
| otherwise = Nothing
finType :: TValue -> Maybe FinType
finType ty =
case ty of
Eval.TVBit -> Just FTBit
Eval.TVInteger -> Just FTInteger
Eval.TVIntMod n -> Just (FTIntMod n)
Eval.TVSeq n t -> FTSeq <$> numType n <*> finType t
Eval.TVTuple ts -> FTTuple <$> traverse finType ts
Eval.TVRec fields -> FTRecord <$> traverse (traverseSnd finType) fields
Eval.TVAbstract {} -> Nothing
_ -> Nothing
unFinType :: FinType -> Type
unFinType fty =
case fty of
FTBit -> tBit
FTInteger -> tInteger
FTIntMod n -> tIntMod (tNum n)
FTSeq l ety -> tSeq (tNum l) (unFinType ety)
FTTuple ftys -> tTuple (unFinType <$> ftys)
FTRecord fs -> tRec (zip fns tys)
where
fns = fst <$> fs
tys = unFinType . snd <$> fs
predArgTypes :: Schema -> Either String [FinType]
predArgTypes schema@(Forall ts ps ty)
| null ts && null ps =
case go <$> (Eval.evalType mempty ty) of
Right (Just fts) -> Right fts
_ -> Left $ "Not a valid predicate type:\n" ++ show (pp schema)
| otherwise = Left $ "Not a monomorphic type:\n" ++ show (pp schema)
where
go :: TValue -> Maybe [FinType]
go Eval.TVBit = Just []
go (Eval.TVFun ty1 ty2) = (:) <$> finType ty1 <*> go ty2
go _ = Nothing
inBoundsIntMod :: Integer -> SInteger -> SBool
inBoundsIntMod n x =
SBV.svAnd (SBV.svLessEq (Eval.integerLit 0) x) (SBV.svLessThan x (Eval.integerLit n))
forallFinType :: FinType -> WriterT [SBool] SBV.Symbolic Value
forallFinType ty =
case ty of
FTBit -> VBit <$> lift forallSBool_
FTInteger -> VInteger <$> lift forallSInteger_
FTIntMod n -> do x <- lift forallSInteger_
tell [inBoundsIntMod n x]
return (VInteger x)
FTSeq 0 FTBit -> return $ Eval.word 0 0
FTSeq n FTBit -> VWord (toInteger n) . return . Eval.WordVal <$> lift (forallBV_ n)
FTSeq n t -> do vs <- replicateM n (forallFinType t)
return $ VSeq (toInteger n) $ Eval.finiteSeqMap (map Eval.ready vs)
FTTuple ts -> VTuple <$> mapM (fmap Eval.ready . forallFinType) ts
FTRecord fs -> VRecord <$> mapM (traverseSnd (fmap Eval.ready . forallFinType)) fs
existsFinType :: FinType -> WriterT [SBool] SBV.Symbolic Value
existsFinType ty =
case ty of
FTBit -> VBit <$> lift existsSBool_
FTInteger -> VInteger <$> lift existsSInteger_
FTIntMod n -> do x <- lift existsSInteger_
tell [inBoundsIntMod n x]
return (VInteger x)
FTSeq 0 FTBit -> return $ Eval.word 0 0
FTSeq n FTBit -> VWord (toInteger n) . return . Eval.WordVal <$> lift (existsBV_ n)
FTSeq n t -> do vs <- replicateM n (existsFinType t)
return $ VSeq (toInteger n) $ Eval.finiteSeqMap (map Eval.ready vs)
FTTuple ts -> VTuple <$> mapM (fmap Eval.ready . existsFinType) ts
FTRecord fs -> VRecord <$> mapM (traverseSnd (fmap Eval.ready . existsFinType)) fs
cryptol-2.8.0/src/Cryptol/Symbolic/ 0000755 0000000 0000000 00000000000 07346545000 015412 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/Symbolic/Prims.hs 0000644 0000000 0000000 00000057111 07346545000 017045 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Symbolic.Prims
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Cryptol.Symbolic.Prims where
import Control.Monad (unless)
import Data.Bits
import qualified Data.Sequence as Seq
import qualified Data.Foldable as Fold
import Cryptol.Eval.Monad (Eval(..), ready, invalidIndex, cryUserError)
import Cryptol.Eval.Type (finNat', TValue(..))
import Cryptol.Eval.Value (BitWord(..), EvalPrims(..), enumerateSeqMap, SeqMap(..),
reverseSeqMap, wlam, nlam, WordValue(..),
asWordVal, fromWordVal, fromBit,
enumerateWordValue, enumerateWordValueRev,
wordValueSize,
updateWordValue,
updateSeqMap, lookupSeqMap, memoMap )
import Cryptol.Prims.Eval (binary, unary, arithUnary,
arithBinary, Binary, BinArith,
logicBinary, logicUnary, zeroV,
ccatV, splitAtV, joinV, ecSplitV,
reverseV, infFromV, infFromThenV,
fromToV, fromThenToV,
transposeV, indexPrim,
ecToIntegerV, ecFromIntegerV,
ecNumberV, updatePrim, randomV, liftWord,
cmpValue, lg2)
import Cryptol.Symbolic.Value
import Cryptol.TypeCheck.AST (Decl(..))
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), widthInteger)
import Cryptol.ModuleSystem.Name (asPrim)
import Cryptol.Utils.Ident (Ident,mkIdent)
import qualified Data.SBV as SBV
import qualified Data.SBV.Dynamic as SBV
import qualified Data.Map as Map
import qualified Data.Text as T
import Prelude ()
import Prelude.Compat
import Control.Monad (join)
traverseSnd :: Functor f => (a -> f b) -> (t, a) -> f (t, b)
traverseSnd f (x, y) = (,) x <$> f y
-- Primitives ------------------------------------------------------------------
instance EvalPrims SBool SWord SInteger where
evalPrim Decl { dName = n, .. } =
do prim <- asPrim n
Map.lookup prim primTable
iteValue b x1 x2
| Just b' <- SBV.svAsBool b = if b' then x1 else x2
| otherwise = do v1 <- x1
v2 <- x2
iteSValue b v1 v2
-- See also Cryptol.Prims.Eval.primTable
primTable :: Map.Map Ident Value
primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
[ ("True" , VBit SBV.svTrue)
, ("False" , VBit SBV.svFalse)
, ("number" , ecNumberV) -- Converts a numeric type into its corresponding value.
-- { val, rep } (Literal val rep) => rep
, ("+" , binary (arithBinary (liftBinArith SBV.svPlus) (liftBin SBV.svPlus)
sModAdd)) -- {a} (Arith a) => a -> a -> a
, ("-" , binary (arithBinary (liftBinArith SBV.svMinus) (liftBin SBV.svMinus)
sModSub)) -- {a} (Arith a) => a -> a -> a
, ("*" , binary (arithBinary (liftBinArith SBV.svTimes) (liftBin SBV.svTimes)
sModMult)) -- {a} (Arith a) => a -> a -> a
, ("/" , binary (arithBinary (liftBinArith SBV.svQuot) (liftBin SBV.svQuot)
(liftModBin SBV.svQuot))) -- {a} (Arith a) => a -> a -> a
, ("%" , binary (arithBinary (liftBinArith SBV.svRem) (liftBin SBV.svRem)
(liftModBin SBV.svRem))) -- {a} (Arith a) => a -> a -> a
, ("^^" , binary (arithBinary sExp (liftBin SBV.svExp)
sModExp)) -- {a} (Arith a) => a -> a -> a
, ("lg2" , unary (arithUnary sLg2 svLg2 svModLg2)) -- {a} (Arith a) => a -> a
, ("negate" , unary (arithUnary (\_ -> ready . SBV.svUNeg) (ready . SBV.svUNeg)
(const (ready . SBV.svUNeg))))
, ("<" , binary (cmpBinary cmpLt cmpLt cmpLt (cmpMod cmpLt) SBV.svFalse))
, (">" , binary (cmpBinary cmpGt cmpGt cmpGt (cmpMod cmpGt) SBV.svFalse))
, ("<=" , binary (cmpBinary cmpLtEq cmpLtEq cmpLtEq (cmpMod cmpLtEq) SBV.svTrue))
, (">=" , binary (cmpBinary cmpGtEq cmpGtEq cmpGtEq (cmpMod cmpGtEq) SBV.svTrue))
, ("==" , binary (cmpBinary cmpEq cmpEq cmpEq cmpModEq SBV.svTrue))
, ("!=" , binary (cmpBinary cmpNotEq cmpNotEq cmpNotEq cmpModNotEq SBV.svFalse))
, ("<$" , let boolFail = evalPanic "<$" ["Attempted signed comparison on bare Bit values"]
intFail = evalPanic "<$" ["Attempted signed comparison on Integer values"]
in binary (cmpBinary boolFail cmpSignedLt intFail (const intFail) SBV.svFalse))
, ("/$" , binary (arithBinary (liftBinArith signedQuot) (liftBin SBV.svQuot)
(liftModBin SBV.svQuot))) -- {a} (Arith a) => a -> a -> a
, ("%$" , binary (arithBinary (liftBinArith signedRem) (liftBin SBV.svRem)
(liftModBin SBV.svRem)))
, (">>$" , sshrV)
, ("&&" , binary (logicBinary SBV.svAnd SBV.svAnd))
, ("||" , binary (logicBinary SBV.svOr SBV.svOr))
, ("^" , binary (logicBinary SBV.svXOr SBV.svXOr))
, ("complement" , unary (logicUnary SBV.svNot SBV.svNot))
, ("zero" , tlam zeroV)
, ("toInteger" , ecToIntegerV)
, ("fromInteger" , ecFromIntegerV (const id))
, ("fromZ" , nlam $ \ modulus ->
lam $ \ x -> do
val <- x
case (modulus, val) of
(Nat n, VInteger i) -> return $ VInteger (SBV.svRem i (integerLit n))
_ -> evalPanic "fromZ" ["Invalid arguments"])
, ("<<" , logicShift "<<"
SBV.svShiftLeft
(\sz i shft ->
case sz of
Inf -> Just (i+shft)
Nat n
| i+shft >= n -> Nothing
| otherwise -> Just (i+shft)))
, (">>" , logicShift ">>"
SBV.svShiftRight
(\_sz i shft ->
if i-shft < 0 then Nothing else Just (i-shft)))
, ("<<<" , logicShift "<<<"
SBV.svRotateLeft
(\sz i shft ->
case sz of
Inf -> evalPanic "cannot rotate infinite sequence" []
Nat n -> Just ((i+shft) `mod` n)))
, (">>>" , logicShift ">>>"
SBV.svRotateRight
(\sz i shft ->
case sz of
Inf -> evalPanic "cannot rotate infinite sequence" []
Nat n -> Just ((i+n-shft) `mod` n)))
, ("carry" , liftWord carry)
, ("scarry" , liftWord scarry)
, ("#" , -- {a,b,d} (fin a) => [a] d -> [b] d -> [a + b] d
nlam $ \ front ->
nlam $ \ back ->
tlam $ \ elty ->
lam $ \ l -> return $
lam $ \ r -> join (ccatV front back elty <$> l <*> r))
, ("splitAt" ,
nlam $ \ front ->
nlam $ \ back ->
tlam $ \ a ->
lam $ \ x ->
splitAtV front back a =<< x)
, ("join" ,
nlam $ \ parts ->
nlam $ \ (finNat' -> each) ->
tlam $ \ a ->
lam $ \ x ->
joinV parts each a =<< x)
, ("split" , ecSplitV)
, ("reverse" , nlam $ \_a ->
tlam $ \_b ->
lam $ \xs -> reverseV =<< xs)
, ("transpose" , nlam $ \a ->
nlam $ \b ->
tlam $ \c ->
lam $ \xs -> transposeV a b c =<< xs)
, ("fromTo" , fromToV)
, ("fromThenTo" , fromThenToV)
, ("infFrom" , infFromV)
, ("infFromThen" , infFromThenV)
, ("@" , indexPrim indexFront_bits indexFront)
, ("!" , indexPrim indexBack_bits indexBack)
, ("update" , updatePrim updateFrontSym_word updateFrontSym)
, ("updateEnd" , updatePrim updateBackSym_word updateBackSym)
-- {at,len} (fin len) => [len][8] -> at
, ("error" ,
tlam $ \at ->
nlam $ \(finNat' -> _len) ->
VFun $ \_msg ->
return $ zeroV at) -- error/undefined, is arbitrarily translated to 0
, ("random" ,
tlam $ \a ->
wlam $ \x ->
case SBV.svAsInteger x of
Just i -> return $ randomV a i
Nothing -> cryUserError "cannot evaluate 'random' with symbolic inputs")
-- The trace function simply forces its first two
-- values before returing the third in the symbolic
-- evaluator.
, ("trace",
nlam $ \_n ->
tlam $ \_a ->
tlam $ \_b ->
lam $ \s -> return $
lam $ \x -> return $
lam $ \y -> do
_ <- s
_ <- x
y)
]
-- | Barrel-shifter algorithm. Takes a list of bits in big-endian order.
shifter :: Monad m => (SBool -> a -> a -> a) -> (a -> Integer -> m a) -> a -> [SBool] -> m a
shifter mux op = go
where
go x [] = return x
go x (b : bs) = do
x' <- op x (2 ^ length bs)
go (mux b x' x) bs
logicShift :: String
-> (SWord -> SWord -> SWord)
-> (Nat' -> Integer -> Integer -> Maybe Integer)
-> Value
logicShift nm wop reindex =
nlam $ \_m ->
nlam $ \_n ->
tlam $ \a ->
VFun $ \xs -> return $
VFun $ \y -> do
idx <- fromWordVal "logicShift" =<< y
xs >>= \case
VWord w x ->
return $ VWord w $ do
x >>= \case
WordVal x' -> WordVal . wop x' <$> asWordVal idx
BitsVal bs0 ->
do idx_bits <- enumerateWordValue idx
let op bs shft = return $ Seq.fromFunction (Seq.length bs) $ \i ->
case reindex (Nat w) (toInteger i) shft of
Nothing -> return $ bitLit False
Just i' -> Seq.index bs (fromInteger i')
BitsVal <$> shifter (mergeBits True) op bs0 idx_bits
LargeBitsVal n bs0 ->
do idx_bits <- enumerateWordValue idx
let op bs shft = memoMap $ IndexSeqMap $ \i ->
case reindex (Nat w) i shft of
Nothing -> return $ VBit $ bitLit False
Just i' -> lookupSeqMap bs i'
LargeBitsVal n <$> shifter (mergeSeqMap True) op bs0 idx_bits
VSeq w vs0 ->
do idx_bits <- enumerateWordValue idx
let op vs shft = memoMap $ IndexSeqMap $ \i ->
case reindex (Nat w) i shft of
Nothing -> return $ zeroV a
Just i' -> lookupSeqMap vs i'
VSeq w <$> shifter (mergeSeqMap True) op vs0 idx_bits
VStream vs0 ->
do idx_bits <- enumerateWordValue idx
let op vs shft = memoMap $ IndexSeqMap $ \i ->
case reindex Inf i shft of
Nothing -> return $ zeroV a
Just i' -> lookupSeqMap vs i'
VStream <$> shifter (mergeSeqMap True) op vs0 idx_bits
_ -> evalPanic "expected sequence value in shift operation" [nm]
indexFront :: Maybe Integer
-> TValue
-> SeqMap SBool SWord SInteger
-> SWord
-> Eval Value
indexFront mblen a xs idx
| Just i <- SBV.svAsInteger idx
= lookupSeqMap xs i
| Just n <- mblen
, TVSeq wlen TVBit <- a
= do wvs <- traverse (fromWordVal "indexFront" =<<) (enumerateSeqMap n xs)
case asWordList wvs of
Just ws ->
return $ VWord wlen $ ready $ WordVal $ SBV.svSelect ws (wordLit wlen 0) idx
Nothing -> foldr f def idxs
| otherwise
= foldr f def idxs
where
k = SBV.kindOf idx
w = SBV.intSizeOf idx
def = ready $ zeroV a
f n y = iteValue (SBV.svEqual idx (SBV.svInteger k n)) (lookupSeqMap xs n) y
idxs = case mblen of
Just n | n < 2^w -> [0 .. n-1]
_ -> [0 .. 2^w - 1]
indexBack :: Maybe Integer
-> TValue
-> SeqMap SBool SWord SInteger
-> SWord
-> Eval Value
indexBack (Just n) a xs idx = indexFront (Just n) a (reverseSeqMap n xs) idx
indexBack Nothing _ _ _ = evalPanic "Expected finite sequence" ["indexBack"]
indexFront_bits :: Maybe Integer
-> TValue
-> SeqMap SBool SWord SInteger
-> Seq.Seq SBool
-> Eval Value
indexFront_bits mblen a xs bits0 = go 0 (length bits0) (Fold.toList bits0)
where
go :: Integer -> Int -> [SBool] -> Eval Value
go i _k []
-- For indices out of range, return 0 arbitrarily
| Just n <- mblen
, i >= n
= return $ zeroV a
| otherwise
= lookupSeqMap xs i
go i k (b:bs)
| Just n <- mblen
, (i `shiftL` k) >= n
= return $ zeroV a
| otherwise
= iteValue b (go ((i `shiftL` 1) + 1) (k-1) bs)
(go (i `shiftL` 1) (k-1) bs)
indexBack_bits :: Maybe Integer
-> TValue
-> SeqMap SBool SWord SInteger
-> Seq.Seq SBool
-> Eval Value
indexBack_bits (Just n) a xs idx = indexFront_bits (Just n) a (reverseSeqMap n xs) idx
indexBack_bits Nothing _ _ _ = evalPanic "Expected finite sequence" ["indexBack_bits"]
-- | Compare a symbolic word value with a concrete integer.
wordValueEqualsInteger :: WordValue SBool SWord SInteger -> Integer -> Eval SBool
wordValueEqualsInteger wv i
| wordValueSize wv < widthInteger i = return SBV.svFalse
| otherwise =
case wv of
WordVal w -> return $ SBV.svEqual w (literalSWord (SBV.intSizeOf w) i)
_ -> bitsAre i <$> enumerateWordValueRev wv -- little-endian
where
bitsAre :: Integer -> [SBool] -> SBool
bitsAre n [] = SBV.svBool (n == 0)
bitsAre n (b : bs) = SBV.svAnd (bitIs (odd n) b) (bitsAre (n `div` 2) bs)
bitIs :: Bool -> SBool -> SBool
bitIs b x = if b then x else SBV.svNot x
lazyMergeBit :: SBool -> Eval SBool -> Eval SBool -> Eval SBool
lazyMergeBit c x y =
case SBV.svAsBool c of
Just True -> x
Just False -> y
Nothing -> mergeBit False c <$> x <*> y
updateFrontSym
:: Nat'
-> TValue
-> SeqMap SBool SWord SInteger
-> WordValue SBool SWord SInteger
-> Eval (GenValue SBool SWord SInteger)
-> Eval (SeqMap SBool SWord SInteger)
updateFrontSym len _eltTy vs wv val =
case wv of
WordVal w | Just j <- SBV.svAsInteger w ->
do case len of
Inf -> return ()
Nat n -> unless (j < n) (invalidIndex j)
return $ updateSeqMap vs j val
_ ->
return $ IndexSeqMap $ \i ->
do b <- wordValueEqualsInteger wv i
iteValue b val (lookupSeqMap vs i)
updateFrontSym_word
:: Nat'
-> TValue
-> WordValue SBool SWord SInteger
-> WordValue SBool SWord SInteger
-> Eval (GenValue SBool SWord SInteger)
-> Eval (WordValue SBool SWord SInteger)
updateFrontSym_word Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_bits"]
updateFrontSym_word (Nat n) eltTy bv wv val =
case wv of
WordVal w | Just j <- SBV.svAsInteger w ->
do unless (j < n) (invalidIndex j)
updateWordValue bv j (fromVBit <$> val)
_ ->
case bv of
WordVal bw -> return $ BitsVal $ Seq.mapWithIndex f bs
where bs = fmap return $ Seq.fromList $ unpackWord bw
BitsVal bs -> return $ BitsVal $ Seq.mapWithIndex f bs
LargeBitsVal l vs -> LargeBitsVal l <$> updateFrontSym (Nat n) eltTy vs wv val
where
f :: Int -> Eval SBool -> Eval SBool
f i x = do c <- wordValueEqualsInteger wv (toInteger i)
lazyMergeBit c (fromBit =<< val) x
updateBackSym
:: Nat'
-> TValue
-> SeqMap SBool SWord SInteger
-> WordValue SBool SWord SInteger
-> Eval (GenValue SBool SWord SInteger)
-> Eval (SeqMap SBool SWord SInteger)
updateBackSym Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"]
updateBackSym (Nat n) _eltTy vs wv val =
case wv of
WordVal w | Just j <- SBV.svAsInteger w ->
do unless (j < n) (invalidIndex j)
return $ updateSeqMap vs (n - 1 - j) val
_ ->
return $ IndexSeqMap $ \i ->
do b <- wordValueEqualsInteger wv (n - 1 - i)
iteValue b val (lookupSeqMap vs i)
updateBackSym_word
:: Nat'
-> TValue
-> WordValue SBool SWord SInteger
-> WordValue SBool SWord SInteger
-> Eval (GenValue SBool SWord SInteger)
-> Eval (WordValue SBool SWord SInteger)
updateBackSym_word Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_bits"]
updateBackSym_word (Nat n) eltTy bv wv val = do
case wv of
WordVal w | Just j <- SBV.svAsInteger w ->
do unless (j < n) (invalidIndex j)
updateWordValue bv (n - 1 - j) (fromVBit <$> val)
_ ->
case bv of
WordVal bw -> return $ BitsVal $ Seq.mapWithIndex f bs
where bs = fmap return $ Seq.fromList $ unpackWord bw
BitsVal bs -> return $ BitsVal $ Seq.mapWithIndex f bs
LargeBitsVal l vs -> LargeBitsVal l <$> updateBackSym (Nat n) eltTy vs wv val
where
f :: Int -> Eval SBool -> Eval SBool
f i x = do c <- wordValueEqualsInteger wv (n - 1 - toInteger i)
lazyMergeBit c (fromBit =<< val) x
asBitList :: [Eval SBool] -> Maybe [SBool]
asBitList = go id
where go :: ([SBool] -> [SBool]) -> [Eval SBool] -> Maybe [SBool]
go f [] = Just (f [])
go f (Ready b:vs) = go (f . (b:)) vs
go _ _ = Nothing
asWordList :: [WordValue SBool SWord SInteger] -> Maybe [SWord]
asWordList = go id
where go :: ([SWord] -> [SWord]) -> [WordValue SBool SWord SInteger] -> Maybe [SWord]
go f [] = Just (f [])
go f (WordVal x :vs) = go (f . (x:)) vs
go f (BitsVal bs:vs) =
case asBitList (Fold.toList bs) of
Just xs -> go (f . (packWord xs:)) vs
Nothing -> Nothing
go _f (LargeBitsVal _ _ : _) = Nothing
liftBinArith :: (SWord -> SWord -> SWord) -> BinArith SWord
liftBinArith op _ x y = ready $ op x y
liftBin :: (a -> b -> c) -> a -> b -> Eval c
liftBin op x y = ready $ op x y
liftModBin :: (SInteger -> SInteger -> a) -> Integer -> SInteger -> SInteger -> Eval a
liftModBin op modulus x y = ready $ op (SBV.svRem x m) (SBV.svRem y m)
where m = integerLit modulus
sExp :: Integer -> SWord -> SWord -> Eval SWord
sExp _w x y = ready $ go (reverse (unpackWord y)) -- bits in little-endian order
where go [] = literalSWord (SBV.intSizeOf x) 1
go (b : bs) = SBV.svIte b (SBV.svTimes x s) s
where a = go bs
s = SBV.svTimes a a
sModAdd :: Integer -> SInteger -> SInteger -> Eval SInteger
sModAdd modulus x y =
case (SBV.svAsInteger x, SBV.svAsInteger y) of
(Just i, Just j) -> ready $ integerLit ((i + j) `mod` modulus)
_ -> ready $ SBV.svPlus x y
sModSub :: Integer -> SInteger -> SInteger -> Eval SInteger
sModSub modulus x y =
case (SBV.svAsInteger x, SBV.svAsInteger y) of
(Just i, Just j) -> ready $ integerLit ((i - j) `mod` modulus)
_ -> ready $ SBV.svMinus x y
sModMult :: Integer -> SInteger -> SInteger -> Eval SInteger
sModMult modulus x y =
case (SBV.svAsInteger x, SBV.svAsInteger y) of
(Just i, Just j) -> ready $ integerLit ((i * j) `mod` modulus)
_ -> ready $ SBV.svTimes x y
sModExp :: Integer -> SInteger -> SInteger -> Eval SInteger
sModExp modulus x y = ready $ SBV.svExp x (SBV.svRem y m)
where m = integerLit modulus
-- | Ceiling (log_2 x)
sLg2 :: Integer -> SWord -> Eval SWord
sLg2 _w x = ready $ go 0
where
lit n = literalSWord (SBV.intSizeOf x) n
go i | i < SBV.intSizeOf x = SBV.svIte (SBV.svLessEq x (lit (2^i))) (lit (toInteger i)) (go (i + 1))
| otherwise = lit (toInteger i)
-- | Ceiling (log_2 x)
svLg2 :: SInteger -> Eval SInteger
svLg2 x =
case SBV.svAsInteger x of
Just n -> ready $ SBV.svInteger SBV.KUnbounded (lg2 n)
Nothing -> evalPanic "cannot compute lg2 of symbolic unbounded integer" []
svModLg2 :: Integer -> SInteger -> Eval SInteger
svModLg2 modulus x = svLg2 (SBV.svRem x m)
where m = integerLit modulus
-- Cmp -------------------------------------------------------------------------
cmpEq :: SWord -> SWord -> Eval SBool -> Eval SBool
cmpEq x y k = SBV.svAnd (SBV.svEqual x y) <$> k
cmpNotEq :: SWord -> SWord -> Eval SBool -> Eval SBool
cmpNotEq x y k = SBV.svOr (SBV.svNotEqual x y) <$> k
cmpSignedLt :: SWord -> SWord -> Eval SBool -> Eval SBool
cmpSignedLt x y k = SBV.svOr (SBV.svLessThan sx sy) <$> (cmpEq sx sy k)
where sx = SBV.svSign x
sy = SBV.svSign y
cmpLt, cmpGt :: SWord -> SWord -> Eval SBool -> Eval SBool
cmpLt x y k = SBV.svOr (SBV.svLessThan x y) <$> (cmpEq x y k)
cmpGt x y k = SBV.svOr (SBV.svGreaterThan x y) <$> (cmpEq x y k)
cmpLtEq, cmpGtEq :: SWord -> SWord -> Eval SBool -> Eval SBool
cmpLtEq x y k = SBV.svAnd (SBV.svLessEq x y) <$> (cmpNotEq x y k)
cmpGtEq x y k = SBV.svAnd (SBV.svGreaterEq x y) <$> (cmpNotEq x y k)
cmpMod ::
(SInteger -> SInteger -> Eval SBool -> Eval SBool) ->
(Integer -> SInteger -> SInteger -> Eval SBool -> Eval SBool)
cmpMod cmp modulus x y k = cmp (SBV.svRem x m) (SBV.svRem y m) k
where m = integerLit modulus
cmpModEq :: Integer -> SInteger -> SInteger -> Eval SBool -> Eval SBool
cmpModEq m x y k = SBV.svAnd (svDivisible m (SBV.svMinus x y)) <$> k
cmpModNotEq :: Integer -> SInteger -> SInteger -> Eval SBool -> Eval SBool
cmpModNotEq m x y k = SBV.svOr (SBV.svNot (svDivisible m (SBV.svMinus x y))) <$> k
svDivisible :: Integer -> SInteger -> SBool
svDivisible m x = SBV.svEqual (SBV.svRem x (integerLit m)) (integerLit 0)
cmpBinary :: (SBool -> SBool -> Eval SBool -> Eval SBool)
-> (SWord -> SWord -> Eval SBool -> Eval SBool)
-> (SInteger -> SInteger -> Eval SBool -> Eval SBool)
-> (Integer -> SInteger -> SInteger -> Eval SBool -> Eval SBool)
-> SBool -> Binary SBool SWord SInteger
cmpBinary fb fw fi fz b ty v1 v2 = VBit <$> cmpValue fb fw fi fz ty v1 v2 (return b)
-- Signed arithmetic -----------------------------------------------------------
signedQuot :: SWord -> SWord -> SWord
signedQuot x y = SBV.svUnsign (SBV.svQuot (SBV.svSign x) (SBV.svSign y))
signedRem :: SWord -> SWord -> SWord
signedRem x y = SBV.svUnsign (SBV.svRem (SBV.svSign x) (SBV.svSign y))
sshrV :: Value
sshrV =
nlam $ \_n ->
nlam $ \_k ->
wlam $ \x -> return $
wlam $ \y ->
case SBV.svAsInteger y of
Just i ->
let z = SBV.svUnsign (SBV.svShr (SBV.svSign x) (fromInteger i))
in return . VWord (toInteger (SBV.intSizeOf x)) . ready . WordVal $ z
Nothing ->
let z = SBV.svUnsign (SBV.svShiftRight (SBV.svSign x) y)
in return . VWord (toInteger (SBV.intSizeOf x)) . ready . WordVal $ z
carry :: SWord -> SWord -> Eval Value
carry x y = return $ VBit c
where
c = SBV.svLessThan (SBV.svPlus x y) x
scarry :: SWord -> SWord -> Eval Value
scarry x y = return $ VBit sc
where
n = SBV.intSizeOf x
z = SBV.svPlus (SBV.svSign x) (SBV.svSign y)
xsign = SBV.svTestBit x (n-1)
ysign = SBV.svTestBit y (n-1)
zsign = SBV.svTestBit z (n-1)
sc = SBV.svAnd (SBV.svEqual xsign ysign) (SBV.svNotEqual xsign zsign)
cryptol-2.8.0/src/Cryptol/Symbolic/Value.hs 0000644 0000000 0000000 00000020576 07346545000 017034 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Symbolic.Value
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Cryptol.Symbolic.Value
( SBool, SWord, SInteger
, literalSWord
, fromBitsLE
, forallBV_, existsBV_
, forallSBool_, existsSBool_
, forallSInteger_, existsSInteger_
, Value
, TValue, isTBit, tvSeq
, GenValue(..), lam, tlam, toStream, toFinSeq, toSeq
, fromVBit, fromVFun, fromVPoly, fromVTuple, fromVRecord, lookupRecord
, fromSeq, fromVWord
, evalPanic
, iteSValue, mergeValue, mergeWord, mergeBit, mergeBits, mergeSeqMap
, mergeWord'
)
where
import Data.Bits (bit, complement)
import Data.List (foldl')
import qualified Data.Sequence as Seq
import Data.SBV (symbolicEnv)
import Data.SBV.Dynamic
--import Cryptol.Eval.Monad
import Cryptol.Eval.Type (TValue(..), isTBit, tvSeq)
import Cryptol.Eval.Monad (Eval, ready)
import Cryptol.Eval.Value ( GenValue(..), BitWord(..), lam, tlam, toStream,
toFinSeq, toSeq, WordValue(..),
fromSeq, fromVBit, fromVWord, fromVFun, fromVPoly,
fromVTuple, fromVRecord, lookupRecord, SeqMap(..),
ppBV, BV(..), integerToChar, lookupSeqMap, memoMap,
wordValueSize, asBitsMap)
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.PP
import Control.Monad.Trans (liftIO)
-- SBool and SWord -------------------------------------------------------------
type SBool = SVal
type SWord = SVal
type SInteger = SVal
fromBitsLE :: [SBool] -> SWord
fromBitsLE bs = foldl' f (literalSWord 0 0) bs
where f w b = svJoin (svToWord1 b) w
literalSWord :: Int -> Integer -> SWord
literalSWord w i = svInteger (KBounded False w) i
forallBV_ :: Int -> Symbolic SWord
forallBV_ w = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) (KBounded False w) Nothing
existsBV_ :: Int -> Symbolic SWord
existsBV_ w = symbolicEnv >>= liftIO . svMkSymVar (Just EX) (KBounded False w) Nothing
forallSBool_ :: Symbolic SBool
forallSBool_ = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) KBool Nothing
existsSBool_ :: Symbolic SBool
existsSBool_ = symbolicEnv >>= liftIO . svMkSymVar (Just EX) KBool Nothing
forallSInteger_ :: Symbolic SBool
forallSInteger_ = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) KUnbounded Nothing
existsSInteger_ :: Symbolic SBool
existsSInteger_ = symbolicEnv >>= liftIO . svMkSymVar (Just EX) KUnbounded Nothing
-- Values ----------------------------------------------------------------------
type Value = GenValue SBool SWord SInteger
-- Symbolic Conditionals -------------------------------------------------------
iteSValue :: SBool -> Value -> Value -> Eval Value
iteSValue c x y =
case svAsBool c of
Just True -> return x
Just False -> return y
Nothing -> mergeValue True c x y
mergeBit :: Bool
-> SBool
-> SBool
-> SBool
-> SBool
mergeBit f c b1 b2 = svSymbolicMerge KBool f c b1 b2
mergeWord :: Bool
-> SBool
-> WordValue SBool SWord SInteger
-> WordValue SBool SWord SInteger
-> WordValue SBool SWord SInteger
mergeWord f c (WordVal w1) (WordVal w2) =
WordVal $ svSymbolicMerge (kindOf w1) f c w1 w2
mergeWord f c (WordVal w1) (BitsVal ys) =
BitsVal $ mergeBits f c (Seq.fromList $ map ready $ unpackWord w1) ys
mergeWord f c (BitsVal xs) (WordVal w2) =
BitsVal $ mergeBits f c xs (Seq.fromList $ map ready $ unpackWord w2)
mergeWord f c (BitsVal xs) (BitsVal ys) =
BitsVal $ mergeBits f c xs ys
mergeWord f c w1 w2 =
LargeBitsVal (wordValueSize w1) (mergeSeqMap f c (asBitsMap w1) (asBitsMap w2))
mergeWord' :: Bool
-> SBool
-> Eval (WordValue SBool SWord SInteger)
-> Eval (WordValue SBool SWord SInteger)
-> Eval (WordValue SBool SWord SInteger)
mergeWord' f c x y = mergeWord f c <$> x <*> y
mergeBits :: Bool
-> SBool
-> Seq.Seq (Eval SBool)
-> Seq.Seq (Eval SBool)
-> Seq.Seq (Eval SBool)
mergeBits f c bs1 bs2 = Seq.zipWith mergeBit' bs1 bs2
where mergeBit' b1 b2 = mergeBit f c <$> b1 <*> b2
mergeInteger :: Bool
-> SBool
-> SInteger
-> SInteger
-> SInteger
mergeInteger f c x y = svSymbolicMerge KUnbounded f c x y
mergeValue :: Bool -> SBool -> Value -> Value -> Eval Value
mergeValue f c v1 v2 =
case (v1, v2) of
(VRecord fs1, VRecord fs2) -> pure $ VRecord $ zipWith mergeField fs1 fs2
(VTuple vs1 , VTuple vs2 ) -> pure $ VTuple $ zipWith (mergeValue' f c) vs1 vs2
(VBit b1 , VBit b2 ) -> pure $ VBit $ mergeBit f c b1 b2
(VInteger i1, VInteger i2) -> pure $ VInteger $ mergeInteger f c i1 i2
(VWord n1 w1, VWord n2 w2 ) | n1 == n2 -> pure $ VWord n1 $ mergeWord' f c w1 w2
(VSeq n1 vs1, VSeq n2 vs2 ) | n1 == n2 -> VSeq n1 <$> memoMap (mergeSeqMap f c vs1 vs2)
(VStream vs1, VStream vs2) -> VStream <$> memoMap (mergeSeqMap f c vs1 vs2)
(VFun f1 , VFun f2 ) -> pure $ VFun $ \x -> mergeValue' f c (f1 x) (f2 x)
(VPoly f1 , VPoly f2 ) -> pure $ VPoly $ \x -> mergeValue' f c (f1 x) (f2 x)
(_ , _ ) -> panic "Cryptol.Symbolic.Value"
[ "mergeValue: incompatible values" ]
where
mergeField (n1, x1) (n2, x2)
| n1 == n2 = (n1, mergeValue' f c x1 x2)
| otherwise = panic "Cryptol.Symbolic.Value"
[ "mergeValue.mergeField: incompatible values" ]
mergeValue' :: Bool -> SBool -> Eval Value -> Eval Value -> Eval Value
mergeValue' f c x1 x2 =
do v1 <- x1
v2 <- x2
mergeValue f c v1 v2
mergeSeqMap :: Bool -> SBool -> SeqMap SBool SWord SInteger -> SeqMap SBool SWord SInteger -> SeqMap SBool SWord SInteger
mergeSeqMap f c x y =
IndexSeqMap $ \i ->
do xi <- lookupSeqMap x i
yi <- lookupSeqMap y i
mergeValue f c xi yi
-- Symbolic Big-endian Words -------------------------------------------------------
instance BitWord SBool SWord SInteger where
wordLen v = toInteger (intSizeOf v)
wordAsChar v = integerToChar <$> svAsInteger v
ppBit v
| Just b <- svAsBool v = text $! if b then "True" else "False"
| otherwise = text "?"
ppWord opts v
| Just x <- svAsInteger v = ppBV opts (BV (wordLen v) x)
| otherwise = text "[?]"
ppInteger _opts v
| Just x <- svAsInteger v = integer x
| otherwise = text "[?]"
bitLit b = svBool b
wordLit n x = svInteger (KBounded False (fromInteger n)) x
integerLit x = svInteger KUnbounded x
wordBit x idx = svTestBit x (intSizeOf x - 1 - fromInteger idx)
wordUpdate x idx b = svSymbolicMerge (kindOf x) False b wtrue wfalse
where
i' = intSizeOf x - 1 - fromInteger idx
wtrue = x `svOr` svInteger (kindOf x) (bit i' :: Integer)
wfalse = x `svAnd` svInteger (kindOf x) (complement (bit i' :: Integer))
packWord bs = fromBitsLE (reverse bs)
unpackWord x = [ svTestBit x i | i <- reverse [0 .. intSizeOf x - 1] ]
joinWord x y = svJoin x y
splitWord _leftW rightW w =
( svExtract (intSizeOf w - 1) (fromInteger rightW) w
, svExtract (fromInteger rightW - 1) 0 w
)
extractWord len start w =
svExtract (fromInteger start + fromInteger len - 1) (fromInteger start) w
wordPlus = svPlus
wordMinus = svMinus
wordMult = svTimes
intPlus = svPlus
intMinus = svMinus
intMult = svTimes
intModPlus _m = svPlus
intModMinus _m = svMinus
intModMult _m = svTimes
wordToInt = svToInteger
wordFromInt = svFromInteger
-- TODO: implement this properly in SBV using "bv2int"
svToInteger :: SWord -> SInteger
svToInteger w =
case svAsInteger w of
Nothing -> svFromIntegral KUnbounded w
Just x -> svInteger KUnbounded x
-- TODO: implement this properly in SBV using "int2bv"
svFromInteger :: Integer -> SInteger -> SWord
svFromInteger 0 _ = literalSWord 0 0
svFromInteger n i =
case svAsInteger i of
Nothing -> svFromIntegral (KBounded False (fromInteger n)) i
Just x -> literalSWord (fromInteger n) x
-- Errors ----------------------------------------------------------------------
evalPanic :: String -> [String] -> a
evalPanic cxt = panic ("[Symbolic]" ++ cxt)
cryptol-2.8.0/src/Cryptol/Testing/ 0000755 0000000 0000000 00000000000 07346545000 015246 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/Testing/Concrete.hs 0000644 0000000 0000000 00000014663 07346545000 017356 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Testing.Concrete
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE RecordWildCards #-}
module Cryptol.Testing.Concrete where
import Control.Monad (join, liftM2)
import Cryptol.Eval.Monad
import Cryptol.Eval.Value
import Cryptol.TypeCheck.AST
import Cryptol.Utils.Panic (panic)
import qualified Control.Exception as X
import Data.List(genericReplicate)
import Prelude ()
import Prelude.Compat
-- | A test result is either a pass, a failure due to evaluating to
-- @False@, or a failure due to an exception raised during evaluation
data TestResult
= Pass
| FailFalse [Value]
| FailError EvalError [Value]
isPass :: TestResult -> Bool
isPass Pass = True
isPass _ = False
-- | Apply a testable value to some arguments.
-- Note that this function assumes that the values come from a call to
-- `testableType` (i.e., things are type-correct). We run in the IO
-- monad in order to catch any @EvalError@s.
runOneTest :: EvalOpts -> Value -> [Value] -> IO TestResult
runOneTest evOpts v0 vs0 = run `X.catch` handle
where
run = do
result <- runEval evOpts (go v0 vs0)
if result
then return Pass
else return (FailFalse vs0)
handle e = return (FailError e vs0)
go :: Value -> [Value] -> Eval Bool
go (VFun f) (v : vs) = join (go <$> (f (ready v)) <*> return vs)
go (VFun _) [] = panic "Not enough arguments while applying function"
[]
go (VBit b) [] = return b
go v vs = do vdoc <- ppValue defaultPPOpts v
vsdocs <- mapM (ppValue defaultPPOpts) vs
panic "Type error while running test" $
[ "Function:"
, show vdoc
, "Arguments:"
] ++ map show vsdocs
{- | Given a (function) type, compute all possible inputs for it.
We also return the types of the arguments and
the total number of test (i.e., the length of the outer list. -}
testableType :: Type -> Maybe (Maybe Integer, [Type], [[Value]])
testableType ty =
case tNoUser ty of
TCon (TC TCFun) [t1,t2] ->
do let sz = typeSize t1
(tot,ts,vss) <- testableType t2
return (liftM2 (*) sz tot, t1:ts, [ v : vs | v <- typeValues t1, vs <- vss ])
TCon (TC TCBit) [] -> return (Just 1, [], [[]])
_ -> Nothing
{- | Given a fully-evaluated type, try to compute the number of values in it.
Returns `Nothing` for infinite types, user-defined types, polymorphic types,
and, currently, function spaces. Of course, we can easily compute the
sizes of function spaces, but we can't easily enumerate their inhabitants. -}
typeSize :: Type -> Maybe Integer
typeSize ty =
case ty of
TVar _ -> Nothing
TUser _ _ t -> typeSize t
TRec fs -> product <$> mapM (typeSize . snd) fs
TCon (TC tc) ts ->
case (tc, ts) of
(TCNum _, _) -> Nothing
(TCInf, _) -> Nothing
(TCBit, _) -> Just 2
(TCInteger, _) -> Nothing
(TCIntMod, [sz]) -> case tNoUser sz of
TCon (TC (TCNum n)) _ -> Just n
_ -> Nothing
(TCIntMod, _) -> Nothing
(TCSeq, [sz,el]) -> case tNoUser sz of
TCon (TC (TCNum n)) _ -> (^ n) <$> typeSize el
_ -> Nothing
(TCSeq, _) -> Nothing
(TCFun, _) -> Nothing
(TCTuple _, els) -> product <$> mapM typeSize els
(TCAbstract _, _) -> Nothing
(TCNewtype _, _) -> Nothing
TCon _ _ -> Nothing
{- | Returns all the values in a type. Returns an empty list of values,
for types where 'typeSize' returned 'Nothing'. -}
typeValues :: Type -> [Value]
typeValues ty =
case ty of
TVar _ -> []
TUser _ _ t -> typeValues t
TRec fs -> [ VRecord xs
| xs <- sequence [ [ (f,ready v) | v <- typeValues t ]
| (f,t) <- fs ]
]
TCon (TC tc) ts ->
case tc of
TCNum _ -> []
TCInf -> []
TCBit -> [ VBit False, VBit True ]
TCInteger -> []
TCIntMod ->
case map tNoUser ts of
[ TCon (TC (TCNum n)) _ ] | 0 < n ->
[ VInteger x | x <- [ 0 .. n - 1 ] ]
_ -> []
TCSeq ->
case map tNoUser ts of
[ TCon (TC (TCNum n)) _, TCon (TC TCBit) [] ] ->
[ VWord n (ready (WordVal (BV n x))) | x <- [ 0 .. 2^n - 1 ] ]
[ TCon (TC (TCNum n)) _, t ] ->
[ VSeq n (finiteSeqMap (map ready xs))
| xs <- sequence $ genericReplicate n
$ typeValues t ]
_ -> []
TCFun -> [] -- We don't generate function values.
TCTuple _ -> [ VTuple (map ready xs)
| xs <- sequence (map typeValues ts)
]
TCAbstract _ -> []
TCNewtype _ -> []
TCon _ _ -> []
--------------------------------------------------------------------------------
-- Driver function
data TestSpec m s = TestSpec {
testFn :: Integer -> s -> m (TestResult, s)
, testProp :: String -- ^ The property as entered by the user
, testTotal :: Integer
, testPossible :: Maybe Integer -- ^ Nothing indicates infinity
, testRptProgress :: Integer -> Integer -> m ()
, testClrProgress :: m ()
, testRptFailure :: TestResult -> m ()
, testRptSuccess :: m ()
}
data TestReport = TestReport {
reportResult :: TestResult
, reportProp :: String -- ^ The property as entered by the user
, reportTestsRun :: Integer
, reportTestsPossible :: Maybe Integer
}
runTests :: Monad m => TestSpec m s -> s -> m TestReport
runTests TestSpec {..} st0 = go 0 st0
where
go testNum _ | testNum >= testTotal = do
testRptSuccess
return $ TestReport Pass testProp testNum testPossible
go testNum st =
do testRptProgress testNum testTotal
res <- testFn (div (100 * (1 + testNum)) testTotal) st
testClrProgress
case res of
(Pass, st') -> do -- delProgress -- unnecessary?
go (testNum + 1) st'
(failure, _st') -> do
testRptFailure failure
return $ TestReport failure testProp testNum testPossible
cryptol-2.8.0/src/Cryptol/Testing/Random.hs 0000644 0000000 0000000 00000020144 07346545000 017023 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Testing.Random
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- This module generates random values for Cryptol types.
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cryptol.Testing.Random where
import Cryptol.Eval.Monad (ready,runEval,EvalOpts)
import Cryptol.Eval.Value (BV(..),Value,GenValue(..),SeqMap(..), WordValue(..), BitWord(..))
import qualified Cryptol.Testing.Concrete as Conc
import Cryptol.TypeCheck.AST (Type(..), TCon(..), TC(..), tNoUser, tIsFun)
import Cryptol.TypeCheck.SimpType(tRebuild')
import Cryptol.Utils.Ident (Ident)
import Cryptol.Utils.Panic (panic)
import Control.Monad (forM,join)
import Data.List (unfoldr, genericTake, genericIndex)
import System.Random (RandomGen, split, random, randomR)
import qualified Data.Sequence as Seq
type Gen g b w i = Integer -> g -> (GenValue b w i, g)
{- | Apply a testable value to some randomly-generated arguments.
Returns `Nothing` if the function returned `True`, or
`Just counterexample` if it returned `False`.
Please note that this function assumes that the generators match
the supplied value, otherwise we'll panic.
-}
runOneTest :: RandomGen g
=> EvalOpts -- ^ how to evaluate things
-> Value -- ^ Function under test
-> [Gen g Bool BV Integer] -- ^ Argument generators
-> Integer -- ^ Size
-> g
-> IO (Conc.TestResult, g)
runOneTest evOpts fun argGens sz g0 = do
let (args, g1) = foldr mkArg ([], g0) argGens
mkArg argGen (as, g) = let (a, g') = argGen sz g in (a:as, g')
result <- Conc.runOneTest evOpts fun args
return (result, g1)
returnOneTest :: RandomGen g
=> EvalOpts -- ^ How to evaluate things
-> Value -- ^ Function to be used to calculate tests
-> [Gen g Bool BV Integer] -- ^ Argument generators
-> Integer -- ^ Size
-> g -- ^ Initial random state
-> IO ([Value], Value, g) -- ^ Arguments, result, and new random state
returnOneTest evOpts fun argGens sz g0 =
do let (args, g1) = foldr mkArg ([], g0) argGens
mkArg argGen (as, g) = let (a, g') = argGen sz g in (a:as, g')
result <- runEval evOpts (go fun args)
return (args, result, g1)
where
go (VFun f) (v : vs) = join (go <$> (f (ready v)) <*> pure vs)
go (VFun _) [] = panic "Cryptol.Testing.Random" ["Not enough arguments to function while generating tests"]
go _ (_ : _) = panic "Cryptol.Testing.Random" ["Too many arguments to function while generating tests"]
go v [] = return v
-- | Return a collection of random tests.
returnTests :: RandomGen g
=> g -- ^ The random generator state
-> EvalOpts -- ^ How to evaluate things
-> [Gen g Bool BV Integer] -- ^ Generators for the function arguments
-> Value -- ^ The function itself
-> Int -- ^ How many tests?
-> IO [([Value], Value)] -- ^ A list of pairs of random arguments and computed outputs
returnTests g evo gens fun num = go gens g 0
where
go args g0 n
| n >= num = return []
| otherwise =
do let sz = toInteger (div (100 * (1 + n)) num)
(inputs, output, g1) <- returnOneTest evo fun args sz g0
more <- go args g1 (n + 1)
return ((inputs, output) : more)
{- | Given a (function) type, compute generators for the function's
arguments. This is like @testableType@, but allows the result to be
any finite type instead of just @Bit@. -}
dumpableType :: forall g. RandomGen g => Type -> Maybe [Gen g Bool BV Integer]
dumpableType ty =
case tIsFun ty of
Just (t1, t2) ->
do g <- randomValue t1
as <- testableType t2
return (g : as)
Nothing ->
do (_ :: Gen g Bool BV Integer) <- randomValue ty
return []
{- | Given a (function) type, compute generators for
the function's arguments. Currently we do not support polymorphic functions.
In principle, we could apply these to random types, and test the results. -}
testableType :: RandomGen g => Type -> Maybe [Gen g Bool BV Integer]
testableType ty =
case tNoUser ty of
TCon (TC TCFun) [t1,t2] ->
do g <- randomValue t1
as <- testableType t2
return (g : as)
TCon (TC TCBit) [] -> return []
_ -> Nothing
{- | A generator for values of the given type. This fails if we are
given a type that lacks a suitable random value generator. -}
randomValue :: (BitWord b w i, RandomGen g) => Type -> Maybe (Gen g b w i)
randomValue ty =
case ty of
TCon tc ts ->
case (tc, map (tRebuild' False) ts) of
(TC TCBit, []) -> Just randomBit
(TC TCInteger, []) -> Just randomInteger
(TC TCIntMod, [TCon (TC (TCNum n)) []]) ->
do return (randomIntMod n)
(TC TCSeq, [TCon (TC TCInf) [], el]) ->
do mk <- randomValue el
return (randomStream mk)
(TC TCSeq, [TCon (TC (TCNum n)) [], TCon (TC TCBit) []]) ->
return (randomWord n)
(TC TCSeq, [TCon (TC (TCNum n)) [], el]) ->
do mk <- randomValue el
return (randomSequence n mk)
(TC (TCTuple _), els) ->
do mks <- mapM randomValue els
return (randomTuple mks)
_ -> Nothing
TVar _ -> Nothing
TUser _ _ t -> randomValue t
TRec fs -> do gs <- forM fs $ \(l,t) -> do g <- randomValue t
return (l,g)
return (randomRecord gs)
-- | Generate a random bit value.
randomBit :: (BitWord b w i, RandomGen g) => Gen g b w i
randomBit _ g =
let (b,g1) = random g
in (VBit (bitLit b), g1)
randomSize :: RandomGen g => Int -> Int -> g -> (Int, g)
randomSize k n g
| p == 1 = (n, g')
| otherwise = randomSize k (n + 1) g'
where (p, g') = randomR (1, k) g
-- | Generate a random integer value. The size parameter is assumed to
-- vary between 1 and 100, and we use it to generate smaller numbers
-- first.
randomInteger :: (BitWord b w i, RandomGen g) => Gen g b w i
randomInteger w g =
let (n, g1) = if w < 100 then (fromInteger w, g) else randomSize 8 100 g
(x, g2) = randomR (- 256^n, 256^n) g1
in (VInteger (integerLit x), g2)
randomIntMod :: (BitWord b w i, RandomGen g) => Integer -> Gen g b w i
randomIntMod modulus _ g =
let (x, g') = randomR (0, modulus-1) g
in (VInteger (integerLit x), g')
-- | Generate a random word of the given length (i.e., a value of type @[w]@)
-- The size parameter is assumed to vary between 1 and 100, and we use
-- it to generate smaller numbers first.
randomWord :: (BitWord b w i, RandomGen g) => Integer -> Gen g b w i
randomWord w _sz g =
let (val, g1) = randomR (0,2^w-1) g
in (VWord w (ready (WordVal (wordLit w val))), g1)
-- | Generate a random infinite stream value.
randomStream :: RandomGen g => Gen g b w i -> Gen g b w i
randomStream mkElem sz g =
let (g1,g2) = split g
in (VStream $ IndexSeqMap $ genericIndex (map ready (unfoldr (Just . mkElem sz) g1)), g2)
{- | Generate a random sequence. This should be used for sequences
other than bits. For sequences of bits use "randomWord". -}
randomSequence :: RandomGen g => Integer -> Gen g b w i -> Gen g b w i
randomSequence w mkElem sz g0 = do
let (g1,g2) = split g0
let f g = let (x,g') = mkElem sz g
in seq x (Just (ready x, g'))
let xs = Seq.fromList $ genericTake w $ unfoldr f g1
seq xs (VSeq w $ IndexSeqMap $ (Seq.index xs . fromInteger), g2)
-- | Generate a random tuple value.
randomTuple :: RandomGen g => [Gen g b w i] -> Gen g b w i
randomTuple gens sz = go [] gens
where
go els [] g = (VTuple (reverse els), g)
go els (mkElem : more) g =
let (v, g1) = mkElem sz g
in seq v (go (ready v : els) more g1)
-- | Generate a random record value.
randomRecord :: RandomGen g => [(Ident, Gen g b w i)] -> Gen g b w i
randomRecord gens sz = go [] gens
where
go els [] g = (VRecord (reverse els), g)
go els ((l,mkElem) : more) g =
let (v, g1) = mkElem sz g
in seq v (go ((l,ready v) : els) more g1)
cryptol-2.8.0/src/Cryptol/Transform/ 0000755 0000000 0000000 00000000000 07346545000 015604 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/Transform/AddModParams.hs 0000644 0000000 0000000 00000022755 07346545000 020447 0 ustar 00 0000000 0000000 -- | Transformed a parametrized module into an ordinary module
-- where everything is parameterized by the module's parameters.
-- Note that this reuses the names from the original parameterized module.
module Cryptol.Transform.AddModParams (addModParams) where
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.Either(partitionEithers)
import Data.List(find,sortBy)
import Data.Ord(comparing)
import Cryptol.TypeCheck.AST
import Cryptol.Parser.Position(thing)
import Cryptol.ModuleSystem.Name(toParamInstName,asParamName,nameIdent
,paramModRecParam)
import Cryptol.Utils.Ident(paramInstModName)
{-
Note that we have to be careful when doing this transformation on
polyomorphic values. In particular,
Consider type parameters AS, with constraints CS, and value
parameters (xs : TS).
f : {as} PS => t
f = f`{as} (<> ..)
~~>
f : {AS ++ as} (CS ++ PS) => { TS } -> t
f = /\ (AS ++ as) ->
\\ (CS ++ PS) ->
\r -> f`{AS ++ as} (<> ...) r
The tricky bit is that we can't just replace `f` with
a new version of `f` with some arguments, instead ew have
to modify the whole instantiation of `f` : f`{as} (<>...)
-}
addModParams :: Module -> Either [Name] Module
addModParams m =
case getParams m of
Left errs -> Left errs
Right ps ->
let toInst = Set.unions ( Map.keysSet (mTySyns m)
: Map.keysSet (mNewtypes m)
: map defs (mDecls m)
)
inp = (toInst, ps { pTypeConstraints = inst inp (pTypeConstraints ps) })
in Right m { mName = paramInstModName (mName m)
, mTySyns = fixMap inp (mTySyns m)
, mNewtypes = fixMap inp (mNewtypes m)
, mDecls = fixUp inp (mDecls m)
, mParamTypes = Map.empty
, mParamConstraints = []
, mParamFuns = Map.empty
}
defs :: DeclGroup -> Set Name
defs dg =
case dg of
Recursive ds -> Set.fromList (map dName ds)
NonRecursive d -> Set.singleton (dName d)
fixUp :: (AddParams a, Inst a) => Inp -> a -> a
fixUp i = addParams (snd i) . inst i
fixMap :: (AddParams a, Inst a) => Inp -> Map Name a -> Map Name a
fixMap i m =
Map.fromList [ (toParamInstName x, fixUp i a) | (x,a) <- Map.toList m ]
--------------------------------------------------------------------------------
data Params = Params
{ pTypes :: [TParam]
, pTypeConstraints :: [Prop]
, pFuns :: [(Name,Type)]
}
getParams :: Module -> Either [Name] Params
getParams m
| null errs =
let ps = Params { pTypes = map rnTP
$ sortBy (comparing mtpNumber)
$ Map.elems
$ mParamTypes m
, pTypeConstraints = map thing (mParamConstraints m)
, pFuns = oks
}
in Right ps
| otherwise = Left errs
where
(errs,oks) = partitionEithers (map checkFunP (Map.toList (mParamFuns m)))
checkFunP (x,s) = case isMono (mvpType s) of
Just t -> Right (asParamName x, t)
Nothing -> Left x
rnTP tp = mtpParam tp { mtpName = asParamName (mtpName tp) }
--------------------------------------------------------------------------------
class AddParams a where
addParams :: Params -> a -> a
instance AddParams a => AddParams [a] where
addParams ps = map (addParams ps)
instance AddParams Schema where
addParams ps s = s { sVars = pTypes ps ++ sVars s
, sProps = pTypeConstraints ps ++ sProps s
, sType = addParams ps (sType s)
}
instance AddParams Type where
addParams ps t
| null (pFuns ps) = t
| otherwise = tFun (paramRecTy ps) t
instance AddParams Expr where
addParams ps e = foldr ETAbs withProps (pTypes ps ++ as)
where (as,rest1) = splitWhile splitTAbs e
(bs,rest2) = splitWhile splitProofAbs rest1
withProps = foldr EProofAbs withArgs (pTypeConstraints ps ++ bs)
withArgs
| null (pFuns ps) = rest2
| otherwise = EAbs paramModRecParam (paramRecTy ps) rest2
instance AddParams DeclGroup where
addParams ps dg =
case dg of
Recursive ds -> Recursive (addParams ps ds)
NonRecursive d -> NonRecursive (addParams ps d)
instance AddParams Decl where
addParams ps d =
case dDefinition d of
DPrim -> d
DExpr e -> d { dSignature = addParams ps (dSignature d)
, dDefinition = DExpr (addParams ps e)
, dName = toParamInstName (dName d)
}
instance AddParams TySyn where
addParams ps ts = ts { tsParams = pTypes ps ++ tsParams ts
, tsConstraints = pTypeConstraints ps ++ tsConstraints ts
-- do we need these here ^ ?
, tsName = toParamInstName (tsName ts)
}
instance AddParams Newtype where
addParams ps nt = nt { ntParams = pTypes ps ++ ntParams nt
, ntConstraints = pTypeConstraints ps ++ ntConstraints nt
, ntName = toParamInstName (ntName nt)
}
--------------------------------------------------------------------------------
-- | Adjust uses of names to account for the new parameters.
-- Assumes unique names---no capture or shadowing.
class Inst a where
inst :: Inp -> a -> a
-- | Set of top-level names which need to be instantiate, and module parameters.
type Inp = (Set Name, Params)
paramRecTy :: Params -> Type
paramRecTy ps = tRec [ (nameIdent x, t) | (x,t) <- pFuns ps ]
nameInst :: Inp -> Name -> [Type] -> Int -> Expr
nameInst (_,ps) x ts prfs
| null (pFuns ps) = withProofs
| otherwise = EApp withProofs (EVar paramModRecParam)
where
withProofs = iterate EProofApp withTys !!
(length (pTypeConstraints ps) + prfs)
withTys = foldl ETApp (EVar (toParamInstName x))
(map (TVar . tpVar) (pTypes ps) ++ ts)
-- | Extra parameters to dd when instantiating a type
instTyParams :: Inp -> [Type]
instTyParams (_,ps) = map (TVar . tpVar) (pTypes ps)
needsInst :: Inp -> Name -> Bool
needsInst (xs,_) x = Set.member x xs
isVParam :: Inp -> Name -> Bool
isVParam (_,ps) x = x `elem` map fst (pFuns ps)
isTParam :: Inp -> TVar -> Maybe TParam
isTParam (_,ps) x =
case x of
TVBound tp -> find thisName (pTypes ps)
where thisName y = tpName tp == tpName y
_ -> Nothing
instance Inst a => Inst [a] where
inst ps = map (inst ps)
instance Inst Expr where
inst ps expr =
case expr of
EVar x
| needsInst ps x -> nameInst ps x [] 0
| isVParam ps x ->
let sh = map (nameIdent . fst) (pFuns (snd ps))
in ESel (EVar paramModRecParam) (RecordSel (nameIdent x) (Just sh))
| otherwise -> EVar x
EList es t -> EList (inst ps es) (inst ps t)
ETuple es -> ETuple (inst ps es)
ERec fs -> ERec [ (f,inst ps e) | (f,e) <- fs ]
ESel e s -> ESel (inst ps e) s
ESet e s v -> ESet (inst ps e) s (inst ps v)
EIf e1 e2 e3 -> EIf (inst ps e1) (inst ps e2) (inst ps e3)
EComp t1 t2 e ms -> EComp (inst ps t1) (inst ps t2)
(inst ps e) (inst ps ms)
ETAbs x e -> ETAbs x (inst ps e)
ETApp e1 t ->
case splitExprInst expr of
(EVar x, ts, prfs) | needsInst ps x -> nameInst ps x ts prfs
_ -> ETApp (inst ps e1) t
EApp e1 e2 -> EApp (inst ps e1) (inst ps e2)
EAbs x t e -> EAbs x (inst ps t) (inst ps e)
EProofAbs p e -> EProofAbs (inst ps p) (inst ps e)
EProofApp e1 ->
case splitExprInst expr of
(EVar x, ts, prfs) | needsInst ps x -> nameInst ps x ts prfs
_ -> EProofApp (inst ps e1)
EWhere e dgs -> EWhere (inst ps e) (inst ps dgs)
instance Inst Match where
inst ps m =
case m of
From x t1 t2 e -> From x (inst ps t1) (inst ps t2) (inst ps e)
Let d -> Let (inst ps d)
instance Inst DeclGroup where
inst ps dg =
case dg of
Recursive ds -> Recursive (inst ps ds)
NonRecursive d -> NonRecursive (inst ps d)
instance Inst Decl where
inst ps d = d { dDefinition = inst ps (dDefinition d) }
instance Inst DeclDef where
inst ps d =
case d of
DPrim -> DPrim
DExpr e -> DExpr (inst ps e)
instance Inst Type where
inst ps ty =
case ty of
TUser x ts t
| needsInst ps x -> TUser x (instTyParams ps ++ ts1) t1
| otherwise -> TUser x ts1 t1
where ts1 = inst ps ts
t1 = inst ps t
TCon tc ts ->
case tc of
TC (TCNewtype (UserTC x k))
| needsInst ps x -> TCon (TC (TCNewtype (UserTC x (k1 k))))
(newTs ++ ts1)
_ -> TCon tc ts1
where
ts1 = inst ps ts
newTs = instTyParams ps
k1 k = foldr (:->) k (map kindOf newTs)
TVar x | Just x' <- isTParam ps x -> TVar (TVBound x')
| otherwise -> ty
TRec xs -> TRec [ (f,inst ps t) | (f,t) <- xs ]
instance Inst TySyn where
inst ps ts = ts { tsConstraints = inst ps (tsConstraints ts)
, tsDef = inst ps (tsDef ts)
}
instance Inst Newtype where
inst ps nt = nt { ntConstraints = inst ps (ntConstraints nt)
, ntFields = [ (f, inst ps t) | (f,t) <- ntFields nt ]
}
cryptol-2.8.0/src/Cryptol/Transform/MonoValues.hs 0000644 0000000 0000000 00000027607 07346545000 020244 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Transform.MonoValues
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- This module implements a transformation, which tries to avoid exponential
-- slow down in some cases. What's the problem? Consider the following (common)
-- patterns:
--
-- fibs = [0,1] # [ x + y | x <- fibs, y <- drop`{1} fibs ]
--
-- The type of `fibs` is:
--
-- {a} (a >= 1, fin a) => [inf][a]
--
-- Here `a` is the number of bits to be used in the values computed by `fibs`.
-- When we evaluate `fibs`, `a` becomes a parameter to `fibs`, which works
-- except that now `fibs` is a function, and we don't get any of the memoization
-- we might expect! What looked like an efficient implementation has all
-- of a sudden become exponential!
--
-- Note that this is only a problem for polymorphic values: if `fibs` was
-- already a function, it would not be that surprising that it does not
-- get cached.
--
-- So, to avoid this, we try to spot recursive polymorphic values,
-- where the recursive occurrences have the exact same type parameters
-- as the definition. For example, this is the case in `fibs`: each
-- recursive call to `fibs` is instantiated with exactly the same
-- type parameter (i.e., `a`). The rewrite we do is as follows:
--
-- fibs : {a} (a >= 1, fin a) => [inf][a]
-- fibs = \{a} (a >= 1, fin a) -> fibs'
-- where fibs' : [inf][a]
-- fibs' = [0,1] # [ x + y | x <- fibs', y <- drop`{1} fibs' ]
--
-- After the rewrite, the recursion is monomorphic (i.e., we are always using
-- the same type). As a result, `fibs'` is an ordinary recursive value,
-- where we get the benefit of caching.
--
-- The rewrite is a bit more complex, when there are multiple mutually
-- recursive functions. Here is an example:
--
-- zig : {a} (a >= 2, fin a) => [inf][a]
-- zig = [1] # zag
--
-- zag : {a} (a >= 2, fin a) => [inf][a]
-- zag = [2] # zig
--
-- This gets rewritten to:
--
-- newName : {a} (a >= 2, fin a) => ([inf][a], [inf][a])
-- newName = \{a} (a >= 2, fin a) -> (zig', zag')
-- where
-- zig' : [inf][a]
-- zig' = [1] # zag'
--
-- zag' : [inf][a]
-- zag' = [2] # zig'
--
-- zig : {a} (a >= 2, fin a) => [inf][a]
-- zig = \{a} (a >= 2, fin a) -> (newName a <> <> ).1
--
-- zag : {a} (a >= 2, fin a) => [inf][a]
-- zag = \{a} (a >= 2, fin a) -> (newName a <> <> ).2
--
-- NOTE: We are assuming that no capture would occur with binders.
-- For values, this is because we replaces things with freshly chosen variables.
-- For types, this should be because there should be no shadowing in the types.
-- XXX: Make sure that this really is the case for types!!
{-# LANGUAGE PatternGuards, FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Transform.MonoValues (rewModule) where
import Cryptol.ModuleSystem.Name
(SupplyT,liftSupply,Supply,mkDeclared,NameSource(..))
import Cryptol.Parser.Position (emptyRange)
import Cryptol.TypeCheck.AST hiding (splitTApp) -- XXX: just use this one
import Cryptol.TypeCheck.TypeMap
import Cryptol.Utils.Ident (ModName)
import Data.List(sortBy,groupBy)
import Data.Either(partitionEithers)
import Data.Map (Map)
import MonadLib hiding (mapM)
import Prelude ()
import Prelude.Compat
{- (f,t,n) |--> x means that when we spot instantiations of `f` with `ts` and
`n` proof argument, we should replace them with `Var x` -}
newtype RewMap' a = RM (Map Name (TypesMap (Map Int a)))
type RewMap = RewMap' Name
instance TrieMap RewMap' (Name,[Type],Int) where
emptyTM = RM emptyTM
nullTM (RM m) = nullTM m
lookupTM (x,ts,n) (RM m) = do tM <- lookupTM x m
tP <- lookupTM ts tM
lookupTM n tP
alterTM (x,ts,n) f (RM m) = RM (alterTM x f1 m)
where
f1 Nothing = do a <- f Nothing
return (insertTM ts (insertTM n a emptyTM) emptyTM)
f1 (Just tM) = Just (alterTM ts f2 tM)
f2 Nothing = do a <- f Nothing
return (insertTM n a emptyTM)
f2 (Just pM) = Just (alterTM n f pM)
unionTM f (RM a) (RM b) = RM (unionTM (unionTM (unionTM f)) a b)
toListTM (RM m) = [ ((x,ts,n),y) | (x,tM) <- toListTM m
, (ts,pM) <- toListTM tM
, (n,y) <- toListTM pM ]
mapMaybeWithKeyTM f (RM m) =
RM (mapWithKeyTM (\qn tm ->
mapWithKeyTM (\tys is ->
mapMaybeWithKeyTM (\i a -> f (qn,tys,i) a) is) tm) m)
-- | Note that this assumes that this pass will be run only once for each
-- module, otherwise we will get name collisions.
rewModule :: Supply -> Module -> (Module,Supply)
rewModule s m = runM body (mName m) s
where
body = do ds <- mapM (rewDeclGroup emptyTM) (mDecls m)
return m { mDecls = ds }
--------------------------------------------------------------------------------
type M = ReaderT RO (SupplyT Id)
type RO = ModName
-- | Produce a fresh top-level name.
newName :: M Name
newName =
do ns <- ask
liftSupply (mkDeclared ns SystemName "$mono" Nothing emptyRange)
newTopOrLocalName :: M Name
newTopOrLocalName = newName
-- | Not really any distinction between global and local, all names get the
-- module prefix added, and a unique id.
inLocal :: M a -> M a
inLocal = id
--------------------------------------------------------------------------------
rewE :: RewMap -> Expr -> M Expr -- XXX: not IO
rewE rews = go
where
tryRewrite (EVar x,tps,n) =
do y <- lookupTM (x,tps,n) rews
return (EVar y)
tryRewrite _ = Nothing
go expr =
case expr of
-- Interesting cases
ETApp e t -> case tryRewrite (splitTApp expr 0) of
Nothing -> ETApp <$> go e <*> return t
Just yes -> return yes
EProofApp e -> case tryRewrite (splitTApp e 1) of
Nothing -> EProofApp <$> go e
Just yes -> return yes
EList es t -> EList <$> mapM go es <*> return t
ETuple es -> ETuple <$> mapM go es
ERec fs -> ERec <$> (forM fs $ \(f,e) -> do e1 <- go e
return (f,e1))
ESel e s -> ESel <$> go e <*> return s
ESet e s v -> ESet <$> go e <*> return s <*> go v
EIf e1 e2 e3 -> EIf <$> go e1 <*> go e2 <*> go e3
EComp len t e mss -> EComp len t <$> go e <*> mapM (mapM (rewM rews)) mss
EVar _ -> return expr
ETAbs x e -> ETAbs x <$> go e
EApp e1 e2 -> EApp <$> go e1 <*> go e2
EAbs x t e -> EAbs x t <$> go e
EProofAbs x e -> EProofAbs x <$> go e
EWhere e dgs -> EWhere <$> go e <*> inLocal
(mapM (rewDeclGroup rews) dgs)
rewM :: RewMap -> Match -> M Match
rewM rews ma =
case ma of
From x len t e -> From x len t <$> rewE rews e
-- These are not recursive.
Let d -> Let <$> rewD rews d
rewD :: RewMap -> Decl -> M Decl
rewD rews d = do e <- rewDef rews (dDefinition d)
return d { dDefinition = e }
rewDef :: RewMap -> DeclDef -> M DeclDef
rewDef rews (DExpr e) = DExpr <$> rewE rews e
rewDef _ DPrim = return DPrim
rewDeclGroup :: RewMap -> DeclGroup -> M DeclGroup
rewDeclGroup rews dg =
case dg of
NonRecursive d -> NonRecursive <$> rewD rews d
Recursive ds ->
do let (leave,rew) = partitionEithers (map consider ds)
rewGroups = groupBy sameTParams
$ sortBy compareTParams rew
ds1 <- mapM (rewD rews) leave
ds2 <- mapM rewSame rewGroups
return $ Recursive (ds1 ++ concat ds2)
where
sameTParams (_,tps1,x,_) (_,tps2,y,_) = tps1 == tps2 && x == y
compareTParams (_,tps1,x,_) (_,tps2,y,_) = compare (x,tps1) (y,tps2)
consider d =
case dDefinition d of
DPrim -> Left d
DExpr e -> let (tps,props,e') = splitTParams e
in if not (null tps) && notFun e'
then Right (d, tps, props, e')
else Left d
rewSame ds =
do new <- forM ds $ \(d,_,_,e) ->
do x <- newName
return (d, x, e)
let (_,tps,props,_) : _ = ds
tys = map (TVar . tpVar) tps
proofNum = length props
addRew (d,x,_) = insertTM (dName d,tys,proofNum) x
newRews = foldr addRew rews new
newDs <- forM new $ \(d,newN,e) ->
do e1 <- rewE newRews e
return ( d
, d { dName = newN
, dSignature = (dSignature d)
{ sVars = [], sProps = [] }
, dDefinition = DExpr e1
}
)
case newDs of
[(f,f')] ->
return [ f { dDefinition =
let newBody = EVar (dName f')
newE = EWhere newBody
[ Recursive [f'] ]
in DExpr $ foldr ETAbs
(foldr EProofAbs newE props) tps
}
]
_ -> do tupName <- newTopOrLocalName
let (polyDs,monoDs) = unzip newDs
tupAr = length monoDs
addTPs = flip (foldr ETAbs) tps
. flip (foldr EProofAbs) props
-- tuple = \{a} p -> (f',g')
-- where f' = ...
-- g' = ...
tupD = Decl
{ dName = tupName
, dSignature =
Forall tps props $
TCon (TC (TCTuple tupAr))
(map (sType . dSignature) monoDs)
, dDefinition =
DExpr $
addTPs $
EWhere (ETuple [ EVar (dName d) | d <- monoDs ])
[ Recursive monoDs ]
, dPragmas = [] -- ?
, dInfix = False
, dFixity = Nothing
, dDoc = Nothing
}
mkProof e _ = EProofApp e
-- f = \{a} (p) -> (tuple @a p). n
mkFunDef n f =
f { dDefinition =
DExpr $
addTPs $ ESel ( flip (foldl mkProof) props
$ flip (foldl ETApp) tys
$ EVar tupName
) (TupleSel n (Just tupAr))
}
return (tupD : zipWith mkFunDef [ 0 .. ] polyDs)
--------------------------------------------------------------------------------
splitTParams :: Expr -> ([TParam], [Prop], Expr)
splitTParams e = let (tps, e1) = splitWhile splitTAbs e
(props, e2) = splitWhile splitProofAbs e1
in (tps,props,e2)
-- returns type instantitaion and how many "proofs" were there
splitTApp :: Expr -> Int -> (Expr, [Type], Int)
splitTApp (EProofApp e) n = splitTApp e $! (n + 1)
splitTApp e0 n = let (e1,ts) = splitTy e0 []
in (e1, ts, n)
where
splitTy (ETApp e t) ts = splitTy e (t:ts)
splitTy e ts = (e,ts)
notFun :: Expr -> Bool
notFun (EAbs {}) = False
notFun (EProofAbs _ e) = notFun e
notFun _ = True
cryptol-2.8.0/src/Cryptol/Transform/Specialize.hs 0000644 0000000 0000000 00000031536 07346545000 020240 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Transform.Specialize
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
module Cryptol.Transform.Specialize
where
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.TypeMap
import Cryptol.TypeCheck.Subst
import qualified Cryptol.ModuleSystem as M
import qualified Cryptol.ModuleSystem.Env as M
import qualified Cryptol.ModuleSystem.Monad as M
import Cryptol.ModuleSystem.Name
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import MonadLib hiding (mapM)
import Prelude ()
import Prelude.Compat
-- Specializer Monad -----------------------------------------------------------
-- | A Name should have an entry in the SpecCache iff it is
-- specializable. Each Name starts out with an empty TypesMap.
type SpecCache = Map Name (Decl, TypesMap (Name, Maybe Decl))
-- | The specializer monad.
type SpecT m a = StateT SpecCache (M.ModuleT m) a
type SpecM a = SpecT IO a
runSpecT :: SpecCache -> SpecT m a -> M.ModuleT m (a, SpecCache)
runSpecT s m = runStateT s m
liftSpecT :: Monad m => M.ModuleT m a -> SpecT m a
liftSpecT m = lift m
getSpecCache :: Monad m => SpecT m SpecCache
getSpecCache = get
setSpecCache :: Monad m => SpecCache -> SpecT m ()
setSpecCache = set
modifySpecCache :: Monad m => (SpecCache -> SpecCache) -> SpecT m ()
modifySpecCache = modify
modify :: StateM m s => (s -> s) -> m ()
modify f = get >>= (set . f)
-- Specializer -----------------------------------------------------------------
-- | Add a `where` clause to the given expression containing
-- type-specialized versions of all functions called (transitively) by
-- the body of the expression.
specialize :: Expr -> M.ModuleCmd Expr
specialize expr (ev,modEnv) = run $ do
let extDgs = allDeclGroups modEnv
let (tparams, expr') = destETAbs expr
spec' <- specializeEWhere expr' extDgs
return (foldr ETAbs spec' tparams)
where
run = M.runModuleT (ev,modEnv) . fmap fst . runSpecT Map.empty
specializeExpr :: Expr -> SpecM Expr
specializeExpr expr =
case expr of
EList es t -> EList <$> traverse specializeExpr es <*> pure t
ETuple es -> ETuple <$> traverse specializeExpr es
ERec fs -> ERec <$> traverse (traverseSnd specializeExpr) fs
ESel e s -> ESel <$> specializeExpr e <*> pure s
ESet e s v -> ESet <$> specializeExpr e <*> pure s <*> specializeExpr v
EIf e1 e2 e3 -> EIf <$> specializeExpr e1 <*> specializeExpr e2 <*> specializeExpr e3
EComp len t e mss -> EComp len t <$> specializeExpr e <*> traverse (traverse specializeMatch) mss
-- Bindings within list comprehensions always have monomorphic types.
EVar {} -> specializeConst expr
ETAbs t e -> do
cache <- getSpecCache
setSpecCache Map.empty
e' <- specializeExpr e
setSpecCache cache
return (ETAbs t e')
-- We need to make sure that after processing `e`, no specialized
-- decls mentioning type variable `t` escape outside the
-- `ETAbs`. To avoid this, we reset to an empty SpecCache while we
-- run `specializeExpr e`, and restore it afterward: this
-- effectively prevents the specializer from registering any type
-- instantiations involving `t` for any decls bound outside the
-- scope of `t`.
ETApp {} -> specializeConst expr
EApp e1 e2 -> EApp <$> specializeExpr e1 <*> specializeExpr e2
EAbs qn t e -> EAbs qn t <$> specializeExpr e
EProofAbs p e -> EProofAbs p <$> specializeExpr e
EProofApp {} -> specializeConst expr
EWhere e dgs -> specializeEWhere e dgs
specializeMatch :: Match -> SpecM Match
specializeMatch (From qn l t e) = From qn l t <$> specializeExpr e
specializeMatch (Let decl)
| null (sVars (dSignature decl)) = return (Let decl)
| otherwise = fail "unimplemented: specializeMatch Let unimplemented"
-- TODO: should treat this case like EWhere.
-- | Add the declarations to the SpecCache, run the given monadic
-- action, and then pull the specialized declarations back out of the
-- SpecCache state. Return the result along with the declarations and
-- a table of names of specialized bindings.
withDeclGroups :: [DeclGroup] -> SpecM a
-> SpecM (a, [DeclGroup], Map Name (TypesMap Name))
withDeclGroups dgs action = do
origCache <- getSpecCache
let decls = concatMap groupDecls dgs
let newCache = Map.fromList [ (dName d, (d, emptyTM)) | d <- decls ]
let savedCache = Map.intersection origCache newCache
-- We assume that the names bound in dgs are disjoint from the other names in scope.
setSpecCache (Map.union newCache origCache)
result <- action
-- Then reassemble the DeclGroups.
let splitDecl :: Decl -> SpecM [Decl]
splitDecl d = do
~(Just (_, tm)) <- Map.lookup (dName d) <$> getSpecCache
return (catMaybes $ map (snd . snd) $ toListTM tm)
let splitDeclGroup :: DeclGroup -> SpecM [DeclGroup]
splitDeclGroup (Recursive ds) = do
ds' <- concat <$> traverse splitDecl ds
if null ds'
then return []
else return [Recursive ds']
splitDeclGroup (NonRecursive d) = map NonRecursive <$> splitDecl d
dgs' <- concat <$> traverse splitDeclGroup dgs
-- Get updated map of only the local entries we added.
newCache' <- flip Map.intersection newCache <$> getSpecCache
let nameTable = fmap (fmap fst . snd) newCache'
-- Remove local definitions from the cache.
modifySpecCache (Map.union savedCache . flip Map.difference newCache)
return (result, dgs', nameTable)
-- | Compute the specialization of `EWhere e dgs`. A decl within `dgs`
-- is replicated once for each monomorphic type instance at which it
-- is used; decls not mentioned in `e` (even monomorphic ones) are
-- simply dropped.
specializeEWhere :: Expr -> [DeclGroup] -> SpecM Expr
specializeEWhere e dgs = do
(e', dgs', _) <- withDeclGroups dgs (specializeExpr e)
return $ if null dgs'
then e'
else EWhere e' dgs'
-- | Transform the given declaration groups into a set of monomorphic
-- declarations. All of the original declarations with monomorphic
-- types are kept; additionally the result set includes instantiated
-- versions of polymorphic decls that are referenced by the
-- monomorphic bindings. We also return a map relating generated names
-- to the names from the original declarations.
specializeDeclGroups :: [DeclGroup] -> SpecM ([DeclGroup], Map Name (TypesMap Name))
specializeDeclGroups dgs = do
let decls = concatMap groupDecls dgs
let isMonoType s = null (sVars s) && null (sProps s)
let monos = [ EVar (dName d) | d <- decls, isMonoType (dSignature d) ]
(_, dgs', names) <- withDeclGroups dgs $ mapM specializeExpr monos
return (dgs', names)
specializeConst :: Expr -> SpecM Expr
specializeConst e0 = do
let (e1, n) = destEProofApps e0
let (e2, ts) = destETApps e1
case e2 of
EVar qname ->
do cache <- getSpecCache
case Map.lookup qname cache of
Nothing -> return e0 -- Primitive/unspecializable variable; leave it alone
Just (decl, tm) ->
case lookupTM ts tm of
Just (qname', _) -> return (EVar qname') -- Already specialized
Nothing -> do -- A new type instance of this function
qname' <- freshName qname ts -- New type instance, record new name
sig' <- instantiateSchema ts n (dSignature decl)
modifySpecCache (Map.adjust (fmap (insertTM ts (qname', Nothing))) qname)
rhs' <- case dDefinition decl of
DExpr e -> do e' <- specializeExpr =<< instantiateExpr ts n e
return (DExpr e')
DPrim -> return DPrim
let decl' = decl { dName = qname', dSignature = sig', dDefinition = rhs' }
modifySpecCache (Map.adjust (fmap (insertTM ts (qname', Just decl'))) qname)
return (EVar qname')
_ -> return e0 -- type/proof application to non-variable; not specializable
-- Utility Functions -----------------------------------------------------------
destEProofApps :: Expr -> (Expr, Int)
destEProofApps = go 0
where
go n (EProofApp e) = go (n + 1) e
go n e = (e, n)
destETApps :: Expr -> (Expr, [Type])
destETApps = go []
where
go ts (ETApp e t) = go (t : ts) e
go ts e = (e, ts)
destEProofAbs :: Expr -> ([Prop], Expr)
destEProofAbs = go []
where
go ps (EProofAbs p e) = go (p : ps) e
go ps e = (ps, e)
destETAbs :: Expr -> ([TParam], Expr)
destETAbs = go []
where
go ts (ETAbs t e) = go (t : ts) e
go ts e = (ts, e)
-- Any top-level declarations in the current module can be found in the
-- ModuleEnv's LoadedModules, and so we can count of freshName to avoid
-- collisions with them. Any generated name for a
-- specialized function will be qualified with the current @ModName@, so genned
-- names will not collide with local decls either.
-- freshName :: Name -> [Type] -> SpecM Name
-- freshName n [] = return n
-- freshName (QName m name) tys = do
-- let name' = reifyName name tys
-- bNames <- matchingBoundNames m
-- let loop i = let nm = name' ++ "_" ++ show i
-- in if nm `elem` bNames
-- then loop $ i + 1
-- else nm
-- let go = if name' `elem` bNames
-- then loop (1 :: Integer)
-- else name'
-- return $ QName m (mkName go)
-- | Freshen a name by giving it a new unique.
freshName :: Name -> [Type] -> SpecM Name
freshName n _ =
case nameInfo n of
Declared ns s -> liftSupply (mkDeclared ns s ident fx loc)
Parameter -> liftSupply (mkParameter ident loc)
where
fx = nameFixity n
ident = nameIdent n
loc = nameLoc n
-- matchingBoundNames :: (Maybe ModName) -> SpecM [String]
-- matchingBoundNames m = do
-- qns <- allPublicNames <$> liftSpecT M.getModuleEnv
-- return [ unpack n | QName m' (Name n) <- qns , m == m' ]
-- reifyName :: Name -> [Type] -> String
-- reifyName name tys = intercalate "_" (showName name : concatMap showT tys)
-- where
-- tvInt (TVFree i _ _ _) = i
-- tvInt (TVBound i _) = i
-- showT typ =
-- case typ of
-- TCon tc ts -> showTCon tc : concatMap showT ts
-- TUser _ _ t -> showT t
-- TVar tv -> [ "a" ++ show (tvInt tv) ]
-- TRec tr -> "rec" : concatMap showRecFld tr
-- showTCon tCon =
-- case tCon of
-- TC tc -> showTC tc
-- PC pc -> showPC pc
-- TF tf -> showTF tf
-- showPC pc =
-- case pc of
-- PEqual -> "eq"
-- PNeq -> "neq"
-- PGeq -> "geq"
-- PFin -> "fin"
-- PHas sel -> "sel_" ++ showSel sel
-- PArith -> "arith"
-- PCmp -> "cmp"
-- showTC tc =
-- case tc of
-- TCNum n -> show n
-- TCInf -> "inf"
-- TCBit -> "bit"
-- TCSeq -> "seq"
-- TCFun -> "fun"
-- TCTuple n -> "t" ++ show n
-- TCNewtype _ -> "user"
-- showSel sel = intercalate "_" $
-- case sel of
-- TupleSel _ sig -> "tup" : maybe [] ((:[]) . show) sig
-- RecordSel x sig -> "rec" : showName x : map showName (maybe [] id sig)
-- ListSel _ sig -> "list" : maybe [] ((:[]) . show) sig
-- showName nm =
-- case nm of
-- Name s -> unpack s
-- NewName _ n -> "x" ++ show n
-- showTF tf =
-- case tf of
-- TCAdd -> "add"
-- TCSub -> "sub"
-- TCMul -> "mul"
-- TCDiv -> "div"
-- TCMod -> "mod"
-- TCExp -> "exp"
-- TCWidth -> "width"
-- TCMin -> "min"
-- TCMax -> "max"
-- TCLenFromThenTo -> "len_from_then_to"
-- showRecFld (nm,t) = showName nm : showT t
instantiateSchema :: [Type] -> Int -> Schema -> SpecM Schema
instantiateSchema ts n (Forall params props ty)
| length params /= length ts = fail "instantiateSchema: wrong number of type arguments"
| length props /= n = fail "instantiateSchema: wrong number of prop arguments"
| otherwise = return $ Forall [] [] (apSubst sub ty)
where sub = listParamSubst (zip params ts)
-- | Reduce `length ts` outermost type abstractions and `n` proof abstractions.
instantiateExpr :: [Type] -> Int -> Expr -> SpecM Expr
instantiateExpr [] 0 e = return e
instantiateExpr [] n (EProofAbs _ e) = instantiateExpr [] (n - 1) e
instantiateExpr (t : ts) n (ETAbs param e) =
instantiateExpr ts n (apSubst (singleSubst (tpVar param) t) e)
instantiateExpr _ _ _ = fail "instantiateExpr: wrong number of type/proof arguments"
allDeclGroups :: M.ModuleEnv -> [DeclGroup]
allDeclGroups =
concatMap mDecls
. M.loadedModules
traverseSnd :: Functor f => (b -> f c) -> (a, b) -> f (a, c)
traverseSnd f (x, y) = (,) x <$> f y
cryptol-2.8.0/src/Cryptol/TypeCheck.hs 0000644 0000000 0000000 00000011164 07346545000 016047 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE PatternGuards, OverloadedStrings #-}
module Cryptol.TypeCheck
( tcModule
, tcModuleInst
, tcExpr
, tcDecls
, InferInput(..)
, InferOutput(..)
, SolverConfig(..)
, NameSeeds
, nameSeeds
, Error(..)
, Warning(..)
, ppWarning
, ppError
) where
import Cryptol.ModuleSystem.Name
(liftSupply,mkDeclared,NameSource(..))
import qualified Cryptol.Parser.AST as P
import Cryptol.Parser.Position(Range,emptyRange)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Depends (FromDecl)
import Cryptol.TypeCheck.Error
import Cryptol.TypeCheck.Monad
( runInferM
, InferInput(..)
, InferOutput(..)
, NameSeeds
, nameSeeds
, lookupVar
)
import Cryptol.TypeCheck.Infer (inferModule, inferBinds, inferDs)
import Cryptol.TypeCheck.InferTypes(VarType(..), SolverConfig(..))
import Cryptol.TypeCheck.Solve(proveModuleTopLevel)
import Cryptol.TypeCheck.CheckModuleInstance(checkModuleInstance)
import Cryptol.TypeCheck.Monad(withParamType,withParameterConstraints)
import Cryptol.Utils.Ident (exprModName,packIdent)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic(panic)
tcModule :: P.Module Name -> InferInput -> IO (InferOutput Module)
tcModule m inp = runInferM inp (inferModule m)
-- | Check a module instantiation, assuming that the functor has already
-- been checked.
tcModuleInst :: Module {- ^ functor -} ->
P.Module Name {- params -} ->
InferInput {- ^ TC settings -} ->
IO (InferOutput Module) {- ^ new version of instance -}
tcModuleInst func m inp = runInferM inp
$ do x <- inferModule m
y <- checkModuleInstance func x
flip (foldr withParamType) (mParamTypes x) $
withParameterConstraints (mParamConstraints x) $
proveModuleTopLevel
return y
tcExpr :: P.Expr Name -> InferInput -> IO (InferOutput (Expr,Schema))
tcExpr e0 inp = runInferM inp
$ do x <- go emptyRange e0
proveModuleTopLevel
return x
where
go loc expr =
case expr of
P.ELocated e loc' -> go loc' e
P.EVar x ->
do res <- lookupVar x
case res of
ExtVar s -> return (EVar x, s)
CurSCC e' t -> panic "Cryptol.TypeCheck.tcExpr"
[ "CurSCC outside binder checking:"
, show e'
, show t
]
_ -> do fresh <- liftSupply (mkDeclared exprModName SystemName
(packIdent "(expression)") Nothing loc)
res <- inferBinds True False
[ P.Bind
{ P.bName = P.Located { P.srcRange = loc, P.thing = fresh }
, P.bParams = []
, P.bDef = P.Located (inpRange inp) (P.DExpr expr)
, P.bPragmas = []
, P.bSignature = Nothing
, P.bMono = False
, P.bInfix = False
, P.bFixity = Nothing
, P.bDoc = Nothing
} ]
case res of
[d] | DExpr e <- dDefinition d -> return (e, dSignature d)
| otherwise ->
panic "Cryptol.TypeCheck.tcExpr"
[ "Expected an expression in definition"
, show d ]
_ -> panic "Cryptol.TypeCheck.tcExpr"
( "Multiple declarations when check expression:"
: map show res
)
tcDecls :: FromDecl d => [d] -> InferInput -> IO (InferOutput [DeclGroup])
tcDecls ds inp = runInferM inp $ inferDs ds $ \dgs -> do
proveModuleTopLevel
return dgs
ppWarning :: (Range,Warning) -> Doc
ppWarning (r,w) = text "[warning] at" <+> pp r <.> colon $$ nest 2 (pp w)
ppError :: (Range,Error) -> Doc
ppError (r,w) = text "[error] at" <+> pp r <.> colon $$ nest 2 (pp w)
cryptol-2.8.0/src/Cryptol/TypeCheck/ 0000755 0000000 0000000 00000000000 07346545000 015510 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/TypeCheck/AST.hs 0000644 0000000 0000000 00000031405 07346545000 016476 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.AST
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.TypeCheck.AST
( module Cryptol.TypeCheck.AST
, Name()
, TFun(..)
, Selector(..)
, Import(..)
, ImportSpec(..)
, ExportType(..)
, ExportSpec(..), isExportedBind, isExportedType
, Pragma(..)
, Fixity(..)
, PrimMap(..)
, TCErrorMessage(..)
, module Cryptol.TypeCheck.Type
) where
import Cryptol.Parser.Position(Located)
import Cryptol.ModuleSystem.Name
import Cryptol.ModuleSystem.Exports(ExportSpec(..)
, isExportedBind, isExportedType)
import Cryptol.Parser.AST ( Selector(..),Pragma(..)
, Import(..), ImportSpec(..), ExportType(..)
, Fixity(..))
import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,packIdent)
import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.Type
import GHC.Generics (Generic)
import Control.DeepSeq
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
-- | A Cryptol module.
data Module = Module { mName :: !ModName
, mExports :: ExportSpec Name
, mImports :: [Import]
, mTySyns :: Map Name TySyn
-- ^ This is just the type-level type synonyms
-- of a module.
, mNewtypes :: Map Name Newtype
, mPrimTypes :: Map Name AbstractType
, mParamTypes :: Map Name ModTParam
, mParamConstraints :: [Located Prop]
, mParamFuns :: Map Name ModVParam
, mDecls :: [DeclGroup]
} deriving (Show, Generic, NFData)
-- | Is this a parameterized module?
isParametrizedModule :: Module -> Bool
isParametrizedModule m = not (null (mParamTypes m) &&
null (mParamConstraints m) &&
null (mParamFuns m))
-- | A type parameter of a module.
data ModTParam = ModTParam
{ mtpName :: Name
, mtpKind :: Kind
, mtpNumber :: !Int -- ^ The number of the parameter in the module
-- This is used when we move parameters from the module
-- level to individual declarations
-- (type synonyms in particular)
, mtpDoc :: Maybe String
} deriving (Show,Generic,NFData)
mtpParam :: ModTParam -> TParam
mtpParam mtp = TParam { tpUnique = nameUnique (mtpName mtp)
, tpKind = mtpKind mtp
, tpFlav = TPModParam (mtpName mtp)
, tpInfo = desc
}
where desc = TVarInfo { tvarDesc = TVFromModParam (mtpName mtp)
, tvarSource = nameLoc (mtpName mtp)
}
-- | A value parameter of a module.
data ModVParam = ModVParam
{ mvpName :: Name
, mvpType :: Schema
, mvpDoc :: Maybe String
, mvpFixity :: Maybe Fixity
} deriving (Show,Generic,NFData)
data Expr = EList [Expr] Type -- ^ List value (with type of elements)
| ETuple [Expr] -- ^ Tuple value
| ERec [(Ident,Expr)] -- ^ Record value
| ESel Expr Selector -- ^ Elimination for tuple/record/list
| ESet Expr Selector Expr -- ^ Change the value of a field.
| EIf Expr Expr Expr -- ^ If-then-else
| EComp Type Type Expr [[Match]]
-- ^ List comprehensions
-- The types cache the length of the
-- sequence and its element type.
| EVar Name -- ^ Use of a bound variable
| ETAbs TParam Expr -- ^ Function Value
| ETApp Expr Type -- ^ Type application
| EApp Expr Expr -- ^ Function application
| EAbs Name Type Expr -- ^ Function value
{- | Proof abstraction. Because we don't keep proofs around
we don't need to name the assumption, but we still need to
record the assumption. The assumption is the `Type` term,
which should be of kind `KProp`.
-}
| EProofAbs {- x -} Prop Expr
{- | If `e : p => t`, then `EProofApp e : t`,
as long as we can prove `p`.
We don't record the actual proofs, as they are not
used for anything. It may be nice to keep them around
for sanity checking.
-}
| EProofApp Expr {- proof -}
| EWhere Expr [DeclGroup]
deriving (Show, Generic, NFData)
data Match = From Name Type Type Expr
-- ^ Type arguments are the length and element
-- type of the sequence expression
| Let Decl
deriving (Show, Generic, NFData)
data DeclGroup = Recursive [Decl] -- ^ Mutually recursive declarations
| NonRecursive Decl -- ^ Non-recursive declaration
deriving (Show, Generic, NFData)
groupDecls :: DeclGroup -> [Decl]
groupDecls dg = case dg of
Recursive ds -> ds
NonRecursive d -> [d]
data Decl = Decl { dName :: !Name
, dSignature :: Schema
, dDefinition :: DeclDef
, dPragmas :: [Pragma]
, dInfix :: !Bool
, dFixity :: Maybe Fixity
, dDoc :: Maybe String
} deriving (Generic, NFData, Show)
data DeclDef = DPrim
| DExpr Expr
deriving (Show, Generic, NFData)
--------------------------------------------------------------------------------
-- | Construct a primitive, given a map to the unique names of the Cryptol
-- module.
ePrim :: PrimMap -> Ident -> Expr
ePrim pm n = EVar (lookupPrimDecl n pm)
-- | Make an expression that is `error` pre-applied to a type and a message.
eError :: PrimMap -> Type -> String -> Expr
eError prims t str =
EApp (ETApp (ETApp (ePrim prims (packIdent "error")) t)
(tNum (length str))) (eString prims str)
eString :: PrimMap -> String -> Expr
eString prims str = EList (map (eChar prims) str) tChar
eChar :: PrimMap -> Char -> Expr
eChar prims c = ETApp (ETApp (ePrim prims (packIdent "number")) (tNum v)) (tWord (tNum w))
where v = fromEnum c
w = 8 :: Int
instance PP (WithNames Expr) where
ppPrec prec (WithNames expr nm) =
case expr of
EList [] t -> optParens (prec > 0)
$ text "[]" <+> colon <+> ppWP prec t
EList es _ -> brackets $ sep $ punctuate comma $ map ppW es
ETuple es -> parens $ sep $ punctuate comma $ map ppW es
ERec fs -> braces $ sep $ punctuate comma
[ pp f <+> text "=" <+> ppW e | (f,e) <- fs ]
ESel e sel -> ppWP 4 e <+> text "." <.> pp sel
ESet e sel v -> braces (pp e <+> "|" <+> pp sel <+> "=" <+> pp v)
EIf e1 e2 e3 -> optParens (prec > 0)
$ sep [ text "if" <+> ppW e1
, text "then" <+> ppW e2
, text "else" <+> ppW e3 ]
EComp _ _ e mss -> let arm ms = text "|" <+> commaSep (map ppW ms)
in brackets $ ppW e <+> vcat (map arm mss)
EVar x -> ppPrefixName x
EAbs {} -> let (xs,e) = splitWhile splitAbs expr
in ppLam nm prec [] [] xs e
EProofAbs {} -> let (ps,e1) = splitWhile splitProofAbs expr
(xs,e2) = splitWhile splitAbs e1
in ppLam nm prec [] ps xs e2
ETAbs {} -> let (ts,e1) = splitWhile splitTAbs expr
(ps,e2) = splitWhile splitProofAbs e1
(xs,e3) = splitWhile splitAbs e2
in ppLam nm prec ts ps xs e3
-- infix applications
EApp (EApp (EVar o) a) b
| isInfixIdent (nameIdent o) ->
ppPrec 3 a <+> ppInfixName o <+> ppPrec 3 b
| otherwise ->
ppPrefixName o <+> ppPrec 3 a <+> ppPrec 3 b
EApp e1 e2 -> optParens (prec > 3)
$ ppWP 3 e1 <+> ppWP 4 e2
EProofApp e -> optParens (prec > 3)
$ ppWP 3 e <+> text "<>"
ETApp e t -> optParens (prec > 3)
$ ppWP 3 e <+> ppWP 4 t
EWhere e ds -> optParens (prec > 0)
( ppW e $$ text "where"
$$ nest 2 (vcat (map ppW ds))
$$ text "" )
where
ppW x = ppWithNames nm x
ppWP x = ppWithNamesPrec nm x
ppLam :: NameMap -> Int -> [TParam] -> [Prop] -> [(Name,Type)] -> Expr -> Doc
ppLam nm prec [] [] [] e = ppWithNamesPrec nm prec e
ppLam nm prec ts ps xs e =
optParens (prec > 0) $
sep [ text "\\" <.> tsD <+> psD <+> xsD <+> text "->"
, ppWithNames ns1 e
]
where
ns1 = addTNames ts nm
tsD = if null ts then empty else braces $ sep $ punctuate comma $ map ppT ts
psD = if null ps then empty else parens $ sep $ punctuate comma $ map ppP ps
xsD = if null xs then empty else sep $ map ppArg xs
ppT = ppWithNames ns1
ppP = ppWithNames ns1
ppArg (x,t) = parens (pp x <+> text ":" <+> ppWithNames ns1 t)
splitWhile :: (a -> Maybe (b,a)) -> a -> ([b],a)
splitWhile f e = case f e of
Nothing -> ([], e)
Just (x,e1) -> let (xs,e2) = splitWhile f e1
in (x:xs,e2)
splitAbs :: Expr -> Maybe ((Name,Type), Expr)
splitAbs (EAbs x t e) = Just ((x,t), e)
splitAbs _ = Nothing
splitTAbs :: Expr -> Maybe (TParam, Expr)
splitTAbs (ETAbs t e) = Just (t, e)
splitTAbs _ = Nothing
splitProofAbs :: Expr -> Maybe (Prop, Expr)
splitProofAbs (EProofAbs p e) = Just (p,e)
splitProofAbs _ = Nothing
splitTApp :: Expr -> Maybe (Type,Expr)
splitTApp (ETApp e t) = Just (t, e)
splitTApp _ = Nothing
splitProofApp :: Expr -> Maybe ((), Expr)
splitProofApp (EProofApp e) = Just ((), e)
splitProofApp _ = Nothing
-- | Deconstruct an expression, typically polymorphic, into
-- the types and proofs to which it is applied.
-- Since we don't store the proofs, we just return
-- the number of proof applications.
-- The first type is the one closest to the expr.
splitExprInst :: Expr -> (Expr, [Type], Int)
splitExprInst e = (e2, reverse ts, length ps)
where
(ps,e1) = splitWhile splitProofApp e
(ts,e2) = splitWhile splitTApp e1
instance PP Expr where
ppPrec n t = ppWithNamesPrec IntMap.empty n t
instance PP (WithNames Match) where
ppPrec _ (WithNames mat nm) =
case mat of
From x _ _ e -> pp x <+> text "<-" <+> ppWithNames nm e
Let d -> text "let" <+> ppWithNames nm d
instance PP Match where
ppPrec = ppWithNamesPrec IntMap.empty
instance PP (WithNames DeclGroup) where
ppPrec _ (WithNames dg nm) =
case dg of
Recursive ds -> text "/* Recursive */"
$$ vcat (map (ppWithNames nm) ds)
$$ text ""
NonRecursive d -> text "/* Not recursive */"
$$ ppWithNames nm d
$$ text ""
instance PP DeclGroup where
ppPrec = ppWithNamesPrec IntMap.empty
instance PP (WithNames Decl) where
ppPrec _ (WithNames Decl { .. } nm) =
pp dName <+> text ":" <+> ppWithNames nm dSignature $$
(if null dPragmas
then empty
else text "pragmas" <+> pp dName <+> sep (map pp dPragmas)
) $$
pp dName <+> text "=" <+> ppWithNames nm dDefinition
instance PP (WithNames DeclDef) where
ppPrec _ (WithNames DPrim _) = text ""
ppPrec _ (WithNames (DExpr e) nm) = ppWithNames nm e
instance PP Decl where
ppPrec = ppWithNamesPrec IntMap.empty
instance PP Module where
ppPrec = ppWithNamesPrec IntMap.empty
instance PP (WithNames Module) where
ppPrec _ (WithNames Module { .. } nm) =
text "module" <+> pp mName $$
-- XXX: Print exports?
vcat (map pp mImports) $$
-- XXX: Print tysyns
-- XXX: Print abstarct types/functions
vcat (map (ppWithNames (addTNames mps nm)) mDecls)
where mps = map mtpParam (Map.elems mParamTypes)
cryptol-2.8.0/src/Cryptol/TypeCheck/CheckModuleInstance.hs 0000644 0000000 0000000 00000016100 07346545000 021712 0 ustar 00 0000000 0000000 module Cryptol.TypeCheck.CheckModuleInstance (checkModuleInstance) where
import Data.Map ( Map )
import qualified Data.Map as Map
import Control.Monad(unless)
import Cryptol.Parser.Position(Located(..))
import qualified Cryptol.Parser.AST as P
import Cryptol.ModuleSystem.Name(Name,nameIdent,nameLoc)
import Cryptol.ModuleSystem.InstantiateModule(instantiateModule)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Monad
import Cryptol.TypeCheck.Infer
import Cryptol.TypeCheck.Subst
import Cryptol.TypeCheck.Error
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
-- | Check that the instance provides what the functor needs.
checkModuleInstance :: Module {- ^ type-checked functor -} ->
Module {- ^ type-checked instance -} ->
InferM Module -- ^ Instantiated module
checkModuleInstance func inst =
do tMap <- checkTyParams func inst
vMap <- checkValParams func tMap inst
(ctrs, m) <- instantiateModule func (mName inst) tMap vMap
let toG p = Goal { goal = thing p
, goalRange = srcRange p
, goalSource = CtModuleInstance (mName inst)
}
addGoals (map toG ctrs)
return Module { mName = mName m
, mExports = mExports m
, mImports = mImports inst ++ mImports m
-- Note that this is just here to record
-- the full dependencies, the actual imports
-- might be ambiguous, but that shouldn't
-- matters as names have been already resolved
, mTySyns = Map.union (mTySyns inst) (mTySyns m)
, mNewtypes = Map.union (mNewtypes inst) (mNewtypes m)
, mPrimTypes = Map.union (mPrimTypes inst) (mPrimTypes m)
, mParamTypes = mParamTypes inst
, mParamConstraints = mParamConstraints inst
, mParamFuns = mParamFuns inst
, mDecls = mDecls inst ++ mDecls m
}
-- | Check that the type parameters of the functors all have appropriate
-- definitions.
checkTyParams :: Module -> Module -> InferM (Map TParam Type)
checkTyParams func inst =
Map.fromList <$> mapM checkTParamDefined (Map.elems (mParamTypes func))
where
-- Maps to lookup things by identifier (i.e., lexical name)
-- rather than using the name unique.
identMap f m = Map.fromList [ (f x, ts) | (x,ts) <- Map.toList m ]
tySyns = identMap nameIdent (mTySyns inst)
newTys = identMap nameIdent (mNewtypes inst)
tParams = Map.fromList [ (tpId x, x) | x0 <- Map.elems (mParamTypes inst)
, let x = mtpParam x0 ]
tpId x = case tpName x of
Just n -> nameIdent n
Nothing -> panic "inferModuleInstance.tpId" ["Missing name"]
-- Find a definition for a given type parameter
checkTParamDefined tp0 =
let tp = mtpParam tp0
x = tpId tp
in case Map.lookup x tySyns of
Just ts -> checkTySynDef tp ts
Nothing ->
case Map.lookup x newTys of
Just nt -> checkNewTyDef tp nt
Nothing ->
case Map.lookup x tParams of
Just tp1 -> checkTP tp tp1
Nothing ->
do recordError $ ErrorMsg $
text "Missing definition for type parameter:" <+> pp x
return (tp, TVar (TVBound tp)) -- hm, maybe just stop!
-- Check that a type parameter defined as a type synonym is OK
checkTySynDef tp ts =
do let k1 = kindOf tp
k2 = kindOf ts
unless (k1 == k2) (recordError (KindMismatch k1 k2))
let nm = tsName ts
src = CtPartialTypeFun nm
mapM_ (newGoal src) (tsConstraints ts)
return (tp, TUser nm [] (tsDef ts))
-- Check that a type parameter defined a newtype is OK
-- This one is a bit weird: since the newtype is deinfed in the
-- instantiation, it will not be exported, and so won't be usable
-- in type signatures, directly. This could be worked around
-- if the parametrized module explictly exported a parameter via
-- a type synonym like this: `type T = p`, where `p` is one of
-- the parametersm and the declartion for `T` is public.
checkNewTyDef tp nt =
do let k1 = kindOf tp
k2 = kindOf nt
unless (k1 == k2) (recordError (KindMismatch k1 k2))
let nm = ntName nt
src = CtPartialTypeFun nm
mapM_ (newGoal src) (ntConstraints nt)
return (tp, TCon (TC (TCNewtype (UserTC nm k2))) [])
-- Check that a type parameter defined as another type parameter is OK
checkTP tp tp1 =
do let k1 = kindOf tp
k2 = kindOf tp1
unless (k1 == k2) (recordError (KindMismatch k1 k2))
return (tp, TVar (TVBound tp1))
checkValParams :: Module {- ^ Parameterized module -} ->
Map TParam Type {- ^ Type instantiations -} ->
Module {- ^ Instantiation module -} ->
InferM (Map Name Expr)
-- ^ Definitions for the parameters
checkValParams func tMap inst =
Map.fromList <$> mapM checkParam (Map.elems (mParamFuns func))
where
valMap = Map.fromList (defByParam ++ defByDef)
defByDef = [ (nameIdent (dName d), (dName d, dSignature d))
| dg <- mDecls inst, d <- groupDecls dg ]
defByParam = [ (nameIdent x, (x, mvpType s)) |
(x,s) <- Map.toList (mParamFuns inst) ]
su = listParamSubst (Map.toList tMap)
checkParam pr =
let x = mvpName pr
sP = mvpType pr
in
case Map.lookup (nameIdent x) valMap of
Just (n,sD) -> do e <- makeValParamDef n sD (apSubst su sP)
return (x,e)
Nothing -> do recordError $ ErrorMsg
$ text "Mising definition for value parameter"
<+> pp x
return (x, panic "checkValParams" ["Should not use this"])
-- | Given a parameter definition, compute an appropriate instantiation
-- that will match the actual schema for the parameter.
makeValParamDef :: Name {- ^ Definition of parameter -} ->
Schema {- ^ Schema for parameter definition -} ->
Schema {- ^ Schema for parameter -} ->
InferM Expr {- ^ Expression to use for param definition -}
makeValParamDef x sDef pDef =
withVar x sDef $ do ~(DExpr e) <- dDefinition <$> checkSigB bnd (pDef,[])
return e
where
bnd = P.Bind { P.bName = loc x
, P.bParams = []
, P.bDef = loc (P.DExpr (P.EVar x))
-- unused
, P.bSignature = Nothing
, P.bInfix = False
, P.bFixity = Nothing
, P.bPragmas = []
, P.bMono = False
, P.bDoc = Nothing
}
loc a = P.Located { P.srcRange = nameLoc x, P.thing = a }
cryptol-2.8.0/src/Cryptol/TypeCheck/Default.hs 0000644 0000000 0000000 00000015305 07346545000 017434 0 ustar 00 0000000 0000000 module Cryptol.TypeCheck.Default where
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe(mapMaybe)
import Data.List((\\),nub)
import Control.Monad(guard)
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.SimpType(tMax,tWidth)
import Cryptol.TypeCheck.Error(Warning(..))
import Cryptol.TypeCheck.Subst(Subst,apSubst,listSubst,substBinds,singleSubst)
import Cryptol.TypeCheck.InferTypes(Goal,goal,Goals(..),goalsFromList)
import Cryptol.TypeCheck.Solver.SMT(Solver,tryGetModel,shrinkModel)
import Cryptol.Utils.Panic(panic)
--------------------------------------------------------------------------------
-- | We default constraints of the form @Literal t a@ to @a := [width t]@
defaultLiterals :: [TVar] -> [Goal] -> ([TVar], Subst, [Warning])
defaultLiterals as gs = let (binds,warns) = unzip (mapMaybe tryDefVar as)
in (as \\ map fst binds, listSubst binds, warns)
where
gSet = goalsFromList gs
tryDefVar a =
do gt <- Map.lookup a (literalGoals gSet)
let d = tvInfo a
defT = tWord (tWidth (goal gt))
w = DefaultingTo d defT
guard (not (Set.member a (fvs defT))) -- Currently shouldn't happen
-- but future proofing.
-- XXX: Make sure that `defT` has only variables that `a` is allowed
-- to depend on
return ((a,defT),w)
--------------------------------------------------------------------------------
-- This is what we use to avoid ambiguity when generalizing.
{- If a variable, `a`, is:
1. Of kind KNum
2. Generic (i.e., does not appear in the environment)
3. It appears only in constraints but not in the resulting type
(i.e., it is not on the RHS of =>)
4. It (say, the variable 'a') appears only in constraints like this:
3.1 `a >= t` with (`a` not in `fvs t`)
3.2 in the `s` of `fin s`
Then we replace `a` with `max(t1 .. tn)` where the `ts`
are from the constraints `a >= t`.
If `t1 .. tn` is empty, then we replace `a` with 0.
This function assumes that 1-3 have been checked, and implements the rest.
So, given some variables and constraints that are about to be generalized,
we return:
1. a new (same or smaller) set of variables to quantify,
2. a new set of constraints,
3. a substitution which indicates what got defaulted.
-}
improveByDefaultingWithPure :: [TVar] -> [Goal] ->
( [TVar] -- non-defaulted
, [Goal] -- new constraints
, Subst -- improvements from defaulting
, [Warning] -- warnings about defaulting
)
improveByDefaultingWithPure as ps =
classify (Map.fromList [ (a,([],Set.empty)) | a <- as ]) [] [] ps
where
-- leq: candidate definitions (i.e. of the form x >= t, x `notElem` fvs t)
-- for each of these, we keep the list of `t`, and the free vars in them.
-- fins: all `fin` constraints
-- others: any other constraints
classify leqs fins others [] =
let -- First, we use the `leqs` to choose some definitions.
(defs, newOthers) = select [] [] (fvs others) (Map.toList leqs)
su = listSubst defs
warn (x,t) =
case x of
TVFree _ _ _ d -> DefaultingTo d t
TVBound {} -> panic "Crypto.TypeCheck.Infer"
[ "tryDefault attempted to default a quantified variable."
]
names = substBinds su
in ( [ a | a <- as, not (a `Set.member` names) ]
, newOthers ++ others ++ nub (apSubst su fins)
, su
, map warn defs
)
classify leqs fins others (prop : more) =
case tNoUser (goal prop) of
-- We found a `fin` constraint.
TCon (PC PFin) [ _ ] -> classify leqs (prop : fins) others more
-- Things of the form: x >= T(x) are not defaulted.
TCon (PC PGeq) [ TVar x, t ]
| x `elem` as && x `Set.notMember` freeRHS ->
classify leqs' fins others more
where freeRHS = fvs t
add (xs1,vs1) (xs2,vs2) = (xs1 ++ xs2, Set.union vs1 vs2)
leqs' = Map.insertWith add x ([(t,prop)],freeRHS) leqs
_ -> classify leqs fins (prop : others) more
-- Pickout which variables may be defaulted and how.
-- XXX: simpType t
select yes no _ [] = ([ (x, t) | (x,t) <- yes ] ,no)
select yes no otherFree ((x,(rhsG,vs)) : more) =
select newYes newNo newFree newMore
where
(ts,gs) = unzip rhsG
-- `x` selected only if appears nowehere else.
-- this includes other candidates for defaulting.
(newYes,newNo,newFree,newMore)
-- Mentioned in other constraints, definately not defaultable.
| x `Set.member` otherFree = noDefaulting
| otherwise =
let deps = [ y | (y,(_,yvs)) <- more, x `Set.member` yvs ]
recs = filter (`Set.member` vs) deps
in if not (null recs) || isBoundTV x -- x >= S(y), y >= T(x)
then noDefaulting
-- x >= S, y >= T(x) or
-- x >= S(y), y >= S
else yesDefaulting
where
noDefaulting = ( yes, gs ++ no, vs `Set.union` otherFree, more )
yesDefaulting =
let ty = case ts of
[] -> tNum (0::Int)
_ -> foldr1 tMax ts
su1 = singleSubst x ty
in ( (x,ty) : [ (y,apSubst su1 t) | (y,t) <- yes ]
, no -- We know that `x` does not appear here
, otherFree -- We know that `x` did not appear here either
-- No need to update the `vs` because we've already
-- checked that there are no recursive dependencies.
, [ (y, (apSubst su1 ts1, vs1)) | (y,(ts1,vs1)) <- more ]
)
{- | Try to pick a reasonable instantiation for an expression with
the given type. This is useful when we do evaluation at the REPL.
The resulting types should satisfy the constraints of the schema.
The parameters should be all of numeric kind, and the props should als
be numeric -}
defaultReplExpr' :: Solver -> [TParam] -> [Prop] -> IO (Maybe [ (TParam,Type) ])
defaultReplExpr' sol as props =
do let params = map tpVar as
mb <- tryGetModel sol params props
case mb of
Nothing -> return Nothing
Just mdl0 ->
do mdl <- shrinkModel sol params props mdl0
let su = listSubst [ (x, tNat' n) | (x,n) <- mdl ]
return $
do guard (null (concatMap pSplitAnd (apSubst su props)))
tys <- mapM (bindParam su) params
return (zip as tys)
where
bindParam su tp =
do let ty = TVar tp
ty' = apSubst su ty
guard (ty /= ty')
return ty'
cryptol-2.8.0/src/Cryptol/TypeCheck/Depends.hs 0000644 0000000 0000000 00000016734 07346545000 017441 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Depends
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances #-}
module Cryptol.TypeCheck.Depends where
import Cryptol.ModuleSystem.Name (Name)
import qualified Cryptol.Parser.AST as P
import Cryptol.Parser.Position(Range, Located(..), thing)
import Cryptol.Parser.Names (namesB, tnamesT, tnamesC,
boundNamesSet, boundNames)
import Cryptol.TypeCheck.Monad( InferM, recordError, getTVars )
import Cryptol.TypeCheck.Error(Error(..))
import Cryptol.Utils.Panic(panic)
import Data.List(sortBy, groupBy)
import Data.Function(on)
import Data.Maybe(mapMaybe)
import Data.Graph.SCC(stronglyConnComp)
import Data.Graph (SCC(..))
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
data TyDecl =
TS (P.TySyn Name) (Maybe String) -- ^ Type synonym
| NT (P.Newtype Name) (Maybe String) -- ^ Newtype
| AT (P.ParameterType Name) (Maybe String) -- ^ Parameter type
| PS (P.PropSyn Name) (Maybe String) -- ^ Property synonym
| PT (P.PrimType Name) (Maybe String) -- ^ A primitive/abstract typee
deriving Show
setDocString :: Maybe String -> TyDecl -> TyDecl
setDocString x d =
case d of
TS a _ -> TS a x
PS a _ -> PS a x
NT a _ -> NT a x
AT a _ -> AT a x
PT a _ -> PT a x
-- | Check for duplicate and recursive type synonyms.
-- Returns the type-synonyms in dependency order.
orderTyDecls :: [TyDecl] -> InferM [TyDecl]
orderTyDecls ts =
do vs <- getTVars
ds <- combine $ map (toMap vs) ts
let ordered = mkScc [ (t,[x],deps)
| (x,(t,deps)) <- Map.toList (Map.map thing ds) ]
concat `fmap` mapM check ordered
where
toMap vs ty@(PT p _) =
let x = P.primTName p
(as,cs) = P.primTCts p
in ( thing x
, x { thing = (ty, Set.toList $
boundNamesSet vs $
boundNames (map P.tpName as) $
Set.unions $
map tnamesC cs
)
}
)
toMap _ ty@(AT a _) =
let x = P.ptName a
in ( thing x, x { thing = (ty, []) } )
toMap vs ty@(NT (P.Newtype x as fs) _) =
( thing x
, x { thing = (ty, Set.toList $
boundNamesSet vs $
boundNames (map P.tpName as) $
Set.unions $
map (tnamesT . P.value) fs
)
}
)
toMap vs ty@(TS (P.TySyn x _ as t) _) =
(thing x
, x { thing = (ty, Set.toList $
boundNamesSet vs $
boundNames (map P.tpName as) $
tnamesT t
)
}
)
toMap vs ty@(PS (P.PropSyn x _ as ps) _) =
(thing x
, x { thing = (ty, Set.toList $
boundNamesSet vs $
boundNames (map P.tpName as) $
Set.unions $
map tnamesC ps
)
}
)
getN (TS x _) = thing (P.tsName x)
getN (PS x _) = thing (P.psName x)
getN (NT x _) = thing (P.nName x)
getN (AT x _) = thing (P.ptName x)
getN (PT x _) = thing (P.primTName x)
check (AcyclicSCC x) = return [x]
-- We don't support any recursion, for now.
-- We could support recursion between newtypes, or newtypes and tysysn.
check (CyclicSCC xs) =
do recordError (RecursiveTypeDecls (map getN xs))
return [] -- XXX: This is likely to cause fake errors for missing
-- type synonyms. We could avoid this by, for example, checking
-- for recursive synonym errors, when looking up tycons.
-- | Associate type signatures with bindings and order bindings by dependency.
orderBinds :: [P.Bind Name] -> [SCC (P.Bind Name)]
orderBinds bs = mkScc [ (b, map thing defs, Set.toList uses)
| b <- bs
, let (defs,uses) = namesB b
]
class FromDecl d where
toBind :: d -> Maybe (P.Bind Name)
toParamFun :: d -> Maybe (P.ParameterFun Name)
toParamConstraints :: d -> [P.Located (P.Prop Name)]
toTyDecl :: d -> Maybe TyDecl
isTopDecl :: d -> Bool
instance FromDecl (P.TopDecl Name) where
toBind (P.Decl x) = toBind (P.tlValue x)
toBind _ = Nothing
toParamFun (P.DParameterFun d) = Just d
toParamFun _ = Nothing
toParamConstraints (P.DParameterConstraint xs) = xs
toParamConstraints _ = []
toTyDecl (P.DPrimType p) = Just (PT (P.tlValue p) (thing <$> P.tlDoc p))
toTyDecl (P.DParameterType d) = Just (AT d (P.ptDoc d))
toTyDecl (P.TDNewtype d) = Just (NT (P.tlValue d) (thing <$> P.tlDoc d))
toTyDecl (P.Decl x) = setDocString (thing <$> P.tlDoc x)
<$> toTyDecl (P.tlValue x)
toTyDecl _ = Nothing
isTopDecl _ = True
instance FromDecl (P.Decl Name) where
toBind (P.DLocated d _) = toBind d
toBind (P.DBind b) = return b
toBind _ = Nothing
toParamFun _ = Nothing
toParamConstraints _ = []
toTyDecl (P.DLocated d _) = toTyDecl d
toTyDecl (P.DType x) = Just (TS x Nothing)
toTyDecl (P.DProp x) = Just (PS x Nothing)
toTyDecl _ = Nothing
isTopDecl _ = False
{- | Given a list of declarations, annoted with (i) the names that they
define, and (ii) the names that they use, we compute a list of strongly
connected components of the declarations. The SCCs are in dependency order. -}
mkScc :: [(a,[Name],[Name])] -> [SCC a]
mkScc ents = stronglyConnComp $ zipWith mkGr keys ents
where
keys = [ 0 :: Integer .. ]
mkGr i (x,_,uses) = (x,i,mapMaybe (`Map.lookup` nodeMap) uses)
-- Maps names to node ids.
nodeMap = Map.fromList $ concat $ zipWith mkNode keys ents
mkNode i (_,defs,_) = [ (d,i) | d <- defs ]
{- | Combine a bunch of definitions into a single map. Here we check
that each name is defined only onces. -}
combineMaps :: [Map Name (Located a)] -> InferM (Map Name (Located a))
combineMaps ms = if null bad then return (Map.unions ms)
else panic "combineMaps" $ "Multiple definitions"
: map show bad
where
bad = do m <- ms
duplicates [ a { thing = x } | (x,a) <- Map.toList m ]
{- | Combine a bunch of definitions into a single map. Here we check
that each name is defined only onces. -}
combine :: [(Name, Located a)] -> InferM (Map Name (Located a))
combine m = if null bad then return (Map.fromList m)
else panic "combine" $ "Multiple definitions"
: map show bad
where
bad = duplicates [ a { thing = x } | (x,a) <- m ]
-- | Identify multiple occurances of something.
duplicates :: Ord a => [Located a] -> [(a,[Range])]
duplicates = mapMaybe multiple
. groupBy ((==) `on` thing)
. sortBy (compare `on` thing)
where
multiple xs@(x : _ : _) = Just (thing x, map srcRange xs)
multiple _ = Nothing
cryptol-2.8.0/src/Cryptol/TypeCheck/Error.hs 0000644 0000000 0000000 00000026670 07346545000 017150 0 ustar 00 0000000 0000000 {-# Language FlexibleInstances, DeriveGeneric, DeriveAnyClass #-}
{-# Language OverloadedStrings #-}
module Cryptol.TypeCheck.Error where
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import Control.DeepSeq(NFData)
import GHC.Generics(Generic)
import Data.List((\\),sortBy,groupBy,minimumBy)
import Data.Function(on)
import qualified Cryptol.Parser.AST as P
import Cryptol.Parser.Position(Located(..), Range(..))
import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.InferTypes
import Cryptol.TypeCheck.Subst
import Cryptol.ModuleSystem.Name(Name)
import Cryptol.Utils.Ident(Ident)
cleanupErrors :: [(Range,Error)] -> [(Range,Error)]
cleanupErrors = dropErrorsFromSameLoc
. sortBy (compare `on` (cmpR . fst)) -- order errors
. dropSumbsumed
where
-- pick shortest error from each location.
dropErrorsFromSameLoc = map chooseBestError
. groupBy ((==) `on` fst)
addErrorSize (r,e) = (length (show (pp e)), (r,e))
chooseBestError = snd . minimumBy (compare `on` fst) . map addErrorSize
cmpR r = ( source r -- Frist by file
, from r -- Then starting position
, to r -- Finally end position
)
dropSumbsumed xs =
case xs of
(r,e) : rest -> (r,e) :
dropSumbsumed (filter (not .subsumes e . snd) rest)
[] -> []
-- | Should the first error suppress the next one.
subsumes :: Error -> Error -> Bool
subsumes (NotForAll x _) (NotForAll y _) = x == y
subsumes _ _ = False
data Warning = DefaultingKind (P.TParam Name) P.Kind
| DefaultingWildType P.Kind
| DefaultingTo TVarInfo Type
deriving (Show, Generic, NFData)
-- | Various errors that might happen during type checking/inference
data Error = ErrorMsg Doc
-- ^ Just say this
| KindMismatch Kind Kind
-- ^ Expected kind, inferred kind
| TooManyTypeParams Int Kind
-- ^ Number of extra parameters, kind of result
-- (which should not be of the form @_ -> _@)
| TyVarWithParams
-- ^ A type variable was applied to some arguments.
| TooManyTySynParams Name Int
-- ^ Type-synonym, number of extra params
| TooFewTyParams Name Int
-- ^ Who is missing params, number of missing params
| RecursiveTypeDecls [Name]
-- ^ The type synonym declarations are recursive
| TypeMismatch Type Type
-- ^ Expected type, inferred type
| RecursiveType Type Type
-- ^ Unification results in a recursive type
| UnsolvedGoals Bool [Goal]
-- ^ A constraint that we could not solve
-- The boolean indicates if we know that this constraint
-- is impossible.
| UnsolvedDelayedCt DelayedCt
-- ^ A constraint (with context) that we could not solve
| UnexpectedTypeWildCard
-- ^ Type wild cards are not allowed in this context
-- (e.g., definitions of type synonyms).
| TypeVariableEscaped Type [TParam]
-- ^ Unification variable depends on quantified variables
-- that are not in scope.
| NotForAll TVar Type
-- ^ Quantified type variables (of kind *) need to
-- match the given type, so it does not work for all types.
| TooManyPositionalTypeParams
-- ^ Too many positional type arguments, in an explicit
-- type instantiation
| CannotMixPositionalAndNamedTypeParams
| UndefinedTypeParameter (Located Ident)
| RepeatedTypeParameter Ident [Range]
deriving (Show, Generic, NFData)
instance TVars Warning where
apSubst su warn =
case warn of
DefaultingKind {} -> warn
DefaultingWildType {} -> warn
DefaultingTo d ty -> DefaultingTo d (apSubst su ty)
instance FVS Warning where
fvs warn =
case warn of
DefaultingKind {} -> Set.empty
DefaultingWildType {} -> Set.empty
DefaultingTo _ ty -> fvs ty
instance TVars Error where
apSubst su err =
case err of
ErrorMsg _ -> err
KindMismatch {} -> err
TooManyTypeParams {} -> err
TyVarWithParams -> err
TooManyTySynParams {} -> err
TooFewTyParams {} -> err
RecursiveTypeDecls {} -> err
TypeMismatch t1 t2 -> TypeMismatch (apSubst su t1) (apSubst su t2)
RecursiveType t1 t2 -> RecursiveType (apSubst su t1) (apSubst su t2)
UnsolvedGoals x gs -> UnsolvedGoals x (apSubst su gs)
UnsolvedDelayedCt g -> UnsolvedDelayedCt (apSubst su g)
UnexpectedTypeWildCard -> err
TypeVariableEscaped t xs -> TypeVariableEscaped (apSubst su t) xs
NotForAll x t -> NotForAll x (apSubst su t)
TooManyPositionalTypeParams -> err
CannotMixPositionalAndNamedTypeParams -> err
UndefinedTypeParameter {} -> err
RepeatedTypeParameter {} -> err
instance FVS Error where
fvs err =
case err of
ErrorMsg {} -> Set.empty
KindMismatch {} -> Set.empty
TooManyTypeParams {} -> Set.empty
TyVarWithParams -> Set.empty
TooManyTySynParams {} -> Set.empty
TooFewTyParams {} -> Set.empty
RecursiveTypeDecls {} -> Set.empty
TypeMismatch t1 t2 -> fvs (t1,t2)
RecursiveType t1 t2 -> fvs (t1,t2)
UnsolvedGoals _ gs -> fvs gs
UnsolvedDelayedCt g -> fvs g
UnexpectedTypeWildCard -> Set.empty
TypeVariableEscaped t xs -> fvs t `Set.union`
Set.fromList (map TVBound xs)
NotForAll x t -> Set.insert x (fvs t)
TooManyPositionalTypeParams -> Set.empty
CannotMixPositionalAndNamedTypeParams -> Set.empty
UndefinedTypeParameter {} -> Set.empty
RepeatedTypeParameter {} -> Set.empty
instance PP Warning where
ppPrec = ppWithNamesPrec IntMap.empty
instance PP Error where
ppPrec = ppWithNamesPrec IntMap.empty
instance PP (WithNames Warning) where
ppPrec _ (WithNames warn names) =
addTVarsDescsAfter names warn $
case warn of
DefaultingKind x k ->
text "Assuming " <+> pp x <+> text "to have" <+> P.cppKind k
DefaultingWildType k ->
text "Assuming _ to have" <+> P.cppKind k
DefaultingTo d ty ->
text "Defaulting" <+> pp (tvarDesc d) <+> text "to"
<+> ppWithNames names ty
instance PP (WithNames Error) where
ppPrec _ (WithNames err names) =
case err of
ErrorMsg msg ->
addTVarsDescsAfter names err
msg
RecursiveType t1 t2 ->
addTVarsDescsAfter names err $
nested "Matching would result in an infinite type."
("The type: " <+> ppWithNames names t1 $$
"occurs in:" <+> ppWithNames names t2)
UnexpectedTypeWildCard ->
addTVarsDescsAfter names err $
nested "Wild card types are not allowed in this context"
"(e.g., they cannot be used in type synonyms)."
KindMismatch k1 k2 ->
addTVarsDescsAfter names err $
nested "Incorrect type form."
("Expected:" <+> cppKind k1 $$
"Inferred:" <+> cppKind k2)
TooManyTypeParams extra k ->
addTVarsDescsAfter names err $
nested "Malformed type."
("Kind" <+> quotes (pp k) <+> "is not a function," $$
"but it was applied to" <+> pl extra "parameter" <.> ".")
TyVarWithParams ->
addTVarsDescsAfter names err $
nested "Malformed type."
"Type variables cannot be applied to parameters."
TooManyTySynParams t extra ->
addTVarsDescsAfter names err $
nested "Malformed type."
("Type synonym" <+> nm t <+> "was applied to" <+>
pl extra "extra parameters" <.> text ".")
TooFewTyParams t few ->
addTVarsDescsAfter names err $
nested "Malformed type."
("Type" <+> nm t <+> "is missing" <+> int few <+> text "parameters.")
RecursiveTypeDecls ts ->
addTVarsDescsAfter names err $
nested "Recursive type declarations:"
(fsep $ punctuate comma $ map nm ts)
TypeMismatch t1 t2 ->
addTVarsDescsAfter names err $
nested "Type mismatch:"
("Expected type:" <+> ppWithNames names t1 $$
"Inferred type:" <+> ppWithNames names t2 $$
mismatchHint t1 t2)
UnsolvedGoals imp gs
| imp ->
addTVarsDescsAfter names err $
nested "Unsolvable constraints:" $
bullets (map (ppWithNames names) gs)
| noUni ->
addTVarsDescsAfter names err $
nested "Unsolved constraints:" $
bullets (map (ppWithNames names) gs)
| otherwise ->
addTVarsDescsBefore names err $
nested "subject to the following constraints:" $
bullets (map (ppWithNames names) gs)
UnsolvedDelayedCt g
| noUni ->
addTVarsDescsAfter names err $
nested "Failed to validate user-specified signature." $
ppWithNames names g
| otherwise ->
addTVarsDescsBefore names err $
nested "while validating user-specified signature" $
ppWithNames names g
TypeVariableEscaped t xs ->
addTVarsDescsAfter names err $
nested ("The type" <+> ppWithNames names t <+>
"is not sufficiently polymorphic.")
("It cannot depend on quantified variables:" <+>
sep (punctuate comma (map (ppWithNames names) xs)))
NotForAll x t ->
addTVarsDescsAfter names err $
nested "Inferred type is not sufficiently polymorphic."
("Quantified variable:" <+> ppWithNames names x $$
"cannot match type:" <+> ppWithNames names t)
TooManyPositionalTypeParams ->
addTVarsDescsAfter names err $
"Too many positional type-parameters in explicit type application"
CannotMixPositionalAndNamedTypeParams ->
addTVarsDescsAfter names err $
"Named and positional type applications may not be mixed."
UndefinedTypeParameter x ->
addTVarsDescsAfter names err $
"Undefined type parameter `" <.> pp (thing x) <.> "`."
$$ "See" <+> pp (srcRange x)
RepeatedTypeParameter x rs ->
addTVarsDescsAfter names err $
"Multiple definitions for type parameter `" <.> pp x <.> "`:"
$$ nest 2 (bullets (map pp rs))
where
bullets xs = vcat [ "•" <+> d | d <- xs ]
nested x y = x $$ nest 2 y
pl 1 x = text "1" <+> text x
pl n x = text (show n) <+> text x <.> text "s"
nm x = text "`" <.> pp x <.> text "`"
mismatchHint (TRec fs1) (TRec fs2) =
hint "Missing" missing $$ hint "Unexpected" extra
where
missing = map fst fs1 \\ map fst fs2
extra = map fst fs2 \\ map fst fs1
hint _ [] = mempty
hint s [x] = text s <+> text "field" <+> pp x
hint s xs = text s <+> text "fields" <+> commaSep (map pp xs)
mismatchHint _ _ = mempty
noUni = Set.null (Set.filter isFreeTV (fvs err))
cryptol-2.8.0/src/Cryptol/TypeCheck/Infer.hs 0000644 0000000 0000000 00000100200 07346545000 017100 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Infer
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- Assumes that the `NoPat` pass has been run.
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
module Cryptol.TypeCheck.Infer
( checkE
, checkSigB
, inferModule
, inferBinds
, inferDs
)
where
import Cryptol.ModuleSystem.Name (asPrim,lookupPrimDecl,nameLoc)
import Cryptol.Parser.Position
import qualified Cryptol.Parser.AST as P
import qualified Cryptol.ModuleSystem.Exports as P
import Cryptol.TypeCheck.AST hiding (tSub,tMul,tExp)
import Cryptol.TypeCheck.Monad
import Cryptol.TypeCheck.Error
import Cryptol.TypeCheck.Solve
import Cryptol.TypeCheck.SimpType(tMul)
import Cryptol.TypeCheck.Kind(checkType,checkSchema,checkTySyn,
checkPropSyn,checkNewtype,
checkParameterType,
checkPrimType,
checkParameterConstraints)
import Cryptol.TypeCheck.Instantiate
import Cryptol.TypeCheck.Depends
import Cryptol.TypeCheck.Subst (listSubst,apSubst,(@@),isEmptySubst)
import Cryptol.TypeCheck.Solver.InfNat(genLog)
import Cryptol.Utils.Ident
import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.PP
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.List(foldl',sortBy)
import Data.Either(partitionEithers)
import Data.Maybe(mapMaybe,isJust, fromMaybe)
import Data.List(partition,find)
import Data.Graph(SCC(..))
import Data.Traversable(forM)
import Control.Monad(zipWithM,unless,foldM)
inferModule :: P.Module Name -> InferM Module
inferModule m =
inferDs (P.mDecls m) $ \ds1 ->
do proveModuleTopLevel
ts <- getTSyns
nts <- getNewtypes
ats <- getAbstractTypes
pTs <- getParamTypes
pCs <- getParamConstraints
pFuns <- getParamFuns
return Module { mName = thing (P.mName m)
, mExports = P.modExports m
, mImports = map thing (P.mImports m)
, mTySyns = Map.mapMaybe onlyLocal ts
, mNewtypes = Map.mapMaybe onlyLocal nts
, mPrimTypes = Map.mapMaybe onlyLocal ats
, mParamTypes = pTs
, mParamConstraints = pCs
, mParamFuns = pFuns
, mDecls = ds1
}
where
onlyLocal (IsLocal, x) = Just x
onlyLocal (IsExternal, _) = Nothing
-- | Construct a primitive in the parsed AST.
mkPrim :: String -> InferM (P.Expr Name)
mkPrim str =
do nm <- mkPrim' str
return (P.EVar nm)
-- | Construct a primitive in the parsed AST.
mkPrim' :: String -> InferM Name
mkPrim' str =
do prims <- getPrimMap
return (lookupPrimDecl (packIdent str) prims)
desugarLiteral :: Bool -> P.Literal -> InferM (P.Expr Name)
desugarLiteral fixDec lit =
do l <- curRange
numberPrim <- mkPrim "number"
let named (x,y) = P.NamedInst
P.Named { name = Located l (packIdent x), value = y }
number fs = P.EAppT numberPrim (map named fs)
tBits n = P.TSeq (P.TNum n) P.TBit
return $ case lit of
P.ECNum num info ->
number $ [ ("val", P.TNum num) ] ++ case info of
P.BinLit n -> [ ("rep", tBits (1 * toInteger n)) ]
P.OctLit n -> [ ("rep", tBits (3 * toInteger n)) ]
P.HexLit n -> [ ("rep", tBits (4 * toInteger n)) ]
P.CharLit -> [ ("rep", tBits (8 :: Integer)) ]
P.DecLit
| fixDec -> if num == 0
then [ ("rep", tBits 0)]
else case genLog num 2 of
Just (x,_) -> [ ("rep", tBits (x + 1)) ]
_ -> []
| otherwise -> [ ]
P.PolyLit _n -> [ ("rep", P.TSeq P.TWild P.TBit) ]
P.ECString s ->
P.ETyped (P.EList [ P.ELit (P.ECNum (toInteger (fromEnum c))
P.CharLit) | c <- s ])
(P.TSeq P.TWild (P.TSeq (P.TNum 8) P.TBit))
-- | Infer the type of an expression with an explicit instantiation.
appTys :: P.Expr Name -> [TypeArg] -> Type -> InferM Expr
appTys expr ts tGoal =
case expr of
P.EVar x ->
do res <- lookupVar x
(e',t) <- case res of
ExtVar s -> instantiateWith x (EVar x) s ts
CurSCC e t -> do checkNoParams ts
return (e,t)
checkHasType t tGoal
return e'
P.ELit l -> do e <- desugarLiteral False l
appTys e ts tGoal
P.EAppT e fs -> appTys e (map uncheckedTypeArg fs ++ ts) tGoal
-- Here is an example of why this might be useful:
-- f ` { x = T } where type T = ...
P.EWhere e ds ->
inferDs ds $ \ds1 -> do e1 <- appTys e ts tGoal
return (EWhere e1 ds1)
-- XXX: Is there a scoping issue here? I think not, but check.
P.ELocated e r ->
inRange r (appTys e ts tGoal)
P.ENeg {} -> mono
P.EComplement {} -> mono
P.EGenerate {} -> mono
P.ETuple {} -> mono
P.ERecord {} -> mono
P.EUpd {} -> mono
P.ESel {} -> mono
P.EList {} -> mono
P.EFromTo {} -> mono
P.EInfFrom {} -> mono
P.EComp {} -> mono
P.EApp {} -> mono
P.EIf {} -> mono
P.ETyped {} -> mono
P.ETypeVal {} -> mono
P.EFun {} -> mono
P.ESplit {} -> mono
P.EParens e -> appTys e ts tGoal
P.EInfix a op _ b -> appTys (P.EVar (thing op) `P.EApp` a `P.EApp` b) ts tGoal
where mono = do e' <- checkE expr tGoal
checkNoParams ts
return e'
checkNoParams :: [TypeArg] -> InferM ()
checkNoParams ts =
case pos of
p : _ -> do r <- case tyArgType p of
Unchecked t | Just r <- getLoc t -> pure r
_ -> curRange
inRange r (recordError TooManyPositionalTypeParams)
_ -> mapM_ badNamed named
where
badNamed l =
case tyArgName l of
Just i -> recordError (UndefinedTypeParameter i)
Nothing -> return ()
(named,pos) = partition (isJust . tyArgName) ts
checkTypeOfKind :: P.Type Name -> Kind -> InferM Type
checkTypeOfKind ty k = checkType ty (Just k)
-- | Infer the type of an expression, and translate it to a fully elaborated
-- core term.
checkE :: P.Expr Name -> Type -> InferM Expr
checkE expr tGoal =
case expr of
P.EVar x ->
do res <- lookupVar x
(e',t) <- case res of
ExtVar s -> instantiateWith x (EVar x) s []
CurSCC e t -> return (e, t)
checkHasType t tGoal
return e'
P.ENeg e ->
do prim <- mkPrim "negate"
checkE (P.EApp prim e) tGoal
P.EComplement e ->
do prim <- mkPrim "complement"
checkE (P.EApp prim e) tGoal
P.EGenerate e ->
do prim <- mkPrim "generate"
checkE (P.EApp prim e) tGoal
P.ELit l@(P.ECNum _ P.DecLit) ->
do e <- desugarLiteral False l
-- NOTE: When 'l' is a decimal literal, 'desugarLiteral' does
-- not generate an instantiation for the 'rep' type argument
-- of the 'number' primitive. Therefore we explicitly
-- instantiate 'rep' to 'tGoal' in this case to avoid
-- generating an unnecessary unification variable.
loc <- curRange
let arg = TypeArg { tyArgName = Just (Located loc (packIdent "rep"))
, tyArgType = Checked tGoal
}
appTys e [arg] tGoal
P.ELit l -> (`checkE` tGoal) =<< desugarLiteral False l
P.ETuple es ->
do etys <- expectTuple (length es) tGoal
es' <- zipWithM checkE es etys
return (ETuple es')
P.ERecord fs ->
do (ns,es,ts) <- unzip3 `fmap` expectRec fs tGoal
es' <- zipWithM checkE es ts
return (ERec (zip ns es'))
P.EUpd x fs -> checkRecUpd x fs tGoal
P.ESel e l ->
do t <- newType (selSrc l) KType
e' <- checkE e t
f <- newHasGoal l t tGoal
return (hasDoSelect f e')
P.EList [] ->
do (len,a) <- expectSeq tGoal
expectFin 0 len
return (EList [] a)
P.EList es ->
do (len,a) <- expectSeq tGoal
expectFin (length es) len
es' <- mapM (`checkE` a) es
return (EList es' a)
P.EFromTo t1 mbt2 t3 mety ->
do l <- curRange
let fs0 =
case mety of
Just ety -> [("a", ety)]
Nothing -> []
let (c,fs) =
case mbt2 of
Nothing ->
("fromTo", ("last", t3) : fs0)
Just t2 ->
("fromThenTo", ("next",t2) : ("last",t3) : fs0)
prim <- mkPrim c
let e' = P.EAppT prim
[ P.NamedInst P.Named { name = Located l (packIdent x), value = y }
| (x,y) <- ("first",t1) : fs
]
checkE e' tGoal
P.EInfFrom e1 Nothing ->
do prim <- mkPrim "infFrom"
checkE (P.EApp prim e1) tGoal
P.EInfFrom e1 (Just e2) ->
do prim <- mkPrim "infFromThen"
checkE (P.EApp (P.EApp prim e1) e2) tGoal
P.EComp e mss ->
do (mss', dss, ts) <- unzip3 `fmap` zipWithM inferCArm [ 1 .. ] mss
(len,a) <- expectSeq tGoal
newGoals CtComprehension =<< unify len =<< smallest ts
ds <- combineMaps dss
e' <- withMonoTypes ds (checkE e a)
return (EComp len a e' mss')
P.EAppT e fs -> appTys e (map uncheckedTypeArg fs) tGoal
P.EApp fun@(dropLoc -> P.EApp (dropLoc -> P.EVar c) _)
arg@(dropLoc -> P.ELit l)
| Just n <- asPrim c
, n `elem` map packIdent [ "<<", ">>", "<<<", ">>>" , "@", "!" ] ->
do newArg <- do l1 <- desugarLiteral True l
return $ case arg of
P.ELocated _ pos -> P.ELocated l1 pos
_ -> l1
checkE (P.EApp fun newArg) tGoal
P.EApp e1 e2 ->
do t1 <- newType (TypeOfArg Nothing) KType
e1' <- checkE e1 (tFun t1 tGoal)
e2' <- checkE e2 t1
return (EApp e1' e2')
P.EIf e1 e2 e3 ->
do e1' <- checkE e1 tBit
e2' <- checkE e2 tGoal
e3' <- checkE e3 tGoal
return (EIf e1' e2' e3')
P.EWhere e ds ->
inferDs ds $ \ds1 -> do e1 <- checkE e tGoal
return (EWhere e1 ds1)
P.ETyped e t ->
do tSig <- checkTypeOfKind t KType
e' <- checkE e tSig
checkHasType tSig tGoal
return e'
P.ETypeVal t ->
do l <- curRange
prim <- mkPrim "number"
checkE (P.EAppT prim
[P.NamedInst
P.Named { name = Located l (packIdent "val")
, value = t }]) tGoal
P.EFun ps e -> checkFun (text "anonymous function") ps e tGoal
P.ELocated e r -> inRange r (checkE e tGoal)
P.ESplit e ->
do prim <- mkPrim "splitAt"
checkE (P.EApp prim e) tGoal
P.EInfix a op _ b -> checkE (P.EVar (thing op) `P.EApp` a `P.EApp` b) tGoal
P.EParens e -> checkE e tGoal
selSrc :: P.Selector -> TVarSource
selSrc l = case l of
RecordSel la _ -> TypeOfRecordField la
TupleSel n _ -> TypeOfTupleField n
ListSel _ _ -> TypeOfSeqElement
checkRecUpd :: Maybe (P.Expr Name) -> [ P.UpdField Name ] -> Type -> InferM Expr
checkRecUpd mb fs tGoal =
case mb of
-- { _ | fs } ~~> \r -> { r | fs }
Nothing ->
do r <- newParamName (packIdent "r")
let p = P.PVar Located { srcRange = nameLoc r, thing = r }
fe = P.EFun [p] (P.EUpd (Just (P.EVar r)) fs)
checkE fe tGoal
Just e ->
do e1 <- checkE e tGoal
foldM doUpd e1 fs
where
doUpd e (P.UpdField how sels v) =
case sels of
[l] ->
case how of
P.UpdSet ->
do ft <- newType (selSrc s) KType
v1 <- checkE v ft
d <- newHasGoal s tGoal ft
pure (hasDoSet d e v1)
P.UpdFun ->
do ft <- newType (selSrc s) KType
v1 <- checkE v (tFun ft ft)
d <- newHasGoal s tGoal ft
tmp <- newParamName (packIdent "rf")
let e' = EVar tmp
pure $ hasDoSet d e' (EApp v1 (hasDoSelect d e'))
`EWhere`
[ NonRecursive
Decl { dName = tmp
, dSignature = tMono tGoal
, dDefinition = DExpr e
, dPragmas = []
, dInfix = False
, dFixity = Nothing
, dDoc = Nothing
} ]
where s = thing l
_ -> panic "checkRecUpd/doUpd" [ "Expected exactly 1 field label"
, "Got: " ++ show (length sels)
]
expectSeq :: Type -> InferM (Type,Type)
expectSeq ty =
case ty of
TUser _ _ ty' ->
expectSeq ty'
TCon (TC TCSeq) [a,b] ->
return (a,b)
TVar _ ->
do tys@(a,b) <- genTys
newGoals CtExactType =<< unify ty (tSeq a b)
return tys
_ ->
do tys@(a,b) <- genTys
recordError (TypeMismatch ty (tSeq a b))
return tys
where
genTys =
do a <- newType LenOfSeq KNum
b <- newType TypeOfSeqElement KType
return (a,b)
expectTuple :: Int -> Type -> InferM [Type]
expectTuple n ty =
case ty of
TUser _ _ ty' ->
expectTuple n ty'
TCon (TC (TCTuple n')) tys | n == n' ->
return tys
TVar _ ->
do tys <- genTys
newGoals CtExactType =<< unify ty (tTuple tys)
return tys
_ ->
do tys <- genTys
recordError (TypeMismatch ty (tTuple tys))
return tys
where
genTys =forM [ 0 .. n - 1 ] $ \ i -> newType (TypeOfTupleField i) KType
expectRec :: [P.Named a] -> Type -> InferM [(Ident,a,Type)]
expectRec fs ty =
case ty of
TUser _ _ ty' ->
expectRec fs ty'
TRec ls | Just tys <- mapM checkField ls ->
return tys
_ ->
do (tys,res) <- genTys
case ty of
TVar TVFree{} -> do ps <- unify ty (TRec tys)
newGoals CtExactType ps
_ -> recordError (TypeMismatch ty (TRec tys))
return res
where
checkField (n,t) =
do f <- find (\f -> thing (P.name f) == n) fs
return (thing (P.name f), P.value f, t)
genTys =
do res <- forM fs $ \ f ->
do let field = thing (P.name f)
t <- newType (TypeOfRecordField field) KType
return (field, P.value f, t)
let (ls,_,ts) = unzip3 res
return (zip ls ts, res)
expectFin :: Int -> Type -> InferM ()
expectFin n ty =
case ty of
TUser _ _ ty' ->
expectFin n ty'
TCon (TC (TCNum n')) [] | toInteger n == n' ->
return ()
_ ->
do newGoals CtExactType =<< unify ty (tNum n)
expectFun :: Int -> Type -> InferM ([Type],Type)
expectFun = go []
where
go tys arity ty
| arity > 0 =
case ty of
TUser _ _ ty' ->
go tys arity ty'
TCon (TC TCFun) [a,b] ->
go (a:tys) (arity - 1) b
_ ->
do args <- genArgs arity
res <- newType TypeOfRes KType
case ty of
TVar TVFree{} -> do ps <- unify ty (foldr tFun res args)
newGoals CtExactType ps
_ -> recordError (TypeMismatch ty (foldr tFun res args))
return (reverse tys ++ args, res)
| otherwise =
return (reverse tys, ty)
genArgs arity = forM [ 1 .. arity ] $
\ ix -> newType (TypeOfArg (Just ix)) KType
checkHasType :: Type -> Type -> InferM ()
checkHasType inferredType givenType =
do ps <- unify givenType inferredType
case ps of
[] -> return ()
_ -> newGoals CtExactType ps
checkFun :: Doc -> [P.Pattern Name] -> P.Expr Name -> Type -> InferM Expr
checkFun _ [] e tGoal = checkE e tGoal
checkFun desc ps e tGoal =
inNewScope $
do let descs = [ text "type of" <+> ordinal n <+> text "argument"
<+> text "of" <+> desc | n <- [ 1 :: Int .. ] ]
(tys,tRes) <- expectFun (length ps) tGoal
largs <- sequence (zipWith3 checkP descs ps tys)
let ds = Map.fromList [ (thing x, x { thing = t }) | (x,t) <- zip largs tys ]
e1 <- withMonoTypes ds (checkE e tRes)
let args = [ (thing x, t) | (x,t) <- zip largs tys ]
return (foldr (\(x,t) b -> EAbs x t b) e1 args)
{-| The type the is the smallest of all -}
smallest :: [Type] -> InferM Type
smallest [] = newType LenOfSeq KNum
smallest [t] = return t
smallest ts = do a <- newType LenOfSeq KNum
newGoals CtComprehension [ a =#= foldr1 tMin ts ]
return a
checkP :: Doc -> P.Pattern Name -> Type -> InferM (Located Name)
checkP desc p tGoal =
do (x, t) <- inferP desc p
ps <- unify tGoal (thing t)
let rng = fromMaybe emptyRange $ getLoc p
let mkErr = recordError . UnsolvedGoals False . (:[])
. Goal (CtPattern desc) rng
mapM_ mkErr ps
return (Located (srcRange t) x)
{-| Infer the type of a pattern. Assumes that the pattern will be just
a variable. -}
inferP :: Doc -> P.Pattern Name -> InferM (Name, Located Type)
inferP desc pat =
case pat of
P.PVar x0 ->
do a <- inRange (srcRange x0) (newType (DefinitionOf (thing x0)) KType)
return (thing x0, x0 { thing = a })
P.PTyped p t ->
do tSig <- checkTypeOfKind t KType
ln <- checkP desc p tSig
return (thing ln, ln { thing = tSig })
_ -> tcPanic "inferP" [ "Unexpected pattern:", show pat ]
-- | Infer the type of one match in a list comprehension.
inferMatch :: P.Match Name -> InferM (Match, Name, Located Type, Type)
inferMatch (P.Match p e) =
do (x,t) <- inferP (text "a value bound by a generator in a comprehension") p
n <- newType LenOfCompGen KNum
e' <- checkE e (tSeq n (thing t))
return (From x n (thing t) e', x, t, n)
inferMatch (P.MatchLet b)
| P.bMono b =
do let rng = srcRange (P.bName b)
a <- inRange rng (newType (DefinitionOf (thing (P.bName b))) KType)
b1 <- checkMonoB b a
return (Let b1, dName b1, Located (srcRange (P.bName b)) a, tNum (1::Int))
| otherwise = tcPanic "inferMatch"
[ "Unexpected polymorphic match let:", show b ]
-- | Infer the type of one arm of a list comprehension.
inferCArm :: Int -> [P.Match Name] -> InferM
( [Match]
, Map Name (Located Type)-- defined vars
, Type -- length of sequence
)
inferCArm _ [] = panic "inferCArm" [ "Empty comprehension arm" ]
inferCArm _ [m] =
do (m1, x, t, n) <- inferMatch m
return ([m1], Map.singleton x t, n)
inferCArm armNum (m : ms) =
do (m1, x, t, n) <- inferMatch m
(ms', ds, n') <- withMonoType (x,t) (inferCArm armNum ms)
newGoals CtComprehension [ pFin n' ]
return (m1 : ms', Map.insertWith (\_ old -> old) x t ds, tMul n n')
-- | @inferBinds isTopLevel isRec binds@ performs inference for a
-- strongly-connected component of 'P.Bind's.
-- If any of the members of the recursive group are already marked
-- as monomorphic, then we don't do generalzation.
-- If @isTopLevel@ is true,
-- any bindings without type signatures will be generalized. If it is
-- false, and the mono-binds flag is enabled, no bindings without type
-- signatures will be generalized, but bindings with signatures will
-- be unaffected.
inferBinds :: Bool -> Bool -> [P.Bind Name] -> InferM [Decl]
inferBinds isTopLevel isRec binds =
do -- when mono-binds is enabled, and we're not checking top-level
-- declarations, mark all bindings lacking signatures as monomorphic
monoBinds <- getMonoBinds
let (sigs,noSigs) = partition (isJust . P.bSignature) binds
monos = sigs ++ [ b { P.bMono = True } | b <- noSigs ]
binds' | any P.bMono binds = monos
| monoBinds && not isTopLevel = monos
| otherwise = binds
check exprMap =
{- Guess type is here, because while we check user supplied signatures
we may generate additional constraints. For example, `x - y` would
generate an additional constraint `x >= y`. -}
do (newEnv,todos) <- unzip `fmap` mapM (guessType exprMap) binds'
let otherEnv = filter isExt newEnv
let (sigsAndMonos,noSigGen) = partitionEithers todos
let prepGen = collectGoals
$ do bs <- sequence noSigGen
simplifyAllConstraints
return bs
if isRec
then
-- First we check the bindings with no signatures
-- that need to be generalized.
do (bs1,cs) <- withVarTypes newEnv prepGen
-- We add these to the environment, so their fvs are
-- not generalized.
genCs <- withVarTypes otherEnv (generalize bs1 cs)
-- Then we do all the rest,
-- using the newly inferred poly types.
let newEnv' = map toExt bs1 ++ otherEnv
done <- withVarTypes newEnv' (sequence sigsAndMonos)
return (done,genCs)
else
do done <- sequence sigsAndMonos
(bs1, cs) <- prepGen
genCs <- generalize bs1 cs
return (done,genCs)
rec
let exprMap = Map.fromList (map monoUse genBs)
(doneBs, genBs) <- check exprMap
simplifyAllConstraints
return (doneBs ++ genBs)
where
toExt d = (dName d, ExtVar (dSignature d))
isExt (_,y) = case y of
ExtVar _ -> True
_ -> False
monoUse d = (x, withQs)
where
x = dName d
as = sVars (dSignature d)
qs = sProps (dSignature d)
appT e a = ETApp e (TVar (tpVar a))
appP e _ = EProofApp e
withTys = foldl' appT (EVar x) as
withQs = foldl' appP withTys qs
{- | Come up with a type for recursive calls to a function, and decide
how we are going to be checking the binding.
Returns: (Name, type or schema, computation to check binding)
The `exprMap` is a thunk where we can lookup the final expressions
and we should be careful not to force it.
-}
guessType :: Map Name Expr -> P.Bind Name ->
InferM ( (Name, VarType)
, Either (InferM Decl) -- no generalization
(InferM Decl) -- generalize these
)
guessType exprMap b@(P.Bind { .. }) =
case bSignature of
Just s ->
do s1 <- checkSchema AllowWildCards s
return ((name, ExtVar (fst s1)), Left (checkSigB b s1))
Nothing
| bMono ->
do t <- newType (DefinitionOf name) KType
let schema = Forall [] [] t
return ((name, ExtVar schema), Left (checkMonoB b t))
| otherwise ->
do t <- newType (DefinitionOf name) KType
let noWay = tcPanic "guessType" [ "Missing expression for:" ,
show name ]
expr = Map.findWithDefault noWay name exprMap
return ((name, CurSCC expr t), Right (checkMonoB b t))
where
name = thing bName
{- | The inputs should be declarations with monomorphic types
(i.e., of the form `Forall [] [] t`). -}
generalize :: [Decl] -> [Goal] -> InferM [Decl]
{- This may happen because we have monomorphic bindings.
In this case we may get some goal, due to the monomorphic bindings,
but the group of components is empty. -}
generalize [] gs0 =
do addGoals gs0
return []
generalize bs0 gs0 =
do {- First, we apply the accumulating substitution to the goals
and the inferred types, to ensure that we have the most up
to date information. -}
gs <- applySubstGoals gs0
bs <- forM bs0 $ \b -> do s <- applySubst (dSignature b)
return b { dSignature = s }
-- Next, we figure out which of the free variables need to be generalized
-- Variables apearing in the types of monomorphic bindings should
-- not be generalizedr.
let goalFVS g = Set.filter isFreeTV $ fvs $ goal g
inGoals = Set.unions $ map goalFVS gs
inSigs = Set.filter isFreeTV $ fvs $ map dSignature bs
candidates = (Set.union inGoals inSigs)
asmpVs <- varsWithAsmps
let gen0 = Set.difference candidates asmpVs
stays g = any (`Set.member` gen0) $ Set.toList $ goalFVS g
(here0,later) = partition stays gs
addGoals later -- these ones we keep around for to solve later
let maybeAmbig = Set.toList (Set.difference gen0 inSigs)
{- See if we might be able to default some of the potentially ambiguous
variables using the constraints that will be part of the newly
generalized schema. -}
let (as0,here1,defSu,ws) = defaultAndSimplify maybeAmbig here0
extendSubst defSu
mapM_ recordWarning ws
let here = map goal here1
{- This is the variables we'll be generalizing:
* any ones that survived the defaulting
* and vars in the inferred types that do not appear anywhere else. -}
let as = sortBy numFst
$ as0 ++ Set.toList (Set.difference inSigs asmpVs)
asPs = [ TParam { tpUnique = x, tpKind = k, tpFlav = TPOther Nothing
, tpInfo = i } | TVFree x k _ i <- as ]
{- Finally, we replace free variables with bound ones, and fix-up
the definitions as needed to reflect that we are now working
with polymorphic things. For example, apply each occurrence to the
type parameters. -}
totSu <- getSubst
let
su = listSubst (zip as (map (TVar . tpVar) asPs)) @@ totSu
qs = concatMap (pSplitAnd . apSubst su) here
genE e = foldr ETAbs (foldr EProofAbs (apSubst su e) qs) asPs
genB d = d { dDefinition = case dDefinition d of
DExpr e -> DExpr (genE e)
DPrim -> DPrim
, dSignature = Forall asPs qs
$ apSubst su $ sType $ dSignature d
}
return (map genB bs)
where
numFst x y = case (kindOf x, kindOf y) of
(KNum, KNum) -> EQ
(KNum, _) -> LT
(_,KNum) -> GT
_ -> EQ
-- | Check a monomorphic binding.
checkMonoB :: P.Bind Name -> Type -> InferM Decl
checkMonoB b t =
inRangeMb (getLoc b) $
case thing (P.bDef b) of
P.DPrim -> panic "checkMonoB" ["Primitive with no signature?"]
P.DExpr e ->
do e1 <- checkFun (pp (thing (P.bName b))) (P.bParams b) e t
let f = thing (P.bName b)
return Decl { dName = f
, dSignature = Forall [] [] t
, dDefinition = DExpr e1
, dPragmas = P.bPragmas b
, dInfix = P.bInfix b
, dFixity = P.bFixity b
, dDoc = P.bDoc b
}
-- XXX: Do we really need to do the defaulting business in two different places?
checkSigB :: P.Bind Name -> (Schema,[Goal]) -> InferM Decl
checkSigB b (Forall as asmps0 t0, validSchema) = case thing (P.bDef b) of
-- XXX what should we do with validSchema in this case?
P.DPrim ->
do return Decl { dName = thing (P.bName b)
, dSignature = Forall as asmps0 t0
, dDefinition = DPrim
, dPragmas = P.bPragmas b
, dInfix = P.bInfix b
, dFixity = P.bFixity b
, dDoc = P.bDoc b
}
P.DExpr e0 ->
inRangeMb (getLoc b) $
withTParams as $
do (e1,cs0) <- collectGoals $
do e1 <- checkFun (pp (thing (P.bName b))) (P.bParams b) e0 t0
addGoals validSchema
() <- simplifyAllConstraints -- XXX: using `asmps` also?
return e1
cs <- applySubstGoals cs0
let findKeep vs keep todo =
let stays (_,cvs) = not $ Set.null $ Set.intersection vs cvs
(yes,perhaps) = partition stays todo
(stayPs,newVars) = unzip yes
in case stayPs of
[] -> (keep,map fst todo)
_ -> findKeep (Set.unions (vs:newVars)) (stayPs ++ keep) perhaps
let (stay,leave) = findKeep (Set.fromList (map tpVar as)) []
[ (c, fvs c) | c <- cs ]
addGoals leave
asmps1 <- applySubstPreds asmps0
su <- proveImplication (Just (thing (P.bName b))) as asmps1 stay
extendSubst su
let asmps = concatMap pSplitAnd (apSubst su asmps1)
t <- applySubst t0
e2 <- applySubst e1
return Decl
{ dName = thing (P.bName b)
, dSignature = Forall as asmps t
, dDefinition = DExpr (foldr ETAbs (foldr EProofAbs e2 asmps) as)
, dPragmas = P.bPragmas b
, dInfix = P.bInfix b
, dFixity = P.bFixity b
, dDoc = P.bDoc b
}
inferDs :: FromDecl d => [d] -> ([DeclGroup] -> InferM a) -> InferM a
inferDs ds continue = checkTyDecls =<< orderTyDecls (mapMaybe toTyDecl ds)
where
isTopLevel = isTopDecl (head ds)
checkTyDecls (AT t mbD : ts) =
do t1 <- checkParameterType t mbD
withParamType t1 (checkTyDecls ts)
checkTyDecls (TS t mbD : ts) =
do t1 <- checkTySyn t mbD
withTySyn t1 (checkTyDecls ts)
checkTyDecls (PS t mbD : ts) =
do t1 <- checkPropSyn t mbD
withTySyn t1 (checkTyDecls ts)
checkTyDecls (NT t mbD : ts) =
do t1 <- checkNewtype t mbD
withNewtype t1 (checkTyDecls ts)
checkTyDecls (PT p mbD : ts) =
do p1 <- checkPrimType p mbD
withPrimType p1 (checkTyDecls ts)
-- We checked all type synonyms, now continue with value-level definitions:
checkTyDecls [] =
do cs <- checkParameterConstraints (concatMap toParamConstraints ds)
withParameterConstraints cs $
do xs <- mapM checkParameterFun (mapMaybe toParamFun ds)
withParamFuns xs $ checkBinds [] $ orderBinds $ mapMaybe toBind ds
checkParameterFun x =
do (s,gs) <- checkSchema NoWildCards (P.pfSchema x)
su <- proveImplication (Just (thing (P.pfName x)))
(sVars s) (sProps s) gs
unless (isEmptySubst su) $
panic "checkParameterFun" ["Subst not empty??"]
let n = thing (P.pfName x)
return ModVParam { mvpName = n
, mvpType = s
, mvpDoc = P.pfDoc x
, mvpFixity = P.pfFixity x
}
checkBinds decls (CyclicSCC bs : more) =
do bs1 <- inferBinds isTopLevel True bs
foldr (\b m -> withVar (dName b) (dSignature b) m)
(checkBinds (Recursive bs1 : decls) more)
bs1
checkBinds decls (AcyclicSCC c : more) =
do ~[b] <- inferBinds isTopLevel False [c]
withVar (dName b) (dSignature b) $
checkBinds (NonRecursive b : decls) more
-- We are done with all value-level definitions.
-- Now continue with anything that's in scope of the declarations.
checkBinds decls [] = continue (reverse decls)
tcPanic :: String -> [String] -> a
tcPanic l msg = panic ("[TypeCheck] " ++ l) msg
cryptol-2.8.0/src/Cryptol/TypeCheck/InferTypes.hs 0000644 0000000 0000000 00000026054 07346545000 020143 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.InferTypes
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- This module contains types used during type inference.
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Cryptol.TypeCheck.InferTypes where
import Cryptol.Parser.Position
import Cryptol.ModuleSystem.Name (asPrim,nameLoc)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.Subst
import Cryptol.TypeCheck.TypePat
import Cryptol.TypeCheck.SimpType(tMax)
import Cryptol.Utils.Ident (ModName, identText)
import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.Misc(anyJust)
import Cryptol.Utils.Patterns(matchMaybe)
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.Map ( Map )
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq
data SolverConfig = SolverConfig
{ solverPath :: FilePath -- ^ The SMT solver to invoke
, solverArgs :: [String] -- ^ Additional arguments to pass to the solver
, solverVerbose :: Int -- ^ How verbose to be when type-checking
, solverPreludePath :: [FilePath]
-- ^ Look for the solver prelude in these locations.
} deriving (Show, Generic, NFData)
-- | The types of variables in the environment.
data VarType = ExtVar Schema
-- ^ Known type
| CurSCC {- LAZY -} Expr Type
{- ^ Part of current SCC. The expression will replace the
variable, after we are done with the SCC. In this way a
variable that gets generalized is replaced with an appropriate
instantiation of itself. -}
data Goals = Goals
{ goalSet :: Set Goal
-- ^ A bunch of goals, not including the ones in 'literalGoals'.
, literalGoals :: Map TVar LitGoal
-- ^ An entry @(a,t)@ corresponds to @Literal t a@.
} deriving (Show)
-- | This abuses the type 'Goal' a bit. The 'goal' field contains
-- only the numeric part of the Literal constraint. For example,
-- @(a, Goal { goal = t })@ representats the goal for @Literal t a@
type LitGoal = Goal
litGoalToGoal :: (TVar,LitGoal) -> Goal
litGoalToGoal (a,g) = g { goal = pLiteral (goal g) (TVar a) }
goalToLitGoal :: Goal -> Maybe (TVar,LitGoal)
goalToLitGoal g =
do (tn,a) <- matchMaybe $ do (tn,b) <- aLiteral (goal g)
a <- aTVar b
return (tn,a)
return (a, g { goal = tn })
emptyGoals :: Goals
emptyGoals = Goals { goalSet = Set.empty, literalGoals = Map.empty }
nullGoals :: Goals -> Bool
nullGoals gs = Set.null (goalSet gs) && Map.null (literalGoals gs)
fromGoals :: Goals -> [Goal]
fromGoals gs = map litGoalToGoal (Map.toList (literalGoals gs)) ++
Set.toList (goalSet gs)
goalsFromList :: [Goal] -> Goals
goalsFromList = foldr insertGoal emptyGoals
insertGoal :: Goal -> Goals -> Goals
insertGoal g gs
| Just (a,newG) <- goalToLitGoal g =
gs { literalGoals = Map.insertWith jn a newG (literalGoals gs) }
| otherwise = gs { goalSet = Set.insert g (goalSet gs) }
where
jn g1 g2 = g1 { goal = tMax (goal g1) (goal g2) }
-- XXX: here we are arbitrarily using the info of the first goal,
-- which could lead to a confusing location for a constraint.
-- | Something that we need to find evidence for.
data Goal = Goal
{ goalSource :: ConstraintSource -- ^ What it is about
, goalRange :: Range -- ^ Part of source code that caused goal
, goal :: Prop -- ^ What needs to be proved
} deriving (Show, Generic, NFData)
instance Eq Goal where
x == y = goal x == goal y
instance Ord Goal where
compare x y = compare (goal x) (goal y)
data HasGoal = HasGoal
{ hasName :: !Int
, hasGoal :: Goal
} deriving Show
-- | A solution for a 'HasGoal'
data HasGoalSln = HasGoalSln
{ hasDoSelect :: Expr -> Expr
-- ^ Select a specific field from the input expsression.
, hasDoSet :: Expr -> Expr -> Expr
-- ^ Set a field of the first expression to the second expression
}
-- | Delayed implication constraints, arising from user-specified type sigs.
data DelayedCt = DelayedCt
{ dctSource :: Maybe Name -- ^ Signature that gave rise to this constraint
-- Nothing means module top-level
, dctForall :: [TParam]
, dctAsmps :: [Prop]
, dctGoals :: [Goal]
} deriving (Show, Generic, NFData)
-- | Information about how a constraint came to be, used in error reporting.
data ConstraintSource
= CtComprehension -- ^ Computing shape of list comprehension
| CtSplitPat -- ^ Use of a split pattern
| CtTypeSig -- ^ A type signature in a pattern or expression
| CtInst Expr -- ^ Instantiation of this expression
| CtSelector
| CtExactType
| CtEnumeration
| CtDefaulting -- ^ Just defaulting on the command line
| CtPartialTypeFun Name -- ^ Use of a partial type function.
| CtImprovement
| CtPattern Doc -- ^ Constraints arising from type-checking patterns
| CtModuleInstance ModName -- ^ Instantiating a parametrized module
deriving (Show, Generic, NFData)
instance TVars ConstraintSource where
apSubst su src =
case src of
CtComprehension -> src
CtSplitPat -> src
CtTypeSig -> src
CtInst e -> CtInst (apSubst su e)
CtSelector -> src
CtExactType -> src
CtEnumeration -> src
CtDefaulting -> src
CtPartialTypeFun _ -> src
CtImprovement -> src
CtPattern _ -> src
CtModuleInstance _ -> src
instance FVS Goal where
fvs g = fvs (goal g)
instance FVS DelayedCt where
fvs d = fvs (dctAsmps d, dctGoals d) `Set.difference`
Set.fromList (map tpVar (dctForall d))
instance TVars Goals where
-- XXX: could be more efficient
apSubst su gs = case anyJust apG (fromGoals gs) of
Nothing -> gs
Just gs1 -> goalsFromList (concatMap norm gs1)
where
norm g = [ g { goal = p } | p <- pSplitAnd (goal g) ]
apG g = mk g <$> apSubstMaybe su (goal g)
mk g p = g { goal = p }
instance TVars Goal where
apSubst su g = Goal { goalSource = apSubst su (goalSource g)
, goalRange = goalRange g
, goal = apSubst su (goal g)
}
instance TVars HasGoal where
apSubst su h = h { hasGoal = apSubst su (hasGoal h) }
instance TVars DelayedCt where
apSubst su g
| Set.null captured =
DelayedCt { dctSource = dctSource g
, dctForall = dctForall g
, dctAsmps = apSubst su (dctAsmps g)
, dctGoals = apSubst su (dctGoals g)
}
| otherwise = panic "Cryptol.TypeCheck.Subst.apSubst (DelayedCt)"
[ "Captured quantified variables:"
, "Substitution: " ++ show su
, "Variables: " ++ show captured
, "Constraint: " ++ show g
]
where
captured = Set.fromList (map tpVar (dctForall g))
`Set.intersection`
subVars
subVars = Set.unions
$ map (fvs . applySubstToVar su)
$ Set.toList used
used = fvs (dctAsmps g, map goal (dctGoals g)) `Set.difference`
Set.fromList (map tpVar (dctForall g))
-- | For use in error messages
cppKind :: Kind -> Doc
cppKind ki =
case ki of
KNum -> text "a numeric type"
KType -> text "a value type"
KProp -> text "a constraint"
_ -> pp ki
addTVarsDescsAfter :: FVS t => NameMap -> t -> Doc -> Doc
addTVarsDescsAfter nm t d
| Set.null vs = d
| otherwise = d $$ text "where" $$ vcat (map desc (Set.toList vs))
where
vs = fvs t
desc v = ppWithNames nm v <+> text "is" <+> pp (tvInfo v)
addTVarsDescsBefore :: FVS t => NameMap -> t -> Doc -> Doc
addTVarsDescsBefore nm t d = frontMsg $$ d $$ backMsg
where
(vs1,vs2) = Set.partition isFreeTV (fvs t)
frontMsg | null vs1 = empty
| otherwise = "Failed to infer the following types:"
$$ nest 2 (vcat (map desc1 (Set.toList vs1)))
desc1 v = "•" <+> ppWithNames nm v <.> comma <+> pp (tvInfo v)
backMsg | null vs2 = empty
| otherwise = "where"
$$ nest 2 (vcat (map desc2 (Set.toList vs2)))
desc2 v = ppWithNames nm v <+> text "is" <+> pp (tvInfo v)
instance PP ConstraintSource where
ppPrec _ src =
case src of
CtComprehension -> "list comprehension"
CtSplitPat -> "split (#) pattern"
CtTypeSig -> "type signature"
CtInst e -> "use of" <+> ppUse e
CtSelector -> "use of selector"
CtExactType -> "matching types"
CtEnumeration -> "list enumeration"
CtDefaulting -> "defaulting"
CtPartialTypeFun f -> "use of partial type function" <+> pp f
CtImprovement -> "examination of collected goals"
CtPattern desc -> "checking a pattern:" <+> desc
CtModuleInstance n -> "module instantiation" <+> pp n
ppUse :: Expr -> Doc
ppUse expr =
case expr of
EVar (asPrim -> Just prim)
| identText prim == "number" -> "literal or demoted expression"
| identText prim == "infFrom" -> "infinite enumeration"
| identText prim == "infFromThen" -> "infinite enumeration (with step)"
| identText prim == "fromTo" -> "finite enumeration"
| identText prim == "fromThenTo" -> "finite enumeration"
_ -> "expression" <+> pp expr
instance PP (WithNames Goal) where
ppPrec _ (WithNames g names) =
(ppWithNames names (goal g)) $$
nest 2 (text "arising from" $$
pp (goalSource g) $$
text "at" <+> pp (goalRange g))
instance PP (WithNames DelayedCt) where
ppPrec _ (WithNames d names) =
sig $$ "we need to show that" $$
nest 2 (vcat [ vars, asmps, "the following constraints hold:"
, nest 2 $ vcat
$ bullets
$ map (ppWithNames ns1)
$ dctGoals d ])
where
bullets xs = [ "•" <+> x | x <- xs ]
sig = case name of
Just n -> "in the definition of" <+> quotes (pp n) <.>
comma <+> "at" <+> pp (nameLoc n) <.> comma
Nothing -> "when checking the module's parameters,"
name = dctSource d
vars = case dctForall d of
[] -> empty
xs -> "for any type" <+>
fsep (punctuate comma (map (ppWithNames ns1 ) xs))
asmps = case dctAsmps d of
[] -> empty
xs -> "assuming" $$
nest 2 (vcat (bullets (map (ppWithNames ns1) xs)))
ns1 = addTNames (dctForall d) names
cryptol-2.8.0/src/Cryptol/TypeCheck/Instantiate.hs 0000644 0000000 0000000 00000015464 07346545000 020341 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Instantiate
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# Language OverloadedStrings #-}
module Cryptol.TypeCheck.Instantiate
( instantiateWith
, TypeArg(..)
, uncheckedTypeArg
, MaybeCheckedType(..)
) where
import Cryptol.ModuleSystem.Name (nameIdent)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Monad
import Cryptol.TypeCheck.Subst (listParamSubst, apSubst)
import Cryptol.TypeCheck.Kind(checkType)
import Cryptol.TypeCheck.Error
import Cryptol.Parser.Position (Located(..))
import Cryptol.Utils.Ident (Ident)
import Cryptol.Utils.Panic(panic)
import qualified Cryptol.Parser.AST as P
import Control.Monad(zipWithM)
import Data.Function (on)
import Data.List(sortBy, groupBy, find)
import Data.Maybe(mapMaybe,isJust)
import Data.Either(partitionEithers)
import qualified Data.Set as Set
data TypeArg = TypeArg
{ tyArgName :: Maybe (Located Ident)
, tyArgType :: MaybeCheckedType
}
uncheckedTypeArg :: P.TypeInst Name -> TypeArg
uncheckedTypeArg a =
case a of
P.NamedInst x ->
TypeArg { tyArgName = Just (P.name x), tyArgType = Unchecked (P.value x) }
P.PosInst t ->
TypeArg { tyArgName = Nothing, tyArgType = Unchecked t }
data MaybeCheckedType = Checked Type | Unchecked (P.Type Name)
checkTyParam :: TVarSource -> Kind -> MaybeCheckedType -> InferM Type
checkTyParam src k mb =
case mb of
Checked t
| k == k' -> pure t
| otherwise -> do recordError (KindMismatch k k')
newType src k
where k' = kindOf t
Unchecked t -> checkType t (Just k)
instantiateWith :: Name -> Expr -> Schema -> [TypeArg] -> InferM (Expr,Type)
instantiateWith nm e s ts
| null named = instantiateWithPos nm e s positional
| null positional = instantiateWithNames nm e s named
| otherwise = do recordError CannotMixPositionalAndNamedTypeParams
instantiateWithNames nm e s named
where
(named,positional) = partitionEithers (map classify ts)
classify t = case tyArgName t of
Just n -> Left n { thing = (thing n, tyArgType t) }
Nothing -> Right (tyArgType t)
instantiateWithPos ::
Name -> Expr -> Schema -> [MaybeCheckedType] -> InferM (Expr,Type)
instantiateWithPos nm e (Forall as ps t) ts =
do su <- makeSu (1::Int) [] as ts
doInst su e ps t
where
isNamed q = isJust (tpName q)
makeSu n su (q : qs) (mbty : tys)
| not (isNamed q) = do r <- unnamed n q
makeSu (n+1) (r : su) qs (mbty : tys)
| otherwise = do ty <- checkTyParam (TypeParamInstPos nm n) (kindOf q) mbty
makeSu (n+1) ((q,ty) : su) qs tys
makeSu _ su [] [] = return (reverse su)
makeSu n su (q : qs) [] = do r <- unnamed n q
makeSu (n+1) (r : su) qs []
makeSu _ su [] _ = do recordError TooManyPositionalTypeParams
return (reverse su)
unnamed n q = do ty <- newType src (kindOf q)
return (q, ty)
where
src = case drop (n-1) {- count from 1 -} as of
p:_ ->
case tpFlav p of
TPOther (Just a) -> TypeParamInstNamed nm (nameIdent a)
_ -> TypeParamInstPos nm n
_ -> panic "instantiateWithPos"
[ "Invalid parameter index", show n, show as ]
{- | Instantiate an expression of the given polymorphic type.
The arguments that are provided will be instantiated as requested,
the rest will be instantiated with fresh type variables.
EProofApp (ETApp e t)
where
- There will be one `ETApp t` for each insantiated type parameter;
- there will be one `EProofApp` for each constraint on the schema;
-}
instantiateWithNames ::
Name -> Expr -> Schema -> [Located (Ident,MaybeCheckedType)]
-> InferM (Expr,Type)
instantiateWithNames nm e (Forall as ps t) xs =
do sequence_ repeatedParams
mapM_ (recordError . UndefinedTypeParameter . fmap fst) undefParams
su' <- zipWithM paramInst [ 1.. ] as
doInst su' e ps t
where
-- Choose the type for type parameter `x`
paramInst n x =
do let k = tpKind x
-- We just use nameIdent for comparison here, as all parameter names
-- should have a NameInfo of Parameter.
lkp name = find (\th -> fst (thing th) == nameIdent name) xs
src = case tpName x of
Just na -> TypeParamInstNamed nm (nameIdent na)
Nothing -> TypeParamInstPos nm n
ty <- case lkp =<< tpName x of
Just lty -> checkTyParam src k (snd (thing lty))
Nothing -> newType src k
return (x, ty)
-- Errors from multiple values for the same parameter.
repeatedParams = mapMaybe isRepeated
$ groupBy ((==) `on` pName)
$ sortBy (compare `on` pName) xs
isRepeated ys@(a : _ : _) =
Just $ recordError (RepeatedTypeParameter (fst (thing a)) (map srcRange ys))
isRepeated _ = Nothing
paramIdents = [ nameIdent n | Just n <- map tpName as ]
-- Errors from parameters that are defined, but do not exist in the schema.
undefParams = [ x | x <- xs, pName x `notElem` paramIdents ]
pName = fst . thing
-- If the instantiation contains an assignment (v := t), and the type
-- contains a free unification variable ?x that could possibly depend
-- on v, then we must require that t = v (i.e. su must be an identity
-- substitution). Otherwise, this causes a problem: If ?x is
-- eventually instantiated to a type containing v, then the type
-- substitution will have computed the wrong result.
doInst :: [(TParam, Type)] -> Expr -> [Prop] -> Type -> InferM (Expr,Type)
doInst su' e ps t =
do let su = listParamSubst su'
newGoals (CtInst e) (map (apSubst su) ps)
let t1 = apSubst su t
-- Possibly more goals due to unification
ps' <- concat <$> mapM checkInst su'
newGoals (CtInst e) ps'
return ( addProofParams (addTyParams (map snd su') e), t1 )
where
-- Add type parameters
addTyParams ts e1 = foldl ETApp e1 ts
-- Add proof parameters (the proofs are omitted but we mark where they'd go)
addProofParams e1 = foldl (\e2 _ -> EProofApp e2) e1 ps
-- free unification variables used in the schema
frees = Set.unions (map fvs (t : ps))
-- the bound variables from the scopes of any unification variables in the schema
bounds = Set.unions (map scope (Set.toList frees))
where
scope (TVFree _ _ vs _) = vs
scope (TVBound _) = Set.empty
-- if the tvar is in 'bounds', then make sure it is an identity substitution
checkInst :: (TParam, Type) -> InferM [Prop]
checkInst (tp, ty)
| Set.notMember tp bounds = return []
| otherwise = unify (TVar (tpVar tp)) ty
cryptol-2.8.0/src/Cryptol/TypeCheck/Kind.hs 0000644 0000000 0000000 00000034674 07346545000 016747 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Kind
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE Safe #-}
module Cryptol.TypeCheck.Kind
( checkType
, checkSchema
, checkNewtype
, checkPrimType
, checkTySyn
, checkPropSyn
, checkParameterType
, checkParameterConstraints
) where
import qualified Cryptol.Parser.AST as P
import Cryptol.Parser.AST (Named(..))
import Cryptol.Parser.Position
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Error
import Cryptol.TypeCheck.Monad hiding (withTParams)
import Cryptol.TypeCheck.SimpType(tRebuild)
import Cryptol.TypeCheck.SimpleSolver(simplify)
import Cryptol.TypeCheck.Solve (simplifyAllConstraints)
import Cryptol.TypeCheck.Subst(listSubst,apSubst)
import Cryptol.Utils.Panic (panic)
import qualified Data.Map as Map
import Data.List(sortBy,groupBy)
import Data.Maybe(fromMaybe)
import Data.Function(on)
import Control.Monad(unless,forM,when)
-- | Check a type signature. Returns validated schema, and any implicit
-- constraints that we inferred.
checkSchema :: AllowWildCards -> P.Schema Name -> InferM (Schema, [Goal])
checkSchema withWild (P.Forall xs ps t mb) =
do ((xs1,(ps1,t1)), gs) <-
collectGoals $
rng $ withTParams withWild schemaParam xs $
do ps1 <- mapM checkProp ps
t1 <- doCheckType t (Just KType)
return (ps1,t1)
-- XXX: We probably shouldn't do this, as we are changing what the
-- user is doing. We do it so that things are in a propal normal form,
-- but we should probably figure out another time to do this.
let newPs = concatMap pSplitAnd $ map (simplify Map.empty)
$ map tRebuild ps1
return ( Forall xs1 newPs (tRebuild t1)
, [ g { goal = tRebuild (goal g) } | g <- gs ]
)
where
rng = case mb of
Nothing -> id
Just r -> inRange r
-- | Check a module parameter declarations. Nothing much to check,
-- we just translate from one syntax to another.
checkParameterType :: P.ParameterType Name -> Maybe String -> InferM ModTParam
checkParameterType a mbDoc =
do let k = cvtK (P.ptKind a)
n = thing (P.ptName a)
return ModTParam { mtpKind = k, mtpName = n, mtpDoc = mbDoc
, mtpNumber = P.ptNumber a }
-- | Check a type-synonym declaration.
checkTySyn :: P.TySyn Name -> Maybe String -> InferM TySyn
checkTySyn (P.TySyn x _ as t) mbD =
do ((as1,t1),gs) <- collectGoals
$ inRange (srcRange x)
$ do r <- withTParams NoWildCards tySynParam as
(doCheckType t Nothing)
simplifyAllConstraints
return r
return TySyn { tsName = thing x
, tsParams = as1
, tsConstraints = map (tRebuild . goal) gs
, tsDef = tRebuild t1
, tsDoc = mbD
}
-- | Check a constraint-synonym declaration.
checkPropSyn :: P.PropSyn Name -> Maybe String -> InferM TySyn
checkPropSyn (P.PropSyn x _ as ps) mbD =
do ((as1,t1),gs) <- collectGoals
$ inRange (srcRange x)
$ do r <- withTParams NoWildCards propSynParam as
(traverse checkProp ps)
simplifyAllConstraints
return r
return TySyn { tsName = thing x
, tsParams = as1
, tsConstraints = map (tRebuild . goal) gs
, tsDef = tRebuild (pAnd t1)
, tsDoc = mbD
}
-- | Check a newtype declaration.
-- XXX: Do something with constraints.
checkNewtype :: P.Newtype Name -> Maybe String -> InferM Newtype
checkNewtype (P.Newtype x as fs) mbD =
do ((as1,fs1),gs) <- collectGoals $
inRange (srcRange x) $
do r <- withTParams NoWildCards newtypeParam as $
forM fs $ \field ->
let n = name field
in kInRange (srcRange n) $
do t1 <- doCheckType (value field) (Just KType)
return (thing n, t1)
simplifyAllConstraints
return r
return Newtype { ntName = thing x
, ntParams = as1
, ntConstraints = map goal gs
, ntFields = fs1
, ntDoc = mbD
}
checkPrimType :: P.PrimType Name -> Maybe String -> InferM AbstractType
checkPrimType p mbD =
do let (as,cs) = P.primTCts p
(as',cs') <- withTParams NoWildCards (TPOther . Just) as $
mapM checkProp cs
pure AbstractType { atName = thing (P.primTName p)
, atKind = cvtK (thing (P.primTKind p))
, atFixitiy = P.primTFixity p
, atCtrs = (as',cs')
, atDoc = mbD
}
checkType :: P.Type Name -> Maybe Kind -> InferM Type
checkType t k =
do (_, t1) <- withTParams AllowWildCards schemaParam [] $ doCheckType t k
return (tRebuild t1)
checkParameterConstraints :: [Located (P.Prop Name)] -> InferM [Located Prop]
checkParameterConstraints ps =
do (_, cs) <- withTParams NoWildCards schemaParam [] (mapM checkL ps)
return cs
where
checkL x = do p <- checkProp (thing x)
return x { thing = tRebuild p }
{- | Check something with type parameters.
When we check things with type parameters (i.e., type schemas, and type
synonym declarations) we do kind inference based only on the immediately
visible body. Type parameters that are not mentioned in the body are
defaulted to kind 'KNum'. If this is not the desired behavior, programmers
may add explicit kind annotations on the type parameters.
Here is an example of how this may show up:
> f : {n}. [8] -> [8]
> f x = x + `n
Note that @n@ does not appear in the body of the schema, so we will
default it to 'KNum', which is the correct thing in this case.
To use such a function, we'd have to provide an explicit type application:
> f `{n = 3}
There are two reasons for this choice:
1. It makes it possible to figure if something is correct without
having to look through arbitrary amounts of code.
2. It is a bit easier to implement, and it covers the large majority
of use cases, with a very small inconvenience (an explicit kind
annotation) in the rest.
-}
withTParams :: AllowWildCards {- ^ Do we allow wild cards -} ->
(Name -> TPFlavor) {- ^ What sort of params are these? -} ->
[P.TParam Name] {- ^ The params -} ->
KindM a {- ^ do this using the params -} ->
InferM ([TParam], a)
withTParams allowWildCards flav xs m
| not (null duplicates) = panic "withTParams" $ "Repeated parameters"
: map show duplicates
| otherwise =
do (as,a,ctrs) <-
mdo (a, vars,ctrs) <- runKindM allowWildCards (zip' xs as) m
as <- mapM (newTP vars) xs
return (as,a,ctrs)
mapM_ (uncurry newGoals) ctrs
return (as,a)
where
getKind vs tp =
case Map.lookup (P.tpName tp) vs of
Just k -> return k
Nothing -> do recordWarning (DefaultingKind tp P.KNum)
return KNum
newTP vs tp = do k <- getKind vs tp
let nm = P.tpName tp
newTParam tp (flav nm) k
{- Note that we only zip based on the first argument.
This is needed to make the monadic recursion work correctly,
because the data dependency is only on the part that is known. -}
zip' [] _ = []
zip' (a:as) ~(t:ts) = (P.tpName a, fmap cvtK (P.tpKind a), t) : zip' as ts
duplicates = [ ds | ds@(_ : _ : _) <- groupBy ((==) `on` P.tpName)
$ sortBy (compare `on` P.tpName) xs ]
cvtK :: P.Kind -> Kind
cvtK P.KNum = KNum
cvtK P.KType = KType
cvtK P.KProp = KProp
cvtK (P.KFun k1 k2) = cvtK k1 :-> cvtK k2
-- | Check an application of a type constant.
tcon :: TCon -- ^ Type constant being applied
-> [P.Type Name] -- ^ Type parameters
-> Maybe Kind -- ^ Expected kind
-> KindM Type -- ^ Resulting type
tcon tc ts0 k =
do (ts1,k1) <- appTy ts0 (kindOf tc)
checkKind (TCon tc ts1) k k1
-- | Check a type application of a non built-in type or type variable.
checkTUser ::
Name {- ^ The name that is being applied to some arguments. -} ->
[P.Type Name] {- ^ Parameters to the type -} ->
Maybe Kind {- ^ Expected kind -} ->
KindM Type {- ^ Resulting type -}
checkTUser x ts k =
mcase kLookupTyVar checkBoundVarUse $
mcase kLookupTSyn checkTySynUse $
mcase kLookupNewtype checkNewTypeUse $
mcase kLookupParamType checkModuleParamUse $
mcase kLookupAbstractType checkAbstractTypeUse $
checkScopedVarUse -- none of the above, must be a scoped type variable,
-- if the renamer did its job correctly.
where
checkTySynUse tysyn =
do (ts1,k1) <- appTy ts (kindOf tysyn)
let as = tsParams tysyn
ts2 <- checkParams as ts1
let su = zip as ts2
ps1 <- mapM (`kInstantiateT` su) (tsConstraints tysyn)
kNewGoals (CtPartialTypeFun (tsName tysyn)) ps1
t1 <- kInstantiateT (tsDef tysyn) su
checkKind (TUser x ts1 t1) k k1
checkNewTypeUse nt =
do let tc = newtypeTyCon nt
(ts1,_) <- appTy ts (kindOf tc)
ts2 <- checkParams (ntParams nt) ts1
return (TCon tc ts2)
checkAbstractTypeUse absT =
do let tc = abstractTypeTC absT
(ts1,k1) <- appTy ts (kindOf tc)
let (as,ps) = atCtrs absT
case ps of
[] -> pure () -- common case
_ -> do let need = length as
have = length ts1
when (need > have) $
kRecordError (TooFewTyParams (atName absT) (need - have))
let su = listSubst (map tpVar as `zip` ts1)
kNewGoals (CtPartialTypeFun (atName absT)) (apSubst su <$> ps)
checkKind (TCon tc ts1) k k1
checkParams as ts1
| paramHave == paramNeed = return ts1
| paramHave < paramNeed =
do kRecordError (TooFewTyParams x (paramNeed-paramHave))
let src = TypeErrorPlaceHolder
fake <- mapM (kNewType src . kindOf . tpVar)
(drop paramHave as)
return (ts1 ++ fake)
| otherwise = do kRecordError (TooManyTySynParams x (paramHave-paramNeed))
return (take paramNeed ts1)
where paramHave = length ts1
paramNeed = length as
checkModuleParamUse a =
do let ty = tpVar (mtpParam a)
(ts1,k1) <- appTy ts (kindOf ty)
case k of
Just ks | ks /= k1 -> kRecordError $ KindMismatch ks k1
_ -> return ()
unless (null ts1) $
panic "Kind.checkTUser.checkModuleParam" [ "Unexpected parameters" ]
return (TVar ty)
checkBoundVarUse v =
do unless (null ts) $ kRecordError TyVarWithParams
case v of
TLocalVar t mbk ->
case k of
Nothing -> return (TVar (tpVar t))
Just k1 ->
case mbk of
Nothing -> kSetKind x k1 >> return (TVar (tpVar t))
Just k2 -> checkKind (TVar (tpVar t)) k k2
TOuterVar t -> checkKind (TVar (tpVar t)) k (kindOf t)
checkScopedVarUse =
do unless (null ts) (kRecordError TyVarWithParams)
kExistTVar x $ fromMaybe KNum k
mcase :: (Name -> KindM (Maybe a)) ->
(a -> KindM Type) ->
KindM Type ->
KindM Type
mcase m f rest =
do mb <- m x
case mb of
Nothing -> rest
Just a -> f a
-- | Check a type-application.
appTy :: [P.Type Name] -- ^ Parameters to type function
-> Kind -- ^ Kind of type function
-> KindM ([Type], Kind) -- ^ Validated parameters, resulting kind
appTy [] k1 = return ([],k1)
appTy (t : ts) (k1 :-> k2) =
do t1 <- doCheckType t (Just k1)
(ts1,k) <- appTy ts k2
return (t1 : ts1, k)
appTy ts k1 =
do kRecordError (TooManyTypeParams (length ts) k1)
return ([], k1)
-- | Validate a parsed type.
doCheckType :: P.Type Name -- ^ Type that needs to be checked
-> Maybe Kind -- ^ Expected kind (if any)
-> KindM Type -- ^ Checked type
doCheckType ty k =
case ty of
P.TWild ->
do wildOk <- kWildOK
case wildOk of
AllowWildCards -> return ()
NoWildCards -> kRecordError UnexpectedTypeWildCard
theKind <- case k of
Just k1 -> return k1
Nothing -> do kRecordWarning (DefaultingWildType P.KNum)
return KNum
kNewType TypeWildCard theKind
P.TFun t1 t2 -> tcon (TC TCFun) [t1,t2] k
P.TSeq t1 t2 -> tcon (TC TCSeq) [t1,t2] k
P.TBit -> tcon (TC TCBit) [] k
P.TNum n -> tcon (TC (TCNum n)) [] k
P.TChar n -> tcon (TC (TCNum $ toInteger $ fromEnum n)) [] k
P.TTuple ts -> tcon (TC (TCTuple (length ts))) ts k
P.TRecord fs -> do t1 <- TRec `fmap` mapM checkF fs
checkKind t1 k KType
P.TLocated t r1 -> kInRange r1 $ doCheckType t k
P.TUser x ts -> checkTUser x ts k
P.TParens t -> doCheckType t k
P.TInfix t x _ u-> doCheckType (P.TUser (thing x) [t, u]) k
where
checkF f = do t <- kInRange (srcRange (name f))
$ doCheckType (value f) (Just KType)
return (thing (name f), t)
-- | Validate a parsed proposition.
checkProp :: P.Prop Name -- ^ Proposition that need to be checked
-> KindM Type -- ^ Checked representation
checkProp (P.CType t) = doCheckType t (Just KProp)
-- | Check that a type has the expected kind.
checkKind :: Type -- ^ Kind-checked type
-> Maybe Kind -- ^ Expected kind (if any)
-> Kind -- ^ Inferred kind
-> KindM Type -- ^ A type consistent with expectations.
checkKind _ (Just k1) k2
| k1 /= k2 = do kRecordError (KindMismatch k1 k2)
kNewType TypeErrorPlaceHolder k1
checkKind t _ _ = return t
cryptol-2.8.0/src/Cryptol/TypeCheck/Monad.hs 0000644 0000000 0000000 00000100547 07346545000 017111 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Monad
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.TypeCheck.Monad
( module Cryptol.TypeCheck.Monad
, module Cryptol.TypeCheck.InferTypes
) where
import Cryptol.ModuleSystem.Name
(FreshM(..),Supply,mkParameter
, nameInfo, NameInfo(..),NameSource(..))
import Cryptol.Parser.Position
import qualified Cryptol.Parser.AST as P
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Subst
import Cryptol.TypeCheck.Unify(mgu, runResult, UnificationError(..))
import Cryptol.TypeCheck.InferTypes
import Cryptol.TypeCheck.Error(Warning(..),Error(..),cleanupErrors)
import Cryptol.TypeCheck.PP (brackets, commaSep)
import qualified Cryptol.TypeCheck.SimpleSolver as Simple
import qualified Cryptol.TypeCheck.Solver.SMT as SMT
import Cryptol.Utils.PP(pp, (<+>), text, quotes)
import Cryptol.Utils.Ident(Ident)
import Cryptol.Utils.Panic(panic)
import qualified Control.Applicative as A
import Control.Monad.Fix(MonadFix(..))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Map (Map)
import Data.Set (Set)
import Data.List(find, foldl')
import Data.Maybe(mapMaybe,fromMaybe)
import MonadLib hiding (mapM)
import Data.IORef
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
-- | Information needed for type inference.
data InferInput = InferInput
{ inpRange :: Range -- ^ Location of program source
, inpVars :: Map Name Schema -- ^ Variables that are in scope
, inpTSyns :: Map Name TySyn -- ^ Type synonyms that are in scope
, inpNewtypes :: Map Name Newtype -- ^ Newtypes in scope
, inpAbstractTypes :: Map Name AbstractType -- ^ Abstract types in scope
-- When typechecking a module these start off empty.
-- We need them when type-checking an expression at the command
-- line, for example.
, inpParamTypes :: !(Map Name ModTParam) -- ^ Type parameters
, inpParamConstraints :: !([Located Prop]) -- ^ Constraints on parameters
, inpParamFuns :: !(Map Name ModVParam) -- ^ Value parameters
, inpNameSeeds :: NameSeeds -- ^ Private state of type-checker
, inpMonoBinds :: Bool -- ^ Should local bindings without
-- signatures be monomorphized?
, inpSolverConfig :: SolverConfig -- ^ Options for the constraint solver
, inpSearchPath :: [FilePath]
-- ^ Where to look for Cryptol theory file.
, inpPrimNames :: !PrimMap
-- ^ This is used when the type-checker needs to refer to a predefined
-- identifier (e.g., @number@).
, inpSupply :: !Supply -- ^ The supply for fresh name generation
} deriving Show
-- | This is used for generating various names.
data NameSeeds = NameSeeds
{ seedTVar :: !Int
, seedGoal :: !Int
} deriving (Show, Generic, NFData)
-- | The initial seeds, used when checking a fresh program.
-- XXX: why does this start at 10?
nameSeeds :: NameSeeds
nameSeeds = NameSeeds { seedTVar = 10, seedGoal = 0 }
-- | The results of type inference.
data InferOutput a
= InferFailed [(Range,Warning)] [(Range,Error)]
-- ^ We found some errors
| InferOK [(Range,Warning)] NameSeeds Supply a
-- ^ Type inference was successful.
deriving Show
bumpCounter :: InferM ()
bumpCounter = do RO { .. } <- IM ask
io $ modifyIORef' iSolveCounter (+1)
runInferM :: TVars a => InferInput -> InferM a -> IO (InferOutput a)
runInferM info (IM m) = SMT.withSolver (inpSolverConfig info) $ \solver ->
do coutner <- newIORef 0
rec ro <- return RO { iRange = inpRange info
, iVars = Map.map ExtVar (inpVars info)
, iTVars = []
, iTSyns = fmap mkExternal (inpTSyns info)
, iNewtypes = fmap mkExternal (inpNewtypes info)
, iAbstractTypes = mkExternal <$> inpAbstractTypes info
, iParamTypes = inpParamTypes info
, iParamFuns = inpParamFuns info
, iParamConstraints = inpParamConstraints info
, iSolvedHasLazy = iSolvedHas finalRW -- RECURSION
, iMonoBinds = inpMonoBinds info
, iSolver = solver
, iPrimNames = inpPrimNames info
, iSolveCounter = coutner
}
(result, finalRW) <- runStateT rw
$ runReaderT ro m -- RECURSION
let theSu = iSubst finalRW
defSu = defaultingSubst theSu
warns = [(r,apSubst theSu w) | (r,w) <- iWarnings finalRW ]
case iErrors finalRW of
[] ->
case (iCts finalRW, iHasCts finalRW) of
(cts,[])
| nullGoals cts
-> return $ InferOK warns
(iNameSeeds finalRW)
(iSupply finalRW)
(apSubst defSu result)
(cts,has) -> return $ InferFailed warns
$ cleanupErrors
[ ( goalRange g
, UnsolvedGoals False [apSubst theSu g]
) | g <- fromGoals cts ++ map hasGoal has
]
errs -> return $ InferFailed warns
$ cleanupErrors [(r,apSubst theSu e) | (r,e) <- errs]
where
mkExternal x = (IsExternal, x)
rw = RW { iErrors = []
, iWarnings = []
, iSubst = emptySubst
, iExistTVars = []
, iNameSeeds = inpNameSeeds info
, iCts = emptyGoals
, iHasCts = []
, iSolvedHas = Map.empty
, iSupply = inpSupply info
}
newtype InferM a = IM { unIM :: ReaderT RO (StateT RW IO) a }
data DefLoc = IsLocal | IsExternal
-- | Read-only component of the monad.
data RO = RO
{ iRange :: Range -- ^ Source code being analysed
, iVars :: Map Name VarType -- ^ Type of variable that are in scope
{- NOTE: We assume no shadowing between these two, so it does not matter
where we look first. Similarly, we assume no shadowing with
the existential type variable (in RW). See `checkTShadowing`. -}
, iTVars :: [TParam] -- ^ Type variable that are in scope
, iTSyns :: Map Name (DefLoc, TySyn) -- ^ Type synonyms that are in scope
, iNewtypes :: Map Name (DefLoc, Newtype)
-- ^ Newtype declarations in scope
--
-- NOTE: type synonyms take precedence over newtype. The reason is
-- that we can define local type synonyms, but not local newtypes.
-- So, either a type-synonym shadows a newtype, or it was declared
-- at the top-level, but then there can't be a newtype with the
-- same name (this should be caught by the renamer).
, iAbstractTypes :: Map Name (DefLoc, AbstractType)
, iParamTypes :: Map Name ModTParam
-- ^ Parameter types
, iParamConstraints :: [Located Prop]
-- ^ Constraints on the type parameters
, iParamFuns :: Map Name ModVParam
-- ^ Parameter functions
, iSolvedHasLazy :: Map Int HasGoalSln
-- ^ NOTE: This field is lazy in an important way! It is the
-- final version of `iSolvedHas` in `RW`, and the two are tied
-- together through recursion. The field is here so that we can
-- look thing up before they are defined, which is OK because we
-- don't need to know the results until everything is done.
, iMonoBinds :: Bool
-- ^ When this flag is set to true, bindings that lack signatures
-- in where-blocks will never be generalized. Bindings with type
-- signatures, and all bindings at top level are unaffected.
, iSolver :: SMT.Solver
, iPrimNames :: !PrimMap
, iSolveCounter :: !(IORef Int)
}
-- | Read-write component of the monad.
data RW = RW
{ iErrors :: ![(Range,Error)] -- ^ Collected errors
, iWarnings :: ![(Range,Warning)] -- ^ Collected warnings
, iSubst :: !Subst -- ^ Accumulated substitution
, iExistTVars :: [Map Name Type]
-- ^ These keeps track of what existential type variables are available.
-- When we start checking a function, we push a new scope for
-- its arguments, and we pop it when we are done checking the function
-- body. The front element of the list is the current scope, which is
-- the only thing that will be modified, as follows. When we encounter
-- a existential type variable:
-- 1. we look in all scopes to see if it is already defined.
-- 2. if it was not defined, we create a fresh type variable,
-- and we add it to the current scope.
-- 3. it is an error if we encounter an existential variable but we
-- have no current scope.
, iSolvedHas :: Map Int HasGoalSln
-- ^ Selector constraints that have been solved (ref. iSolvedSelectorsLazy)
-- Generating names
, iNameSeeds :: !NameSeeds
-- Constraints that need solving
, iCts :: !Goals -- ^ Ordinary constraints
, iHasCts :: ![HasGoal]
{- ^ Tuple/record projection constraints. The `Int` is the "name"
of the constraint, used so that we can name it solution properly. -}
, iSupply :: !Supply
}
instance Functor InferM where
fmap f (IM m) = IM (fmap f m)
instance A.Applicative InferM where
pure = return
(<*>) = ap
instance Monad InferM where
return x = IM (return x)
fail x = IM (fail x)
IM m >>= f = IM (m >>= unIM . f)
instance MonadFix InferM where
mfix f = IM (mfix (unIM . f))
instance FreshM InferM where
liftSupply f = IM $
do rw <- get
let (a,s') = f (iSupply rw)
set rw { iSupply = s' }
return a
io :: IO a -> InferM a
io m = IM $ inBase m
-- | The monadic computation is about the given range of source code.
-- This is useful for error reporting.
inRange :: Range -> InferM a -> InferM a
inRange r (IM m) = IM $ mapReader (\ro -> ro { iRange = r }) m
inRangeMb :: Maybe Range -> InferM a -> InferM a
inRangeMb Nothing m = m
inRangeMb (Just r) m = inRange r m
-- | This is the current range that we are working on.
curRange :: InferM Range
curRange = IM $ asks iRange
-- | Report an error.
recordError :: Error -> InferM ()
recordError e =
do r <- curRange
IM $ sets_ $ \s -> s { iErrors = (r,e) : iErrors s }
recordWarning :: Warning -> InferM ()
recordWarning w =
unless ignore $
do r <- case w of
DefaultingTo d _ -> return (tvarSource d)
_ -> curRange
IM $ sets_ $ \s -> s { iWarnings = (r,w) : iWarnings s }
where
ignore
| DefaultingTo d _ <- w
, Just n <- tvSourceName (tvarDesc d)
, Declared _ SystemName <- nameInfo n
= True
| otherwise = False
getSolver :: InferM SMT.Solver
getSolver =
do RO { .. } <- IM ask
return iSolver
-- | Retrieve the mapping between identifiers and declarations in the prelude.
getPrimMap :: InferM PrimMap
getPrimMap =
do RO { .. } <- IM ask
return iPrimNames
--------------------------------------------------------------------------------
newGoal :: ConstraintSource -> Prop -> InferM Goal
newGoal goalSource goal =
do goalRange <- curRange
return Goal { .. }
-- | Record some constraints that need to be solved.
-- The string explains where the constraints came from.
newGoals :: ConstraintSource -> [Prop] -> InferM ()
newGoals src ps = addGoals =<< mapM (newGoal src) ps
{- | The constraints are removed, and returned to the caller.
The substitution IS applied to them. -}
getGoals :: InferM [Goal]
getGoals =
do goals <- applySubst =<<
IM (sets $ \s -> (iCts s, s { iCts = emptyGoals }))
return (fromGoals goals)
-- | Add a bunch of goals that need solving.
addGoals :: [Goal] -> InferM ()
addGoals gs0 = doAdd =<< simpGoals gs0
where
doAdd [] = return ()
doAdd gs = IM $ sets_ $ \s -> s { iCts = foldl' (flip insertGoal) (iCts s) gs }
-- | Collect the goals emitted by the given sub-computation.
-- Does not emit any new goals.
collectGoals :: InferM a -> InferM (a, [Goal])
collectGoals m =
do origGs <- applySubst =<< getGoals'
a <- m
newGs <- getGoals
setGoals' origGs
return (a, newGs)
where
-- retrieve the type map only
getGoals' = IM $ sets $ \ RW { .. } -> (iCts, RW { iCts = emptyGoals, .. })
-- set the type map directly
setGoals' gs = IM $ sets $ \ RW { .. } -> ((), RW { iCts = gs, .. })
simpGoal :: Goal -> InferM [Goal]
simpGoal g =
case Simple.simplify Map.empty (goal g) of
p | Just e <- tIsError p ->
do recordError $ ErrorMsg $ text $ tcErrorMessage e
return []
| ps <- pSplitAnd p -> return [ g { goal = pr } | pr <- ps ]
simpGoals :: [Goal] -> InferM [Goal]
simpGoals gs = concat <$> mapM simpGoal gs
{- | Record a constraint that when we select from the first type,
we should get a value of the second type.
The returned function should be used to wrap the expression from
which we are selecting (i.e., the record or tuple). Plese note
that the resulting expression should not be forced before the
constraint is solved.
-}
newHasGoal :: P.Selector -> Type -> Type -> InferM HasGoalSln
newHasGoal l ty f =
do goalName <- newGoalName
g <- newGoal CtSelector (pHas l ty f)
IM $ sets_ $ \s -> s { iHasCts = HasGoal goalName g : iHasCts s }
solns <- IM $ fmap iSolvedHasLazy ask
return $ case Map.lookup goalName solns of
Just e1 -> e1
Nothing -> panic "newHasGoal" ["Unsolved has goal in result"]
-- | Add a previously generate has constrained
addHasGoal :: HasGoal -> InferM ()
addHasGoal g = IM $ sets_ $ \s -> s { iHasCts = g : iHasCts s }
-- | Get the `Has` constraints. Each of this should either be solved,
-- or added back using `addHasGoal`.
getHasGoals :: InferM [HasGoal]
getHasGoals = do gs <- IM $ sets $ \s -> (iHasCts s, s { iHasCts = [] })
applySubst gs
-- | Specify the solution (`Expr -> Expr`) for the given constraint (`Int`).
solveHasGoal :: Int -> HasGoalSln -> InferM ()
solveHasGoal n e =
IM $ sets_ $ \s -> s { iSolvedHas = Map.insert n e (iSolvedHas s) }
--------------------------------------------------------------------------------
-- | Generate a fresh variable name to be used in a local binding.
newParamName :: Ident -> InferM Name
newParamName x =
do r <- curRange
liftSupply (mkParameter x r)
newName :: (NameSeeds -> (a , NameSeeds)) -> InferM a
newName upd = IM $ sets $ \s -> let (x,seeds) = upd (iNameSeeds s)
in (x, s { iNameSeeds = seeds })
-- | Generate a new name for a goal.
newGoalName :: InferM Int
newGoalName = newName $ \s -> let x = seedGoal s
in (x, s { seedGoal = x + 1})
-- | Generate a new free type variable.
newTVar :: TVarSource -> Kind -> InferM TVar
newTVar src k = newTVar' src Set.empty k
-- | Generate a new free type variable that depends on these additional
-- type parameters.
newTVar' :: TVarSource -> Set TParam -> Kind -> InferM TVar
newTVar' src extraBound k =
do r <- curRange
bound <- getBoundInScope
let vs = Set.union extraBound bound
msg = TVarInfo { tvarDesc = src, tvarSource = r }
newName $ \s -> let x = seedTVar s
in (TVFree x k vs msg, s { seedTVar = x + 1 })
-- | Generate a new free type variable.
newTParam :: P.TParam Name -> TPFlavor -> Kind -> InferM TParam
newTParam nm flav k = newName $ \s ->
let x = seedTVar s
in (TParam { tpUnique = x
, tpKind = k
, tpFlav = flav
, tpInfo = desc
}
, s { seedTVar = x + 1 })
where desc = TVarInfo { tvarDesc = TVFromSignature (P.tpName nm)
, tvarSource = fromMaybe emptyRange (P.tpRange nm)
}
-- | Generate an unknown type. The doc is a note about what is this type about.
newType :: TVarSource -> Kind -> InferM Type
newType src k = TVar `fmap` newTVar src k
--------------------------------------------------------------------------------
-- | Record that the two types should be syntactically equal.
unify :: Type -> Type -> InferM [Prop]
unify t1 t2 =
do t1' <- applySubst t1
t2' <- applySubst t2
let ((su1, ps), errs) = runResult (mgu t1' t2')
extendSubst su1
let toError :: UnificationError -> Error
toError err =
case err of
UniTypeLenMismatch _ _ -> TypeMismatch t1' t2'
UniTypeMismatch s1 s2 -> TypeMismatch s1 s2
UniKindMismatch k1 k2 -> KindMismatch k1 k2
UniRecursive x t -> RecursiveType (TVar x) t
UniNonPolyDepends x vs -> TypeVariableEscaped (TVar x) vs
UniNonPoly x t -> NotForAll x t
case errs of
[] -> return ps
_ -> do mapM_ (recordError . toError) errs
return []
-- | Apply the accumulated substitution to something with free type variables.
applySubst :: TVars t => t -> InferM t
applySubst t =
do su <- getSubst
return (apSubst su t)
applySubstPreds :: [Prop] -> InferM [Prop]
applySubstPreds ps =
do ps1 <- applySubst ps
return (concatMap pSplitAnd ps1)
applySubstGoals :: [Goal] -> InferM [Goal]
applySubstGoals gs =
do gs1 <- applySubst gs
return [ g { goal = p } | g <- gs1, p <- pSplitAnd (goal g) ]
-- | Get the substitution that we have accumulated so far.
getSubst :: InferM Subst
getSubst = IM $ fmap iSubst get
-- | Add to the accumulated substitution, checking that the datatype
-- invariant for `Subst` is maintained.
extendSubst :: Subst -> InferM ()
extendSubst su =
do mapM_ check (substToList su)
IM $ sets_ $ \s -> s { iSubst = su @@ iSubst s }
where
check :: (TVar, Type) -> InferM ()
check (v, ty) =
case v of
TVBound _ ->
panic "Cryptol.TypeCheck.Monad.extendSubst"
[ "Substitution instantiates bound variable:"
, "Variable: " ++ show (pp v)
, "Type: " ++ show (pp ty)
]
TVFree _ _ tvs _ ->
do let bounds tv =
case tv of
TVBound tp -> Set.singleton tp
TVFree _ _ tps _ -> tps
let vars = Set.unions (map bounds (Set.elems (fvs ty)))
-- (Set.filter isBoundTV (fvs ty))
let escaped = Set.difference vars tvs
if Set.null escaped then return () else
panic "Cryptol.TypeCheck.Monad.extendSubst"
[ "Escaped quantified variables:"
, "Substitution: " ++ show (pp v <+> text ":=" <+> pp ty)
, "Vars in scope: " ++ show (brackets (commaSep (map pp (Set.toList tvs))))
, "Escaped: " ++ show (brackets (commaSep (map pp (Set.toList escaped))))
]
-- | Variables that are either mentioned in the environment or in
-- a selector constraint.
varsWithAsmps :: InferM (Set TVar)
varsWithAsmps =
do env <- IM $ fmap (Map.elems . iVars) ask
fromEnv <- forM env $ \v ->
case v of
ExtVar sch -> getVars sch
CurSCC _ t -> getVars t
sels <- IM $ fmap (map (goal . hasGoal) . iHasCts) get
fromSels <- mapM getVars sels
fromEx <- (getVars . concatMap Map.elems) =<< IM (fmap iExistTVars get)
return (Set.unions fromEnv `Set.union` Set.unions fromSels
`Set.union` fromEx)
where
getVars x = fvs `fmap` applySubst x
--------------------------------------------------------------------------------
-- | Lookup the type of a variable.
lookupVar :: Name -> InferM VarType
lookupVar x =
do mb <- IM $ asks $ Map.lookup x . iVars
case mb of
Just t -> return t
Nothing ->
do mbNT <- lookupNewtype x
case mbNT of
Just nt -> return (ExtVar (newtypeConType nt))
Nothing ->
do mbParamFun <- lookupParamFun x
case mbParamFun of
Just pf -> return (ExtVar (mvpType pf))
Nothing -> panic "lookupVar" [ "Undefined type variable"
, show x]
-- | Lookup a type variable. Return `Nothing` if there is no such variable
-- in scope, in which case we must be dealing with a type constant.
lookupTParam :: Name -> InferM (Maybe TParam)
lookupTParam x = IM $ asks $ find this . iTVars
where this tp = tpName tp == Just x
-- | Lookup the definition of a type synonym.
lookupTSyn :: Name -> InferM (Maybe TySyn)
lookupTSyn x = fmap (fmap snd . Map.lookup x) getTSyns
-- | Lookup the definition of a newtype
lookupNewtype :: Name -> InferM (Maybe Newtype)
lookupNewtype x = fmap (fmap snd . Map.lookup x) getNewtypes
lookupAbstractType :: Name -> InferM (Maybe AbstractType)
lookupAbstractType x = fmap (fmap snd . Map.lookup x) getAbstractTypes
-- | Lookup the kind of a parameter type
lookupParamType :: Name -> InferM (Maybe ModTParam)
lookupParamType x = Map.lookup x <$> getParamTypes
-- | Lookup the schema for a parameter function.
lookupParamFun :: Name -> InferM (Maybe ModVParam)
lookupParamFun x = Map.lookup x <$> getParamFuns
-- | Check if we already have a name for this existential type variable and,
-- if so, return the definition. If not, try to create a new definition,
-- if this is allowed. If not, returns nothing.
existVar :: Name -> Kind -> InferM Type
existVar x k =
do scopes <- iExistTVars <$> IM get
case msum (map (Map.lookup x) scopes) of
Just ty -> return ty
Nothing ->
case scopes of
[] ->
do recordError $ ErrorMsg
$ text "Undefined type" <+> quotes (pp x)
<+> text (show x)
newType TypeErrorPlaceHolder k
sc : more ->
do ty <- newType TypeErrorPlaceHolder k
IM $ sets_ $ \s -> s{ iExistTVars = Map.insert x ty sc : more }
return ty
-- | Returns the type synonyms that are currently in scope.
getTSyns :: InferM (Map Name (DefLoc,TySyn))
getTSyns = IM $ asks iTSyns
-- | Returns the newtype declarations that are in scope.
getNewtypes :: InferM (Map Name (DefLoc,Newtype))
getNewtypes = IM $ asks iNewtypes
-- | Returns the abstract type declarations that are in scope.
getAbstractTypes :: InferM (Map Name (DefLoc,AbstractType))
getAbstractTypes = IM $ asks iAbstractTypes
-- | Returns the parameter functions declarations
getParamFuns :: InferM (Map Name ModVParam)
getParamFuns = IM $ asks iParamFuns
-- | Returns the abstract function declarations
getParamTypes :: InferM (Map Name ModTParam)
getParamTypes = IM $ asks iParamTypes
-- | Constraints on the module's parameters.
getParamConstraints :: InferM [Located Prop]
getParamConstraints = IM $ asks iParamConstraints
-- | Get the set of bound type variables that are in scope.
getTVars :: InferM (Set Name)
getTVars = IM $ asks $ Set.fromList . mapMaybe tpName . iTVars
-- | Return the keys of the bound variables that are in scope.
getBoundInScope :: InferM (Set TParam)
getBoundInScope =
do ro <- IM ask
let params = Set.fromList (map mtpParam (Map.elems (iParamTypes ro)))
bound = Set.fromList (iTVars ro)
return $! Set.union params bound
-- | Retrieve the value of the `mono-binds` option.
getMonoBinds :: InferM Bool
getMonoBinds = IM (asks iMonoBinds)
{- | We disallow shadowing between type synonyms and type variables
because it is confusing. As a bonus, in the implementation we don't
need to worry about where we lookup things (i.e., in the variable or
type synonym environment. -}
checkTShadowing :: String -> Name -> InferM ()
checkTShadowing this new =
do ro <- IM ask
rw <- IM get
let shadowed =
do _ <- Map.lookup new (iTSyns ro)
return "type synonym"
`mplus`
do guard (new `elem` mapMaybe tpName (iTVars ro))
return "type variable"
`mplus`
do _ <- msum (map (Map.lookup new) (iExistTVars rw))
return "type"
case shadowed of
Nothing -> return ()
Just that ->
recordError $ ErrorMsg $
text "Type" <+> text this <+> quotes (pp new) <+>
text "shadows an existing" <+>
text that <+> text "with the same name."
-- | The sub-computation is performed with the given type parameter in scope.
withTParam :: TParam -> InferM a -> InferM a
withTParam p (IM m) =
do case tpName p of
Just x -> checkTShadowing "variable" x
Nothing -> return ()
IM $ mapReader (\r -> r { iTVars = p : iTVars r }) m
withTParams :: [TParam] -> InferM a -> InferM a
withTParams ps m = foldr withTParam m ps
-- | The sub-computation is performed with the given type-synonym in scope.
withTySyn :: TySyn -> InferM a -> InferM a
withTySyn t (IM m) =
do let x = tsName t
checkTShadowing "synonym" x
IM $ mapReader (\r -> r { iTSyns = Map.insert x (IsLocal,t) (iTSyns r) }) m
withNewtype :: Newtype -> InferM a -> InferM a
withNewtype t (IM m) =
IM $ mapReader
(\r -> r { iNewtypes = Map.insert (ntName t) (IsLocal,t)
(iNewtypes r) }) m
withPrimType :: AbstractType -> InferM a -> InferM a
withPrimType t (IM m) =
IM $ mapReader
(\r -> r { iAbstractTypes = Map.insert (atName t) (IsLocal,t)
(iAbstractTypes r) }) m
withParamType :: ModTParam -> InferM a -> InferM a
withParamType a (IM m) =
IM $ mapReader
(\r -> r { iParamTypes = Map.insert (mtpName a) a (iParamTypes r) })
m
-- | The sub-computation is performed with the given variable in scope.
withVarType :: Name -> VarType -> InferM a -> InferM a
withVarType x s (IM m) =
IM $ mapReader (\r -> r { iVars = Map.insert x s (iVars r) }) m
withVarTypes :: [(Name,VarType)] -> InferM a -> InferM a
withVarTypes xs m = foldr (uncurry withVarType) m xs
withVar :: Name -> Schema -> InferM a -> InferM a
withVar x s = withVarType x (ExtVar s)
-- | The sub-computation is performed with the given abstract function in scope.
withParamFuns :: [ModVParam] -> InferM a -> InferM a
withParamFuns xs (IM m) =
IM $ mapReader (\r -> r { iParamFuns = foldr add (iParamFuns r) xs }) m
where
add x = Map.insert (mvpName x) x
-- | Add some assumptions for an entire module
withParameterConstraints :: [Located Prop] -> InferM a -> InferM a
withParameterConstraints ps (IM m) =
IM $ mapReader (\r -> r { iParamConstraints = ps ++ iParamConstraints r }) m
-- | The sub-computation is performed with the given variables in scope.
withMonoType :: (Name,Located Type) -> InferM a -> InferM a
withMonoType (x,lt) = withVar x (Forall [] [] (thing lt))
-- | The sub-computation is performed with the given variables in scope.
withMonoTypes :: Map Name (Located Type) -> InferM a -> InferM a
withMonoTypes xs m = foldr withMonoType m (Map.toList xs)
-- | The sub-computation is performed with the given type synonyms
-- and variables in scope.
withDecls :: ([TySyn], Map Name Schema) -> InferM a -> InferM a
withDecls (ts,vs) m = foldr withTySyn (foldr add m (Map.toList vs)) ts
where
add (x,t) = withVar x t
-- | Perform the given computation in a new scope (i.e., the subcomputation
-- may use existential type variables).
inNewScope :: InferM a -> InferM a
inNewScope m =
do curScopes <- iExistTVars <$> IM get
IM $ sets_ $ \s -> s { iExistTVars = Map.empty : curScopes }
a <- m
IM $ sets_ $ \s -> s { iExistTVars = curScopes }
return a
--------------------------------------------------------------------------------
-- Kind checking
newtype KindM a = KM { unKM :: ReaderT KRO (StateT KRW InferM) a }
data KRO = KRO { lazyTParams :: Map Name TParam -- ^ lazy map, with tparams.
, allowWild :: AllowWildCards -- ^ are type-wild cards allowed?
}
-- | Do we allow wild cards in the given context.
data AllowWildCards = AllowWildCards | NoWildCards
data KRW = KRW { typeParams :: Map Name Kind -- ^ kinds of (known) vars.
, kCtrs :: [(ConstraintSource,[Prop])]
}
instance Functor KindM where
fmap f (KM m) = KM (fmap f m)
instance A.Applicative KindM where
pure = return
(<*>) = ap
instance Monad KindM where
return x = KM (return x)
fail x = KM (fail x)
KM m >>= k = KM (m >>= unKM . k)
{- | The arguments to this function are as follows:
(type param. name, kind signature (opt.), type parameter)
The type parameter is just a thunk that we should not force.
The reason is that the parameter depends on the kind that we are
in the process of computing.
As a result we return the value of the sub-computation and the computed
kinds of the type parameters. -}
runKindM :: AllowWildCards -- Are type-wild cards allowed?
-> [(Name, Maybe Kind, TParam)] -- ^ See comment
-> KindM a -> InferM (a, Map Name Kind, [(ConstraintSource,[Prop])])
runKindM wildOK vs (KM m) =
do (a,kw) <- runStateT krw (runReaderT kro m)
return (a, typeParams kw, kCtrs kw)
where
tps = Map.fromList [ (x,t) | (x,_,t) <- vs ]
kro = KRO { allowWild = wildOK, lazyTParams = tps }
krw = KRW { typeParams = Map.fromList [ (x,k) | (x,Just k,_) <- vs ]
, kCtrs = []
}
-- | This is what's returned when we lookup variables during kind checking.
data LkpTyVar = TLocalVar TParam (Maybe Kind) -- ^ Locally bound variable.
| TOuterVar TParam -- ^ An outer binding.
-- | Check if a name refers to a type variable.
kLookupTyVar :: Name -> KindM (Maybe LkpTyVar)
kLookupTyVar x = KM $
do vs <- lazyTParams `fmap` ask
ss <- get
case Map.lookup x vs of
Just t -> return $ Just $ TLocalVar t $ Map.lookup x $ typeParams ss
Nothing -> lift $ lift $ do t <- lookupTParam x
return (fmap TOuterVar t)
-- | Are type wild-cards OK in this context?
kWildOK :: KindM AllowWildCards
kWildOK = KM $ fmap allowWild ask
-- | Reports an error.
kRecordError :: Error -> KindM ()
kRecordError e = kInInferM $ recordError e
kRecordWarning :: Warning -> KindM ()
kRecordWarning w = kInInferM $ recordWarning w
kIO :: IO a -> KindM a
kIO m = KM $ lift $ lift $ io m
-- | Generate a fresh unification variable of the given kind.
-- NOTE: We do not simplify these, because we end up with bottom.
-- See `Kind.hs`
-- XXX: Perhaps we can avoid the recursion?
kNewType :: TVarSource -> Kind -> KindM Type
kNewType src k =
do tps <- KM $ do vs <- asks lazyTParams
return $ Set.fromList (Map.elems vs)
kInInferM $ TVar `fmap` newTVar' src tps k
-- | Lookup the definition of a type synonym.
kLookupTSyn :: Name -> KindM (Maybe TySyn)
kLookupTSyn x = kInInferM $ lookupTSyn x
-- | Lookup the definition of a newtype.
kLookupNewtype :: Name -> KindM (Maybe Newtype)
kLookupNewtype x = kInInferM $ lookupNewtype x
kLookupParamType :: Name -> KindM (Maybe ModTParam)
kLookupParamType x = kInInferM (lookupParamType x)
kLookupAbstractType :: Name -> KindM (Maybe AbstractType)
kLookupAbstractType x = kInInferM $ lookupAbstractType x
kExistTVar :: Name -> Kind -> KindM Type
kExistTVar x k = kInInferM $ existVar x k
-- | Replace the given bound variables with concrete types.
kInstantiateT :: Type -> [(TParam, Type)] -> KindM Type
kInstantiateT t as = return (apSubst su t)
where su = listParamSubst as
{- | Record the kind for a local type variable.
This assumes that we already checked that there was no other valid
kind for the variable (if there was one, it gets over-written). -}
kSetKind :: Name -> Kind -> KindM ()
kSetKind v k = KM $ sets_ $ \s -> s{ typeParams = Map.insert v k (typeParams s)}
-- | The sub-computation is about the given range of the source code.
kInRange :: Range -> KindM a -> KindM a
kInRange r (KM m) = KM $
do e <- ask
s <- get
(a,s1) <- lift $ lift $ inRange r $ runStateT s $ runReaderT e m
set s1
return a
kNewGoals :: ConstraintSource -> [Prop] -> KindM ()
kNewGoals _ [] = return ()
kNewGoals c ps = KM $ sets_ $ \s -> s { kCtrs = (c,ps) : kCtrs s }
kInInferM :: InferM a -> KindM a
kInInferM m = KM $ lift $ lift m
cryptol-2.8.0/src/Cryptol/TypeCheck/PP.hs 0000644 0000000 0000000 00000003273 07346545000 016370 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.PP
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
module Cryptol.TypeCheck.PP
( NameMap, WithNames(..)
, emptyNameMap
, ppWithNamesPrec, ppWithNames
, nameList
, dump
, module Cryptol.Utils.PP
) where
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List(transpose)
import Cryptol.Utils.PP
type NameMap = IntMap String
emptyNameMap :: NameMap
emptyNameMap = IntMap.empty
-- | This packages together a type with some names to be used to display
-- the variables. It is used for pretty printing types.
data WithNames a = WithNames a NameMap
ppWithNamesPrec :: PP (WithNames a) => NameMap -> Int -> a -> Doc
ppWithNamesPrec names prec t = ppPrec prec (WithNames t names)
ppWithNames :: PP (WithNames a) => NameMap -> a -> Doc
ppWithNames names t = ppWithNamesPrec names 0 t
dump :: PP (WithNames a) => a -> String
dump x = show (ppWithNames IntMap.empty x)
-- | Compute the n-th variant of a name (e.g., @a5@).
nameVariant :: Int -> String -> String
nameVariant 0 x = x
nameVariant n x = x ++ show n
-- | Compute all variants of a name: @a, a1, a2, a3, ...@
nameVariants :: String -> [String]
nameVariants x = map (`nameVariant` x) [ 0 .. ]
-- | Expand a list of base names into an infinite list of variations.
nameList :: [String] -> [String]
nameList names = concat $ transpose $ map nameVariants baseNames
where
baseNames | null names = map (:[]) [ 'a' .. 'z' ]
| otherwise = names
cryptol-2.8.0/src/Cryptol/TypeCheck/Parseable.hs 0000644 0000000 0000000 00000012353 07346545000 017746 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Parseable
-- Copyright : (c) 2013-2017 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
module Cryptol.TypeCheck.Parseable
( module Cryptol.TypeCheck.Parseable
, ShowParseable(..)
) where
import Cryptol.TypeCheck.AST
import Cryptol.Utils.Ident (Ident,unpackIdent)
import Cryptol.Parser.AST ( Located(..))
import Cryptol.ModuleSystem.Name
import Text.PrettyPrint hiding ((<>))
import qualified Text.PrettyPrint as PP ((<>))
-- ShowParseable prints out a cryptol program in a way that it's parseable by Coq (and likely other things)
-- Used mainly for reasoning about the semantics of cryptol programs in Coq (https://github.com/GaloisInc/cryptol-semantics)
class ShowParseable t where
showParseable :: t -> Doc
instance ShowParseable Expr where
showParseable (EList es _) = parens (text "EList" <+> showParseable es)
showParseable (ETuple es) = parens (text "ETuple" <+> showParseable es)
showParseable (ERec ides) = parens (text "ERec" <+> showParseable ides)
showParseable (ESel e s) = parens (text "ESel" <+> showParseable e <+> showParseable s)
showParseable (ESet e s v) = parens (text "ESet" <+>
showParseable e <+> showParseable s
<+> showParseable v)
showParseable (EIf c t f) = parens (text "EIf" <+> showParseable c $$ showParseable t $$ showParseable f)
showParseable (EComp _ _ e mss) = parens (text "EComp" $$ showParseable e $$ showParseable mss)
showParseable (EVar n) = parens (text "EVar" <+> showParseable n)
showParseable (EApp fe ae) = parens (text "EApp" $$ showParseable fe $$ showParseable ae)
showParseable (EAbs n _ e) = parens (text "EAbs" <+> showParseable n $$ showParseable e)
showParseable (EWhere e dclg) = parens (text "EWhere" $$ showParseable e $$ showParseable dclg)
showParseable (ETAbs tp e) = parens (text "ETAbs" <+> showParseable tp
$$ showParseable e)
showParseable (ETApp e t) = parens (text "ETApp" $$ showParseable e $$ parens (text "ETyp" <+> showParseable t))
--NOTE: erase all "proofs" for now (change the following two lines to change that)
showParseable (EProofAbs {-p-}_ e) = showParseable e --"(EProofAbs " ++ show p ++ showParseable e ++ ")"
showParseable (EProofApp e) = showParseable e --"(EProofApp " ++ showParseable e ++ ")"
instance (ShowParseable a, ShowParseable b) => ShowParseable (a,b) where
showParseable (x,y) = parens (showParseable x PP.<> comma PP.<> showParseable y)
instance ShowParseable Int where
showParseable i = int i
instance ShowParseable Ident where
showParseable i = text $ show $ unpackIdent i
instance ShowParseable Type where
showParseable (TUser n lt t) = parens (text "TUser" <+> showParseable n <+> showParseable lt <+> showParseable t)
showParseable (TRec lidt) = parens (text "TRec" <+> showParseable lidt)
showParseable t = parens $ text $ show t
instance ShowParseable Selector where
showParseable (TupleSel n _) = parens (text "TupleSel" <+> showParseable n)
showParseable (RecordSel n _) = parens (text "RecordSel" <+> showParseable n)
showParseable (ListSel n _) = parens (text "ListSel" <+> showParseable n)
instance ShowParseable Match where
showParseable (From n _ _ e) = parens (text "From" <+> showParseable n <+> showParseable e)
showParseable (Let d) = parens (text "MLet" <+> showParseable d)
instance ShowParseable Decl where
showParseable d = parens (text "Decl" <+> showParseable (dName d)
$$ showParseable (dDefinition d))
instance ShowParseable DeclDef where
showParseable DPrim = text (show DPrim)
showParseable (DExpr e) = parens (text "DExpr" $$ showParseable e)
instance ShowParseable DeclGroup where
showParseable (Recursive ds) =
parens (text "Recursive" $$ showParseable ds)
showParseable (NonRecursive d) =
parens (text "NonRecursive" $$ showParseable d)
instance (ShowParseable a) => ShowParseable [a] where
showParseable a = case a of
[] -> text "[]"
[x] -> brackets (showParseable x)
x : xs -> text "[" <+> showParseable x $$
vcat [ comma <+> showParseable y | y <- xs ] $$
text "]"
instance (ShowParseable a) => ShowParseable (Maybe a) where
showParseable Nothing = text "(0,\"\")" --empty ident, won't shadow number
showParseable (Just x) = showParseable x
instance (ShowParseable a) => ShowParseable (Located a) where
showParseable l = showParseable (thing l)
instance ShowParseable TParam where
showParseable tp = parens (text (show (tpUnique tp)) PP.<> comma PP.<> maybeNameDoc (tpName tp))
maybeNameDoc :: Maybe Name -> Doc
maybeNameDoc Nothing = doubleQuotes empty
maybeNameDoc (Just n) = showParseable (nameIdent n)
instance ShowParseable Name where
showParseable n = parens (text (show (nameUnique n)) PP.<> comma PP.<> showParseable (nameIdent n))
cryptol-2.8.0/src/Cryptol/TypeCheck/Sanity.hs 0000644 0000000 0000000 00000037447 07346545000 017332 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Sanity
-- Copyright : (c) 2015-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
module Cryptol.TypeCheck.Sanity
( tcExpr
, tcDecls
, tcModule
, ProofObligation
, Error(..)
, same
) where
import Cryptol.Parser.Position(thing)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Subst (apSubst, singleSubst)
import Cryptol.TypeCheck.Monad(InferInput(..))
import Cryptol.Utils.Ident
import qualified Data.Set as Set
import Data.List (sort, sortBy)
import Data.Function (on)
import MonadLib
import qualified Control.Applicative as A
import Data.Map ( Map )
import qualified Data.Map as Map
tcExpr :: InferInput -> Expr -> Either Error (Schema, [ ProofObligation ])
tcExpr env e = runTcM env (exprSchema e)
tcDecls :: InferInput -> [DeclGroup] -> Either Error [ ProofObligation ]
tcDecls env ds0 = case runTcM env (checkDecls ds0) of
Left err -> Left err
Right (_,ps) -> Right ps
tcModule :: InferInput -> Module -> Either Error [ ProofObligation ]
tcModule env m = case runTcM env check of
Left err -> Left err
Right (_,ps) -> Right ps
where check = foldr withTVar k1 (map mtpParam (Map.elems (mParamTypes m)))
k1 = foldr withAsmp k2 (map thing (mParamConstraints m))
k2 = withVars (Map.toList (fmap mvpType (mParamFuns m)))
$ checkDecls (mDecls m)
--------------------------------------------------------------------------------
checkDecls :: [DeclGroup] -> TcM ()
checkDecls decls =
case decls of
[] -> return ()
d : ds -> do xs <- checkDeclGroup d
withVars xs (checkDecls ds)
-- | Validate a type, returning its kind.
checkType :: Type -> TcM Kind
checkType ty =
case ty of
TUser _ _ t -> checkType t -- Maybe check synonym too?
TCon tc ts ->
do ks <- mapM checkType ts
checkKind (kindOf tc) ks
TVar tv -> lookupTVar tv
TRec fs ->
do forM_ fs $ \(_,t) ->
do k <- checkType t
unless (k == KType) $ reportError $ KindMismatch KType k
return KType
where
checkKind k [] = case k of
_ :-> _ -> reportError $ NotEnoughArgumentsInKind k
KProp -> return k
KNum -> return k
KType -> return k
checkKind (k1 :-> k2) (k : ks)
| k == k1 = checkKind k2 ks
| otherwise = reportError $ KindMismatch k1 k
checkKind k ks = reportError $ BadTypeApplication k ks
-- | Check that the type is valid, and it has the given kind.
checkTypeIs :: Kind -> Type -> TcM ()
checkTypeIs k ty =
do k1 <- checkType ty
unless (k == k1) $ reportError $ KindMismatch k k1
-- | Check that this is a valid schema.
checkSchema :: Schema -> TcM ()
checkSchema (Forall as ps t) = foldr withTVar check as
where check = do mapM_ (checkTypeIs KProp) ps
checkTypeIs KType t
class Same a where
same :: a -> a -> Bool
instance Same a => Same [a] where
same [] [] = True
same (x : xs) (y : ys) = same x y && same xs ys
same _ _ = False
instance Same Type where
same t1 t2 = tNoUser t1 == tNoUser t2
instance Same Schema where
same (Forall xs ps s) (Forall ys qs t) = same xs ys && same ps qs && same s t
instance Same TParam where
same x y = tpName x == tpName y && tpKind x == tpKind y
--------------------------------------------------------------------------------
-- | Check that the expression is well-formed, and compute its type.
-- Reports an error if the expression is not of a mono type.
exprType :: Expr -> TcM Type
exprType expr =
do s <- exprSchema expr
case isMono s of
Just t -> return t
Nothing -> reportError (ExpectedMono s)
-- | Check that the expression is well-formed, and compute its schema.
exprSchema :: Expr -> TcM Schema
exprSchema expr =
case expr of
EList es t ->
do checkTypeIs KType t
forM_ es $ \e ->
do t1 <- exprType e
unless (same t1 t) $
reportError $ TypeMismatch "EList" (tMono t) (tMono t1)
return $ tMono $ tSeq (tNum (length es)) t
ETuple es ->
fmap (tMono . tTuple) (mapM exprType es)
ERec fs ->
do fs1 <- forM fs $ \(f,e) -> do t <- exprType e
return (f,t)
return $ tMono $ TRec fs1
ESet e x v -> do ty <- exprType e
expe <- checkHas ty x
has <- exprType v
unless (same expe has) $
reportError $
TypeMismatch "ESet" (tMono expe) (tMono has)
return (tMono ty)
ESel e sel -> do ty <- exprType e
ty1 <- checkHas ty sel
return (tMono ty1)
EIf e1 e2 e3 ->
do ty <- exprType e1
unless (same tBit ty) $
reportError $ TypeMismatch "EIf_condition" (tMono tBit) (tMono ty)
t1 <- exprType e2
t2 <- exprType e3
unless (same t1 t2) $
reportError $ TypeMismatch "EIf_arms" (tMono t1) (tMono t2)
return $ tMono t1
EComp len t e mss ->
do checkTypeIs KNum len
checkTypeIs KType t
(xs,ls) <- unzip `fmap` mapM checkArm mss
-- XXX: check no duplicates
elT <- withVars (concat xs) $ exprType e
case ls of
[] -> return ()
_ -> convertible (tSeq len t) (tSeq (foldr1 tMin ls) elT)
return (tMono (tSeq len t))
EVar x -> lookupVar x
ETAbs a e ->
do Forall as p t <- withTVar a (exprSchema e)
when (any (== a) as) $
reportError $ RepeatedVariableInForall a
return (Forall (a : as) p t)
ETApp e t ->
do k <- checkType t
s <- exprSchema e
case s of
Forall (a : as) ps t1 ->
do let vs = fvs t
forM_ (map tpVar as) $ \b ->
when (b `Set.member` vs) $ reportError $ Captured b
let k' = kindOf a
unless (k == k') $ reportError $ KindMismatch k' k
let su = singleSubst (tpVar a) t
return $ Forall as (apSubst su ps) (apSubst su t1)
Forall [] _ _ -> reportError BadInstantiation
EApp e1 e2 ->
do t1 <- exprType e1
t2 <- exprType e2
case tNoUser t1 of
TCon (TC TCFun) [ a, b ]
| same a t2 -> return (tMono b)
tf -> reportError (BadApplication tf t1)
EAbs x t e ->
do checkTypeIs KType t
res <- withVar x t (exprType e)
return $ tMono $ tFun t res
EProofAbs p e ->
do checkTypeIs KProp p
withAsmp p $ do Forall as ps t <- exprSchema e
return $ Forall as (p : ps) t
EProofApp e ->
do Forall as ps t <- exprSchema e
case (as,ps) of
([], p:qs) -> do proofObligation p
return (Forall [] qs t)
([], _) -> reportError BadProofNoAbs
(_,_) -> reportError (BadProofTyVars as)
-- XXX: Check that defined things are distinct?
EWhere e dgs ->
let go [] = exprSchema e
go (d : ds) = do xs <- checkDeclGroup d
withVars xs (go ds)
in go dgs
checkHas :: Type -> Selector -> TcM Type
checkHas t sel =
case sel of
TupleSel n mb ->
case tNoUser t of
TCon (TC (TCTuple sz)) ts ->
do case mb of
Just sz1 ->
when (sz /= sz1) (reportError (UnexpectedTupleShape sz1 sz))
Nothing -> return ()
unless (n < sz) $ reportError (TupleSelectorOutOfRange n sz)
return $ ts !! n
TCon (TC TCSeq) [s,elT] ->
do res <- checkHas elT sel
return (TCon (TC TCSeq) [s,res])
TCon (TC TCFun) [a,b] ->
do res <- checkHas b sel
return (TCon (TC TCFun) [a,res])
_ -> reportError $ BadSelector sel t
RecordSel f mb ->
case tNoUser t of
TRec fs ->
do case mb of
Nothing -> return ()
Just fs1 ->
do let ns = sort (map fst fs)
ns1 = sort fs1
unless (ns == ns1) $
reportError $ UnexpectedRecordShape ns1 ns
case lookup f fs of
Nothing -> reportError $ MissingField f $ map fst fs
Just ft -> return ft
TCon (TC TCSeq) [s,elT] -> do res <- checkHas elT sel
return (TCon (TC TCSeq) [s,res])
TCon (TC TCFun) [a,b] -> do res <- checkHas b sel
return (TCon (TC TCFun) [a,res])
_ -> reportError $ BadSelector sel t
-- XXX: Remove this?
ListSel _ mb ->
case tNoUser t of
TCon (TC TCSeq) [ n, elT ] ->
do case mb of
Nothing -> return ()
Just len ->
case tNoUser n of
TCon (TC (TCNum m)) []
| m == toInteger len -> return ()
_ -> reportError $ UnexpectedSequenceShape len n
return elT
_ -> reportError $ BadSelector sel t
-- | Check if the one type is convertible to the other.
convertible :: Type -> Type -> TcM ()
convertible t1 t2
| k1 /= k2 = reportError (KindMismatch k1 k2)
| k1 == KNum = proofObligation (t1 =#= t2)
where
k1 = kindOf t1
k2 = kindOf t2
convertible t1 t2 = go t1 t2
where
go ty1 ty2 =
let err = reportError $ TypeMismatch "convertible" (tMono ty1) (tMono ty2)
other = tNoUser ty2
goMany [] [] = return ()
goMany (x : xs) (y : ys) = convertible x y >> goMany xs ys
goMany _ _ = err
in case ty1 of
TUser _ _ s -> go s ty2
TVar x -> case other of
TVar y | x == y -> return ()
_ -> err
TCon tc1 ts1 -> case other of
TCon tc2 ts2
| tc1 == tc2 -> goMany ts1 ts2
_ -> err
TRec fs ->
case other of
TRec gs ->
do let order = sortBy (compare `on` fst)
fs1 = order fs
gs1 = order gs
unless (map fst fs1 == map fst gs1) err
goMany (map snd fs1) (map snd gs1)
_ -> err
--------------------------------------------------------------------------------
-- | Check a declaration. The boolean indicates if we should check the siganture
checkDecl :: Bool -> Decl -> TcM (Name, Schema)
checkDecl checkSig d =
case dDefinition d of
DPrim ->
do when checkSig $ checkSchema $ dSignature d
return (dName d, dSignature d)
DExpr e ->
do let s = dSignature d
when checkSig $ checkSchema s
s1 <- exprSchema e
unless (same s s1) $
reportError $ TypeMismatch "DExpr" s s1
return (dName d, s)
checkDeclGroup :: DeclGroup -> TcM [(Name, Schema)]
checkDeclGroup dg =
case dg of
NonRecursive d -> do x <- checkDecl True d
return [x]
Recursive ds ->
do xs <- forM ds $ \d ->
do checkSchema (dSignature d)
return (dName d, dSignature d)
withVars xs $ mapM (checkDecl False) ds
checkMatch :: Match -> TcM ((Name, Schema), Type)
checkMatch ma =
case ma of
From x len elt e ->
do checkTypeIs KNum len
checkTypeIs KType elt
t1 <- exprType e
case tNoUser t1 of
TCon (TC TCSeq) [ l, el ]
| same elt el -> return ((x, tMono elt), l)
| otherwise -> reportError $ TypeMismatch "From" (tMono elt) (tMono el)
_ -> reportError $ BadMatch t1
Let d -> do x <- checkDecl True d
return (x, tNum (1 :: Int))
checkArm :: [Match] -> TcM ([(Name, Schema)], Type)
checkArm [] = reportError EmptyArm
checkArm [m] = do (x,l) <- checkMatch m
return ([x], l)
checkArm (m : ms) =
do (x, l) <- checkMatch m
(xs, l1) <- withVars [x] $ checkArm ms
let newLen = tMul l l1
return $ if fst x `elem` map fst xs
then (xs, newLen)
else (x : xs, newLen)
--------------------------------------------------------------------------------
data RO = RO
{ roTVars :: Map Int TParam
, roAsmps :: [Prop]
, roVars :: Map Name Schema
}
type ProofObligation = Schema -- but the type is of kind Prop
data RW = RW
{ woProofObligations :: [ProofObligation]
}
newtype TcM a = TcM (ReaderT RO (ExceptionT Error (StateT RW Id)) a)
instance Functor TcM where
fmap = liftM
instance A.Applicative TcM where
pure = return
(<*>) = ap
instance Monad TcM where
return a = TcM (return a)
fail x = TcM (fail x)
TcM m >>= f = TcM (do a <- m
let TcM m1 = f a
m1)
runTcM :: InferInput -> TcM a -> Either Error (a, [ProofObligation])
runTcM env (TcM m) =
case runM m ro rw of
(Left err, _) -> Left err
(Right a, s) -> Right (a, woProofObligations s)
where
ro = RO { roTVars = Map.fromList [ (tpUnique x, x)
| tp <- Map.elems (inpParamTypes env)
, let x = mtpParam tp ]
, roAsmps = map thing (inpParamConstraints env)
, roVars = Map.union
(fmap mvpType (inpParamFuns env))
(inpVars env)
}
rw = RW { woProofObligations = [] }
data Error =
TypeMismatch String Schema Schema -- ^ expected, actual
| ExpectedMono Schema -- ^ expected a mono type, got this
| TupleSelectorOutOfRange Int Int
| MissingField Ident [Ident]
| UnexpectedTupleShape Int Int
| UnexpectedRecordShape [Ident] [Ident]
| UnexpectedSequenceShape Int Type
| BadSelector Selector Type
| BadInstantiation
| Captured TVar
| BadProofNoAbs
| BadProofTyVars [TParam]
| KindMismatch Kind Kind
| NotEnoughArgumentsInKind Kind
| BadApplication Type Type
| FreeTypeVariable TVar
| BadTypeApplication Kind [Kind]
| RepeatedVariableInForall TParam
| BadMatch Type
| EmptyArm
| UndefinedTypeVaraible TVar
| UndefinedVariable Name
deriving Show
reportError :: Error -> TcM a
reportError e = TcM (raise e)
withTVar :: TParam -> TcM a -> TcM a
withTVar a (TcM m) = TcM $
do ro <- ask
local ro { roTVars = Map.insert (tpUnique a) a (roTVars ro) } m
withAsmp :: Prop -> TcM a -> TcM a
withAsmp p (TcM m) = TcM $
do ro <- ask
local ro { roAsmps = p : roAsmps ro } m
withVar :: Name -> Type -> TcM a -> TcM a
withVar x t = withVars [(x,tMono t)]
withVars :: [(Name, Schema)] -> TcM a -> TcM a
withVars xs (TcM m) = TcM $
do ro <- ask
local ro { roVars = Map.union (Map.fromList xs) (roVars ro) } m
proofObligation :: Prop -> TcM ()
proofObligation p = TcM $
do ro <- ask
sets_ $ \rw -> rw { woProofObligations =
Forall (Map.elems (roTVars ro)) (roAsmps ro) p
: woProofObligations rw }
lookupTVar :: TVar -> TcM Kind
lookupTVar x =
case x of
TVFree {} -> reportError (FreeTypeVariable x)
TVBound tpv ->
do let u = tpUnique tpv
k = tpKind tpv
ro <- TcM ask
case Map.lookup u (roTVars ro) of
Just tp
| kindOf tp == k -> return k
| otherwise -> reportError $ KindMismatch (kindOf tp) k
Nothing -> reportError $ UndefinedTypeVaraible x
lookupVar :: Name -> TcM Schema
lookupVar x =
do ro <- TcM ask
case Map.lookup x (roVars ro) of
Just s -> return s
Nothing -> reportError $ UndefinedVariable x
cryptol-2.8.0/src/Cryptol/TypeCheck/SimpType.hs 0000644 0000000 0000000 00000022752 07346545000 017626 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards #-}
module Cryptol.TypeCheck.SimpType where
import Control.Applicative((<|>))
import Cryptol.TypeCheck.Type hiding
(tSub,tMul,tDiv,tMod,tExp,tMin,tCeilDiv,tCeilMod,tLenFromThenTo)
import Cryptol.TypeCheck.TypePat
import Cryptol.TypeCheck.Solver.InfNat
import Control.Monad(msum,guard)
import Cryptol.TypeCheck.PP(pp)
tRebuild' :: Bool -> Type -> Type
tRebuild' withUser = go
where
go ty =
case ty of
TUser x xs t
| withUser -> TUser x xs (go t)
| otherwise -> go t
TVar _ -> ty
TRec xs -> TRec [ (x, go y) | (x, y) <- xs ]
TCon tc ts -> tCon tc (map go ts)
tRebuild :: Type -> Type
tRebuild = tRebuild' True
tCon :: TCon -> [Type] -> Type
tCon tc ts =
case tc of
TF f ->
case (f, ts) of
(TCAdd, [x, y]) -> tAdd x y
(TCSub, [x, y]) -> tSub x y
(TCMul, [x, y]) -> tMul x y
(TCExp, [x, y]) -> tExp x y
(TCDiv, [x, y]) -> tDiv x y
(TCMod, [x, y]) -> tMod x y
(TCMin, [x, y]) -> tMin x y
(TCMax, [x, y]) -> tMax x y
(TCWidth, [x]) -> tWidth x
(TCCeilDiv, [x, y]) -> tCeilDiv x y
(TCCeilMod, [x, y]) -> tCeilMod x y
(TCLenFromThenTo, [x, y, z]) -> tLenFromThenTo x y z
_ -> TCon tc ts
_ -> TCon tc ts
-- Normal: constants to the left
tAdd :: Type -> Type -> Type
tAdd x y
| Just t <- tOp TCAdd (total (op2 nAdd)) [x,y] = t
| tIsInf x = tInf
| tIsInf y = tInf
| Just n <- tIsNum x = addK n y
| Just n <- tIsNum y = addK n x
| Just (n,x1) <- isSumK x = addK n (tAdd x1 y)
| Just (n,y1) <- isSumK y = addK n (tAdd x y1)
| Just v <- matchMaybe (do (a,b) <- (|-|) y
guard (x == b)
return a) = v
| Just v <- matchMaybe (do (a,b) <- (|-|) x
guard (b == y)
return a) = v
| Just v <- matchMaybe (factor <|> same <|> swapVars) = v
| otherwise = tf2 TCAdd x y
where
isSumK t = case tNoUser t of
TCon (TF TCAdd) [ l, r ] ->
do n <- tIsNum l
return (n, r)
_ -> Nothing
addK 0 t = t
addK n t | Just (m,b) <- isSumK t = tf2 TCAdd (tNum (n + m)) b
| Just v <- matchMaybe
$ do (a,b) <- (|-|) t
(do m <- aNat b
return $ case compare n m of
GT -> tAdd (tNum (n-m)) a
EQ -> a
LT -> tSub a (tNum (m-n)))
<|>
(do m <- aNat a
return (tSub (tNum (m+n)) b))
= v
-- K + min a b ~> min (K + a) (K + b)
| Just v <- matchMaybe
$ do (a,b) <- aMin t
return $ tMin (tAdd (tNum n) a) (tAdd (tNum n) b)
= v
| otherwise = tf2 TCAdd (tNum n) t
factor = do (a,b1) <- aMul x
(a',b2) <- aMul y
guard (a == a')
return (tMul a (tAdd b1 b2))
same = do guard (x == y)
return (tMul (tNum (2 :: Int)) x)
swapVars = do a <- aTVar x
b <- aTVar y
guard (b < a)
return (tf2 TCAdd y x)
tSub :: Type -> Type -> Type
tSub x y
| Just t <- tOp TCSub (op2 nSub) [x,y] = t
| tIsInf y = tBadNumber $ TCErrorMessage "Subtraction of `inf`."
| Just 0 <- yNum = x
| Just k <- yNum
, TCon (TF TCAdd) [a,b] <- tNoUser x
, Just n <- tIsNum a = case compare k n of
EQ -> b
LT -> tf2 TCAdd (tNum (n - k)) b
GT -> tSub b (tNum (k - n))
| Just v <- matchMaybe (do (a,b) <- anAdd x
(guard (a == y) >> return b)
<|> (guard (b == y) >> return a))
= v
| Just v <- matchMaybe (do (a,b) <- (|-|) y
return (tSub (tAdd x b) a)) = v
| otherwise = tf2 TCSub x y
where
yNum = tIsNum y
-- Normal: constants to the left
tMul :: Type -> Type -> Type
tMul x y
| Just t <- tOp TCMul (total (op2 nMul)) [x,y] = t
| Just n <- tIsNum x = mulK n y
| Just n <- tIsNum y = mulK n x
| Just v <- matchMaybe swapVars = v
| otherwise = tf2 TCMul x y
where
mulK 0 _ = tNum (0 :: Int)
mulK 1 t = t
mulK n t | TCon (TF TCMul) [a,b] <- t'
, Just a' <- tIsNat' a = case a' of
Inf -> t
Nat m -> tf2 TCMul (tNum (n * m)) b
| TCon (TF TCDiv) [a,b] <- t'
, Just b' <- tIsNum b
-- XXX: similar for a = b * k?
, n == b' = tSub a (tMod a b)
| otherwise = tf2 TCMul (tNum n) t
where t' = tNoUser t
swapVars = do a <- aTVar x
b <- aTVar y
guard (b < a)
return (tf2 TCMul y x)
tDiv :: Type -> Type -> Type
tDiv x y
| Just t <- tOp TCDiv (op2 nDiv) [x,y] = t
| tIsInf x = tBadNumber $ TCErrorMessage "Division of `inf`."
| Just 0 <- tIsNum y = tBadNumber $ TCErrorMessage "Division by 0."
| otherwise = tf2 TCDiv x y
tMod :: Type -> Type -> Type
tMod x y
| Just t <- tOp TCMod (op2 nMod) [x,y] = t
| tIsInf x = tBadNumber $ TCErrorMessage "Modulus of `inf`."
| Just 0 <- tIsNum x = tBadNumber $ TCErrorMessage "Modulus by 0."
| otherwise = tf2 TCMod x y
tCeilDiv :: Type -> Type -> Type
tCeilDiv x y
| Just t <- tOp TCCeilDiv (op2 nCeilDiv) [x,y] = t
| tIsInf x = tBadNumber $ TCErrorMessage "CeilDiv of `inf`."
| tIsInf y = tBadNumber $ TCErrorMessage "CeilDiv by `inf`."
| Just 0 <- tIsNum y = tBadNumber $ TCErrorMessage "CeilDiv by 0."
| otherwise = tf2 TCCeilDiv x y
tCeilMod :: Type -> Type -> Type
tCeilMod x y
| Just t <- tOp TCCeilMod (op2 nCeilMod) [x,y] = t
| tIsInf x = tBadNumber $ TCErrorMessage "CeilMod of `inf`."
| tIsInf y = tBadNumber $ TCErrorMessage "CeilMod by `inf`."
| Just 0 <- tIsNum x = tBadNumber $ TCErrorMessage "CeilMod to size 0."
| otherwise = tf2 TCCeilMod x y
tExp :: Type -> Type -> Type
tExp x y
| Just t <- tOp TCExp (total (op2 nExp)) [x,y] = t
| Just 0 <- tIsNum y = tNum (1 :: Int)
| TCon (TF TCExp) [a,b] <- tNoUser y = tExp x (tMul a b)
| otherwise = tf2 TCExp x y
-- Normal: constants to the left
tMin :: Type -> Type -> Type
tMin x y
| Just t <- tOp TCMin (total (op2 nMin)) [x,y] = t
| Just n <- tIsNat' x = minK n y
| Just n <- tIsNat' y = minK n x
| Just n <- matchMaybe (minPlusK x y <|> minPlusK y x) = n
| Just n <- matchMaybe $ do (k,a) <- isMinK x
return $ minK k (tMin a y)
<|>
do (k,a) <- isMinK y
return $ minK k (tMin x a)
= n
| Just n <- matchMaybe $ do (k1,a) <- isAddK x
(k2,b) <- isAddK y
guard (a == b)
return $ tAdd (tNum (min k1 k2)) a
= n
| x == y = x
-- XXX: min (k + t) t -> t
| otherwise = tf2 TCMin x y
where
isAddK ty = do (a,b) <- anAdd ty
k <- aNat a
return (k,b)
isMinK ty = do (a,b) <- aMin ty
k <- aNat' a
return (k,b)
minPlusK a b = do (k,r) <- isAddK a
guard (k >= 1 && b == r)
return b
minK Inf t = t
minK (Nat 0) _ = tNum (0 :: Int)
minK (Nat k) t
| TCon (TF TCMin) [a,b] <- t'
, Just n <- tIsNum a = tf2 TCMin (tNum (min k n)) b
| otherwise = tf2 TCMin (tNum k) t
where t' = tNoUser t
-- Normal: constants to the left
tMax :: Type -> Type -> Type
tMax x y
| Just t <- tOp TCMax (total (op2 nMax)) [x,y] = t
| Just n <- tIsNat' x = maxK n y
| Just n <- tIsNat' y = maxK n x
| otherwise = tf2 TCMax x y
where
maxK Inf _ = tInf
maxK (Nat 0) t = t
maxK (Nat k) t
| TCon (TF TCAdd) [a,b] <- t'
, Just n <- tIsNum a = if k <= n
then t
else tAdd (tNum n) (tMax (tNum (k - n)) b)
| TCon (TF TCSub) [a,b] <- t'
, Just n <- tIsNat' a =
case n of
Inf -> t
Nat m -> if k >= m then tNum k else tSub a (tMin (tNum (m - k)) b)
| TCon (TF TCMax) [a,b] <- t'
, Just n <- tIsNum a = tf2 TCMax (tNum (max k n)) b
| otherwise = tf2 TCMax (tNum k) t
where t' = tNoUser t
tWidth :: Type -> Type
tWidth x
| Just t <- tOp TCWidth (total (op1 nWidth)) [x] = t
| otherwise = tf1 TCWidth x
tLenFromThenTo :: Type -> Type -> Type -> Type
tLenFromThenTo x y z
| Just t <- tOp TCLenFromThenTo (op3 nLenFromThenTo) [x,y,z] = t
| otherwise = tf3 TCLenFromThenTo x y z
total :: ([Nat'] -> Nat') -> ([Nat'] -> Maybe Nat')
total f xs = Just (f xs)
op1 :: (a -> b) -> [a] -> b
op1 f ~[x] = f x
op2 :: (a -> a -> b) -> [a] -> b
op2 f ~[x,y] = f x y
op3 :: (a -> a -> a -> b) -> [a] -> b
op3 f ~[x,y,z] = f x y z
-- | Common checks: check for error, or simple full evaluation.
tOp :: TFun -> ([Nat'] -> Maybe Nat') -> [Type] -> Maybe Type
tOp tf f ts
| Just e <- msum (map tIsError ts) = Just (tBadNumber e)
| Just xs <- mapM tIsNat' ts =
Just $ case f xs of
Nothing -> tBadNumber (err xs)
Just n -> tNat' n
| otherwise = Nothing
where
err xs = TCErrorMessage $
"Invalid type: " ++ show (pp (TCon (TF tf) (map tNat' xs)))
cryptol-2.8.0/src/Cryptol/TypeCheck/SimpleSolver.hs 0000644 0000000 0000000 00000003524 07346545000 020474 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, Trustworthy #-}
module Cryptol.TypeCheck.SimpleSolver ( simplify , simplifyStep) where
import Cryptol.TypeCheck.Type hiding
( tSub, tMul, tDiv, tMod, tExp, tMin, tLenFromThenTo)
import Cryptol.TypeCheck.Solver.Types
import Cryptol.TypeCheck.Solver.Numeric.Fin(cryIsFinType)
import Cryptol.TypeCheck.Solver.Numeric(cryIsEqual, cryIsNotEqual, cryIsGeq)
import Cryptol.TypeCheck.Solver.Class
( solveZeroInst, solveLogicInst, solveArithInst, solveCmpInst
, solveSignedCmpInst, solveLiteralInst )
import Cryptol.Utils.Debug(ppTrace)
import Cryptol.TypeCheck.PP
simplify :: Ctxt -> Prop -> Prop
simplify ctxt p =
case simplifyStep ctxt p of
Unsolvable e -> pError e
Unsolved -> dbg msg p
where msg = text "unsolved:" <+> pp p
SolvedIf ps -> dbg msg $ pAnd (map (simplify ctxt) ps)
where msg = case ps of
[] -> text "solved:" <+> pp p
_ -> pp p <+> text "~~~>" <+>
vcat (punctuate comma (map pp ps))
where
dbg msg x
| False = ppTrace msg x
| otherwise = x
simplifyStep :: Ctxt -> Prop -> Solved
simplifyStep ctxt prop =
case tNoUser prop of
TCon (PC PTrue) [] -> SolvedIf []
TCon (PC PAnd) [l,r] -> SolvedIf [l,r]
TCon (PC PZero) [ty] -> solveZeroInst ty
TCon (PC PLogic) [ty] -> solveLogicInst ty
TCon (PC PArith) [ty] -> solveArithInst ty
TCon (PC PCmp) [ty] -> solveCmpInst ty
TCon (PC PSignedCmp) [ty] -> solveSignedCmpInst ty
TCon (PC PLiteral) [t1,t2] -> solveLiteralInst t1 t2
TCon (PC PFin) [ty] -> cryIsFinType ctxt ty
TCon (PC PEqual) [t1,t2] -> cryIsEqual ctxt t1 t2
TCon (PC PNeq) [t1,t2] -> cryIsNotEqual ctxt t1 t2
TCon (PC PGeq) [t1,t2] -> cryIsGeq ctxt t1 t2
_ -> Unsolved
cryptol-2.8.0/src/Cryptol/TypeCheck/Solve.hs 0000644 0000000 0000000 00000025137 07346545000 017144 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Solve
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE PatternGuards, BangPatterns, RecordWildCards #-}
{-# LANGUAGE Safe #-}
module Cryptol.TypeCheck.Solve
( simplifyAllConstraints
, proveImplication
, proveModuleTopLevel
, defaultAndSimplify
, defaultReplExpr
) where
import Cryptol.Parser.Position(thing,emptyRange)
import Cryptol.TypeCheck.PP -- (pp)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Monad
import Cryptol.TypeCheck.Default
import Cryptol.TypeCheck.SimpType(tWidth)
import Cryptol.TypeCheck.Error(Error(..),Warning(..))
import Cryptol.TypeCheck.Subst
(apSubst, isEmptySubst, substToList,
emptySubst,Subst,(@@), Subst, listParamSubst)
import qualified Cryptol.TypeCheck.SimpleSolver as Simplify
import Cryptol.TypeCheck.Solver.Types
import Cryptol.TypeCheck.Solver.Selector(tryHasGoal)
import Cryptol.TypeCheck.Solver.SMT(Solver,proveImp,isNumeric)
import Cryptol.TypeCheck.Solver.Improve(improveProp,improveProps)
import Cryptol.TypeCheck.Solver.Numeric.Interval
import Cryptol.Utils.PP (text,vcat,(<+>))
import Cryptol.Utils.Patterns(matchMaybe)
import Control.Applicative ((<|>))
import Control.Monad(mzero)
import qualified Data.Map as Map
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.List(partition)
import Data.Maybe(listToMaybe)
quickSolverIO :: Ctxt -> [Goal] -> IO (Either Goal (Subst,[Goal]))
quickSolverIO _ [] = return (Right (emptySubst, []))
quickSolverIO ctxt gs =
case quickSolver ctxt gs of
Left err ->
do msg (text "Contradiction:" <+> pp (goal err))
return (Left err)
Right (su,gs') ->
do msg (vcat (map (pp . goal) gs' ++ [pp su]))
return (Right (su,gs'))
where
msg _ = return ()
{-
shAsmps = case [ pp x <+> text "in" <+> ppInterval i |
(x,i) <- Map.toList ctxt ] of
[] -> text ""
xs -> text "ASMPS:" $$ nest 2 (vcat xs $$ text "===")
msg d = putStrLn $ show (
text "quickSolver:" $$ nest 2 (vcat
[ shAsmps
, vcat (map (pp.goal) gs)
, text "==>"
, d
])) -- -}
quickSolver :: Ctxt -- ^ Facts we can know
-> [Goal] -- ^ Need to solve these
-> Either Goal (Subst,[Goal])
-- ^ Left: contradicting goals,
-- Right: inferred types, unsolved goals.
quickSolver ctxt gs0 = go emptySubst [] gs0
where
go su [] [] = Right (su,[])
go su unsolved [] =
case matchMaybe (findImprovement unsolved) of
Nothing -> Right (su,unsolved)
Just (newSu, subs) -> go (newSu @@ su) [] (subs ++ apSubst newSu unsolved)
go su unsolved (g : gs) =
case Simplify.simplifyStep ctxt (goal g) of
Unsolvable _ -> Left g
Unsolved -> go su (g : unsolved) gs
SolvedIf subs ->
let cvt x = g { goal = x }
in go su unsolved (map cvt subs ++ gs)
-- Probably better to find more than one.
findImprovement [] = mzero
findImprovement (g : gs) =
do (su,ps) <- improveProp False ctxt (goal g)
return (su, [ g { goal = p } | p <- ps ])
<|> findImprovement gs
--------------------------------------------------------------------------------
defaultReplExpr :: Solver -> Expr -> Schema ->
IO (Maybe ([(TParam,Type)], Expr))
defaultReplExpr sol expr sch =
do mb <- defaultReplExpr' sol numVs numPs
case mb of
Nothing -> return Nothing
Just numBinds -> return $
do optss <- mapM tryDefVar otherVs
su <- listToMaybe
[ binds | nonSu <- sequence optss
, let binds = nonSu ++ numBinds
, validate binds ]
tys <- sequence [ lookup v su | v <- sVars sch ]
return (su, appExpr tys)
where
validate binds =
let su = listParamSubst binds
in null (concatMap pSplitAnd (apSubst su (sProps sch)))
(numVs,otherVs) = partition (kindIs KNum) (sVars sch)
(numPs,otherPs) = partition isNumeric (sProps sch)
kindIs k x = kindOf x == k
gSet = goalsFromList
[ Goal { goal = p
, goalRange = emptyRange
, goalSource = CtDefaulting } | p <- otherPs ]
tryDefVar a =
do let a' = TVBound a
gt <- Map.lookup a' (literalGoals gSet)
let ok p = not (Set.member a' (fvs p))
return [ (a,t) | t <- [ tInteger, tBit, tWord (tWidth (goal gt)) ]
, ok t ]
appExpr tys = foldl (\e1 _ -> EProofApp e1)
(foldl ETApp expr tys)
(sProps sch)
defaultAndSimplify :: [TVar] -> [Goal] -> ([TVar],[Goal],Subst,[Warning])
defaultAndSimplify as gs =
let (as1, gs1, su1, ws1) = defLit
(as2, gs2, su2, ws2) = improveByDefaultingWithPure as1 gs1
in (as2,gs2,su2 @@ su1, ws1 ++ ws2)
where
defLit
| isEmptySubst su = nope
| otherwise = case quickSolver Map.empty (apSubst su gs) of
Left _ -> nope -- hm?
Right (su1,gs1) -> (as1,gs1,su1@@su,ws)
where (as1,su,ws) = defaultLiterals as gs
nope = (as,gs,emptySubst,[])
simplifyAllConstraints :: InferM ()
simplifyAllConstraints =
do simpHasGoals
gs <- getGoals
case gs of
[] -> return ()
_ ->
case quickSolver Map.empty gs of
Left badG -> recordError (UnsolvedGoals True [badG])
Right (su,gs1) ->
do extendSubst su
addGoals gs1
-- | Simplify @Has@ constraints as much as possible.
simpHasGoals :: InferM ()
simpHasGoals = go False [] =<< getHasGoals
where
go _ [] [] = return ()
go True unsolved [] = go False [] unsolved
go False unsolved [] = mapM_ addHasGoal unsolved
go changes unsolved (g : todo) =
do (ch,solved) <- tryHasGoal g
let changes' = ch || changes
unsolved' = if solved then unsolved else g : unsolved
changes' `seq` unsolved `seq` go changes' unsolved' todo
-- | Try to clean-up any left-over constraints after we've checked everything
-- in a module. Typically these are either trivial things, or constraints
-- on the module's type parameters.
proveModuleTopLevel :: InferM ()
proveModuleTopLevel =
do simplifyAllConstraints
gs <- getGoals
let vs = Set.toList (Set.filter isFreeTV (fvs gs))
(_,gs1,su1,ws) = defaultAndSimplify vs gs
extendSubst su1
mapM_ recordWarning ws
cs <- getParamConstraints
case cs of
[] -> addGoals gs1
_ -> do su2 <- proveImplication Nothing [] [] gs1
extendSubst su2
-- | Prove an implication, and return any improvements that we computed.
-- Records errors, if any of the goals couldn't be solved.
proveImplication :: Maybe Name -> [TParam] -> [Prop] -> [Goal] -> InferM Subst
proveImplication lnam as ps gs =
do evars <- varsWithAsmps
solver <- getSolver
extraAs <- (map mtpParam . Map.elems) <$> getParamTypes
extra <- map thing <$> getParamConstraints
(mbErr,su) <- io (proveImplicationIO solver lnam evars
(extraAs ++ as) (extra ++ ps) gs)
case mbErr of
Right ws -> mapM_ recordWarning ws
Left err -> recordError err
return su
proveImplicationIO :: Solver
-> Maybe Name -- ^ Checking this function
-> Set TVar -- ^ These appear in the env., and we should
-- not try to default them
-> [TParam] -- ^ Type parameters
-> [Prop] -- ^ Assumed constraint
-> [Goal] -- ^ Collected constraints
-> IO (Either Error [Warning], Subst)
proveImplicationIO _ _ _ _ [] [] = return (Right [], emptySubst)
proveImplicationIO s f varsInEnv ps asmps0 gs0 =
do let ctxt = assumptionIntervals Map.empty asmps
res <- quickSolverIO ctxt gs
case res of
Left bad -> return (Left (UnsolvedGoals True [bad]), emptySubst)
Right (su,[]) -> return (Right [], su)
Right (su,gs1) ->
do gs2 <- proveImp s asmps gs1
case gs2 of
[] -> return (Right [], su)
gs3 ->
do let free = filter isFreeTV
$ Set.toList
$ Set.difference (fvs (map goal gs3)) varsInEnv
case defaultAndSimplify free gs3 of
(_,_,newSu,_)
| isEmptySubst newSu ->
return (err gs3, su) -- XXX: Old?
(_,newGs,newSu,ws) ->
do let su1 = newSu @@ su
(res1,su2) <- proveImplicationIO s f varsInEnv ps
(apSubst su1 asmps0) newGs
let su3 = su2 @@ su1
case res1 of
Left bad -> return (Left bad, su3)
Right ws1 -> return (Right (ws++ws1),su3)
where
err us = Left $ cleanupError
$ UnsolvedDelayedCt
$ DelayedCt { dctSource = f
, dctForall = ps
, dctAsmps = asmps0
, dctGoals = us
}
asmps1 = concatMap pSplitAnd asmps0
(asmps,gs) =
let gs1 = [ g { goal = p } | g <- gs0, p <- pSplitAnd (goal g)
, notElem p asmps1 ]
in case matchMaybe (improveProps True Map.empty asmps1) of
Nothing -> (asmps1,gs1)
Just (newSu,newAsmps) ->
( [ TVar x =#= t | (x,t) <- substToList newSu ]
++ newAsmps
, [ g { goal = apSubst newSu (goal g) } | g <- gs1 ]
)
cleanupError :: Error -> Error
cleanupError err =
case err of
UnsolvedDelayedCt d ->
let noInferVars = Set.null . Set.filter isFreeTV . fvs . goal
without = filter noInferVars (dctGoals d)
in UnsolvedDelayedCt $
if not (null without) then d { dctGoals = without } else d
_ -> err
assumptionIntervals :: Ctxt -> [Prop] -> Ctxt
assumptionIntervals as ps =
case computePropIntervals as ps of
NoChange -> as
InvalidInterval {} -> as -- XXX: say something
NewIntervals bs -> Map.union bs as
cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/ 0000755 0000000 0000000 00000000000 07346545000 016762 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/Class.hs 0000644 0000000 0000000 00000017765 07346545000 020403 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Solver.Class
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- Solving class constraints.
{-# LANGUAGE PatternGuards, OverloadedStrings #-}
module Cryptol.TypeCheck.Solver.Class
( classStep
, solveZeroInst
, solveLogicInst
, solveArithInst
, solveCmpInst
, solveSignedCmpInst
, solveLiteralInst
, expandProp
) where
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.SimpType (tAdd,tWidth)
import Cryptol.TypeCheck.Solver.Types
import Cryptol.TypeCheck.PP
-- | Solve class constraints.
-- If not, then we return 'Nothing'.
-- If solved, then we return 'Just' a list of sub-goals.
classStep :: Prop -> Solved
classStep p = case tNoUser p of
TCon (PC PLogic) [ty] -> solveLogicInst (tNoUser ty)
TCon (PC PArith) [ty] -> solveArithInst (tNoUser ty)
TCon (PC PCmp) [ty] -> solveCmpInst (tNoUser ty)
_ -> Unsolved
-- | Solve a Zero constraint by instance, if possible.
solveZeroInst :: Type -> Solved
solveZeroInst ty = case tNoUser ty of
-- Zero Error -> fails
TCon (TError _ e) _ -> Unsolvable e
-- Zero Bit
TCon (TC TCBit) [] -> SolvedIf []
-- Zero Integer
TCon (TC TCInteger) [] -> SolvedIf []
-- Zero (Z n)
TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ]
-- Zero a => Zero [n]a
TCon (TC TCSeq) [_, a] -> SolvedIf [ pZero a ]
-- Zero b => Zero (a -> b)
TCon (TC TCFun) [_, b] -> SolvedIf [ pZero b ]
-- (Zero a, Zero b) => Zero (a,b)
TCon (TC (TCTuple _)) es -> SolvedIf [ pZero e | e <- es ]
-- (Zero a, Zero b) => Zero { x1 : a, x2 : b }
TRec fs -> SolvedIf [ pZero ety | (_,ety) <- fs ]
_ -> Unsolved
-- | Solve a Logic constraint by instance, if possible.
solveLogicInst :: Type -> Solved
solveLogicInst ty = case tNoUser ty of
-- Logic Error -> fails
TCon (TError _ e) _ -> Unsolvable e
-- Logic Bit
TCon (TC TCBit) [] -> SolvedIf []
-- Logic a => Logic [n]a
TCon (TC TCSeq) [_, a] -> SolvedIf [ pLogic a ]
-- Logic b => Logic (a -> b)
TCon (TC TCFun) [_, b] -> SolvedIf [ pLogic b ]
-- (Logic a, Logic b) => Logic (a,b)
TCon (TC (TCTuple _)) es -> SolvedIf [ pLogic e | e <- es ]
-- (Logic a, Logic b) => Logic { x1 : a, x2 : b }
TRec fs -> SolvedIf [ pLogic ety | (_,ety) <- fs ]
_ -> Unsolved
-- | Solve an Arith constraint by instance, if possible.
solveArithInst :: Type -> Solved
solveArithInst ty = case tNoUser ty of
-- Arith Error -> fails
TCon (TError _ e) _ -> Unsolvable e
-- Arith [n]e
TCon (TC TCSeq) [n, e] -> solveArithSeq n e
-- Arith b => Arith (a -> b)
TCon (TC TCFun) [_,b] -> SolvedIf [ pArith b ]
-- (Arith a, Arith b) => Arith (a,b)
TCon (TC (TCTuple _)) es -> SolvedIf [ pArith e | e <- es ]
-- Arith Bit fails
TCon (TC TCBit) [] ->
Unsolvable $ TCErrorMessage "Arithmetic cannot be done on individual bits."
-- Arith Integer
TCon (TC TCInteger) [] -> SolvedIf []
-- Arith (Z n)
TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ]
-- (Arith a, Arith b) => Arith { x1 : a, x2 : b }
TRec fs -> SolvedIf [ pArith ety | (_,ety) <- fs ]
_ -> Unsolved
-- | Solve an Arith constraint for a sequence. The type passed here is the
-- element type of the sequence.
solveArithSeq :: Type -> Type -> Solved
solveArithSeq n ty = case tNoUser ty of
-- fin n => Arith [n]Bit
TCon (TC TCBit) [] -> SolvedIf [ pFin n ]
-- variables are not solvable.
TVar {} -> case tNoUser n of
{- We are sure that the lenght is not `fin`, so the
special case for `Bit` does not apply.
Arith ty => Arith [n]ty -}
TCon (TC TCInf) [] -> SolvedIf [ pArith ty ]
_ -> Unsolved
-- Arith ty => Arith [n]ty
_ -> SolvedIf [ pArith ty ]
-- | Solve Cmp constraints.
solveCmpInst :: Type -> Solved
solveCmpInst ty = case tNoUser ty of
-- Cmp Error -> fails
TCon (TError _ e) _ -> Unsolvable e
-- Cmp Bit
TCon (TC TCBit) [] -> SolvedIf []
-- Cmp Integer
TCon (TC TCInteger) [] -> SolvedIf []
-- Cmp (Z n)
TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ]
-- (fin n, Cmp a) => Cmp [n]a
TCon (TC TCSeq) [n,a] -> SolvedIf [ pFin n, pCmp a ]
-- (Cmp a, Cmp b) => Cmp (a,b)
TCon (TC (TCTuple _)) es -> SolvedIf (map pCmp es)
-- Cmp (a -> b) fails
TCon (TC TCFun) [_,_] ->
Unsolvable $ TCErrorMessage "Comparisons may not be performed on functions."
-- (Cmp a, Cmp b) => Cmp { x:a, y:b }
TRec fs -> SolvedIf [ pCmp e | (_,e) <- fs ]
_ -> Unsolved
-- | Solve a SignedCmp constraint for a sequence. The type passed here is the
-- element type of the sequence.
solveSignedCmpSeq :: Type -> Type -> Solved
solveSignedCmpSeq n ty = case tNoUser ty of
-- (fin n, n >=1 ) => SignedCmp [n]Bit
TCon (TC TCBit) [] -> SolvedIf [ pFin n, n >== tNum (1 :: Integer) ]
-- variables are not solvable.
TVar {} -> Unsolved
-- (fin n, SignedCmp ty) => SignedCmp [n]ty, when ty != Bit
_ -> SolvedIf [ pFin n, pSignedCmp ty ]
-- | Solve SignedCmp constraints.
solveSignedCmpInst :: Type -> Solved
solveSignedCmpInst ty = case tNoUser ty of
-- SignedCmp Error -> fails
TCon (TError _ e) _ -> Unsolvable e
-- SignedCmp Bit
TCon (TC TCBit) [] -> Unsolvable $ TCErrorMessage "Signed comparisons may not be performed on bits"
-- SignedCmp for sequences
TCon (TC TCSeq) [n,a] -> solveSignedCmpSeq n a
-- (SignedCmp a, SignedCmp b) => SignedCmp (a,b)
TCon (TC (TCTuple _)) es -> SolvedIf (map pSignedCmp es)
-- SignedCmp (a -> b) fails
TCon (TC TCFun) [_,_] ->
Unsolvable $ TCErrorMessage "Signed comparisons may not be performed on functions."
-- (SignedCmp a, SignedCmp b) => SignedCmp { x:a, y:b }
TRec fs -> SolvedIf [ pSignedCmp e | (_,e) <- fs ]
_ -> Unsolved
-- | Solve Literal constraints.
solveLiteralInst :: Type -> Type -> Solved
solveLiteralInst val ty
| TCon (TError _ e) _ <- tNoUser val = Unsolvable e
| otherwise =
case tNoUser ty of
-- Literal n Error -> fails
TCon (TError _ e) _ -> Unsolvable e
-- (fin val) => Literal val Integer
TCon (TC TCInteger) [] -> SolvedIf [ pFin val ]
-- (fin val, fin m, m >= val + 1) => Literal val (Z m)
TCon (TC TCIntMod) [modulus] ->
SolvedIf [ pFin val, pFin modulus, modulus >== tAdd val tOne ]
-- (fin bits, bits => width n) => Literal n [bits]
TCon (TC TCSeq) [bits, elTy]
| TCon (TC TCBit) [] <- ety ->
SolvedIf [ pFin val, pFin bits, bits >== tWidth val ]
| TVar _ <- ety -> Unsolved
where ety = tNoUser elTy
TVar _ -> Unsolved
_ -> Unsolvable $ TCErrorMessage $ show
$ "Type" <+> quotes (pp ty) <+> "does not support literals."
-- | Add propositions that are implied by the given one.
-- The result contains the orignal proposition, and maybe some more.
expandProp :: Prop -> [Prop]
expandProp prop =
prop :
case tNoUser prop of
TCon (PC pc) [ty] ->
case (pc, tNoUser ty) of
-- Arith [n]Bit => fin n
-- (Arith [n]a, a/=Bit) => Arith a
(PArith, TCon (TC TCSeq) [n,a])
| TCon (TC TCBit) _ <- ty1 -> [pFin n]
| TCon _ _ <- ty1 -> expandProp (pArith ty1)
| TRec {} <- ty1 -> expandProp (pArith ty1)
where
ty1 = tNoUser a
-- Arith (a -> b) => Arith b
(PArith, TCon (TC TCFun) [_,b]) -> expandProp (pArith b)
-- Arith (a,b) => (Arith a, Arith b)
(PArith, TCon (TC (TCTuple _)) ts) -> concatMap (expandProp . pArith) ts
-- Arith { x1 : a, x2 : b } => (Arith a, Arith b)
(PArith, TRec fs) -> concatMap (expandProp . pArith. snd) fs
-- Cmp [n]a => (fin n, Cmp a)
(PCmp, TCon (TC TCSeq) [n,a]) -> pFin n : expandProp (pCmp a)
-- Cmp (a,b) => (Cmp a, Cmp b)
(PCmp, TCon (TC (TCTuple _)) ts) -> concatMap (expandProp . pCmp) ts
-- Cmp { x:a, y:b } => (Cmp a, Cmp b)
(PCmp, TRec fs) -> concatMap (expandProp . pCmp . snd) fs
_ -> []
_ -> []
cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/Improve.hs 0000644 0000000 0000000 00000016252 07346545000 020745 0 ustar 00 0000000 0000000 -- | Look for opportunity to solve goals by instantiating variables.
module Cryptol.TypeCheck.Solver.Improve where
import qualified Data.Set as Set
import Control.Applicative
import Control.Monad
import Cryptol.Utils.Patterns
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.SimpType as Mk
import Cryptol.TypeCheck.Solver.Types
import Cryptol.TypeCheck.Solver.Numeric.Interval
import Cryptol.TypeCheck.TypePat
import Cryptol.TypeCheck.Subst
-- | Improvements from a bunch of propositions.
-- Invariant:
-- the substitions should be already applied to the new sub-goals, if any.
improveProps :: Bool -> Ctxt -> [Prop] -> Match (Subst,[Prop])
improveProps impSkol ctxt ps0 = loop emptySubst ps0
where
loop su props = case go emptySubst [] props of
(newSu,newProps)
| isEmptySubst newSu ->
if isEmptySubst su then mzero else return (su,props)
| otherwise -> loop (newSu @@ su) newProps
go su subs [] = (su,subs)
go su subs (p : ps) =
case matchMaybe (improveProp impSkol ctxt p) of
Nothing -> go su (p:subs) ps
Just (suNew,psNew) -> go (suNew @@ su) (psNew ++ apSubst suNew subs)
(apSubst su ps)
-- | Improvements from a proposition.
-- Invariant:
-- the substitions should be already applied to the new sub-goals, if any.
improveProp :: Bool -> Ctxt -> Prop -> Match (Subst,[Prop])
improveProp impSkol ctxt prop =
improveEq impSkol ctxt prop <|>
improveLit impSkol prop
-- XXX: others
improveLit :: Bool -> Prop -> Match (Subst, [Prop])
improveLit impSkol prop =
do (_,t) <- aLiteral prop
(_,b) <- aSeq t
a <- aTVar b
unless impSkol $ guard (isFreeTV a)
let su = singleSubst a tBit
return (su, [])
-- | Improvements from equality constraints.
-- Invariant:
-- the substitions should be already applied to the new sub-goals, if any.
improveEq :: Bool -> Ctxt -> Prop -> Match (Subst,[Prop])
improveEq impSkol fins prop =
do (lhs,rhs) <- (|=|) prop
rewrite lhs rhs <|> rewrite rhs lhs
where
rewrite this other =
do x <- aTVar this
guard (considerVar x && x `Set.notMember` fvs other)
return (singleSubst x other, [])
<|>
do (v,s) <- isSum this
guard (v `Set.notMember` fvs other)
return (singleSubst v (Mk.tSub other s), [ other >== s ])
isSum t = do (v,s) <- matches t (anAdd, aTVar, __)
valid v s
<|> do (s,v) <- matches t (anAdd, __, aTVar)
valid v s
valid v s = do let i = typeInterval fins s
guard (considerVar v && v `Set.notMember` fvs s && iIsFin i)
return (v,s)
considerVar x = impSkol || isFreeTV x
--------------------------------------------------------------------------------
-- XXX
{-
-- | When given an equality constraint, attempt to rewrite it to the form `?x =
-- ...`, by moving all occurrences of `?x` to the LHS, and any other variables
-- to the RHS. This will only work when there's only one unification variable
-- present in the prop.
tryRewrteEqAsSubst :: Ctxt -> Type -> Type -> Maybe (TVar,Type)
tryRewrteEqAsSubst fins t1 t2 =
do let vars = Set.toList (Set.filter isFreeTV (fvs (t1,t2)))
listToMaybe $ sortBy (flip compare `on` rank)
$ catMaybes [ tryRewriteEq fins var t1 t2 | var <- vars ]
-- | Rank a rewrite, favoring expressions that have fewer subtractions than
-- additions.
rank :: (TVar,Type) -> Int
rank (_,ty) = go ty
where
go (TCon (TF TCAdd) ts) = sum (map go ts) + 1
go (TCon (TF TCSub) ts) = sum (map go ts) - 1
go (TCon (TF TCMul) ts) = sum (map go ts) + 1
go (TCon (TF TCDiv) ts) = sum (map go ts) - 1
go (TCon _ ts) = sum (map go ts)
go _ = 0
-- | Rewrite an equation with respect to a unification variable ?x, into the
-- form `?x = t`. There are two interesting cases to consider (four with
-- symmetry):
--
-- * ?x = ty
-- * expr containing ?x = expr
--
-- In the first case, we just return the type variable and the type, but in the
-- second we try to rewrite the equation until it's in the form of the first
-- case.
tryRewriteEq :: Map TVar Interval -> TVar -> Type -> Type -> Maybe (TVar,Type)
tryRewriteEq fins uvar l r =
msum [ do guard (uvarTy == l && uvar `Set.notMember` rfvs)
return (uvar, r)
, do guard (uvarTy == r && uvar `Set.notMember` lfvs)
return (uvar, l)
, do guard (uvar `Set.notMember` rfvs)
ty <- rewriteLHS fins uvar l r
return (uvar,ty)
, do guard (uvar `Set.notMember` lfvs)
ty <- rewriteLHS fins uvar r l
return (uvar,ty)
]
where
uvarTy = TVar uvar
lfvs = fvs l
rfvs = fvs r
-- | Check that a type contains only finite type variables.
allFin :: Map TVar Interval -> Type -> Bool
allFin ints ty = iIsFin (typeInterval ints ty)
-- | Rewrite an equality until the LHS is just `uvar`. Return the rewritten RHS.
--
-- There are a few interesting cases when rewriting the equality:
--
-- A o B = R when `uvar` is only present in A
-- A o B = R when `uvar` is only present in B
--
-- In the first case, as we only consider addition and subtraction, the
-- rewriting will continue on the left, after moving the `B` side to the RHS of
-- the equation. In the second case, if the operation is addition, the `A` side
-- will be moved to the RHS, with rewriting continuing in `B`. However, in the
-- case of subtraction, the `B` side is moved to the RHS, and rewriting
-- continues on the RHS instead.
--
-- In both cases, if the operation is addition, rewriting will only continue if
-- the operand being moved to the RHS is known to be finite. If this check was
-- not done, we would end up violating the well-definedness condition for
-- subtraction (for a, b: well defined (a - b) iff fin b).
rewriteLHS :: Map TVar Interval -> TVar -> Type -> Type -> Maybe Type
rewriteLHS fins uvar = go
where
go (TVar tv) rhs | tv == uvar = return rhs
go (TCon (TF tf) [x,y]) rhs =
do let xfvs = fvs x
yfvs = fvs y
inX = Set.member uvar xfvs
inY = Set.member uvar yfvs
if | inX && inY -> mzero
| inX -> balanceR x tf y rhs
| inY -> balanceL x tf y rhs
| otherwise -> mzero
-- discard type synonyms, the rewriting will make them no longer apply
go (TUser _ _ l) rhs =
go l rhs
-- records won't work here.
go _ _ =
mzero
-- invert the type function to balance the equation, when the variable occurs
-- on the LHS of the expression `x tf y`
balanceR x TCAdd y rhs = do guardFin y
go x (tSub rhs y)
balanceR x TCSub y rhs = go x (tAdd rhs y)
balanceR _ _ _ _ = mzero
-- invert the type function to balance the equation, when the variable occurs
-- on the RHS of the expression `x tf y`
balanceL x TCAdd y rhs = do guardFin y
go y (tSub rhs x)
balanceL x TCSub y rhs = go (tAdd rhs y) x
balanceL _ _ _ _ = mzero
-- guard that the type is finite
--
-- XXX this ignores things like `min x inf` where x is finite, and just
-- assumes that it won't work.
guardFin ty = guard (allFin fins ty)
-}
cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/InfNat.hs 0000644 0000000 0000000 00000020156 07346545000 020501 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Solver.InfNat
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- This module defines natural numbers with an additional infinity
-- element, and various arithmetic operators on them.
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.TypeCheck.Solver.InfNat where
import Data.Bits
import Cryptol.Utils.Panic
import GHC.Generics (Generic)
import Control.DeepSeq
-- | Natural numbers with an infinity element
data Nat' = Nat Integer | Inf
deriving (Show, Eq, Ord, Generic, NFData)
fromNat :: Nat' -> Maybe Integer
fromNat n' =
case n' of
Nat i -> Just i
_ -> Nothing
--------------------------------------------------------------------------------
nAdd :: Nat' -> Nat' -> Nat'
nAdd Inf _ = Inf
nAdd _ Inf = Inf
nAdd (Nat x) (Nat y) = Nat (x + y)
{-| Some algebraic properties of interest:
> 1 * x = x
> x * (y * z) = (x * y) * z
> 0 * x = 0
> x * y = y * x
> x * (a + b) = x * a + x * b
-}
nMul :: Nat' -> Nat' -> Nat'
nMul (Nat 0) _ = Nat 0
nMul _ (Nat 0) = Nat 0
nMul Inf _ = Inf
nMul _ Inf = Inf
nMul (Nat x) (Nat y) = Nat (x * y)
{-| Some algebraic properties of interest:
> x ^ 0 = 1
> x ^ (n + 1) = x * (x ^ n)
> x ^ (m + n) = (x ^ m) * (x ^ n)
> x ^ (m * n) = (x ^ m) ^ n
-}
nExp :: Nat' -> Nat' -> Nat'
nExp _ (Nat 0) = Nat 1
nExp Inf _ = Inf
nExp (Nat 0) Inf = Nat 0
nExp (Nat 1) Inf = Nat 1
nExp (Nat _) Inf = Inf
nExp (Nat x) (Nat y) = Nat (x ^ y)
nMin :: Nat' -> Nat' -> Nat'
nMin Inf x = x
nMin x Inf = x
nMin (Nat x) (Nat y) = Nat (min x y)
nMax :: Nat' -> Nat' -> Nat'
nMax Inf _ = Inf
nMax _ Inf = Inf
nMax (Nat x) (Nat y) = Nat (max x y)
{- | @nSub x y = Just z@ iff @z@ is the unique value
such that @Add y z = Just x@. -}
nSub :: Nat' -> Nat' -> Maybe Nat'
nSub Inf (Nat _) = Just Inf
nSub (Nat x) (Nat y)
| x >= y = Just (Nat (x - y))
nSub _ _ = Nothing
-- XXX:
-- Does it make sense to define:
-- nDiv Inf (Nat x) = Inf
-- nMod Inf (Nat x) = Nat 0
{- | Rounds down.
> y * q + r = x
> x / y = q with remainder r
> 0 <= r && r < y
We don't allow `Inf` in the first argument for two reasons:
1. It matches the behavior of `nMod`,
2. The well-formedness constraints can be expressed as a conjunction.
-}
nDiv :: Nat' -> Nat' -> Maybe Nat'
nDiv _ (Nat 0) = Nothing
nDiv Inf _ = Nothing
nDiv (Nat x) (Nat y) = Just (Nat (div x y))
nDiv (Nat _) Inf = Just (Nat 0)
nMod :: Nat' -> Nat' -> Maybe Nat'
nMod _ (Nat 0) = Nothing
nMod Inf _ = Nothing
nMod (Nat x) (Nat y) = Just (Nat (mod x y))
nMod (Nat x) Inf = Just (Nat x) -- inf * 0 + x = 0 + x
-- | @nCeilDiv msgLen blockSize@ computes the least @n@ such that
-- @msgLen <= blockSize * n@. It is undefined when @blockSize = 0@.
-- It is also undefined when either input is infinite; perhaps this
-- could be relaxed later.
nCeilDiv :: Nat' -> Nat' -> Maybe Nat'
nCeilDiv _ (Nat 0) = Nothing
nCeilDiv Inf _ = Nothing
nCeilDiv (Nat _) Inf = Nothing
nCeilDiv (Nat x) (Nat y) = Just (Nat (- div (- x) y))
-- | @nCeilMod msgLen blockSize@ computes the least @k@ such that
-- @blockSize@ divides @msgLen + k@. It is undefined when @blockSize = 0@.
-- It is also undefined when either input is infinite; perhaps this
-- could be relaxed later.
nCeilMod :: Nat' -> Nat' -> Maybe Nat'
nCeilMod _ (Nat 0) = Nothing
nCeilMod Inf _ = Nothing
nCeilMod (Nat _) Inf = Nothing
nCeilMod (Nat x) (Nat y) = Just (Nat (mod (- x) y))
-- | Rounds up.
-- @lg2 x = y@, iff @y@ is the smallest number such that @x <= 2 ^ y@
nLg2 :: Nat' -> Nat'
nLg2 Inf = Inf
nLg2 (Nat 0) = Nat 0
nLg2 (Nat n) = case genLog n 2 of
Just (x,exact) | exact -> Nat x
| otherwise -> Nat (x + 1)
Nothing -> panic "Cryptol.TypeCheck.Solver.InfNat.nLg2"
[ "genLog returned Nothing" ]
-- | @nWidth n@ is number of bits needed to represent all numbers
-- from 0 to n, inclusive. @nWidth x = nLg2 (x + 1)@.
nWidth :: Nat' -> Nat'
nWidth Inf = Inf
nWidth (Nat n) = Nat (widthInteger n)
-- | @length [ x, y .. z ]@
nLenFromThenTo :: Nat' -> Nat' -> Nat' -> Maybe Nat'
nLenFromThenTo (Nat x) (Nat y) (Nat z)
| step /= 0 = let len = div dist step + 1
in Just $ Nat $ if x > y
-- decreasing
then (if z > x then 0 else len)
-- increasing
else (if z < x then 0 else len)
where
step = abs (x - y)
dist = abs (x - z)
nLenFromThenTo _ _ _ = Nothing
{- Note [Sequences of Length 0]
nLenFromThenTo x y z == 0
case 1: x > y && z > x
case 2: x <= y && z < x
-}
{- Note [Sequences of Length 1]
`nLenFromThenTo x y z == 1`
dist < step && (x > y && z <= x || y >= x && z >= x)
case 1: dist < step && x > y && z <= x
case 2: dist < step && y >= x && z >= x
case 1: if `z <= x`,
then `x - z >= 0`,
hence `dist = x - z` (a)
if `x > y`
then `x - y` > 0
hence `step = x - y` (b)
from (a) and (b):
`dist < step`
`x - z < x - y`
`-z < -y`
`z > y`
case 1 summary: x >= z && z > y
case 2: if y >= x, then step = y - x (a)
if z >= x, then dist = z - x (b)
dist < step =
(z - x) < (y - x) =
(z < y)
case 2 summary: y > z, z >= x
-}
--------------------------------------------------------------------------------
-- | Compute the logarithm of a number in the given base, rounded down to the
-- closest integer. The boolean indicates if we the result is exact
-- (i.e., True means no rounding happened, False means we rounded down).
-- The logarithm base is the second argument.
genLog :: Integer -> Integer -> Maybe (Integer, Bool)
genLog x 0 = if x == 1 then Just (0, True) else Nothing
genLog _ 1 = Nothing
genLog 0 _ = Nothing
genLog x base = Just (exactLoop 0 x)
where
exactLoop s i
| i == 1 = (s,True)
| i < base = (s,False)
| otherwise =
let s1 = s + 1
in s1 `seq` case divMod i base of
(j,r)
| r == 0 -> exactLoop s1 j
| otherwise -> (underLoop s1 j, False)
underLoop s i
| i < base = s
| otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base)
-- | Compute the number of bits required to represent the given integer.
widthInteger :: Integer -> Integer
widthInteger x = go' 0 (if x < 0 then complement x else x)
where
go s 0 = s
go s n = let s' = s + 1 in s' `seq` go s' (n `shiftR` 1)
go' s n
| n < bit 32 = go s n
| otherwise = let s' = s + 32 in s' `seq` go' s' (n `shiftR` 32)
-- | Compute the exact root of a natural number.
-- The second argument specifies which root we are computing.
rootExact :: Integer -> Integer -> Maybe Integer
rootExact x y = do (z,True) <- genRoot x y
return z
{- | Compute the the n-th root of a natural number, rounded down to
the closest natural number. The boolean indicates if the result
is exact (i.e., True means no rounding was done, False means rounded down).
The second argument specifies which root we are computing. -}
genRoot :: Integer -> Integer -> Maybe (Integer, Bool)
genRoot _ 0 = Nothing
genRoot x0 1 = Just (x0, True)
genRoot x0 root = Just (search 0 (x0+1))
where
search from to = let x = from + div (to - from) 2
a = x ^ root
in case compare a x0 of
EQ -> (x, True)
LT | x /= from -> search x to
| otherwise -> (from, False)
GT | x /= to -> search from x
| otherwise -> (from, False)
cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/Numeric.hs 0000644 0000000 0000000 00000033312 07346545000 020722 0 ustar 00 0000000 0000000 {-# LANGUAGE Safe, PatternGuards, MultiWayIf #-}
module Cryptol.TypeCheck.Solver.Numeric
( cryIsEqual, cryIsNotEqual, cryIsGeq
) where
import Control.Applicative(Alternative(..))
import Control.Monad (guard,mzero)
import Data.List (sortBy)
import Cryptol.Utils.Patterns
import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.Type hiding (tMul)
import Cryptol.TypeCheck.TypePat
import Cryptol.TypeCheck.Solver.Types
import Cryptol.TypeCheck.Solver.InfNat
import Cryptol.TypeCheck.Solver.Numeric.Interval
import Cryptol.TypeCheck.SimpType as Simp
{- Convention for comments:
K1, K2 ... Concrete constants
s1, s2, t1, t2 ... Arbitrary type expressions
a, b, c ... Type variables
-}
-- | Try to solve @t1 = t2@
cryIsEqual :: Ctxt -> Type -> Type -> Solved
cryIsEqual ctxt t1 t2 =
matchDefault Unsolved $
(pBin PEqual (==) t1 t2)
<|> (aNat' t1 >>= tryEqK ctxt t2)
<|> (aNat' t2 >>= tryEqK ctxt t1)
<|> (aTVar t1 >>= tryEqVar t2)
<|> (aTVar t2 >>= tryEqVar t1)
<|> ( guard (t1 == t2) >> return (SolvedIf []))
<|> tryEqMin t1 t2
<|> tryEqMin t2 t1
<|> tryEqMins t1 t2
<|> tryEqMins t2 t1
<|> tryEqMulConst t1 t2
<|> tryEqAddInf ctxt t1 t2
<|> tryAddConst (=#=) t1 t2
<|> tryCancelVar ctxt (=#=) t1 t2
<|> tryLinearSolution t1 t2
<|> tryLinearSolution t2 t1
-- | Try to solve @t1 /= t2@
cryIsNotEqual :: Ctxt -> Type -> Type -> Solved
cryIsNotEqual _i t1 t2 = matchDefault Unsolved (pBin PNeq (/=) t1 t2)
-- | Try to solve @t1 >= t2@
cryIsGeq :: Ctxt -> Type -> Type -> Solved
cryIsGeq i t1 t2 =
matchDefault Unsolved $
(pBin PGeq (>=) t1 t2)
<|> (aNat' t1 >>= tryGeqKThan i t2)
<|> (aNat' t2 >>= tryGeqThanK i t1)
<|> (aTVar t2 >>= tryGeqThanVar i t1)
<|> tryGeqThanSub i t1 t2
<|> (geqByInterval i t1 t2)
<|> (guard (t1 == t2) >> return (SolvedIf []))
<|> tryAddConst (>==) t1 t2
<|> tryCancelVar i (>==) t1 t2
<|> tryMinIsGeq t1 t2
-- XXX: k >= width e
-- XXX: width e >= k
-- XXX: max t 10 >= 2 --> True
-- XXX: max t 2 >= 10 --> a >= 10
-- | Try to solve something by evaluation.
pBin :: PC -> (Nat' -> Nat' -> Bool) -> Type -> Type -> Match Solved
pBin tf p t1 t2 =
Unsolvable <$> anError KNum t1
<|> Unsolvable <$> anError KNum t2
<|> (do x <- aNat' t1
y <- aNat' t2
return $ if p x y
then SolvedIf []
else Unsolvable $ TCErrorMessage
$ "Unsolvable constraint: " ++
show (pp (TCon (PC tf) [ tNat' x, tNat' y ])))
--------------------------------------------------------------------------------
-- GEQ
-- | Try to solve @K >= t@
tryGeqKThan :: Ctxt -> Type -> Nat' -> Match Solved
tryGeqKThan _ _ Inf = return (SolvedIf [])
tryGeqKThan _ ty (Nat n) =
-- K1 >= K2 * t
do (a,b) <- aMul ty
m <- aNat' a
return $ SolvedIf
$ case m of
Inf -> [ b =#= tZero ]
Nat 0 -> []
Nat k -> [ tNum (div n k) >== b ]
-- | Try to solve @t >= K@
tryGeqThanK :: Ctxt -> Type -> Nat' -> Match Solved
tryGeqThanK _ t Inf = return (SolvedIf [ t =#= tInf ])
tryGeqThanK _ t (Nat k) =
-- K1 + t >= K2
do (a,b) <- anAdd t
n <- aNat a
return $ SolvedIf $ if n >= k
then []
else [ b >== tNum (k - n) ]
-- XXX: K1 ^^ n >= K2
tryGeqThanSub :: Ctxt -> Type -> Type -> Match Solved
tryGeqThanSub _ x y =
-- t1 >= t1 - t2
do (a,_) <- (|-|) y
guard (x == a)
return (SolvedIf [])
tryGeqThanVar :: Ctxt -> Type -> TVar -> Match Solved
tryGeqThanVar _ctxt ty x =
-- (t + a) >= a
do (a,b) <- anAdd ty
let check y = do x' <- aTVar y
guard (x == x')
return (SolvedIf [])
check a <|> check b
-- | Try to prove GEQ by considering the known intervals for the given types.
geqByInterval :: Ctxt -> Type -> Type -> Match Solved
geqByInterval ctxt x y =
let ix = typeInterval ctxt x
iy = typeInterval ctxt y
in case (iLower ix, iUpper iy) of
(l,Just n) | l >= n -> return (SolvedIf [])
_ -> mzero
-- min K1 t >= K2 ~~> t >= K2, if K1 >= K2; Err otherwise
tryMinIsGeq :: Type -> Type -> Match Solved
tryMinIsGeq t1 t2 =
do (a,b) <- aMin t1
k1 <- aNat a
k2 <- aNat t2
return $ if k1 >= k2
then SolvedIf [ b >== t2 ]
else Unsolvable $ TCErrorMessage $
show k1 ++ " can't be greater than " ++ show k2
--------------------------------------------------------------------------------
-- | Cancel finite positive variables from both sides.
-- @(fin a, a >= 1) => a * t1 == a * t2 ~~~> t1 == t2@
-- @(fin a, a >= 1) => a * t1 >= a * t2 ~~~> t1 >= t2@
tryCancelVar :: Ctxt -> (Type -> Type -> Prop) -> Type -> Type -> Match Solved
tryCancelVar ctxt p t1 t2 =
let lhs = preproc t1
rhs = preproc t2
in case check [] [] lhs rhs of
Nothing -> fail ""
Just x -> return x
where
check doneLHS doneRHS lhs@((a,mbA) : moreLHS) rhs@((b, mbB) : moreRHS) =
do x <- mbA
y <- mbB
case compare x y of
LT -> check (a : doneLHS) doneRHS moreLHS rhs
EQ -> return $ SolvedIf [ p (term (doneLHS ++ map fst moreLHS))
(term (doneRHS ++ map fst moreRHS)) ]
GT -> check doneLHS (b : doneRHS) lhs moreRHS
check _ _ _ _ = Nothing
term xs = case xs of
[] -> tNum (1::Int)
_ -> foldr1 tMul xs
preproc t = let fs = splitMul t []
in sortBy cmpFact (zip fs (map cancelVar fs))
splitMul t rest = case matchMaybe (aMul t) of
Just (a,b) -> splitMul a (splitMul b rest)
Nothing -> t : rest
cancelVar t = matchMaybe $ do x <- aTVar t
guard (iIsPosFin (tvarInterval ctxt x))
return x
-- cancellable variables go first, sorted alphabetically
cmpFact (_,mbA) (_,mbB) =
case (mbA,mbB) of
(Just x, Just y) -> compare x y
(Just _, Nothing) -> LT
(Nothing, Just _) -> GT
_ -> EQ
-- min t1 t2 = t1 ~> t1 <= t2
tryEqMin :: Type -> Type -> Match Solved
tryEqMin x y =
do (a,b) <- aMin x
let check m1 m2 = do guard (m1 == y)
return $ SolvedIf [ m2 >== m1 ]
check a b <|> check b a
-- t1 == min (K + t1) t2 ~~> t1 == t2, if K >= 1
-- (also if (K + t1) is one term in a multi-way min)
tryEqMins :: Type -> Type -> Match Solved
tryEqMins x y =
do (a, b) <- aMin y
let ys = splitMin a ++ splitMin b
let ys' = filter (not . isGt) ys
let y' = if null ys' then tInf else foldr1 Simp.tMin ys'
return $ if length ys' < length ys
then SolvedIf [x =#= y']
else Unsolved
where
splitMin :: Type -> [Type]
splitMin ty =
case matchMaybe (aMin ty) of
Just (t1, t2) -> splitMin t1 ++ splitMin t2
Nothing -> [ty]
isGt :: Type -> Bool
isGt t =
case matchMaybe (asAddK t) of
Just (k, t') -> k > 0 && t' == x
Nothing -> False
asAddK :: Type -> Match (Integer, Type)
asAddK t =
do (t1, t2) <- anAdd t
k <- aNat t1
return (k, t2)
tryEqVar :: Type -> TVar -> Match Solved
tryEqVar ty x =
-- a = K + a --> x = inf
(do (k,tv) <- matches ty (anAdd, aNat, aTVar)
guard (tv == x && k >= 1)
return $ SolvedIf [ TVar x =#= tInf ]
)
<|>
-- a = min (K + a) t --> a = t
(do (l,r) <- aMin ty
let check this other =
do (k,x') <- matches this (anAdd, aNat', aTVar)
guard (x == x' && k >= Nat 1)
return $ SolvedIf [ TVar x =#= other ]
check l r <|> check r l
)
<|>
-- a = K + min t a
(do (k,(l,r)) <- matches ty (anAdd, aNat, aMin)
guard (k >= 1)
let check a b = do x' <- aTVar a
guard (x' == x)
return (SolvedIf [ TVar x =#= tAdd (tNum k) b ])
check l r <|> check r l
)
-- e.g., 10 = t
tryEqK :: Ctxt -> Type -> Nat' -> Match Solved
tryEqK ctxt ty lk =
-- (t1 + t2 = inf, fin t1) ~~~> t2 = inf
do guard (lk == Inf)
(a,b) <- anAdd ty
let check x y = do guard (iIsFin (typeInterval ctxt x))
return $ SolvedIf [ y =#= tInf ]
check a b <|> check b a
<|>
-- (K1 + t = K2, K2 >= K1) ~~~> t = (K2 - K1)
do (rk, b) <- matches ty (anAdd, aNat', __)
return $
case nSub lk rk of
-- NOTE: (Inf - Inf) shouldn't be possible
Nothing -> Unsolvable
$ TCErrorMessage
$ "Adding " ++ showNat' rk ++ " will always exceed "
++ showNat' lk
Just r -> SolvedIf [ b =#= tNat' r ]
<|>
-- (lk = t - rk) ~~> t = lk + rk
do (t,rk) <- matches ty ((|-|) , __, aNat')
return (SolvedIf [ t =#= tNat' (nAdd lk rk) ])
<|>
do (rk, b) <- matches ty (aMul, aNat', __)
return $
case (lk,rk) of
-- Inf * t = Inf ~~~> t >= 1
(Inf,Inf) -> SolvedIf [ b >== tOne ]
-- K * t = Inf ~~~> t = Inf
(Inf,Nat _) -> SolvedIf [ b =#= tInf ]
-- Inf * t = 0 ~~~> t = 0
(Nat 0, Inf) -> SolvedIf [ b =#= tZero ]
-- Inf * t = K ~~~> ERR (K /= 0)
(Nat k, Inf) -> Unsolvable
$ TCErrorMessage
$ show k ++ " != inf * anything"
(Nat lk', Nat rk')
-- 0 * t = K2 ~~> K2 = 0
| rk' == 0 -> SolvedIf [ tNat' lk =#= tZero ]
-- shouldn't happen, as `0 * t = t` should have been simplified
-- K1 * t = K2 ~~> t = K2/K1
| (q,0) <- divMod lk' rk' -> SolvedIf [ b =#= tNum q ]
| otherwise ->
Unsolvable
$ TCErrorMessage
$ showNat' lk ++ " != " ++ showNat' rk ++ " * anything"
<|>
-- K1 == K2 ^^ t ~~> t = logBase K2 K1
do (rk, b) <- matches ty ((|^|), aNat, __)
return $ case lk of
Inf | rk > 1 -> SolvedIf [ b =#= tInf ]
Nat n | Just (a,True) <- genLog n rk -> SolvedIf [ b =#= tNum a]
_ -> Unsolvable $ TCErrorMessage
$ show rk ++ " ^^ anything != " ++ showNat' lk
-- XXX: Min, Max, etx
-- 2 = min (10,y) --> y = 2
-- 2 = min (2,y) --> y >= 2
-- 10 = min (2,y) --> impossible
-- | K1 * t1 + K2 * t2 + ... = K3 * t3 + K4 * t4 + ...
tryEqMulConst :: Type -> Type -> Match Solved
tryEqMulConst l r =
do (lc,ls) <- matchLinear l
(rc,rs) <- matchLinear r
let d = foldr1 gcd (lc : rc : map fst (ls ++ rs))
guard (d > 1)
return (SolvedIf [build d lc ls =#= build d rc rs])
where
build d k ts = foldr tAdd (cancel d k) (map (buildS d) ts)
buildS d (k,t) = tMul (cancel d k) t
cancel d x = tNum (div x d)
-- | @(t1 + t2 = Inf, fin t1) ~~> t2 = Inf@
tryEqAddInf :: Ctxt -> Type -> Type -> Match Solved
tryEqAddInf ctxt l r = check l r <|> check r l
where
-- check for x = a + b /\ x = inf
check x y =
do (x1,x2) <- anAdd x
aInf y
let x1Fin = iIsFin (typeInterval ctxt x1)
let x2Fin = iIsFin (typeInterval ctxt x2)
return $!
if | x1Fin ->
SolvedIf [ x2 =#= y ]
| x2Fin ->
SolvedIf [ x1 =#= y ]
| otherwise ->
Unsolved
-- | Check for addition of constants to both sides of a relation.
-- @((K1 + K2) + t1) `R` (K1 + t2) ~~> (K2 + t1) `R` t2@
--
-- This relies on the fact that constants are floated left during
-- simplification.
tryAddConst :: (Type -> Type -> Prop) -> Type -> Type -> Match Solved
tryAddConst rel l r =
do (x1,x2) <- anAdd l
(y1,y2) <- anAdd r
k1 <- aNat x1
k2 <- aNat y1
if k1 > k2
then return (SolvedIf [ tAdd (tNum (k1 - k2)) x2 `rel` y2 ])
else return (SolvedIf [ x2 `rel` tAdd (tNum (k2 - k1)) y2 ])
-- | Check for situations where a unification variable is involved in
-- a sum of terms not containing additional unification variables,
-- and replace it with a solution and an inequality.
-- @s1 = ?a + s2 ~~> (?a = s1 - s2, s1 >= s2)@
tryLinearSolution :: Type -> Type -> Match Solved
tryLinearSolution s1 t =
do (a,xs) <- matchLinearUnifier t
guard (noFreeVariables s1)
-- NB: matchLinearUnifier only matches if xs is nonempty
let s2 = foldr1 Simp.tAdd xs
return (SolvedIf [ TVar a =#= (Simp.tSub s1 s2), s1 >== s2 ])
-- | Match a sum of the form @(s1 + ... + ?a + ... sn)@ where
-- @s1@ through @sn@ do not contain any free variables.
--
-- Note: a successful match should only occur if @s1 ... sn@ is
-- not empty.
matchLinearUnifier :: Pat Type (TVar,[Type])
matchLinearUnifier = go []
where
go xs t =
-- Case where a free variable occurs at the end of a sequence of additions.
-- NB: match fails if @xs@ is empty
do v <- aFreeTVar t
guard (not . null $ xs)
return (v, xs)
<|>
-- Next symbol is an addition
do (x, y) <- anAdd t
-- Case where a free variable occurs in the middle of an expression
(do v <- aFreeTVar x
guard (noFreeVariables y)
return (v, reverse (y:xs))
<|>
-- Non-free-variable recursive case
do guard (noFreeVariables x)
go (x:xs) y)
-- | Is this a sum of products, where the products have constant coefficients?
matchLinear :: Pat Type (Integer, [(Integer,Type)])
matchLinear = go (0, [])
where
go (c,ts) t =
do n <- aNat t
return (n + c, ts)
<|>
do (x,y) <- aMul t
n <- aNat x
return (c, (n,y) : ts)
<|>
do (l,r) <- anAdd t
(c',ts') <- go (c,ts) l
go (c',ts') r
showNat' :: Nat' -> String
showNat' Inf = "inf"
showNat' (Nat n) = show n
cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/Numeric/ 0000755 0000000 0000000 00000000000 07346545000 020364 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/Numeric/Fin.hs 0000644 0000000 0000000 00000005545 07346545000 021445 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Solver.Numeric.Fin
-- Copyright : (c) 2015-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- Simplification of `fin` constraints.
{-# LANGUAGE PatternGuards #-}
module Cryptol.TypeCheck.Solver.Numeric.Fin where
import Data.Map (Map)
import qualified Data.Map as Map
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.Solver.Types
import Cryptol.TypeCheck.Solver.Numeric.Interval
import Cryptol.TypeCheck.Solver.InfNat
cryIsFin :: Map TVar Interval -> Prop -> Solved
cryIsFin varInfo p =
case pIsFin p of
Just ty -> cryIsFinType varInfo ty
Nothing -> Unsolved
cryIsFinType :: Map TVar Interval -> Type -> Solved
cryIsFinType varInfo ty =
case tNoUser ty of
TVar x | Just i <- Map.lookup x varInfo
, iIsFin i -> SolvedIf []
TCon (TC tc) []
| TCNum _ <- tc -> SolvedIf []
| TCInf <- tc ->
Unsolvable $ TCErrorMessage "Expected a finite type, but found `inf`."
TCon (TF f) ts ->
case (f,ts) of
(TCAdd,[t1,t2]) -> SolvedIf [ pFin t1, pFin t2 ]
(TCSub,[t1,_ ]) -> SolvedIf [ pFin t1 ]
-- fin (x * y)
(TCMul,[t1,t2])
| iLower i1 >= Nat 1 && iIsFin i1 -> SolvedIf [ pFin t2 ]
| iLower i2 >= Nat 1 && iIsFin i2 -> SolvedIf [ pFin t1 ]
| iLower i1 >= Nat 1 &&
iLower i2 >= Nat 1 -> SolvedIf [ pFin t1, pFin t2 ]
| iIsFin i1 && iIsFin i2 -> SolvedIf []
where
i1 = typeInterval varInfo t1
i2 = typeInterval varInfo t2
(TCDiv, [t1,_]) -> SolvedIf [ pFin t1 ]
(TCMod, [_,_]) -> SolvedIf []
-- fin (x ^ y)
(TCExp, [t1,t2])
| iLower i1 == Inf -> SolvedIf [ t2 =#= tZero ]
| iLower i2 == Inf -> SolvedIf [ tOne >== t1 ]
| iLower i1 >= Nat 2 -> SolvedIf [ pFin t1, pFin t2 ]
| iLower i2 >= Nat 1 -> SolvedIf [ pFin t1, pFin t2 ]
| Just x <- iUpper i1, x <= Nat 1 -> SolvedIf []
| Just (Nat 0) <- iUpper i2 -> SolvedIf []
where
i1 = typeInterval varInfo t1
i2 = typeInterval varInfo t2
-- fin (min x y)
(TCMin, [t1,t2])
| iIsFin i1 -> SolvedIf []
| iIsFin i2 -> SolvedIf []
| Just x <- iUpper i1, x <= iLower i2 -> SolvedIf [ pFin t1 ]
| Just x <- iUpper i2, x <= iLower i1 -> SolvedIf [ pFin t2 ]
where
i1 = typeInterval varInfo t1
i2 = typeInterval varInfo t2
(TCMax, [t1,t2]) -> SolvedIf [ pFin t1, pFin t2 ]
(TCWidth, [t1]) -> SolvedIf [ pFin t1 ]
(TCCeilDiv, [_,_]) -> SolvedIf []
(TCCeilMod, [_,_]) -> SolvedIf []
(TCLenFromThenTo,[_,_,_]) -> SolvedIf []
_ -> Unsolved
_ -> Unsolved
cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs 0000644 0000000 0000000 00000030144 07346545000 022506 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Solver.Numeric.Interval
-- Copyright : (c) 2015-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- An interval interpretation of types.
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE BangPatterns #-}
module Cryptol.TypeCheck.Solver.Numeric.Interval where
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat
import Cryptol.Utils.PP hiding (int)
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
-- | Only meaningful for numeric types
typeInterval :: Map TVar Interval -> Type -> Interval
typeInterval varInfo = go
where
go ty =
case ty of
TUser _ _ t -> go t
TCon tc ts ->
case (tc, ts) of
(TC TCInf, []) -> iConst Inf
(TC (TCNum n), []) -> iConst (Nat n)
(TF TCAdd, [x,y]) -> iAdd (go x) (go y)
(TF TCSub, [x,y]) -> iSub (go x) (go y)
(TF TCMul, [x,y]) -> iMul (go x) (go y)
(TF TCDiv, [x,y]) -> iDiv (go x) (go y)
(TF TCMod, [x,y]) -> iMod (go x) (go y)
(TF TCExp, [x,y]) -> iExp (go x) (go y)
(TF TCWidth, [x]) -> iWidth (go x)
(TF TCMin, [x,y]) -> iMin (go x) (go y)
(TF TCMax, [x,y]) -> iMax (go x) (go y)
(TF TCCeilDiv, [x,y]) -> iCeilDiv (go x) (go y)
(TF TCCeilMod, [x,y]) -> iCeilMod (go x) (go y)
(TF TCLenFromThenTo, [x,y,z]) ->
iLenFromThenTo (go x) (go y) (go z)
_ -> iAny
TVar x -> tvarInterval varInfo x
_ -> iAny
tvarInterval :: Map TVar Interval -> TVar -> Interval
tvarInterval varInfo x = Map.findWithDefault iAny x varInfo
data IntervalUpdate = NoChange
| InvalidInterval TVar
| NewIntervals (Map TVar Interval)
deriving (Show)
updateInterval :: (TVar,Interval) -> Map TVar Interval -> IntervalUpdate
updateInterval (x,int) varInts =
case Map.lookup x varInts of
Just int' ->
case iIntersect int int' of
Just val | int' /= val -> NewIntervals (Map.insert x val varInts)
| otherwise -> NoChange
Nothing -> InvalidInterval x
Nothing -> NewIntervals (Map.insert x int varInts)
computePropIntervals :: Map TVar Interval -> [Prop] -> IntervalUpdate
computePropIntervals ints ps0 = go (3 :: Int) False ints ps0
where
go !_n False _ [] = NoChange
go !n True is []
| n > 0 = changed is (go (n-1) False is ps0)
| otherwise = NewIntervals is
go !n new is (p:ps) =
case add False (propInterval is p) is of
InvalidInterval i -> InvalidInterval i
NewIntervals is' -> go n True is' ps
NoChange -> go n new is ps
add ch [] int = if ch then NewIntervals int else NoChange
add ch (i:is) int = case updateInterval i int of
InvalidInterval j -> InvalidInterval j
NoChange -> add ch is int
NewIntervals is' -> add True is is'
changed a x = case x of
NoChange -> NewIntervals a
r -> r
-- | What we learn about variables from a single prop.
propInterval :: Map TVar Interval -> Prop -> [(TVar,Interval)]
propInterval varInts prop = catMaybes
[ do ty <- pIsFin prop
x <- tIsVar ty
return (x,iAnyFin)
, do (l,r) <- pIsEq prop
x <- tIsVar l
return (x,typeInterval varInts r)
, do (l,r) <- pIsEq prop
x <- tIsVar r
return (x,typeInterval varInts l)
, do (l,r) <- pIsGeq prop
x <- tIsVar l
let int = typeInterval varInts r
return (x,int { iUpper = Just Inf })
, do (l,r) <- pIsGeq prop
x <- tIsVar r
let int = typeInterval varInts l
return (x,int { iLower = Nat 0 })
-- k >= width x
, do (l,r) <- pIsGeq prop
x <- tIsVar =<< pIsWidth r
-- record the exact upper bound when it produces values within 128
-- bits
let ub = case iIsExact (typeInterval varInts l) of
Just (Nat val) | val < 128 -> Just (Nat (2 ^ val - 1))
| otherwise -> Nothing
upper -> upper
return (x, Interval { iLower = Nat 0, iUpper = ub })
]
--------------------------------------------------------------------------------
data Interval = Interval
{ iLower :: Nat' -- ^ lower bound (inclusive)
, iUpper :: Maybe Nat' -- ^ upper bound (inclusive)
-- If there is no upper bound,
-- then all *natural* numbers.
} deriving (Eq,Show)
ppIntervals :: Map TVar Interval -> Doc
ppIntervals = vcat . map ppr . Map.toList
where
ppr (var,i) = pp var <.> char ':' <+> ppInterval i
ppInterval :: Interval -> Doc
ppInterval x = brackets (hsep [ ppr (iLower x)
, text ".."
, maybe (text "fin") ppr (iUpper x)])
where
ppr a = case a of
Nat n -> integer n
Inf -> text "inf"
iIsExact :: Interval -> Maybe Nat'
iIsExact i = if iUpper i == Just (iLower i) then Just (iLower i) else Nothing
iIsFin :: Interval -> Bool
iIsFin i = case iUpper i of
Just Inf -> False
_ -> True
-- | Finite positive number. @[1 .. inf)@.
iIsPosFin :: Interval -> Bool
iIsPosFin i = iLower i >= Nat 1 && iIsFin i
-- | Returns 'True' when the intervals definitely overlap, and 'False'
-- otherwise.
iOverlap :: Interval -> Interval -> Bool
iOverlap
(Interval (Nat l1) (Just (Nat h1)))
(Interval (Nat l2) (Just (Nat h2))) =
or [ h1 > l2 && h1 < h2, l1 > l2 && l1 < h2 ]
iOverlap _ _ = False
-- | Intersect two intervals, yielding a new one that describes the space where
-- they overlap. If the two intervals are disjoint, the result will be
-- 'Nothing'.
iIntersect :: Interval -> Interval -> Maybe Interval
iIntersect i j =
case (lower,upper) of
(Nat l, Just (Nat u)) | l <= u -> ok
(Nat _, Just Inf) -> ok
(Nat _, Nothing) -> ok
(Inf, Just Inf) -> ok
_ -> Nothing
where
ok = Just (Interval lower upper)
lower = nMax (iLower i) (iLower j)
upper = case (iUpper i, iUpper j) of
(Just a, Just b) -> Just (nMin a b)
(Nothing,Nothing) -> Nothing
(Just l,Nothing) | l /= Inf -> Just l
(Nothing,Just r) | r /= Inf -> Just r
_ -> Nothing
-- | Any value
iAny :: Interval
iAny = Interval (Nat 0) (Just Inf)
-- | Any finite value
iAnyFin :: Interval
iAnyFin = Interval (Nat 0) Nothing
-- | Exactly this value
iConst :: Nat' -> Interval
iConst x = Interval x (Just x)
iAdd :: Interval -> Interval -> Interval
iAdd i j = Interval { iLower = nAdd (iLower i) (iLower j)
, iUpper = case (iUpper i, iUpper j) of
(Nothing, Nothing) -> Nothing
(Just x, Just y) -> Just (nAdd x y)
(Nothing, Just y) -> upper y
(Just x, Nothing) -> upper x
}
where
upper x = case x of
Inf -> Just Inf
_ -> Nothing
iMul :: Interval -> Interval -> Interval
iMul i j = Interval { iLower = nMul (iLower i) (iLower j)
, iUpper = case (iUpper i, iUpper j) of
(Nothing, Nothing) -> Nothing
(Just x, Just y) -> Just (nMul x y)
(Nothing, Just y) -> upper y
(Just x, Nothing) -> upper x
}
where
upper x = case x of
Inf -> Just Inf
Nat 0 -> Just (Nat 0)
_ -> Nothing
iExp :: Interval -> Interval -> Interval
iExp i j = Interval { iLower = nExp (iLower i) (iLower j)
, iUpper = case (iUpper i, iUpper j) of
(Nothing, Nothing) -> Nothing
(Just x, Just y) -> Just (nExp x y)
(Nothing, Just y) -> upperR y
(Just x, Nothing) -> upperL x
}
where
upperL x = case x of
Inf -> Just Inf
Nat 0 -> Just (Nat 0)
Nat 1 -> Just (Nat 1)
_ -> Nothing
upperR x = case x of
Inf -> Just Inf
Nat 0 -> Just (Nat 1)
_ -> Nothing
iMin :: Interval -> Interval -> Interval
iMin i j = Interval { iLower = nMin (iLower i) (iLower j)
, iUpper = case (iUpper i, iUpper j) of
(Nothing, Nothing) -> Nothing
(Just x, Just y) -> Just (nMin x y)
(Nothing, Just Inf) -> Nothing
(Nothing, Just y) -> Just y
(Just Inf, Nothing) -> Nothing
(Just x, Nothing) -> Just x
}
iMax :: Interval -> Interval -> Interval
iMax i j = Interval { iLower = nMax (iLower i) (iLower j)
, iUpper = case (iUpper i, iUpper j) of
(Nothing, Nothing) -> Nothing
(Just x, Just y) -> Just (nMax x y)
(Nothing, Just Inf) -> Just Inf
(Nothing, Just _) -> Nothing
(Just Inf, Nothing) -> Just Inf
(Just _, Nothing) -> Nothing
}
iSub :: Interval -> Interval -> Interval
iSub i j = Interval { iLower = lower, iUpper = upper }
where
lower = case iUpper j of
Nothing -> Nat 0
Just x -> case nSub (iLower i) x of
Nothing -> Nat 0
Just y -> y
upper = case iUpper i of
Nothing -> Nothing
Just x -> case nSub x (iLower j) of
Nothing -> Just Inf {- malformed subtraction -}
Just y -> Just y
iDiv :: Interval -> Interval -> Interval
iDiv i j = Interval { iLower = lower, iUpper = upper }
where
lower = case iUpper j of
Nothing -> Nat 0
Just x -> case nDiv (iLower i) x of
Nothing -> Nat 0 -- malformed division
Just y -> y
upper = case iUpper i of
Nothing -> Nothing
Just x -> case nDiv x (nMax (iLower i) (Nat 1)) of
Nothing -> Just Inf
Just y -> Just y
iMod :: Interval -> Interval -> Interval
iMod _ j = Interval { iLower = Nat 0, iUpper = upper }
where
upper = case iUpper j of
Just (Nat n) | n > 0 -> Just (Nat (n - 1))
_ -> Nothing
iCeilDiv :: Interval -> Interval -> Interval
iCeilDiv i j = Interval { iLower = lower, iUpper = upper }
where
lower = case iUpper j of
Nothing -> if iLower i == Nat 0 then Nat 0 else Nat 1
Just x -> case nCeilDiv (iLower i) x of
Nothing -> Nat 0 -- malformed division
Just y -> y
upper = case iUpper i of
Nothing -> Nothing
Just x -> case nCeilDiv x (nMax (iLower i) (Nat 1)) of
Nothing -> Just Inf
Just y -> Just y
iCeilMod :: Interval -> Interval -> Interval
iCeilMod = iMod -- bounds are the same as for Mod
iWidth :: Interval -> Interval
iWidth i = Interval { iLower = nWidth (iLower i)
, iUpper = case iUpper i of
Nothing -> Nothing
Just n -> Just (nWidth n)
}
iLenFromThenTo :: Interval -> Interval -> Interval -> Interval
iLenFromThenTo i j k
| Just x <- iIsExact i, Just y <- iIsExact j, Just z <- iIsExact k
, Just r <- nLenFromThenTo x y z = iConst r
| otherwise = iAnyFin
cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/SMT.hs 0000644 0000000 0000000 00000026407 07346545000 017772 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Solver.SMT
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# Language FlexibleInstances #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Cryptol.TypeCheck.Solver.SMT
( -- * Setup
Solver
, withSolver
, isNumeric
-- * Debugging
, debugBlock
, debugLog
-- * Proving stuff
, proveImp
, checkUnsolvable
, tryGetModel
, shrinkModel
) where
import SimpleSMT (SExpr)
import qualified SimpleSMT as SMT
import Data.Map ( Map )
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe(catMaybes)
import Data.List(partition)
import Control.Exception
import Control.Monad(msum,zipWithM,void)
import Data.Char(isSpace)
import Text.Read(readMaybe)
import qualified System.IO.Strict as StrictIO
import System.FilePath((>))
import System.Directory(doesFileExist)
import Cryptol.Prelude(cryptolTcContents)
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.InferTypes
import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
import Cryptol.TypeCheck.TypePat hiding ((~>),(~~>))
import Cryptol.TypeCheck.Subst(Subst)
import Cryptol.Utils.Panic
import Cryptol.Utils.PP -- ( Doc )
-- | An SMT solver packed with a logger for debugging.
data Solver = Solver
{ solver :: SMT.Solver
-- ^ The actual solver
, logger :: SMT.Logger
-- ^ For debugging
}
-- | Execute a computation with a fresh solver instance.
withSolver :: SolverConfig -> (Solver -> IO a) -> IO a
withSolver SolverConfig{ .. } =
bracket
(do logger <- if solverVerbose > 0 then SMT.newLogger 0
else return quietLogger
let smtDbg = if solverVerbose > 1 then Just logger else Nothing
solver <- SMT.newSolver solverPath solverArgs smtDbg
_ <- SMT.setOptionMaybe solver ":global-decls" "false"
-- SMT.setLogic solver "QF_LIA"
let sol = Solver { .. }
loadTcPrelude sol solverPreludePath
return sol)
(\s -> void $ SMT.stop (solver s))
where
quietLogger = SMT.Logger { SMT.logMessage = \_ -> return ()
, SMT.logLevel = return 0
, SMT.logSetLevel= \_ -> return ()
, SMT.logTab = return ()
, SMT.logUntab = return ()
}
-- | Load the definitions used for type checking.
loadTcPrelude :: Solver -> [FilePath] {- ^ Search in this paths -} -> IO ()
loadTcPrelude s [] = loadString s cryptolTcContents
loadTcPrelude s (p : ps) =
do let file = p > "CryptolTC.z3"
yes <- doesFileExist file
if yes then loadFile s file
else loadTcPrelude s ps
loadFile :: Solver -> FilePath -> IO ()
loadFile s file = loadString s =<< StrictIO.readFile file
loadString :: Solver -> String -> IO ()
loadString s str = go (dropComments str)
where
go txt
| all isSpace txt = return ()
| otherwise =
case SMT.readSExpr txt of
Just (e,rest) -> SMT.command (solver s) e >> go rest
Nothing -> panic "loadFile" [ "Failed to parse SMT file."
, txt
]
dropComments = unlines . map dropComment . lines
dropComment xs = case break (== ';') xs of
(as,_:_) -> as
_ -> xs
--------------------------------------------------------------------------------
-- Debugging
debugBlock :: Solver -> String -> IO a -> IO a
debugBlock s@Solver { .. } name m =
do debugLog s name
SMT.logTab logger
a <- m
SMT.logUntab logger
return a
class DebugLog t where
debugLog :: Solver -> t -> IO ()
debugLogList :: Solver -> [t] -> IO ()
debugLogList s ts = case ts of
[] -> debugLog s "(none)"
_ -> mapM_ (debugLog s) ts
instance DebugLog Char where
debugLog s x = SMT.logMessage (logger s) (show x)
debugLogList s x = SMT.logMessage (logger s) x
instance DebugLog a => DebugLog [a] where
debugLog = debugLogList
instance DebugLog a => DebugLog (Maybe a) where
debugLog s x = case x of
Nothing -> debugLog s "(nothing)"
Just a -> debugLog s a
instance DebugLog Doc where
debugLog s x = debugLog s (show x)
instance DebugLog Type where
debugLog s x = debugLog s (pp x)
instance DebugLog Goal where
debugLog s x = debugLog s (goal x)
instance DebugLog Subst where
debugLog s x = debugLog s (pp x)
--------------------------------------------------------------------------------
-- | Returns goals that were not proved
proveImp :: Solver -> [Prop] -> [Goal] -> IO [Goal]
proveImp sol ps gs0 =
debugBlock sol "PROVE IMP" $
do let gs1 = concatMap flatGoal gs0
(gs,rest) = partition (isNumeric . goal) gs1
numAsmp = filter isNumeric (concatMap pSplitAnd ps)
vs = Set.toList (fvs (numAsmp, map goal gs))
tvs <- debugBlock sol "VARIABLES" $
do SMT.push (solver sol)
Map.fromList <$> zipWithM (declareVar sol) [ 0 .. ] vs
debugBlock sol "ASSUMPTIONS" $
mapM_ (assume sol tvs) numAsmp
gs' <- mapM (prove sol tvs) gs
SMT.pop (solver sol)
return (catMaybes gs' ++ rest)
-- | Check if the given goals are known to be unsolvable.
checkUnsolvable :: Solver -> [Goal] -> IO Bool
checkUnsolvable sol gs0 =
debugBlock sol "CHECK UNSOLVABLE" $
do let ps = filter isNumeric
$ map goal
$ concatMap flatGoal gs0
vs = Set.toList (fvs ps)
tvs <- debugBlock sol "VARIABLES" $
do push sol
Map.fromList <$> zipWithM (declareVar sol) [ 0 .. ] vs
ans <- unsolvable sol tvs ps
pop sol
return ans
tryGetModel :: Solver -> [TVar] -> [Prop] -> IO (Maybe [(TVar,Nat')])
tryGetModel sol as ps =
debugBlock sol "TRY GET MODEL" $
do push sol
tvs <- Map.fromList <$> zipWithM (declareVar sol) [ 0 .. ] as
mapM_ (assume sol tvs) ps
sat <- SMT.check (solver sol)
su <- case sat of
SMT.Sat ->
case as of
[] -> return (Just [])
_ -> do res <- SMT.getExprs (solver sol) (Map.elems tvs)
let parse x = do e <- Map.lookup x tvs
t <- parseNum =<< lookup e res
return (x, t)
return (mapM parse as)
_ -> return Nothing
pop sol
return su
where
parseNum a
| SMT.Other s <- a
, SMT.List [con,val,isFin,isErr] <- s
, SMT.Atom "mk-infnat" <- con
, SMT.Atom "false" <- isErr
, SMT.Atom fin <- isFin
, SMT.Atom v <- val
, Just n <- readMaybe v
= Just (if fin == "false" then Inf else Nat n)
parseNum _ = Nothing
shrinkModel :: Solver -> [TVar] -> [Prop] -> [(TVar,Nat')] -> IO [(TVar,Nat')]
shrinkModel sol as ps0 mdl = go [] ps0 mdl
where
go done ps ((x,Nat k) : more) =
do k1 <- shrink1 ps x k
go ((x,Nat k1) : done) ((tNum k1 >== TVar x) : ps) more
go done ps ((x,i) : more) = go ((x,i) : done) ps more
go done _ [] = return done
shrink1 ps x k
| k == 0 = return 0
| otherwise =
do let k1 = div k 2
p1 = tNum k1 >== TVar x
mb <- tryGetModel sol as (p1 : ps)
case mb of
Nothing -> return k
Just newMdl ->
case lookup x newMdl of
Just (Nat k2) -> shrink1 ps x k2
_ -> panic "shrink" ["model is missing variable", show x]
--------------------------------------------------------------------------------
push :: Solver -> IO ()
push sol = SMT.push (solver sol)
pop :: Solver -> IO ()
pop sol = SMT.pop (solver sol)
declareVar :: Solver -> Int -> TVar -> IO (TVar, SExpr)
declareVar s x v =
do let name = (if isFreeTV v then "fv" else "kv") ++ show x
e <- SMT.declare (solver s) name cryInfNat
SMT.assert (solver s) (SMT.fun "cryVar" [ e ])
return (v,e)
assume :: Solver -> TVars -> Prop -> IO ()
assume s tvs p = SMT.assert (solver s) (SMT.fun "cryAssume" [ toSMT tvs p ])
prove :: Solver -> TVars -> Goal -> IO (Maybe Goal)
prove sol tvs g =
debugBlock sol "PROVE" $
do let s = solver sol
push sol
SMT.assert s (SMT.fun "cryProve" [ toSMT tvs (goal g) ])
res <- SMT.check s
pop sol
case res of
SMT.Unsat -> return Nothing
_ -> return (Just g)
-- | Check if some numeric goals are known to be unsolvable.
unsolvable :: Solver -> TVars -> [Prop] -> IO Bool
unsolvable sol tvs ps =
debugBlock sol "UNSOLVABLE" $
do SMT.push (solver sol)
mapM_ (assume sol tvs) ps
res <- SMT.check (solver sol)
SMT.pop (solver sol)
case res of
SMT.Unsat -> return True
_ -> return False
--------------------------------------------------------------------------------
-- | Split up the 'And' in a goal
flatGoal :: Goal -> [Goal]
flatGoal g = [ g { goal = p } | p <- pSplitAnd (goal g) ]
-- | Assumes no 'And'
isNumeric :: Prop -> Bool
isNumeric ty = matchDefault False $ msum [ is (|=|), is (|/=|), is (|>=|), is aFin ]
where
is f = f ty >> return True
--------------------------------------------------------------------------------
type TVars = Map TVar SExpr
cryInfNat :: SExpr
cryInfNat = SMT.const "InfNat"
toSMT :: TVars -> Type -> SExpr
toSMT tvs ty = matchDefault (panic "toSMT" [ "Unexpected type", show ty ])
$ msum $ map (\f -> f tvs ty)
[ aInf ~> "cryInf"
, aNat ~> "cryNat"
, aFin ~> "cryFin"
, (|=|) ~> "cryEq"
, (|/=|) ~> "cryNeq"
, (|>=|) ~> "cryGeq"
, aAnd ~> "cryAnd"
, aTrue ~> "cryTrue"
, anAdd ~> "cryAdd"
, (|-|) ~> "crySub"
, aMul ~> "cryMul"
, (|^|) ~> "cryExp"
, (|/|) ~> "cryDiv"
, (|%|) ~> "cryMod"
, aMin ~> "cryMin"
, aMax ~> "cryMax"
, aWidth ~> "cryWidth"
, aCeilDiv ~> "cryCeilDiv"
, aCeilMod ~> "cryCeilMod"
, aLenFromThenTo ~> "cryLenFromThenTo"
, anError KNum ~> "cryErr"
, anError KProp ~> "cryErrProp"
, aTVar ~> "(unused)"
]
--------------------------------------------------------------------------------
(~>) :: Mk a => (Type -> Match a) -> String -> TVars -> Type -> Match SExpr
(m ~> f) tvs t = m t >>= \a -> return (mk tvs f a)
class Mk t where
mk :: TVars -> String -> t -> SExpr
instance Mk () where
mk _ f _ = SMT.const f
instance Mk Integer where
mk _ f x = SMT.fun f [ SMT.int x ]
instance Mk TVar where
mk tvs _ x = tvs Map.! x
instance Mk Type where
mk tvs f x = SMT.fun f [toSMT tvs x]
instance Mk TCErrorMessage where
mk _ f _ = SMT.fun f []
instance Mk (Type,Type) where
mk tvs f (x,y) = SMT.fun f [ toSMT tvs x, toSMT tvs y]
instance Mk (Type,Type,Type) where
mk tvs f (x,y,z) = SMT.fun f [ toSMT tvs x, toSMT tvs y, toSMT tvs z ]
--------------------------------------------------------------------------------
cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/Selector.hs 0000644 0000000 0000000 00000015205 07346545000 021101 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Solver.Selector
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE PatternGuards, Safe #-}
module Cryptol.TypeCheck.Solver.Selector (tryHasGoal) where
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.InferTypes
import Cryptol.TypeCheck.Monad( InferM, unify, newGoals, lookupNewtype
, newType, applySubst, solveHasGoal
, newParamName
)
import Cryptol.TypeCheck.Subst (listParamSubst, apSubst)
import Cryptol.Utils.Ident (Ident, packIdent)
import Cryptol.Utils.Panic(panic)
import Control.Monad(forM,guard)
recordType :: [Ident] -> InferM Type
recordType labels =
do fields <- forM labels $ \l ->
do t <- newType (TypeOfRecordField l) KType
return (l,t)
return (TRec fields)
tupleType :: Int -> InferM Type
tupleType n =
do fields <- mapM (\x -> newType (TypeOfTupleField x) KType)
[ 0 .. (n-1) ]
return (tTuple fields)
listType :: Int -> InferM Type
listType n =
do elems <- newType TypeOfSeqElement KType
return (tSeq (tNum n) elems)
improveSelector :: Selector -> Type -> InferM Bool
improveSelector sel outerT =
case sel of
RecordSel _ mb -> cvt recordType mb
TupleSel _ mb -> cvt tupleType mb
ListSel _ mb -> cvt listType mb
where
cvt _ Nothing = return False
cvt f (Just a) = do ty <- f a
newGoals CtExactType =<< unify ty outerT
newT <- applySubst outerT
return (newT /= outerT)
{- | Compute the type of a field based on the selector.
The given type should be "zonked" (i.e., substitution was applied to it),
and (outermost) type synonyms have been expanded.
-}
solveSelector :: Selector -> Type -> InferM (Maybe Type)
solveSelector sel outerT =
case (sel, outerT) of
(RecordSel l _, ty) ->
case ty of
TRec fs -> return (lookup l fs)
TCon (TC TCSeq) [len,el] -> liftSeq len el
TCon (TC TCFun) [t1,t2] -> liftFun t1 t2
TCon (TC (TCNewtype (UserTC x _))) ts ->
do mb <- lookupNewtype x
case mb of
Nothing -> return Nothing
Just nt ->
case lookup l (ntFields nt) of
Nothing -> return Nothing
Just t ->
do let su = listParamSubst (zip (ntParams nt) ts)
newGoals (CtPartialTypeFun x)
$ apSubst su $ ntConstraints nt
return $ Just $ apSubst su t
_ -> return Nothing
(TupleSel n _, ty) ->
case ty of
TCon (TC (TCTuple m)) ts ->
return $ do guard (0 <= n && n < m)
return $ ts !! n
TCon (TC TCSeq) [len,el] -> liftSeq len el
TCon (TC TCFun) [t1,t2] -> liftFun t1 t2
_ -> return Nothing
(ListSel n _, TCon (TC TCSeq) [l,t])
| n < 2 -> return (Just t)
| otherwise ->
do newGoals CtSelector [ l >== tNum (n - 1) ]
return (Just t)
_ -> return Nothing
where
liftSeq len el =
do mb <- solveSelector sel (tNoUser el)
return $ do el' <- mb
return (TCon (TC TCSeq) [len,el'])
liftFun t1 t2 =
do mb <- solveSelector sel (tNoUser t2)
return $ do t2' <- mb
return (TCon (TC TCFun) [t1,t2'])
-- | Solve has-constraints.
tryHasGoal :: HasGoal -> InferM (Bool, Bool) -- ^ changes, solved
tryHasGoal has
| TCon (PC (PHas sel)) [ th, ft ] <- goal (hasGoal has) =
do imped <- improveSelector sel th
outerT <- tNoUser `fmap` applySubst th
mbInnerT <- solveSelector sel outerT
case mbInnerT of
Nothing -> return (imped, False)
Just innerT ->
do newGoals CtExactType =<< unify innerT ft
oT <- applySubst outerT
iT <- applySubst innerT
sln <- mkSelSln sel oT iT
solveHasGoal (hasName has) sln
return (True, True)
| otherwise = panic "hasGoalSolved"
[ "Unexpected selector proposition:"
, show (hasGoal has)
]
{- | Generator an appropriate selector, once the "Has" constraint
has been discharged. The resulting selectors should always work
on their corresponding types (i.e., tuple selectros only select from tuples).
This function generates the code for lifting tuple/record selectors to sequences
and functions.
Assumes types are zonked. -}
mkSelSln :: Selector -> Type -> Type -> InferM HasGoalSln
mkSelSln s outerT innerT =
case tNoUser outerT of
TCon (TC TCSeq) [len,el]
| TupleSel {} <- s -> liftSeq len el
| RecordSel {} <- s -> liftSeq len el
TCon (TC TCFun) [t1,t2]
| TupleSel {} <- s -> liftFun t1 t2
| RecordSel {} <- s -> liftFun t1 t2
_ -> return HasGoalSln { hasDoSelect = \e -> ESel e s
, hasDoSet = \e v -> ESet e s v }
where
-- Has s a t => Has s ([n]a) ([n]t)
-- xs.s ~~> [ x.s | x <- xs ]
-- { xs | s = ys } ~~> [ { x | s = y } | x <- xs | y <- ys ]
liftSeq len el =
do x1 <- newParamName (packIdent "x")
x2 <- newParamName (packIdent "x")
y2 <- newParamName (packIdent "y")
case tNoUser innerT of
TCon _ [_,eli] ->
do d <- mkSelSln s el eli
pure HasGoalSln
{ hasDoSelect = \e ->
EComp len eli (hasDoSelect d (EVar x1))
[[ From x1 len el e ]]
, hasDoSet = \e v ->
EComp len el (hasDoSet d (EVar x2) (EVar y2))
[ [ From x2 len el e ]
, [ From y2 len eli v ]
]
}
_ -> panic "mkSelSln" [ "Unexpected inner seq type.", show innerT ]
-- Has s b t => Has s (a -> b)
-- f.s ~~> \x -> (f x).s
-- { f | s = g } ~~> \x -> { f x | s = g x }
liftFun t1 t2 =
do x1 <- newParamName (packIdent "x")
x2 <- newParamName (packIdent "x")
case tNoUser innerT of
TCon _ [_,inT] ->
do d <- mkSelSln s t2 inT
pure HasGoalSln
{ hasDoSelect = \e ->
EAbs x1 t1 (hasDoSelect d (EApp e (EVar x1)))
, hasDoSet = \e v ->
EAbs x2 t1 (hasDoSet d (EApp e (EVar x2))
(EApp v (EVar x2))) }
_ -> panic "mkSelSln" [ "Unexpected inner fun type", show innerT ]
cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/Types.hs 0000644 0000000 0000000 00000002077 07346545000 020430 0 ustar 00 0000000 0000000 module Cryptol.TypeCheck.Solver.Types where
import Data.Map(Map)
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.Solver.Numeric.Interval
type Ctxt = Map TVar Interval
data Solved = SolvedIf [Prop] -- ^ Solved, assuming the sub-goals.
| Unsolved -- ^ We could not solve the goal.
| Unsolvable TCErrorMessage -- ^ The goal can never be solved.
deriving (Show)
elseTry :: Solved -> Solved -> Solved
Unsolved `elseTry` x = x
x `elseTry` _ = x
solveOpts :: [Solved] -> Solved
solveOpts [] = Unsolved
solveOpts (x : xs) = x `elseTry` solveOpts xs
matchThen :: Maybe a -> (a -> Solved) -> Solved
matchThen Nothing _ = Unsolved
matchThen (Just a) f = f a
guarded :: Bool -> Solved -> Solved
guarded True x = x
guarded False _ = Unsolved
instance PP Solved where
ppPrec _ res =
case res of
SolvedIf ps -> text "solved" $$ nest 2 (vcat (map pp ps))
Unsolved -> text "unsolved"
Unsolvable e -> text "unsolvable" <.> colon <+> text (tcErrorMessage e)
cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/Utils.hs 0000644 0000000 0000000 00000004660 07346545000 020424 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Solver.Utils
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
module Cryptol.TypeCheck.Solver.Utils where
import Cryptol.TypeCheck.AST hiding (tMul)
import Cryptol.TypeCheck.SimpType(tAdd,tMul)
import Control.Monad(mplus,guard)
import Data.Maybe(listToMaybe)
-- | All ways to split a type in the form: `a + t1`, where `a` is a variable.
splitVarSummands :: Type -> [(TVar,Type)]
splitVarSummands ty0 = [ (x,t1) | (x,t1) <- go ty0, tNum (0::Int) /= t1 ]
where
go ty = case ty of
TVar x -> return (x, tNum (0::Int))
TRec {} -> []
TUser _ _ t -> go t
TCon (TF TCAdd) [t1,t2] ->
do (a,yes) <- go t1
return (a, tAdd yes t2)
`mplus`
do (a,yes) <- go t2
return (a, tAdd t1 yes)
TCon _ _ -> [] -- XXX: we could do some distributivity etc
-- | Check if we can express a type in the form: `a + t1`.
splitVarSummand :: TVar -> Type -> Maybe Type
splitVarSummand a ty = listToMaybe [ t | (x,t) <- splitVarSummands ty, x == a ]
{- | Check if we can express a type in the form: `k + t1`,
where `k` is a constant > 0.
This assumes that the type has been simplified already,
so that constants are floated to the left. -}
splitConstSummand :: Type -> Maybe (Integer, Type)
splitConstSummand ty =
case ty of
TVar {} -> Nothing
TRec {} -> Nothing
TUser _ _ t -> splitConstSummand t
TCon (TF TCAdd) [t1,t2] ->
do (k,t1') <- splitConstSummand t1
case t1' of
TCon (TC (TCNum 0)) [] -> return (k, t2)
_ -> return (k, tAdd t1' t2)
TCon (TC (TCNum k)) [] -> guard (k > 0) >> return (k, tNum (0::Int))
TCon {} -> Nothing
{- | Check if we can express a type in the form: `k * t1`,
where `k` is a constant > 1
This assumes that the type has been simplified already,
so that constants are floated to the left. -}
splitConstFactor :: Type -> Maybe (Integer, Type)
splitConstFactor ty =
case ty of
TVar {} -> Nothing
TRec {} -> Nothing
TUser _ _ t -> splitConstFactor t
TCon (TF TCMul) [t1,t2] ->
do (k,t1') <- splitConstFactor t1
return (k, tMul t1' t2)
TCon (TC (TCNum k)) [] -> guard (k > 1) >> return (k, tNum (1::Int))
TCon {} -> Nothing
cryptol-2.8.0/src/Cryptol/TypeCheck/Subst.hs 0000644 0000000 0000000 00000025276 07346545000 017160 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Subst
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Safe #-}
module Cryptol.TypeCheck.Subst
( Subst
, emptySubst
, singleSubst
, (@@)
, defaultingSubst
, listSubst
, listParamSubst
, isEmptySubst
, FVS(..)
, apSubstMaybe
, TVars(..)
, apSubstTypeMapKeys
, substBinds
, applySubstToVar
, substToList
) where
import Data.Maybe
import Data.Either (partitionEithers)
import qualified Data.Map.Strict as Map
import qualified Data.IntMap as IntMap
import Data.Set (Set)
import qualified Data.Set as Set
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.TypeMap
import qualified Cryptol.TypeCheck.SimpType as Simp
import qualified Cryptol.TypeCheck.SimpleSolver as Simp
import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.Misc(anyJust)
-- | A 'Subst' value represents a substitution that maps each 'TVar'
-- to a 'Type'.
--
-- Invariant: If there is a mapping from @TVFree _ _ tps _@ to a type
-- @t@, then @t@ must not mention (directly or indirectly) any type
-- parameter that is not in @tps@. In particular, if @t@ contains a
-- variable @TVFree _ _ tps2 _@, then @tps2@ must be a subset of
-- @tps@. This ensures that applying the substitution will not permit
-- any type parameter to escape from its scope.
data Subst = S { suFreeMap :: !(IntMap.IntMap (TVar, Type))
, suBoundMap :: !(IntMap.IntMap (TVar, Type))
, suDefaulting :: !Bool
}
deriving Show
emptySubst :: Subst
emptySubst =
S { suFreeMap = IntMap.empty
, suBoundMap = IntMap.empty
, suDefaulting = False
}
singleSubst :: TVar -> Type -> Subst
singleSubst v@(TVFree i _ _tps _) t =
S { suFreeMap = IntMap.singleton i (v, t)
, suBoundMap = IntMap.empty
, suDefaulting = False
}
singleSubst v@(TVBound tp) t =
S { suFreeMap = IntMap.empty
, suBoundMap = IntMap.singleton (tpUnique tp) (v, t)
, suDefaulting = False
}
(@@) :: Subst -> Subst -> Subst
s2 @@ s1
| isEmptySubst s2 =
if suDefaulting s1 || not (suDefaulting s2) then
s1
else
s1{ suDefaulting = True }
s2 @@ s1 =
S { suFreeMap = IntMap.map (fmap (apSubst s2)) (suFreeMap s1) `IntMap.union` suFreeMap s2
, suBoundMap = IntMap.map (fmap (apSubst s2)) (suBoundMap s1) `IntMap.union` suBoundMap s2
, suDefaulting = suDefaulting s1 || suDefaulting s2
}
-- | A defaulting substitution maps all otherwise-unmapped free
-- variables to a kind-appropriate default type (@Bit@ for value types
-- and @0@ for numeric types).
defaultingSubst :: Subst -> Subst
defaultingSubst s = s { suDefaulting = True }
-- | Makes a substitution out of a list.
-- WARNING: We do not validate the list in any way, so the caller should
-- ensure that we end up with a valid (e.g., idempotent) substitution.
listSubst :: [(TVar, Type)] -> Subst
listSubst xs
| null xs = emptySubst
| otherwise = S { suFreeMap = IntMap.fromList frees
, suBoundMap = IntMap.fromList bounds
, suDefaulting = False }
where
(frees, bounds) = partitionEithers (map classify xs)
classify x =
case fst x of
TVFree i _ _ _ -> Left (i, x)
TVBound tp -> Right (tpUnique tp, x)
-- | Makes a substitution out of a list.
-- WARNING: We do not validate the list in any way, so the caller should
-- ensure that we end up with a valid (e.g., idempotent) substitution.
listParamSubst :: [(TParam, Type)] -> Subst
listParamSubst xs
| null xs = emptySubst
| otherwise = S { suFreeMap = IntMap.empty
, suBoundMap = IntMap.fromList bounds
, suDefaulting = False }
where
bounds = [ (tpUnique tp, (TVBound tp, t)) | (tp, t) <- xs ]
isEmptySubst :: Subst -> Bool
isEmptySubst su = IntMap.null (suFreeMap su) && IntMap.null (suBoundMap su)
-- Returns the empty set if this is a defaulting substitution
substBinds :: Subst -> Set TVar
substBinds su
| suDefaulting su = Set.empty
| otherwise = Set.fromList (map fst (assocsSubst su))
substToList :: Subst -> [(TVar, Type)]
substToList s
| suDefaulting s = panic "substToList" ["Defaulting substitution."]
| otherwise = assocsSubst s
assocsSubst :: Subst -> [(TVar, Type)]
assocsSubst s = frees ++ bounds
where
frees = IntMap.elems (suFreeMap s)
bounds = IntMap.elems (suBoundMap s)
instance PP (WithNames Subst) where
ppPrec _ (WithNames s mp)
| null els = text "(empty substitution)"
| otherwise = text "Substitution:" $$ nest 2 (vcat (map pp1 els))
where pp1 (x,t) = ppWithNames mp x <+> text "=" <+> ppWithNames mp t
els = assocsSubst s
instance PP Subst where
ppPrec n = ppWithNamesPrec IntMap.empty n
-- | Apply a substitution. Returns `Nothing` if nothing changed.
apSubstMaybe :: Subst -> Type -> Maybe Type
apSubstMaybe su ty =
case ty of
TCon t ts ->
do ss <- anyJust (apSubstMaybe su) ts
case t of
TF _ -> Just $! Simp.tCon t ss
PC _ -> Just $! Simp.simplify Map.empty (TCon t ss)
_ -> Just (TCon t ss)
TUser f ts t -> do t1 <- apSubstMaybe su t
return (TUser f (map (apSubst su) ts) t1)
TRec fs -> TRec `fmap` anyJust fld fs
where fld (x,t) = do t1 <- apSubstMaybe su t
return (x,t1)
TVar x -> applySubstToVar su x
lookupSubst :: TVar -> Subst -> Maybe Type
lookupSubst x su =
fmap snd $
case x of
TVFree i _ _ _ -> IntMap.lookup i (suFreeMap su)
TVBound tp -> IntMap.lookup (tpUnique tp) (suBoundMap su)
applySubstToVar :: Subst -> TVar -> Maybe Type
applySubstToVar su x =
case lookupSubst x su of
-- For a defaulting substitution, we must recurse in order to
-- replace unmapped free vars with default types.
Just t -> Just (if suDefaulting su then apSubst su t else t)
Nothing
| suDefaulting su -> Just $! defaultFreeVar x
| otherwise -> Nothing
class TVars t where
apSubst :: Subst -> t -> t -- ^ replaces free vars
instance TVars t => TVars (Maybe t) where
apSubst s = fmap (apSubst s)
instance TVars t => TVars [t] where
apSubst s = map (apSubst s)
instance (TVars s, TVars t) => TVars (s,t) where
apSubst s (x,y) = (apSubst s x, apSubst s y)
instance TVars Type where
apSubst su ty = fromMaybe ty (apSubstMaybe su ty)
-- | Pick types for unconstrained unification variables.
defaultFreeVar :: TVar -> Type
defaultFreeVar x@(TVBound {}) = TVar x
defaultFreeVar (TVFree _ k _ d) =
case k of
KType -> tBit
KNum -> tNum (0 :: Int)
_ -> panic "Cryptol.TypeCheck.Subst.defaultFreeVar"
[ "Free variable of unexpected kind."
, "Source: " ++ show d
, "Kind: " ++ show (pp k) ]
instance (Functor m, TVars a) => TVars (List m a) where
apSubst su = fmap (apSubst su)
instance TVars a => TVars (TypeMap a) where
apSubst su = fmap (apSubst su)
-- | Apply the substitution to the keys of a type map.
apSubstTypeMapKeys :: Subst -> TypeMap a -> TypeMap a
apSubstTypeMapKeys su = go (\_ x -> x) id
where
go :: (a -> a -> a) -> (a -> a) -> TypeMap a -> TypeMap a
go merge atNode TM { .. } = foldl addKey tm' tys
where
addKey tm (ty,a) = insertWithTM merge ty a tm
tm' = TM { tvar = Map.fromList vars
, tcon = fmap (lgo merge atNode) tcon
, trec = fmap (lgo merge atNode) trec
}
-- partition out variables that have been replaced with more specific types
(vars,tys) = partitionEithers
[ case applySubstToVar su v of
Just ty -> Right (ty,a')
Nothing -> Left (v, a')
| (v,a) <- Map.toList tvar
, let a' = atNode a
]
lgo :: (a -> a -> a) -> (a -> a) -> List TypeMap a -> List TypeMap a
lgo merge atNode k = k { nil = fmap atNode (nil k)
, cons = go (unionTM merge)
(lgo merge atNode)
(cons k)
}
{- | This instance does not need to worry about bound variable
capture, because we rely on the 'Subst' datatype invariant to ensure
that variable scopes will be properly preserved. -}
instance TVars Schema where
apSubst su (Forall xs ps t) = Forall xs (concatMap pSplitAnd (apSubst su ps))
(apSubst su t)
instance TVars Expr where
apSubst su = go
where
go expr =
case expr of
EApp e1 e2 -> EApp (go e1) (go e2)
EAbs x t e1 -> EAbs x (apSubst su t) (go e1)
ETAbs a e -> ETAbs a (go e)
ETApp e t -> ETApp (go e) (apSubst su t)
EProofAbs p e -> EProofAbs hmm (go e)
where hmm = case pSplitAnd (apSubst su p) of
[p1] -> p1
res -> panic "apSubst@EProofAbs"
[ "Predicate split or disappeared after"
, "we applied a substitution."
, "Predicate:"
, show (pp p)
, "Became:"
, show (map pp res)
, "subst:"
, show (pp su)
]
EProofApp e -> EProofApp (go e)
EVar {} -> expr
ETuple es -> ETuple (map go es)
ERec fs -> ERec [ (f, go e) | (f,e) <- fs ]
ESet e x v -> ESet (go e) x (go v)
EList es t -> EList (map go es) (apSubst su t)
ESel e s -> ESel (go e) s
EComp len t e mss -> EComp (apSubst su len) (apSubst su t) (go e) (apSubst su mss)
EIf e1 e2 e3 -> EIf (go e1) (go e2) (go e3)
EWhere e ds -> EWhere (go e) (apSubst su ds)
instance TVars Match where
apSubst su (From x len t e) = From x (apSubst su len) (apSubst su t) (apSubst su e)
apSubst su (Let b) = Let (apSubst su b)
instance TVars DeclGroup where
apSubst su (NonRecursive d) = NonRecursive (apSubst su d)
apSubst su (Recursive ds) = Recursive (apSubst su ds)
instance TVars Decl where
apSubst su d = d { dSignature = apSubst su (dSignature d)
, dDefinition = apSubst su (dDefinition d)
}
instance TVars DeclDef where
apSubst su (DExpr e) = DExpr (apSubst su e)
apSubst _ DPrim = DPrim
instance TVars Module where
apSubst su m = m { mDecls = apSubst su (mDecls m) }
cryptol-2.8.0/src/Cryptol/TypeCheck/TCon.hs 0000644 0000000 0000000 00000023013 07346545000 016706 0 ustar 00 0000000 0000000 {-# Language DeriveGeneric, DeriveAnyClass #-}
module Cryptol.TypeCheck.TCon where
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq
import Cryptol.Parser.Selector
import Cryptol.Parser.Fixity
import qualified Cryptol.ModuleSystem.Name as M
import Cryptol.Utils.Ident
import Cryptol.Utils.PP
-- | This is used for pretty prinitng.
-- XXX: it would be nice to just rely in the info from the Prelude.
infixPrimTy :: TCon -> Maybe (Ident,Fixity)
infixPrimTy = \tc -> Map.lookup tc mp
where
mp = Map.fromList
[ tInfix "==" PC PEqual (n 20)
, tInfix "!=" PC PNeq (n 20)
, tInfix ">=" PC PGeq (n 30)
, tInfix "+" TF TCAdd (l 80)
, tInfix "-" TF TCSub (l 80)
, tInfix "*" TF TCMul (l 90)
, tInfix "/" TF TCDiv (l 90)
, tInfix "%" TF TCMod (l 90)
, tInfix "^^" TF TCExp (r 95)
, tInfix "/^" TF TCCeilDiv (l 90)
, tInfix "%^" TF TCCeilMod (l 90)
]
r x = Fixity { fAssoc = RightAssoc, fLevel = x }
l x = Fixity { fAssoc = LeftAssoc, fLevel = x }
n x = Fixity { fAssoc = NonAssoc, fLevel = x }
tInfix x mk tc f = (mk tc, (packIdent x, f))
builtInType :: M.Name -> Maybe TCon
builtInType nm =
case M.nameInfo nm of
M.Declared m _
| m == preludeName -> Map.lookup (M.nameIdent nm) builtInTypes
_ -> Nothing
where
x ~> y = (packIdent x, y)
builtInTypes = Map.fromList
[ -- Types
"inf" ~> TC TCInf
, "Bit" ~> TC TCBit
, "Integer" ~> TC TCInteger
, "Z" ~> TC TCIntMod
-- Predicate contstructors
, "==" ~> PC PEqual
, "!=" ~> PC PNeq
, ">=" ~> PC PGeq
, "fin" ~> PC PFin
, "Zero" ~> PC PZero
, "Logic" ~> PC PLogic
, "Arith" ~> PC PArith
, "Cmp" ~> PC PCmp
, "SignedCmp" ~> PC PSignedCmp
, "Literal" ~> PC PLiteral
-- Type functions
, "+" ~> TF TCAdd
, "-" ~> TF TCSub
, "*" ~> TF TCMul
, "/" ~> TF TCDiv
, "%" ~> TF TCMod
, "^^" ~> TF TCExp
, "width" ~> TF TCWidth
, "min" ~> TF TCMin
, "max" ~> TF TCMax
, "/^" ~> TF TCCeilDiv
, "%^" ~> TF TCCeilMod
, "lengthFromThenTo" ~> TF TCLenFromThenTo
]
--------------------------------------------------------------------------------
infixr 5 :->
-- | Kinds, classify types.
data Kind = KType
| KNum
| KProp
| Kind :-> Kind
deriving (Eq, Ord, Show, Generic, NFData)
class HasKind t where
kindOf :: t -> Kind
instance HasKind TCon where
kindOf (TC tc) = kindOf tc
kindOf (PC pc) = kindOf pc
kindOf (TF tf) = kindOf tf
kindOf (TError k _) = k
instance HasKind UserTC where
kindOf (UserTC _ k) = k
instance HasKind TC where
kindOf tcon =
case tcon of
TCNum _ -> KNum
TCInf -> KNum
TCBit -> KType
TCInteger -> KType
TCIntMod -> KNum :-> KType
TCSeq -> KNum :-> KType :-> KType
TCFun -> KType :-> KType :-> KType
TCTuple n -> foldr (:->) KType (replicate n KType)
TCNewtype x -> kindOf x
TCAbstract x -> kindOf x
instance HasKind PC where
kindOf pc =
case pc of
PEqual -> KNum :-> KNum :-> KProp
PNeq -> KNum :-> KNum :-> KProp
PGeq -> KNum :-> KNum :-> KProp
PFin -> KNum :-> KProp
PHas _ -> KType :-> KType :-> KProp
PZero -> KType :-> KProp
PLogic -> KType :-> KProp
PArith -> KType :-> KProp
PCmp -> KType :-> KProp
PSignedCmp -> KType :-> KProp
PLiteral -> KNum :-> KType :-> KProp
PAnd -> KProp :-> KProp :-> KProp
PTrue -> KProp
instance HasKind TFun where
kindOf tfun =
case tfun of
TCWidth -> KNum :-> KNum
TCAdd -> KNum :-> KNum :-> KNum
TCSub -> KNum :-> KNum :-> KNum
TCMul -> KNum :-> KNum :-> KNum
TCDiv -> KNum :-> KNum :-> KNum
TCMod -> KNum :-> KNum :-> KNum
TCExp -> KNum :-> KNum :-> KNum
TCMin -> KNum :-> KNum :-> KNum
TCMax -> KNum :-> KNum :-> KNum
TCCeilDiv -> KNum :-> KNum :-> KNum
TCCeilMod -> KNum :-> KNum :-> KNum
TCLenFromThenTo -> KNum :-> KNum :-> KNum :-> KNum
-- | Type constants.
data TCon = TC TC | PC PC | TF TFun | TError Kind TCErrorMessage
deriving (Show, Eq, Ord, Generic, NFData)
-- | Predicate symbols.
-- If you add additional user-visible constructors, please update 'primTys'.
data PC = PEqual -- ^ @_ == _@
| PNeq -- ^ @_ /= _@
| PGeq -- ^ @_ >= _@
| PFin -- ^ @fin _@
-- classes
| PHas Selector -- ^ @Has sel type field@ does not appear in schemas
| PZero -- ^ @Zero _@
| PLogic -- ^ @Logic _@
| PArith -- ^ @Arith _@
| PCmp -- ^ @Cmp _@
| PSignedCmp -- ^ @SignedCmp _@
| PLiteral -- ^ @Literal _ _@
| PAnd -- ^ This is useful when simplifying things in place
| PTrue -- ^ Ditto
deriving (Show, Eq, Ord, Generic, NFData)
-- | 1-1 constants.
-- If you add additional user-visible constructors, please update 'primTys'.
data TC = TCNum Integer -- ^ Numbers
| TCInf -- ^ Inf
| TCBit -- ^ Bit
| TCInteger -- ^ Integer
| TCIntMod -- ^ @Z _@
| TCSeq -- ^ @[_] _@
| TCFun -- ^ @_ -> _@
| TCTuple Int -- ^ @(_, _, _)@
| TCAbstract UserTC -- ^ An abstract type
| TCNewtype UserTC -- ^ user-defined, @T@
deriving (Show, Eq, Ord, Generic, NFData)
data UserTC = UserTC M.Name Kind
deriving (Show, Generic, NFData)
instance Eq UserTC where
UserTC x _ == UserTC y _ = x == y
instance Ord UserTC where
compare (UserTC x _) (UserTC y _) = compare x y
data TCErrorMessage = TCErrorMessage
{ tcErrorMessage :: !String
-- XXX: Add location?
} deriving (Show, Eq, Ord, Generic, NFData)
-- | Built-in type functions.
-- If you add additional user-visible constructors,
-- please update 'primTys' in "Cryptol.Prims.Types".
data TFun
= TCAdd -- ^ @ : Num -> Num -> Num @
| TCSub -- ^ @ : Num -> Num -> Num @
| TCMul -- ^ @ : Num -> Num -> Num @
| TCDiv -- ^ @ : Num -> Num -> Num @
| TCMod -- ^ @ : Num -> Num -> Num @
| TCExp -- ^ @ : Num -> Num -> Num @
| TCWidth -- ^ @ : Num -> Num @
| TCMin -- ^ @ : Num -> Num -> Num @
| TCMax -- ^ @ : Num -> Num -> Num @
| TCCeilDiv -- ^ @ : Num -> Num -> Num @
| TCCeilMod -- ^ @ : Num -> Num -> Num @
-- Computing the lengths of explicit enumerations
| TCLenFromThenTo -- ^ @ : Num -> Num -> Num -> Num@
-- Example: @[ 1, 5 .. 9 ] :: [lengthFromThenTo 1 5 9][b]@
deriving (Show, Eq, Ord, Bounded, Enum, Generic, NFData)
--------------------------------------------------------------------------------
-- Pretty printing
instance PP Kind where
ppPrec p k = case k of
KType -> char '*'
KNum -> char '#'
KProp -> text "Prop"
l :-> r -> optParens (p >= 1) (sep [ppPrec 1 l, text "->", ppPrec 0 r])
instance PP TCon where
ppPrec _ (TC tc) = pp tc
ppPrec _ (PC tc) = pp tc
ppPrec _ (TF tc) = pp tc
ppPrec _ (TError _ msg) = pp msg
instance PP TCErrorMessage where
ppPrec _ tc = parens (text "error:" <+> text (tcErrorMessage tc))
instance PP PC where
ppPrec _ x =
case x of
PEqual -> text "(==)"
PNeq -> text "(/=)"
PGeq -> text "(>=)"
PFin -> text "fin"
PHas sel -> parens (ppSelector sel)
PZero -> text "Zero"
PLogic -> text "Logic"
PArith -> text "Arith"
PCmp -> text "Cmp"
PSignedCmp -> text "SignedCmp"
PLiteral -> text "Literal"
PTrue -> text "True"
PAnd -> text "(&&)"
instance PP TC where
ppPrec _ x =
case x of
TCNum n -> integer n
TCInf -> text "inf"
TCBit -> text "Bit"
TCInteger -> text "Integer"
TCIntMod -> text "Z"
TCSeq -> text "[]"
TCFun -> text "(->)"
TCTuple 0 -> text "()"
TCTuple 1 -> text "(one tuple?)"
TCTuple n -> parens $ hcat $ replicate (n-1) comma
TCNewtype u -> pp u
TCAbstract u -> pp u
instance PP UserTC where
ppPrec p (UserTC x _) = ppPrec p x
instance PP TFun where
ppPrec _ tcon =
case tcon of
TCAdd -> text "+"
TCSub -> text "-"
TCMul -> text "*"
TCDiv -> text "/"
TCMod -> text "%"
TCExp -> text "^^"
TCWidth -> text "width"
TCMin -> text "min"
TCMax -> text "max"
TCCeilDiv -> text "/^"
TCCeilMod -> text "%^"
TCLenFromThenTo -> text "lengthFromThenTo"
cryptol-2.8.0/src/Cryptol/TypeCheck/Type.hs 0000644 0000000 0000000 00000063033 07346545000 016772 0 ustar 00 0000000 0000000 {-# Language Safe, DeriveGeneric, DeriveAnyClass, RecordWildCards #-}
{-# Language FlexibleInstances, FlexibleContexts #-}
{-# Language PatternGuards #-}
{-# Language OverloadedStrings #-}
module Cryptol.TypeCheck.Type
( module Cryptol.TypeCheck.Type
, module Cryptol.TypeCheck.TCon
) where
import GHC.Generics (Generic)
import Control.DeepSeq
import qualified Data.IntMap as IntMap
import Data.Set (Set)
import qualified Data.Set as Set
import Data.List(sortBy)
import Data.Ord(comparing)
import Cryptol.Parser.Selector
import Cryptol.Parser.Fixity
import Cryptol.Parser.Position(Range,emptyRange)
import Cryptol.ModuleSystem.Name
import Cryptol.Utils.Ident (Ident)
import Cryptol.TypeCheck.TCon
import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.Solver.InfNat
import Cryptol.Utils.Panic(panic)
import Prelude
infix 4 =#=, >==
infixr 5 `tFun`
-- | The types of polymorphic values.
data Schema = Forall { sVars :: [TParam], sProps :: [Prop], sType :: Type }
deriving (Eq, Show, Generic, NFData)
-- | Type parameters.
data TParam = TParam { tpUnique :: !Int -- ^ Parameter identifier
, tpKind :: Kind -- ^ Kind of parameter
, tpFlav :: TPFlavor
-- ^ What sort of type parameter is this
, tpInfo :: !TVarInfo
-- ^ A description for better messages.
}
deriving (Generic, NFData, Show)
data TPFlavor = TPModParam Name
| TPOther (Maybe Name)
deriving (Generic, NFData, Show)
tMono :: Type -> Schema
tMono = Forall [] []
isMono :: Schema -> Maybe Type
isMono s =
case s of
Forall [] [] t -> Just t
_ -> Nothing
schemaParam :: Name -> TPFlavor
schemaParam x = TPOther (Just x)
tySynParam :: Name -> TPFlavor
tySynParam x = TPOther (Just x)
propSynParam :: Name -> TPFlavor
propSynParam x = TPOther (Just x)
newtypeParam :: Name -> TPFlavor
newtypeParam x = TPOther (Just x)
modTyParam :: Name -> TPFlavor
modTyParam = TPModParam
tpfName :: TPFlavor -> Maybe Name
tpfName f =
case f of
TPModParam x -> Just x
TPOther x -> x
tpName :: TParam -> Maybe Name
tpName = tpfName . tpFlav
-- | The internal representation of types.
-- These are assumed to be kind correct.
data Type = TCon !TCon ![Type]
-- ^ Type constant with args
| TVar TVar
-- ^ Type variable (free or bound)
| TUser !Name ![Type] !Type
{- ^ This is just a type annotation, for a type that
was written as a type synonym. It is useful so that we
can use it to report nicer errors.
Example: `TUser T ts t` is really just the type `t` that
was written as `T ts` by the user. -}
| TRec ![(Ident,Type)]
-- ^ Record type
deriving (Show, Generic, NFData)
-- | Type variables.
data TVar = TVFree !Int Kind (Set TParam) TVarInfo
-- ^ Unique, kind, ids of bound type variables that are in scope
-- The last field gives us some infor for nicer warnings/errors.
| TVBound {-# UNPACK #-} !TParam
deriving (Show, Generic, NFData)
tvInfo :: TVar -> TVarInfo
tvInfo tv =
case tv of
TVFree _ _ _ d -> d
TVBound tp -> tpInfo tp
data TVarInfo = TVarInfo { tvarSource :: Range -- ^ Source code that gave rise
, tvarDesc :: TVarSource -- ^ Description
}
deriving (Show, Generic, NFData)
data TVarSource = TVFromModParam Name -- ^ Name of module parameter
| TVFromSignature Name -- ^ A variable in a signature
| TypeWildCard
| TypeOfRecordField Ident
| TypeOfTupleField Int
| TypeOfSeqElement
| LenOfSeq
| TypeParamInstNamed {-Fun-}Name {-Param-}Ident
| TypeParamInstPos {-Fun-}Name {-Pos (from 1)-}Int
| DefinitionOf Name
| LenOfCompGen
| TypeOfArg (Maybe Int)
| TypeOfRes
| TypeErrorPlaceHolder
deriving (Show, Generic, NFData)
-- | Get the names of something that is related to the tvar.
tvSourceName :: TVarSource -> Maybe Name
tvSourceName tvs =
case tvs of
TVFromModParam x -> Just x
TVFromSignature x -> Just x
TypeParamInstNamed x _ -> Just x
TypeParamInstPos x _ -> Just x
DefinitionOf x -> Just x
_ -> Nothing
-- | The type is supposed to be of kind `KProp`
type Prop = Type
-- | Type synonym.
data TySyn = TySyn { tsName :: Name -- ^ Name
, tsParams :: [TParam] -- ^ Parameters
, tsConstraints :: [Prop] -- ^ Ensure body is OK
, tsDef :: Type -- ^ Definition
, tsDoc :: !(Maybe String) -- ^ Documentation
}
deriving (Show, Generic, NFData)
-- | Named records
data Newtype = Newtype { ntName :: Name
, ntParams :: [TParam]
, ntConstraints :: [Prop]
, ntFields :: [(Ident,Type)]
, ntDoc :: Maybe String
} deriving (Show, Generic, NFData)
-- | Information about an abstract type.
data AbstractType = AbstractType
{ atName :: Name
, atKind :: Kind
, atCtrs :: ([TParam], [Prop])
, atFixitiy :: Maybe Fixity
, atDoc :: Maybe String
} deriving (Show, Generic, NFData)
--------------------------------------------------------------------------------
instance HasKind TVar where
kindOf (TVFree _ k _ _) = k
kindOf (TVBound tp) = kindOf tp
instance HasKind Type where
kindOf ty =
case ty of
TVar a -> kindOf a
TCon c ts -> quickApply (kindOf c) ts
TUser _ _ t -> kindOf t
TRec {} -> KType
instance HasKind TySyn where
kindOf ts = foldr (:->) (kindOf (tsDef ts)) (map kindOf (tsParams ts))
instance HasKind Newtype where
kindOf nt = foldr (:->) KType (map kindOf (ntParams nt))
instance HasKind TParam where
kindOf p = tpKind p
quickApply :: Kind -> [a] -> Kind
quickApply k [] = k
quickApply (_ :-> k) (_ : ts) = quickApply k ts
quickApply k _ = panic "Cryptol.TypeCheck.AST.quickApply"
[ "Applying a non-function kind:", show k ]
kindResult :: Kind -> Kind
kindResult (_ :-> k) = kindResult k
kindResult k = k
--------------------------------------------------------------------------------
-- Syntactic equality, ignoring type synonyms and record order
instance Eq Type where
TUser _ _ x == y = x == y
x == TUser _ _ y = y == x
TCon x xs == TCon y ys = x == y && xs == ys
TVar x == TVar y = x == y
TRec xs == TRec ys = norm xs == norm ys
where norm = sortBy (comparing fst)
_ == _ = False
instance Ord Type where
compare x0 y0 =
case (x0,y0) of
(TUser _ _ t, _) -> compare t y0
(_, TUser _ _ t) -> compare x0 t
(TVar x, TVar y) -> compare x y
(TVar {}, _) -> LT
(_, TVar {}) -> GT
(TCon x xs, TCon y ys) -> compare (x,xs) (y,ys)
(TCon {}, _) -> LT
(_,TCon {}) -> GT
(TRec xs, TRec ys) -> compare (norm xs) (norm ys)
where norm = sortBy (comparing fst)
instance Eq TParam where
x == y = tpUnique x == tpUnique y
instance Ord TParam where
compare x y = compare (tpUnique x) (tpUnique y)
tpVar :: TParam -> TVar
tpVar p = TVBound p
-- | The type is "simple" (i.e., it contains no type functions).
type SType = Type
newtypeConType :: Newtype -> Schema
newtypeConType nt =
Forall as (ntConstraints nt)
$ TRec (ntFields nt) `tFun` TCon (newtypeTyCon nt) (map (TVar . tpVar) as)
where
as = ntParams nt
abstractTypeTC :: AbstractType -> TCon
abstractTypeTC at =
case builtInType (atName at) of
Just tcon -> tcon
_ -> TC $ TCAbstract $ UserTC (atName at) (atKind at)
instance Eq TVar where
TVBound x == TVBound y = x == y
TVFree x _ _ _ == TVFree y _ _ _ = x == y
_ == _ = False
instance Ord TVar where
compare (TVFree x _ _ _) (TVFree y _ _ _) = compare x y
compare (TVFree _ _ _ _) _ = LT
compare _ (TVFree _ _ _ _) = GT
compare (TVBound x) (TVBound y) = compare x y
--------------------------------------------------------------------------------
-- Queries
isFreeTV :: TVar -> Bool
isFreeTV (TVFree {}) = True
isFreeTV _ = False
isBoundTV :: TVar -> Bool
isBoundTV (TVBound {}) = True
isBoundTV _ = False
tIsError :: Type -> Maybe TCErrorMessage
tIsError ty = case tNoUser ty of
TCon (TError _ x) _ -> Just x
_ -> Nothing
tIsNat' :: Type -> Maybe Nat'
tIsNat' ty =
case tNoUser ty of
TCon (TC (TCNum x)) [] -> Just (Nat x)
TCon (TC TCInf) [] -> Just Inf
_ -> Nothing
tIsNum :: Type -> Maybe Integer
tIsNum ty = do Nat x <- tIsNat' ty
return x
tIsInf :: Type -> Bool
tIsInf ty = tIsNat' ty == Just Inf
tIsVar :: Type -> Maybe TVar
tIsVar ty = case tNoUser ty of
TVar x -> Just x
_ -> Nothing
tIsFun :: Type -> Maybe (Type, Type)
tIsFun ty = case tNoUser ty of
TCon (TC TCFun) [a, b] -> Just (a, b)
_ -> Nothing
tIsSeq :: Type -> Maybe (Type, Type)
tIsSeq ty = case tNoUser ty of
TCon (TC TCSeq) [n, a] -> Just (n, a)
_ -> Nothing
tIsBit :: Type -> Bool
tIsBit ty = case tNoUser ty of
TCon (TC TCBit) [] -> True
_ -> False
tIsInteger :: Type -> Bool
tIsInteger ty = case tNoUser ty of
TCon (TC TCInteger) [] -> True
_ -> False
tIsIntMod :: Type -> Maybe Type
tIsIntMod ty = case tNoUser ty of
TCon (TC TCIntMod) [n] -> Just n
_ -> Nothing
tIsTuple :: Type -> Maybe [Type]
tIsTuple ty = case tNoUser ty of
TCon (TC (TCTuple _)) ts -> Just ts
_ -> Nothing
tIsRec :: Type -> Maybe [(Ident, Type)]
tIsRec ty = case tNoUser ty of
TRec fs -> Just fs
_ -> Nothing
tIsBinFun :: TFun -> Type -> Maybe (Type,Type)
tIsBinFun f ty = case tNoUser ty of
TCon (TF g) [a,b] | f == g -> Just (a,b)
_ -> Nothing
-- | Split up repeated occurances of the given binary type-level function.
tSplitFun :: TFun -> Type -> [Type]
tSplitFun f t0 = go t0 []
where go ty xs = case tIsBinFun f ty of
Just (a,b) -> go a (go b xs)
Nothing -> ty : xs
pIsFin :: Prop -> Maybe Type
pIsFin ty = case tNoUser ty of
TCon (PC PFin) [t1] -> Just t1
_ -> Nothing
pIsGeq :: Prop -> Maybe (Type,Type)
pIsGeq ty = case tNoUser ty of
TCon (PC PGeq) [t1,t2] -> Just (t1,t2)
_ -> Nothing
pIsEq :: Prop -> Maybe (Type,Type)
pIsEq ty = case tNoUser ty of
TCon (PC PEqual) [t1,t2] -> Just (t1,t2)
_ -> Nothing
pIsZero :: Prop -> Maybe Type
pIsZero ty = case tNoUser ty of
TCon (PC PZero) [t1] -> Just t1
_ -> Nothing
pIsLogic :: Prop -> Maybe Type
pIsLogic ty = case tNoUser ty of
TCon (PC PLogic) [t1] -> Just t1
_ -> Nothing
pIsArith :: Prop -> Maybe Type
pIsArith ty = case tNoUser ty of
TCon (PC PArith) [t1] -> Just t1
_ -> Nothing
pIsCmp :: Prop -> Maybe Type
pIsCmp ty = case tNoUser ty of
TCon (PC PCmp) [t1] -> Just t1
_ -> Nothing
pIsSignedCmp :: Prop -> Maybe Type
pIsSignedCmp ty = case tNoUser ty of
TCon (PC PSignedCmp) [t1] -> Just t1
_ -> Nothing
pIsLiteral :: Prop -> Maybe (Type, Type)
pIsLiteral ty = case tNoUser ty of
TCon (PC PLiteral) [t1, t2] -> Just (t1, t2)
_ -> Nothing
pIsTrue :: Prop -> Bool
pIsTrue ty = case tNoUser ty of
TCon (PC PTrue) _ -> True
_ -> False
pIsWidth :: Prop -> Maybe Type
pIsWidth ty = case tNoUser ty of
TCon (TF TCWidth) [t1] -> Just t1
_ -> Nothing
--------------------------------------------------------------------------------
tNum :: Integral a => a -> Type
tNum n = TCon (TC (TCNum (toInteger n))) []
tZero :: Type
tZero = tNum (0 :: Int)
tOne :: Type
tOne = tNum (1 :: Int)
tTwo :: Type
tTwo = tNum (2 :: Int)
tInf :: Type
tInf = TCon (TC TCInf) []
tNat' :: Nat' -> Type
tNat' n' = case n' of
Inf -> tInf
Nat n -> tNum n
tAbstract :: UserTC -> [Type] -> Type
tAbstract u ts = TCon (TC (TCAbstract u)) ts
tBit :: Type
tBit = TCon (TC TCBit) []
tInteger :: Type
tInteger = TCon (TC TCInteger) []
tIntMod :: Type -> Type
tIntMod n = TCon (TC TCIntMod) [n]
tWord :: Type -> Type
tWord a = tSeq a tBit
tSeq :: Type -> Type -> Type
tSeq a b = TCon (TC TCSeq) [a,b]
tChar :: Type
tChar = tWord (tNum (8 :: Int))
tString :: Int -> Type
tString len = tSeq (tNum len) tChar
tRec :: [(Ident,Type)] -> Type
tRec = TRec
tTuple :: [Type] -> Type
tTuple ts = TCon (TC (TCTuple (length ts))) ts
newtypeTyCon :: Newtype -> TCon
newtypeTyCon nt = TC $ TCNewtype $ UserTC (ntName nt) (kindOf nt)
-- | Make a function type.
tFun :: Type -> Type -> Type
tFun a b = TCon (TC TCFun) [a,b]
-- | Eliminate outermost type synonyms.
tNoUser :: Type -> Type
tNoUser t = case t of
TUser _ _ a -> tNoUser a
_ -> t
--------------------------------------------------------------------------------
-- Construction of type functions
-- | Make a malformed numeric type.
tBadNumber :: TCErrorMessage -> Type
tBadNumber = tError KNum
-- | Make an error value of the given type.
tError :: Kind -> TCErrorMessage -> Type
tError k msg = TCon (TError k msg) []
tf1 :: TFun -> Type -> Type
tf1 f x = TCon (TF f) [x]
tf2 :: TFun -> Type -> Type -> Type
tf2 f x y = TCon (TF f) [x,y]
tf3 :: TFun -> Type -> Type -> Type -> Type
tf3 f x y z = TCon (TF f) [x,y,z]
tSub :: Type -> Type -> Type
tSub = tf2 TCSub
tMul :: Type -> Type -> Type
tMul = tf2 TCMul
tDiv :: Type -> Type -> Type
tDiv = tf2 TCDiv
tMod :: Type -> Type -> Type
tMod = tf2 TCMod
tExp :: Type -> Type -> Type
tExp = tf2 TCExp
tMin :: Type -> Type -> Type
tMin = tf2 TCMin
tCeilDiv :: Type -> Type -> Type
tCeilDiv = tf2 TCCeilDiv
tCeilMod :: Type -> Type -> Type
tCeilMod = tf2 TCCeilMod
tLenFromThenTo :: Type -> Type -> Type -> Type
tLenFromThenTo = tf3 TCLenFromThenTo
--------------------------------------------------------------------------------
-- Construction of constraints.
-- | Equality for numeric types.
(=#=) :: Type -> Type -> Prop
x =#= y = TCon (PC PEqual) [x,y]
(=/=) :: Type -> Type -> Prop
x =/= y = TCon (PC PNeq) [x,y]
pZero :: Type -> Prop
pZero t = TCon (PC PZero) [t]
pLogic :: Type -> Prop
pLogic t = TCon (PC PLogic) [t]
pArith :: Type -> Prop
pArith t = TCon (PC PArith) [t]
pCmp :: Type -> Prop
pCmp t = TCon (PC PCmp) [t]
pSignedCmp :: Type -> Prop
pSignedCmp t = TCon (PC PSignedCmp) [t]
pLiteral :: Type -> Type -> Prop
pLiteral x y = TCon (PC PLiteral) [x, y]
-- | Make a greater-than-or-equal-to constraint.
(>==) :: Type -> Type -> Prop
x >== y = TCon (PC PGeq) [x,y]
-- | A `Has` constraint, used for tuple and record selection.
pHas :: Selector -> Type -> Type -> Prop
pHas l ty fi = TCon (PC (PHas l)) [ty,fi]
pTrue :: Prop
pTrue = TCon (PC PTrue) []
pAnd :: [Prop] -> Prop
pAnd [] = pTrue
pAnd [x] = x
pAnd (x : xs)
| Just _ <- tIsError x = x
| pIsTrue x = rest
| Just _ <- tIsError rest = rest
| pIsTrue rest = x
| otherwise = TCon (PC PAnd) [x, rest]
where rest = pAnd xs
pSplitAnd :: Prop -> [Prop]
pSplitAnd p0 = go [p0]
where
go [] = []
go (q : qs) =
case tNoUser q of
TCon (PC PAnd) [l,r] -> go (l : r : qs)
TCon (PC PTrue) _ -> go qs
_ -> q : go qs
pFin :: Type -> Prop
pFin ty =
case tNoUser ty of
TCon (TC (TCNum _)) _ -> pTrue
TCon (TC TCInf) _ -> pError (TCErrorMessage "`inf` is not finite.")
_ -> TCon (PC PFin) [ty]
-- | Make a malformed property.
pError :: TCErrorMessage -> Prop
pError msg = TCon (TError KProp msg) []
--------------------------------------------------------------------------------
noFreeVariables :: FVS t => t -> Bool
noFreeVariables = all (not . isFreeTV) . Set.toList . fvs
class FVS t where
fvs :: t -> Set TVar
instance FVS Type where
fvs = go
where
go ty =
case ty of
TCon _ ts -> fvs ts
TVar x -> Set.singleton x
TUser _ _ t -> go t
TRec fs -> fvs (map snd fs)
instance FVS a => FVS (Maybe a) where
fvs Nothing = Set.empty
fvs (Just x) = fvs x
instance FVS a => FVS [a] where
fvs xs = Set.unions (map fvs xs)
instance (FVS a, FVS b) => FVS (a,b) where
fvs (x,y) = Set.union (fvs x) (fvs y)
instance FVS Schema where
fvs (Forall as ps t) =
Set.difference (Set.union (fvs ps) (fvs t)) bound
where bound = Set.fromList (map tpVar as)
-- Pretty Printing -------------------------------------------------------------
instance PP TParam where
ppPrec = ppWithNamesPrec IntMap.empty
instance PP (WithNames TParam) where
ppPrec _ (WithNames p mp) = ppWithNames mp (tpVar p)
addTNames :: [TParam] -> NameMap -> NameMap
addTNames as ns = foldr (uncurry IntMap.insert) ns
$ named ++ zip unnamed_nums numNames
++ zip unnamed_vals valNames
where avail xs = filter (`notElem` used) (nameList xs)
numNames = avail ["n","m","i","j","k"]
valNames = avail ["a","b","c","d","e"]
nm x = (tpUnique x, tpName x, tpKind x)
named = [ (u,show (pp n)) | (u,Just n,_) <- map nm as ]
unnamed_nums = [ u | (u,Nothing,KNum) <- map nm as ]
unnamed_vals = [ u | (u,Nothing,KType) <- map nm as ]
used = map snd named ++ IntMap.elems ns
ppNewtypeShort :: Newtype -> Doc
ppNewtypeShort nt =
text "newtype" <+> pp (ntName nt) <+> hsep (map (ppWithNamesPrec nm 9) ps)
where
ps = ntParams nt
nm = addTNames ps emptyNameMap
instance PP Schema where
ppPrec = ppWithNamesPrec IntMap.empty
instance PP (WithNames Schema) where
ppPrec _ (WithNames s ns)
| null (sVars s) && null (sProps s) = body
| otherwise = hang (vars <+> props) 2 body
where
body = ppWithNames ns1 (sType s)
vars = case sVars s of
[] -> empty
vs -> braces $ commaSep $ map (ppWithNames ns1) vs
props = case sProps s of
[] -> empty
ps -> parens (commaSep (map (ppWithNames ns1) ps)) <+> text "=>"
ns1 = addTNames (sVars s) ns
instance PP TySyn where
ppPrec = ppWithNamesPrec IntMap.empty
instance PP (WithNames TySyn) where
ppPrec _ (WithNames ts ns) =
text "type" <+> ctr <+> lhs <+> char '=' <+> ppWithNames ns1 (tsDef ts)
where ns1 = addTNames (tsParams ts) ns
ctr = case kindResult (kindOf ts) of
KProp -> text "constraint"
_ -> empty
n = tsName ts
lhs = case (nameFixity n, tsParams ts) of
(Just _, [x, y]) ->
ppWithNames ns1 x <+> pp (nameIdent n) <+> ppWithNames ns1 y
(_, ps) ->
pp n <+> sep (map (ppWithNames ns1) ps)
instance PP Newtype where
ppPrec = ppWithNamesPrec IntMap.empty
instance PP (WithNames Newtype) where
ppPrec _ (WithNames nt _) = ppNewtypeShort nt -- XXX: do the full thing?
instance PP (WithNames Type) where
ppPrec prec ty0@(WithNames ty nmMap) =
case ty of
TVar a -> ppWithNames nmMap a
TRec fs -> braces $ fsep $ punctuate comma
[ pp l <+> text ":" <+> go 0 t | (l,t) <- fs ]
_ | Just tinf <- isTInfix ty0 -> optParens (prec > 2)
$ ppInfix 2 isTInfix tinf
TUser c [] _ -> pp c
TUser c ts _ -> optParens (prec > 3) $ pp c <+> fsep (map (go 4) ts)
TCon (TC tc) ts ->
case (tc,ts) of
(TCNum n, []) -> integer n
(TCInf, []) -> text "inf"
(TCBit, []) -> text "Bit"
(TCInteger, []) -> text "Integer"
(TCIntMod, [n]) -> optParens (prec > 3) $ text "Z" <+> go 4 n
(TCSeq, [t1,TCon (TC TCBit) []]) -> brackets (go 0 t1)
(TCSeq, [t1,t2]) -> optParens (prec > 3)
$ brackets (go 0 t1) <.> go 3 t2
(TCFun, [t1,t2]) -> optParens (prec > 1)
$ go 2 t1 <+> text "->" <+> go 1 t2
(TCTuple _, fs) -> parens $ fsep $ punctuate comma $ map (go 0) fs
(_, _) -> pp tc <+> fsep (map (go 4) ts)
TCon (PC pc) ts ->
case (pc,ts) of
(PEqual, [t1,t2]) -> go 0 t1 <+> text "==" <+> go 0 t2
(PNeq , [t1,t2]) -> go 0 t1 <+> text "!=" <+> go 0 t2
(PGeq, [t1,t2]) -> go 0 t1 <+> text ">=" <+> go 0 t2
(PFin, [t1]) -> text "fin" <+> (go 4 t1)
(PHas x, [t1,t2]) -> ppSelector x <+> text "of"
<+> go 0 t1 <+> text "is" <+> go 0 t2
(PArith, [t1]) -> pp pc <+> go 4 t1
(PCmp, [t1]) -> pp pc <+> go 4 t1
(PSignedCmp, [t1]) -> pp pc <+> go 4 t1
(PLiteral, [t1,t2]) -> pp pc <+> go 4 t1 <+> go 4 t2
(_, _) -> pp pc <+> fsep (map (go 4) ts)
TCon f ts -> optParens (prec > 3)
$ pp f <+> fsep (map (go 4) ts)
where
go p t = ppWithNamesPrec nmMap p t
isTInfix (WithNames (TCon tc [ieLeft',ieRight']) _) =
do let ieLeft = WithNames ieLeft' nmMap
ieRight = WithNames ieRight' nmMap
(ieOp,fi) <- infixPrimTy tc
let ieAssoc = fAssoc fi
iePrec = fLevel fi
return Infix { .. }
isTInfix (WithNames (TUser n [ieLeft',ieRight'] _) _) =
do let ieLeft = WithNames ieLeft' nmMap
ieRight = WithNames ieRight' nmMap
fi <- nameFixity n
let ieAssoc = fAssoc fi
iePrec = fLevel fi
ieOp = nameIdent n
return Infix { .. }
isTInfix _ = Nothing
instance PP (WithNames TVar) where
ppPrec _ (WithNames (TVBound x) mp) =
case IntMap.lookup (tpUnique x) mp of
Just a -> text a
Nothing ->
case tpFlav x of
TPModParam n -> ppPrefixName n
TPOther (Just n) -> pp n <.> "`" <.> int (tpUnique x)
_ -> pickTVarName (tpKind x) (tvarDesc (tpInfo x)) (tpUnique x)
ppPrec _ (WithNames (TVFree x k _ d) _) =
char '?' <.> pickTVarName k (tvarDesc d) x
pickTVarName :: Kind -> TVarSource -> Int -> Doc
pickTVarName k src uni =
text $
case src of
TVFromModParam n -> using n
TVFromSignature n -> using n
TypeWildCard -> mk $ case k of
KNum -> "n"
_ -> "a"
TypeOfRecordField i -> using i
TypeOfTupleField n -> mk ("tup_" ++ show n)
TypeOfSeqElement -> mk "a"
LenOfSeq -> mk "n"
TypeParamInstNamed _ i -> using i
TypeParamInstPos f n -> mk (sh f ++ "_" ++ show n)
DefinitionOf x -> using x
LenOfCompGen -> mk "n"
TypeOfArg mb -> mk (case mb of
Nothing -> "arg"
Just n -> "arg_" ++ show n)
TypeOfRes -> "res"
TypeErrorPlaceHolder -> "err"
where
sh a = show (pp a)
using a = mk (sh a)
mk a = a ++ "`" ++ show uni
instance PP TVar where
ppPrec = ppWithNamesPrec IntMap.empty
instance PP Type where
ppPrec n t = ppWithNamesPrec IntMap.empty n t
instance PP TVarInfo where
ppPrec _ tvinfo = pp (tvarDesc tvinfo) <+> loc
where
loc = if rng == emptyRange then empty else "at" <+> pp rng
rng = tvarSource tvinfo
instance PP TVarSource where
ppPrec _ tvsrc =
case tvsrc of
TVFromModParam m -> "module parameter" <+> pp m
TVFromSignature x -> "signature variable" <+> quotes (pp x)
TypeWildCard -> "type wildcard (_)"
TypeOfRecordField l -> "type of field" <+> quotes (pp l)
TypeOfTupleField n -> "type of" <+> ordinal n <+> "tuple field"
TypeOfSeqElement -> "type of sequence member"
LenOfSeq -> "length of sequence"
TypeParamInstNamed f i -> "type argument" <+> quotes (pp i) <+>
"of" <+> quotes (pp f)
TypeParamInstPos f i -> ordinal i <+> "type argument of" <+>
quotes (pp f)
DefinitionOf x -> "the type of" <+> quotes (pp x)
LenOfCompGen -> "length of comprehension generator"
TypeOfArg mb ->
case mb of
Nothing -> "type of function argument"
Just n -> "type of" <+> ordinal n <+> "function argument"
TypeOfRes -> "type of function result"
TypeErrorPlaceHolder -> "type error place-holder"
cryptol-2.8.0/src/Cryptol/TypeCheck/TypeMap.hs 0000644 0000000 0000000 00000013061 07346545000 017424 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.TypeMap
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances, FlexibleInstances #-}
{-# LANGUAGE DeriveFunctor #-}
module Cryptol.TypeCheck.TypeMap
( TypeMap(..), TypesMap, TrieMap(..)
, insertTM, insertWithTM
, membersTM
, mapTM, mapWithKeyTM, mapMaybeTM
, List(..)
) where
import Cryptol.TypeCheck.AST
import Cryptol.Utils.Ident
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe(fromMaybe,maybeToList)
import Control.Monad((<=<))
import Data.List(sortBy)
import Data.Maybe (isNothing)
import Data.Ord(comparing)
class TrieMap m k | m -> k where
emptyTM :: m a
nullTM :: m a -> Bool
lookupTM :: k -> m a -> Maybe a
alterTM :: k -> (Maybe a -> Maybe a) -> m a -> m a
unionTM :: (a -> a -> a) -> m a -> m a -> m a
toListTM :: m a -> [(k,a)]
mapMaybeWithKeyTM :: (k -> a -> Maybe b) -> m a -> m b
membersTM :: TrieMap m k => m a -> [a]
membersTM = map snd . toListTM
insertTM :: TrieMap m k => k -> a -> m a -> m a
insertTM t a = alterTM t (\_ -> Just a)
insertWithTM :: TrieMap m k => (a -> a -> a) -> k -> a -> m a -> m a
insertWithTM f t new = alterTM t $ \mb -> Just $ case mb of
Nothing -> new
Just old -> f old new
{-# INLINE mapTM #-}
mapTM :: TrieMap m k => (a -> b) -> m a -> m b
mapTM f = mapMaybeWithKeyTM (\ _ a -> Just (f a))
{-# INLINE mapWithKeyTM #-}
mapWithKeyTM :: TrieMap m k => (k -> a -> b) -> m a -> m b
mapWithKeyTM f = mapMaybeWithKeyTM (\ k a -> Just (f k a))
{-# INLINE mapMaybeTM #-}
mapMaybeTM :: TrieMap m k => (a -> Maybe b) -> m a -> m b
mapMaybeTM f = mapMaybeWithKeyTM (\_ -> f)
data List m a = L { nil :: Maybe a
, cons :: m (List m a)
} deriving (Functor)
instance TrieMap m a => TrieMap (List m) [a] where
emptyTM = L { nil = Nothing, cons = emptyTM }
nullTM k = isNothing (nil k) && nullTM (cons k)
lookupTM k =
case k of
[] -> nil
x : xs -> lookupTM xs <=< lookupTM x . cons
alterTM k f m =
case k of
[] -> m { nil = f (nil m) }
x:xs -> m { cons = alterTM x (updSub xs f) (cons m) }
toListTM m =
[ ([], v) | v <- maybeToList (nil m) ] ++
[ (x:xs,v) | (x,m1) <- toListTM (cons m), (xs,v) <- toListTM m1 ]
unionTM f m1 m2 = L { nil = case (nil m1, nil m2) of
(Just x, Just y) -> Just (f x y)
(Just x, _) -> Just x
(_, Just y) -> Just y
_ -> Nothing
, cons = unionTM (unionTM f) (cons m1) (cons m2)
}
mapMaybeWithKeyTM f = go []
where
go acc l = L { nil = f (reverse acc) =<< nil l
, cons = mapMaybeWithKeyTM (\k a -> Just (go (k:acc) a)) (cons l)
}
instance Ord a => TrieMap (Map a) a where
emptyTM = Map.empty
nullTM = Map.null
lookupTM = Map.lookup
alterTM = flip Map.alter
toListTM = Map.toList
unionTM = Map.unionWith
mapMaybeWithKeyTM = Map.mapMaybeWithKey
type TypesMap = List TypeMap
data TypeMap a = TM { tvar :: Map TVar a
, tcon :: Map TCon (List TypeMap a)
, trec :: Map [Ident] (List TypeMap a)
} deriving (Functor)
instance TrieMap TypeMap Type where
emptyTM = TM { tvar = emptyTM, tcon = emptyTM, trec = emptyTM }
nullTM ty = and [ nullTM (tvar ty)
, nullTM (tcon ty)
, nullTM (trec ty) ]
lookupTM ty =
case ty of
TUser _ _ t -> lookupTM t
TVar x -> lookupTM x . tvar
TCon c ts -> lookupTM ts <=< lookupTM c . tcon
TRec fs -> let (xs,ts) = unzip $ sortBy (comparing fst) fs
in lookupTM ts <=< lookupTM xs . trec
alterTM ty f m =
case ty of
TUser _ _ t -> alterTM t f m
TVar x -> m { tvar = alterTM x f (tvar m) }
TCon c ts -> m { tcon = alterTM c (updSub ts f) (tcon m) }
TRec fs -> let (xs,ts) = unzip $ sortBy (comparing fst) fs
in m { trec = alterTM xs (updSub ts f) (trec m) }
toListTM m =
[ (TVar x, v) | (x,v) <- toListTM (tvar m) ] ++
[ (TCon c ts, v) | (c,m1) <- toListTM (tcon m)
, (ts,v) <- toListTM m1 ] ++
[ (TRec (zip fs ts), v) | (fs,m1) <- toListTM (trec m)
, (ts,v) <- toListTM m1 ]
unionTM f m1 m2 = TM { tvar = unionTM f (tvar m1) (tvar m2)
, tcon = unionTM (unionTM f) (tcon m1) (tcon m2)
, trec = unionTM (unionTM f) (trec m1) (trec m2)
}
mapMaybeWithKeyTM f m =
TM { tvar = mapMaybeWithKeyTM (\v -> f (TVar v)) (tvar m)
, tcon = mapWithKeyTM (\c l -> mapMaybeWithKeyTM
(\ts a -> f (TCon c ts) a) l) (tcon m)
, trec = mapWithKeyTM (\fs l -> mapMaybeWithKeyTM
(\ts a -> f (TRec (zip fs ts)) a) l) (trec m)
}
updSub :: TrieMap m k => k -> (Maybe a -> Maybe a) -> Maybe (m a) -> Maybe (m a)
updSub k f = Just . alterTM k f . fromMaybe emptyTM
instance Show a => Show (TypeMap a) where
showsPrec p xs = showsPrec p (toListTM xs)
cryptol-2.8.0/src/Cryptol/TypeCheck/TypeOf.hs 0000644 0000000 0000000 00000013457 07346545000 017264 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.TypeOf
-- Copyright : (c) 2014-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternGuards #-}
module Cryptol.TypeCheck.TypeOf
( fastTypeOf
, fastSchemaOf
) where
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Subst
import Cryptol.Utils.Panic
import Cryptol.Utils.PP
import Data.Map (Map)
import qualified Data.Map as Map
-- | Given a typing environment and an expression, compute the type of
-- the expression as quickly as possible, assuming that the expression
-- is well formed with correct type annotations.
fastTypeOf :: Map Name Schema -> Expr -> Type
fastTypeOf tyenv expr =
case expr of
-- Monomorphic fragment
EList es t -> tSeq (tNum (length es)) t
ETuple es -> tTuple (map (fastTypeOf tyenv) es)
ERec fields -> tRec [ (name, fastTypeOf tyenv e) | (name, e) <- fields ]
ESel e sel -> typeSelect (fastTypeOf tyenv e) sel
ESet e _ _ -> fastTypeOf tyenv e
EIf _ e _ -> fastTypeOf tyenv e
EComp len t _ _ -> tSeq len t
EAbs x t e -> tFun t (fastTypeOf (Map.insert x (Forall [] [] t) tyenv) e)
EApp e _ -> case tIsFun (fastTypeOf tyenv e) of
Just (_, t) -> t
Nothing -> panic "Cryptol.TypeCheck.TypeOf.fastTypeOf"
[ "EApp with non-function operator" ]
-- Polymorphic fragment
EVar {} -> polymorphic
ETAbs {} -> polymorphic
ETApp {} -> polymorphic
EProofAbs {} -> polymorphic
EProofApp {} -> polymorphic
EWhere {} -> polymorphic
where
polymorphic =
case fastSchemaOf tyenv expr of
Forall [] [] ty -> ty
_ -> panic "Cryptol.TypeCheck.TypeOf.fastTypeOf"
[ "unexpected polymorphic type" ]
fastSchemaOf :: Map Name Schema -> Expr -> Schema
fastSchemaOf tyenv expr =
case expr of
-- Polymorphic fragment
EVar x -> case Map.lookup x tyenv of
Just ty -> ty
Nothing -> panic "Cryptol.TypeCheck.TypeOf.fastSchemaOf"
[ "EVar failed to find type variable:", show x ]
ETAbs tparam e -> case fastSchemaOf tyenv e of
Forall tparams props ty -> Forall (tparam : tparams) props ty
ETApp e t -> case fastSchemaOf tyenv e of
Forall (tparam : tparams) props ty
-> Forall tparams (map (plainSubst s) props) (plainSubst s ty)
where s = singleSubst (tpVar tparam) t
_ -> panic "Cryptol.TypeCheck.TypeOf.fastSchemaOf"
[ "ETApp body with no type parameters" ]
-- When calling 'fastSchemaOf' on a
-- polymorphic function with instantiated type
-- variables but undischarged type
-- constraints, we would prefer to see the
-- instantiated constraints in an
-- un-simplified form. Thus we use
-- 'plainSubst' instead of 'apSubst' on the
-- type constraints.
EProofAbs p e -> case fastSchemaOf tyenv e of
Forall [] props ty -> Forall [] (p : props) ty
_ -> panic "Cryptol.TypeCheck.TypeOf.fastSchemaOf"
[ "EProofAbs with polymorphic expression" ]
EProofApp e -> case fastSchemaOf tyenv e of
Forall [] (_ : props) ty -> Forall [] props ty
_ -> panic "Cryptol.TypeCheck.TypeOf.fastSchemaOf"
[ "EProofApp with polymorphic expression or"
, "no props in scope"
]
EWhere e dgs -> fastSchemaOf (foldr addDeclGroup tyenv dgs) e
where addDeclGroup (Recursive ds) = flip (foldr addDecl) ds
addDeclGroup (NonRecursive d) = addDecl d
addDecl d = Map.insert (dName d) (dSignature d)
-- Monomorphic fragment
EList {} -> monomorphic
ETuple {} -> monomorphic
ERec {} -> monomorphic
ESet {} -> monomorphic
ESel {} -> monomorphic
EIf {} -> monomorphic
EComp {} -> monomorphic
EApp {} -> monomorphic
EAbs {} -> monomorphic
where
monomorphic = Forall [] [] (fastTypeOf tyenv expr)
-- | Apply a substitution to a type *without* simplifying
-- constraints like @Arith [n]a@ to @Arith a@. (This is in contrast to
-- 'apSubst', which performs simplifications wherever possible.)
plainSubst :: Subst -> Type -> Type
plainSubst s ty =
case ty of
TCon tc ts -> TCon tc (map (plainSubst s) ts)
TUser f ts t -> TUser f (map (plainSubst s) ts) (plainSubst s t)
TRec fs -> TRec [ (x, plainSubst s t) | (x, t) <- fs ]
TVar x -> apSubst s (TVar x)
-- | Yields the return type of the selector on the given argument type.
typeSelect :: Type -> Selector -> Type
typeSelect (TUser _ _ ty) sel = typeSelect ty sel
typeSelect (tIsTuple -> Just ts) (TupleSel i _)
| i < length ts = ts !! i
typeSelect (TRec fields) (RecordSel n _)
| Just ty <- lookup n fields = ty
typeSelect (tIsSeq -> Just (_, a)) ListSel{} = a
typeSelect (tIsSeq -> Just (n, a)) sel@TupleSel{} = tSeq n (typeSelect a sel)
typeSelect (tIsSeq -> Just (n, a)) sel@RecordSel{} = tSeq n (typeSelect a sel)
typeSelect ty _ = panic "Cryptol.TypeCheck.TypeOf.typeSelect"
[ "cannot apply selector to value of type", render (pp ty) ]
cryptol-2.8.0/src/Cryptol/TypeCheck/TypePat.hs 0000644 0000000 0000000 00000007662 07346545000 017445 0 ustar 00 0000000 0000000 module Cryptol.TypeCheck.TypePat
( aInf, aNat, aNat'
, anAdd, (|-|), aMul, (|^|), (|/|), (|%|)
, aMin, aMax
, aWidth
, aCeilDiv, aCeilMod
, aLenFromThenTo
, aLiteral, aLogic
, aTVar
, aFreeTVar
, aBit
, aSeq
, aWord
, aChar
, aTuple
, aRec
, (|->|)
, aFin, (|=|), (|/=|), (|>=|)
, aCmp, aArith
, aAnd
, aTrue
, anError
, module Cryptol.Utils.Patterns
) where
import Control.Applicative((<|>))
import Control.Monad
import Cryptol.Utils.Ident (Ident)
import Cryptol.Utils.Patterns
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.Solver.InfNat
tcon :: TCon -> ([Type] -> a) -> Pat Type a
tcon f p = \ty -> case tNoUser ty of
TCon c ts | f == c -> return (p ts)
_ -> mzero
ar0 :: [a] -> ()
ar0 ~[] = ()
ar1 :: [a] -> a
ar1 ~[a] = a
ar2 :: [a] -> (a,a)
ar2 ~[a,b] = (a,b)
ar3 :: [a] -> (a,a,a)
ar3 ~[a,b,c] = (a,b,c)
tf :: TFun -> ([Type] -> a) -> Pat Type a
tf f ar = tcon (TF f) ar
tc :: TC -> ([Type] -> a) -> Pat Type a
tc f ar = tcon (TC f) ar
tp :: PC -> ([Type] -> a) -> Pat Prop a
tp f ar = tcon (PC f) ar
--------------------------------------------------------------------------------
aInf :: Pat Type ()
aInf = tc TCInf ar0
aNat :: Pat Type Integer
aNat = \a -> case tNoUser a of
TCon (TC (TCNum n)) _ -> return n
_ -> mzero
aNat' :: Pat Type Nat'
aNat' = \a -> (Inf <$ aInf a)
<|> (Nat <$> aNat a)
anAdd :: Pat Type (Type,Type)
anAdd = tf TCAdd ar2
(|-|) :: Pat Type (Type,Type)
(|-|) = tf TCSub ar2
aMul :: Pat Type (Type,Type)
aMul = tf TCMul ar2
(|^|) :: Pat Type (Type,Type)
(|^|) = tf TCExp ar2
(|/|) :: Pat Type (Type,Type)
(|/|) = tf TCDiv ar2
(|%|) :: Pat Type (Type,Type)
(|%|) = tf TCMod ar2
aMin :: Pat Type (Type,Type)
aMin = tf TCMin ar2
aMax :: Pat Type (Type,Type)
aMax = tf TCMax ar2
aWidth :: Pat Type Type
aWidth = tf TCWidth ar1
aCeilDiv :: Pat Type (Type,Type)
aCeilDiv = tf TCCeilDiv ar2
aCeilMod :: Pat Type (Type,Type)
aCeilMod = tf TCCeilMod ar2
aLenFromThenTo :: Pat Type (Type,Type,Type)
aLenFromThenTo = tf TCLenFromThenTo ar3
--------------------------------------------------------------------------------
aTVar :: Pat Type TVar
aTVar = \a -> case tNoUser a of
TVar x -> return x
_ -> mzero
aFreeTVar :: Pat Type TVar
aFreeTVar t =
do v <- aTVar t
guard (isFreeTV v)
return v
aBit :: Pat Type ()
aBit = tc TCBit ar0
aSeq :: Pat Type (Type,Type)
aSeq = tc TCSeq ar2
aWord :: Pat Type Type
aWord = \a -> do (l,t) <- aSeq a
aBit t
return l
aChar :: Pat Type ()
aChar = \a -> do (l,t) <- aSeq a
n <- aNat l
guard (n == 8)
aBit t
aTuple :: Pat Type [Type]
aTuple = \a -> case tNoUser a of
TCon (TC (TCTuple _)) ts -> return ts
_ -> mzero
aRec :: Pat Type [(Ident, Type)]
aRec = \a -> case tNoUser a of
TRec fs -> return fs
_ -> mzero
(|->|) :: Pat Type (Type,Type)
(|->|) = tc TCFun ar2
--------------------------------------------------------------------------------
aFin :: Pat Prop Type
aFin = tp PFin ar1
(|=|) :: Pat Prop (Type,Type)
(|=|) = tp PEqual ar2
(|/=|) :: Pat Prop (Type,Type)
(|/=|) = tp PNeq ar2
(|>=|) :: Pat Prop (Type,Type)
(|>=|) = tp PGeq ar2
aCmp :: Pat Prop Type
aCmp = tp PCmp ar1
aArith :: Pat Prop Type
aArith = tp PArith ar1
aAnd :: Pat Prop (Prop,Prop)
aAnd = tp PAnd ar2
aTrue :: Pat Prop ()
aTrue = tp PTrue ar0
aLiteral :: Pat Prop (Type,Type)
aLiteral = tp PLiteral ar2
aLogic :: Pat Prop Type
aLogic = tp PLogic ar1
--------------------------------------------------------------------------------
anError :: Kind -> Pat Type TCErrorMessage
anError k = \a -> case tNoUser a of
TCon (TError k1 err) _ | k == k1 -> return err
_ -> mzero
cryptol-2.8.0/src/Cryptol/TypeCheck/Unify.hs 0000644 0000000 0000000 00000007205 07346545000 017142 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.TypeCheck.Unify
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE PatternGuards, ViewPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
module Cryptol.TypeCheck.Unify where
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Subst
import Control.Monad.Writer (Writer, writer, runWriter)
import Data.Ord(comparing)
import Data.List(sortBy)
import qualified Data.Set as Set
import Prelude ()
import Prelude.Compat
-- | The most general unifier is a substitution and a set of constraints
-- on bound variables.
type MGU = (Subst,[Prop])
type Result a = Writer [UnificationError] a
runResult :: Result a -> (a, [UnificationError])
runResult = runWriter
data UnificationError
= UniTypeMismatch Type Type
| UniKindMismatch Kind Kind
| UniTypeLenMismatch Int Int
| UniRecursive TVar Type
| UniNonPolyDepends TVar [TParam]
| UniNonPoly TVar Type
uniError :: UnificationError -> Result MGU
uniError e = writer (emptyMGU, [e])
emptyMGU :: MGU
emptyMGU = (emptySubst, [])
mgu :: Type -> Type -> Result MGU
mgu (TUser c1 ts1 _) (TUser c2 ts2 _)
| c1 == c2 && ts1 == ts2 = return emptyMGU
mgu (TVar x) t = bindVar x t
mgu t (TVar x) = bindVar x t
mgu (TUser _ _ t1) t2 = mgu t1 t2
mgu t1 (TUser _ _ t2) = mgu t1 t2
mgu (TCon (TC tc1) ts1) (TCon (TC tc2) ts2)
| tc1 == tc2 = mguMany ts1 ts2
mgu (TCon (TF f1) ts1) (TCon (TF f2) ts2)
| f1 == f2 && ts1 == ts2 = return emptyMGU
mgu t1 t2
| TCon (TF _) _ <- t1, isNum, k1 == k2 = return (emptySubst, [t1 =#= t2])
| TCon (TF _) _ <- t2, isNum, k1 == k2 = return (emptySubst, [t1 =#= t2])
where
k1 = kindOf t1
k2 = kindOf t2
isNum = k1 == KNum
mgu (TRec fs1) (TRec fs2)
| ns1 == ns2 = mguMany ts1 ts2
where
(ns1,ts1) = sortFields fs1
(ns2,ts2) = sortFields fs2
sortFields = unzip . sortBy (comparing fst)
mgu t1 t2
| not (k1 == k2) = uniError $ UniKindMismatch k1 k2
| otherwise = uniError $ UniTypeMismatch t1 t2
where
k1 = kindOf t1
k2 = kindOf t2
mguMany :: [Type] -> [Type] -> Result MGU
mguMany [] [] = return emptyMGU
mguMany (t1 : ts1) (t2 : ts2) =
do (su1,ps1) <- mgu t1 t2
(su2,ps2) <- mguMany (apSubst su1 ts1) (apSubst su1 ts2)
return (su2 @@ su1, ps1 ++ ps2)
mguMany t1 t2 = uniError $ UniTypeLenMismatch (length t1) (length t2)
bindVar :: TVar -> Type -> Result MGU
bindVar x (tNoUser -> TVar y)
| x == y = return emptyMGU
bindVar v@(TVBound {}) (tNoUser -> TVar v1@(TVFree {})) = bindVar v1 (TVar v)
bindVar v@(TVBound {}) t
| k == kindOf t = if k == KNum
then return (emptySubst, [TVar v =#= t])
else uniError $ UniNonPoly v t
| otherwise = uniError $ UniKindMismatch k (kindOf t)
where k = kindOf v
bindVar x@(TVFree _ _ xscope _) (TVar y@(TVFree _ _ yscope _))
| xscope `Set.isProperSubsetOf` yscope = return (singleSubst y (TVar x), [])
bindVar x@(TVFree _ k inScope _d) t
| not (k == kindOf t) = uniError $ UniKindMismatch k (kindOf t)
| recTy && k == KType = uniError $ UniRecursive x t
| not (Set.null escaped) = uniError $ UniNonPolyDepends x $ Set.toList escaped
| recTy = return (emptySubst, [TVar x =#= t])
| otherwise = return (singleSubst x t, [])
where
escaped = freeParams t `Set.difference` inScope
recTy = x `Set.member` fvs t
freeParams :: FVS t => t -> Set.Set TParam
freeParams x = Set.unions (map params (Set.toList (fvs x)))
where
params (TVFree _ _ tps _) = tps
params (TVBound tp) = Set.singleton tp
cryptol-2.8.0/src/Cryptol/Utils/ 0000755 0000000 0000000 00000000000 07346545000 014731 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/Cryptol/Utils/Debug.hs 0000644 0000000 0000000 00000000612 07346545000 016312 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Utils.Debug
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
module Cryptol.Utils.Debug where
import Cryptol.Utils.PP
import qualified Debug.Trace as X
trace :: String -> b -> b
trace = X.trace
ppTrace :: Doc -> b -> b
ppTrace d = trace (show d)
cryptol-2.8.0/src/Cryptol/Utils/Ident.hs 0000644 0000000 0000000 00000007346 07346545000 016342 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Utils.Ident
-- Copyright : (c) 2015-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
module Cryptol.Utils.Ident
( -- * Module names
ModName
, modNameToText
, textToModName
, modNameChunks
, packModName
, preludeName
, interactiveName
, noModuleName
, exprModName
, isParamInstModName
, paramInstModName
, notParamInstModName
-- * Identifiers
, Ident
, packIdent
, packInfix
, unpackIdent
, mkIdent
, mkInfix
, isInfixIdent
, nullIdent
, identText
, modParamIdent
) where
import Control.DeepSeq (NFData)
import Data.Char (isSpace)
import Data.List (unfoldr)
import qualified Data.Text as T
import Data.String (IsString(..))
import GHC.Generics (Generic)
-- | Module names are just text.
data ModName = ModName T.Text
deriving (Eq,Ord,Show,Generic)
instance NFData ModName
modNameToText :: ModName -> T.Text
modNameToText (ModName x) = x
textToModName :: T.Text -> ModName
textToModName = ModName
modNameChunks :: ModName -> [String]
modNameChunks = unfoldr step . modNameToText . notParamInstModName
where
step str
| T.null str = Nothing
| otherwise = case T.breakOn modSep str of
(a,b) -> Just (T.unpack a,T.drop (T.length modSep) b)
isParamInstModName :: ModName -> Bool
isParamInstModName (ModName x) = modInstPref `T.isPrefixOf` x
-- | Convert a parameterized module's name to the name of the module
-- containing the same definitions but with explicit parameters on each
-- definition.
paramInstModName :: ModName -> ModName
paramInstModName (ModName x)
| modInstPref `T.isPrefixOf` x = ModName x
| otherwise = ModName (T.append modInstPref x)
notParamInstModName :: ModName -> ModName
notParamInstModName (ModName x)
| modInstPref `T.isPrefixOf` x = ModName (T.drop (T.length modInstPref) x)
| otherwise = ModName x
packModName :: [T.Text] -> ModName
packModName strs = textToModName (T.intercalate modSep (map trim strs))
where
-- trim space off of the start and end of the string
trim str = T.dropWhile isSpace (T.dropWhileEnd isSpace str)
modSep :: T.Text
modSep = "::"
modInstPref :: T.Text
modInstPref = "`"
preludeName :: ModName
preludeName = packModName ["Cryptol"]
interactiveName :: ModName
interactiveName = packModName [""]
noModuleName :: ModName
noModuleName = packModName [""]
exprModName :: ModName
exprModName = packModName [""]
--------------------------------------------------------------------------------
-- | Identifiers, along with a flag that indicates whether or not they're infix
-- operators. The boolean is present just as cached information from the lexer,
-- and never used during comparisons.
data Ident = Ident Bool T.Text
deriving (Show,Generic)
instance Eq Ident where
a == b = compare a b == EQ
a /= b = compare a b /= EQ
instance Ord Ident where
compare (Ident _ i1) (Ident _ i2) = compare i1 i2
instance IsString Ident where
fromString str = mkIdent (T.pack str)
instance NFData Ident
packIdent :: String -> Ident
packIdent = mkIdent . T.pack
packInfix :: String -> Ident
packInfix = mkInfix . T.pack
unpackIdent :: Ident -> String
unpackIdent = T.unpack . identText
mkIdent :: T.Text -> Ident
mkIdent = Ident False
mkInfix :: T.Text -> Ident
mkInfix = Ident True
isInfixIdent :: Ident -> Bool
isInfixIdent (Ident b _) = b
nullIdent :: Ident -> Bool
nullIdent (Ident _ t) = T.null t
identText :: Ident -> T.Text
identText (Ident _ t) = t
modParamIdent :: Ident -> Ident
modParamIdent (Ident x t) = Ident x (T.append (T.pack "module parameter ") t)
cryptol-2.8.0/src/Cryptol/Utils/Logger.hs 0000644 0000000 0000000 00000002547 07346545000 016514 0 ustar 00 0000000 0000000 -- | A simple system so that the Cryptol driver can communicate
-- with users (or not).
module Cryptol.Utils.Logger
( Logger
, stdoutLogger
, stderrLogger
, handleLogger
, quietLogger
, funLogger
, logPutStr
, logPutStrLn
, logPrint
) where
import System.IO(Handle, hPutStr, stdout, stderr)
import Control.DeepSeq(NFData(..))
-- | A logger provides simple abstraction for sending messages.
newtype Logger = Logger (String -> IO ())
instance NFData Logger where
rnf (Logger x) = rnf x
-- | Send the given string to the log.
logPutStr :: Logger -> String -> IO ()
logPutStr (Logger f) = f
-- | Send the given string with a newline at the end.
logPutStrLn :: Logger -> String -> IO ()
logPutStrLn l s = logPutStr l (s ++ "\n")
-- | Send the given value using its 'Show' instance.
-- Adds a newline at the end.
logPrint :: Show a => Logger -> a -> IO ()
logPrint l a = logPutStrLn l (show a)
-- | A logger that ignores all messages.
quietLogger :: Logger
quietLogger = Logger (const (return ()))
-- | Log to the given handle.
handleLogger :: Handle -> Logger
handleLogger h = Logger (hPutStr h)
-- | Log to stdout.
stdoutLogger :: Logger
stdoutLogger = handleLogger stdout
-- | Log to stderr.
stderrLogger :: Logger
stderrLogger = handleLogger stderr
-- | Just use this function for logging.
funLogger :: (String -> IO ()) -> Logger
funLogger = Logger
cryptol-2.8.0/src/Cryptol/Utils/Misc.hs 0000644 0000000 0000000 00000002120 07346545000 016153 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Utils.Misc
-- Copyright : (c) 2014-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe, FlexibleContexts #-}
module Cryptol.Utils.Misc where
import MonadLib
import Data.Maybe(fromMaybe)
import Prelude ()
import Prelude.Compat
-- | Apply a function to all elements of a container.
-- Returns `Nothing` if nothing changed, and @Just container@ otherwise.
anyJust :: Traversable t => (a -> Maybe a) -> t a -> Maybe (t a)
anyJust f m = mk $ runId $ runStateT False $ traverse upd m
where
mk (a,changes) = if changes then Just a else Nothing
upd x = case f x of
Just y -> set True >> return y
Nothing -> return x
-- | Apply functions to both elements of a pair.
-- Returns `Nothing` if neither changed, and @Just pair@ otherwise.
anyJust2 :: (a -> Maybe a) -> (b -> Maybe b) -> (a,b) -> Maybe (a,b)
anyJust2 f g (a,b) =
case (f a, g b) of
(Nothing, Nothing) -> Nothing
(x,y) -> Just (fromMaybe a x, fromMaybe b y)
cryptol-2.8.0/src/Cryptol/Utils/PP.hs 0000644 0000000 0000000 00000017452 07346545000 015615 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Utils.PP
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Utils.PP where
import Cryptol.Utils.Ident
import Control.DeepSeq
import Control.Monad (mplus)
import Data.Maybe (fromMaybe)
import qualified Data.Semigroup as S
import Data.String (IsString(..))
import qualified Data.Text as T
import GHC.Generics (Generic)
import qualified Text.PrettyPrint as PJ
import Prelude ()
import Prelude.Compat
-- Name Displaying -------------------------------------------------------------
{- | How to display names, inspired by the GHC `Outputable` module.
Getting a value of 'Nothing' from the NameDisp function indicates
that the display has no opinion on how this name should be displayed,
and some other display should be tried out. -}
data NameDisp = EmptyNameDisp
| NameDisp (ModName -> Ident -> Maybe NameFormat)
deriving (Generic, NFData)
instance Show NameDisp where
show _ = ""
instance S.Semigroup NameDisp where
NameDisp f <> NameDisp g = NameDisp (\m n -> f m n `mplus` g m n)
EmptyNameDisp <> EmptyNameDisp = EmptyNameDisp
EmptyNameDisp <> x = x
x <> _ = x
instance Monoid NameDisp where
mempty = EmptyNameDisp
mappend = (S.<>)
data NameFormat = UnQualified
| Qualified !ModName
| NotInScope
deriving (Show)
-- | Never qualify names from this module.
neverQualifyMod :: ModName -> NameDisp
neverQualifyMod mn = NameDisp $ \ mn' _ ->
if mn == mn' then Just UnQualified
else Nothing
alwaysQualify :: NameDisp
alwaysQualify = NameDisp $ \ mn _ -> Just (Qualified mn)
neverQualify :: NameDisp
neverQualify = NameDisp $ \ _ _ -> Just UnQualified
fmtModName :: ModName -> NameFormat -> T.Text
fmtModName _ UnQualified = T.empty
fmtModName _ (Qualified mn) = modNameToText mn
fmtModName mn NotInScope = modNameToText mn
-- | Compose two naming environments, preferring names from the left
-- environment.
extend :: NameDisp -> NameDisp -> NameDisp
extend = mappend
-- | Get the format for a name. When 'Nothing' is returned, the name is not
-- currently in scope.
getNameFormat :: ModName -> Ident -> NameDisp -> NameFormat
getNameFormat m i (NameDisp f) = fromMaybe NotInScope (f m i)
getNameFormat _ _ EmptyNameDisp = NotInScope
-- | Produce a document in the context of the current 'NameDisp'.
withNameDisp :: (NameDisp -> Doc) -> Doc
withNameDisp k = Doc (\disp -> runDoc disp (k disp))
-- | Fix the way that names are displayed inside of a doc.
fixNameDisp :: NameDisp -> Doc -> Doc
fixNameDisp disp (Doc f) = Doc (\ _ -> f disp)
-- Documents -------------------------------------------------------------------
newtype Doc = Doc (NameDisp -> PJ.Doc) deriving (Generic, NFData)
instance S.Semigroup Doc where
(<>) = liftPJ2 (PJ.<>)
instance Monoid Doc where
mempty = liftPJ PJ.empty
mappend = (S.<>)
runDoc :: NameDisp -> Doc -> PJ.Doc
runDoc names (Doc f) = f names
instance Show Doc where
show d = show (runDoc mempty d)
instance IsString Doc where
fromString = text
render :: Doc -> String
render d = PJ.render (runDoc mempty d)
renderOneLine :: Doc -> String
renderOneLine d = PJ.renderStyle (PJ.style { PJ.mode = PJ.OneLineMode }) (runDoc mempty d)
class PP a where
ppPrec :: Int -> a -> Doc
class PP a => PPName a where
-- | Fixity information for infix operators
ppNameFixity :: a -> Maybe (Assoc, Int)
-- | Print a name in prefix: @f a b@ or @(+) a b)@
ppPrefixName :: a -> Doc
-- | Print a name as an infix operator: @a + b@
ppInfixName :: a -> Doc
pp :: PP a => a -> Doc
pp = ppPrec 0
pretty :: PP a => a -> String
pretty = show . pp
optParens :: Bool -> Doc -> Doc
optParens b body | b = parens body
| otherwise = body
-- | Information about associativity.
data Assoc = LeftAssoc | RightAssoc | NonAssoc
deriving (Show, Eq, Generic, NFData)
-- | Information about an infix expression of some sort.
data Infix op thing = Infix
{ ieOp :: op -- ^ operator
, ieLeft :: thing -- ^ left argument
, ieRight :: thing -- ^ right argument
, iePrec :: Int -- ^ operator precedence
, ieAssoc :: Assoc -- ^ operator associativity
}
commaSep :: [Doc] -> Doc
commaSep = fsep . punctuate comma
-- | Pretty print an infix expression of some sort.
ppInfix :: (PP thing, PP op)
=> Int -- ^ Non-infix leaves are printed with this precedence
-> (thing -> Maybe (Infix op thing))
-- ^ pattern to check if sub-thing is also infix
-> Infix op thing -- ^ Pretty print this infix expression
-> Doc
ppInfix lp isInfix expr =
sep [ ppSub (wrapSub LeftAssoc ) (ieLeft expr) <+> pp (ieOp expr)
, ppSub (wrapSub RightAssoc) (ieRight expr) ]
where
wrapSub dir p = p < iePrec expr || p == iePrec expr && ieAssoc expr /= dir
ppSub w e
| Just e1 <- isInfix e = optParens (w (iePrec e1)) (ppInfix lp isInfix e1)
ppSub _ e = ppPrec lp e
-- | Display a numeric value as an ordinal (e.g., 2nd)
ordinal :: (Integral a, Show a, Eq a) => a -> Doc
ordinal x = text (show x) <.> text (ordSuffix x)
-- | The suffix to use when displaying a number as an oridinal
ordSuffix :: (Integral a, Eq a) => a -> String
ordSuffix n0 =
case n `mod` 10 of
1 | notTeen -> "st"
2 | notTeen -> "nd"
3 | notTeen -> "rd"
_ -> "th"
where
n = abs n0
m = n `mod` 100
notTeen = m < 11 || m > 19
-- Wrapped Combinators ---------------------------------------------------------
liftPJ :: PJ.Doc -> Doc
liftPJ d = Doc (const d)
liftPJ1 :: (PJ.Doc -> PJ.Doc) -> Doc -> Doc
liftPJ1 f (Doc d) = Doc (\env -> f (d env))
liftPJ2 :: (PJ.Doc -> PJ.Doc -> PJ.Doc) -> (Doc -> Doc -> Doc)
liftPJ2 f (Doc a) (Doc b) = Doc (\e -> f (a e) (b e))
liftSep :: ([PJ.Doc] -> PJ.Doc) -> ([Doc] -> Doc)
liftSep f ds = Doc (\e -> f [ d e | Doc d <- ds ])
infixl 6 <.>, <+>
(<.>) :: Doc -> Doc -> Doc
(<.>) = liftPJ2 (PJ.<>)
(<+>) :: Doc -> Doc -> Doc
(<+>) = liftPJ2 (PJ.<+>)
infixl 5 $$
($$) :: Doc -> Doc -> Doc
($$) = liftPJ2 (PJ.$$)
sep :: [Doc] -> Doc
sep = liftSep PJ.sep
fsep :: [Doc] -> Doc
fsep = liftSep PJ.fsep
hsep :: [Doc] -> Doc
hsep = liftSep PJ.hsep
hcat :: [Doc] -> Doc
hcat = liftSep PJ.hcat
vcat :: [Doc] -> Doc
vcat = liftSep PJ.vcat
hang :: Doc -> Int -> Doc -> Doc
hang (Doc p) i (Doc q) = Doc (\e -> PJ.hang (p e) i (q e))
nest :: Int -> Doc -> Doc
nest n = liftPJ1 (PJ.nest n)
parens :: Doc -> Doc
parens = liftPJ1 PJ.parens
braces :: Doc -> Doc
braces = liftPJ1 PJ.braces
brackets :: Doc -> Doc
brackets = liftPJ1 PJ.brackets
quotes :: Doc -> Doc
quotes = liftPJ1 PJ.quotes
backticks :: Doc -> Doc
backticks d = hcat [ "`", d, "`" ]
punctuate :: Doc -> [Doc] -> [Doc]
punctuate p = go
where
go (d:ds) | null ds = [d]
| otherwise = d <.> p : go ds
go [] = []
text :: String -> Doc
text s = liftPJ (PJ.text s)
char :: Char -> Doc
char c = liftPJ (PJ.char c)
integer :: Integer -> Doc
integer i = liftPJ (PJ.integer i)
int :: Int -> Doc
int i = liftPJ (PJ.int i)
comma :: Doc
comma = liftPJ PJ.comma
empty :: Doc
empty = liftPJ PJ.empty
colon :: Doc
colon = liftPJ PJ.colon
instance PP T.Text where
ppPrec _ str = text (T.unpack str)
instance PP Ident where
ppPrec _ i = text (T.unpack (identText i))
instance PP ModName where
ppPrec _ = text . T.unpack . modNameToText
instance PP Assoc where
ppPrec _ LeftAssoc = text "left-associative"
ppPrec _ RightAssoc = text "right-associative"
ppPrec _ NonAssoc = text "non-associative"
cryptol-2.8.0/src/Cryptol/Utils/Panic.hs 0000644 0000000 0000000 00000001404 07346545000 016316 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Utils.Panic
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Trustworthy, TemplateHaskell #-}
module Cryptol.Utils.Panic
(HasCallStack, CryptolPanic, Cryptol, Panic, panic) where
import Panic hiding (panic)
import qualified Panic as Panic
data Cryptol = Cryptol
type CryptolPanic = Panic Cryptol
panic :: HasCallStack => String -> [String] -> a
panic = Panic.panic Cryptol
instance PanicComponent Cryptol where
panicComponentName _ = "Cryptol"
panicComponentIssues _ = "https://github.com/GaloisInc/cryptol/issues"
{-# Noinline panicComponentRevision #-}
panicComponentRevision = $useGitRevision
cryptol-2.8.0/src/Cryptol/Utils/Patterns.hs 0000644 0000000 0000000 00000006665 07346545000 017102 0 ustar 00 0000000 0000000 {-# Language Safe, RankNTypes, MultiParamTypeClasses #-}
{-# Language FunctionalDependencies #-}
{-# Language FlexibleInstances #-}
{-# Language TypeFamilies, UndecidableInstances #-}
module Cryptol.Utils.Patterns where
import Control.Monad(liftM,liftM2,ap,MonadPlus(..),guard)
import Control.Applicative(Alternative(..))
newtype Match b = Match (forall r. r -> (b -> r) -> r)
instance Functor Match where
fmap = liftM
instance Applicative Match where
pure a = Match $ \_no yes -> yes a
(<*>) = ap
instance Monad Match where
fail _ = empty
Match m >>= f = Match $ \no yes -> m no $ \a ->
let Match n = f a in
n no yes
instance Alternative Match where
empty = Match $ \no _ -> no
Match m <|> Match n = Match $ \no yes -> m (n no yes) yes
instance MonadPlus Match where
type Pat a b = a -> Match b
(|||) :: Pat a b -> Pat a b -> Pat a b
p ||| q = \a -> p a <|> q a
-- | Check that a value satisfies multiple patterns.
-- For example, an "as" pattern is @(__ &&& p)@.
(&&&) :: Pat a b -> Pat a c -> Pat a (b,c)
p &&& q = \a -> liftM2 (,) (p a) (q a)
-- | Match a value, and modify the result.
(~>) :: Pat a b -> (b -> c) -> Pat a c
p ~> f = \a -> f <$> p a
-- | Match a value, and return the given result
(~~>) :: Pat a b -> c -> Pat a c
p ~~> f = \a -> f <$ p a
-- | View pattern.
(<~) :: (a -> b) -> Pat b c -> Pat a c
f <~ p = \a -> p (f a)
-- | Variable pattern.
__ :: Pat a a
__ = return
-- | Constant pattern.
succeed :: a -> Pat x a
succeed = const . return
-- | Predicate pattern
checkThat :: (a -> Bool) -> Pat a ()
checkThat p = \a -> guard (p a)
-- | Check for exact value.
lit :: Eq a => a -> Pat a ()
lit x = checkThat (x ==)
{-# Inline lit #-}
-- | Match a pattern, using the given default if valure.
matchDefault :: a -> Match a -> a
matchDefault a (Match m) = m a id
{-# Inline matchDefault #-}
-- | Match an irrefutable pattern. Crashes on faliure.
match :: Match a -> a
match m = matchDefault (error "Pattern match failure.") m
{-# Inline match #-}
matchMaybe :: Match a -> Maybe a
matchMaybe (Match m) = m Nothing Just
list :: [Pat a b] -> Pat [a] [b]
list [] = \a ->
case a of
[] -> return []
_ -> mzero
list (p : ps) = \as ->
case as of
[] -> mzero
x : xs ->
do a <- p x
bs <- list ps xs
return (a : bs)
(><) :: Pat a b -> Pat x y -> Pat (a,x) (b,y)
p >< q = \(a,x) -> do b <- p a
y <- q x
return (b,y)
class Matches thing pats res | pats -> thing res where
matches :: thing -> pats -> Match res
instance ( f ~ Pat a a1'
, a1 ~ Pat a1' r1
) => Matches a (f,a1) r1 where
matches ty (f,a1) = do a1' <- f ty
a1 a1'
instance ( op ~ Pat a (a1',a2')
, a1 ~ Pat a1' r1
, a2 ~ Pat a2' r2
) => Matches a (op,a1,a2) (r1,r2)
where
matches ty (f,a1,a2) = do (a1',a2') <- f ty
r1 <- a1 a1'
r2 <- a2 a2'
return (r1,r2)
instance ( op ~ Pat a (a1',a2',a3')
, a1 ~ Pat a1' r1
, a2 ~ Pat a2' r2
, a3 ~ Pat a3' r3
) => Matches a (op,a1,a2,a3) (r1,r2,r3) where
matches ty (f,a1,a2,a3) = do (a1',a2',a3') <- f ty
r1 <- a1 a1'
r2 <- a2 a2'
r3 <- a3 a3'
return (r1,r2,r3)
cryptol-2.8.0/src/Cryptol/Version.hs 0000644 0000000 0000000 00000001126 07346545000 015612 0 ustar 00 0000000 0000000 -- |
-- Module : Cryptol.Version
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
module Cryptol.Version (
commitHash
, commitShortHash
, commitBranch
, commitDirty
, version
) where
import Paths_cryptol
import qualified GitRev
commitHash :: String
commitHash = GitRev.hash
commitShortHash :: String
commitShortHash = take 7 GitRev.hash
commitBranch :: String
commitBranch = GitRev.branch
commitDirty :: Bool
commitDirty = GitRev.dirty
cryptol-2.8.0/src/ 0000755 0000000 0000000 00000000000 07346545000 012175 5 ustar 00 0000000 0000000 cryptol-2.8.0/src/GitRev.hs 0000644 0000000 0000000 00000001036 07346545000 013731 0 ustar 00 0000000 0000000 -- |
-- Module : GitRev
-- Copyright : (c) 2014-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- Include information about the current git status for use in error
-- messages and version info output
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}
module GitRev (hash, branch, dirty) where
import Development.GitRev
hash :: String
hash = $(gitHash)
branch :: String
branch = $(gitBranch)
dirty :: Bool
dirty = $(gitDirty)
cryptol-2.8.0/utils/ 0000755 0000000 0000000 00000000000 07346545000 012546 5 ustar 00 0000000 0000000 cryptol-2.8.0/utils/CryHtml.hs 0000644 0000000 0000000 00000004237 07346545000 014472 0 ustar 00 0000000 0000000 #!/usr/bin/env runhaskell
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Main
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
import Cryptol.Parser.Lexer
import Cryptol.Utils.PP
import qualified Data.Text.IO as Text
import Text.Blaze.Html (Html, AttributeValue, toValue, toHtml, (!))
import qualified Text.Blaze.Html as H
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Pretty (renderHtml)
main :: IO ()
main =
do txt <- Text.getContents
putStrLn $ renderHtml
$ page
$ toHtml
$ map toBlaze
$ fst
$ primLexer defaultConfig txt
page :: Html -> Html
page inner = do
H.docTypeHtml ! A.xmlns "http://www.w3.org/1999/xhtml" $ do
H.head $ do
H.meta ! A.httpEquiv "Content-Type" ! A.content "text/html; charset=UTF-8"
H.title "Cryptol Source"
H.style $ H.preEscapedString sty
H.body inner
toBlaze :: Located Token -> Html
toBlaze tok = H.span ! (A.class_ $ cl $ tokenType $ thing tok)
! (A.title $ toValue $ show $ pp $ srcRange tok)
$ H.toHtml
$ tokenText
$ thing tok
cl :: TokenT -> AttributeValue
cl tok =
case tok of
Num {} -> "number"
Ident {} -> "identifier"
KW {} -> "keyword"
Op {} -> "operator"
Sym {} -> "symbol"
Virt {} -> "virtual"
White Space -> "white"
White _ -> "comment"
Err {} -> "error"
EOF -> "eof"
StrLit {} -> "text"
ChrLit {} -> "text"
sty :: String
sty = unlines
[ "body { font-family: monospace }"
, ".number { color: #cc00cc }"
, ".identifier { }"
, ".keyword { color: blue; }"
, ".operator { color: #cc00cc }"
, ".symbol { color: blue }"
, ".white { }"
, ".virtual { background-color: red }"
, ".comment { color: green }"
, ".error { color: red }"
, ".text { color: #cc00cc }"
]