cryptol-2.8.0/0000755000000000000000000000000007346545000011406 5ustar0000000000000000cryptol-2.8.0/CHANGES.md0000755000000000000000000001076707346545000013016 0ustar0000000000000000# 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/LICENSE0000644000000000000000000000274007346545000012416 0ustar0000000000000000Copyright (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.hs0000644000000000000000000000035507346545000013045 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000012465 5ustar0000000000000000cryptol-2.8.0/bench/Main.hs0000644000000000000000000001413207346545000013706 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000013376 5ustar0000000000000000cryptol-2.8.0/bench/data/AES.cry0000755000000000000000000004140207346545000014531 0ustar0000000000000000// 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 = 0x9b00ae426bcc2cd6150a0af62b8be77fbb389c5b061a893588d1918f50f1f31ea1183bd81fd7faae77b4f6321a17130f46e21a2653b1f7dc520bf13305c5e7141cee9d8809d58b9b8ec2aa225120ea6ecec21fba09678bbbeda0b483ad299a8adb7b306599531cf717fd67a1c25e2adeeb48521619991e122b053c3a842936b14b6eea74734a6fc2abea6c1fc4780b2df8059ce9715299eeff7b6577409ebae71285929379cd065df0c249f9696e1b28da476ae52d55d0b1f676c619271d37d4211906d402e4eaf4df3031be5bc00962b7747e7b880bf55bee2882e5008e1c1fed70beb7e54be0545100a2e122b94536b888aaea25dde9e0715dfc892dee2b4fb8e94c6b15a2e77adad1f98e50ffef837309998fcdfd9bcb3d16dcd2a162a3b66c2533474981ba72321aaa9a611c670015fa6cbf9f7d7f26b3da415eccf01872cc3a686f659c0cc0d1d08a1d41470b0ceab527bd6499433a2f2df865982b3f616c246fe49f3a15b676983f7f853f6355bc2f4cdc39e5a29347f7031ab7d2659d0ddfb259fbdfe37eaee2e4dcbdfe0ac584038c5a98d85182ca2424f0e75b7f84d512828ed20bbd05065ed4ba0b850b51c31ecb231f2c879993038d7c9487e0fa46a84a02d4f5408faabd9f41edbbef5d6183dd880ea5b7272a2c46900e02357550c036f4b84168a3e891cd8fe33c2d521ce060a2863bb735e97614d0f5bf40068bfacb02297351db4a5bd80d8140a7e0734550967b2445d4236411e04f83e7f15f5148c9d758994cb8427238cea307ddde786dd74e5565b1dd905d085ebb5a7c725d72164adeeafd7387636c31eee2e729bd0fdf95686f957befdb190101cc23cc9b8e39c652e937bd1e21adad99b86d3b2ed0e4ed4ea4bd9d9ed2ad2b99adf40577fba6b25364cd6d96f79cb0f24ae551021904b57c1d469cfac780ea8469c530ab9d2fe6e98c270c5e1babed259878f48ab5824ebf327d8d18fd2e460334cc0ca9f3b0208c0b322a074185830c460cf58c45cef2234aa5ceb6ac294325bd4d4f9e569531165b9e731c84ffc92f453ce92464658592396f83555284a5f69288e3263d7bd083fa3257b0a11a9d8e4702ed06ebd172eacb7f559527637e0259573b1723c079465d593d5e89163e187ae7ac629ed75e398274daf9c420cac2d3b8f0de82dc9d50cd85d93460213416e3e5c0960c563d26fdb56e1e0dc79b251e95364389f6acbd78edd2664be1edc789b2c7a45b2101c69b3cdb8f9f6a2d7316d2cdca02fb5119d76c9bc93f7bc4e075eee1d453fa4668f368919d14035a7ba293d9787744f44e734443e9abc79a8d7aea71918f0a925026809cf43ae2fd1f6ea00fae2f87d4e7d83e4e86c81695d77e48d5f7080d61d878bde080cec46f4ed19d78f2b0c14db0bb6c871e6506064aa1c7b23c7d2baa9b5db5be3fc94923e09fddc13cd8322d05d990b3a9c5ce418c542eb80b1839a23ed7bc0b588ec957db3df1e1389ff0d541ec2f5331ab92fa7f85efa5ae9ec1c513365df179bb29d4f1914940c68468bd12e9fce04c8d08b6d3f1a4e2d632303ca99656bb248efbb6becad7ac6535678d6534aec746fbca6ec3dec85e4db505872e88bde65214b92eba09b91aff63c5db7e440a1f0ef0bca38759f9aaa35c0b8c565ec4307cc07a3226c992163aaa968ab9b9e507fa4b1910d1c24442615ffea299a8d7fcaf7aa2db3fac83d9f3b8a90bd9ae9100167944e01a07c011d0115870f5079d991d3dccd71fdd23b383b69409a1ba519c22194de6d1048e1195a4c716e0b27055aef816218d94972177732b0abd9df432d8f09293d8b22cc83e05522f7fa46742cd29b63357096601137130dc772717f8f4d02b5651fae2d74f72b25e9266090b95bf3ecb6ddda78edfa47346cf336e79548f9ea09eebe95da8903c86af35cb0abdaa4b78f05b2ef66342072b229a7f030e5b2f8e2ead7a8f5ea2a512cf0f02a4b0fc23e5aef4518f1c40674f5552a040cddf2daf47eec38103e6703720bdf40d68f8de4a9c9a39b1a21a2ea15337772526128abb3234bdce85dd7187a827f7aed625b862887f4ef41f656cc76c5311e34e654e0babe2230d3c1f7554106bab1dcdf18361e5579cf794af967421a1f06f80cfc254a9fa0a5b2a7bebd6dc8bbbf178f9647e356a4fd61e41301386784ba90dfaf5823a0007e50e61a0c3720b9b54edb800ba805e3817cddc7015febed997de87030f3341fad7249ce4530d55f5e0b3aac5a9de0d72c6c5672bc29440354d3a7d88873abdd090f41fa1db8740736583f74c7bfe526b283274f4bc08dea4884ccd75d34df9d8410f7e488b541f467331c5e7da352faa1019c394535472aa0f1ed1512928591e0b4335271df7a7d2d9d7fa1f7f4522be394b39bf15a7bc7a97ad21e171a638eb27d44efd57921938ed70335e3f3a8922553392db8a07e02cd4dc1184edbfbadaf09f97c50268d25dd5e7064968fde486d68b1051cef118d80c7a2c911a8cad22b26fd94f559cc12972b655ce014914cd3c20542815a0ff98ee166611eb2edc147bf2989d4fa1d72d88f7d211d05fe8e312b441edb3627982da6606d0cfa1c696979af5ff371e293c0a749f172343ab5f87ccd8a9d1c364f032e763a939f0696989a5316b48df43763d42170f598326579acba84e16508b5d4ffac1723c9bb98f7736e961c67caf3243b07760b3be602be9995a1a6b8c5360357e9fefab445229ccddd6214476a2c3af0eeadcd067db77ecaf7c84d605b99c89ab583edac68c3c8d951cce207c2df274709fe2d25477f14a8e50bc05f82b2cf49d9b56d97182b90a9395d90f23b9ee734d70d9312c9f6278f0ecd5f90c82f67693a589a94a6555f3abd8eac5408259879603acdc67b6fbcryptol-2.8.0/bench/data/BigSequence.cry0000755000000000000000000004566107346545000016326 0ustar0000000000000000xs = [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.cry0000755000000000000000000007000507346545000016761 0ustar0000000000000000xs = [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.cry0000755000000000000000000003141207346545000017544 0ustar0000000000000000/* * 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.cry0000755000000000000000000001005407346545000014763 0ustar0000000000000000// 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.cry0000755000000000000000000002666307346545000014576 0ustar0000000000000000// 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.cabal0000644000000000000000000002401607346545000014071 0ustar0000000000000000Name: 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/0000755000000000000000000000000007346545000013102 5ustar0000000000000000cryptol-2.8.0/cryptol/Main.hs0000644000000000000000000002314007346545000014322 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000203607346545000015356 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000013644 5ustar0000000000000000cryptol-2.8.0/cryptol/REPL/Haskeline.hs0000644000000000000000000002602507346545000016110 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000364507346545000015110 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000012154 5ustar0000000000000000cryptol-2.8.0/lib/Cryptol.cry0000644000000000000000000005635707346545000014347 0ustar0000000000000000/* * 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.z30000644000000000000000000002036707346545000014325 0ustar0000000000000000; ------------------------------------------------------------------------------ ; 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/0000755000000000000000000000000007346545000013631 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/Eval.hs0000644000000000000000000005431607346545000015065 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000014520 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/Eval/Arch.hs0000644000000000000000000000215507346545000015734 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000547607346545000015620 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000001724107346545000016117 0ustar0000000000000000-- | -- 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.lhs0000644000000000000000000013314007346545000017130 0ustar0000000000000000> -- | > -- 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.hs0000644000000000000000000001337607346545000016007 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000007466607346545000016153 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000014143 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/IR/FreeVars.hs0000644000000000000000000001226407346545000016221 0ustar0000000000000000module 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.hs0000644000000000000000000000751607346545000016630 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000016263 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/ModuleSystem/Base.hs0000644000000000000000000004411507346545000017476 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000003130607346545000017352 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000437207346545000020271 0ustar0000000000000000{-# 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.hs0000644000000000000000000000223707346545000021112 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000002425507346545000022260 0ustar0000000000000000{-# 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.hs0000644000000000000000000001255407346545000020526 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000004231707346545000017664 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000002612407346545000017504 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000003246407346545000020512 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000010071107346545000020210 0ustar0000000000000000-- | -- 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.y0000644000000000000000000010536707346545000015273 0ustar0000000000000000{ -- | -- 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/0000755000000000000000000000000007346545000015065 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/Parser/AST.hs0000644000000000000000000010511207346545000016050 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000240007346545000016671 0ustar0000000000000000-- | -- 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.x0000644000000000000000000002012507346545000016335 0ustar0000000000000000{ -- | -- 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.hs0000644000000000000000000004153107346545000017525 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000432007346545000016300 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000002374707346545000016501 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000001362507346545000017310 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000005156407346545000016455 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000005764007346545000017712 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000721507346545000017232 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000511107346545000017177 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000757007346545000016525 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000315207346545000016522 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000130107346545000015560 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000014723 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/Prims/Eval.hs0000644000000000000000000014617407346545000016163 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000014373 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/REPL/Command.hs0000644000000000000000000015122007346545000016306 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000006612707346545000016001 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000331607346545000015635 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000003652207346545000015756 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000015412 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/Symbolic/Prims.hs0000644000000000000000000005711107346545000017045 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000002057607346545000017034 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000015246 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/Testing/Concrete.hs0000644000000000000000000001466307346545000017356 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000002014407346545000017023 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000015604 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/Transform/AddModParams.hs0000644000000000000000000002275507346545000020447 0ustar0000000000000000-- | 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.hs0000644000000000000000000002760707346545000020244 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000003153607346545000020240 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000001116407346545000016047 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000015510 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/TypeCheck/AST.hs0000644000000000000000000003140507346545000016476 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000001610007346545000021712 0ustar0000000000000000module 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.hs0000644000000000000000000001530507346545000017434 0ustar0000000000000000module 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.hs0000644000000000000000000001673407346545000017441 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000002667007346545000017150 0ustar0000000000000000{-# 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.hs0000644000000000000000000010020007346545000017100 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000002605407346545000020143 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000001546407346545000020341 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000003467407346545000016747 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000010054707346545000017111 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000327307346545000016370 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000001235307346545000017746 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000003744707346545000017332 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000002275207346545000017626 0ustar0000000000000000{-# 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.hs0000644000000000000000000000352407346545000020474 0ustar0000000000000000{-# 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.hs0000644000000000000000000002513707346545000017144 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000016762 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/Class.hs0000644000000000000000000001776507346545000020403 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000001625207346545000020745 0ustar0000000000000000-- | 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.hs0000644000000000000000000002015607346545000020501 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000003331207346545000020722 0ustar0000000000000000{-# 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/0000755000000000000000000000000007346545000020364 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/TypeCheck/Solver/Numeric/Fin.hs0000644000000000000000000000554507346545000021445 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000003014407346545000022506 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000002640707346545000017772 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000001520507346545000021101 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000207707346545000020430 0ustar0000000000000000module 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.hs0000644000000000000000000000466007346545000020424 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000002527607346545000017160 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000002301307346545000016706 0ustar0000000000000000{-# 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.hs0000644000000000000000000006303307346545000016772 0ustar0000000000000000{-# 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.hs0000644000000000000000000001306107346545000017424 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000001345707346545000017264 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000766207346545000017445 0ustar0000000000000000module 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.hs0000644000000000000000000000720507346545000017142 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000014731 5ustar0000000000000000cryptol-2.8.0/src/Cryptol/Utils/Debug.hs0000644000000000000000000000061207346545000016312 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000734607346545000016342 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000254707346545000016514 0ustar0000000000000000-- | 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.hs0000644000000000000000000000212007346545000016153 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000001745207346545000015615 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000140407346545000016316 0ustar0000000000000000-- | -- 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.hs0000644000000000000000000000666507346545000017102 0ustar0000000000000000{-# 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.hs0000644000000000000000000000112607346545000015612 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000012175 5ustar0000000000000000cryptol-2.8.0/src/GitRev.hs0000644000000000000000000000103607346545000013731 0ustar0000000000000000-- | -- 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/0000755000000000000000000000000007346545000012546 5ustar0000000000000000cryptol-2.8.0/utils/CryHtml.hs0000644000000000000000000000423707346545000014472 0ustar0000000000000000#!/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 }" ]