cryptol-3.0.0/0000755000000000000000000000000007346545000011377 5ustar0000000000000000cryptol-3.0.0/CHANGES.md0000644000000000000000000005725107346545000013003 0ustar0000000000000000# 3.0.0 -- 2023-06-26 ## Language changes * Cryptol now includes a redesigned module system that is significantly more expressive than in previous releases. The new module system includes the following features: * Nested modules: Modules may now be defined within other modules. * Named interfaces: An interface specifies the parameters to a module. Separating the interface from the parameter declarations makes it possible to have different parameters that use the same interface. * Top-level module constraints: These are useful to specify constraints between different module parameters (i.e., ones that come from different interfaces or multiple copies of the same interface). See the [manual section](https://galoisinc.github.io/cryptol/master/Modules.html#instantiation-by-parametrizing-declarations) for more information. * Declarations may now use *numeric constraint guards*. This is a feature that allows a function to behave differently depending on its numeric type parameters. See the [manual section](https://galoisinc.github.io/cryptol/master/BasicSyntax.html#numeric-constraint-guards)) for more information. * The foreign function interface (FFI) has been added, which allows Cryptol to call functions written in C. See the [manual section](https://galoisinc.github.io/cryptol/master/FFI.html) for more information. * The unary `-` operator now has the same precedence as binary `-`, meaning expressions like `-x^^2` will now parse as `-(x^^2)` instead of `(-x)^^2`. **This is a breaking change.** A warning has been added in cases where the behavior has changed, and can be disabled with `:set warnPrefixAssoc=off`. * Infix operators are now allowed in import lists: `import M ((<+>))` will import only the operator `<+>` from module `M`. * `lib/Array.cry` now contains an `arrayEq` primitive. Like the other array-related primitives, this has no computational interpretation (and therefore cannot be used in the Cryptol interpreter), but it is useful for stating specifications that are used in SAW. ## New features * Add a `:time` command to benchmark the evaluation time of expressions. * Add support for literate Cryptol using reStructuredText. Cryptol code is extracted from `.. code-block:: cryptol` and `.. sourcecode:: cryptol` directives. * Add a syntax highlight file for Vim, available in `syntax-highlight/cryptol.vim` * Add `:new-seed` and `:set-seed` commands to the REPL. These affect random test generation, and help write reproducable Cryptol scripts. * Add support for the CVC5 solver, which can be selected with `:set prover=cvc5`. If you want to specify a What4 or SBV backend, you can use `:set prover=w4-cvc5` or `:set prover=sbv-cvc5`, respectively. (Note that `sbv-cvc5` is non-functional on Windows at this time due to a downstream issue with CVC5 1.0.4 and earlier.) * Add `:file-deps` commands to the REPL and Python API. It shows information about the source files and dependencies of modules or Cryptol files. ## Bug fixes * Fix a bug in the What4 backend that could cause applications of `(@)` with symbolic `Integer` indices to become out of bounds (#1359). * Fix a bug that caused finite bitvector enumerations to panic when used in combination with `(#)` (e.g., `[0..1] # 0`). * Cryptol's markdown parser is slightly more permissive and will now parse code blocks with whitespace in between the backticks and `cryptol`. This sort of whitespace is often inserted by markdown generation tools such as `pandoc`. * Improve documentation for `fromInteger` (#1465) * Closed issues #812, #977, #1090, #1140, #1147, #1253, #1322, #1324, #1329, #1344, #1347, #1351, #1354, #1355, #1359, #1366, #1368, #1370, #1371, #1372, #1373, #1378, #1383, #1385, #1386, #1391, #1394, #1395, #1396, #1398, #1399, #1404, #1415, #1423, #1435, #1439, #1440, #1441, #1442, #1444, #1445, #1448, #1449, #1450, #1451, #1452, #1456, #1457, #1458, #1462, #1465, #1466, #1470, #1475, #1480, #1483, #1484, #1485, #1487, #1488, #1491, #1496, #1497, #1501, #1503, #1510, #1511, #1513, and #1514. * Merged pull requests #1184, #1205, #1279, #1356, #1357, #1358, #1361, #1363, #1365, #1367, #1376, #1379, #1380, #1384, #1387, #1388, #1393, #1401, #1402, #1403, #1406, #1408, #1409, #1410, #1411, #1412, #1413, #1414, #1416, #1417, #1418, #1419, #1420, #1422, #1424, #1429, #1430, #1431, #1432, #1436, #1438, #1443, #1447, #1453, #1454, #1459, #1460, #1461, #1463, #1464, #1467, #1468, #1472, #1473, #1474, #1476, #1477, #1478, #1481, #1493, #1499, #1502, #1504, #1506, #1509, #1512, #1516, #1518, #1519, #1520, #1521, #1523, #1527, and #1528. # 2.13.0 ## Language changes * Update the implementation of the Prelude function `sortBy` to use a merge sort instead of an insertion sort. This improves the both asymptotic and observed performance on sorting tasks. ## UI improvements * "Type mismatch" errors now show a context giving more information about the location of the error. The context is shown when the part of the types match, but then some nested types do not. For example, when mathching `{ a : [8], b : [8] }` with `{ a : [8], b : [16] }` the error will be `8` does not match `16` and the context will be `{ b : [ERROR] _ }` indicating that the error is in the length of the sequence of field `b`. ## Bug fixes * The What4 backend now properly supports Boolector 3.2.2 or later. * Make error message locations more precise in some cases (issue #1299). * Make `:reload` behave as expected after loading a module with `:module` (issue #1313). * Make `include` paths work as expected when nested within another `include` (issue #1321). * Fix a panic that occurred when loading dependencies before `include`s are resolved (issue #1330). * Closed issues #1098, #1280, and #1347. * Merged pull requests #1233, #1300, #1301, #1302, #1303, #1305, #1306, #1307, #1308, #1311, #1312, #1317, #1319, #1323, #1326, #1331, #1333, #1336, #1337, #1338, #1342, #1346, #1348, and #1349. # 2.12.0 ## Language changes * Updates to the layout rule. We simplified the specification and made some minor changes, in particular: - Paren blocks nested in a layout block need to respect the indentation if the layout block - We allow nested layout blocks to have the same indentation, which is convenient when writing `private` declarations as they don't need to be indented as long as they are at the end of the file. * New enumeration forms `[x .. y by n]`, `[x .. y down by n]` have been implemented. These new forms let the user explicitly specify the stride for an enumeration, as opposed to the previous `[x, y .. z]` form (where the stride was computed from `x` and `y`). * Nested modules are now available (from pull request #1048). For example, the following is now valid Cryptol: module SubmodTest where import submodule B as C submodule A where propA = C::y > 5 submodule B where y : Integer y = 42 ## New features * What4 prover backends now feature an improved multi-SAT procedure which is significantly faster than the old algorithm. Thanks to Levent Erkök for the suggestion. * There is a new `w4-abc` solver option, which communicates to ABC as an external process via What4. * Expanded support for declaration forms in the REPL. You can now define infix operators, type synonyms and mutually-recursive functions, and state signatures and fixity declarations. Multiple declarations can be combined into a single line by separating them with `;`, which is necessary for stating a signature together with a definition, etc. * There is a new `:set path` REPL option that provides an alternative to `CRYPTOLPATH` for controlling where to search for imported modules (issue #631). * The `cryptol-remote-api` server now natively supports HTTPS (issue #1008), `newtype` values (issue #1033), and safety checking (issue #1166). * Releases optionally include solvers (issue #1111). See the `*-with-solvers*` files in the assets list for this release. ## Bug fixes * Closed issues #422, #436, #619, #631, #633, #640, #680, #734, #735, #759, #760, #764, #849, #996, #1000, #1008, #1019, #1032, #1033, #1034, #1043, #1047, #1060, #1064, #1083, #1084, #1087, #1102, #1111, #1113, #1117, #1125, #1133, #1142, #1144, #1145, #1146, #1157, #1160, #1163, #1166, #1169, #1175, #1179, #1182, #1190, #1191, #1196, #1197, #1204, #1209, #1210, #1213, #1216, #1223, #1226, #1238, #1239, #1240, #1241, #1250, #1256, #1259, #1261, #1266, #1274, #1275, #1283, and #1291. * Merged pull requests #1048, #1128, #1129, #1130, #1131, #1135, #1136, #1137, #1139, #1148, #1149, #1150, #1152, #1154, #1156, #1158, #1159, #1161, #1164, #1165, #1168, #1170, #1171, #1172, #1173, #1174, #1176, #1181, #1183, #1186, #1188, #1192, #1193, #1194, #1195, #1199, #1200, #1202, #1203, #1205, #1207, #1211, #1214, #1215, #1218, #1219, #1221, #1224, #1225, #1227, #1228, #1230, #1231, #1232, #1234, #1242, #1243, #1244, #1245, #1246, #1247, #1248, #1251, #1252, #1254, #1255, #1258, #1263, #1265, #1268, #1269, #1270, #1271, #1272, #1273, #1276, #1281, #1282, #1284, #1285, #1286, #1287, #1288, #1293, #1294, and #1295. # 2.11.0 ## Language changes * The `newtype` construct, which has existed in the interpreter in an incomplete and undocumented form for quite a while, is now fullly supported. The construct is documented in section 1.22 of [Programming Cryptol](https://cryptol.net/files/ProgrammingCryptol.pdf). Note, however, that the `cryptol-remote-api` RPC server currently does not include full support for referring to `newtype` names, though it can work with implementations that use `newtype` internally. ## New features * By default, the interpreter will now track source locations of expressions being evaluated, and retain call stack information. This information is incorporated into error messages arising from runtime errors. This additional bookkeeping incurs significant runtime overhead, but may be disabled using the `--no-call-stacks` command-line option. * The `:exhaust` command now works for floating-point types and the `:check` command now uses more representative sampling of floating-point input values to test. * The `cryptol-remote-api` RPC server now has methods corresponding to the `:prove` and `:sat` commands in the REPL. * The `cryptol-eval-server` executable is a new, stateless server providing a subset of the functionality of `cryptol-remote-api` dedicated entirely to invoking Cryptol functions on concrete inputs. ## Internal changes * A single running instance of the SMT solver used for type checking (Z3) is now used to check a larger number of type correctness queries. This means that fewer solver instances are invoked, and type checking should generally be faster. * The Cryptol interpreter now builds against `libBF` version 0.6, which fixes a few bugs in the evaluation of floating-point operations. ## Bug fixes * Closed issues #118, #398, #426, #470, #491, #567, #594, #639, #656, #698, #743, #810, #858, #870, #905, #915, #917, #962, #973, #975, #980, #984, #986, #990, #996, #997, #1002, #1006, #1009, #1012, #1024, #1030, #1035, #1036, #1039, #1040, #1044, #1045, #1049, #1050, #1051, #1052, #1063, #1092, #1093, #1094, and #1100. # 2.10.0 ## Language changes * Cryptol now supports primality checking at the type level. The type-level predicate `prime` is true when its parameter passes the Miller-Rabin probabilistic primality test implemented in the GMP library. * The `Z p` type is now a `Field` when `p` is prime, allowing additional operations on `Z p` values. * The literals `0` and `1` can now be used at type `Bit`, as alternatives for `False` and `True`, respectively. ## New features * The interpreter now includes a number of primitive functions that allow faster execution of a number of common cryptographic functions, including the core operations of AES and SHA-2, operations on GF(2) polynomials (the existing `pmod`, `pdiv`, and `pmult` functions), and some operations on prime field elliptic curves. These functions are useful for implementing higher-level algorithms, such as many post-quantum schemes, with more acceptable performance than possible when running a top-to-bottom Cryptol implementation in the interpreter. For a full list of the new primitives, see the new Cryptol [`SuiteB`](https://github.com/GaloisInc/cryptol/blob/master/lib/SuiteB.cry) and [`PrimeEC`](https://github.com/GaloisInc/cryptol/blob/master/lib/PrimeEC.cry) modules. * The REPL now allows lines containing only comments, making it easier to copy and paste examples. * The interpreter has generally improved performance overall. * Several error messages are more comprehensible and less verbose. * Cryptol releases and nightly builds now include an RPC server alongside the REPL. This provides an alternative interface to the same interpreter and proof engine available from the REPL, but is better-suited to programmatic use. Details on the protocol used by the server are available [here](https://github.com/GaloisInc/argo/blob/master/docs/Protocol.rst). A Python client for this protocol is available [here](https://github.com/GaloisInc/argo/tree/master/python). * Windows builds are now distributed as both `.tar.gz` and `.msi` files. ## Bug Fixes * Closed issues #98, #485, #713, #744, #746, #787, #796, #803, #818, #826, #838, #856, #873, #875, #876, #877, #879, #880, #881, #883, #886, #887, #888, #892, #894, #901, #910, #913, #924, #926, #931, #933, #937, #939, #946, #948, #953, #956, #958, and #969. # 2.9.1 ## Language changes * The type of `generate` which is used for `a@i` sequence definitions, is generalized so that the index type can be any `Integral` type large enough to index the entire array being defined. ## Bug Fixes * Closed issues #848, #850, #851, #859, and #861. * Fixed Windows installer paths. # 2.9.0 ## Language changes * Removed the `Arith` class. Replaced it instead with more specialized numeric classes: `Ring`, `Integral`, `Field`, and `Round`. `Ring` is the closest analogue to the old `Arith` class; it contains the `fromInteger`, `(+)`, `(*)`, `(-)` and `negate` methods. `Ring` contains all the base arithmetic types in Cryptol, and lifts pointwise over tuples, sequences and functions, just as `Arith` did. The new `Integral` class now contains the integer division and modulus methods (`(/)` and `(%)`), and the sequence indexing, sequence update and shifting operations are generalized over `Integral`. The `toInteger` operation is also generalized over this class. `Integral` contains the bitvector types and `Integer`. The new `Field` class contains types representing mathematical fields (or types that are approximately fields). It is currently inhabited by the new `Rational` type, and the `Float` family of types. It will eventually also contain the `Real` type. It has the operation `recip` for reciprocal and `(/.)` for field division (not to be confused for `(/)`, which is Euclidean integral division). There is also a new `Round` class for types that can sensibly be rounded to integers. This class has the methods `floor`, `ceiling`, `trunc`, `roundToEven` and `roundAway` for performing different kinds of integer rounding. `Rational` and `Float` inhabit `Round`. The type of `(^^)` is modified to be `{a, e} (Ring a, Integral e) => a -> e -> a`. This makes it clear that the semantics are iterated multiplication, which makes sense in any ring. Finally, the `lg2`, `(/$)` and `(%$)` methods of `Arith` have had their types specialized so they operate only on bitvectors. * Added an `Eq` class, and moved the equality operations from `Cmp` into `Eq`. The `Z` type becomes a member of `Eq` but not `Cmp`. * Added a base `Rational` type. It is implemented as a pair of integers, quotiented in the usual way. As such, it reduces to the theory of integers and requires no new solver support (beyond nonlinear integer arithmetic). `Rational` inhabits the new `Field` and `Round` classes. Rational values can be constructed using the `ratio` function, or via `fromInteger`. * The `generate` function (and thus `x @ i= e` definitions) has had its type specialized so the index type is always `Integer`. * The new typeclasses are arranged into a class hierarchy, and the typechecker will use that information to infer superclass instances from subclasses. * Added a family of base types, `Float e p`, for working with floating point numbers. The parameters control the precision of the numbers, with `e` being the number of bits to use in the exponent and `p-1` being the number of bits to use in the mantissa. The `Float` family of types may be used through the usual overloaded functionality in Cryptol, and there is a new built-in module called `Float`, which contains functionality specific to floating point numbers. * Add a way to write fractional literals in base 2,8,10, and 16. Fractional literals are overloaded, and may be used for different types (currently `Rational` and the `Float` family). Fractional literal in base 2,8,and 16 must be precise, and will be rejected statically if they cannot be represented exactly. Fractional literals in base 10 are rounded to the nearest even representable number. * Changes to the defaulting algorithm. The new algorithm only applies to constraints arising from literals (i.e., `Literal` and `FLiteral` constraints). The guiding principle is that we now default these to one of the infinite precision types `Integer` or `Rational`. `Literal` constraints are defaulted to `Integer`, unless the corresponding type also has `Field` constraint, in which case we use `Rational`. Fractional literal constraints are always defaulted to `Rational. ## New features * Document the behavior of lifted selectors. * Added support for symbolic simulation via the `What4` library in addition to the previous method based on `SBV`. The What4 symbolic simulator is used when selecting solvers with the `w4` prefix, such as `w4-z3`, `w4-cvc4`, `w4-yices`, etc. The `SBV` and `What4` libraries make different tradeoffs in how they represent formulae. You may find one works better than another for the same problem, even with the same solver. * More detailed information about the status of various symbols in the output of the `:browse` command (issue #688). * The `:safe` command will attempt to prove that a given Cryptol term is safe; in other words, that it will not encounter a run-time error for all inputs. Run-time errors arise from things like division-by-zero, index-out-of-bounds situations and explicit calls to `error` or `assert`. * The `:prove` and `:sat` commands now incorporate safety predicates by default. In a `:sat` call, models will only be found that do not cause run-time errors. For `:prove` calls, the safety conditions are added as additional proof goals. The prior behavior (which ignored safety conditions) can be restored using `:set ignore-safety = on`. * Improvements to the `any` prover. It will now shut down external prover processes correctly when one finds a solution. It will also wait for the first _successful_ result to be returned from a prover, instead of failing as soon as one prover fails. * An experimental `parmap` primitive that applies a function to a sequence of arguments and computes the results in parallel. This operation should be considered experimental and may significantly change or disappear in the future, and could possibly uncover unknown race conditions in the interpreter. ## Bug fixes * Closed issues #346, #444, #614, #617, #636, #660, #662, #663, #664, #667, #670, #702, #711, #712, #716, #723, #725, #731, #835, #836, #839, #840, and #845 # 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. cryptol-3.0.0/LICENSE0000644000000000000000000000274007346545000012407 0ustar0000000000000000Copyright (c) 2013-2020 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-3.0.0/Setup.hs0000644000000000000000000000035507346545000013036 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-3.0.0/bench/0000755000000000000000000000000007346545000012456 5ustar0000000000000000cryptol-3.0.0/bench/Main.hs0000644000000000000000000001465707346545000013713 0ustar0000000000000000-- | -- Module : Main -- Copyright : (c) 2015-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Control.DeepSeq ( force ) import Control.Monad.IO.Class( liftIO ) 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.Value as E import qualified Cryptol.Eval.Concrete as C 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 qualified Cryptol.Parser as P import qualified Cryptol.Parser.AST as P import qualified Cryptol.Parser.NoInclude as P import qualified Cryptol.Eval.SBV 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 "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 "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 (eres, _) <- M.runModuleM (evOpts,menv) $ withLib $ do -- code from `loadModule` and `checkModule` in -- `Cryptol.ModuleSystem.Base` let pm' = M.addPrelude pm M.loadDeps pm' enim <- M.io (P.removeIncludesModule path pm') nim <- either (error "Failed to remove includes") return enim 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) case eres of Right ((prims, scm, tcEnv), menv') -> return (prims, scm, tcEnv, menv') Left _ -> error $ "Failed to load " ++ name in env setup $ \ ~(prims, scm, tcEnv, menv) -> bench name $ whnfIO $ 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 mempty 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 (eres, _) <- 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 case eres of Right (texpr, menv') -> return (texpr, menv') Left _ -> error $ "Failed to load " ++ name in env setup $ \ ~(texpr, menv) -> bench name $ nfIO $ E.runEval evOpts $ do let ?evalPrim = C.evalPrim env' <- E.evalDecls C.Concrete (M.allDeclGroups menv) mempty (e :: C.Value) <- E.evalExpr C.Concrete 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 (eres, _) <- 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 case eres of Right (texpr, menv') -> return (texpr, menv') Left _ -> error $ "Failed to load " ++ name in env setup $ \ ~(texpr, menv) -> bench name $ whnfIO $ fmap force E.runEval evOpts $ S.sbvEval $ do let ?evalPrim = S.evalPrim env' <- E.evalDecls S.SBV (M.allDeclGroups menv) mempty (e :: S.Value) <- E.evalExpr S.SBV env' texpr liftIO $ SBV.generateSMTBenchmark False $ return (E.fromVBit e) cryptol-3.0.0/bench/data/0000755000000000000000000000000007346545000013367 5ustar0000000000000000cryptol-3.0.0/bench/data/AES.cry0000644000000000000000000004140207346545000014517 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-3.0.0/bench/data/BigSequence.cry0000644000000000000000000004566107346545000016314 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-3.0.0/bench/data/BigSequenceHex.cry0000644000000000000000000007000507346545000016747 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-3.0.0/bench/data/SHA512.cry0000644000000000000000000001005407346545000014751 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-3.0.0/bench/data/ZUC.cry0000644000000000000000000002666307346545000014564 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-3.0.0/cryptol.cabal0000644000000000000000000003072107346545000014062 0ustar0000000000000000Cabal-version: 2.4 Name: cryptol Version: 3.0.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: BSD-3-Clause 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-2022 Galois Inc. Category: Language Build-type: Simple extra-source-files: bench/data/*.cry CHANGES.md lib/*.cry lib/*.z3 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 -- add a tag on release branches tag: 3.0.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. flag ffi default: True description: Enable the foreign function interface library Default-language: Haskell2010 Build-depends: base >= 4.9 && < 5, arithmoi >= 0.12, async >= 2.2 && < 2.3, base-compat >= 0.6 && < 0.13, bv-sized >= 1.0 && < 1.1, bytestring >= 0.10, array >= 0.4, containers >= 0.5, criterion-measurement, cryptohash-sha1 >= 0.11 && < 0.12, deepseq >= 1.3, directory >= 1.2.2.0, exceptions, filepath >= 1.3, gitrev >= 1.0, ghc-prim, GraphSCC >= 1.0.4, heredoc >= 0.2, language-c99, language-c99-simple, libBF >= 0.6 && < 0.7, MemoTrie >= 0.6 && < 0.7, monad-control >= 1.0, monadLib >= 3.7.2, parameterized-utils >= 2.0.2, pretty, prettyprinter >= 1.7.0, pretty-show, process >= 1.2, sbv >= 9.1 && < 10.2, simple-smt >= 0.9.7, stm >= 2.4, strict, text >= 1.1, tf-random >= 0.5, transformers-base >= 0.4, vector, mtl >= 2.2.1, time >= 1.6.0.1, panic >= 0.3, what4 >= 1.4 && < 1.5 if impl(ghc >= 9.0) build-depends: ghc-bignum >= 1.0 && < 1.4 else build-depends: integer-gmp >= 1.0 && < 1.1 if flag(ffi) build-depends: hgmp, libffi >= 0.2 if os(windows) build-depends: Win32 else build-depends: unix cpp-options: -DFFI_ENABLED Build-tool-depends: alex:alex, happy:happy hs-source-dirs: src Exposed-modules: Cryptol.Parser, Cryptol.Parser.Lexer, Cryptol.Parser.Token, Cryptol.Parser.Layout, Cryptol.Parser.AST, Cryptol.Parser.Position, Cryptol.Parser.Names, Cryptol.Parser.Name, Cryptol.Parser.NoPat, Cryptol.Parser.ExpandPropGuards, Cryptol.Parser.NoInclude, Cryptol.Parser.Selector, Cryptol.Parser.Utils, Cryptol.Parser.Unlit, Cryptol.Utils.Fixity, Cryptol.Utils.Ident, Cryptol.Utils.RecordMap, Cryptol.Utils.PP, Cryptol.Utils.Panic, Cryptol.Utils.Debug, Cryptol.Utils.Misc, Cryptol.Utils.Patterns, Cryptol.Utils.Logger, Cryptol.Utils.Benchmark, Cryptol.Utils.Types, Cryptol.Version, Cryptol.ModuleSystem, Cryptol.ModuleSystem.Base, Cryptol.ModuleSystem.Env, Cryptol.ModuleSystem.Fingerprint, Cryptol.ModuleSystem.Interface, Cryptol.ModuleSystem.Monad, Cryptol.ModuleSystem.Name, Cryptol.ModuleSystem.Names, Cryptol.ModuleSystem.NamingEnv, Cryptol.ModuleSystem.Binds Cryptol.ModuleSystem.Exports, Cryptol.ModuleSystem.Renamer, Cryptol.ModuleSystem.Renamer.Imports, Cryptol.ModuleSystem.Renamer.ImplicitImports, Cryptol.ModuleSystem.Renamer.Monad, Cryptol.ModuleSystem.Renamer.Error, 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.InferTypes, Cryptol.TypeCheck.Interface, Cryptol.TypeCheck.Error, Cryptol.TypeCheck.Kind, Cryptol.TypeCheck.Subst, Cryptol.TypeCheck.Instantiate, Cryptol.TypeCheck.Unify, Cryptol.TypeCheck.PP, Cryptol.TypeCheck.Solve, Cryptol.TypeCheck.Default, Cryptol.TypeCheck.SimpleSolver, Cryptol.TypeCheck.TypeMap, Cryptol.TypeCheck.TypeOf, Cryptol.TypeCheck.Sanity, Cryptol.TypeCheck.FFI, Cryptol.TypeCheck.FFI.Error, Cryptol.TypeCheck.FFI.FFIType, Cryptol.TypeCheck.Module, Cryptol.TypeCheck.ModuleInstance, Cryptol.TypeCheck.ModuleBacktickInstance, 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.IR.FreeVars, Cryptol.IR.TraverseNames, Cryptol.Backend, Cryptol.Backend.Arch, Cryptol.Backend.Concrete, Cryptol.Backend.FFI, Cryptol.Backend.FFI.Error, Cryptol.Backend.FloatHelpers, Cryptol.Backend.Monad, Cryptol.Backend.SeqMap, Cryptol.Backend.SBV, Cryptol.Backend.What4, Cryptol.Backend.WordValue, Cryptol.Eval, Cryptol.Eval.Concrete, Cryptol.Eval.Env, Cryptol.Eval.FFI, Cryptol.Eval.FFI.GenHeader, Cryptol.Eval.Generic, Cryptol.Eval.Prims, Cryptol.Eval.Reference, Cryptol.Eval.SBV, Cryptol.Eval.Type, Cryptol.Eval.Value, Cryptol.Eval.What4, Cryptol.AES, Cryptol.F2, Cryptol.SHA, Cryptol.PrimeEC, Cryptol.Testing.Random, Cryptol.Symbolic, Cryptol.Symbolic.SBV, Cryptol.Symbolic.What4, Cryptol.REPL.Command, Cryptol.REPL.Help, Cryptol.REPL.Browse, Cryptol.REPL.Monad, Cryptol.REPL.Trie Other-modules: Cryptol.Parser.LexerUtils, Cryptol.Parser.ParserUtils, Cryptol.Prelude, GHC.Num.Compat, Paths_cryptol, GitRev GHC-options: -Wall -fsimpl-tick-factor=140 -O2 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 Autogen-modules: Paths_cryptol Other-modules: OptParser, REPL.Haskeline, REPL.Logo, Paths_cryptol build-depends: ansi-terminal , base , base-compat , containers , cryptol , directory , filepath , haskeline >= 0.7 && < 0.9 , exceptions , monad-control , text , transformers GHC-options: -Wall -threaded -rtsopts "-with-rtsopts=-N1 -A64m" -O2 if impl(ghc >= 8.0.1) ghc-options: -Wno-redundant-constraints if os(linux) && flag(static) ld-options: -static -pthread ghc-options: -optl-fuse-ld=bfd executable cryptol-html Default-language: Haskell2010 main-is: CryHtml.hs hs-source-dirs: utils build-depends: base, text, cryptol, blaze-html GHC-options: -Wall if os(linux) && flag(static) ld-options: -static -pthread ghc-options: -optl-fuse-ld=bfd executable check-exercises Default-language: Haskell2010 Main-is: CheckExercises.hs hs-source-dirs: cryptol build-depends: ansi-terminal , base , containers , directory , extra , filepath , mtl , optparse-applicative , process , temporary , text GHC-options: -Wall 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" -O2 if impl(ghc >= 8.0.1) ghc-options: -Wno-redundant-constraints if os(linux) && flag(static) ld-options: -static -pthread ghc-options: -optl-fuse-ld=bfd build-depends: base , criterion , cryptol , deepseq , directory , filepath , sbv , text cryptol-3.0.0/cryptol/0000755000000000000000000000000007346545000013073 5ustar0000000000000000cryptol-3.0.0/cryptol/CheckExercises.hs0000644000000000000000000003541407346545000016326 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module Main(main) where import Control.Monad.State import Options.Applicative import Data.Char (isSpace, isAlpha) import Data.Foldable (traverse_) import Data.List (isInfixOf, isPrefixOf, stripPrefix) import Data.Maybe (fromMaybe) import qualified Data.Sequence as Seq import Numeric.Natural import qualified System.Process as P import System.Directory import System.Exit import System.IO.Temp import Data.Foldable (toList) data Opts = Opts { latexFile :: FilePath -- ^ The latex file we are going to check , cryptolExe :: Maybe FilePath -- ^ Path to cryptol executable (default: cabal v2-exec cryptol) , tempDir :: Maybe FilePath -- ^ Path to store temporary files and log files } deriving Show optsParser :: Parser Opts optsParser = Opts <$> strArgument ( help "path to latex file" <> metavar "PATH" ) <*> ( optional $ strOption ( long "exe" <> short 'e' <> metavar "PATH" <> help "Path to cryptol executable (defaults to 'cabal v2-exec cryptol')" ) ) <*> ( optional $ strOption ( long "log-dir" <> short 'l' <> metavar "PATH" <> help "Directory for log files in case of failure (defaults to .)" ) ) -- | Trim whitespace off both ends of a string trim :: String -> String trim = f . f where f = reverse . dropWhile isSpace ---------------------------------------------------------------------- -- LaTeX processing state monad -- -- We process the text-by-line. The behavior of the state monad on a line is -- governed by the mode it is currently in. The current mode dictates how to -- interpret each line, and which mode to transition to next. -- -- There are four modes: AwaitingReplMode, ReplinMode, ReploutMode, and -- ReplPromptMode. Below we describe the behavior of each mode. -- -- AwaitingReplMode: When in this mode, we are anticipating "replin" or -- "replout" lines; that is, lines that will be issued as input to the repl or -- expected as output from the repl.. When we see a \begin{replinVerb}, we -- transition to ReplinMode. When we see a \begin{reploutVerb}, we transition to -- ReploutMode. When we see a \begin{replPromptVerb}, we transition to -- ReplPromptMode. When we see an inline \replin{..} command, we add the content -- to the list of replin lines without changing modes. When we see an inline -- \replout{..} command, we add the content to the list of replout lines without -- changing modes. -- -- ReplinMode: When in this mode, we are inside of a "\begin{replinVerb}" -- section. When we see a \end{replinVerb} line, we transition to -- AwaitingReplMode. Otherwise, we simply add the entire line to the list of -- replin lines. -- -- ReploutMode: Like ReplinMode, except we add each line to the expected output. -- -- ReplPromptMode: A combination of ReplinMode and ReploutMode. Each line is -- either added to input or expected output. If the line starts with a prompt -- like "Cryptol>" or "Float>", it is added to expected input. Otherwise it is -- added to expected output. data PMode = AwaitingReplMode | ReplinMode | ReploutMode | ReplPromptMode deriving (Eq, Show) data Line = Line { lineNum :: Natural , lineText :: String } deriving (Eq, Show) -- | REPL input and expected output, with line number annotations. data ReplData = ReplData { rdReplin :: Seq.Seq Line , rdReplout :: Seq.Seq Line } deriving (Eq, Show) -- | Latex processing state data PState = PState { pMode :: PMode -- ^ current mode , pCompletedReplData :: Seq.Seq ReplData -- ^ list of all completed REPL input/output pairs to be -- validated (thus far) , pReplin :: Seq.Seq Line -- ^ list of replin lines (so far) for unfinished ReplData , pReplout :: Seq.Seq Line -- ^ list of replout lines (so far) for unfinished ReplData , pCurrentLine :: Natural } deriving (Eq, Show) initPState :: PState initPState = PState AwaitingReplMode Seq.empty Seq.empty Seq.empty 1 -- | P monad for reading in lines type P = State PState first3 :: (a -> a') -> (a, b, c) -> (a', b, c) first3 f (a, b, c) = (f a, b, c) -- | Like 'stripPrefix', but takes a list of prefixes rather than a single -- prefix. Returns the first prefix that matches the start of the list along -- with the remainder of the list. stripPrefixOneOf :: Eq a => [[a]] -> [a] -> Maybe ([a], [a]) stripPrefixOneOf [] _ = Nothing stripPrefixOneOf (p:ps) as = case stripPrefix p as of Nothing -> stripPrefixOneOf ps as Just as' -> Just (p, as') -- | Like 'stripInfix', but takes a list of infixes. Returns the infix that -- matches at the earliest index. stripInfixOneOf :: Eq a => [[a]] -> [a] -> Maybe ([a], [a], [a]) stripInfixOneOf needles haystack | Just (needle, suffix) <- stripPrefixOneOf needles haystack = Just ([], needle, suffix) stripInfixOneOf _ [] = Nothing stripInfixOneOf needles (x:xs) = first3 (x:) <$> stripInfixOneOf needles xs data InlineRepl = InlineReplin | InlineReplout -- | Extracts the first inline repl command returns the type of command, its -- contents, and the remainder of the string. inlineRepl :: String -> Maybe (InlineRepl, String, String) inlineRepl s | Just (_, ir, s1) <- stripInfixOneOf [ "\\replin|" , "\\replout|" , "\\hidereplin|" , "\\hidereplout|"] s , (s2, s3) <- break (=='|') s1 = case ir of "\\replin|" -> Just (InlineReplin, s2, s3) "\\replout|" -> Just (InlineReplout, s2, s3) "\\hidereplin|" -> Just (InlineReplin, s2, s3) "\\hidereplout|" -> Just (InlineReplout, s2, s3) _ -> error "PANIC: CheckExercises.inlineRepl" | otherwise = Nothing addReplData :: P () addReplData = do replin <- gets pReplin replout <- gets pReplout completedReplData <- gets pCompletedReplData let completedReplData' = completedReplData Seq.|> ReplData replin replout when (not (Seq.null replin && Seq.null replout)) $ modify' $ \st -> st { pCompletedReplData = completedReplData' , pReplin = Seq.empty , pReplout = Seq.empty } addReplin :: String -> P () addReplin s = do ln <- gets pCurrentLine replin <- gets pReplin modify' $ \st -> st { pReplin = replin Seq.|> Line ln s } addReplout :: String -> P () addReplout s = do ln <- gets pCurrentLine replout <- gets pReplout modify' $ \st -> st { pReplout = replout Seq.|> Line ln s } nextLine :: P () nextLine = modify' $ \st -> st { pCurrentLine = pCurrentLine st + 1 } stripPrompt :: String -> Maybe String stripPrompt s = case span isAlpha s of (_:_, '>':s') -> Just s' _ -> Nothing -- | The main function for our monad. Input is a single line. processLine :: String -> P () processLine s = do let s_nocomment = takeWhile (not . (== '%')) s s_nowhitespace = filter (not . isSpace) s_nocomment m <- gets pMode ln <- gets pCurrentLine case m of AwaitingReplMode | "\\begin{replinVerb}" `isInfixOf` s_nowhitespace -> do modify' $ \st -> st { pMode = ReplinMode } nextLine | "\\begin{reploutVerb}" `isInfixOf` s_nowhitespace -> do modify' $ \st -> st { pMode = ReploutMode } nextLine | "\\begin{replPrompt}" `isInfixOf` s_nowhitespace -> do modify' $ \st -> st { pMode = ReplPromptMode } nextLine | "\\restartrepl" `isInfixOf` s_nowhitespace -> do -- This is a command that acts as the barrier between discrete -- input/output pairs. When we see it, we commit the current pair, -- begin a brand new pair, and advance to the next line. addReplData nextLine | Just (InlineReplin, cmd, rst) <- inlineRepl s -> do addReplin cmd processLine rst | Just (InlineReplout, cmd, rst) <- inlineRepl s -> do addReplout cmd processLine rst | otherwise -> nextLine ReplinMode | "\\end{replinVerb}" `isInfixOf` s_nowhitespace -> do -- Switching from ingesting repl input to awaiting repl input. modify' $ \st -> st { pMode = AwaitingReplMode } nextLine | otherwise -> do -- Ingest the current line, and stay in ReplinMode. replin <- gets pReplin let replin' = replin Seq.|> Line ln s -- use the full input since % -- isn't a comment in verbatim -- mode. modify' $ \st -> st { pReplin = replin' } nextLine ReploutMode | "\\end{reploutVerb}" `isInfixOf` s_nowhitespace -> do -- Switching from ingesting repl output to awaiting repl output. modify' $ \st -> st { pMode = AwaitingReplMode } nextLine | otherwise -> do -- Ingest the current line, and stay in ReploutMode. replout <- gets pReplout let replout' = replout Seq.|> Line ln s -- use the full input since % -- isn't a comment in verbatim -- mode. modify' $ \st -> st { pReplout = replout' } nextLine ReplPromptMode | "\\end{replPrompt}" `isInfixOf` s_nowhitespace -> do -- Switching from ingesting repl input/output to awaiting repl -- input. modify' $ \st -> st { pMode = AwaitingReplMode } nextLine | Just input <- stripPrompt (trim s) -> do replin <- gets pReplin let input' = trim input replin' = replin Seq.|> Line ln input' -- use the full input since -- % isn't a comment in -- verbatim mode. modify $ \st -> st { pReplin = replin' } nextLine | otherwise -> do replout <- gets pReplout let replout' = replout Seq.|> Line ln s -- use the full input since % -- isn't a comment in verbatim -- mode. modify $ \st -> st { pReplout = replout' } nextLine main :: IO () main = do opts <- execParser p allLines <- lines <$> readFile (latexFile opts) let PState {..} = flip execState initPState $ do -- Process every line traverse_ processLine allLines -- Insert the final ReplData upon completion addReplData let allReplData = toList pCompletedReplData dir = fromMaybe "." (tempDir opts) forM_ allReplData $ \rd -> do let inText = unlines $ fmap (trim . lineText) $ toList $ rdReplin rd inFileNameTemplate = "in.icry" inFile <- writeTempFile dir inFileNameTemplate inText let exe = fromMaybe "./cry run" (cryptolExe opts) if Seq.null (rdReplout rd) then do let cryCmd = (P.shell (exe ++ " --interactive-batch " ++ inFile ++ " -e")) (cryEC, cryOut, cryErr) <- P.readCreateProcessWithExitCode cryCmd "" Line lnReplinStart _ Seq.:<| _ <- return $ rdReplin rd _ Seq.:|> Line lnReplinEnd _ <- return $ rdReplin rd case cryEC of ExitFailure _ -> do putStrLn $ "REPL error (replin lines " ++ show lnReplinStart ++ "-" ++ show lnReplinEnd ++ ")." putStr cryOut putStr cryErr exitFailure ExitSuccess -> do -- remove temporary input file removeFile inFile else do let outExpectedText = unlines $ filter (not . null) $ fmap (trim . lineText) $ toList $ rdReplout rd outExpectedFileNameTemplate = "out-expected.icry" outFileNameTemplate = "out.icry" cryCmd = (P.shell (exe ++ " --interactive-batch " ++ inFile)) outExpectedFile <- writeTempFile dir outExpectedFileNameTemplate outExpectedText outFile <- emptyTempFile dir outFileNameTemplate (_, cryOut, _) <- P.readCreateProcessWithExitCode cryCmd "" -- remove temporary input file removeFile inFile let outText = unlines $ filter (not . null) $ trim <$> (dropWhile ("Loading module" `isPrefixOf`) $ lines cryOut) writeFile outFile outText let diffCmd = (P.shell ("diff -u " ++ outExpectedFile ++ " " ++ outFile)) (diffEC, diffOut, _) <- P.readCreateProcessWithExitCode diffCmd "" case diffEC of ExitSuccess -> do -- Remove temporary output files removeFile outExpectedFile removeFile outFile ExitFailure _ -> do Line lnReplinStart _ Seq.:<| _ <- return $ rdReplin rd _ Seq.:|> Line lnReplinEnd _ <- return $ rdReplin rd Line lnReploutStart _ Seq.:<| _ <- return $ rdReplout rd _ Seq.:|> Line lnReploutEnd _ <- return $ rdReplout rd putStrLn $ "REPL output mismatch in " ++ latexFile opts putStrLn $ " (replin lines " ++ show lnReplinStart ++ "-" ++ show lnReplinEnd ++ ", replout lines " ++ show lnReploutStart ++ "-" ++ show lnReploutEnd ++ ")." putStrLn $ "Diff output:" putStr diffOut let outExpectedFileName = dir ++ "/" ++ outExpectedFileNameTemplate outFileName = dir ++ "/" ++ outFileNameTemplate putStrLn "" putStrLn $ "Expected output written to: " ++ outExpectedFileName putStrLn $ "Actual output written to: " ++ outFileName -- Write to log files writeFile outExpectedFileName outExpectedText writeFile outFileName outText -- Remove temporary output files and exit removeFile outExpectedFile removeFile outFile exitFailure putStrLn $ "Successfully checked " ++ show (length allReplData) ++ " repl examples in " ++ latexFile opts return () where p = info (optsParser <**> helper) ( fullDesc <> progDesc "Test the exercises in a cryptol LaTeX file" <> header "check-exercises -- test cryptol exercises" ) cryptol-3.0.0/cryptol/Main.hs0000644000000000000000000002451307346545000014320 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,parseSearchPath) 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 (displayVersion) import Control.Monad (when) 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, 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 :: ReplMode , optCallStacks :: Bool , optCommands :: [String] , optColorMode :: ColorMode , optCryptolrc :: Cryptolrc , optCryptolPathOnly :: Bool , optStopOnError :: Bool , optNoUnicodeLogo :: Bool } deriving (Show) defaultOptions :: Options defaultOptions = Options { optLoad = [] , optVersion = False , optHelp = False , optBatch = InteractiveRepl , optCallStacks = True , optCommands = [] , optColorMode = AutoColor , optCryptolrc = CryrcDefault , optCryptolPathOnly = False , optStopOnError = False , optNoUnicodeLogo = False } options :: [OptDescr (OptParser Options)] options = [ Option "b" ["batch"] (ReqArg setBatchScript "FILE") "run the script provided and exit" , Option "" ["interactive-batch"] (ReqArg setInteractiveBatchScript "FILE") "run the script provided and exit, but behave as if running an interactive session" , 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 "" ["no-call-stacks"] (NoArg setNoCallStacks) "Disable tracking of call stack information, which reduces interpreter overhead" , Option "" ["no-unicode-logo"] (NoArg setNoUnicodeLogo) "Don't use unicode characters in the REPL logo" , 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 = Batch path } -- | Set an interactive batch script setInteractiveBatchScript :: String -> OptParser Options setInteractiveBatchScript path = modify $ \ opts -> opts { optBatch = InteractiveBatch 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"] -- | Disable unicde characters in the REPL logo setNoUnicodeLogo :: OptParser Options setNoUnicodeLogo = modify $ \opts -> opts { optNoUnicodeLogo = True } -- | 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 } -- | Disable call stack tracking setNoCallStacks :: OptParser Options setNoCallStacks = modify $ \opts -> opts { optCallStacks = False } -- | 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 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" ] ) , ( "EDITOR" , [ "Sets the editor executable to use when opening an editor" , "via the `:edit` command" ] ) , ( "SBV_{ABC,BOOLECTOR,CVC4,CVC5,MATHSAT,YICES,Z3}_OPTIONS" , [ "A string of command-line arguments to be passed to the" , "corresponding solver invoked for `:sat` and `:prove`" , "when using a prover via SBV" ] ) ] 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 putStrLn | otherwise -> do (opts', mCleanup) <- setupCmdScript opts status <- repl (optCryptolrc opts') (optBatch opts') (optCallStacks 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 (optBatch opts /= InteractiveRepl) $ putStrLn "[warning] --command argument specified; ignoring batch file" return (opts { optBatch = InteractiveBatch path }, Just path) setupREPL :: Options -> REPL () setupREPL opts = do mCryptolPath <- io $ lookupEnv "CRYPTOLPATH" case mCryptolPath of Nothing -> return () Just path | optCryptolPathOnly opts -> setSearchPath (parseSearchPath path) | otherwise -> prependSearchPath (parseSearchPath path) 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 let useUnicode = not (optNoUnicodeLogo opts) displayLogo color useUnicode setUpdateREPLTitle (shouldSetREPLTitle >>= \b -> when b setREPLTitle) updateREPLTitle case optBatch opts of -- add the directory containing the batch file to the module search path Batch file -> prependSearchPath [ takeDirectory file ] _ -> return () 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-3.0.0/cryptol/OptParser.hs0000644000000000000000000000200007346545000015336 0ustar0000000000000000-- | -- Module : OptParser -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable module OptParser where 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-3.0.0/cryptol/REPL/0000755000000000000000000000000007346545000013635 5ustar0000000000000000cryptol-3.0.0/cryptol/REPL/Haskeline.hs0000644000000000000000000003007707346545000016103 0ustar0000000000000000-- | -- Module : REPL.Haskeline -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE CPP #-} {-# 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 hiding (()) 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 #if !MIN_VERSION_haskeline(0,8,0) import Control.Monad.Trans.Control #endif import Data.Char (isAlphaNum, isSpace) 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.Console.ANSI (setTitle, hSupportsANSI) import System.Console.Haskeline import System.Directory ( doesFileExist , getHomeDirectory , getCurrentDirectory) import System.FilePath (()) import System.IO (stdout) import Prelude () import Prelude.Compat data ReplMode = InteractiveRepl -- ^ Interactive terminal session | Batch FilePath -- ^ Execute from a batch file | InteractiveBatch FilePath -- ^ Execute from a batch file, but behave as though -- lines are entered in an interactive session. deriving (Show, Eq) -- | One REPL invocation, either from a file or from the terminal. crySession :: ReplMode -> Bool -> REPL CommandExitCode crySession replMode stopOnError = do settings <- io (setHistoryFile (replSettings isBatch)) let act = runInputTBehavior behavior settings (withInterrupt (loop 1)) if isBatch then asBatch act else act where (isBatch,behavior) = case replMode of InteractiveRepl -> (False, defaultBehavior) Batch path -> (True, useFile path) InteractiveBatch path -> (False, useFile path) loop :: Int -> InputT REPL CommandExitCode loop lineNum = do ln <- getInputLines =<< MTL.lift getPrompt case ln of NoMoreLines -> return CommandOk Interrupted | isBatch && stopOnError -> return CommandError | otherwise -> loop lineNum NextLine ls | all (all isSpace) ls -> loop (lineNum + length ls) | otherwise -> doCommand lineNum ls run lineNum cmd = case replMode of InteractiveRepl -> runCommand lineNum Nothing cmd InteractiveBatch _ -> runCommand lineNum Nothing cmd Batch path -> runCommand lineNum (Just path) cmd doCommand lineNum txt = case parseCommand findCommandExact (unlines txt) of Nothing | isBatch && stopOnError -> return CommandError | otherwise -> loop (lineNum + length txt) -- say somtething? Just cmd -> join $ MTL.lift $ do status <- handleInterrupt (handleCtrlC CommandError) (run lineNum cmd) case status of CommandError | isBatch && stopOnError -> return (return status) _ -> do goOn <- shouldContinue return (if goOn then loop (lineNum + length txt) 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 <- fmap (filter (/= '\r')) <$> 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 $ 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 (Batch file) True else check others loadMany [] = return CommandOk loadMany (f : fs) = do status <- crySession (Batch f) True case status of CommandOk -> loadMany fs _ -> return status -- | Haskeline-specific repl implementation. repl :: Cryptolrc -> ReplMode -> Bool -> Bool -> REPL () -> IO CommandExitCode repl cryrc replMode callStacks stopOnError begin = runREPL isBatch callStacks stdoutLogger replAction where -- this flag is used to suppress the logo and prompts isBatch = case replMode of InteractiveRepl -> False Batch _ -> True InteractiveBatch _ -> True replAction = do status <- loadCryRC cryrc case status of CommandOk -> begin >> crySession replMode 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` \(X.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 ------------------------------------------------------------------- #if !MIN_VERSION_haskeline(0,8,0) instance MonadException REPL where controlIO f = join $ liftBaseWith $ \f' -> f $ RunIO $ \m -> restoreM <$> (f' m) #endif -- 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-3.0.0/cryptol/REPL/Logo.hs0000644000000000000000000000407007346545000015072 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 import Prelude () import Prelude.Compat 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 ++ "\n" ++ "https://cryptol.net :? for help" ls = mk ver slen = length ls `div` 3 (ws,rest) = splitAt slen ls (vs,ds) = splitAt slen rest lineLen = length (head ls) displayLogo :: Bool -> Bool -> REPL () displayLogo useColor useUnicode = unlessBatch (io (mapM_ putStrLn (logo useColor (if useUnicode then logo2 else logo1)))) logo1 :: String -> [String] logo1 ver = [ " _ _" , " ___ _ __ _ _ _ __ | |_ ___ | |" , " / __| \'__| | | | \'_ \\| __/ _ \\| |" , " | (__| | | |_| | |_) | || (_) | |" , " \\___|_| \\__, | .__/ \\__\\___/|_|" , " |___/|_| " ++ ver ] logo2 :: String -> [String] logo2 ver = [ "┏━╸┏━┓╻ ╻┏━┓╺┳╸┏━┓╻ " , "┃ ┣┳┛┗┳┛┣━┛ ┃ ┃ ┃┃ " , "┗━╸╹┗╸ ╹ ╹ ╹ ┗━┛┗━╸" , ver ] cryptol-3.0.0/lib/0000755000000000000000000000000007346545000012145 5ustar0000000000000000cryptol-3.0.0/lib/Array.cry0000644000000000000000000000410507346545000013742 0ustar0000000000000000/* * Copyright (c) 2020 Galois, Inc. * Distributed under the terms of the BSD3 license (see LICENSE file) */ module Array where primitive type Array : * -> * -> * primitive arrayConstant : {a, b} b -> (Array a b) primitive arrayLookup : {a, b} (Array a b) -> a -> b primitive arrayUpdate : {a, b} (Array a b) -> a -> b -> (Array a b) primitive arrayEq : {n, a} (Array [n] a) -> (Array [n] a) -> Bool /** * Copy elements from the source array to the destination array. * * 'arrayCopy dest_arr dest_idx src_arr src_idx len' copies the * elements from 'src_arr' at indices '[src_idx ..< (src_idx + len)]' into * 'dest_arr' at indices '[dest_idx ..< (dest_idx + len)]'. * * The result is undefined if either 'dest_idx + len' or 'src_idx + len' * wraps around. */ primitive arrayCopy : {n, a} (Array [n] a) -> [n] -> (Array [n] a) -> [n] -> [n] -> (Array [n] a) /** * Set elements of the given array. * * 'arraySet' arr idx val len' sets the elements of 'arr' at indices * '[idx ..< (idx + len)]' to 'val'. * * The result is undefined if 'idx + len' wraps around. */ primitive arraySet : {n, a} (Array [n] a) -> [n] -> a -> [n] -> (Array [n] a) /** * Check whether the lhs array and rhs array are equal at a range of * indices. * * 'arrayRangeEq sym lhs_arr lhs_idx rhs_arr rhs_idx len' checks whether * the elements of 'lhs_arr' at indices '[lhs_idx ..< (lhs_idx + len)]' and * the elements of 'rhs_arr' at indices '[rhs_idx ..< (rhs_idx + len)]' are * equal. * * The result is undefined if either 'lhs_idx + len' or 'rhs_idx + len' * wraps around. */ primitive arrayRangeEqual : {n, a} (Array [n] a) -> [n] -> (Array [n] a) -> [n] -> [n] -> Bool arrayRangeLookup : {a, b, n} (Integral a, fin n, LiteralLessThan n a) => (Array a b) -> a -> [n]b arrayRangeLookup arr idx = res where res @ i = arrayLookup arr (idx + i) arrayRangeUpdate : {a, b, n} (Integral a, fin n, LiteralLessThan n a) => (Array a b) -> a -> [n]b -> (Array a b) arrayRangeUpdate arr idx vals = arrs ! 0 where arrs = [arr] # [ arrayUpdate acc (idx + i) val | acc <- arrs | i <- [0 ..< n] | val <- vals ] cryptol-3.0.0/lib/Cryptol.cry0000644000000000000000000010500407346545000014320 0ustar0000000000000000/* * Copyright (c) 2013-2020 Galois, Inc. * Distributed under the terms of the BSD3 license (see LICENSE file) */ module Cryptol where 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 @, @@, !, !! // Base types ----------------------------------------------------------------------- /** 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'. * * The values of 'Z n' may be thought of as equivalence * classes of integers according to the equivalence * 'x ~ y' iff 'n' divides 'x - y'. 'Z n' naturally * forms a ring, but does not support integral division * or indexing. * * However, you may use the 'fromZ' operation * to project values in 'Z n' into the integers if such operations * are required. This will compute the reduced representative * of the equivalence class. In other words, 'fromZ' computes * the (unique) integer value 'i' where '0 <= i < n' and * 'i' is in the given equivalence class. * * If the modulus 'n' is prime, 'Z n' also * supports computing inverses and forms a field. */ primitive type {n : #} (fin n, n >= 1) => Z n : * /** * 'Rational' is the type of rational numbers. * Rational numbers form a Field (and thus a Ring). * * The 'ratio' operation may be used to directly create * rational values from as a ratio of integers, or * the 'fromInteger' method and the field operations * can be used. */ primitive type Rational : * type Bool = Bit type Word n = [n] type Char = [8] type String n = [n]Char // Numeric operators and constraints ---------------------------------------------- /** A numeric type representing infinity. */ primitive type inf : # /** 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 /** Assert that a numeric type is a prime number. */ primitive type prime : # -> Prop /** Add numeric types. */ primitive type (+) : # -> # -> # /** Multiply numeric types. */ primitive type (*) : # -> # -> # /** Subtract numeric types. */ primitive type {m : #, n : # } (fin n, m >= n) => m - n : # /** 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 ceiling of the base-2 logarithm of a numeric type. * We define 'lg2 n = width (n - 1)' for nonzero n, and 'lg2 0 = 0'. */ type lg2 n = width (max n 1 - 1) /** 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 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 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 // The Literal class ---------------------------------------------------- /** 'Literal n a' asserts that type 'a' contains the number 'n'. */ primitive type Literal : # -> * -> Prop /** * 'LiteralLessThan n a' asserts that the type 'a' contains all the * natural numbers strictly below 'n'. Note that we may have 'n = inf', * in which case the type 'a' must be unbounded. */ primitive type LiteralLessThan : # -> * -> Prop /** * 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} /** * 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 /** * A finite sequence counting up from 'first' to 'last'. * * '[x .. y]' is syntactic sugar for 'fromTo`{first=x,last=y}'. */ primitive fromTo : {first, last, a} (fin last, last >= first, Literal last a) => [1 + (last - first)]a /** * A possibly infinite sequence counting up from 'first' up to (but not including) 'bound'. * * '[ x ..< y ]' is syntactic sugar for 'fromToLessThan`{first=x,bound=y}'. * * Note that if 'first' = 'bound' then the sequence will be empty. If 'bound = inf' * then the sequence will be infinite, and will eventually wrap around for bounded types. */ primitive fromToLessThan : {first, bound, a} (fin first, bound >= first, LiteralLessThan bound a) => [bound - first]a /** * A finite sequence counting up from 'first' to 'last' by 'stride'. * Note that 'last' will only be an element of the enumeration if * 'stride' divides 'last - first' evenly. * * '[x .. y by n]' is syntactic sugar for 'fromToBy`{first=x,last=y,stride=n}'. */ primitive fromToBy : {first, last, stride, a} (fin last, fin stride, stride >= 1, last >= first, Literal last a) => [1 + (last - first)/stride]a /** * A finite sequence counting from 'first' up to (but not including) 'bound' * by 'stride'. Note that if 'first = bound' then the sequence will * be empty. If 'bound = inf' then the sequence will be infinite, and will * eventually wrap around for bounded types. * * '[x ..< y by n]' is syntactic sugar for 'fromToByLessThan`{first=x,bound=y,stride=n}'. */ primitive fromToByLessThan : {first, bound, stride, a} (fin first, fin stride, stride >= 1, bound >= first, LiteralLessThan bound a) => [(bound - first)/^stride]a /** * A finite sequence counting from 'first' down to 'last' by 'stride'. * Note that 'last' will only be an element of the enumeration if * 'stride' divides 'first - last' evenly. * * '[x .. y down by n]' is syntactic sugar for 'fromToDownBy`{first=x,last=y,stride=n}'. */ primitive fromToDownBy : {first, last, stride, a} (fin first, fin stride, stride >= 1, first >= last, Literal first a) => [1 + (first - last)/stride]a /** * A finite sequence counting from 'first' down to (but not including) * 'bound' by 'stride'. * * '[x ..> y down by n]' is syntactic sugar for * 'fromToDownByGreaterThan`{first=x,bound=y,stride=n}'. * * Note that if 'first = bound' the sequence will be empty. */ primitive fromToDownByGreaterThan : {first, bound, stride, a} (fin first, fin stride, stride >= 1, first >= bound, Literal first a) => [(first - bound)/^stride]a /** * A finite arithmetic sequence starting with 'first' and 'next', * stopping when the values reach or would skip over 'last'. * * '[x,y..z]' is syntactic sugar for 'fromThenTo`{first=x,next=y,last=z}'. */ 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 // Fractional Literals --------------------- /** 'FLiteral m n r a' asserts that the type 'a' contains the fraction 'm/n'. The flag 'r' indicates if we should round ('r >= 1') or report an error if the number can't be represented exactly. */ primitive type FLiteral : # -> # -> # -> * -> Prop /** A fractional literal corresponding to 'm/n' */ primitive fraction : { m, n, r, a } FLiteral m n r a => a // The Zero class ------------------------------------------------------- /** Value types that have a notion of 'zero'. */ primitive type Zero : * -> Prop /** * 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 // The Logic class ------------------------------------------------------ /** Value types that support logical operations. */ primitive type Logic : * -> Prop /** * 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 /** * Bitwise complement. The prefix notation '~ x' * is syntactic sugar for 'complement x'. */ primitive complement : {a} (Logic a) => a -> a // The Ring class ------------------------------------------------------- /** * Value types that support ring addition and multiplication. * * Floating-point values are only approximately a ring, but * nonetheless inhabit this class. */ primitive type Ring : * -> Prop /** * Converts an unbounded integer to a value in a Ring using the following rules: * * to bitvector type [n]: * the value is reduced modulo 2^^n, * * to Z n: * the value is reduced modulo n, * * floating point types: * the value is rounded to the nearest representable value, * * sequences other than bitvectors: * elements are computed by using `fromInteger` pointwise * Example: (fromInteger 2 : [3][8]) === [ 0x02, 0x02, 0x02 ] * * tuples and records: * elements are computed by using `fromInteger` pointwise * Example: (fromInteger 2 : (Integer,[3][8])) === (2, [ 0x2, 0x2, 0x2 ]) * * functions: * a constant function returning `fromInteger` on the result type */ primitive fromInteger : {a} (Ring a) => Integer -> a /** * Add two values. * * For type [n], addition is modulo 2^^n. * * Structured values are added element-wise. */ primitive (+) : {a} (Ring 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} (Ring a) => a -> a -> a /** * Multiply two values. * * For type [n], multiplication is modulo 2^^n. * * Structured values are multiplied element-wise. */ primitive (*) : {a} (Ring a) => a -> a -> a /** * Returns the additive inverse of its argument. * Over structured values, operates element-wise. * The prefix notation '- x' is syntactic sugar * for 'negate x'. * * Satisfies 'a + negate a = 0'. * Satisfies 'negate a = ~a + 1' for bitvector values. */ primitive negate : {a} (Ring a) => a -> a // The Integral class ------------------------------------------------- /** * Value types that correspond to a segment of the * integers. These types support integer division and * modulus, indexing into sequences, and enumeration. */ primitive type Integral : * -> Prop /** * Divide two values, rounding down (toward negative infinity). * * For type [n], the arguments are treated as unsigned. * * Division by zero is undefined. */ primitive (/) : {a} (Integral a) => a -> a -> a /** * Compute the remainder from dividing two values. * * For type [n], the arguments are treated as unsigned. * * Remainder of division by zero is undefined. * * Satisfies 'x % y == x - (x / y) * y'. */ primitive (%) : {a} (Integral a) => a -> a -> a /** * Converts a value of an integral type to an integer. */ primitive toInteger : {a} (Integral a) => a -> Integer /** * Compute the exponentiation of a value in a ring. * * For type [n], the exponent is treated as unsigned. * * It is an error to raise a value to a negative integer exponent. * * Satisfies: 'x ^^ 0 == fromInteger 1' * * Satisfies: 'x ^^ e == x * x ^^ (e-1)' when 'e > 0'. */ primitive (^^) : {a, e} (Ring a, Integral e) => a -> e -> a /** * An infinite sequence counting up from the given starting value. * '[x...]' is syntactic sugar for 'infFrom x'. */ primitive infFrom : {a} (Integral 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} (Integral a) => a -> a -> [inf]a // The Field class ------------------------------------------------- /** * Value types that correspond to a field; that is, * a ring also possessing multiplicative inverses for * non-zero elements. * * Floating-point values are only approximately a field, * but nonetheless inhabit this class. */ primitive type Field : * -> Prop /** * Reciprocal * * Compute the multiplicative inverse of an element of a field. * The reciprocal of 0 is undefined. */ primitive recip : {a} (Field a) => a -> a /** * Field division * * The division operation in a field. * Satisfies 'x /. y == x * (recip y)' * * Field division by 0 is undefined. */ primitive (/.) : {a} (Field a) => a -> a -> a // The Round class ------------------------------------------------- /** Value types that can be rounded to integer values. */ primitive type Round : * -> Prop /** * Ceiling function. * * Given 'x', compute the smallest integer 'i' * such that 'x <= i'. */ primitive ceiling : {a} (Round a) => a -> Integer /** * Floor function. * * Given 'x', compute the largest integer 'i' * such that 'i <= x'. */ primitive floor : {a} (Round a) => a -> Integer /** * Truncate the value toward 0. * * Given 'x' compute the nearest integer between * 'x' and 0. For nonnegative 'x', this is floor, * and for negative 'x' this is ceiling. */ primitive trunc : {a} (Round a) => a -> Integer /** * Round to the nearest integer, ties away from 0. * * Ties are broken away from 0. For nonnegative 'x' * this is 'floor (x + 0.5)'. For negative 'x' this * is 'ceiling (x - 0.5)'. */ primitive roundAway : {a} (Round a) => a -> Integer /** * Round to the nearest integer, ties to even. * * Ties are broken to the nearest even integer. */ primitive roundToEven : {a} (Round a) => a -> Integer // The Eq class ---------------------------------------------------- /** Value types that support equality comparisons. */ primitive type Eq : * -> Prop /** * Compares any two values of the same type for equality. */ primitive (==) : {a} (Eq a) => a -> a -> Bit /** * Compares any two values of the same type for inequality. */ primitive (!=) : {a} (Eq a) => a -> a -> Bit /** * Compare the outputs of two functions for equality. */ (===) : {a, b} (Eq b) => (a -> b) -> (a -> b) -> (a -> Bit) f === g = \ x -> f x == g x /** * Compare the outputs of two functions for inequality. */ (!==) : {a, b} (Eq b) => (a -> b) -> (a -> b) -> (a -> Bit) f !== g = \x -> f x != g x // The Cmp class --------------------------------------------------- /** Value types that support equality and ordering comparisons. */ primitive type Cmp : * -> Prop /** * 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 /** * 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 /** * Compute the absolute value of a value from an ordered ring. * Bitvector values are considered unsigned, so this is * the identity function on [n]. */ abs : {a} (Cmp a, Ring a) => a -> a abs x = if x < fromInteger 0 then negate x else x // The SignedCmp class ---------------------------------------------- /** Value types that support signed comparisons. */ primitive type SignedCmp : * -> Prop /** * 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) // Bit specific operations ---------------------------------------- /** * The constant True. Corresponds to the bit value 1. */ primitive True : Bit /** * The constant False. Corresponds to the bit value 0. */ primitive False : Bit /** * 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 // Bitvector specific operations ---------------------------------- /** * 2's complement signed division. Division rounds toward 0. * Division by 0 is undefined. * * * Satisfies 'x == x %$ y + (x /$ y) * y' for 'y != 0'. */ primitive (/$) : {n} (fin n, n >= 1) => [n] -> [n] -> [n] /** * 2's complement signed remainder. Division rounds toward 0. * Division by 0 is undefined. Satisfies the following for 'y != 0' * * * 'x %$ y == x - (x /$ y) * y'. * * 'x >=$ 0 ==> x %$ y >=$ 0' * * 'x <=$ 0 ==> x %$ y <=$ 0' */ primitive (%$) : {n} (fin n, n >= 1) => [n] -> [n] -> [n] /** * Unsigned carry. Returns true if the unsigned addition of the given * bitvector arguments would result in an unsigned overflow. */ carry : {n} (fin n) => [n] -> [n] -> Bit carry x y = (x + y) < x /** * Signed carry. Returns true if the 2's complement signed addition of the * given bitvector arguments would result in a signed overflow. */ scarry : {n} (fin n, n >= 1) => [n] -> [n] -> Bit scarry x y = (sx == sy) && (sx != sz) where z = x + y sx = x@0 sy = y@0 sz = z@0 /** * 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 /** * 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, Integral ix) => [n] -> ix -> [n] /** * The ceiling of the base-2 logarithm of an unsigned bitvector. * We set 'lg2 0 = 0'. */ primitive lg2 : {n} (fin n) => [n] -> [n] /** * Convert a signed 2's complement bitvector to an integer. */ primitive toSignedInteger : {n} (fin n, n >= 1) => [n] -> Integer // Rational specific operations ---------------------------------------------- /** * Compute the ratio of two integers as a rational. * Ratio is undefined if the denominator is 0. * * 'ratio x y = (fromInteger x /. fromInteger y) : Rational' */ primitive ratio : Integer -> Integer -> Rational // Zn specific operations ---------------------------------------------------- /** * 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 // Sequence operations ------------------------------------------------------- /** * 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'. */ splitAt : {front, back, a} (fin front) => [front + back]a -> ([front]a, [back]a) splitAt xs = (take`{front,back} xs, drop`{front,back} xs) /** * 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 /** * Select the first (left-most) 'front' elements of a sequence. */ primitive take : {front, back, a} [front + back]a -> [front]a /** * Select all the elements after (to the right of) the 'front' elements of a sequence. */ primitive drop : {front, back, a} (fin front) => [front + back]a -> [back]a /** * Drop the first (left-most) element of a sequence. */ tail : {n, a} [1 + n]a -> [n]a tail xs = drop`{1} xs /** * Return the first (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 /** * Same as 'split', but with a different type argument order. * Take a sequence of elements and break it into 'parts' sequences * of 'each' elements. */ groupBy : {each, parts, a} (fin each) => [parts * each]a -> [parts][each]a groupBy = split`{parts=parts} /** * Left shift. The first argument is the sequence to shift, the second is the * number of positions to shift by. */ primitive (<<) : {n, ix, a} (Integral 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} (Integral 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, Integral 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, Integral ix) => [n]a -> ix -> [n]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} (Integral 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} (Integral 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, Integral 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, Integral 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} (Integral 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, Integral 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} (Integral ix, fin k) => [n]a -> [k]ix -> [k]a -> [n]a updates xs0 idxs vals = foldl upd xs0 (zip idxs vals) where upd xs (i,b) = update xs i b /** * 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, Integral ix, fin k) => [n]a -> [k]ix -> [k]a -> [n]a updatesEnd xs0 idxs vals = foldl upd xs0 (zip idxs vals) where upd xs (i,b) = updateEnd xs i b /** * 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, a, ix} (Integral ix, LiteralLessThan n ix) => (ix -> a) -> [n]a generate f = [ f i | i <- [0 .. [n]a -> [n]a sort = sortBy (<=) /** * Sort a sequence according to the given less-than-or-equal relation. * The sorting is stable, so it preserves the relative position of any * pair of elements that are equivalent according to the order relation. */ sortBy : {a, n} (fin n) => (a -> a -> Bit) -> [n]a -> [n]a sortBy le ((xs : [n/2]a) # (ys : [n/^2]a)) = take zs.0 where xs' = if `(n/2) == 1 then xs else sortBy le xs ys' = if `(n/^2) == 1 then ys else sortBy le ys zs = [ if i == `(n/2) then (ys'@j, i , j+1) | j == `(n/^2) then (xs'@i, i+1, j ) | le (xs'@i) (ys'@j) then (xs'@i, i+1, j ) else (ys'@j, i , j+1) | (_, i, j) <- [ (undefined, 0, 0) ] # zs ] // GF_2^n polynomial computations ------------------------------------------- /** * Performs multiplication of polynomials over GF(2). */ primitive pmult : {u, v} (fin u, fin v) => [1 + u] -> [1 + v] -> [1 + u + v] /** * Performs division of polynomials over GF(2). */ primitive pdiv : {u, v} (fin u, fin v) => [u] -> [v] -> [u] /** * Performs modulus of polynomials over GF(2). */ primitive pmod : {u, v} (fin u, fin v) => [u] -> [1 + v] -> [v] // Experimental primitives ------------------------------------------------------------ /** * Parallel map. The given function is applied to each element in the * given finite sequence, and the results are computed in parallel. * The values in the resulting sequence are reduced to normal form, * as is done with the deepseq operation. * * The Eq constraint restricts this operation to types * where reduction to normal form makes sense. * * This function is experimental. */ primitive parmap : {a, b, n} (Eq b, fin n) => (a -> b) -> [n]a -> [n]b // Utility operations ----------------------------------------------------------------- /** * A strictness-increasing operation. The first operand * is reduced to normal form before evaluating the second * argument. * * The Eq constraint restricts this operation to types * where reduction to normal form makes sense. */ primitive deepseq : {a, b} Eq a => a -> b -> b /** * Reduce to normal form. * * The Eq constraint restricts this operation to types * where reduction to normal form makes sense. */ rnf : {a} Eq a => a -> a rnf x = deepseq x x /** * Raise a run-time error with the given message. * This function can be called at any type. */ primitive error : {a, n} (fin n) => String n -> a /** * Raise a run-time error with a generic message. * This function can be called at any type. */ undefined : {a} a undefined = error "undefined" /** * Assert that the given condition holds, and raise an error * with the given message if it does not. If the condition * holds, return the third argument unchanged. */ assert : {a, n} (fin n) => Bit -> String n -> a -> a assert pred msg x = if pred then x else error msg /** * Generates random values from a seed. When called with a function, currently * generates a function that always returns zero. */ primitive random : {a} [256] -> a /** * 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) => String n -> 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) => String n -> 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 = foldl' (/\) True (map f xs) /** * Disjunction after applying a predicate to all elements. */ any : {n, a} (fin n) => (a -> Bit) -> [n]a -> Bit any f xs = foldl' (\/) False (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 */ primitive foldl : {n, a, b} (fin n) => (a -> b -> a) -> a -> [n]b -> a /** * Functional left fold, with strict evaluation of the accumulator value. * The accumulator is reduced to normal form at each step. The Eq constraint * restricts the accumulator to types where reduction to normal form makes sense. * * foldl' (+) 0 [1,2,3] = ((0 + 1) + 2) + 3 */ primitive foldl' : {n, a, b} (fin n, Eq a) => (a -> b -> a) -> a -> [n]b -> a /** * 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 = foldl g acc (reverse xs) where g b a = f a b /** * Functional right fold, with strict evaluation of the accumulator value. * The accumulator is reduced to weak head normal form at each step. * * foldr' (-) 0 [1,2,3] = 0 - (1 - (2 - 3)) */ foldr' : {n, a, b} (fin n, Eq b) => (a -> b -> b) -> b -> [n]a -> b foldr' f acc xs = foldl' g acc (reverse xs) where g b a = f a b /** * Compute the sum of the values in the sequence. */ sum : {n, a} (fin n, Eq a, Ring a) => [n]a -> a sum xs = foldl' (+) (fromInteger 0) xs /** * Compute the product of the values in the sequence. */ product : {n, a} (fin n, Eq a, Ring a) => [n]a -> a product xs = foldl' (*) (fromInteger 1) xs /** * Scan left is like a foldl that also emits the intermediate values. */ primitive scanl : {n, a, b} (a -> b -> a) -> a -> [n]b -> [1+n]a /** * Scan right is like a foldr that also emits the intermediate values. */ scanr : {n, a, b} (fin n) => (a -> b -> b) -> b -> [n]a -> [1+n]b scanr f acc xs = reverse (scanl (\a b -> f b a) acc (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, Eq 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 z = scanl (\x _ -> f x) z (zero:[inf]()) cryptol-3.0.0/lib/Cryptol/0000755000000000000000000000000007346545000013601 5ustar0000000000000000cryptol-3.0.0/lib/Cryptol/Reference.cry0000644000000000000000000000402107346545000016213 0ustar0000000000000000module Cryptol::Reference where /** * Performs multiplication of polynomials over GF(2). * Reference implementation. */ 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). * Reference implementation. */ 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). * Reference implementation. */ 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 ] /** * Functional left fold. * * foldl (+) 0 [1,2,3] = ((0 + 1) + 2) + 3 * * Reference implementation. */ foldl : {n, a, b} (fin n) => (a -> b -> a) -> a -> [n]b -> a foldl f z bs = last (scanl f z bs) /** * Scan left is like a foldl that also emits the intermediate values. * * Reference implementation. */ scanl : {n, a, b} (a -> b -> a) -> a -> [n]b -> [1+n]a scanl f z bs = as where as = [z] # [ f a b | a <- as | b <- bs ] /** * Map a function iteratively over a seed value, producing an infinite * list of successive function applications. * * Reference implementation. */ iterate : {a} (a -> a) -> a -> [inf]a iterate f z = xs where xs = [z] # [ f x | x <- xs ] cryptol-3.0.0/lib/CryptolTC.z30000644000000000000000000002060207346545000014306 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) (assert (forall ((x Int) (y Int)) (=> (and (> y 0) (> x 0)) (>= (cryExpUnknown x y) x)))) (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 y))) cryErr (ite (= (value y) 0) cryErr (ite (not (isFin x)) cryInf (cryNat (- (div (- (value x)) (value y)))) ))) ) (define-fun cryCeilMod ((x InfNat) (y InfNat)) InfNat (ite (or (isErr x) (isErr y) (not (isFin y))) cryErr (ite (= (value y) 0) cryErr (ite (not (isFin x)) (cryNat 0) (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-3.0.0/lib/Float.cry0000644000000000000000000001476707346545000013750 0ustar0000000000000000module Float where primitive type ValidFloat : # -> # -> Prop /** IEEE-754 floating point numbers. */ primitive type { exponent : #, precision : #} ValidFloat exponent precision => Float exponent precision : * /** An abbreviation for common 16-bit floating point numbers. */ type Float16 = Float 5 11 /** An abbreviation for common 32-bit floating point numbers. */ type Float32 = Float 8 24 /** An abbreviation for common 64-bit floating point numbers. */ type Float64 = Float 11 53 /** An abbreviation for common 128-bit floating point numbers. */ type Float128 = Float 15 113 /** An abbreviation for common 256-bit floating point numbers. */ type Float256 = Float 19 237 /* ---------------------------------------------------------------------- * Rounding modes (this should be an enumeration type, when we add these) *---------------------------------------------------------------------- */ /** * A 'RoundingMode' is used to specify the precise behavior of some * floating point primitives. * * There are five valid 'RoundingMode' values: * * roundNearestEven * * roundNearestAway * * roundPositive * * roundNegative * * roundZero */ type RoundingMode = [3] /** Round toward nearest, ties go to even. */ roundNearestEven, rne : RoundingMode roundNearestEven = 0 rne = roundNearestEven /** Round toward nearest, ties away from zero. */ roundNearestAway, rna : RoundingMode roundNearestAway = 1 rna = roundNearestAway /** Round toward positive infinity. */ roundPositive, rtp : RoundingMode roundPositive = 2 rtp = roundPositive /** Round toward negative infinity. */ roundNegative, rtn : RoundingMode roundNegative = 3 rtn = roundNegative /** Round toward zero. */ roundZero, rtz : RoundingMode roundZero = 4 rtz = roundZero /* ---------------------------------------------------------------------- * Constants * ---------------------------------------------------------------------- */ /** Not a number. */ primitive fpNaN : {e,p} ValidFloat e p => Float e p /** Positive infinity. */ primitive fpPosInf : {e,p} ValidFloat e p => Float e p /** Negative infinity. */ fpNegInf : {e,p} ValidFloat e p => Float e p fpNegInf = - fpPosInf /** Positive zero. */ fpPosZero : {e,p} ValidFloat e p => Float e p fpPosZero = zero /** Negative zero. */ fpNegZero : {e,p} ValidFloat e p => Float e p fpNegZero = - fpPosZero // Binary representations /** A floating point number using the exact bit pattern, in IEEE interchange format with layout: (sign : [1]) # (biased_exponent : [e]) # (significand : [p-1]) */ primitive fpFromBits : {e,p} ValidFloat e p => [e + p] -> Float e p /** Export a floating point number in IEEE interchange format with layout: (sign : [1]) # (biased_exponent : [e]) # (significand : [p-1]) NaN is represented as: * positive: sign == 0 * quiet with no info: significand == 0b1 # 0 */ primitive fpToBits : {e,p} ValidFloat e p => Float e p -> [e + p] /* ---------------------------------------------------------------------- * Predicates * ---------------------------------------------------------------------- */ // Operations in `Cmp` use IEEE reasoning. /** Check if two floating point numbers are representationally the same. In particular, the following hold: * NaN =.= NaN * ~ (pfNegZero =.= fpPosZero) */ primitive (=.=) : {e,p} ValidFloat e p => Float e p -> Float e p -> Bool infix 20 =.= /** Test if this value is not-a-number (NaN). */ primitive fpIsNaN : {e,p} ValidFloat e p => Float e p -> Bool /** Test if this value is positive or negative infinity. */ primitive fpIsInf : {e,p} ValidFloat e p => Float e p -> Bool /** Test if this value is positive or negative zero. */ primitive fpIsZero : {e,p} ValidFloat e p => Float e p -> Bool /** Test if this value is negative. */ primitive fpIsNeg : {e,p} ValidFloat e p => Float e p -> Bool /** Test if this value is normal (not NaN, not infinite, not zero, and not subnormal). */ primitive fpIsNormal : {e,p} ValidFloat e p => Float e p -> Bool /** * Test if this value is subnormal. Subnormal values are nonzero * values with magnitudes smaller than can be represented with the * normal implicit leading bit convention. */ primitive fpIsSubnormal : {e,p} ValidFloat e p => Float e p -> Bool /* Returns true for numbers that are not an infinity or NaN. */ fpIsFinite : {e,p} ValidFloat e p => Float e p -> Bool fpIsFinite f = ~ (fpIsNaN f \/ fpIsInf f ) /* ---------------------------------------------------------------------- * Arithmetic * ---------------------------------------------------------------------- */ /** Add floating point numbers using the given rounding mode. */ primitive fpAdd : {e,p} ValidFloat e p => RoundingMode -> Float e p -> Float e p -> Float e p /** Subtract floating point numbers using the given rounding mode. */ primitive fpSub : {e,p} ValidFloat e p => RoundingMode -> Float e p -> Float e p -> Float e p /** Multiply floating point numbers using the given rounding mode. */ primitive fpMul : {e,p} ValidFloat e p => RoundingMode -> Float e p -> Float e p -> Float e p /** Divide floating point numbers using the given rounding mode. */ primitive fpDiv : {e,p} ValidFloat e p => RoundingMode -> Float e p -> Float e p -> Float e p /** * Fused-multiply-add. 'fpFMA r x y z' computes the value '(x*y)+z', * rounding the result according to mode 'r' only after performing both * operations. */ primitive fpFMA : {e,p} ValidFloat e p => RoundingMode -> Float e p -> Float e p -> Float e p -> Float e p /** * Absolute value of a floating-point value. */ primitive fpAbs : {e,p} ValidFloat e p => Float e p -> Float e p /** * Square root of a floating-point value. The square root of * a negative value yiels NaN, except that the sqaure root of * '-0.0' is '-0.0'. */ primitive fpSqrt : {e,p} ValidFloat e p => RoundingMode -> Float e p -> Float e p /* ------------------------------------------------------------ * * Rationals * * ------------------------------------------------------------ */ /** Convert a floating point number to a rational. It is an error to use this with infinity or NaN **/ primitive fpToRational : {e,p} ValidFloat e p => Float e p -> Rational /** Convert a rational to a floating point number, using the given rounding mode, if the number cannot be represented exactly. */ primitive fpFromRational : {e,p} ValidFloat e p => RoundingMode -> Rational -> Float e p cryptol-3.0.0/lib/PrimeEC.cry0000644000000000000000000001302207346545000014146 0ustar0000000000000000module PrimeEC where /** * The type of points of an elliptic curve in affine coordinates. * The coefficients are taken from the prime field 'Z p' with 'p > 3'. * This is intended to represent all the "normal" points * on the curve, which satisfy 'x^^3 == y^^2 - 3x + b', * for some curve parameter 'b'. This type cannot represent * the special projective "point at infinity". */ type AffinePoint p = { x : Z p , y : Z p } /** * The type of points of an elliptic curve in (homogeneous) * projective coordinates. The coefficients are taken from the * prime field 'Z p' with 'p > 3'. These points should be understood as * representatives of equivalence classes of points, where two representatives * 'S' and 'T' are equivalent iff one is a scalar multiple of the other. That * is, 'S' and 'T' are equivalent iff there exists some 'k' where * 'S.x == k*T.x /\ S.y == k*T.y /\ S.z == k*T.z'. Finally, the * vector with all coordinates equal to 0 is excluded and does not * represent any point. * * Note that all the affine points are easily embedded into projective * coordinates by simply setting the `z` coordinate to 1, and the "point at * infinity" is represented by any point with 'z == 0'. Further, for any * projective point with 'z != 0', we can compute the corresponding affine * point by simply multiplying the x and y coordinates by the inverse of z. */ type ProjectivePoint p = { x : Z p , y : Z p , z : Z p } /** * 'ec_is_point_affine b S' checks that the supposed affine elliptic curve * point 'S' in fact lies on the curve defined by the curve parameter 'b'. Here, * and throughout this module, we assume the curve parameter 'a' is equal to * '-3'. Precisely, this function checks the following condition: * * S.y^^2 == S.x^^3 - 3*S.x + b */ ec_is_point_affine : {p} (prime p, p > 3) => Z p -> AffinePoint p -> Bit ec_is_point_affine b S = S.y^^2 == S.x^^3 - (3*S.x) + b /** * 'ec_is_nonsingular' checks that the given curve parameter 'b' gives rise to * a non-singular elliptic curve, appropriate for use in ECC. * * Precisely, this checks that '4*a^^3 + 27*b^^2 != 0 mod p'. Here, and * throughout this module, we assume 'a = -3'. */ ec_is_nonsingular : {p} (prime p, p > 3) => Z p -> Bit ec_is_nonsingular b = (fromInteger 4) * a^^3 + (fromInteger 27) * b^^2 != 0 where a = -3 : Z p /** * Returns true if the given point is the identity "point at infinity." * This is true whenever the 'z' coordinate is 0, but one of the 'x' or * 'y' coordinates is nonzero. */ ec_is_identity : {p} (prime p, p > 3) => ProjectivePoint p -> Bit ec_is_identity S = S.z == 0 /\ ~(S.x == 0 /\ S.y == 0) /** * Test two projective points for equality, up to the equivalence relation * on projective points. */ ec_equal : {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p -> Bit ec_equal S T = (S.z == 0 /\ T.z == 0) \/ (S.z != 0 /\ T.z != 0 /\ ec_affinify S == ec_affinify T) /** * Compute a projective representative for the given affine point. */ ec_projectify : {p} (prime p, p > 3) => AffinePoint p -> ProjectivePoint p ec_projectify R = { x = R.x, y = R.y, z = 1 } /** * Compute the affine point corresponding to the given projective point. * This results in an error if the 'z' component of the given point is 0, * in which case there is no corresponding affine point. */ ec_affinify : {p} (prime p, p > 3) => ProjectivePoint p -> AffinePoint p ec_affinify S = if S.z == 0 then error "Cannot affinify the point at infinity" else R where R = {x = lambda^^2 * S.x, y = lambda^^3 * S.y } lambda = recip S.z /** * Coerce an integer modulo 'p' to a bitvector. This will reduce the value * modulo '2^^a' if necessary. */ ZtoBV : {p, a} (fin p, p >= 1, fin a) => Z p -> [a] ZtoBV x = fromInteger (fromZ x) /** * Coerce a bitvector value to an integer modulo 'p'. This will * reduce the value modulo 'p' if necessary. */ BVtoZ : {p, a} (fin p, p >= 1, fin a) => [a] -> Z p BVtoZ x = fromInteger (toInteger x) /** * Given a projective point 'S', compute '2S = S+S'. */ primitive ec_double : {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p /** * Given two projective points 'S' and 'T' where neither is the identity, * compute 'S+T'. If the points are not known to be distinct from the point * at infinity, use 'ec_add' instead. */ primitive ec_add_nonzero : {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p -> ProjectivePoint p /** * Given a projective point 'S', compute its negation, '-S' */ ec_negate : {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p ec_negate S = { x = S.x, y = -S.y, z = S.z } /** * Given two projective points 'S' and 'T' compute 'S+T'. */ ec_add : {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p -> ProjectivePoint p ec_add S T = if S.z == 0 then T | T.z == 0 then S else R where R = ec_add_nonzero S T /** * Given two projective points 'S' and 'T' compute 'S-T'. */ ec_sub : {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p -> ProjectivePoint p ec_sub S T = ec_add S U where U = { x = T.x, y = -T.y, z = T.z } /** * Given a scalar value 'k' and a projective point 'S', compute the * scalar multiplication 'kS'. */ primitive ec_mult : {p} (prime p, p > 3) => Z p -> ProjectivePoint p -> ProjectivePoint p /** * Given a scalar value 'j' and a projective point 'S', and another scalar * value 'k' and point 'T', compute the "twin" scalar multiplication 'jS + kT'. */ primitive ec_twin_mult : {p} (prime p, p > 3) => Z p -> ProjectivePoint p -> Z p -> ProjectivePoint p -> ProjectivePoint p cryptol-3.0.0/lib/SuiteB.cry0000644000000000000000000001671507346545000014071 0ustar0000000000000000module SuiteB where /***** AES ******/ /** * Key schedule parameter setting for AES-128 */ type AES128 = 4 /** * Key schedule parameter setting for AES-192 */ type AES192 = 6 /** * Key schedule parameter setting for AES-256 */ type AES256 = 8 /** * Element of an AES key schedule for use in a particular round */ type AESRoundKey = [4][32] /** * Expanded encryption key schedule for AES */ type AESEncryptKeySchedule k = { aesEncInitialKey : AESRoundKey , aesEncRoundKeys : [k+5]AESRoundKey , aesEncFinalKey : AESRoundKey } /** * Expanded decryption key schedule for AES */ type AESDecryptKeySchedule k = { aesDecInitialKey : AESRoundKey , aesDecRoundKeys : [k+5]AESRoundKey , aesDecFinalKey : AESRoundKey } /** * Encryption key expansion for AES-128. * See FIPS 197, section 5.2. */ aes128EncryptSchedule : [128] -> AESEncryptKeySchedule AES128 aes128EncryptSchedule = aesExpandEncryptSchedule /** * Decryption key expansion for AES-128, for use in the "equivalent inverse cypher". * See FIPS 197, sections 5.2 and 5.3.5. */ aes128DecryptSchedule : [128] -> AESDecryptKeySchedule AES128 aes128DecryptSchedule = aesExpandDecryptSchedule /** * Encryption and decryption key schedules for AES-128. * If you will need both schedules, it is slightly more efficient * to call this function than to compute the two schedules separately. * See FIPS 197, sections 5.2 and 5.3.5. */ aes128Schedules : [128] -> (AESEncryptKeySchedule AES128, AESDecryptKeySchedule AES128) aes128Schedules = aesExpandSchedules /** * Encryption key expansion for AES-192. * See FIPS 197, section 5.2. */ aes192EncryptSchedule : [192] -> AESEncryptKeySchedule AES192 aes192EncryptSchedule = aesExpandEncryptSchedule /** * Decryption key expansion for AES-192, for use in the "equivalent inverse cypher". * See FIPS 197, sections 5.2 and 5.3.5. */ aes192DecryptSchedule : [192] -> AESDecryptKeySchedule AES192 aes192DecryptSchedule = aesExpandDecryptSchedule /** * Encryption and decryption key schedules for AES-192. * If you will need both schedules, it is slightly more efficient * to call this function than to compute the two schedules separately. * See FIPS 197, sections 5.2 and 5.3.5. */ aes192Schedules : [192] -> (AESEncryptKeySchedule AES192, AESDecryptKeySchedule AES192) aes192Schedules = aesExpandSchedules /** * Encryption key expansion for AES-256. * See FIPS 197, section 5.2 */ aes256EncryptSchedule : [256] -> AESEncryptKeySchedule AES256 aes256EncryptSchedule = aesExpandEncryptSchedule /** * Decryption key expansion for AES-256, for use in the "equivalent inverse cypher". * See FIPS 197, sections 5.2 and 5.3.5. */ aes256DecryptSchedule : [256] -> AESDecryptKeySchedule AES256 aes256DecryptSchedule = aesExpandDecryptSchedule /** * Encryption and decryption key schedules for AES-256. * If you will need both schedules, it is slightly more efficient * to call this function than to compute the two schedules separately. * See FIPS 197, sections 5.2 and 5.3.5. */ aes256Schedules : [256] -> (AESEncryptKeySchedule AES256, AESDecryptKeySchedule AES256) aes256Schedules = aesExpandSchedules /** * AES block encryption algorithm. * See FIPS 197, section 5.1. */ aesEncryptBlock : {k} (fin k) => AESEncryptKeySchedule k -> [128] -> [128] aesEncryptBlock schedule plaintext = rnf (join final) where final = (AESEncFinalRound (rds!0)) ^ schedule.aesEncFinalKey rds = [ schedule.aesEncInitialKey ^ split plaintext ] # [ AESEncRound r ^ rdk | rdk <- schedule.aesEncRoundKeys | r <- rds ] /** * AES block decryption algorithm, via the "equivalent inverse cypher". * See FIPS 197, section 5.3.5. */ aesDecryptBlock : {k} (fin k) => AESDecryptKeySchedule k -> [128] -> [128] aesDecryptBlock schedule cyphertext = rnf (join final) where final = (AESDecFinalRound (rds!0)) ^ schedule.aesDecFinalKey rds = [ split cyphertext ^ schedule.aesDecInitialKey ] # [ AESDecRound r ^ rdk | rdk <- schedule.aesDecRoundKeys | r <- rds ] private aesExpandEncryptSchedule : {k} (fin k, k >= 4, 8 >= k) => [k * 32] -> AESEncryptKeySchedule k aesExpandEncryptSchedule key = rnf { aesEncInitialKey = ks @ 0 , aesEncRoundKeys = ks @@ [ 1 .. k+5 ] , aesEncFinalKey = ks @ `(k+6) } where ks : [k+7]AESRoundKey ks = groupBy`{4} (AESKeyExpand`{k} (split key)) aesEncToDecSchedule : {k} (fin k) => AESEncryptKeySchedule k -> AESDecryptKeySchedule k aesEncToDecSchedule enc = rnf { aesDecInitialKey = enc.aesEncFinalKey , aesDecRoundKeys = map AESInvMixColumns (reverse (enc.aesEncRoundKeys)) , aesDecFinalKey = enc.aesEncInitialKey } aesExpandDecryptSchedule : {k} (fin k, k >= 4, 8 >= k) => [k * 32] -> AESDecryptKeySchedule k aesExpandDecryptSchedule key = aesEncToDecSchedule (aesExpandEncryptSchedule key) aesExpandSchedules : {k} (fin k, k >= 4, 8 >= k) => [k * 32] -> (AESEncryptKeySchedule k, AESDecryptKeySchedule k) aesExpandSchedules key = (encS, aesEncToDecSchedule encS) where encS = aesExpandEncryptSchedule key primitive AESEncRound : [4][32] -> [4][32] primitive AESEncFinalRound : [4][32] -> [4][32] primitive AESDecRound : [4][32] -> [4][32] primitive AESDecFinalRound : [4][32] -> [4][32] primitive AESInvMixColumns : [4][32] -> [4][32] primitive AESKeyExpand : {k} (fin k, k >= 4, 8 >= k) => [k][32] -> [4*(k+7)][32] /***** SHA2 *****/ /** * The SHA-224 secure hash algorithm. See FIPS 180-4, section 6.3. */ sha224 : {L} (fin L) => [L] -> [224] sha224 msg = join (processSHA2_224 (sha2blocks`{32} msg)) /** * The SHA-256 secure hash algorithm. See FIPS 180-4, section 6.2.2. */ sha256 : {L} (fin L) => [L] -> [256] sha256 msg = join (processSHA2_256 (sha2blocks`{32} msg)) /** * The SHA-384 secure hash algorithm. See FIPS 180-4, section 6.5. */ sha384 : {L} (fin L) => [L] -> [384] sha384 msg = join (processSHA2_384 (sha2blocks`{64} msg)) /** * The SHA-512 secure hash algorithm. See FIPS 180-4, section 6.4. */ sha512 : {L} (fin L) => [L] -> [512] sha512 msg = join (processSHA2_512 (sha2blocks`{64} msg)) private type sha2_block_size w = 16 * w type sha2_num_blocks w L = (L+1+2*w) /^ sha2_block_size w type sha2_padded_size w L = sha2_num_blocks w L * sha2_block_size w sha2pad : {w, L} (fin w, fin L, w >= 1) => [L] -> [sha2_padded_size w L] sha2pad M = rnf (M # 0b1 # zero # ((fromInteger `L) : [2*w])) sha2blocks : {w, L} (fin w, fin L, w >= 1) => [L] -> [sha2_num_blocks w L][16][w] sha2blocks msg = [ split x | x <- split (sha2pad`{w} msg) ] /** * Apply the SHA224 hash algorithm to a sequence of SHA256-size blocks, * which are assumed to already be correctly padded. */ primitive processSHA2_224 : {n} (fin n) => [n][16][32] -> [7][32] /** * Apply the SHA256 hash algorithm to a sequence of SHA256-size blocks, * which are assumed to already be correctly padded. */ primitive processSHA2_256 : {n} (fin n) => [n][16][32] -> [8][32] /** * Apply the SHA384 hash algorithm to a sequence of SHA512-size blocks, * which are assumed to already be correctly padded. */ primitive processSHA2_384 : {n} (fin n) => [n][16][64] -> [6][64] /** * Apply the SHA512 hash algorithm to a sequence of SHA512-size blocks, * which are assumed to already be correctly padded. */ primitive processSHA2_512 : {n} (fin n) => [n][16][64] -> [8][64] cryptol-3.0.0/src/Cryptol/0000755000000000000000000000000007346545000013622 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/AES.hs0000644000000000000000000005411307346545000014572 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Cryptol.AES -- Copyright : (c) Levent Erkok -- License : BSD3 -- Maintainer: erkokl@gmail.com -- Stability : experimental -- -- A TBox-based implementation of AES primitives, based on -- the AES example code from SBV. Here we've stripped out -- everything except the basic primitives needed, which -- essentially boil down to table table lookups in most cases. ----------------------------------------------------------------------------- {-# LANGUAGE ParallelListComp #-} module Cryptol.AES ( State , Key , keyExpansionWords , invMixColumns , aesRound , aesFinalRound , aesInvRound , aesInvFinalRound ) where import Data.Bits import Data.List (transpose, genericDrop, genericTake) import Data.Word (Word8, Word32) -- | An element of the Galois Field 2^8, which are essentially polynomials with -- maximum degree 7. They are conveniently represented as values between 0 and 255. type GF28 = Word8 ----------------------------------------------------------------------------- -- ** Types and basic operations ----------------------------------------------------------------------------- -- | AES state. The state consists of four 32-bit words, each of which is in turn treated -- as four GF28's, i.e., 4 bytes. The T-Box implementation keeps the four-bytes together -- for efficient representation. type State = [Word32] -- | The key, which can be 128, 192, or 256 bits. Represented as a sequence of 32-bit words. type Key = [Word32] -- | Rotating a state row by a fixed amount to the right. rotR :: [GF28] -> Int -> [GF28] rotR [a, b, c, d] 1 = [d, a, b, c] rotR [a, b, c, d] 2 = [c, d, a, b] rotR [a, b, c, d] 3 = [b, c, d, a] rotR xs i = error $ "rotR: Unexpected input: " ++ show (xs, i) toBytes :: Word32 -> [Word8] toBytes w = [b0,b1,b2,b3] where b0 = fromIntegral (w `shiftR` 24) b1 = fromIntegral (w `shiftR` 16) b2 = fromIntegral (w `shiftR` 8) b3 = fromIntegral w fromBytes :: [Word8] -> Word32 fromBytes [b0,b1,b2,b3] = w where w = ((fromIntegral b0) `shiftL` 24) .|. ((fromIntegral b1) `shiftL` 16) .|. ((fromIntegral b2) `shiftL` 8) .|. (fromIntegral b3) fromBytes bs = error ("Unexpected list length in fromBytes: " ++ show (length bs)) ----------------------------------------------------------------------------- -- ** GF28 multiplication tables ----------------------------------------------------------------------------- -- GF(2^8) multiplication by 0x0e mETable :: [GF28] mETable = [0x00, 0x0e, 0x1c, 0x12, 0x38, 0x36, 0x24, 0x2a, 0x70, 0x7e, 0x6c, 0x62, 0x48, 0x46, 0x54, 0x5a, 0xe0, 0xee, 0xfc, 0xf2, 0xd8, 0xd6, 0xc4, 0xca, 0x90, 0x9e, 0x8c, 0x82, 0xa8, 0xa6, 0xb4, 0xba, 0xdb, 0xd5, 0xc7, 0xc9, 0xe3, 0xed, 0xff, 0xf1, 0xab, 0xa5, 0xb7, 0xb9, 0x93, 0x9d, 0x8f, 0x81, 0x3b, 0x35, 0x27, 0x29, 0x03, 0x0d, 0x1f, 0x11, 0x4b, 0x45, 0x57, 0x59, 0x73, 0x7d, 0x6f, 0x61, 0xad, 0xa3, 0xb1, 0xbf, 0x95, 0x9b, 0x89, 0x87, 0xdd, 0xd3, 0xc1, 0xcf, 0xe5, 0xeb, 0xf9, 0xf7, 0x4d, 0x43, 0x51, 0x5f, 0x75, 0x7b, 0x69, 0x67, 0x3d, 0x33, 0x21, 0x2f, 0x05, 0x0b, 0x19, 0x17, 0x76, 0x78, 0x6a, 0x64, 0x4e, 0x40, 0x52, 0x5c, 0x06, 0x08, 0x1a, 0x14, 0x3e, 0x30, 0x22, 0x2c, 0x96, 0x98, 0x8a, 0x84, 0xae, 0xa0, 0xb2, 0xbc, 0xe6, 0xe8, 0xfa, 0xf4, 0xde, 0xd0, 0xc2, 0xcc, 0x41, 0x4f, 0x5d, 0x53, 0x79, 0x77, 0x65, 0x6b, 0x31, 0x3f, 0x2d, 0x23, 0x09, 0x07, 0x15, 0x1b, 0xa1, 0xaf, 0xbd, 0xb3, 0x99, 0x97, 0x85, 0x8b, 0xd1, 0xdf, 0xcd, 0xc3, 0xe9, 0xe7, 0xf5, 0xfb, 0x9a, 0x94, 0x86, 0x88, 0xa2, 0xac, 0xbe, 0xb0, 0xea, 0xe4, 0xf6, 0xf8, 0xd2, 0xdc, 0xce, 0xc0, 0x7a, 0x74, 0x66, 0x68, 0x42, 0x4c, 0x5e, 0x50, 0x0a, 0x04, 0x16, 0x18, 0x32, 0x3c, 0x2e, 0x20, 0xec, 0xe2, 0xf0, 0xfe, 0xd4, 0xda, 0xc8, 0xc6, 0x9c, 0x92, 0x80, 0x8e, 0xa4, 0xaa, 0xb8, 0xb6, 0x0c, 0x02, 0x10, 0x1e, 0x34, 0x3a, 0x28, 0x26, 0x7c, 0x72, 0x60, 0x6e, 0x44, 0x4a, 0x58, 0x56, 0x37, 0x39, 0x2b, 0x25, 0x0f, 0x01, 0x13, 0x1d, 0x47, 0x49, 0x5b, 0x55, 0x7f, 0x71, 0x63, 0x6d, 0xd7, 0xd9, 0xcb, 0xc5, 0xef, 0xe1, 0xf3, 0xfd, 0xa7, 0xa9, 0xbb, 0xb5, 0x9f, 0x91, 0x83, 0x8d] -- GF(2^8) multiplication by 0x0b mBTable :: [GF28] mBTable = [0x00, 0x0b, 0x16, 0x1d, 0x2c, 0x27, 0x3a, 0x31, 0x58, 0x53, 0x4e, 0x45, 0x74, 0x7f, 0x62, 0x69, 0xb0, 0xbb, 0xa6, 0xad, 0x9c, 0x97, 0x8a, 0x81, 0xe8, 0xe3, 0xfe, 0xf5, 0xc4, 0xcf, 0xd2, 0xd9, 0x7b, 0x70, 0x6d, 0x66, 0x57, 0x5c, 0x41, 0x4a, 0x23, 0x28, 0x35, 0x3e, 0x0f, 0x04, 0x19, 0x12, 0xcb, 0xc0, 0xdd, 0xd6, 0xe7, 0xec, 0xf1, 0xfa, 0x93, 0x98, 0x85, 0x8e, 0xbf, 0xb4, 0xa9, 0xa2, 0xf6, 0xfd, 0xe0, 0xeb, 0xda, 0xd1, 0xcc, 0xc7, 0xae, 0xa5, 0xb8, 0xb3, 0x82, 0x89, 0x94, 0x9f, 0x46, 0x4d, 0x50, 0x5b, 0x6a, 0x61, 0x7c, 0x77, 0x1e, 0x15, 0x08, 0x03, 0x32, 0x39, 0x24, 0x2f, 0x8d, 0x86, 0x9b, 0x90, 0xa1, 0xaa, 0xb7, 0xbc, 0xd5, 0xde, 0xc3, 0xc8, 0xf9, 0xf2, 0xef, 0xe4, 0x3d, 0x36, 0x2b, 0x20, 0x11, 0x1a, 0x07, 0x0c, 0x65, 0x6e, 0x73, 0x78, 0x49, 0x42, 0x5f, 0x54, 0xf7, 0xfc, 0xe1, 0xea, 0xdb, 0xd0, 0xcd, 0xc6, 0xaf, 0xa4, 0xb9, 0xb2, 0x83, 0x88, 0x95, 0x9e, 0x47, 0x4c, 0x51, 0x5a, 0x6b, 0x60, 0x7d, 0x76, 0x1f, 0x14, 0x09, 0x02, 0x33, 0x38, 0x25, 0x2e, 0x8c, 0x87, 0x9a, 0x91, 0xa0, 0xab, 0xb6, 0xbd, 0xd4, 0xdf, 0xc2, 0xc9, 0xf8, 0xf3, 0xee, 0xe5, 0x3c, 0x37, 0x2a, 0x21, 0x10, 0x1b, 0x06, 0x0d, 0x64, 0x6f, 0x72, 0x79, 0x48, 0x43, 0x5e, 0x55, 0x01, 0x0a, 0x17, 0x1c, 0x2d, 0x26, 0x3b, 0x30, 0x59, 0x52, 0x4f, 0x44, 0x75, 0x7e, 0x63, 0x68, 0xb1, 0xba, 0xa7, 0xac, 0x9d, 0x96, 0x8b, 0x80, 0xe9, 0xe2, 0xff, 0xf4, 0xc5, 0xce, 0xd3, 0xd8, 0x7a, 0x71, 0x6c, 0x67, 0x56, 0x5d, 0x40, 0x4b, 0x22, 0x29, 0x34, 0x3f, 0x0e, 0x05, 0x18, 0x13, 0xca, 0xc1, 0xdc, 0xd7, 0xe6, 0xed, 0xf0, 0xfb, 0x92, 0x99, 0x84, 0x8f, 0xbe, 0xb5, 0xa8, 0xa3] -- GF(2^8) multiplication by 0x0d mDTable :: [GF28] mDTable = [0x00, 0x0d, 0x1a, 0x17, 0x34, 0x39, 0x2e, 0x23, 0x68, 0x65, 0x72, 0x7f, 0x5c, 0x51, 0x46, 0x4b, 0xd0, 0xdd, 0xca, 0xc7, 0xe4, 0xe9, 0xfe, 0xf3, 0xb8, 0xb5, 0xa2, 0xaf, 0x8c, 0x81, 0x96, 0x9b, 0xbb, 0xb6, 0xa1, 0xac, 0x8f, 0x82, 0x95, 0x98, 0xd3, 0xde, 0xc9, 0xc4, 0xe7, 0xea, 0xfd, 0xf0, 0x6b, 0x66, 0x71, 0x7c, 0x5f, 0x52, 0x45, 0x48, 0x03, 0x0e, 0x19, 0x14, 0x37, 0x3a, 0x2d, 0x20, 0x6d, 0x60, 0x77, 0x7a, 0x59, 0x54, 0x43, 0x4e, 0x05, 0x08, 0x1f, 0x12, 0x31, 0x3c, 0x2b, 0x26, 0xbd, 0xb0, 0xa7, 0xaa, 0x89, 0x84, 0x93, 0x9e, 0xd5, 0xd8, 0xcf, 0xc2, 0xe1, 0xec, 0xfb, 0xf6, 0xd6, 0xdb, 0xcc, 0xc1, 0xe2, 0xef, 0xf8, 0xf5, 0xbe, 0xb3, 0xa4, 0xa9, 0x8a, 0x87, 0x90, 0x9d, 0x06, 0x0b, 0x1c, 0x11, 0x32, 0x3f, 0x28, 0x25, 0x6e, 0x63, 0x74, 0x79, 0x5a, 0x57, 0x40, 0x4d, 0xda, 0xd7, 0xc0, 0xcd, 0xee, 0xe3, 0xf4, 0xf9, 0xb2, 0xbf, 0xa8, 0xa5, 0x86, 0x8b, 0x9c, 0x91, 0x0a, 0x07, 0x10, 0x1d, 0x3e, 0x33, 0x24, 0x29, 0x62, 0x6f, 0x78, 0x75, 0x56, 0x5b, 0x4c, 0x41, 0x61, 0x6c, 0x7b, 0x76, 0x55, 0x58, 0x4f, 0x42, 0x09, 0x04, 0x13, 0x1e, 0x3d, 0x30, 0x27, 0x2a, 0xb1, 0xbc, 0xab, 0xa6, 0x85, 0x88, 0x9f, 0x92, 0xd9, 0xd4, 0xc3, 0xce, 0xed, 0xe0, 0xf7, 0xfa, 0xb7, 0xba, 0xad, 0xa0, 0x83, 0x8e, 0x99, 0x94, 0xdf, 0xd2, 0xc5, 0xc8, 0xeb, 0xe6, 0xf1, 0xfc, 0x67, 0x6a, 0x7d, 0x70, 0x53, 0x5e, 0x49, 0x44, 0x0f, 0x02, 0x15, 0x18, 0x3b, 0x36, 0x21, 0x2c, 0x0c, 0x01, 0x16, 0x1b, 0x38, 0x35, 0x22, 0x2f, 0x64, 0x69, 0x7e, 0x73, 0x50, 0x5d, 0x4a, 0x47, 0xdc, 0xd1, 0xc6, 0xcb, 0xe8, 0xe5, 0xf2, 0xff, 0xb4, 0xb9, 0xae, 0xa3, 0x80, 0x8d, 0x9a, 0x97] -- GF(2^8) multiplication by 0x09 m9Table :: [GF28] m9Table = [0x00, 0x09, 0x12, 0x1b, 0x24, 0x2d, 0x36, 0x3f, 0x48, 0x41, 0x5a, 0x53, 0x6c, 0x65, 0x7e, 0x77, 0x90, 0x99, 0x82, 0x8b, 0xb4, 0xbd, 0xa6, 0xaf, 0xd8, 0xd1, 0xca, 0xc3, 0xfc, 0xf5, 0xee, 0xe7, 0x3b, 0x32, 0x29, 0x20, 0x1f, 0x16, 0x0d, 0x04, 0x73, 0x7a, 0x61, 0x68, 0x57, 0x5e, 0x45, 0x4c, 0xab, 0xa2, 0xb9, 0xb0, 0x8f, 0x86, 0x9d, 0x94, 0xe3, 0xea, 0xf1, 0xf8, 0xc7, 0xce, 0xd5, 0xdc, 0x76, 0x7f, 0x64, 0x6d, 0x52, 0x5b, 0x40, 0x49, 0x3e, 0x37, 0x2c, 0x25, 0x1a, 0x13, 0x08, 0x01, 0xe6, 0xef, 0xf4, 0xfd, 0xc2, 0xcb, 0xd0, 0xd9, 0xae, 0xa7, 0xbc, 0xb5, 0x8a, 0x83, 0x98, 0x91, 0x4d, 0x44, 0x5f, 0x56, 0x69, 0x60, 0x7b, 0x72, 0x05, 0x0c, 0x17, 0x1e, 0x21, 0x28, 0x33, 0x3a, 0xdd, 0xd4, 0xcf, 0xc6, 0xf9, 0xf0, 0xeb, 0xe2, 0x95, 0x9c, 0x87, 0x8e, 0xb1, 0xb8, 0xa3, 0xaa, 0xec, 0xe5, 0xfe, 0xf7, 0xc8, 0xc1, 0xda, 0xd3, 0xa4, 0xad, 0xb6, 0xbf, 0x80, 0x89, 0x92, 0x9b, 0x7c, 0x75, 0x6e, 0x67, 0x58, 0x51, 0x4a, 0x43, 0x34, 0x3d, 0x26, 0x2f, 0x10, 0x19, 0x02, 0x0b, 0xd7, 0xde, 0xc5, 0xcc, 0xf3, 0xfa, 0xe1, 0xe8, 0x9f, 0x96, 0x8d, 0x84, 0xbb, 0xb2, 0xa9, 0xa0, 0x47, 0x4e, 0x55, 0x5c, 0x63, 0x6a, 0x71, 0x78, 0x0f, 0x06, 0x1d, 0x14, 0x2b, 0x22, 0x39, 0x30, 0x9a, 0x93, 0x88, 0x81, 0xbe, 0xb7, 0xac, 0xa5, 0xd2, 0xdb, 0xc0, 0xc9, 0xf6, 0xff, 0xe4, 0xed, 0x0a, 0x03, 0x18, 0x11, 0x2e, 0x27, 0x3c, 0x35, 0x42, 0x4b, 0x50, 0x59, 0x66, 0x6f, 0x74, 0x7d, 0xa1, 0xa8, 0xb3, 0xba, 0x85, 0x8c, 0x97, 0x9e, 0xe9, 0xe0, 0xfb, 0xf2, 0xcd, 0xc4, 0xdf, 0xd6, 0x31, 0x38, 0x23, 0x2a, 0x15, 0x1c, 0x07, 0x0e, 0x79, 0x70, 0x6b, 0x62, 0x5d, 0x54, 0x4f, 0x46] -- GF(2^8) multiplication by 0x02 m2Table :: [GF28] m2Table = [0x00, 0x02, 0x04, 0x06, 0x08, 0x0a, 0x0c, 0x0e, 0x10, 0x12, 0x14, 0x16, 0x18, 0x1a, 0x1c, 0x1e, 0x20, 0x22, 0x24, 0x26, 0x28, 0x2a, 0x2c, 0x2e, 0x30, 0x32, 0x34, 0x36, 0x38, 0x3a, 0x3c, 0x3e, 0x40, 0x42, 0x44, 0x46, 0x48, 0x4a, 0x4c, 0x4e, 0x50, 0x52, 0x54, 0x56, 0x58, 0x5a, 0x5c, 0x5e, 0x60, 0x62, 0x64, 0x66, 0x68, 0x6a, 0x6c, 0x6e, 0x70, 0x72, 0x74, 0x76, 0x78, 0x7a, 0x7c, 0x7e, 0x80, 0x82, 0x84, 0x86, 0x88, 0x8a, 0x8c, 0x8e, 0x90, 0x92, 0x94, 0x96, 0x98, 0x9a, 0x9c, 0x9e, 0xa0, 0xa2, 0xa4, 0xa6, 0xa8, 0xaa, 0xac, 0xae, 0xb0, 0xb2, 0xb4, 0xb6, 0xb8, 0xba, 0xbc, 0xbe, 0xc0, 0xc2, 0xc4, 0xc6, 0xc8, 0xca, 0xcc, 0xce, 0xd0, 0xd2, 0xd4, 0xd6, 0xd8, 0xda, 0xdc, 0xde, 0xe0, 0xe2, 0xe4, 0xe6, 0xe8, 0xea, 0xec, 0xee, 0xf0, 0xf2, 0xf4, 0xf6, 0xf8, 0xfa, 0xfc, 0xfe, 0x1b, 0x19, 0x1f, 0x1d, 0x13, 0x11, 0x17, 0x15, 0x0b, 0x09, 0x0f, 0x0d, 0x03, 0x01, 0x07, 0x05, 0x3b, 0x39, 0x3f, 0x3d, 0x33, 0x31, 0x37, 0x35, 0x2b, 0x29, 0x2f, 0x2d, 0x23, 0x21, 0x27, 0x25, 0x5b, 0x59, 0x5f, 0x5d, 0x53, 0x51, 0x57, 0x55, 0x4b, 0x49, 0x4f, 0x4d, 0x43, 0x41, 0x47, 0x45, 0x7b, 0x79, 0x7f, 0x7d, 0x73, 0x71, 0x77, 0x75, 0x6b, 0x69, 0x6f, 0x6d, 0x63, 0x61, 0x67, 0x65, 0x9b, 0x99, 0x9f, 0x9d, 0x93, 0x91, 0x97, 0x95, 0x8b, 0x89, 0x8f, 0x8d, 0x83, 0x81, 0x87, 0x85, 0xbb, 0xb9, 0xbf, 0xbd, 0xb3, 0xb1, 0xb7, 0xb5, 0xab, 0xa9, 0xaf, 0xad, 0xa3, 0xa1, 0xa7, 0xa5, 0xdb, 0xd9, 0xdf, 0xdd, 0xd3, 0xd1, 0xd7, 0xd5, 0xcb, 0xc9, 0xcf, 0xcd, 0xc3, 0xc1, 0xc7, 0xc5, 0xfb, 0xf9, 0xff, 0xfd, 0xf3, 0xf1, 0xf7, 0xf5, 0xeb, 0xe9, 0xef, 0xed, 0xe3, 0xe1, 0xe7, 0xe5] -- GF(2^8) multiplication by 0x03 m3Table :: [GF28] m3Table = [0x00, 0x03, 0x06, 0x05, 0x0c, 0x0f, 0x0a, 0x09, 0x18, 0x1b, 0x1e, 0x1d, 0x14, 0x17, 0x12, 0x11, 0x30, 0x33, 0x36, 0x35, 0x3c, 0x3f, 0x3a, 0x39, 0x28, 0x2b, 0x2e, 0x2d, 0x24, 0x27, 0x22, 0x21, 0x60, 0x63, 0x66, 0x65, 0x6c, 0x6f, 0x6a, 0x69, 0x78, 0x7b, 0x7e, 0x7d, 0x74, 0x77, 0x72, 0x71, 0x50, 0x53, 0x56, 0x55, 0x5c, 0x5f, 0x5a, 0x59, 0x48, 0x4b, 0x4e, 0x4d, 0x44, 0x47, 0x42, 0x41, 0xc0, 0xc3, 0xc6, 0xc5, 0xcc, 0xcf, 0xca, 0xc9, 0xd8, 0xdb, 0xde, 0xdd, 0xd4, 0xd7, 0xd2, 0xd1, 0xf0, 0xf3, 0xf6, 0xf5, 0xfc, 0xff, 0xfa, 0xf9, 0xe8, 0xeb, 0xee, 0xed, 0xe4, 0xe7, 0xe2, 0xe1, 0xa0, 0xa3, 0xa6, 0xa5, 0xac, 0xaf, 0xaa, 0xa9, 0xb8, 0xbb, 0xbe, 0xbd, 0xb4, 0xb7, 0xb2, 0xb1, 0x90, 0x93, 0x96, 0x95, 0x9c, 0x9f, 0x9a, 0x99, 0x88, 0x8b, 0x8e, 0x8d, 0x84, 0x87, 0x82, 0x81, 0x9b, 0x98, 0x9d, 0x9e, 0x97, 0x94, 0x91, 0x92, 0x83, 0x80, 0x85, 0x86, 0x8f, 0x8c, 0x89, 0x8a, 0xab, 0xa8, 0xad, 0xae, 0xa7, 0xa4, 0xa1, 0xa2, 0xb3, 0xb0, 0xb5, 0xb6, 0xbf, 0xbc, 0xb9, 0xba, 0xfb, 0xf8, 0xfd, 0xfe, 0xf7, 0xf4, 0xf1, 0xf2, 0xe3, 0xe0, 0xe5, 0xe6, 0xef, 0xec, 0xe9, 0xea, 0xcb, 0xc8, 0xcd, 0xce, 0xc7, 0xc4, 0xc1, 0xc2, 0xd3, 0xd0, 0xd5, 0xd6, 0xdf, 0xdc, 0xd9, 0xda, 0x5b, 0x58, 0x5d, 0x5e, 0x57, 0x54, 0x51, 0x52, 0x43, 0x40, 0x45, 0x46, 0x4f, 0x4c, 0x49, 0x4a, 0x6b, 0x68, 0x6d, 0x6e, 0x67, 0x64, 0x61, 0x62, 0x73, 0x70, 0x75, 0x76, 0x7f, 0x7c, 0x79, 0x7a, 0x3b, 0x38, 0x3d, 0x3e, 0x37, 0x34, 0x31, 0x32, 0x23, 0x20, 0x25, 0x26, 0x2f, 0x2c, 0x29, 0x2a, 0x0b, 0x08, 0x0d, 0x0e, 0x07, 0x04, 0x01, 0x02, 0x13, 0x10, 0x15, 0x16, 0x1f, 0x1c, 0x19, 0x1a] -- table-lookup versions of gf28Mult with the constants used in invMixColumns -- and TBox construction m2 :: GF28 -> GF28 m2 i = m2Table !! fromIntegral i m3 :: GF28 -> GF28 m3 i = m3Table !! fromIntegral i mE :: GF28 -> GF28 mE i = mETable !! fromIntegral i mB :: GF28 -> GF28 mB i = mBTable !! fromIntegral i mD :: GF28 -> GF28 mD i = mDTable !! fromIntegral i m9 :: GF28 -> GF28 m9 i = m9Table !! fromIntegral i ----------------------------------------------------------------------------- -- ** The key schedule ----------------------------------------------------------------------------- -- | The @InvMixColumns@ transformation, as described in Section 5.3.3 of the standard. Note -- that this transformation is only used explicitly during key-expansion in the T-Box implementation -- of AES. invMixColumns :: State -> State invMixColumns state = map fromBytes $ transpose $ mmult (map toBytes state) where dot f = foldr1 xor . zipWith ($) f mmult :: [[Word8]] -> [[Word8]] mmult n = [map (dot r) n | r <- [ [mE, mB, mD, m9] , [m9, mE, mB, mD] , [mD, m9, mE, mB] , [mB, mD, m9, mE] ]] keyExpansionWords :: Integer -> Key -> [Word32] keyExpansionWords nk key = genericTake (4*(nk+7)) keys where keys :: [Word32] keys = key ++ [nextWord i prev old | i <- [nk ..] | prev <- genericDrop (nk-1) keys | old <- keys] nextWord :: Integer -> Word32 -> Word32 -> Word32 nextWord i prev old | i `mod` nk == 0 = old `xor` subWordRcon (prev `rotateL` 8) (roundConstants !! fromInteger (i `div` nk)) | i `mod` nk == 4 && nk > 6 = old `xor` subWordRcon prev 0 | True = old `xor` prev subWordRcon :: Word32 -> GF28 -> Word32 subWordRcon w rc = fromBytes [a `xor` rc, b, c, d] where (a, b, c, d) = case map sbox $ toBytes w of [a', b', c', d'] -> (a', b', c', d') bs -> error $ "Unexpected list length in keyExpansionWords: " ++ show (length bs) -- | Definition of round-constants, as specified in Section 5.2 of the AES standard. -- We only need up to the 11th value for AES-128, and fewer than that for AES-192 -- and AES-256. roundConstants :: [GF28] roundConstants = [0,1,2,4,8,16,32,64,128,27,54] ----------------------------------------------------------------------------- -- ** The S-box transformation ----------------------------------------------------------------------------- sboxTable :: [GF28] sboxTable = [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] -- | The AES sbox transformation sbox :: GF28 -> GF28 sbox i = sboxTable !! fromIntegral i ----------------------------------------------------------------------------- -- ** The inverse S-box transformation ----------------------------------------------------------------------------- unSBoxTable :: [GF28] unSBoxTable = [0x52, 0x09, 0x6a, 0xd5, 0x30, 0x36, 0xa5, 0x38, 0xbf, 0x40, 0xa3, 0x9e, 0x81, 0xf3, 0xd7, 0xfb, 0x7c, 0xe3, 0x39, 0x82, 0x9b, 0x2f, 0xff, 0x87, 0x34, 0x8e, 0x43, 0x44, 0xc4, 0xde, 0xe9, 0xcb, 0x54, 0x7b, 0x94, 0x32, 0xa6, 0xc2, 0x23, 0x3d, 0xee, 0x4c, 0x95, 0x0b, 0x42, 0xfa, 0xc3, 0x4e, 0x08, 0x2e, 0xa1, 0x66, 0x28, 0xd9, 0x24, 0xb2, 0x76, 0x5b, 0xa2, 0x49, 0x6d, 0x8b, 0xd1, 0x25, 0x72, 0xf8, 0xf6, 0x64, 0x86, 0x68, 0x98, 0x16, 0xd4, 0xa4, 0x5c, 0xcc, 0x5d, 0x65, 0xb6, 0x92, 0x6c, 0x70, 0x48, 0x50, 0xfd, 0xed, 0xb9, 0xda, 0x5e, 0x15, 0x46, 0x57, 0xa7, 0x8d, 0x9d, 0x84, 0x90, 0xd8, 0xab, 0x00, 0x8c, 0xbc, 0xd3, 0x0a, 0xf7, 0xe4, 0x58, 0x05, 0xb8, 0xb3, 0x45, 0x06, 0xd0, 0x2c, 0x1e, 0x8f, 0xca, 0x3f, 0x0f, 0x02, 0xc1, 0xaf, 0xbd, 0x03, 0x01, 0x13, 0x8a, 0x6b, 0x3a, 0x91, 0x11, 0x41, 0x4f, 0x67, 0xdc, 0xea, 0x97, 0xf2, 0xcf, 0xce, 0xf0, 0xb4, 0xe6, 0x73, 0x96, 0xac, 0x74, 0x22, 0xe7, 0xad, 0x35, 0x85, 0xe2, 0xf9, 0x37, 0xe8, 0x1c, 0x75, 0xdf, 0x6e, 0x47, 0xf1, 0x1a, 0x71, 0x1d, 0x29, 0xc5, 0x89, 0x6f, 0xb7, 0x62, 0x0e, 0xaa, 0x18, 0xbe, 0x1b, 0xfc, 0x56, 0x3e, 0x4b, 0xc6, 0xd2, 0x79, 0x20, 0x9a, 0xdb, 0xc0, 0xfe, 0x78, 0xcd, 0x5a, 0xf4, 0x1f, 0xdd, 0xa8, 0x33, 0x88, 0x07, 0xc7, 0x31, 0xb1, 0x12, 0x10, 0x59, 0x27, 0x80, 0xec, 0x5f, 0x60, 0x51, 0x7f, 0xa9, 0x19, 0xb5, 0x4a, 0x0d, 0x2d, 0xe5, 0x7a, 0x9f, 0x93, 0xc9, 0x9c, 0xef, 0xa0, 0xe0, 0x3b, 0x4d, 0xae, 0x2a, 0xf5, 0xb0, 0xc8, 0xeb, 0xbb, 0x3c, 0x83, 0x53, 0x99, 0x61, 0x17, 0x2b, 0x04, 0x7e, 0xba, 0x77, 0xd6, 0x26, 0xe1, 0x69, 0x14, 0x63, 0x55, 0x21, 0x0c, 0x7d] -- | The inverse s-box transformation. unSBox :: GF28 -> GF28 unSBox i = unSBoxTable !! fromIntegral i ----------------------------------------------------------------------------- -- ** Tables for T-Box encryption ----------------------------------------------------------------------------- -- | T-box table generation function for encryption t0Func :: GF28 -> [GF28] t0Func a = [ m2 s, s, s, m3 s] where s = sbox a -- | First look-up table used in encryption t0 :: GF28 -> Word32 t0 i = t0Table !! fromIntegral i t0Table :: [Word32] t0Table = [fromBytes (t0Func a) | a <- [0..255]] -- | Second look-up table used in encryption t1 :: GF28 -> Word32 t1 i = t1Table !! fromIntegral i t1Table :: [Word32] t1Table = [fromBytes (t0Func a `rotR` 1) | a <- [0..255]] -- | Third look-up table used in encryption t2 :: GF28 -> Word32 t2 i = t2Table !! fromIntegral i t2Table :: [Word32] t2Table = [fromBytes (t0Func a `rotR` 2) | a <- [0..255]] -- | Fourth look-up table used in encryption t3 :: GF28 -> Word32 t3 i = t3Table !! fromIntegral i t3Table :: [Word32] t3Table = [fromBytes (t0Func a `rotR` 3) | a <- [0..255]] ----------------------------------------------------------------------------- -- ** Tables for T-Box decryption ----------------------------------------------------------------------------- -- | T-box table generating function for decryption u0Func :: GF28 -> [GF28] u0Func a = [ mE s, m9 s, mD s, mB s ] where s = unSBox a -- | First look-up table used in decryption u0 :: GF28 -> Word32 u0 i = u0Table !! fromIntegral i u0Table :: [Word32] u0Table = [fromBytes (u0Func a) | a <- [0..255]] -- | Second look-up table used in decryption u1 :: GF28 -> Word32 u1 i = u1Table !! fromIntegral i u1Table :: [Word32] u1Table = [fromBytes (u0Func a `rotR` 1) | a <- [0..255]] -- | Third look-up table used in decryption u2 :: GF28 -> Word32 u2 i = u2Table !! fromIntegral i u2Table :: [Word32] u2Table = [fromBytes (u0Func a `rotR` 2) | a <- [0..255]] -- | Fourth look-up table used in decryption u3 :: GF28 -> Word32 u3 i = u3Table !! fromIntegral i u3Table :: [Word32] u3Table = [fromBytes (u0Func a `rotR` 3) | a <- [0..255]] ----------------------------------------------------------------------------- -- ** AES rounds ----------------------------------------------------------------------------- aesRound :: State -> State aesRound s = d where d = map f [0..3] a = map toBytes s f j = e0 `xor` e1 `xor` e2 `xor` e3 where e0 = t0 (a !! ((j+0) `mod` 4) !! 0) e1 = t1 (a !! ((j+1) `mod` 4) !! 1) e2 = t2 (a !! ((j+2) `mod` 4) !! 2) e3 = t3 (a !! ((j+3) `mod` 4) !! 3) aesFinalRound :: State -> State aesFinalRound s = d where d = map f [0..3] a = map toBytes s f j = fromBytes [ sbox (a !! ((j+0) `mod` 4) !! 0) , sbox (a !! ((j+1) `mod` 4) !! 1) , sbox (a !! ((j+2) `mod` 4) !! 2) , sbox (a !! ((j+3) `mod` 4) !! 3) ] aesInvRound :: State -> State aesInvRound s = d where d = map f [0..3] a = map toBytes s f j = e0 `xor` e1 `xor` e2 `xor` e3 where e0 = u0 (a !! ((j+0) `mod` 4) !! 0) e1 = u1 (a !! ((j+3) `mod` 4) !! 1) e2 = u2 (a !! ((j+2) `mod` 4) !! 2) e3 = u3 (a !! ((j+1) `mod` 4) !! 3) aesInvFinalRound :: State -> State aesInvFinalRound s = d where d = map f [0..3] a = map toBytes s f j = fromBytes [ unSBox (a !! ((j+0) `mod` 4) !! 0) , unSBox (a !! ((j+3) `mod` 4) !! 1) , unSBox (a !! ((j+2) `mod` 4) !! 2) , unSBox (a !! ((j+1) `mod` 4) !! 3) ] cryptol-3.0.0/src/Cryptol/Backend.hs0000644000000000000000000006171307346545000015515 0ustar0000000000000000{-# Language FlexibleContexts #-} {-# Language TypeFamilies #-} module Cryptol.Backend ( Backend(..) , sDelay , invalidIndex , cryUserError , cryNoPrimError , FPArith2 , IndexDirection(..) , enumerateIntBits , enumerateIntBits' -- * Rationals , SRational(..) , intToRational , ratio , rationalAdd , rationalSub , rationalNegate , rationalMul , rationalRecip , rationalDivide , rationalFloor , rationalCeiling , rationalTrunc , rationalRoundAway , rationalRoundToEven , rationalEq , rationalLessThan , rationalGreaterThan , iteRational ) where import qualified Control.Exception as X import Control.Monad.IO.Class import Data.Kind (Type) import Cryptol.Backend.FloatHelpers (BF) import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..), CallStack, pushCallFrame ) import Cryptol.ModuleSystem.Name(Name) import Cryptol.Parser.Position import Cryptol.TypeCheck.Solver.InfNat(Nat'(..),widthInteger) data IndexDirection = IndexForward | IndexBackward invalidIndex :: Backend sym => sym -> Integer -> SEval sym a invalidIndex sym i = raiseError sym (InvalidIndex (Just i)) cryUserError :: Backend sym => sym -> String -> SEval sym a cryUserError sym msg = raiseError sym (UserError msg) cryNoPrimError :: Backend sym => sym -> Name -> SEval sym a cryNoPrimError sym nm = raiseError sym (NoPrim nm) {-# INLINE sDelay #-} -- | 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. sDelay :: Backend sym => sym -> SEval sym a -> SEval sym (SEval sym a) sDelay sym m = sDelayFill sym m Nothing "" -- | Representation of rational numbers. -- Invariant: denominator is not 0 data SRational sym = SRational { sNum :: SInteger sym , sDenom :: SInteger sym } intToRational :: Backend sym => sym -> SInteger sym -> SEval sym (SRational sym) intToRational sym x = SRational x <$> (integerLit sym 1) ratio :: Backend sym => sym -> SInteger sym -> SInteger sym -> SEval sym (SRational sym) ratio sym n d = do pz <- bitComplement sym =<< intEq sym d =<< integerLit sym 0 assertSideCondition sym pz DivideByZero pure (SRational n d) rationalRecip :: Backend sym => sym -> SRational sym -> SEval sym (SRational sym) rationalRecip sym (SRational a b) = ratio sym b a rationalDivide :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym) rationalDivide sym x y = rationalMul sym x =<< rationalRecip sym y rationalFloor :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym) -- NB, relies on integer division being round-to-negative-inf division rationalFloor sym (SRational n d) = intDiv sym n d rationalCeiling :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym) rationalCeiling sym r = intNegate sym =<< rationalFloor sym =<< rationalNegate sym r rationalTrunc :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym) rationalTrunc sym r = do p <- rationalLessThan sym r =<< intToRational sym =<< integerLit sym 0 cr <- rationalCeiling sym r fr <- rationalFloor sym r iteInteger sym p cr fr rationalRoundAway :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym) rationalRoundAway sym r = do p <- rationalLessThan sym r =<< intToRational sym =<< integerLit sym 0 half <- SRational <$> integerLit sym 1 <*> integerLit sym 2 cr <- rationalCeiling sym =<< rationalSub sym r half fr <- rationalFloor sym =<< rationalAdd sym r half iteInteger sym p cr fr rationalRoundToEven :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym) rationalRoundToEven sym r = do lo <- rationalFloor sym r hi <- intPlus sym lo =<< integerLit sym 1 -- NB: `diff` will be nonnegative because `lo <= r` diff <- rationalSub sym r =<< intToRational sym lo half <- SRational <$> integerLit sym 1 <*> integerLit sym 2 ite (rationalLessThan sym diff half) (pure lo) $ ite (rationalGreaterThan sym diff half) (pure hi) $ ite (isEven lo) (pure lo) (pure hi) where isEven x = do parity <- intMod sym x =<< integerLit sym 2 intEq sym parity =<< integerLit sym 0 ite x t e = do x' <- x case bitAsLit sym x' of Just True -> t Just False -> e Nothing -> do t' <- t e' <- e iteInteger sym x' t' e' rationalAdd :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym) rationalAdd sym (SRational a b) (SRational c d) = do ad <- intMult sym a d bc <- intMult sym b c bd <- intMult sym b d ad_bc <- intPlus sym ad bc pure (SRational ad_bc bd) rationalSub :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym) rationalSub sym (SRational a b) (SRational c d) = do ad <- intMult sym a d bc <- intMult sym b c bd <- intMult sym b d ad_bc <- intMinus sym ad bc pure (SRational ad_bc bd) rationalNegate :: Backend sym => sym -> SRational sym -> SEval sym (SRational sym) rationalNegate sym (SRational a b) = do aneg <- intNegate sym a pure (SRational aneg b) rationalMul :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym) rationalMul sym (SRational a b) (SRational c d) = do ac <- intMult sym a c bd <- intMult sym b d pure (SRational ac bd) rationalEq :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SBit sym) rationalEq sym (SRational a b) (SRational c d) = do ad <- intMult sym a d bc <- intMult sym b c intEq sym ad bc normalizeSign :: Backend sym => sym -> SRational sym -> SEval sym (SRational sym) normalizeSign sym (SRational a b) = do p <- intLessThan sym b =<< integerLit sym 0 case bitAsLit sym p of Just False -> pure (SRational a b) Just True -> do aneg <- intNegate sym a bneg <- intNegate sym b pure (SRational aneg bneg) Nothing -> do aneg <- intNegate sym a bneg <- intNegate sym b a' <- iteInteger sym p aneg a b' <- iteInteger sym p bneg b pure (SRational a' b') rationalLessThan:: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SBit sym) rationalLessThan sym x y = do SRational a b <- normalizeSign sym x SRational c d <- normalizeSign sym y ad <- intMult sym a d bc <- intMult sym b c intLessThan sym ad bc rationalGreaterThan:: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SBit sym) rationalGreaterThan sym = flip (rationalLessThan sym) iteRational :: Backend sym => sym -> SBit sym -> SRational sym -> SRational sym -> SEval sym (SRational sym) iteRational sym p (SRational a b) (SRational c d) = SRational <$> iteInteger sym p a c <*> iteInteger sym p b d -- | Compute the list of bits in an integer in big-endian order. -- The integer argument is a concrete upper bound for -- the symbolic integer. enumerateIntBits' :: Backend sym => sym -> Integer -> SInteger sym -> SEval sym (Integer, [SBit sym]) enumerateIntBits' sym n idx = do let width = widthInteger n w <- wordFromInt sym width idx bs <- unpackWord sym w pure (width, bs) -- | Compute the list of bits in an integer in big-endian order. -- Fails if neither the sequence length nor the type value -- provide an upper bound for the integer. enumerateIntBits :: Backend sym => sym -> Nat' -> SInteger sym -> SEval sym (Integer, [SBit sym]) enumerateIntBits sym (Nat n) idx = enumerateIntBits' sym n idx enumerateIntBits _sym Inf _ = liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer shifting")) -- | This type class defines a collection of operations on bits, words and integers that -- are necessary to define generic evaluator primitives that operate on both concrete -- and symbolic values uniformly. class MonadIO (SEval sym) => Backend sym where type SBit sym :: Type type SWord sym :: Type type SInteger sym :: Type type SFloat sym :: Type type SEval sym :: Type -> Type -- ==== Evaluation monad operations ==== -- | Check if an operation is "ready", which means its -- evaluation will be trivial. isReady :: sym -> SEval sym a -> SEval sym (Maybe a) -- | 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. sDeclareHole :: sym -> String -> SEval sym (SEval sym a, SEval sym a -> SEval sym ()) -- | 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. sDelayFill :: sym -> SEval sym a -> Maybe (SEval sym a) -> String -> SEval sym (SEval sym a) -- | Begin evaluating the given computation eagerly in a separate thread -- and return a thunk which will await the completion of the given computation -- when forced. sSpark :: sym -> SEval sym a -> SEval sym (SEval sym a) -- | Push a call frame on to the current call stack while evaluating the given action sPushFrame :: sym -> Name -> Range -> SEval sym a -> SEval sym a sPushFrame sym nm rng m = sModifyCallStack sym (pushCallFrame nm rng) m -- | Use the given call stack while evaluating the given action sWithCallStack :: sym -> CallStack -> SEval sym a -> SEval sym a sWithCallStack sym stk m = sModifyCallStack sym (\_ -> stk) m -- | Apply the given function to the current call stack while evaluating the given action sModifyCallStack :: sym -> (CallStack -> CallStack) -> SEval sym a -> SEval sym a -- | Retrieve the current evaluation call stack sGetCallStack :: sym -> SEval sym CallStack -- | Merge the two given computations according to the predicate. mergeEval :: sym -> (SBit sym -> a -> a -> SEval sym a) {- ^ A merge operation on values -} -> SBit sym {- ^ The condition -} -> SEval sym a {- ^ The "then" computation -} -> SEval sym a {- ^ The "else" computation -} -> SEval sym a -- | Assert that a condition must hold, and indicate what sort of -- error is indicated if the condition fails. assertSideCondition :: sym -> SBit sym -> EvalError -> SEval sym () -- | Indiciate that an error condition exists raiseError :: sym -> EvalError -> SEval sym a -- ==== Identifying literal values ==== -- | Determine if this symbolic bit is a boolean literal bitAsLit :: sym -> SBit sym -> Maybe Bool -- | The number of bits in a word value. wordLen :: sym -> SWord sym -> Integer -- | Determine if this symbolic word is a literal. -- If so, return the bit width and value. wordAsLit :: sym -> SWord sym -> Maybe (Integer, Integer) -- | Attempt to render a word value as an ASCII character. Return 'Nothing' -- if the character value is unknown (e.g., for symbolic values). wordAsChar :: sym -> SWord sym -> Maybe Char -- | Determine if this symbolic integer is a literal integerAsLit :: sym -> SInteger sym -> Maybe Integer -- | Determine if this symbolic floating-point value is a literal fpAsLit :: sym -> SFloat sym -> Maybe BF -- ==== Creating literal values ==== -- | Construct a literal bit value from a boolean. bitLit :: sym -> Bool -> SBit sym -- | Construct a literal word value given a bit width and a value. wordLit :: sym -> Integer {- ^ Width -} -> Integer {- ^ Value -} -> SEval sym (SWord sym) -- | Construct a literal integer value from the given integer. integerLit :: sym -> Integer {- ^ Value -} -> SEval sym (SInteger sym) -- | Construct a floating point value from the given rational. fpLit :: sym -> Integer {- ^ exponent bits -} -> Integer {- ^ precision bits -} -> Rational {- ^ The rational -} -> SEval sym (SFloat sym) -- | Construct a floating point value from the given bit-precise -- floating-point representation. fpExactLit :: sym -> BF -> SEval sym (SFloat sym) -- ==== If/then/else operations ==== iteBit :: sym -> SBit sym -> SBit sym -> SBit sym -> SEval sym (SBit sym) iteWord :: sym -> SBit sym -> SWord sym -> SWord sym -> SEval sym (SWord sym) iteInteger :: sym -> SBit sym -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) iteFloat :: sym -> SBit sym -> SFloat sym -> SFloat sym -> SEval sym (SFloat sym) -- ==== Bit operations ==== bitEq :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym) bitOr :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym) bitAnd :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym) bitXor :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym) bitComplement :: sym -> SBit sym -> SEval sym (SBit sym) -- ==== Word operations ==== -- | 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 :: sym -> SWord sym -> Integer {- ^ Bit position to extract -} -> SEval sym (SBit sym) -- | 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 :: sym -> SWord sym -> Integer {- ^ Bit position to update -} -> SBit sym -> SEval sym (SWord sym) -- | 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 :: sym -> [SBit sym] -> SEval sym (SWord sym) -- | 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 :: sym -> SWord sym -> SEval sym [SBit sym] -- | Construct a packed word of the specified width from an integer value. wordFromInt :: sym -> Integer {- ^ bit-width -} -> SInteger sym -> SEval sym (SWord sym) -- | Concatenate the two given word values. -- NOTE: the first argument represents the more-significant bits joinWord :: sym -> SWord sym -> SWord sym -> SEval sym (SWord sym) -- | 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 :: sym -> Integer {- ^ left width -} -> Integer {- ^ right width -} -> SWord sym -> SEval sym (SWord sym, SWord sym) -- | 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 :: sym -> Integer {- ^ Number of bits to take -} -> Integer {- ^ starting bit -} -> SWord sym -> SEval sym (SWord sym) -- | Bitwise OR wordOr :: sym -> SWord sym -> SWord sym -> SEval sym (SWord sym) -- | Bitwise AND wordAnd :: sym -> SWord sym -> SWord sym -> SEval sym (SWord sym) -- | Bitwise XOR wordXor :: sym -> SWord sym -> SWord sym -> SEval sym (SWord sym) -- | Bitwise complement wordComplement :: sym -> SWord sym -> SEval sym (SWord sym) -- | 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 :: sym -> SWord sym -> SWord sym -> SEval sym (SWord sym) -- | 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 :: sym -> SWord sym -> SWord sym -> SEval sym (SWord sym) -- | 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 :: sym -> SWord sym -> SWord sym -> SEval sym (SWord sym) -- | 2's complement unsigned division of packed words. The arguments must have -- equal bit width, and the result is of the same width. It is illegal to -- call with a second argument concretely equal to 0. wordDiv :: sym -> SWord sym -> SWord sym -> SEval sym (SWord sym) -- | 2's complement unsigned modulus of packed words. The arguments must have -- equal bit width, and the result is of the same width. It is illegal to -- call with a second argument concretely equal to 0. wordMod :: sym -> SWord sym -> SWord sym -> SEval sym (SWord sym) -- | 2's complement signed division of packed words. The arguments must have -- equal bit width, and the result is of the same width. It is illegal to -- call with a second argument concretely equal to 0. wordSignedDiv :: sym -> SWord sym -> SWord sym -> SEval sym (SWord sym) -- | 2's complement signed modulus of packed words. The arguments must have -- equal bit width, and the result is of the same width. It is illegal to -- call with a second argument concretely equal to 0. wordSignedMod :: sym -> SWord sym -> SWord sym -> SEval sym (SWord sym) -- | Shift a bitvector left by the specified amount. -- The shift amount is considered as an unsigned value. -- Shifting by more than the word length results in 0. wordShiftLeft :: sym -> SWord sym {- ^ value to shift -} -> SWord sym {- ^ amount to shift by -} -> SEval sym (SWord sym) -- | Shift a bitvector right by the specified amount. -- This is a logical shift, which shifts in 0 values -- on the left. The shift amount is considered as an -- unsigned value. Shifting by more than the word length -- results in 0. wordShiftRight :: sym -> SWord sym {- ^ value to shift -} -> SWord sym {- ^ amount to shift by -} -> SEval sym (SWord sym) -- | Shift a bitvector right by the specified amount. This is an -- arithmetic shift, which shifts in copies of the high bit on the -- left. The shift amount is considered as an unsigned -- value. Shifting by more than the word length results in filling -- the bitvector with the high bit. wordSignedShiftRight :: sym -> SWord sym {- ^ value to shift -} -> SWord sym {- ^ amount to shift by -} -> SEval sym (SWord sym) wordRotateLeft :: sym -> SWord sym {- ^ value to rotate -} -> SWord sym {- ^ amount to rotate by -} -> SEval sym (SWord sym) wordRotateRight :: sym -> SWord sym {- ^ value to rotate -} -> SWord sym {- ^ amount to rotate by -} -> SEval sym (SWord sym) -- | 2's complement negation of bitvectors wordNegate :: sym -> SWord sym -> SEval sym (SWord sym) -- | Compute rounded-up log-2 of the input wordLg2 :: sym -> SWord sym -> SEval sym (SWord sym) -- | Test if two words are equal. Arguments must have the same width. wordEq :: sym -> SWord sym -> SWord sym -> SEval sym (SBit sym) -- | Signed less-than comparison on words. Arguments must have the same width. wordSignedLessThan :: sym -> SWord sym -> SWord sym -> SEval sym (SBit sym) -- | Unsigned less-than comparison on words. Arguments must have the same width. wordLessThan :: sym -> SWord sym -> SWord sym -> SEval sym (SBit sym) -- | Unsigned greater-than comparison on words. Arguments must have the same width. wordGreaterThan :: sym -> SWord sym -> SWord sym -> SEval sym (SBit sym) -- | Construct an integer value from the given packed word. wordToInt :: sym -> SWord sym -> SEval sym (SInteger sym) -- | Construct a signed integer value from the given packed word. wordToSignedInt :: sym -> SWord sym -> SEval sym (SInteger sym) -- ==== Integer operations ==== -- | Addition of unbounded integers. intPlus :: sym -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) -- | Negation of unbounded integers intNegate :: sym -> SInteger sym -> SEval sym (SInteger sym) -- | Subtraction of unbounded integers. intMinus :: sym -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) -- | Multiplication of unbounded integers. intMult :: sym -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) -- | Integer division, rounding down. It is illegal to -- call with a second argument concretely equal to 0. -- Same semantics as Haskell's @div@ operation. intDiv :: sym -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) -- | Integer modulus, with division rounding down. It is illegal to -- call with a second argument concretely equal to 0. -- Same semantics as Haskell's @mod@ operation. intMod :: sym -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) -- | Equality comparison on integers intEq :: sym -> SInteger sym -> SInteger sym -> SEval sym (SBit sym) -- | Less-than comparison on integers intLessThan :: sym -> SInteger sym -> SInteger sym -> SEval sym (SBit sym) -- | Greater-than comparison on integers intGreaterThan :: sym -> SInteger sym -> SInteger sym -> SEval sym (SBit sym) -- ==== Operations on Z_n ==== -- | Turn an integer into a value in Z_n intToZn :: sym -> Integer {- ^ modulus -} -> SInteger sym -> SEval sym (SInteger sym) -- | Transform a Z_n value into an integer, ensuring the value is properly -- reduced modulo n znToInt :: sym -> Integer {- ^ modulus -} -> SInteger sym -> SEval sym (SInteger sym) -- | Addition of integers modulo n, for a concrete positive integer n. znPlus :: sym -> Integer {- ^ modulus -} -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) -- | Additive inverse of integers modulo n znNegate :: sym -> Integer {- ^ modulus -} -> SInteger sym -> SEval sym (SInteger sym) -- | Subtraction of integers modulo n, for a concrete positive integer n. znMinus :: sym -> Integer {- ^ modulus -} -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) -- | Multiplication of integers modulo n, for a concrete positive integer n. znMult :: sym -> Integer {- ^ modulus -} -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) -- | Equality test of integers modulo n znEq :: sym -> Integer {- ^ modulus -} -> SInteger sym -> SInteger sym -> SEval sym (SBit sym) -- | Multiplicative inverse in (Z n). -- PRECONDITION: the modulus is a prime znRecip :: sym -> Integer {- ^ modulus -} -> SInteger sym -> SEval sym (SInteger sym) -- == Float Operations == fpEq :: sym -> SFloat sym -> SFloat sym -> SEval sym (SBit sym) fpLessThan :: sym -> SFloat sym -> SFloat sym -> SEval sym (SBit sym) fpGreaterThan :: sym -> SFloat sym -> SFloat sym -> SEval sym (SBit sym) fpLogicalEq :: sym -> SFloat sym -> SFloat sym -> SEval sym (SBit sym) fpNaN :: sym -> Integer {- ^ exponent bits -} -> Integer {- ^ precision bits -} -> SEval sym (SFloat sym) fpPosInf :: sym -> Integer {- ^ exponent bits -} -> Integer {- ^ precision bits -} -> SEval sym (SFloat sym) fpPlus, fpMinus, fpMult, fpDiv :: FPArith2 sym fpNeg, fpAbs :: sym -> SFloat sym -> SEval sym (SFloat sym) fpSqrt :: sym -> SWord sym -> SFloat sym -> SEval sym (SFloat sym) fpFMA :: sym -> SWord sym -> SFloat sym -> SFloat sym -> SFloat sym -> SEval sym (SFloat sym) fpIsZero, fpIsNeg, fpIsNaN, fpIsInf, fpIsNorm, fpIsSubnorm :: sym -> SFloat sym -> SEval sym (SBit sym) fpToBits :: sym -> SFloat sym -> SEval sym (SWord sym) fpFromBits :: sym -> Integer {- ^ exponent bits -} -> Integer {- ^ precision bits -} -> SWord sym -> SEval sym (SFloat sym) fpToInteger :: sym -> String {- ^ Name of the function for error reporting -} -> SWord sym {- ^ Rounding mode -} -> SFloat sym -> SEval sym (SInteger sym) fpFromInteger :: sym -> Integer {- ^ exp width -} -> Integer {- ^ prec width -} -> SWord sym {- ^ rounding mode -} -> SInteger sym {- ^ the integer to use -} -> SEval sym (SFloat sym) fpToRational :: sym -> SFloat sym -> SEval sym (SRational sym) fpFromRational :: sym -> Integer {- ^ exp width -} -> Integer {- ^ prec width -} -> SWord sym {- ^ rounding mode -} -> SRational sym -> SEval sym (SFloat sym) type FPArith2 sym = sym -> SWord sym -> SFloat sym -> SFloat sym -> SEval sym (SFloat sym) cryptol-3.0.0/src/Cryptol/Backend/0000755000000000000000000000000007346545000015151 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/Backend/Arch.hs0000644000000000000000000000216007346545000016361 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.Backend.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-3.0.0/src/Cryptol/Backend/Concrete.hs0000644000000000000000000003603607346545000017257 0ustar0000000000000000-- | -- Module : Cryptol.Backend.Concrete -- Copyright : (c) 2013-2020 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Cryptol.Backend.Concrete ( BV(..) , binBV , unaryBV , bvVal , ppBV , mkBv , mask , signedBV , signedValue , integerToChar , lg2 , Concrete(..) , liftBinIntMod , fpBinArith , fpRoundMode ) where import qualified Control.Exception as X import Data.Bits import Data.Ratio import Numeric (showIntAtBase) import qualified LibBF as FP import qualified GHC.Num.Compat as Integer import qualified Cryptol.Backend.Arch as Arch import qualified Cryptol.Backend.FloatHelpers as FP import Cryptol.Backend import Cryptol.Backend.Monad import Cryptol.TypeCheck.Solver.InfNat (genLog) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.PP data Concrete = Concrete deriving Show -- | Concrete bitvector values: width, value -- Invariant: The value must be within the range 0 .. 2^width-1 data BV = BV !Integer !Integer 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 :: Applicative m => (Integer -> Integer -> Integer) -> BV -> BV -> m BV binBV f (BV w x) (BV _ y) = pure $! mkBv w (f x y) {-# INLINE binBV #-} -- | 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 {-# INLINE unaryBV #-} bvVal :: BV -> Integer bvVal (BV _w x) = x {-# INLINE bvVal #-} -- | Smart constructor for 'BV's that checks for the width limit mkBv :: Integer -> Integer -> BV mkBv w i = BV w (mask w i) 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 - (bit (fromInteger i)) else x integerToChar :: Integer -> Char integerToChar = toEnum . fromInteger lg2 :: Integer -> Integer lg2 i = case genLog i 2 of Just (i',isExact) | isExact -> i' | otherwise -> i' + 1 Nothing -> 0 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 -> mempty 16 -> text "0x" <.> padding 4 _ -> text "0" <.> char '<' <.> int base <.> char '>' value = showIntAtBase (toInteger base) (digits !!) i "" digits = "0123456789abcdefghijklmnopqrstuvwxyz" -- Concrete Big-endian Words ------------------------------------------------------------ mask :: Integer {- ^ Bit-width -} -> Integer {- ^ Value -} -> Integer {- ^ Masked result -} mask w i | w >= Arch.maxBigIntWidth = wordTooWide w | otherwise = i .&. (bit (fromInteger w) - 1) instance Backend Concrete where type SBit Concrete = Bool type SWord Concrete = BV type SInteger Concrete = Integer type SFloat Concrete = FP.BF type SEval Concrete = Eval raiseError _ err = do stk <- getCallStack io (X.throwIO (EvalErrorEx stk err)) assertSideCondition _ True _ = return () assertSideCondition sym False err = raiseError sym err wordLen _ (BV w _) = w wordAsChar _ (BV _ x) = Just $! integerToChar x wordBit _ (BV w x) idx = pure $! testBit x (fromInteger (w - 1 - idx)) wordUpdate _ (BV w x) idx True = pure $! BV w (setBit x (fromInteger (w - 1 - idx))) wordUpdate _ (BV w x) idx False = pure $! BV w (clearBit x (fromInteger (w - 1 - idx))) isReady _ = maybeReady mergeEval _sym f c mx my = do x <- mx y <- my f c x y sDeclareHole _ = blackhole sDelayFill _ = delayFill sSpark _ = evalSpark sModifyCallStack _ f m = modifyCallStack f m sGetCallStack _ = getCallStack bitLit _ b = b bitAsLit _ b = Just b bitEq _ x y = pure $! x == y bitOr _ x y = pure $! x .|. y bitAnd _ x y = pure $! x .&. y bitXor _ x y = pure $! x `xor` y bitComplement _ x = pure $! complement x iteBit _ b x y = pure $! if b then x else y iteWord _ b x y = pure $! if b then x else y iteInteger _ b x y = pure $! if b then x else y iteFloat _ b x y = pure $! if b then x else y wordLit _ w i = pure $! mkBv w i wordAsLit _ (BV w i) = Just (w,i) integerLit _ i = pure i integerAsLit _ = Just wordToInt _ (BV _ x) = pure x wordToSignedInt _ (BV w x) = pure $! signedValue w x wordFromInt _ w x = pure $! mkBv w x packWord _ bits = pure $! 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) = pure [ testBit a n | n <- [w' - 1, w' - 2 .. 0] ] where w' = fromInteger w joinWord _ (BV i x) (BV j y) = pure $! BV (i + j) (shiftL x (fromInteger j) + y) splitWord _ leftW rightW (BV _ x) = pure ( BV leftW (x `shiftR` (fromInteger rightW)), mkBv rightW x ) extractWord _ n i (BV _ x) = pure $! mkBv n (x `shiftR` (fromInteger i)) wordEq _ (BV i x) (BV j y) | i == j = pure $! x == y | otherwise = panic "Attempt to compare words of different sizes: wordEq" [show i, show j] wordSignedLessThan _ (BV i x) (BV j y) | i == j = pure $! signedValue i x < signedValue i y | otherwise = panic "Attempt to compare words of different sizes: wordSignedLessThan" [show i, show j] wordLessThan _ (BV i x) (BV j y) | i == j = pure $! x < y | otherwise = panic "Attempt to compare words of different sizes: wordLessThan" [show i, show j] wordGreaterThan _ (BV i x) (BV j y) | i == j = pure $! x > y | otherwise = panic "Attempt to compare words of different sizes: wordGreaterThan" [show i, show j] wordAnd _ (BV i x) (BV j y) | i == j = pure $! mkBv i (x .&. y) | otherwise = panic "Attempt to AND words of different sizes: wordPlus" [show i, show j] wordOr _ (BV i x) (BV j y) | i == j = pure $! mkBv i (x .|. y) | otherwise = panic "Attempt to OR words of different sizes: wordPlus" [show i, show j] wordXor _ (BV i x) (BV j y) | i == j = pure $! mkBv i (x `xor` y) | otherwise = panic "Attempt to XOR words of different sizes: wordPlus" [show i, show j] wordComplement _ (BV i x) = pure $! mkBv i (complement x) wordPlus _ (BV i x) (BV j y) | i == j = pure $! mkBv i (x+y) | otherwise = panic "Attempt to add words of different sizes: wordPlus" [show i, show j] wordNegate _ (BV i x) = pure $! mkBv i (negate x) wordMinus _ (BV i x) (BV j y) | i == j = pure $! mkBv i (x-y) | otherwise = panic "Attempt to subtract words of different sizes: wordMinus" [show i, show j] wordMult _ (BV i x) (BV j y) | i == j = pure $! mkBv i (x*y) | otherwise = panic "Attempt to multiply words of different sizes: wordMult" [show i, show j] wordDiv sym (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = do assertSideCondition sym (y /= 0) DivideByZero pure $! mkBv i (x `div` y) | otherwise = panic "Attempt to divide words of different sizes: wordDiv" [show i, show j] wordMod sym (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = do assertSideCondition sym (y /= 0) DivideByZero pure $! mkBv i (x `mod` y) | otherwise = panic "Attempt to mod words of different sizes: wordMod" [show i, show j] wordSignedDiv sym (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = do assertSideCondition sym (y /= 0) DivideByZero let sx = signedValue i x sy = signedValue i y pure $! mkBv i (sx `quot` sy) | otherwise = panic "Attempt to divide words of different sizes: wordSignedDiv" [show i, show j] wordSignedMod sym (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = do assertSideCondition sym (y /= 0) DivideByZero let sx = signedValue i x sy = signedValue i y pure $! mkBv i (sx `rem` sy) | otherwise = panic "Attempt to mod words of different sizes: wordSignedMod" [show i, show j] wordShiftLeft _sym (BV w ival) (BV _ by) | by >= w = pure $! BV w 0 | by > toInteger (maxBound :: Int) = panic "shl" ["Shift amount too large", show by] | otherwise = pure $! mkBv w (shiftL ival (fromInteger by)) wordShiftRight _sym (BV w ival) (BV _ by) | by >= w = pure $! BV w 0 | by > toInteger (maxBound :: Int) = panic "lshr" ["Shift amount too large", show by] | otherwise = pure $! BV w (shiftR ival (fromInteger by)) wordSignedShiftRight _sym (BV w ival) (BV _ by) = let by' = min w by in if by' > toInteger (maxBound :: Int) then panic "wordSignedShiftRight" ["Shift amount too large", show by] else pure $! mkBv w (shiftR (signedValue w ival) (fromInteger by')) wordRotateRight _sym (BV 0 i) _ = pure (BV 0 i) wordRotateRight _sym (BV w i) (BV _ by) = pure . mkBv w $! (i `shiftR` b) .|. (i `shiftL` (fromInteger w - b)) where b = fromInteger (by `mod` w) wordRotateLeft _sym (BV 0 i) _ = pure (BV 0 i) wordRotateLeft _sym (BV w i) (BV _ by) = pure . mkBv w $! (i `shiftL` b) .|. (i `shiftR` (fromInteger w - b)) where b = fromInteger (by `mod` w) wordLg2 _ (BV i x) = pure $! mkBv i (lg2 x) intEq _ x y = pure $! x == y intLessThan _ x y = pure $! x < y intGreaterThan _ x y = pure $! x > y intPlus _ x y = pure $! x + y intMinus _ x y = pure $! x - y intNegate _ x = pure $! negate x intMult _ x y = pure $! x * y intDiv sym x y = do assertSideCondition sym (y /= 0) DivideByZero pure $! x `div` y intMod sym x y = do assertSideCondition sym (y /= 0) DivideByZero pure $! x `mod` y intToZn _ 0 _ = evalPanic "intToZn" ["0 modulus not allowed"] intToZn _ m x = pure $! x `mod` m -- NB: requires we maintain the invariant that -- Z_n is in reduced form znToInt _ _m x = pure x znEq _ _m x y = pure $! x == y -- NB: under the precondition that `m` is prime, -- the only values for which no inverse exists are -- congruent to 0 modulo m. znRecip sym m x = case Integer.integerRecipMod x m of Just r -> integerLit sym r Nothing -> raiseError sym DivideByZero znPlus _ = liftBinIntMod (+) znMinus _ = liftBinIntMod (-) znMult _ = liftBinIntMod (*) znNegate _ 0 _ = evalPanic "znNegate" ["0 modulus not allowed"] znNegate _ m x = pure $! (negate x) `mod` m ------------------------------------------------------------------------ -- Floating Point fpLit _sym e p rat = pure (FP.fpLit e p rat) fpNaN _sym e p = pure (FP.BF e p FP.bfNaN) fpPosInf _sym e p = pure (FP.BF e p FP.bfPosInf) fpAsLit _ f = Just f fpExactLit _sym bf = pure bf fpEq _sym x y = pure (FP.bfValue x == FP.bfValue y) fpLogicalEq _sym x y = pure (FP.bfCompare (FP.bfValue x) (FP.bfValue y) == EQ) fpLessThan _sym x y = pure (FP.bfValue x < FP.bfValue y) fpGreaterThan _sym x y = pure (FP.bfValue x > FP.bfValue y) fpPlus = fpBinArith FP.bfAdd fpMinus = fpBinArith FP.bfSub fpMult = fpBinArith FP.bfMul fpDiv = fpBinArith FP.bfDiv fpNeg _ x = pure $! x { FP.bfValue = FP.bfNeg (FP.bfValue x) } fpAbs _ x = pure $! x { FP.bfValue = FP.bfAbs (FP.bfValue x) } fpSqrt sym r x = do r' <- fpRoundMode sym r let opts = FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x) r' pure $! x{ FP.bfValue = FP.fpCheckStatus (FP.bfSqrt opts (FP.bfValue x)) } fpFMA sym r x y z = do r' <- fpRoundMode sym r let opts = FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x) r' pure $! x { FP.bfValue = FP.fpCheckStatus (FP.bfFMA opts (FP.bfValue x) (FP.bfValue y) (FP.bfValue z)) } fpIsZero _ x = pure (FP.bfIsZero (FP.bfValue x)) fpIsNeg _ x = pure (FP.bfIsNeg (FP.bfValue x)) fpIsNaN _ x = pure (FP.bfIsNaN (FP.bfValue x)) fpIsInf _ x = pure (FP.bfIsInf (FP.bfValue x)) fpIsNorm _ x = let opts = FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x) FP.NearEven in pure (FP.bfIsNormal opts (FP.bfValue x)) fpIsSubnorm _ x = let opts = FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x) FP.NearEven in pure (FP.bfIsSubnormal opts (FP.bfValue x)) fpFromBits _sym e p bv = pure (FP.floatFromBits e p (bvVal bv)) fpToBits _sym (FP.BF e p v) = pure (mkBv (e+p) (FP.floatToBits e p v)) fpFromInteger sym e p r x = do r' <- fpRoundMode sym r pure FP.BF { FP.bfExpWidth = e , FP.bfPrecWidth = p , FP.bfValue = FP.fpCheckStatus $ FP.bfRoundInt r' (FP.bfFromInteger x) } fpToInteger = fpCvtToInteger fpFromRational sym e p r x = do mode <- fpRoundMode sym r pure (FP.floatFromRational e p mode (sNum x % sDenom x)) fpToRational sym fp = case FP.floatToRational "fpToRational" fp of Left err -> raiseError sym err Right r -> pure $ SRational { sNum = numerator r, sDenom = denominator r } {-# INLINE liftBinIntMod #-} liftBinIntMod :: Monad m => (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer -> m Integer liftBinIntMod op m x y | m == 0 = evalPanic "znArithmetic" ["0 modulus not allowed"] | otherwise = pure $ (op x y) `mod` m {-# INLINE fpBinArith #-} fpBinArith :: (FP.BFOpts -> FP.BigFloat -> FP.BigFloat -> (FP.BigFloat, FP.Status)) -> Concrete -> SWord Concrete {- ^ Rouding mode -} -> SFloat Concrete -> SFloat Concrete -> SEval Concrete (SFloat Concrete) fpBinArith fun = \sym r x y -> do opts <- FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x) <$> fpRoundMode sym r pure $! x { FP.bfValue = FP.fpCheckStatus (fun opts (FP.bfValue x) (FP.bfValue y)) } fpCvtToInteger :: Concrete -> String -> SWord Concrete {- ^ Rounding mode -} -> SFloat Concrete -> SEval Concrete (SInteger Concrete) fpCvtToInteger sym fun rnd flt = do mode <- fpRoundMode sym rnd case FP.floatToInteger fun mode flt of Right i -> pure i Left err -> raiseError sym err fpRoundMode :: Concrete -> SWord Concrete -> SEval Concrete FP.RoundMode fpRoundMode sym w = case FP.fpRound (bvVal w) of Left err -> raiseError sym err Right a -> pure a cryptol-3.0.0/src/Cryptol/Backend/FFI.hs0000644000000000000000000002016607346545000016116 0ustar0000000000000000{-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | The implementation of loading and calling external functions from shared -- libraries. module Cryptol.Backend.FFI ( ForeignSrc , getForeignSrcPath , loadForeignSrc , unloadForeignSrc , foreignLibPath #ifdef FFI_ENABLED , ForeignImpl , loadForeignImpl , FFIArg , FFIRet , SomeFFIArg (..) , callForeignImpl #endif ) where import Control.DeepSeq import Cryptol.Backend.FFI.Error #ifdef FFI_ENABLED import Control.Concurrent.MVar import Control.Exception import Control.Monad import Data.Bifunctor import Data.Word import Foreign hiding (newForeignPtr) import Foreign.C.Types import Foreign.Concurrent import Foreign.LibFFI import System.FilePath ((-<.>)) import System.Directory(doesFileExist) import System.IO.Error import System.Info(os) #if defined(mingw32_HOST_OS) import System.Win32.DLL #else import System.Posix.DynamicLinker #endif import Cryptol.Utils.Panic #else import GHC.Generics #endif #ifdef FFI_ENABLED -- | A source from which we can retrieve implementations of foreign functions. data ForeignSrc = ForeignSrc { -- | The file path of the 'ForeignSrc'. foreignSrcPath :: FilePath -- | The 'ForeignPtr' wraps the pointer returned by 'dlopen', where the -- finalizer calls 'dlclose' when the library is no longer needed. We keep -- references to the 'ForeignPtr' in each foreign function that is in the -- evaluation environment, so that the shared library will stay open as long -- as there are references to it. , foreignSrcFPtr :: ForeignPtr () -- | We support explicit unloading of the shared library so we keep track of -- if it has already been unloaded, and if so the finalizer does nothing. -- This is updated atomically when the library is unloaded. , foreignSrcLoaded :: MVar Bool } instance Show ForeignSrc where show = show . foreignSrcFPtr instance NFData ForeignSrc where rnf ForeignSrc {..} = foreignSrcFPtr `seq` foreignSrcLoaded `deepseq` () -- | Get the file path of the 'ForeignSrc'. getForeignSrcPath :: ForeignSrc -> Maybe FilePath getForeignSrcPath = Just . foreignSrcPath -- | Load a 'ForeignSrc' for the given __Cryptol__ file path. The file path of -- the shared library that we try to load is the same as the Cryptol file path -- except with a platform specific extension. loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc) loadForeignSrc = loadForeignLib >=> traverse \(foreignSrcPath, ptr) -> do foreignSrcLoaded <- newMVar True foreignSrcFPtr <- newForeignPtr ptr (unloadForeignSrc' foreignSrcLoaded ptr) pure ForeignSrc {..} -- | Given the path to a Cryptol module, compute the location of -- the shared library we'd like to load. foreignLibPath :: FilePath -> IO (Maybe FilePath) foreignLibPath path = search case os of "mingw32" -> ["dll"] "darwin" -> ["dylib","so"] _ -> ["so"] where search es = case es of [] -> pure Nothing e : more -> do let p = path -<.> e yes <- doesFileExist p if yes then pure (Just p) else search more loadForeignLib :: FilePath -> IO (Either FFILoadError (FilePath, Ptr ())) loadForeignLib path = do mb <- foreignLibPath path case mb of Nothing -> pure (Left (CantLoadFFISrc path "File not found")) Just libPath -> tryLoad (CantLoadFFISrc path) (open libPath) where open libPath = do #if defined(mingw32_HOST_OS) ptr <- loadLibrary libPath #else -- RTLD_NOW so we can make sure that the symbols actually exist at -- module loading time ptr <- undl <$> dlopen libPath [RTLD_NOW] #endif pure (libPath, ptr) -- | Explicitly unload a 'ForeignSrc' immediately instead of waiting for the -- garbage collector to do it. This can be useful if you want to immediately -- load the same library again to pick up new changes. -- -- The 'ForeignSrc' __must not__ be used in any way after this is called, -- including calling 'ForeignImpl's loaded from it. unloadForeignSrc :: ForeignSrc -> IO () unloadForeignSrc ForeignSrc {..} = withForeignPtr foreignSrcFPtr $ unloadForeignSrc' foreignSrcLoaded unloadForeignSrc' :: MVar Bool -> Ptr () -> IO () unloadForeignSrc' loaded lib = modifyMVar_ loaded \l -> do when l $ unloadForeignLib lib pure False unloadForeignLib :: Ptr () -> IO () #if defined(mingw32_HOST_OS) unloadForeignLib = freeLibrary #else unloadForeignLib = dlclose . DLHandle #endif withForeignSrc :: ForeignSrc -> (Ptr () -> IO a) -> IO a withForeignSrc ForeignSrc {..} f = withMVar foreignSrcLoaded \case True -> withForeignPtr foreignSrcFPtr f False -> panic "[FFI] withForeignSrc" ["Use of foreign library after unload"] -- | An implementation of a foreign function. data ForeignImpl = ForeignImpl { foreignImplFun :: FunPtr () -- | We don't need this to call the function but we want to keep the library -- around as long as we still have a function from it so that it isn't -- unloaded too early. , foreignImplSrc :: ForeignSrc } -- | Load a 'ForeignImpl' with the given name from the given 'ForeignSrc'. loadForeignImpl :: ForeignSrc -> String -> IO (Either FFILoadError ForeignImpl) loadForeignImpl foreignImplSrc name = withForeignSrc foreignImplSrc \lib -> tryLoad (CantLoadFFIImpl name) do foreignImplFun <- loadForeignFunPtr lib name pure ForeignImpl {..} loadForeignFunPtr :: Ptr () -> String -> IO (FunPtr ()) #if defined(mingw32_HOST_OS) loadForeignFunPtr source symbol = do addr <- getProcAddress source symbol pure $ castPtrToFunPtr addr #else loadForeignFunPtr = dlsym . DLHandle #endif tryLoad :: (String -> FFILoadError) -> IO a -> IO (Either FFILoadError a) tryLoad err = fmap (first $ err . displayException) . tryIOError -- | Types which can be converted into libffi arguments. -- -- The Storable constraint is so that we can put them in arrays. class Storable a => FFIArg a where ffiArg :: a -> Arg instance FFIArg Word8 where ffiArg = argWord8 instance FFIArg Word16 where ffiArg = argWord16 instance FFIArg Word32 where ffiArg = argWord32 instance FFIArg Word64 where ffiArg = argWord64 instance FFIArg CFloat where ffiArg = argCFloat instance FFIArg CDouble where ffiArg = argCDouble instance FFIArg (Ptr a) where ffiArg = argPtr instance FFIArg CSize where ffiArg = argCSize -- | Types which can be returned from libffi. -- -- The Storable constraint is so that we can put them in arrays. class Storable a => FFIRet a where ffiRet :: RetType a instance FFIRet Word8 where ffiRet = retWord8 instance FFIRet Word16 where ffiRet = retWord16 instance FFIRet Word32 where ffiRet = retWord32 instance FFIRet Word64 where ffiRet = retWord64 instance FFIRet CFloat where ffiRet = retCFloat instance FFIRet CDouble where ffiRet = retCDouble instance FFIRet () where ffiRet = retVoid -- | Existential wrapper around a 'FFIArg'. data SomeFFIArg = forall a. FFIArg a => SomeFFIArg a -- | Call a 'ForeignImpl' with the given arguments. The type parameter decides -- how the return value should be converted into a Haskell value. callForeignImpl :: forall a. FFIRet a => ForeignImpl -> [SomeFFIArg] -> IO a callForeignImpl ForeignImpl {..} xs = withForeignSrc foreignImplSrc \_ -> callFFI foreignImplFun (ffiRet @a) $ map toArg xs where toArg (SomeFFIArg x) = ffiArg x #else data ForeignSrc = ForeignSrc deriving (Show, Generic, NFData) getForeignSrcPath :: ForeignSrc -> Maybe FilePath getForeignSrcPath _ = Nothing loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc) loadForeignSrc _ = pure $ Right ForeignSrc unloadForeignSrc :: ForeignSrc -> IO () unloadForeignSrc _ = pure () #endif cryptol-3.0.0/src/Cryptol/Backend/FFI/0000755000000000000000000000000007346545000015555 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/Backend/FFI/Error.hs0000644000000000000000000000264107346545000017205 0ustar0000000000000000{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Safe #-} -- | Errors from dynamic loading of shared libraries for FFI. module Cryptol.Backend.FFI.Error where import Control.DeepSeq import GHC.Generics import Cryptol.Utils.PP import Cryptol.ModuleSystem.Name data FFILoadError = CantLoadFFISrc FilePath -- ^ Path to cryptol module String -- ^ Error message | CantLoadFFIImpl String -- ^ Function name String -- ^ Error message | FFIDuplicates [Name] | FFIInFunctor Name deriving (Show, Generic, NFData) instance PP FFILoadError where ppPrec _ e = case e of CantLoadFFISrc path msg -> hang ("Could not load foreign source for module located at" <+> text path <.> colon) 4 (text msg) CantLoadFFIImpl name msg -> hang ("Could not load foreign implementation for binding" <+> text name <.> colon) 4 (text msg) FFIDuplicates xs -> hang "Multiple foreign declarations with the same name:" 4 (backticks (pp (nameIdent (head xs))) <+> "defined at" <+> align (vcat (map (pp . nameLoc) xs))) FFIInFunctor x -> hang (pp (nameLoc x) <.> ":") 4 "Foreign declaration" <+> backticks (pp (nameIdent x)) <+> "may not appear in a parameterized module." cryptol-3.0.0/src/Cryptol/Backend/FloatHelpers.hs0000644000000000000000000001260607346545000020102 0ustar0000000000000000{-# Language BlockArguments, OverloadedStrings #-} {-# Language BangPatterns #-} module Cryptol.Backend.FloatHelpers where import Data.Char (isDigit) import Data.Ratio(numerator,denominator) import LibBF import Cryptol.Utils.PP import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Types import Cryptol.Backend.Monad( EvalError(..) ) data BF = BF { bfExpWidth :: !Integer , bfPrecWidth :: !Integer , bfValue :: !BigFloat } -- | Make LibBF options for the given precision and rounding mode. fpOpts :: Integer -> Integer -> RoundMode -> BFOpts fpOpts e p r = case ok of Just opts -> opts Nothing -> panic "floatOpts" [ "Invalid Float size" , "exponent: " ++ show e , "precision: " ++ show p ] where ok = do eb <- rng expBits expBitsMin expBitsMax e pb <- rng precBits precBitsMin precBitsMax p pure (eb <> pb <> allowSubnormal <> rnd r) rng f a b x = if toInteger a <= x && x <= toInteger b then Just (f (fromInteger x)) else Nothing -- | Mapping from the rounding modes defined in the `Float.cry` to -- the rounding modes of `LibBF`. fpRound :: Integer -> Either EvalError RoundMode fpRound n = case n of 0 -> Right NearEven 1 -> Right NearAway 2 -> Right ToPosInf 3 -> Right ToNegInf 4 -> Right ToZero _ -> Left (BadRoundingMode n) -- | Check that we didn't get an unexpected status. fpCheckStatus :: (BigFloat,Status) -> BigFloat fpCheckStatus (r,s) = case s of MemError -> panic "checkStatus" [ "libBF: Memory error" ] _ -> r -- | Pretty print a float fpPP :: PPOpts -> BF -> Doc fpPP opts bf = case bfSign num of Nothing -> "fpNaN" Just s | bfIsFinite num -> text hacStr | otherwise -> case s of Pos -> "fpPosInf" Neg -> "fpNegInf" where num = bfValue bf precW = bfPrecWidth bf base = useFPBase opts withExp :: PPFloatExp -> ShowFmt -> ShowFmt withExp e f = case e of AutoExponent -> f ForceExponent -> f <> forceExp str = bfToString base fmt num fmt = addPrefix <> showRnd NearEven <> case useFPFormat opts of FloatFree e -> withExp e $ showFree $ Just $ fromInteger precW FloatFixed n e -> withExp e $ showFixed $ fromIntegral n FloatFrac n -> showFrac $ fromIntegral n -- non-base 10 literals are not overloaded so we add an explicit -- .0 if one is not present. Moreover, we trim any extra zeros -- that appear in a decimal representation. hacStr | base == 10 = trimZeros | elem '.' str = str | otherwise = case break (== 'p') str of (xs,ys) -> xs ++ ".0" ++ ys trimZeros = case break (== '.') str of (xs,'.':ys) -> case break (not . isDigit) ys of (frac, suffix) -> xs ++ '.' : processFraction frac ++ suffix _ -> str processFraction frac = case dropWhile (== '0') (reverse frac) of [] -> "0" zs -> reverse zs -- | Make a literal fpLit :: Integer {- ^ Exponent width -} -> Integer {- ^ Precision width -} -> Rational -> BF fpLit e p rat = floatFromRational e p NearEven rat -- | Make a floating point number from a rational, using the given rounding mode floatFromRational :: Integer -> Integer -> RoundMode -> Rational -> BF floatFromRational e p r rat = BF { bfExpWidth = e , bfPrecWidth = p , bfValue = fpCheckStatus if den == 1 then bfRoundFloat opts num else bfDiv opts num (bfFromInteger den) } where opts = fpOpts e p r num = bfFromInteger (numerator rat) den = denominator rat -- | Convert a floating point number to a rational, if possible. floatToRational :: String -> BF -> Either EvalError Rational floatToRational fun bf = case bfToRep (bfValue bf) of BFNaN -> Left (BadValue fun) BFRep s num -> case num of Inf -> Left (BadValue fun) Zero -> Right 0 Num i ev -> Right case s of Pos -> ab Neg -> negate ab where ab = fromInteger i * (2 ^^ ev) -- | Convert a floating point number to an integer, if possible. floatToInteger :: String -> RoundMode -> BF -> Either EvalError Integer floatToInteger fun r fp = do rat <- floatToRational fun fp pure case r of NearEven -> round rat NearAway -> if rat > 0 then ceiling rat else floor rat ToPosInf -> ceiling rat ToNegInf -> floor rat ToZero -> truncate rat _ -> panic "fpCvtToInteger" ["Unexpected rounding mode", show r] floatFromBits :: Integer {- ^ Exponent width -} -> Integer {- ^ Precision widht -} -> Integer {- ^ Raw bits -} -> BF floatFromBits e p bv = BF { bfValue = bfFromBits (fpOpts e p NearEven) bv , bfExpWidth = e, bfPrecWidth = p } -- | Turn a float into raw bits. -- @NaN@ is represented as a positive "quiet" @NaN@ -- (most significant bit in the significand is set, the rest of it is 0) floatToBits :: Integer -> Integer -> BigFloat -> Integer floatToBits e p bf = bfToBits (fpOpts e p NearEven) bf -- | Create a 64-bit IEEE-754 float. floatFromDouble :: Double -> BF floatFromDouble = uncurry BF float64ExpPrec . bfFromDouble cryptol-3.0.0/src/Cryptol/Backend/Monad.hs0000644000000000000000000004533407346545000016554 0ustar0000000000000000-- | -- Module : Cryptol.Backend.Monad -- Copyright : (c) 2013-2020 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE Safe #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Cryptol.Backend.Monad ( -- * Evaluation monad Eval(..) , runEval , io , delayFill , ready , blackhole , evalSpark , maybeReady -- * Call stacks , CallStack , getCallStack , withCallStack , modifyCallStack , combineCallStacks , pushCallFrame , displayCallStack -- * Error reporting , Unsupported(..) , EvalError(..) , EvalErrorEx(..) , evalPanic , wordTooWide , WordTooWide(..) ) where import Control.Concurrent import Control.Concurrent.STM import Control.Monad import Control.Monad.IO.Class import Data.Foldable (toList) import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Typeable (Typeable) import qualified Control.Exception as X import Cryptol.Parser.Position import Cryptol.Utils.Panic import Cryptol.Utils.PP import Cryptol.TypeCheck.AST(Name, TParam) -- | A computation that returns an already-evaluated value. ready :: a -> Eval a ready a = Ready a -- | The type of dynamic call stacks for the interpreter. -- New frames are pushed onto the right side of the sequence. data CallStack = EmptyCallStack | CombineCallStacks !CallStack !CallStack | PushCallFrame !Name !Range !CallStack instance Semigroup CallStack where (<>) = CombineCallStacks instance Monoid CallStack where mempty = EmptyCallStack type CallStack' = Seq (Name, Range) evalCallStack :: CallStack -> CallStack' evalCallStack stk = case stk of EmptyCallStack -> mempty CombineCallStacks appstk fnstk -> combineCallStacks' (evalCallStack appstk) (evalCallStack fnstk) PushCallFrame n r stk1 -> pushCallFrame' n r (evalCallStack stk1) -- | Pretty print a call stack with each call frame on a separate -- line, with most recent call frames at the top. displayCallStack :: CallStack -> Doc displayCallStack = displayCallStack' . evalCallStack displayCallStack' :: CallStack' -> Doc displayCallStack' = vcat . map f . toList . Seq.reverse where f (nm,rng) | rng == emptyRange = pp nm | otherwise = pp nm <+> text "called at" <+> pp rng -- | Combine the call stack of a function value with the call -- stack of the current calling context. This algorithm is -- the same one GHC uses to compute profiling calling contexts. -- -- The algorithm is as follows. -- -- ccs ++> ccsfn = ccs ++ dropCommonPrefix ccs ccsfn -- -- where -- -- dropCommonPrefix A B -- -- returns the suffix of B after removing any prefix common -- -- to both A and B. combineCallStacks :: CallStack {- ^ call stack of the application context -} -> CallStack {- ^ call stack of the function being applied -} -> CallStack combineCallStacks appstk EmptyCallStack = appstk combineCallStacks EmptyCallStack fnstk = fnstk combineCallStacks appstk fnstk = CombineCallStacks appstk fnstk combineCallStacks' :: CallStack' {- ^ call stack of the application context -} -> CallStack' {- ^ call stack of the function being applied -} -> CallStack' combineCallStacks' appstk fnstk = appstk <> dropCommonPrefix appstk fnstk where dropCommonPrefix _ Seq.Empty = Seq.Empty dropCommonPrefix Seq.Empty fs = fs dropCommonPrefix (a Seq.:<| as) xs@(f Seq.:<| fs) | a == f = dropCommonPrefix as fs | otherwise = xs -- | Add a call frame to the top of a call stack pushCallFrame :: Name -> Range -> CallStack -> CallStack pushCallFrame nm rng stk = PushCallFrame nm rng stk pushCallFrame' :: Name -> Range -> CallStack' -> CallStack' pushCallFrame' nm rng stk@( _ Seq.:|> (nm',rng')) | nm == nm', rng == rng' = stk pushCallFrame' nm rng stk = stk Seq.:|> (nm,rng) -- | The monad for Cryptol evaluation. -- A computation is either "ready", which means it represents -- only trivial computation, or is an "eval" action which must -- be computed to get the answer, or it is a "thunk", which -- represents a delayed, shared computation. data Eval a = Ready !a | Eval !(CallStack -> IO a) | Thunk !(TVar (ThunkState a)) -- | This datastructure tracks the lifecycle of a thunk. -- -- Thunks are used for basically three use cases. First, -- we use thunks to preserve sharing. Basically every -- cryptol expression that is bound to a name, and is not -- already obviously a value (and in a few other places as -- well) will get turned into a thunk in order to avoid -- recomputation. These thunks will start in the `Unforced` -- state, and have a backup computation that just raises -- the `LoopError` exception. -- -- Secondly, thunks are used to cut cycles when evaluating -- recursive definition groups. Every named clause in a -- recursive definition is thunked so that the value can appear -- in its definition. Such thunks start in the `Void` state, -- as they must exist before we have a definition to assign them. -- Forcing a thunk in the `Void` state is a programmer error (panic). -- Once the body of a definition is ready, we replace the -- thunk with the relevant computation, going to the `Unforced` state. -- -- In the third case, we are using thunks to provide an optimistic -- shortcut for evaluation. In these cases we first try to run a -- computation that is stricter than the semantics actually allows. -- If it succeeds, all is well an we continue. However, if it tight -- loops, we fall back on a lazier (and generally more expensive) -- version, which is the "backup" computation referred to above. data ThunkState a = Void !String -- ^ This thunk has not yet been initialized | Unforced !(IO a) !(Maybe (IO a)) !String !CallStack -- ^ This thunk has not yet been forced. We keep track of the "main" -- computation to run and an optional "backup" computation to run if we -- detect a tight loop when evaluating the first one. -- The final two arguments are used to throw a loop exception -- if the backup computation also causes a tight loop. | UnderEvaluation !ThreadId !(Maybe (IO a)) !String !CallStack -- ^ This thunk is currently being evaluated by the thread with the given -- thread ID. We track an optional "backup" computation to run if we detect -- a tight loop evaluating this thunk. If the thunk is being evaluated -- by some other thread, the current thread will await its completion. -- The final two arguments are used to throw a loop exception -- if the backup computation also causes a tight loop. | ForcedErr !EvalErrorEx -- ^ This thunk has been forced, and its evaluation results in an exception | Forced !a -- ^ This thunk has been forced to the given value -- | Test if a value is "ready", which means that -- it requires no computation to return. maybeReady :: Eval a -> Eval (Maybe a) maybeReady (Ready a) = pure (Just a) maybeReady (Thunk tv) = Eval $ \_ -> readTVarIO tv >>= \case Forced a -> pure (Just a) _ -> pure Nothing maybeReady (Eval _) = pure Nothing {-# 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 -} -> Maybe (Eval a) {- ^ Optional backup computation to run if a tight loop is detected -} -> String {- ^ message for the <> exception if a tight loop is detected -} -> Eval (Eval a) delayFill e@(Ready _) _ _ = return e delayFill e@(Thunk _) _ _ = return e delayFill (Eval x) backup msg = Eval (\stk -> Thunk <$> newTVarIO (Unforced (x stk) (runEval stk <$> backup) msg stk)) -- | Begin executing the given operation in a separate thread, -- returning a thunk which will await the completion of -- the computation when forced. evalSpark :: Eval a -> Eval (Eval a) -- Ready computations need no additional evaluation. evalSpark e@(Ready _) = return e -- A thunked computation might already have -- been forced. If so, return the result. Otherwise, -- fork a thread to force this computation and return -- the thunk. evalSpark (Thunk tv) = Eval $ \_stk -> readTVarIO tv >>= \case Forced x -> return (Ready x) ForcedErr ex -> return (Eval $ \_ -> (X.throwIO ex)) _ -> do _ <- forkIO (sparkThunk tv) return (Thunk tv) -- If the computation is nontrivial but not already a thunk, -- create a thunk and fork a thread to force it. evalSpark (Eval x) = Eval $ \stk -> do tv <- newTVarIO (Unforced (x stk) Nothing "" stk) _ <- forkIO (sparkThunk tv) return (Thunk tv) -- | To the work of forcing a thunk. This is the worker computation -- that is forked off via @evalSpark@. sparkThunk :: TVar (ThunkState a) -> IO () sparkThunk tv = do tid <- myThreadId -- Try to claim the thunk. If it is still in the @Void@ state, wait -- until it is in some other state. If it is @Unforced@ claim the thunk. -- Otherwise, it is already evaluated or under evaluation by another thread, -- and we have no work to do. st <- atomically $ do st <- readTVar tv case st of Void _ -> retry Unforced _ backup msg stk -> writeTVar tv (UnderEvaluation tid backup msg stk) _ -> return () return st -- If we successfully claimed the thunk to work on, run the computation and -- update the thunk state with the result. case st of Unforced work _ _ _ -> X.try work >>= \case Left err -> atomically (writeTVar tv (ForcedErr err)) Right a -> atomically (writeTVar tv (Forced a)) _ -> return () -- | 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 = Eval $ \stk -> do tv <- newTVarIO (Void msg) let set (Ready x) = io $ atomically (writeTVar tv (Forced x)) set m = io $ atomically (writeTVar tv (Unforced (runEval stk m) Nothing msg stk)) return (Thunk tv, set) -- | Force a thunk to get the result. unDelay :: TVar (ThunkState a) -> IO a unDelay tv = -- First, check if the thunk is in an evaluated state, -- and return the value if so. readTVarIO tv >>= \case Forced x -> pure x ForcedErr e -> X.throwIO e _ -> -- Otherwise, try to claim the thunk to work on. do tid <- myThreadId res <- atomically $ do res <- readTVar tv case res of -- In this case, we claim the thunk. Update the state to indicate -- that we are working on it. Unforced _ backup msg stk -> writeTVar tv (UnderEvaluation tid backup msg stk) -- In this case, the thunk is already being evaluated. If it is -- under evaluation by this thread, we have to run the backup computation, -- and "consume" it by updating the backup computation to one that throws -- a loop error. If some other thread is evaluating, reset the -- transaction to await completion of the thunk. UnderEvaluation t backup msg stk | tid == t -> case backup of Just _ -> writeTVar tv (UnderEvaluation tid Nothing msg stk) Nothing -> writeTVar tv (ForcedErr (EvalErrorEx stk (LoopError msg))) | otherwise -> retry -- wait, if some other thread is evaluating _ -> return () -- Return the original thunk state so we can decide what work to do -- after the transaction completes. return res -- helper for actually doing the work let doWork work = X.try work >>= \case Left ex -> do atomically (writeTVar tv (ForcedErr ex)) X.throwIO ex Right a -> do atomically (writeTVar tv (Forced a)) return a -- Now, examine the thunk state and decide what to do. case res of Void msg -> evalPanic "unDelay" ["Thunk forced before it was initialized", msg] Forced x -> pure x ForcedErr e -> X.throwIO e -- this thread was already evaluating this thunk UnderEvaluation _ (Just backup) _ _ -> doWork backup UnderEvaluation _ Nothing msg stk -> X.throwIO (EvalErrorEx stk (LoopError msg)) Unforced work _ _ _ -> doWork work -- | Get the current call stack getCallStack :: Eval CallStack getCallStack = Eval (\stk -> pure stk) -- | Execute the action with the given call stack withCallStack :: CallStack -> Eval a -> Eval a withCallStack stk m = Eval (\_ -> runEval stk m) -- | Run the given action with a modify call stack modifyCallStack :: (CallStack -> CallStack) -> Eval a -> Eval a modifyCallStack f m = Eval $ \stk -> do let stk' = f stk -- putStrLn $ unwords ["Pushing call stack", show (displayCallStack stk')] seq stk' (runEval stk' m) {-# INLINE modifyCallStack #-} -- | Execute the given evaluation action. runEval :: CallStack -> Eval a -> IO a runEval _ (Ready a) = return a runEval stk (Eval x) = x stk runEval _ (Thunk tv) = unDelay tv {-# INLINE runEval #-} {-# INLINE evalBind #-} evalBind :: Eval a -> (a -> Eval b) -> Eval b evalBind (Ready a) f = f a evalBind (Eval x) f = Eval (\stk -> x stk >>= runEval stk . f) evalBind (Thunk x) f = Eval (\stk -> unDelay x >>= runEval stk . f) instance Functor Eval where fmap f (Ready x) = Ready (f x) fmap f (Eval m) = Eval (\stk -> f <$> m stk) fmap f (Thunk tv) = Eval (\_ -> f <$> unDelay tv) {-# INLINE fmap #-} instance Applicative Eval where pure = Ready (<*>) = ap {-# INLINE pure #-} {-# INLINE (<*>) #-} instance Monad Eval where return = pure (>>=) = evalBind {-# INLINE return #-} {-# INLINE (>>=) #-} instance MonadIO Eval where liftIO = io -- | Lift an 'IO' computation into the 'Eval' monad. io :: IO a -> Eval a io m = Eval (\_stk -> 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 (Maybe Integer) -- ^ Out-of-bounds index | DivideByZero -- ^ Division or modulus by 0 | NegativeExponent -- ^ Exponentiation by negative integer | LogNegative -- ^ Logarithm of a negative integer | UserError String -- ^ Call to the Cryptol @error@ primitive | LoopError String -- ^ Detectable nontermination | NoPrim Name -- ^ Primitive with no implementation | BadRoundingMode Integer -- ^ Invalid rounding mode | BadValue String -- ^ Value outside the domain of a partial function. | NoMatchingPropGuardCase String -- ^ No prop guard holds for the given type variables. | FFINotSupported Name -- ^ Foreign function cannot be called | FFITypeNumTooBig Name TParam Integer -- ^ Number passed to foreign function -- as a type argument is too large deriving Typeable instance PP EvalError where ppPrec _ e = case e of InvalidIndex (Just i) -> text "invalid sequence index:" <+> integer i InvalidIndex Nothing -> text "invalid sequence index" DivideByZero -> text "division by 0" NegativeExponent -> text "negative exponent" LogNegative -> text "logarithm of negative" UserError x -> text "Run-time error:" <+> text x LoopError x -> vcat [ text "<>" <+> text x , text "This usually occurs due to an improper recursive definition," , text "but may also result from retrying a previously interrupted" , text "computation (e.g., after CTRL^C). In that case, you may need to" , text "`:reload` the current module to reset to a good state." ] BadRoundingMode r -> "invalid rounding mode" <+> integer r BadValue x -> "invalid input for" <+> backticks (text x) NoPrim x -> text "unimplemented primitive:" <+> pp x NoMatchingPropGuardCase msg -> text $ "No matching constraint guard; " ++ msg FFINotSupported x -> vcat [ text "cannot call foreign function" <+> pp x , text "FFI calls are not supported in this context" , text "If you are trying to evaluate an expression, try rebuilding" , text " Cryptol with FFI support enabled." ] FFITypeNumTooBig f p n -> vcat [ text "numeric type argument to foreign function is too large:" <+> integer n , text "in type parameter" <+> pp p <+> "of function" <+> pp f , text "type arguments must fit in a C `size_t`" ] instance Show EvalError where show = show . pp data EvalErrorEx = EvalErrorEx CallStack EvalError deriving Typeable instance PP EvalErrorEx where ppPrec _ (EvalErrorEx stk0 ex) = vcat ([ pp ex ] ++ callStk) where stk = evalCallStack stk0 callStk | Seq.null stk = [] | otherwise = [ text "-- Backtrace --", displayCallStack' stk ] instance Show EvalErrorEx where show = show . pp instance X.Exception EvalErrorEx data Unsupported = UnsupportedSymbolicOp String -- ^ Operation cannot be supported in the symbolic simulator deriving (Typeable,Show) instance PP Unsupported where ppPrec _ e = case e of UnsupportedSymbolicOp nm -> text "operation can not be supported on symbolic values:" <+> text nm instance X.Exception Unsupported -- | 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) data WordTooWide = WordTooWide Integer -- ^ Bitvector too large deriving Typeable instance PP WordTooWide where ppPrec _ (WordTooWide w) = text "word too wide for memory:" <+> integer w <+> text "bits" instance Show WordTooWide where show = show . pp instance X.Exception WordTooWide cryptol-3.0.0/src/Cryptol/Backend/SBV.hs0000644000000000000000000003774407346545000016156 0ustar0000000000000000-- | -- Module : Cryptol.Backend.SBV -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} module Cryptol.Backend.SBV ( SBV(..), SBVEval(..), SBVResult(..) , literalSWord , freshSBool_ , freshBV_ , freshSInteger_ , addDefEqn , ashr , lshr , shl , evalPanic , svFromInteger , svToInteger ) where import qualified Control.Exception as X import Control.Concurrent.MVar import Control.Monad.IO.Class (MonadIO(..)) import Data.Bits (bit, complement) import Data.List (foldl') import qualified GHC.Num.Compat as Integer import Data.SBV.Dynamic as SBV import qualified Data.SBV.Internals as SBV import Cryptol.Backend import Cryptol.Backend.Concrete ( integerToChar ) import Cryptol.Backend.Monad ( Eval(..), blackhole, delayFill, evalSpark , EvalError(..), EvalErrorEx(..), Unsupported(..) , modifyCallStack, getCallStack, maybeReady ) import Cryptol.Utils.Panic (panic) data SBV = SBV { sbvStateVar :: MVar (SBV.State) , sbvDefRelations :: MVar SVal } -- Utility operations ------------------------------------------------------------- fromBitsLE :: [SBit SBV] -> SWord SBV fromBitsLE bs = foldl' f (literalSWord 0 0) bs where f w b = svJoin (svToWord1 b) w packSBV :: [SBit SBV] -> SWord SBV packSBV bs = fromBitsLE (reverse bs) unpackSBV :: SWord SBV -> [SBit SBV] unpackSBV x = [ svTestBit x i | i <- reverse [0 .. intSizeOf x - 1] ] literalSWord :: Int -> Integer -> SWord SBV literalSWord w i = svInteger (KBounded False w) i svMkSymVar_ :: Maybe Quantifier -> Kind -> Maybe String -> SBV.State -> IO SVal #if MIN_VERSION_sbv(8,8,0) svMkSymVar_ = svMkSymVar . SBV.NonQueryVar #else svMkSymVar_ = svMkSymVar #endif freshBV_ :: SBV -> Int -> IO (SWord SBV) freshBV_ (SBV stateVar _) w = withMVar stateVar (svMkSymVar_ Nothing (KBounded False w) Nothing) freshSBool_ :: SBV -> IO (SBit SBV) freshSBool_ (SBV stateVar _) = withMVar stateVar (svMkSymVar_ Nothing KBool Nothing) freshSInteger_ :: SBV -> IO (SInteger SBV) freshSInteger_ (SBV stateVar _) = withMVar stateVar (svMkSymVar_ Nothing KUnbounded Nothing) -- SBV Evaluation monad ------------------------------------------------------- data SBVResult a = SBVError !EvalErrorEx | SBVResult !SVal !a -- safety predicate and result instance Functor SBVResult where fmap _ (SBVError err) = SBVError err fmap f (SBVResult p x) = SBVResult p (f x) instance Applicative SBVResult where pure = SBVResult svTrue SBVError err <*> _ = SBVError err _ <*> SBVError err = SBVError err SBVResult p1 f <*> SBVResult p2 x = SBVResult (svAnd p1 p2) (f x) instance Monad SBVResult where return = pure SBVError err >>= _ = SBVError err SBVResult px x >>= m = case m x of SBVError err -> SBVError err SBVResult pm z -> SBVResult (svAnd px pm) z newtype SBVEval a = SBVEval{ sbvEval :: Eval (SBVResult a) } deriving (Functor) instance Applicative SBVEval where pure = SBVEval . pure . pure f <*> x = SBVEval $ do f' <- sbvEval f x' <- sbvEval x pure (f' <*> x') instance Monad SBVEval where return = pure x >>= f = SBVEval $ sbvEval x >>= \case SBVError err -> pure (SBVError err) SBVResult px x' -> sbvEval (f x') >>= \case SBVError err -> pure (SBVError err) SBVResult pz z -> pure (SBVResult (svAnd px pz) z) instance MonadIO SBVEval where liftIO m = SBVEval $ fmap pure (liftIO m) addDefEqn :: SBV -> SVal -> IO () addDefEqn (SBV _ relsVar) b = modifyMVar_ relsVar (pure . svAnd b) -- Symbolic Big-endian Words ------------------------------------------------------- instance Backend SBV where type SBit SBV = SVal type SWord SBV = SVal type SInteger SBV = SVal type SFloat SBV = () -- XXX: not implemented type SEval SBV = SBVEval raiseError _ err = SBVEval $ do stk <- getCallStack pure (SBVError (EvalErrorEx stk err)) assertSideCondition sym cond err | Just False <- svAsBool cond = raiseError sym err | otherwise = SBVEval (pure (SBVResult cond ())) isReady _ (SBVEval m) = SBVEval $ maybeReady m >>= \case Just x -> pure (Just <$> x) Nothing -> pure (pure Nothing) sDelayFill _ m retry msg = SBVEval $ do m' <- delayFill (sbvEval m) (sbvEval <$> retry) msg pure (pure (SBVEval m')) sSpark _ m = SBVEval $ do m' <- evalSpark (sbvEval m) pure (pure (SBVEval m')) sDeclareHole _ msg = SBVEval $ do (hole, fill) <- blackhole msg pure (pure (SBVEval hole, \m -> SBVEval (fmap pure $ fill (sbvEval m)))) sModifyCallStack _ f (SBVEval m) = SBVEval $ modifyCallStack f m sGetCallStack _ = SBVEval (pure <$> getCallStack) mergeEval _sym f c mx my = SBVEval $ do rx <- sbvEval mx ry <- sbvEval my case (rx, ry) of (SBVError err, SBVError _) -> pure $ SBVError err -- arbitrarily choose left error to report (SBVError _, SBVResult p y) -> pure $ SBVResult (svAnd (svNot c) p) y (SBVResult p x, SBVError _) -> pure $ SBVResult (svAnd c p) x (SBVResult px x, SBVResult py y) -> do zr <- sbvEval (f c x y) case zr of SBVError err -> pure $ SBVError err SBVResult pz z -> pure $ SBVResult (svAnd (svIte c px py) pz) z wordLen _ v = toInteger (intSizeOf v) wordAsChar _ v = integerToChar <$> svAsInteger v iteBit _ b x y = pure $! svSymbolicMerge KBool True b x y iteWord _ b x y = pure $! svSymbolicMerge (kindOf x) True b x y iteInteger _ b x y = pure $! svSymbolicMerge KUnbounded True b x y bitAsLit _ b = svAsBool b wordAsLit _ w = case svAsInteger w of Just x -> Just (toInteger (intSizeOf w), x) Nothing -> Nothing integerAsLit _ v = svAsInteger v bitLit _ b = svBool b wordLit _ n x = pure $! literalSWord (fromInteger n) x integerLit _ x = pure $! svInteger KUnbounded x bitEq _ x y = pure $! svEqual x y bitOr _ x y = pure $! svOr x y bitAnd _ x y = pure $! svAnd x y bitXor _ x y = pure $! svXOr x y bitComplement _ x = pure $! svNot x wordBit _ x idx = pure $! svTestBit x (intSizeOf x - 1 - fromInteger idx) wordUpdate _ x idx b = pure $! 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 = pure $! packSBV bs unpackWord _ x = pure $! unpackSBV x wordEq _ x y = pure $! svEqual x y wordLessThan _ x y = pure $! svLessThan x y wordGreaterThan _ x y = pure $! svGreaterThan x y wordSignedLessThan _ x y = pure $! svLessThan sx sy where sx = svSign x sy = svSign y joinWord _ x y = pure $! svJoin x y splitWord _ _leftW rightW w = pure ( svExtract (intSizeOf w - 1) (fromInteger rightW) w , svExtract (fromInteger rightW - 1) 0 w ) extractWord _ len start w = pure $! svExtract (fromInteger start + fromInteger len - 1) (fromInteger start) w wordAnd _ a b = pure $! svAnd a b wordOr _ a b = pure $! svOr a b wordXor _ a b = pure $! svXOr a b wordComplement _ a = pure $! svNot a wordPlus _ a b = pure $! svPlus a b wordMinus _ a b = pure $! svMinus a b wordMult _ a b = pure $! svTimes a b wordNegate _ a = pure $! svUNeg a wordShiftLeft _ a b = pure $! shl a b wordShiftRight _ a b = pure $! lshr a b wordRotateLeft _ a b = pure $! SBV.svRotateLeft a b wordRotateRight _ a b = pure $! SBV.svRotateRight a b wordSignedShiftRight _ a b = pure $! ashr a b wordDiv sym a b = do let z = literalSWord (intSizeOf b) 0 assertSideCondition sym (svNot (svEqual b z)) DivideByZero pure $! svQuot a b wordMod sym a b = do let z = literalSWord (intSizeOf b) 0 assertSideCondition sym (svNot (svEqual b z)) DivideByZero pure $! svRem a b wordSignedDiv sym a b = do let z = literalSWord (intSizeOf b) 0 assertSideCondition sym (svNot (svEqual b z)) DivideByZero pure $! signedQuot a b wordSignedMod sym a b = do let z = literalSWord (intSizeOf b) 0 assertSideCondition sym (svNot (svEqual b z)) DivideByZero pure $! signedRem a b wordLg2 _ a = sLg2 a wordToInt _ x = pure $! svToInteger x wordToSignedInt _ x = pure $! svToInteger (svSign x) wordFromInt _ w i = pure $! svFromInteger w i intEq _ a b = pure $! svEqual a b intLessThan _ a b = pure $! svLessThan a b intGreaterThan _ a b = pure $! svGreaterThan a b intPlus _ a b = pure $! svPlus a b intMinus _ a b = pure $! svMinus a b intMult _ a b = pure $! svTimes a b intNegate _ a = pure $! SBV.svUNeg a intDiv sym a b = do let z = svInteger KUnbounded 0 assertSideCondition sym (svNot (svEqual b z)) DivideByZero let p = svLessThan z b pure $! svSymbolicMerge KUnbounded True p (svQuot a b) (svQuot (svUNeg a) (svUNeg b)) intMod sym a b = do let z = svInteger KUnbounded 0 assertSideCondition sym (svNot (svEqual b z)) DivideByZero let p = svLessThan z b pure $! svSymbolicMerge KUnbounded True p (svRem a b) (svUNeg (svRem (svUNeg a) (svUNeg b))) -- NB, we don't do reduction here intToZn _ _m a = pure a znToInt _ 0 _ = evalPanic "znToInt" ["0 modulus not allowed"] znToInt _ m a = do let m' = svInteger KUnbounded m pure $! svRem a m' znEq _ 0 _ _ = evalPanic "znEq" ["0 modulus not allowed"] znEq sym m a b = svDivisible sym m (SBV.svMinus a b) znPlus sym m a b = sModAdd sym m a b znMinus sym m a b = sModSub sym m a b znMult sym m a b = sModMult sym m a b znNegate sym m a = sModNegate sym m a znRecip = sModRecip fpAsLit _ _ = Nothing iteFloat _ _ _ _ = unsupported "iteFloat" fpNaN _ _ _ = unsupported "fpNaN" fpPosInf _ _ _ = unsupported "fpPosInf" fpExactLit _ _ = unsupported "fpExactLit" fpLit _ _ _ _ = unsupported "fpLit" fpLogicalEq _ _ _ = unsupported "fpLogicalEq" fpEq _ _ _ = unsupported "fpEq" fpLessThan _ _ _ = unsupported "fpLessThan" fpGreaterThan _ _ _ = unsupported "fpGreaterThan" fpPlus _ _ _ _ = unsupported "fpPlus" fpMinus _ _ _ _ = unsupported "fpMinus" fpMult _ _ _ _ = unsupported "fpMult" fpDiv _ _ _ _ = unsupported "fpDiv" fpAbs _ _ = unsupported "fpAbs" fpSqrt _ _ _ = unsupported "fpSqrt" fpFMA _ _ _ _ _ = unsupported "fpFMA" fpNeg _ _ = unsupported "fpNeg" fpFromInteger _ _ _ _ _ = unsupported "fpFromInteger" fpToInteger _ _ _ _ = unsupported "fpToInteger" fpIsZero _ _ = unsupported "fpIsZero" fpIsInf _ _ = unsupported "fpIsInf" fpIsNeg _ _ = unsupported "fpIsNeg" fpIsNaN _ _ = unsupported "fpIsNaN" fpIsNorm _ _ = unsupported "fpIsNorm" fpIsSubnorm _ _ = unsupported "fpIsSubnorm" fpToBits _ _ = unsupported "fpToBits" fpFromBits _ _ _ _ = unsupported "fpFromBits" fpToRational _ _ = unsupported "fpToRational" fpFromRational _ _ _ _ _ = unsupported "fpFromRational" unsupported :: String -> SEval SBV a unsupported x = liftIO (X.throw (UnsupportedSymbolicOp x)) svToInteger :: SWord SBV -> SInteger SBV svToInteger w = case svAsInteger w of Nothing -> svFromIntegral KUnbounded w Just x -> svInteger KUnbounded x svFromInteger :: Integer -> SInteger SBV -> SWord SBV 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 ("[SBV] " ++ cxt) sModAdd :: SBV -> Integer -> SInteger SBV -> SInteger SBV -> SEval SBV (SInteger SBV) sModAdd _ 0 _ _ = evalPanic "sModAdd" ["0 modulus not allowed"] sModAdd sym modulus x y = case (SBV.svAsInteger x, SBV.svAsInteger y) of (Just i, Just j) -> integerLit sym ((i + j) `mod` modulus) _ -> pure $ SBV.svPlus x y sModSub :: SBV -> Integer -> SInteger SBV -> SInteger SBV -> SEval SBV (SInteger SBV) sModSub _ 0 _ _ = evalPanic "sModSub" ["0 modulus not allowed"] sModSub sym modulus x y = case (SBV.svAsInteger x, SBV.svAsInteger y) of (Just i, Just j) -> integerLit sym ((i - j) `mod` modulus) _ -> pure $ SBV.svMinus x y sModNegate :: SBV -> Integer -> SInteger SBV -> SEval SBV (SInteger SBV) sModNegate _ 0 _ = evalPanic "sModNegate" ["0 modulus not allowed"] sModNegate sym modulus x = case SBV.svAsInteger x of Just i -> integerLit sym ((negate i) `mod` modulus) _ -> pure $ SBV.svUNeg x sModMult :: SBV -> Integer -> SInteger SBV -> SInteger SBV -> SEval SBV (SInteger SBV) sModMult _ 0 _ _ = evalPanic "sModMult" ["0 modulus not allowed"] sModMult sym modulus x y = case (SBV.svAsInteger x, SBV.svAsInteger y) of (Just i, Just j) -> integerLit sym ((i * j) `mod` modulus) _ -> pure $ SBV.svTimes x y -- Create a fresh constant and assert that it is the -- multiplicitive inverse of x; return the constant. -- Such an inverse must exist under the precondition -- that the modulus is prime and the input is nonzero. sModRecip :: SBV -> Integer {- ^ modulus: must be prime -} -> SInteger SBV -> SEval SBV (SInteger SBV) sModRecip _sym 0 _ = panic "sModRecip" ["0 modulus not allowed"] sModRecip sym m x -- If the input is concrete, evaluate the answer | Just xi <- svAsInteger x = case Integer.integerRecipMod xi m of Just r -> integerLit sym r Nothing -> raiseError sym DivideByZero -- If the input is symbolic, create a new symbolic constant -- and assert that it is the desired multiplicitive inverse. -- Such an inverse will exist under the precondition that -- the modulus is prime, and as long as the input is nonzero. | otherwise = do divZero <- svDivisible sym m x assertSideCondition sym (svNot divZero) DivideByZero z <- liftIO (freshSInteger_ sym) let xz = svTimes x z rel <- znEq sym m xz (svInteger KUnbounded 1) let range = svAnd (svLessThan (svInteger KUnbounded 0) z) (svLessThan z (svInteger KUnbounded m)) liftIO (addDefEqn sym (svAnd range (svOr divZero rel))) return z -- | Ceiling (log_2 x) sLg2 :: SWord SBV -> SEval SBV (SWord SBV) sLg2 x = pure $ 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) svDivisible :: SBV -> Integer -> SInteger SBV -> SEval SBV (SBit SBV) svDivisible sym m x = do m' <- integerLit sym m z <- integerLit sym 0 pure $ SBV.svEqual (SBV.svRem x m') z signedQuot :: SWord SBV -> SWord SBV -> SWord SBV signedQuot x y = SBV.svUnsign (SBV.svQuot (SBV.svSign x) (SBV.svSign y)) signedRem :: SWord SBV -> SWord SBV -> SWord SBV signedRem x y = SBV.svUnsign (SBV.svRem (SBV.svSign x) (SBV.svSign y)) ashr :: SVal -> SVal -> SVal ashr x idx = case SBV.svAsInteger idx of Just i -> SBV.svUnsign (SBV.svShr (SBV.svSign x) (fromInteger i)) Nothing -> SBV.svUnsign (SBV.svShiftRight (SBV.svSign x) idx) lshr :: SVal -> SVal -> SVal lshr x idx = case SBV.svAsInteger idx of Just i -> SBV.svShr x (fromInteger i) Nothing -> SBV.svShiftRight x idx shl :: SVal -> SVal -> SVal shl x idx = case SBV.svAsInteger idx of Just i -> SBV.svShl x (fromInteger i) Nothing -> SBV.svShiftLeft x idx cryptol-3.0.0/src/Cryptol/Backend/SeqMap.hs0000644000000000000000000002265107346545000016701 0ustar0000000000000000-- | -- Module : Cryptol.Backend.SeqMap -- Copyright : (c) 2013-2021 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Cryptol.Backend.SeqMap ( -- * Sequence Maps SeqMap , indexSeqMap , lookupSeqMap , finiteSeqMap , infiniteSeqMap , enumerateSeqMap , streamSeqMap , reverseSeqMap , updateSeqMap , dropSeqMap , concatSeqMap , splitSeqMap , memoMap , delaySeqMap , zipSeqMap , mapSeqMap , mergeSeqMap , barrelShifter , shiftSeqByInteger , IndexSegment(..) ) where import qualified Control.Exception as X import Control.Monad import Control.Monad.IO.Class import Data.Bits import Data.List import Data.IORef import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Cryptol.Backend import Cryptol.Backend.Concrete (Concrete) import Cryptol.Backend.Monad (Unsupported(..)) import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) import Cryptol.Utils.Panic -- | A sequence map represents a mapping from nonnegative integer indices -- to values. These are used to represent both finite and infinite sequences. data SeqMap sym a = IndexSeqMap !(Integer -> SEval sym a) | UpdateSeqMap !(Map Integer (SEval sym a)) !(SeqMap sym a) | MemoSeqMap !Nat' !(IORef (Map Integer a)) !(IORef (Integer -> SEval sym a)) indexSeqMap :: (Integer -> SEval sym a) -> SeqMap sym a indexSeqMap = IndexSeqMap lookupSeqMap :: Backend sym => SeqMap sym a -> Integer -> SEval sym a lookupSeqMap (IndexSeqMap f) i = f i lookupSeqMap (UpdateSeqMap m xs) i = case Map.lookup i m of Just x -> x Nothing -> lookupSeqMap xs i lookupSeqMap (MemoSeqMap sz cache eval) i = do mz <- liftIO (Map.lookup i <$> readIORef cache) case mz of Just z -> return z Nothing -> do f <- liftIO (readIORef eval) v <- f i msz <- liftIO $ atomicModifyIORef' cache (\m -> let m' = Map.insert i v m in (m', Map.size m')) -- If we memoize the entire map, overwrite the evaluation closure to let -- the garbage collector reap it when (case sz of Inf -> False; Nat sz' -> toInteger msz >= sz') (liftIO (writeIORef eval (\j -> panic "lookupSeqMap" ["Messed up size accounting", show sz, show j]))) return v instance Backend sym => Functor (SeqMap sym) where fmap f xs = IndexSeqMap (\i -> f <$> lookupSeqMap xs i) -- | Generate a finite sequence map from a list of values finiteSeqMap :: Backend sym => sym -> [SEval sym a] -> SeqMap sym a finiteSeqMap sym xs = UpdateSeqMap (Map.fromList (zip [0..] xs)) (IndexSeqMap (\i -> invalidIndex sym i)) -- | Generate an infinite sequence map from a stream of values infiniteSeqMap :: Backend sym => sym -> [SEval sym a] -> SEval sym (SeqMap sym a) infiniteSeqMap sym xs = -- TODO: use an int-trie? memoMap sym Inf (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 :: (Backend sym, Integral n) => n -> SeqMap sym a -> [SEval sym a] enumerateSeqMap n m = [ lookupSeqMap m i | i <- [0 .. (toInteger n)-1] ] -- | Create an infinite stream of all the values in a sequence map streamSeqMap :: Backend sym => SeqMap sym a -> [SEval sym a] streamSeqMap m = [ lookupSeqMap m i | i <- [0..] ] -- | Reverse the order of a finite sequence map reverseSeqMap :: Backend sym => Integer {- ^ Size of the sequence map -} -> SeqMap sym a -> SeqMap sym a reverseSeqMap n vals = IndexSeqMap $ \i -> lookupSeqMap vals (n - 1 - i) updateSeqMap :: SeqMap sym a -> Integer -> SEval sym a -> SeqMap sym a updateSeqMap (UpdateSeqMap m sm) i x = UpdateSeqMap (Map.insert i x m) sm updateSeqMap xs i x = UpdateSeqMap (Map.singleton i x) xs -- | Concatenate the first @n@ values of the first sequence map onto the -- beginning of the second sequence map. concatSeqMap :: Backend sym => Integer -> SeqMap sym a -> SeqMap sym a -> SeqMap sym a 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 :: Backend sym => Integer -> SeqMap sym a -> (SeqMap sym a, SeqMap sym a) 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 :: Backend sym => Integer -> SeqMap sym a -> SeqMap sym a dropSeqMap 0 xs = xs dropSeqMap n xs = IndexSeqMap $ \i -> lookupSeqMap xs (i+n) delaySeqMap :: Backend sym => sym -> SEval sym (SeqMap sym a) -> SEval sym (SeqMap sym a) delaySeqMap sym xs = do xs' <- sDelay sym xs pure $ IndexSeqMap $ \i -> do m <- xs'; lookupSeqMap m i -- | Given a sequence map, return a new sequence map that is memoized using -- a finite map memo table. memoMap :: Backend sym => sym -> Nat' -> SeqMap sym a -> SEval sym (SeqMap sym a) -- Sequence is alreay memoized, just return it memoMap _sym _sz x@(MemoSeqMap{}) = pure x memoMap sym sz x = do stk <- sGetCallStack sym cache <- liftIO $ newIORef $ Map.empty evalRef <- liftIO $ newIORef $ eval stk return (MemoSeqMap sz cache evalRef) where eval stk i = sWithCallStack sym stk (lookupSeqMap x i) -- | Apply the given evaluation function pointwise to the two given -- sequence maps. zipSeqMap :: Backend sym => sym -> (a -> a -> SEval sym a) -> Nat' -> SeqMap sym a -> SeqMap sym a -> SEval sym (SeqMap sym a) zipSeqMap sym f sz x y = memoMap sym sz (IndexSeqMap $ \i -> join (f <$> lookupSeqMap x i <*> lookupSeqMap y i)) -- | Apply the given function to each value in the given sequence map mapSeqMap :: Backend sym => sym -> (a -> SEval sym a) -> Nat' -> SeqMap sym a -> SEval sym (SeqMap sym a) mapSeqMap sym f sz x = memoMap sym sz (IndexSeqMap $ \i -> f =<< lookupSeqMap x i) {-# INLINE mergeSeqMap #-} mergeSeqMap :: Backend sym => sym -> (SBit sym -> a -> a -> SEval sym a) -> SBit sym -> SeqMap sym a -> SeqMap sym a -> SeqMap sym a mergeSeqMap sym f c x y = IndexSeqMap $ \i -> mergeEval sym f c (lookupSeqMap x i) (lookupSeqMap y i) {-# INLINE shiftSeqByInteger #-} shiftSeqByInteger :: Backend sym => sym -> (SBit sym -> a -> a -> SEval sym a) {- ^ if/then/else operation of values -} -> (Integer -> Integer -> Maybe Integer) {- ^ reindexing operation -} -> SEval sym a {- ^ zero value -} -> Nat' {- ^ size of the sequence -} -> SeqMap sym a {- ^ sequence to shift -} -> SInteger sym {- ^ shift amount, assumed to be in range [0,len] -} -> SEval sym (SeqMap sym a) shiftSeqByInteger sym merge reindex zro m xs idx | Just j <- integerAsLit sym idx = shiftOp xs j | otherwise = do (n, idx_bits) <- enumerateIntBits sym m idx barrelShifter sym merge shiftOp m xs n (map BitIndexSegment idx_bits) where shiftOp vs shft = pure $ indexSeqMap $ \i -> case reindex i shft of Nothing -> zro Just i' -> lookupSeqMap vs i' data IndexSegment sym = BitIndexSegment (SBit sym) | WordIndexSegment (SWord sym) {-# SPECIALIZE barrelShifter :: Concrete -> (SBit Concrete -> a -> a -> SEval Concrete a) -> (SeqMap Concrete a -> Integer -> SEval Concrete (SeqMap Concrete a)) -> Nat' -> SeqMap Concrete a -> Integer -> [IndexSegment Concrete] -> SEval Concrete (SeqMap Concrete a) #-} barrelShifter :: Backend sym => sym -> (SBit sym -> a -> a -> SEval sym a) {- ^ if/then/else operation of values -} -> (SeqMap sym a -> Integer -> SEval sym (SeqMap sym a)) {- ^ concrete shifting operation -} -> Nat' {- ^ Size of the map being shifted -} -> SeqMap sym a {- ^ initial value -} -> Integer {- Number of bits in shift amount -} -> [IndexSegment sym] {- ^ segments of the shift amount, in big-endian order -} -> SEval sym (SeqMap sym a) barrelShifter sym mux shift_op sz x0 n0 bs0 | n0 >= toInteger (maxBound :: Int) = liftIO (X.throw (UnsupportedSymbolicOp ("Barrel shifter with too many bits in shift amount: " ++ show n0))) | otherwise = go x0 (fromInteger n0) bs0 where go x !_n [] = return x go x !n (WordIndexSegment w:bs) = let n' = n - fromInteger (wordLen sym w) in case wordAsLit sym w of Just (_,0) -> go x n' bs Just (_,j) -> do x_shft <- shift_op x (j * bit n') go x_shft n' bs Nothing -> do wbs <- unpackWord sym w go x n (map BitIndexSegment wbs ++ bs) go x !n (BitIndexSegment b:bs) = let n' = n - 1 in case bitAsLit sym b of Just False -> go x n' bs Just True -> do x_shft <- shift_op x (bit n') go x_shft n' bs Nothing -> do x_shft <- shift_op x (bit n') x' <- memoMap sym sz (mergeSeqMap sym mux b x_shft x) go x' n' bs cryptol-3.0.0/src/Cryptol/Backend/What4.hs0000644000000000000000000005502007346545000016476 0ustar0000000000000000-- | -- Module : Cryptol.Backend.What4 -- Copyright : (c) 2020 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} module Cryptol.Backend.What4 where import qualified Control.Exception as X import Control.Concurrent.MVar import Control.Monad (foldM,ap,liftM) import Control.Monad.IO.Class import Data.Bits (bit) import qualified Data.BitVector.Sized as BV import Data.List import Data.Map (Map) import Data.Set (Set) import Data.Text (Text) import Data.Parameterized.NatRepr import Data.Parameterized.Some import qualified GHC.Num.Compat as Integer import qualified What4.Interface as W4 import qualified What4.SWord as SW import qualified What4.SFloat as FP import Cryptol.Backend import Cryptol.Backend.FloatHelpers import Cryptol.Backend.Monad ( Eval(..), EvalError(..), EvalErrorEx(..) , Unsupported(..), delayFill, blackhole, evalSpark , modifyCallStack, getCallStack, maybeReady ) import Cryptol.Utils.Panic data What4 sym = What4 { w4 :: sym , w4defs :: MVar (W4.Pred sym) , w4funs :: MVar (What4FunCache sym) , w4uninterpWarns :: MVar (Set Text) } type What4FunCache sym = Map Text (SomeSymFn sym) data SomeSymFn sym = forall args ret. SomeSymFn (W4.SymFn sym args ret) {- | This is the monad used for symbolic evaluation. It adds to aspects to 'Eval'---'WConn' keeps track of the backend and collects definitional predicates, and 'W4Eval` adds support for partially defined values -} newtype W4Eval sym a = W4Eval { evalPartial :: W4Conn sym (W4Result sym a) } {- | This layer has the symbolic back-end, and can keep track of definitional predicates used when working with uninterpreted constants defined via a property. -} newtype W4Conn sym a = W4Conn { evalConn :: sym -> Eval a } -- | The symbolic value we computed. data W4Result sym a = W4Error !EvalErrorEx -- ^ A malformed value | W4Result !(W4.Pred sym) !a -- ^ safety predicate and result: the result only makes sense when -- the predicate holds. deriving Functor -------------------------------------------------------------------------------- -- Moving between the layers w4Eval :: W4Eval sym a -> sym -> Eval (W4Result sym a) w4Eval (W4Eval (W4Conn m)) = m w4Thunk :: Eval (W4Result sym a) -> W4Eval sym a w4Thunk m = W4Eval (W4Conn \_ -> m) -- | A value with no context. doEval :: W4.IsSymExprBuilder sym => Eval a -> W4Conn sym a doEval m = W4Conn \_sym -> m -- | A total value. total :: W4.IsSymExprBuilder sym => W4Conn sym a -> W4Eval sym a total m = W4Eval do sym <- getSym W4Result (W4.backendPred sym True) <$> m -------------------------------------------------------------------------------- -- Operations in WConn instance W4.IsSymExprBuilder sym => Functor (W4Conn sym) where fmap = liftM instance W4.IsSymExprBuilder sym => Applicative (W4Conn sym) where pure = doEval . pure (<*>) = ap instance W4.IsSymExprBuilder sym => Monad (W4Conn sym) where m1 >>= f = W4Conn \sym -> do res1 <- evalConn m1 sym evalConn (f res1) sym instance W4.IsSymExprBuilder sym => MonadIO (W4Conn sym) where liftIO = doEval . liftIO -- | Access the symbolic back-end getSym :: W4Conn sym sym getSym = W4Conn \sym -> pure sym -- | Record a definition. --addDef :: W4.Pred sym -> W4Conn sym () --addDef p = W4Conn \_ -> pure W4Defs { w4Defs = p, w4Result = () } -- | Compute conjunction. w4And :: W4.IsSymExprBuilder sym => W4.Pred sym -> W4.Pred sym -> W4Conn sym (W4.Pred sym) w4And p q = do sym <- getSym liftIO (W4.andPred sym p q) -- | Compute negation. w4Not :: W4.IsSymExprBuilder sym => W4.Pred sym -> W4Conn sym (W4.Pred sym) w4Not p = do sym <- getSym liftIO (W4.notPred sym p) -- | Compute if-then-else. w4ITE :: W4.IsSymExprBuilder sym => W4.Pred sym -> W4.Pred sym -> W4.Pred sym -> W4Conn sym (W4.Pred sym) w4ITE ifP ifThen ifElse = do sym <- getSym liftIO (W4.itePred sym ifP ifThen ifElse) -------------------------------------------------------------------------------- -- Operations in W4Eval instance W4.IsSymExprBuilder sym => Functor (W4Eval sym) where fmap = liftM instance W4.IsSymExprBuilder sym => Applicative (W4Eval sym) where pure = total . pure (<*>) = ap instance W4.IsSymExprBuilder sym => Monad (W4Eval sym) where m1 >>= f = W4Eval do res1 <- evalPartial m1 case res1 of W4Error err -> pure (W4Error err) W4Result px x' -> do res2 <- evalPartial (f x') case res2 of W4Result py y -> do pz <- w4And px py pure (W4Result pz y) W4Error _ -> pure res2 instance W4.IsSymExprBuilder sym => MonadIO (W4Eval sym) where liftIO = total . liftIO -- | Add a definitional equation. -- This will always be asserted when we make queries to the solver. addDefEqn :: W4.IsSymExprBuilder sym => What4 sym -> W4.Pred sym -> W4Eval sym () addDefEqn sym p = liftIO (modifyMVar_ (w4defs sym) (W4.andPred (w4 sym) p)) -- | Add s safety condition. addSafety :: W4.IsSymExprBuilder sym => W4.Pred sym -> W4Eval sym () addSafety p = W4Eval (pure (W4Result p ())) -- | A fully undefined symbolic value evalError :: W4.IsSymExprBuilder sym => EvalError -> W4Eval sym a evalError err = W4Eval $ W4Conn $ \_sym -> do stk <- getCallStack pure (W4Error (EvalErrorEx stk err)) -------------------------------------------------------------------------------- assertBVDivisor :: W4.IsSymExprBuilder sym => What4 sym -> SW.SWord sym -> W4Eval sym () assertBVDivisor sym x = do p <- liftIO (SW.bvIsNonzero (w4 sym) x) assertSideCondition sym p DivideByZero assertIntDivisor :: W4.IsSymExprBuilder sym => What4 sym -> W4.SymInteger sym -> W4Eval sym () assertIntDivisor sym x = do p <- liftIO (W4.notPred (w4 sym) =<< W4.intEq (w4 sym) x =<< W4.intLit (w4 sym) 0) assertSideCondition sym p DivideByZero instance W4.IsSymExprBuilder sym => Backend (What4 sym) where type SBit (What4 sym) = W4.Pred sym type SWord (What4 sym) = SW.SWord sym type SInteger (What4 sym) = W4.SymInteger sym type SFloat (What4 sym) = FP.SFloat sym type SEval (What4 sym) = W4Eval sym raiseError _ = evalError assertSideCondition _ cond err | Just False <- W4.asConstantPred cond = evalError err | otherwise = addSafety cond isReady sym m = W4Eval $ W4Conn $ \_ -> maybeReady (w4Eval m (w4 sym)) >>= \case Just x -> pure (Just <$> x) Nothing -> pure (W4Result (W4.backendPred (w4 sym) True) Nothing) sDelayFill _ m retry msg = total do sym <- getSym doEval (w4Thunk <$> delayFill (w4Eval m sym) (w4Eval <$> retry <*> pure sym) msg) sSpark _ m = total do sym <- getSym doEval (w4Thunk <$> evalSpark (w4Eval m sym)) sModifyCallStack _ f (W4Eval (W4Conn m)) = W4Eval (W4Conn \sym -> modifyCallStack f (m sym)) sGetCallStack _ = total (doEval getCallStack) sDeclareHole _ msg = total do (hole, fill) <- doEval (blackhole msg) pure ( w4Thunk hole , \m -> total do sym <- getSym doEval (fill (w4Eval m sym)) ) mergeEval _sym f c mx my = W4Eval do rx <- evalPartial mx ry <- evalPartial my case (rx, ry) of (W4Error err, W4Error _) -> pure (W4Error err) -- arbitrarily choose left error to report (W4Error _, W4Result p y) -> do p' <- w4And p =<< w4Not c pure (W4Result p' y) (W4Result p x, W4Error _) -> do p' <- w4And p c pure (W4Result p' x) (W4Result px x, W4Result py y) -> do zr <- evalPartial (f c x y) case zr of W4Error err -> pure $ W4Error err W4Result pz z -> do p' <- w4And pz =<< w4ITE c px py pure (W4Result p' z) wordAsChar _ bv | SW.bvWidth bv == 8 = toEnum . fromInteger <$> SW.bvAsUnsignedInteger bv | otherwise = Nothing wordLen _ bv = SW.bvWidth bv bitLit sym b = W4.backendPred (w4 sym) b bitAsLit _ v = W4.asConstantPred v wordLit sym intw i | Just (Some w) <- someNat intw = case isPosNat w of Nothing -> pure $ SW.ZBV Just LeqProof -> SW.DBV <$> liftIO (W4.bvLit (w4 sym) w (BV.mkBV w i)) | otherwise = panic "what4: wordLit" ["invalid bit width:", show intw ] wordAsLit _ v | Just x <- SW.bvAsUnsignedInteger v = Just (SW.bvWidth v, x) | otherwise = Nothing integerLit sym i = liftIO (W4.intLit (w4 sym) i) integerAsLit _ v = W4.asInteger v iteBit sym c x y = liftIO (W4.itePred (w4 sym) c x y) iteWord sym c x y = liftIO (SW.bvIte (w4 sym) c x y) iteInteger sym c x y = liftIO (W4.intIte (w4 sym) c x y) iteFloat sym p x y = liftIO (FP.fpIte (w4 sym) p x y) bitEq sym x y = liftIO (W4.eqPred (w4 sym) x y) bitAnd sym x y = liftIO (W4.andPred (w4 sym) x y) bitOr sym x y = liftIO (W4.orPred (w4 sym) x y) bitXor sym x y = liftIO (W4.xorPred (w4 sym) x y) bitComplement sym x = liftIO (W4.notPred (w4 sym) x) wordBit sym bv idx = liftIO (SW.bvAtBE (w4 sym) bv idx) wordUpdate sym bv idx b = liftIO (SW.bvSetBE (w4 sym) bv idx b) packWord sym bs = do z <- wordLit sym (genericLength bs) 0 let f w (idx,b) = wordUpdate sym w idx b foldM f z (zip [0..] bs) unpackWord sym bv = liftIO $ mapM (SW.bvAtBE (w4 sym) bv) [0 .. SW.bvWidth bv-1] joinWord sym x y = liftIO $ SW.bvJoin (w4 sym) x y splitWord _sym 0 _ bv = pure (SW.ZBV, bv) splitWord _sym _ 0 bv = pure (bv, SW.ZBV) splitWord sym lw rw bv = liftIO $ do l <- SW.bvSliceBE (w4 sym) 0 lw bv r <- SW.bvSliceBE (w4 sym) lw rw bv return (l, r) extractWord sym bits idx bv = liftIO $ SW.bvSliceLE (w4 sym) idx bits bv wordEq sym x y = liftIO (SW.bvEq (w4 sym) x y) wordLessThan sym x y = liftIO (SW.bvult (w4 sym) x y) wordGreaterThan sym x y = liftIO (SW.bvugt (w4 sym) x y) wordSignedLessThan sym x y = liftIO (SW.bvslt (w4 sym) x y) wordOr sym x y = liftIO (SW.bvOr (w4 sym) x y) wordAnd sym x y = liftIO (SW.bvAnd (w4 sym) x y) wordXor sym x y = liftIO (SW.bvXor (w4 sym) x y) wordComplement sym x = liftIO (SW.bvNot (w4 sym) x) wordPlus sym x y = liftIO (SW.bvAdd (w4 sym) x y) wordMinus sym x y = liftIO (SW.bvSub (w4 sym) x y) wordMult sym x y = liftIO (SW.bvMul (w4 sym) x y) wordNegate sym x = liftIO (SW.bvNeg (w4 sym) x) wordLg2 sym x = sLg2 (w4 sym) x wordShiftLeft sym x y = w4bvShl (w4 sym) x y wordShiftRight sym x y = w4bvLshr (w4 sym) x y wordRotateLeft sym x y = w4bvRol (w4 sym) x y wordRotateRight sym x y = w4bvRor (w4 sym) x y wordSignedShiftRight sym x y = w4bvAshr (w4 sym) x y wordDiv sym x y = do assertBVDivisor sym y liftIO (SW.bvUDiv (w4 sym) x y) wordMod sym x y = do assertBVDivisor sym y liftIO (SW.bvURem (w4 sym) x y) wordSignedDiv sym x y = do assertBVDivisor sym y liftIO (SW.bvSDiv (w4 sym) x y) wordSignedMod sym x y = do assertBVDivisor sym y liftIO (SW.bvSRem (w4 sym) x y) wordToInt sym x = liftIO (SW.bvToInteger (w4 sym) x) wordToSignedInt sym x = liftIO (SW.sbvToInteger (w4 sym) x) wordFromInt sym width i = liftIO (SW.integerToBV (w4 sym) i width) intPlus sym x y = liftIO $ W4.intAdd (w4 sym) x y intMinus sym x y = liftIO $ W4.intSub (w4 sym) x y intMult sym x y = liftIO $ W4.intMul (w4 sym) x y intNegate sym x = liftIO $ W4.intNeg (w4 sym) x -- NB: What4's division operation provides SMTLib's euclidean division, -- which doesn't match the round-to-neg-infinity semantics of Cryptol, -- so we have to do some work to get the desired semantics. intDiv sym x y = do assertIntDivisor sym y liftIO $ do neg <- liftIO (W4.intLt (w4 sym) y =<< W4.intLit (w4 sym) 0) case W4.asConstantPred neg of Just False -> W4.intDiv (w4 sym) x y Just True -> do xneg <- W4.intNeg (w4 sym) x yneg <- W4.intNeg (w4 sym) y W4.intDiv (w4 sym) xneg yneg Nothing -> do xneg <- W4.intNeg (w4 sym) x yneg <- W4.intNeg (w4 sym) y zneg <- W4.intDiv (w4 sym) xneg yneg z <- W4.intDiv (w4 sym) x y W4.intIte (w4 sym) neg zneg z -- NB: What4's division operation provides SMTLib's euclidean division, -- which doesn't match the round-to-neg-infinity semantics of Cryptol, -- so we have to do some work to get the desired semantics. intMod sym x y = do assertIntDivisor sym y liftIO $ do neg <- liftIO (W4.intLt (w4 sym) y =<< W4.intLit (w4 sym) 0) case W4.asConstantPred neg of Just False -> W4.intMod (w4 sym) x y Just True -> do xneg <- W4.intNeg (w4 sym) x yneg <- W4.intNeg (w4 sym) y W4.intNeg (w4 sym) =<< W4.intMod (w4 sym) xneg yneg Nothing -> do xneg <- W4.intNeg (w4 sym) x yneg <- W4.intNeg (w4 sym) y z <- W4.intMod (w4 sym) x y zneg <- W4.intNeg (w4 sym) =<< W4.intMod (w4 sym) xneg yneg W4.intIte (w4 sym) neg zneg z intEq sym x y = liftIO $ W4.intEq (w4 sym) x y intLessThan sym x y = liftIO $ W4.intLt (w4 sym) x y intGreaterThan sym x y = liftIO $ W4.intLt (w4 sym) y x -- NB, we don't do reduction here on symbolic values intToZn sym m x | Just xi <- W4.asInteger x = liftIO $ W4.intLit (w4 sym) (xi `mod` m) | otherwise = pure x znToInt _ 0 _ = evalPanic "znToInt" ["0 modulus not allowed"] znToInt sym m x = liftIO (W4.intMod (w4 sym) x =<< W4.intLit (w4 sym) m) znEq _ 0 _ _ = evalPanic "znEq" ["0 modulus not allowed"] znEq sym m x y = liftIO $ do diff <- W4.intSub (w4 sym) x y W4.intDivisible (w4 sym) diff (fromInteger m) znPlus sym m x y = liftIO $ sModAdd (w4 sym) m x y znMinus sym m x y = liftIO $ sModSub (w4 sym) m x y znMult sym m x y = liftIO $ sModMult (w4 sym) m x y znNegate sym m x = liftIO $ sModNegate (w4 sym) m x znRecip = sModRecip -------------------------------------------------------------- fpLit sym e p r = liftIO $ FP.fpFromRationalLit (w4 sym) e p r fpAsLit _ f = BF e p <$> FP.fpAsLit f where (e,p) = FP.fpSize f fpExactLit sym BF{ bfExpWidth = e, bfPrecWidth = p, bfValue = bf } = liftIO (FP.fpFromBinary (w4 sym) e p =<< SW.bvLit (w4 sym) (e+p) (floatToBits e p bf)) fpNaN sym e p = liftIO (FP.fpNaN (w4 sym) e p) fpPosInf sym e p = liftIO (FP.fpPosInf (w4 sym) e p) fpToBits sym f = liftIO (FP.fpToBinary (w4 sym) f) fpFromBits sym e p w = liftIO (FP.fpFromBinary (w4 sym) e p w) fpEq sym x y = liftIO $ FP.fpEqIEEE (w4 sym) x y fpLessThan sym x y = liftIO $ FP.fpLtIEEE (w4 sym) x y fpGreaterThan sym x y = liftIO $ FP.fpGtIEEE (w4 sym) x y fpLogicalEq sym x y = liftIO $ FP.fpEq (w4 sym) x y fpPlus = fpBinArith FP.fpAdd fpMinus = fpBinArith FP.fpSub fpMult = fpBinArith FP.fpMul fpDiv = fpBinArith FP.fpDiv fpNeg sym x = liftIO $ FP.fpNeg (w4 sym) x fpAbs sym x = liftIO $ FP.fpAbs (w4 sym) x fpSqrt sym r x = do rm <- fpRoundingMode sym r liftIO $ FP.fpSqrt (w4 sym) rm x fpFMA sym r x y z = do rm <- fpRoundingMode sym r liftIO $ FP.fpFMA (w4 sym) rm x y z fpIsZero sym x = liftIO $ FP.fpIsZero (w4 sym) x fpIsNeg sym x = liftIO $ FP.fpIsNeg (w4 sym) x fpIsNaN sym x = liftIO $ FP.fpIsNaN (w4 sym) x fpIsInf sym x = liftIO $ FP.fpIsInf (w4 sym) x fpIsNorm sym x = liftIO $ FP.fpIsNorm (w4 sym) x fpIsSubnorm sym x = liftIO $ FP.fpIsSubnorm (w4 sym) x fpFromInteger sym e p r x = do rm <- fpRoundingMode sym r liftIO $ FP.fpFromInteger (w4 sym) e p rm x fpToInteger = fpCvtToInteger fpFromRational = fpCvtFromRational fpToRational = fpCvtToRational sModAdd :: W4.IsSymExprBuilder sym => sym -> Integer -> W4.SymInteger sym -> W4.SymInteger sym -> IO (W4.SymInteger sym) sModAdd _sym 0 _ _ = evalPanic "sModAdd" ["0 modulus not allowed"] sModAdd sym m x y | Just xi <- W4.asInteger x , Just yi <- W4.asInteger y = W4.intLit sym ((xi+yi) `mod` m) | otherwise = W4.intAdd sym x y sModSub :: W4.IsSymExprBuilder sym => sym -> Integer -> W4.SymInteger sym -> W4.SymInteger sym -> IO (W4.SymInteger sym) sModSub _sym 0 _ _ = evalPanic "sModSub" ["0 modulus not allowed"] sModSub sym m x y | Just xi <- W4.asInteger x , Just yi <- W4.asInteger y = W4.intLit sym ((xi-yi) `mod` m) | otherwise = W4.intSub sym x y sModMult :: W4.IsSymExprBuilder sym => sym -> Integer -> W4.SymInteger sym -> W4.SymInteger sym -> IO (W4.SymInteger sym) sModMult _sym 0 _ _ = evalPanic "sModMult" ["0 modulus not allowed"] sModMult sym m x y | Just xi <- W4.asInteger x , Just yi <- W4.asInteger y = W4.intLit sym ((xi*yi) `mod` m) | otherwise = W4.intMul sym x y sModNegate :: W4.IsSymExprBuilder sym => sym -> Integer -> W4.SymInteger sym -> IO (W4.SymInteger sym) sModNegate _sym 0 _ = evalPanic "sModMult" ["0 modulus not allowed"] sModNegate sym m x | Just xi <- W4.asInteger x = W4.intLit sym ((negate xi) `mod` m) | otherwise = W4.intNeg sym x -- | Try successive powers of 2 to find the first that dominates the input. -- We could perhaps reduce to using CLZ instead... sLg2 :: W4.IsSymExprBuilder sym => sym -> SW.SWord sym -> SEval (What4 sym) (SW.SWord sym) sLg2 sym x = liftIO $ go 0 where w = SW.bvWidth x lit n = SW.bvLit sym w (toInteger n) go i | toInteger i < w = do p <- SW.bvule sym x =<< lit (bit i) lazyIte (SW.bvIte sym) p (lit i) (go (i+1)) -- base case, should only happen when i = w go i = lit i -- Errors ---------------------------------------------------------------------- evalPanic :: String -> [String] -> a evalPanic cxt = panic ("[What4] " ++ cxt) lazyIte :: (W4.IsExpr p, Monad m) => (p W4.BaseBoolType -> a -> a -> m a) -> p W4.BaseBoolType -> m a -> m a -> m a lazyIte f c mx my | Just b <- W4.asConstantPred c = if b then mx else my | otherwise = do x <- mx y <- my f c x y w4bvShl :: W4.IsSymExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym) w4bvShl sym x y = liftIO $ SW.bvShl sym x y w4bvLshr :: W4.IsSymExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym) w4bvLshr sym x y = liftIO $ SW.bvLshr sym x y w4bvAshr :: W4.IsSymExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym) w4bvAshr sym x y = liftIO $ SW.bvAshr sym x y w4bvRol :: W4.IsSymExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym) w4bvRol sym x y = liftIO $ SW.bvRol sym x y w4bvRor :: W4.IsSymExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym) w4bvRor sym x y = liftIO $ SW.bvRor sym x y fpRoundingMode :: W4.IsSymExprBuilder sym => What4 sym -> SWord (What4 sym) -> SEval (What4 sym) W4.RoundingMode fpRoundingMode sym v = case wordAsLit sym v of Just (_w,i) -> case i of 0 -> pure W4.RNE 1 -> pure W4.RNA 2 -> pure W4.RTP 3 -> pure W4.RTN 4 -> pure W4.RTZ x -> raiseError sym (BadRoundingMode x) _ -> liftIO $ X.throwIO $ UnsupportedSymbolicOp "rounding mode" fpBinArith :: W4.IsSymExprBuilder sym => FP.SFloatBinArith sym -> What4 sym -> SWord (What4 sym) -> SFloat (What4 sym) -> SFloat (What4 sym) -> SEval (What4 sym) (SFloat (What4 sym)) fpBinArith fun = \sym r x y -> do m <- fpRoundingMode sym r liftIO (fun (w4 sym) m x y) fpCvtToInteger :: (W4.IsSymExprBuilder sy, sym ~ What4 sy) => sym -> String -> SWord sym -> SFloat sym -> SEval sym (SInteger sym) fpCvtToInteger sym fun r x = do grd <- liftIO do bad1 <- FP.fpIsInf (w4 sym) x bad2 <- FP.fpIsNaN (w4 sym) x W4.notPred (w4 sym) =<< W4.orPred (w4 sym) bad1 bad2 assertSideCondition sym grd (BadValue fun) rnd <- fpRoundingMode sym r liftIO do y <- FP.fpToReal (w4 sym) x case rnd of W4.RNE -> W4.realRoundEven (w4 sym) y W4.RNA -> W4.realRound (w4 sym) y W4.RTP -> W4.realCeil (w4 sym) y W4.RTN -> W4.realFloor (w4 sym) y W4.RTZ -> W4.realTrunc (w4 sym) y fpCvtToRational :: (W4.IsSymExprBuilder sy, sym ~ What4 sy) => sym -> SFloat sym -> SEval sym (SRational sym) fpCvtToRational sym fp = do grd <- liftIO do bad1 <- FP.fpIsInf (w4 sym) fp bad2 <- FP.fpIsNaN (w4 sym) fp W4.notPred (w4 sym) =<< W4.orPred (w4 sym) bad1 bad2 assertSideCondition sym grd (BadValue "fpToRational") (rel,x,y) <- liftIO (FP.fpToRational (w4 sym) fp) addDefEqn sym =<< liftIO (W4.impliesPred (w4 sym) grd rel) ratio sym x y fpCvtFromRational :: (W4.IsSymExprBuilder sy, sym ~ What4 sy) => sym -> Integer -> Integer -> SWord sym -> SRational sym -> SEval sym (SFloat sym) fpCvtFromRational sym e p r rat = do rnd <- fpRoundingMode sym r liftIO (FP.fpFromRational (w4 sym) e p rnd (sNum rat) (sDenom rat)) -- Create a fresh constant and assert that it is the -- multiplicitive inverse of x; return the constant. -- Such an inverse must exist under the precondition -- that the modulus is prime and the input is nonzero. sModRecip :: W4.IsSymExprBuilder sym => What4 sym -> Integer -> W4.SymInteger sym -> W4Eval sym (W4.SymInteger sym) sModRecip _sym 0 _ = panic "sModRecip" ["0 modulus not allowed"] sModRecip sym m x -- If the input is concrete, evaluate the answer | Just xi <- W4.asInteger x = case Integer.integerRecipMod xi m of Just r -> integerLit sym r Nothing -> raiseError sym DivideByZero -- If the input is symbolic, create a new symbolic constant -- and assert that it is the desired multiplicitive inverse. -- Such an inverse will exist under the precondition that -- the modulus is prime, and as long as the input is nonzero. | otherwise = do divZero <- liftIO (W4.intDivisible (w4 sym) x (fromInteger m)) ok <- liftIO (W4.notPred (w4 sym) divZero) assertSideCondition sym ok DivideByZero z <- liftIO (W4.freshBoundedInt (w4 sym) W4.emptySymbol (Just 1) (Just (m-1))) xz <- liftIO (W4.intMul (w4 sym) x z) rel <- znEq sym m xz =<< liftIO (W4.intLit (w4 sym) 1) addDefEqn sym =<< liftIO (W4.orPred (w4 sym) divZero rel) return z cryptol-3.0.0/src/Cryptol/Backend/WordValue.hs0000644000000000000000000006302707346545000017425 0ustar0000000000000000-- | -- Module : Cryptol.Backend.WordValue -- Copyright : (c) 2013-2021 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Cryptol.Backend.WordValue ( -- * WordValue WordValue , wordVal , bitmapWordVal , asWordList , asWordVal , asBitsMap , joinWordVal , takeWordVal , dropWordVal , extractWordVal , wordValLogicOp , wordValUnaryOp , assertWordValueInBounds , enumerateWordValue , enumerateWordValueRev , enumerateIndexSegments , wordValueSize , indexWordValue , updateWordValue , delayWordValue , joinWords , shiftSeqByWord , shiftWordByInteger , shiftWordByWord , wordValAsLit , reverseWordVal , forceWordValue , wordValueEqualsInteger , updateWordByWord , mergeWord , mergeWord' ) where import Control.Monad (unless) import Data.Bits import GHC.Generics (Generic) import Cryptol.Backend import Cryptol.Backend.Concrete (Concrete(..)) import Cryptol.Backend.Monad (EvalError(..)) import Cryptol.Backend.SeqMap import Cryptol.TypeCheck.Solver.InfNat(widthInteger, Nat'(..)) -- | Force the evaluation of a word value forceWordValue :: Backend sym => WordValue sym -> SEval sym () forceWordValue (WordVal w) = seq w (return ()) forceWordValue (ThunkWordVal _ m) = forceWordValue =<< m forceWordValue (BitmapVal _n packed _) = do w <- packed; seq w (return ()) -- | An arbitrarily-chosen number of elements where we switch from a dense -- sequence representation of bit-level words to 'SeqMap' representation. largeBitSize :: Integer largeBitSize = bit 32 -- | 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 sym = ThunkWordVal Integer !(SEval sym (WordValue sym)) | WordVal !(SWord sym) -- ^ Packed word representation for bit sequences. | BitmapVal !Integer -- ^ Length of the word !(SEval sym (SWord sym)) -- ^ Thunk for packing the word !(SeqMap sym (SBit sym)) -- ^ deriving (Generic) wordVal :: SWord sym -> WordValue sym wordVal = WordVal packBitmap :: Backend sym => sym -> Integer -> SeqMap sym (SBit sym) -> SEval sym (SWord sym) packBitmap sym sz bs = packWord sym =<< sequence (enumerateSeqMap sz bs) unpackBitmap :: Backend sym => sym -> SWord sym -> SeqMap sym (SBit sym) unpackBitmap sym w = indexSeqMap $ \i -> wordBit sym w i bitmapWordVal :: Backend sym => sym -> Integer -> SeqMap sym (SBit sym) -> SEval sym (WordValue sym) bitmapWordVal sym sz bs = do packed <- sDelay sym (packBitmap sym sz bs) pure (BitmapVal sz packed bs) {-# INLINE joinWordVal #-} joinWordVal :: Backend sym => sym -> WordValue sym -> WordValue sym -> SEval sym (WordValue sym) joinWordVal sym wv1 wv2 = let fallback = fallbackWordJoin sym wv1 wv2 in case (wv1, wv2) of (WordVal w1, WordVal w2) -> WordVal <$> joinWord sym w1 w2 (ThunkWordVal _ m1, _) -> isReady sym m1 >>= \case Just x -> joinWordVal sym x wv2 Nothing -> fallback (_,ThunkWordVal _ m2) -> isReady sym m2 >>= \case Just x -> joinWordVal sym wv1 x Nothing -> fallback (WordVal w1, BitmapVal _ packed2 _) -> isReady sym packed2 >>= \case Just w2 -> WordVal <$> joinWord sym w1 w2 Nothing -> fallback (BitmapVal _ packed1 _, WordVal w2) -> isReady sym packed1 >>= \case Just w1 -> WordVal <$> joinWord sym w1 w2 Nothing -> fallback (BitmapVal _ packed1 _, BitmapVal _ packed2 _) -> do r1 <- isReady sym packed1 r2 <- isReady sym packed2 case (r1,r2) of (Just w1, Just w2) -> WordVal <$> joinWord sym w1 w2 _ -> fallback {-# INLINE fallbackWordJoin #-} fallbackWordJoin :: Backend sym => sym -> WordValue sym -> WordValue sym -> SEval sym (WordValue sym) fallbackWordJoin sym w1 w2 = do let n1 = wordValueSize sym w1 let n2 = wordValueSize sym w2 let len = n1 + n2 packed <- sDelay sym (do a <- asWordVal sym w1 b <- asWordVal sym w2 joinWord sym a b) let bs = concatSeqMap n1 (asBitsMap sym w1) (asBitsMap sym w2) pure (BitmapVal len packed bs) {-# INLINE takeWordVal #-} takeWordVal :: Backend sym => sym -> Integer -> Integer -> WordValue sym -> SEval sym (WordValue sym) takeWordVal sym leftWidth rigthWidth (WordVal w) = do (lw, _rw) <- splitWord sym leftWidth rigthWidth w pure (WordVal lw) takeWordVal sym leftWidth rightWidth (ThunkWordVal _ m) = isReady sym m >>= \case Just w -> takeWordVal sym leftWidth rightWidth w Nothing -> do m' <- sDelay sym (takeWordVal sym leftWidth rightWidth =<< m) return (ThunkWordVal leftWidth m') takeWordVal sym leftWidth rightWidth (BitmapVal _n packed xs) = isReady sym packed >>= \case Just w -> do (lw, _rw) <- splitWord sym leftWidth rightWidth w pure (WordVal lw) Nothing -> bitmapWordVal sym leftWidth xs {-# INLINE dropWordVal #-} dropWordVal :: Backend sym => sym -> Integer -> Integer -> WordValue sym -> SEval sym (WordValue sym) dropWordVal sym leftWidth rigthWidth (WordVal w) = do (_lw, rw) <- splitWord sym leftWidth rigthWidth w pure (WordVal rw) dropWordVal sym leftWidth rightWidth (ThunkWordVal _ m) = isReady sym m >>= \case Just w -> dropWordVal sym leftWidth rightWidth w Nothing -> do m' <- sDelay sym (dropWordVal sym leftWidth rightWidth =<< m) return (ThunkWordVal rightWidth m') dropWordVal sym leftWidth rightWidth (BitmapVal _n packed xs) = isReady sym packed >>= \case Just w -> do (_lw, rw) <- splitWord sym leftWidth rightWidth w pure (WordVal rw) Nothing -> do let rxs = dropSeqMap leftWidth xs bitmapWordVal sym rightWidth rxs {-# INLINE extractWordVal #-} -- | 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 :: Backend sym => sym -> Integer -> Integer -> WordValue sym -> SEval sym (WordValue sym) extractWordVal sym len start (WordVal w) = WordVal <$> extractWord sym len start w extractWordVal sym len start (ThunkWordVal _n m) = isReady sym m >>= \case Just w -> extractWordVal sym len start w Nothing -> do m' <- sDelay sym (extractWordVal sym len start =<< m) pure (ThunkWordVal len m') extractWordVal sym len start (BitmapVal n packed xs) = isReady sym packed >>= \case Just w -> WordVal <$> extractWord sym len start w Nothing -> do let xs' = dropSeqMap (n - start - len) xs bitmapWordVal sym len xs' {-# INLINE wordValLogicOp #-} wordValLogicOp :: Backend sym => sym -> (SBit sym -> SBit sym -> SEval sym (SBit sym)) -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) -> WordValue sym -> WordValue sym -> SEval sym (WordValue sym) wordValLogicOp _sym _ wop (WordVal w1) (WordVal w2) = WordVal <$> wop w1 w2 wordValLogicOp sym bop wop (WordVal w1) (BitmapVal n2 packed2 bs2) = isReady sym packed2 >>= \case Just w2 -> WordVal <$> wop w1 w2 Nothing -> bitmapWordVal sym n2 =<< zipSeqMap sym bop (Nat n2) (unpackBitmap sym w1) bs2 wordValLogicOp sym bop wop (BitmapVal n1 packed1 bs1) (WordVal w2) = isReady sym packed1 >>= \case Just w1 -> WordVal <$> wop w1 w2 Nothing -> bitmapWordVal sym n1 =<< zipSeqMap sym bop (Nat n1) bs1 (unpackBitmap sym w2) wordValLogicOp sym bop wop (BitmapVal n1 packed1 bs1) (BitmapVal _n2 packed2 bs2) = do r1 <- isReady sym packed1 r2 <- isReady sym packed2 case (r1,r2) of (Just w1, Just w2) -> WordVal <$> wop w1 w2 _ -> bitmapWordVal sym n1 =<< zipSeqMap sym bop (Nat n1) bs1 bs2 wordValLogicOp sym bop wop (ThunkWordVal _ m1) w2 = do w1 <- m1 wordValLogicOp sym bop wop w1 w2 wordValLogicOp sym bop wop w1 (ThunkWordVal _ m2) = do w2 <- m2 wordValLogicOp sym bop wop w1 w2 {-# INLINE wordValUnaryOp #-} wordValUnaryOp :: Backend sym => sym -> (SBit sym -> SEval sym (SBit sym)) -> (SWord sym -> SEval sym (SWord sym)) -> WordValue sym -> SEval sym (WordValue sym) wordValUnaryOp _ _ wop (WordVal w) = WordVal <$> wop w wordValUnaryOp sym bop wop (ThunkWordVal _ m) = wordValUnaryOp sym bop wop =<< m wordValUnaryOp sym bop wop (BitmapVal n packed xs) = isReady sym packed >>= \case Just w -> WordVal <$> wop w Nothing -> bitmapWordVal sym n =<< mapSeqMap sym bop (Nat n) xs {-# SPECIALIZE joinWords :: Concrete -> Integer -> Integer -> SeqMap Concrete (WordValue Concrete)-> SEval Concrete (WordValue Concrete) #-} joinWords :: forall sym. Backend sym => sym -> Integer -> Integer -> SeqMap sym (WordValue sym) -> SEval sym (WordValue sym) -- small enough to pack joinWords sym nParts nEach xs | nParts * nEach < largeBitSize = do z <- wordLit sym 0 0 loop (wordVal z) (enumerateSeqMap nParts xs) where loop :: WordValue sym -> [SEval sym (WordValue sym)] -> SEval sym (WordValue sym) loop !wv [] = pure wv loop !wv (w : ws) = do w' <- delayWordValue sym nEach w wv' <- joinWordVal sym wv w' loop wv' ws -- too large to pack joinWords sym nParts nEach xs = bitmapWordVal sym (nParts * nEach) zs where zs = indexSeqMap $ \i -> do let (q,r) = divMod i nEach ys <- lookupSeqMap xs q indexWordValue sym ys r reverseWordVal :: Backend sym => sym -> WordValue sym -> SEval sym (WordValue sym) reverseWordVal sym w = let m = wordValueSize sym w in bitmapWordVal sym m <$> reverseSeqMap m $ asBitsMap sym w wordValAsLit :: Backend sym => sym -> WordValue sym -> SEval sym (Maybe Integer) wordValAsLit sym (WordVal w) = pure (snd <$> wordAsLit sym w) wordValAsLit sym (ThunkWordVal _ m) = isReady sym m >>= \case Just v -> wordValAsLit sym v Nothing -> pure Nothing wordValAsLit sym (BitmapVal _ packed _) = isReady sym packed >>= \case Just w -> pure (snd <$> wordAsLit sym w) Nothing -> pure Nothing -- | Force a word value into packed word form asWordVal :: Backend sym => sym -> WordValue sym -> SEval sym (SWord sym) asWordVal _ (WordVal w) = return w asWordVal sym (ThunkWordVal _ m) = asWordVal sym =<< m asWordVal _ (BitmapVal _ packed _) = packed wordValueEqualsInteger :: forall sym. Backend sym => sym -> WordValue sym -> Integer -> SEval sym (SBit sym) wordValueEqualsInteger sym wv i | wordValueSize sym wv < widthInteger i = return (bitLit sym False) | otherwise = loop wv where loop (ThunkWordVal _ m) = loop =<< m loop (WordVal w) = wordEq sym w =<< wordLit sym (wordLen sym w) i loop (BitmapVal n packed bs) = isReady sym packed >>= \case Just w -> loop (WordVal w) Nothing -> bitsAre i =<< sequence (enumerateSeqMap n (reverseSeqMap n bs)) -- NB little-endian sequence of bits bitsAre :: Integer -> [SBit sym] -> SEval sym (SBit sym) bitsAre !n [] = return (bitLit sym (n == 0)) bitsAre !n (b:bs) = do pb <- bitIs (testBit n 0) b pbs <- bitsAre (n `shiftR` 1) bs bitAnd sym pb pbs bitIs :: Bool -> SBit sym -> SEval sym (SBit sym) bitIs b x = if b then pure x else bitComplement sym x asWordList :: forall sym. Backend sym => sym -> [WordValue sym] -> SEval sym (Maybe [SWord sym]) asWordList sym = loop id where loop :: ([SWord sym] -> [SWord sym]) -> [WordValue sym] -> SEval sym (Maybe [SWord sym]) loop f [] = pure (Just (f [])) loop f (WordVal x : vs) = loop (f . (x:)) vs loop f (ThunkWordVal _ m : vs) = isReady sym m >>= \case Just m' -> loop f (m' : vs) Nothing -> pure Nothing loop f (BitmapVal _ packed _ : vs) = isReady sym packed >>= \case Just x -> loop (f . (x:)) vs Nothing -> pure Nothing -- | Force a word value into a sequence of bits asBitsMap :: Backend sym => sym -> WordValue sym -> SeqMap sym (SBit sym) asBitsMap _ (BitmapVal _ _ xs) = xs asBitsMap sym (WordVal w) = indexSeqMap $ \i -> wordBit sym w i asBitsMap sym (ThunkWordVal _ m) = indexSeqMap $ \i -> do mp <- asBitsMap sym <$> (unwindThunks m) lookupSeqMap mp i -- | Turn a word value into a sequence of bits, forcing each bit. -- The sequence is returned in big-endian order. enumerateWordValue :: Backend sym => sym -> WordValue sym -> SEval sym [SBit sym] enumerateWordValue sym (WordVal w) = unpackWord sym w enumerateWordValue sym (ThunkWordVal _ m) = enumerateWordValue sym =<< m -- TODO? used the packed value if it is ready? enumerateWordValue _ (BitmapVal n _ xs) = sequence (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 :: Backend sym => sym -> WordValue sym -> SEval sym [SBit sym] enumerateWordValueRev sym (WordVal w) = reverse <$> unpackWord sym w enumerateWordValueRev sym (ThunkWordVal _ m) = enumerateWordValueRev sym =<< m -- TODO? used the packed value if it is ready? enumerateWordValueRev _ (BitmapVal n _ xs) = sequence (enumerateSeqMap n (reverseSeqMap n xs)) enumerateIndexSegments :: Backend sym => sym -> WordValue sym -> SEval sym [IndexSegment sym] enumerateIndexSegments _sym (WordVal w) = pure [WordIndexSegment w] enumerateIndexSegments sym (ThunkWordVal _ m) = enumerateIndexSegments sym =<< m enumerateIndexSegments sym (BitmapVal n packed xs) = isReady sym packed >>= \case Just w -> pure [WordIndexSegment w] Nothing -> traverse (BitIndexSegment <$>) (enumerateSeqMap n xs) {-# SPECIALIZE bitsValueLessThan :: Concrete -> Integer -> [SBit Concrete] -> Integer -> SEval Concrete (SBit Concrete) #-} bitsValueLessThan :: Backend sym => sym -> Integer {- ^ bit-width -} -> [SBit sym] {- ^ big-endian list of index bits -} -> Integer {- ^ Upper bound to test against -} -> SEval sym (SBit sym) bitsValueLessThan sym _w [] _n = pure $ bitLit sym False bitsValueLessThan sym w (b:bs) n | nbit = do notb <- bitComplement sym b bitOr sym notb =<< bitsValueLessThan sym (w-1) bs n | otherwise = do notb <- bitComplement sym b bitAnd sym notb =<< bitsValueLessThan sym (w-1) bs n where nbit = testBit n (fromInteger (w-1)) assertWordValueInBounds :: Backend sym => sym -> Integer -> WordValue sym -> SEval sym () -- Can't index out of bounds for a sequence that is -- longer than the expressible index values assertWordValueInBounds sym n idx | n >= 2^(wordValueSize sym idx) = return () assertWordValueInBounds sym n (WordVal idx) | Just (_w,i) <- wordAsLit sym idx = unless (i < n) (raiseError sym (InvalidIndex (Just i))) -- If the index is a packed word, test that it -- is less than the concrete value of n, which -- fits into w bits because of the above test. assertWordValueInBounds sym n (WordVal idx) = do n' <- wordLit sym (wordLen sym idx) n p <- wordLessThan sym idx n' assertSideCondition sym p (InvalidIndex Nothing) -- Force thunks assertWordValueInBounds sym n (ThunkWordVal _ m) = assertWordValueInBounds sym n =<< m -- If the index is an unpacked word, force all the bits -- and compute the unsigned less-than test directly. assertWordValueInBounds sym n (BitmapVal sz packed bits) = isReady sym packed >>= \case Just w -> assertWordValueInBounds sym n (WordVal w) Nothing -> do bitsList <- sequence (enumerateSeqMap sz bits) p <- bitsValueLessThan sym sz bitsList n assertSideCondition sym p (InvalidIndex Nothing) delayWordValue :: Backend sym => sym -> Integer -> SEval sym (WordValue sym) -> SEval sym (WordValue sym) delayWordValue sym sz m = isReady sym m >>= \case Just w -> pure w Nothing -> ThunkWordVal sz <$> sDelay sym (unwindThunks m) -- If we are calling this, we know the spine of the word value has been -- demanded, so we unwind any chains of `ThunkWordValue` that may have built up. unwindThunks :: Backend sym => SEval sym (WordValue sym) -> SEval sym (WordValue sym) unwindThunks m = m >>= \case ThunkWordVal _ m' -> unwindThunks m' x -> pure x {-# INLINE shiftWordByInteger #-} shiftWordByInteger :: Backend sym => sym -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) {- ^ operation on word values -} -> (Integer -> Integer -> Maybe Integer) {- ^ reindexing operation -} -> WordValue sym {- ^ word value to shift -} -> SInteger sym {- ^ shift amount, assumed to be in range [0,len] -} -> SEval sym (WordValue sym) shiftWordByInteger sym wop reindex x idx = case x of ThunkWordVal w wm -> isReady sym wm >>= \case Just x' -> shiftWordByInteger sym wop reindex x' idx Nothing -> do m' <- sDelay sym (do x' <- wm shiftWordByInteger sym wop reindex x' idx) return (ThunkWordVal w m') WordVal x' -> WordVal <$> (wop x' =<< wordFromInt sym (wordLen sym x') idx) BitmapVal n packed bs0 -> isReady sym packed >>= \case Just w -> shiftWordByInteger sym wop reindex (WordVal w) idx Nothing -> bitmapWordVal sym n =<< shiftSeqByInteger sym (iteBit sym) reindex (pure (bitLit sym False)) (Nat n) bs0 idx {-# INLINE shiftWordByWord #-} shiftWordByWord :: Backend sym => sym -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) {- ^ operation on word values -} -> (Integer -> Integer -> Maybe Integer) {- ^ reindexing operation -} -> WordValue sym {- ^ value to shift -} -> WordValue sym {- ^ amount to shift -} -> SEval sym (WordValue sym) shiftWordByWord sym wop reindex x idx = case x of ThunkWordVal w wm -> isReady sym wm >>= \case Just wm' -> shiftWordByWord sym wop reindex wm' idx Nothing -> do m' <- sDelay sym (do wm' <- wm shiftWordByWord sym wop reindex wm' idx) return (ThunkWordVal w m') WordVal x' -> WordVal <$> (wop x' =<< asWordVal sym idx) BitmapVal n packed bs0 -> isReady sym packed >>= \case Just w -> shiftWordByWord sym wop reindex (WordVal w) idx Nothing -> bitmapWordVal sym n =<< shiftSeqByWord sym (iteBit sym) reindex (pure (bitLit sym False)) (Nat n) bs0 idx {-# INLINE updateWordByWord #-} updateWordByWord :: Backend sym => sym -> IndexDirection -> WordValue sym {- ^ value to update -} -> WordValue sym {- ^ index to update at -} -> SEval sym (SBit sym) {- ^ fresh bit -} -> SEval sym (WordValue sym) updateWordByWord sym dir w0 idx bitval = wordValAsLit sym idx >>= \case Just j -> let sz = wordValueSize sym w0 in case dir of IndexForward -> updateWordValue sym w0 j bitval IndexBackward -> updateWordValue sym w0 (sz - j - 1) bitval Nothing -> loop w0 where loop (ThunkWordVal sz m) = isReady sym m >>= \case Just w' -> loop w' Nothing -> delayWordValue sym sz (loop =<< m) loop (BitmapVal sz packed bs) = isReady sym packed >>= \case Just w -> loop (WordVal w) Nothing -> case dir of IndexForward -> bitmapWordVal sym sz $ indexSeqMap $ \i -> do b <- wordValueEqualsInteger sym idx i mergeEval sym (iteBit sym) b bitval (lookupSeqMap bs i) IndexBackward -> bitmapWordVal sym sz $ indexSeqMap $ \i -> do b <- wordValueEqualsInteger sym idx (sz - i - 1) mergeEval sym (iteBit sym) b bitval (lookupSeqMap bs i) loop (WordVal wv) = WordVal <$> -- TODO, this is too strict in bit do let sz = wordLen sym wv b <- bitval msk <- case dir of IndexForward -> do highbit <- wordLit sym sz (bit (fromInteger (sz-1))) wordShiftRight sym highbit =<< asWordVal sym idx IndexBackward -> do lowbit <- wordLit sym sz 1 wordShiftLeft sym lowbit =<< asWordVal sym idx case bitAsLit sym b of Just True -> wordOr sym wv msk Just False -> wordAnd sym wv =<< wordComplement sym msk Nothing -> do zro <- wordLit sym sz 0 one <- wordComplement sym zro q <- iteWord sym b one zro w' <- wordAnd sym wv =<< wordComplement sym msk wordXor sym w' =<< wordAnd sym msk q {-# INLINE shiftSeqByWord #-} shiftSeqByWord :: Backend sym => sym -> (SBit sym -> a -> a -> SEval sym a) {- ^ if/then/else operation of values -} -> (Integer -> Integer -> Maybe Integer) {- ^ reindexing operation -} -> SEval sym a {- ^ zero value -} -> Nat' {- ^ size of the sequence -} -> SeqMap sym a {- ^ sequence to shift -} -> WordValue sym {- ^ shift amount -} -> SEval sym (SeqMap sym a) shiftSeqByWord sym merge reindex zro sz xs idx = wordValAsLit sym idx >>= \case Just j -> shiftOp xs j Nothing -> do idx_segs <- enumerateIndexSegments sym idx barrelShifter sym merge shiftOp sz xs idx_bits idx_segs where idx_bits = wordValueSize sym idx shiftOp vs shft = pure $ indexSeqMap $ \i -> case reindex i shft of Nothing -> zro Just i' -> lookupSeqMap vs i' -- | Compute the size of a word value -- TODO, can we get rid of this? If feels like it should be -- unnecessary. wordValueSize :: Backend sym => sym -> WordValue sym -> Integer wordValueSize sym (WordVal w) = wordLen sym w wordValueSize _ (ThunkWordVal n _) = n wordValueSize _ (BitmapVal n _ _) = n -- | Select an individual bit from a word value indexWordValue :: Backend sym => sym -> WordValue sym -> Integer -> SEval sym (SBit sym) indexWordValue sym (ThunkWordVal _ m) idx = do m' <- m ; indexWordValue sym m' idx indexWordValue sym (WordVal w) idx | 0 <= idx && idx < wordLen sym w = wordBit sym w idx | otherwise = invalidIndex sym idx indexWordValue sym (BitmapVal n _packed xs) idx | 0 <= idx && idx < n = lookupSeqMap xs idx | otherwise = invalidIndex sym idx -- | Produce a new 'WordValue' from the one given by updating the @i@th bit with the -- given bit value. updateWordValue :: Backend sym => sym -> WordValue sym -> Integer -> SEval sym (SBit sym) -> SEval sym (WordValue sym) updateWordValue sym wv0 idx b = loop wv0 where loop (ThunkWordVal sz m) = isReady sym m >>= \case Just w -> loop w Nothing -> delayWordValue sym sz (loop =<< m) loop (WordVal w) | idx < 0 || idx >= wordLen sym w = invalidIndex sym idx | otherwise = isReady sym b >>= \case Just b' -> WordVal <$> wordUpdate sym w idx b' Nothing -> do let bs = unpackBitmap sym w bitmapWordVal sym (wordLen sym w) $ updateSeqMap bs idx b loop (BitmapVal sz packed bs) | 0 <= idx && idx < sz = isReady sym packed >>= \case Just w -> loop (WordVal w) Nothing -> bitmapWordVal sym sz $ updateSeqMap bs idx b | otherwise = invalidIndex sym idx {-# INLINE mergeWord #-} mergeWord :: Backend sym => sym -> SBit sym -> WordValue sym -> WordValue sym -> SEval sym (WordValue sym) mergeWord sym c (ThunkWordVal _ m1) (ThunkWordVal _ m2) = mergeWord' sym c (unwindThunks m1) (unwindThunks m2) mergeWord sym c (ThunkWordVal _ m1) w2 = mergeWord' sym c (unwindThunks m1) (pure w2) mergeWord sym c w1 (ThunkWordVal _ m2) = mergeWord' sym c (pure w1) (unwindThunks m2) mergeWord sym c (WordVal w1) (WordVal w2) = WordVal <$> iteWord sym c w1 w2 mergeWord sym c (BitmapVal n1 packed1 bs1) (WordVal w2) = isReady sym packed1 >>= \case Just w1 -> WordVal <$> iteWord sym c w1 w2 Nothing -> mergeBitmaps sym c n1 bs1 (unpackBitmap sym w2) mergeWord sym c (WordVal w1) (BitmapVal n2 packed2 bs2) = isReady sym packed2 >>= \case Just w2 -> WordVal <$> iteWord sym c w1 w2 Nothing -> mergeBitmaps sym c n2 (unpackBitmap sym w1) bs2 mergeWord sym c (BitmapVal n1 packed1 bs1) (BitmapVal _n2 packed2 bs2) = do r1 <- isReady sym packed1 r2 <- isReady sym packed2 case (r1,r2) of (Just w1, Just w2) -> WordVal <$> iteWord sym c w1 w2 _ -> mergeBitmaps sym c n1 bs1 bs2 mergeBitmaps :: Backend sym => sym -> SBit sym -> Integer -> SeqMap sym (SBit sym) -> SeqMap sym (SBit sym) -> SEval sym (WordValue sym) mergeBitmaps sym c sz bs1 bs2 = do bs <- memoMap sym (Nat sz) (mergeSeqMap sym (iteBit sym) c bs1 bs2) bitmapWordVal sym sz bs {-# INLINE mergeWord' #-} mergeWord' :: Backend sym => sym -> SBit sym -> SEval sym (WordValue sym) -> SEval sym (WordValue sym) -> SEval sym (WordValue sym) mergeWord' sym c x y | Just b <- bitAsLit sym c = if b then x else y | otherwise = mergeEval sym (mergeWord sym) c x y cryptol-3.0.0/src/Cryptol/Eval.hs0000644000000000000000000006245107346545000015055 0ustar0000000000000000-- | -- Module : Cryptol.Eval -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NamedFieldPuns #-} module Cryptol.Eval ( moduleEnv , runEval , EvalOpts(..) , PPOpts(..) , defaultPPOpts , Eval , EvalEnv , emptyEnv , evalExpr , evalDecls , evalNewtypeDecls , evalSel , evalSetSel , EvalError(..) , EvalErrorEx(..) , Unsupported(..) , WordTooWide(..) , forceValue , checkProp ) where import Cryptol.Backend import Cryptol.Backend.Concrete( Concrete(..) ) import Cryptol.Backend.Monad import Cryptol.Backend.SeqMap import Cryptol.Backend.WordValue import Cryptol.Eval.Env import Cryptol.Eval.Prims import Cryptol.Eval.Type import Cryptol.Eval.Value import Cryptol.ModuleSystem.Name import Cryptol.Parser.Position import Cryptol.Parser.Selector(ppSelector) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) import Cryptol.Utils.Ident import Cryptol.Utils.Panic (panic) import Cryptol.Utils.PP import Cryptol.Utils.RecordMap import Control.Monad import Data.List import Data.Maybe import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map import Data.Semigroup import Control.Applicative import Prelude () import Prelude.Compat type EvalEnv = GenEvalEnv Concrete type EvalPrims sym = ( Backend sym, ?callStacks :: Bool, ?evalPrim :: PrimIdent -> Maybe (Either Expr (Prim sym)) ) type ConcPrims = (?callStacks :: Bool, ?evalPrim :: PrimIdent -> Maybe (Either Expr (Prim Concrete))) -- Expression Evaluation ------------------------------------------------------- {-# SPECIALIZE moduleEnv :: ConcPrims => Concrete -> Module -> GenEvalEnv Concrete -> SEval Concrete (GenEvalEnv Concrete) #-} -- | Extend the given evaluation environment with all the declarations -- contained in the given module. moduleEnv :: EvalPrims sym => sym -> Module {- ^ Module containing declarations to evaluate -} -> GenEvalEnv sym {- ^ Environment to extend -} -> SEval sym (GenEvalEnv sym) moduleEnv sym m env = evalDecls sym (mDecls m) =<< evalNewtypeDecls sym (mNewtypes m) env {-# SPECIALIZE evalExpr :: (?range :: Range, ConcPrims) => Concrete -> GenEvalEnv Concrete -> Expr -> SEval Concrete (GenValue Concrete) #-} -- | 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 :: (?range :: Range, EvalPrims sym) => sym -> GenEvalEnv sym {- ^ Evaluation environment -} -> Expr {- ^ Expression to evaluate -} -> SEval sym (GenValue sym) evalExpr sym env expr = case expr of ELocated r e -> let ?range = r in evalExpr sym env e -- 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" #-} VWord len <$> (tryFromBits sym vs >>= \case Just w -> pure (wordVal w) Nothing -> do xs <- mapM (\x -> sDelay sym (fromVBit <$> x)) vs bitmapWordVal sym len $ finiteSeqMap sym xs) | otherwise -> {-# SCC "evalExpr->EList" #-} do xs <- mapM (sDelay sym) vs return $ VSeq len $ finiteSeqMap sym xs where tyv = evalValType (envTypes env) ty vs = map eval es len = genericLength es ETuple es -> {-# SCC "evalExpr->ETuple" #-} do xs <- mapM (sDelay sym . eval) es return $ VTuple xs ERec fields -> {-# SCC "evalExpr->ERec" #-} do xs <- traverse (sDelay sym . eval) fields return $ VRecord xs ESel e sel -> {-# SCC "evalExpr->ESel" #-} do e' <- eval e evalSel sym e' sel ESet ty e sel v -> {-# SCC "evalExpr->ESet" #-} do e' <- eval e let tyv = evalValType (envTypes env) ty evalSetSel sym tyv e' sel (eval v) EIf c t f -> {-# SCC "evalExpr->EIf" #-} do b <- fromVBit <$> eval c iteValue sym 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 sym env len elty h gs EVar n -> {-# SCC "evalExpr->EVar" #-} do case lookupVar n env of Just (Left p) | ?callStacks -> sPushFrame sym n ?range (cacheCallStack sym =<< evalPrim sym n p) | otherwise -> evalPrim sym n p Just (Right val) | ?callStacks -> case nameInfo n of GlobalName {} -> sPushFrame sym n ?range (cacheCallStack sym =<< val) LocalName {} -> cacheCallStack sym =<< val | otherwise -> val Nothing -> do envdoc <- ppEnv sym defaultPPOpts env panic "[Eval] evalExpr" ["var `" ++ show (pp n) ++ "` (" ++ show (nameUnique n) ++ ") is not defined" , show envdoc ] ETAbs tv b -> {-# SCC "evalExpr->ETAbs" #-} case tpKind tv of KType -> tlam sym $ \ty -> evalExpr sym (bindType (tpVar tv) (Right ty) env) b KNum -> nlam sym $ \n -> evalExpr sym (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 f@VPoly{} -> fromVPoly sym f $! (evalValType (envTypes env) ty) f@VNumPoly{} -> fromVNumPoly sym 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 v -> {-# SCC "evalExpr->EApp" #-} do eval f >>= \case f'@VFun {} -> fromVFun sym f' (eval v) it -> do itdoc <- ppV it panic "[Eval] evalExpr" ["not a function", show itdoc ] EAbs n _ty b -> {-# SCC "evalExpr->EAbs" #-} lam sym (\v -> do env' <- bindVar sym n v env evalExpr sym env' b) -- XXX these will likely change once there is an evidence value EProofAbs _ e -> eval e EProofApp e -> eval e EWhere e ds -> {-# SCC "evalExpr->EWhere" #-} do env' <- evalDecls sym ds env evalExpr sym env' e EPropGuards guards _ -> {-# SCC "evalExpr->EPropGuards" #-} do let checkedGuards = [ e | (ps,e) <- guards, all (checkProp . evalProp env) ps ] case checkedGuards of (e:_) -> eval e [] -> raiseError sym (NoMatchingPropGuardCase $ "Among constraint guards: " ++ show (fmap pp . fst <$> guards)) where {-# INLINE eval #-} eval = evalExpr sym env ppV = ppValue sym defaultPPOpts -- | Checks whether an evaluated `Prop` holds checkProp :: Prop -> Bool checkProp = \case TCon tcon ts -> let ns = toNat' <$> ts in case tcon of PC PEqual | [n1, n2] <- ns -> n1 == n2 PC PNeq | [n1, n2] <- ns -> n1 /= n2 PC PGeq | [n1, n2] <- ns -> n1 >= n2 PC PFin | [n] <- ns -> n /= Inf -- TODO: instantiate UniqueFactorization for Nat'? -- PC PPrime | [n] <- ns -> isJust (isPrime n) PC PTrue -> True TError {} -> False _ -> evalPanic "evalProp" ["cannot use this as a guarding constraint: ", show . pp $ TCon tcon ts ] prop -> evalPanic "evalProp" ["cannot use this as a guarding constraint: ", show . pp $ prop ] where toNat' :: Type -> Nat' toNat' = \case TCon (TC (TCNum n)) [] -> Nat n TCon (TC TCInf) [] -> Inf prop -> panic "checkProp" ["Expected `" ++ pretty prop ++ "` to be an evaluated numeric type"] -- | Evaluates a `Prop` in an `EvalEnv` by substituting all variables according -- to `envTypes` and expanding all type synonyms via `tNoUser`. evalProp :: GenEvalEnv sym -> Prop -> Prop evalProp env@EvalEnv { envTypes } = \case TCon tc tys | TError KProp <- tc, [p] <- tys -> case evalProp env p of x@(TCon (TError KProp) _) -> x _ -> TCon (TError KProp) [evalProp env p] | otherwise -> TCon tc (toType . evalType envTypes <$> tys) TVar tv | Just (toType -> ty) <- lookupTypeVar tv envTypes -> ty prop@TUser {} -> evalProp env (tNoUser prop) TVar tv | Nothing <- lookupTypeVar tv envTypes -> panic "evalProp" ["Could not find type variable `" ++ pretty tv ++ "` in the type evaluation environment"] prop -> panic "evalProp" ["Cannot use the following as a type constraint: `" ++ pretty prop ++ "`"] where toType = either tNumTy tValTy -- | Capure the current call stack from the evaluation monad and -- annotate function values. When arguments are later applied -- to the function, the call stacks will be combined together. cacheCallStack :: Backend sym => sym -> GenValue sym -> SEval sym (GenValue sym) cacheCallStack sym v = case v of VFun fnstk f -> do stk <- sGetCallStack sym pure (VFun (combineCallStacks stk fnstk) f) VPoly fnstk f -> do stk <- sGetCallStack sym pure (VPoly (combineCallStacks stk fnstk) f) VNumPoly fnstk f -> do stk <- sGetCallStack sym pure (VNumPoly (combineCallStacks stk fnstk) f) -- non-function types don't get annotated _ -> pure v -- Newtypes -------------------------------------------------------------------- {-# SPECIALIZE evalNewtypeDecls :: ConcPrims => Concrete -> Map.Map Name Newtype -> GenEvalEnv Concrete -> SEval Concrete (GenEvalEnv Concrete) #-} evalNewtypeDecls :: EvalPrims sym => sym -> Map.Map Name Newtype -> GenEvalEnv sym -> SEval sym (GenEvalEnv sym) evalNewtypeDecls sym nts env = foldM (flip (evalNewtypeDecl sym)) env $ Map.elems nts -- | Introduce the constructor function for a newtype. evalNewtypeDecl :: EvalPrims sym => sym -> Newtype -> GenEvalEnv sym -> SEval sym (GenEvalEnv sym) evalNewtypeDecl _sym nt = pure . bindVarDirect (ntConName nt) (foldr tabs con (ntParams nt)) where con = PFun PPrim tabs tp body = case tpKind tp of KType -> PTyPoly (\ _ -> body) KNum -> PNumPoly (\ _ -> body) k -> evalPanic "evalNewtypeDecl" ["illegal newtype parameter kind", show (pp k)] {-# INLINE evalNewtypeDecl #-} -- Declarations ---------------------------------------------------------------- {-# SPECIALIZE evalDecls :: ConcPrims => Concrete -> [DeclGroup] -> GenEvalEnv Concrete -> SEval Concrete (GenEvalEnv Concrete) #-} -- | Extend the given evaluation environment with the result of evaluating the -- given collection of declaration groups. evalDecls :: EvalPrims sym => sym -> [DeclGroup] {- ^ Declaration groups to evaluate -} -> GenEvalEnv sym {- ^ Environment to extend -} -> SEval sym (GenEvalEnv sym) evalDecls x dgs env = foldM (evalDeclGroup x) env dgs {-# SPECIALIZE evalDeclGroup :: ConcPrims => Concrete -> GenEvalEnv Concrete -> DeclGroup -> SEval Concrete (GenEvalEnv Concrete) #-} evalDeclGroup :: EvalPrims sym => sym -> GenEvalEnv sym -> DeclGroup -> SEval sym (GenEvalEnv sym) evalDeclGroup sym env dg = do case dg of Recursive ds -> do -- declare a "hole" for each declaration -- and extend the evaluation environment holes <- mapM (declHole sym) ds let holeEnv = IntMap.fromList $ [ (nameUnique nm, Right h) | (nm,_,h,_) <- holes ] let env' = env `mappend` emptyEnv{ envVars = holeEnv } -- evaluate the declaration bodies, building a new evaluation environment env'' <- foldM (evalDecl sym env') env ds -- now backfill the holes we declared earlier using the definitions -- calculated in the previous step mapM_ (fillHole sym env'') holes -- return the map containing the holes return env' NonRecursive d -> do evalDecl sym env env d {-# SPECIALIZE fillHole :: Concrete -> GenEvalEnv Concrete -> (Name, Schema, SEval Concrete (GenValue Concrete), SEval Concrete (GenValue Concrete) -> SEval Concrete ()) -> SEval Concrete () #-} -- | 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 :: Backend sym => sym -> GenEvalEnv sym -> (Name, Schema, SEval sym (GenValue sym), SEval sym (GenValue sym) -> SEval sym ()) -> SEval sym () fillHole _sym env (nm, _sch, _, fill) = do case lookupVar nm env of Just (Right v) -> fill v _ -> evalPanic "fillHole" ["Recursive definition not completed", show (ppLocName nm)] {-# SPECIALIZE declHole :: Concrete -> Decl -> SEval Concrete (Name, Schema, SEval Concrete (GenValue Concrete), SEval Concrete (GenValue Concrete) -> SEval Concrete ()) #-} declHole :: Backend sym => sym -> Decl -> SEval sym (Name, Schema, SEval sym (GenValue sym), SEval sym (GenValue sym) -> SEval sym ()) declHole sym d = case dDefinition d of DPrim -> evalPanic "Unexpected primitive declaration in recursive group" [show (ppLocName nm)] DForeign _ -> evalPanic "Unexpected foreign declaration in recursive group" [show (ppLocName nm)] DExpr _ -> do (hole, fill) <- sDeclareHole sym 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 sym => sym -> GenEvalEnv sym {- ^ A 'read only' environment for use in declaration bodies -} -> GenEvalEnv sym {- ^ An evaluation environment to extend with the given declaration -} -> Decl {- ^ The declaration to evaluate -} -> SEval sym (GenEvalEnv sym) -- evalDecl sym renv env d = -- let ?range = nameLoc (dName d) in evalDecl sym renv env d = do let ?range = nameLoc (dName d) case dDefinition d of DPrim -> case ?evalPrim =<< asPrim (dName d) of Just (Right p) -> pure $ bindVarDirect (dName d) p env Just (Left ex) -> bindVar sym (dName d) (evalExpr sym renv ex) env Nothing -> bindVar sym (dName d) (cryNoPrimError sym (dName d)) env DForeign _ -> do -- Foreign declarations should have been handled by the previous -- Cryptol.Eval.FFI.evalForeignDecls pass already, so they should already -- be in the environment. If not, then either Cryptol was not compiled -- with FFI support enabled, or we are in a non-Concrete backend. In that -- case, we just bind the name to an error computation which will raise an -- error if we try to evaluate it. case lookupVar (dName d) env of Just _ -> pure env Nothing -> bindVar sym (dName d) (raiseError sym $ FFINotSupported $ dName d) env DExpr e -> bindVar sym (dName d) (evalExpr sym renv e) env -- Selectors ------------------------------------------------------------------- {-# SPECIALIZE evalSel :: Concrete -> GenValue Concrete -> Selector -> SEval Concrete (GenValue Concrete) #-} -- | Apply the the given "selector" form to the given value. Note that -- selectors are expected to apply only to values of the right type, -- e.g. tuple selectors expect only tuple values. The lifting of -- tuple an record selectors over functions and sequences has already -- been resolved earlier in the typechecker. evalSel :: Backend sym => sym -> GenValue sym -> Selector -> SEval sym (GenValue sym) evalSel sym 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 sym 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 sym 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 <$> indexWordValue sym wv (toInteger n) _ -> do vdoc <- ppValue sym defaultPPOpts val evalPanic "Cryptol.Eval.evalSel" [ "Unexpected value in list selection" , show vdoc ] {-# SPECIALIZE evalSetSel :: Concrete -> TValue -> GenValue Concrete -> Selector -> SEval Concrete (GenValue Concrete) -> SEval Concrete (GenValue Concrete) #-} evalSetSel :: forall sym. Backend sym => sym -> TValue -> GenValue sym -> Selector -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) evalSetSel sym _tyv e sel v = case sel of TupleSel n _ -> setTuple n RecordSel n _ -> setRecord n ListSel ix _ -> setList (toInteger ix) where bad msg = do ed <- ppValue sym defaultPPOpts e evalPanic "Cryptol.Eval.evalSetSel" [ msg , "Selector: " ++ show (ppSelector sel) , "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 adjustField n (\_ -> v) xs of Just xs' -> pure (VRecord xs') Nothing -> 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 -> VWord i <$> updateWordValue sym m 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 sym = ListEnv { leVars :: !(IntMap.IntMap (Integer -> SEval sym (GenValue sym))) -- ^ Bindings whose values vary by position , leStatic :: !(IntMap.IntMap (Either (Prim sym) (SEval sym (GenValue sym)))) -- ^ Bindings whose values are constant , leTypes :: !TypeEnv } instance Semigroup (ListEnv sym) where l <> r = ListEnv { leVars = IntMap.union (leVars l) (leVars r) , leStatic = IntMap.union (leStatic l) (leStatic r) , leTypes = leTypes l <> leTypes r } instance Monoid (ListEnv sym) where mempty = ListEnv { leVars = IntMap.empty , leStatic = IntMap.empty , leTypes = mempty } mappend = (<>) toListEnv :: GenEvalEnv sym -> ListEnv sym toListEnv e = ListEnv { leVars = mempty , leStatic = envVars e , leTypes = envTypes e } {-# INLINE toListEnv #-} -- | Evaluate a list environment at a position. -- This choses a particular value for the varying -- locations. evalListEnv :: ListEnv sym -> Integer -> GenEvalEnv sym evalListEnv (ListEnv vm st tm) i = let v = fmap (Right . ($ i)) vm in EvalEnv{ envVars = IntMap.union v st , envTypes = tm } {-# INLINE evalListEnv #-} bindVarList :: Name -> (Integer -> SEval sym (GenValue sym)) -> ListEnv sym -> ListEnv sym bindVarList n vs lenv = lenv { leVars = IntMap.insert (nameUnique n) vs (leVars lenv) } {-# INLINE bindVarList #-} -- List Comprehensions --------------------------------------------------------- {-# SPECIALIZE evalComp :: (?range :: Range, ConcPrims) => Concrete -> GenEvalEnv Concrete -> Nat' -> TValue -> Expr -> [[Match]] -> SEval Concrete (GenValue Concrete) #-} -- | Evaluate a comprehension. evalComp :: (?range :: Range, EvalPrims sym) => sym -> GenEvalEnv sym {- ^ 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 -} -> SEval sym (GenValue sym) evalComp sym env len elty body ms = do lenv <- mconcat <$> mapM (branchEnvs sym (toListEnv env)) ms mkSeq sym len elty =<< memoMap sym len (indexSeqMap $ \i -> do evalExpr sym (evalListEnv lenv i) body) {-# SPECIALIZE branchEnvs :: (?range :: Range, ConcPrims) => Concrete -> ListEnv Concrete -> [Match] -> SEval Concrete (ListEnv Concrete) #-} -- | Turn a list of matches into the final environments for each iteration of -- the branch. branchEnvs :: (?range :: Range, EvalPrims sym) => sym -> ListEnv sym -> [Match] -> SEval sym (ListEnv sym) branchEnvs sym env matches = snd <$> foldM (evalMatch sym) (1, env) matches {-# SPECIALIZE evalMatch :: (?range :: Range, ConcPrims) => Concrete -> (Integer, ListEnv Concrete) -> Match -> SEval Concrete (Integer, ListEnv Concrete) #-} -- | Turn a match into the list of environments it represents. evalMatch :: (?range :: Range, EvalPrims sym) => sym -> (Integer, ListEnv sym) -> Match -> SEval sym (Integer, ListEnv sym) evalMatch sym (lsz, lenv) m = seq lsz $ 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 sym (Nat lsz) $ indexSeqMap $ \i -> evalExpr sym (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 <$> indexWordValue sym w r VSeq _ xs' -> lookupSeqMap xs' r VStream xs' -> lookupSeqMap xs' r _ -> evalPanic "evalMatch" ["Not a list value"] return (lsz * nLen, 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 = IntMap.union (fmap (Right . ($ 0)) (leVars lenv)) (leStatic lenv) let lenv' = lenv { leVars = IntMap.empty , leStatic = allvars } let env = EvalEnv allvars (leTypes lenv) xs <- evalExpr sym env expr let vs i = case xs of VWord _ w -> VBit <$> indexWordValue sym w i VSeq _ xs' -> lookupSeqMap xs' i VStream xs' -> lookupSeqMap xs' i _ -> evalPanic "evalMatch" ["Not a list value"] -- Selecting from an infinite list effectively resets the length of the -- list environment, so return 1 as the length return (1, 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 (lsz, bindVarList (dName d) (\i -> f (evalListEnv lenv i)) lenv) where f env = case dDefinition d of DPrim -> evalPanic "evalMatch" ["Unexpected local primitive"] DForeign _ -> evalPanic "evalMatch" ["Unexpected local foreign"] DExpr e -> evalExpr sym env e cryptol-3.0.0/src/Cryptol/Eval/0000755000000000000000000000000007346545000014511 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/Eval/Concrete.hs0000644000000000000000000004545607346545000016625 0ustar0000000000000000-- | -- Module : Cryptol.Eval.Concrete -- Copyright : (c) 2013-2020 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Cryptol.Eval.Concrete ( module Cryptol.Backend.Concrete , Value , primTable , toExpr ) where import Control.Monad (guard, zipWithM, foldM, mzero) import Data.Ratio(numerator,denominator) import Data.Word(Word32, Word64) import MonadLib( ChoiceT, findOne, lift ) import qualified LibBF as FP import qualified Cryptol.F2 as F2 import qualified Data.Map.Strict as Map import Data.Map(Map) import Cryptol.TypeCheck.Solver.InfNat (Nat'(..)) import Cryptol.Backend import Cryptol.Backend.Concrete import Cryptol.Backend.FloatHelpers import Cryptol.Backend.Monad import Cryptol.Backend.SeqMap import Cryptol.Backend.WordValue import Cryptol.Eval.Generic import Cryptol.Eval.Prims import Cryptol.Eval.Type import Cryptol.Eval.Value import qualified Cryptol.SHA as SHA import qualified Cryptol.AES as AES import qualified Cryptol.PrimeEC as PrimeEC import Cryptol.ModuleSystem.Name import Cryptol.TypeCheck.AST as AST import Cryptol.Utils.Panic (panic) import Cryptol.Utils.Ident (PrimIdent,prelPrim,floatPrim,suiteBPrim,primeECPrim) import Cryptol.Utils.PP import Cryptol.Utils.RecordMap type Value = GenValue Concrete -- Value to Expression conversion ---------------------------------------------- -- | Given an expected type, returns an expression that evaluates to -- this value, if we can determine it. toExpr :: PrimMap -> TValue -> Value -> Eval (Maybe AST.Expr) toExpr prims t0 v0 = findOne (go t0 v0) where prim n = ePrim prims (prelPrim n) go :: TValue -> Value -> ChoiceT Eval Expr go ty val = case (ty,val) of (TVRec tfs, VRecord vfs) -> do -- NB, vfs first argument to keep their display order res <- zipRecordsM (\_lbl v t -> go t =<< lift v) vfs tfs case res of Left _ -> mismatch -- different fields Right efs -> pure (ERec efs) (TVNewtype nt ts tfs, VRecord vfs) -> do -- NB, vfs first argument to keep their display order res <- zipRecordsM (\_lbl v t -> go t =<< lift v) vfs tfs case res of Left _ -> mismatch -- different fields Right efs -> let f = foldl (\x t -> ETApp x (tNumValTy t)) (EVar (ntConName nt)) ts in pure (EApp f (ERec efs)) (TVTuple ts, VTuple tvs) -> do guard (length ts == length tvs) ETuple <$> (zipWithM go ts =<< lift (sequence tvs)) (TVBit, VBit b) -> pure (prim (if b then "True" else "False")) (TVInteger, VInteger i) -> pure $ ETApp (ETApp (prim "number") (tNum i)) tInteger (TVIntMod n, VInteger i) -> pure $ ETApp (ETApp (prim "number") (tNum i)) (tIntMod (tNum n)) (TVRational, VRational (SRational n d)) -> do let n' = ETApp (ETApp (prim "number") (tNum n)) tInteger let d' = ETApp (ETApp (prim "number") (tNum d)) tInteger pure $ EApp (EApp (prim "ratio") n') d' (TVFloat e p, VFloat i) -> pure (floatToExpr prims (tNum e) (tNum p) (bfValue i)) (TVSeq _ b, VSeq n svs) -> do ses <- traverse (go b) =<< lift (sequence (enumerateSeqMap n svs)) pure $ EList ses (tValTy b) (TVSeq n TVBit, VWord _ wval) -> do BV _ v <- lift (asWordVal Concrete wval) pure $ ETApp (ETApp (prim "number") (tNum v)) (tWord (tNum n)) (_,VStream{}) -> mzero (_,VFun{}) -> mzero (_,VPoly{}) -> mzero (_,VNumPoly{}) -> mzero _ -> mismatch where mismatch :: forall a. ChoiceT Eval a mismatch = do doc <- lift (ppValue Concrete defaultPPOpts val) panic "Cryptol.Eval.Concrete.toExpr" ["type mismatch:" , pretty (tValTy ty) , show doc ] floatToExpr :: PrimMap -> AST.Type -> AST.Type -> FP.BigFloat -> AST.Expr floatToExpr prims eT pT f = case FP.bfToRep f of FP.BFNaN -> mkP "fpNaN" FP.BFRep sign num -> case (sign,num) of (FP.Pos, FP.Zero) -> mkP "fpPosZero" (FP.Neg, FP.Zero) -> mkP "fpNegZero" (FP.Pos, FP.Inf) -> mkP "fpPosInf" (FP.Neg, FP.Inf) -> mkP "fpNegInf" (_, FP.Num m e) -> let r = toRational m * (2 ^^ e) in EProofApp $ ePrim prims (prelPrim "fraction") `ETApp` tNum (numerator r) `ETApp` tNum (denominator r) `ETApp` tNum (0 :: Int) `ETApp` tFloat eT pT where mkP n = EProofApp $ ePrim prims (floatPrim n) `ETApp` eT `ETApp` pT -- Primitives ------------------------------------------------------------------ primTable :: IO EvalOpts -> Map PrimIdent (Prim Concrete) primTable getEOpts = let sym = Concrete in Map.union (genericPrimTable sym getEOpts) $ Map.union (genericFloatTable sym) $ Map.union suiteBPrims $ Map.union primeECPrims $ Map.fromList $ map (\(n, v) -> (prelPrim n, v)) [ -- Indexing and updates ("@" , {-# SCC "Prelude::(@)" #-} indexPrim sym IndexForward indexFront_int indexFront_segs) , ("!" , {-# SCC "Prelude::(!)" #-} indexPrim sym IndexBackward indexFront_int indexFront_segs) , ("update" , {-# SCC "Prelude::update" #-} updatePrim sym updateFront_word updateFront) , ("updateEnd" , {-# SCC "Prelude::updateEnd" #-} updatePrim sym updateBack_word updateBack) , ("pmult", PFinPoly \u -> PFinPoly \v -> PWordFun \(BV _ x) -> PWordFun \(BV _ y) -> PPrim let z = if u <= v then F2.pmult (fromInteger (u+1)) x y else F2.pmult (fromInteger (v+1)) y x in return . VWord (1+u+v) . wordVal . mkBv (1+u+v) $! z) , ("pmod", PFinPoly \_u -> PFinPoly \v -> PWordFun \(BV w x) -> PWordFun \(BV _ m) -> PPrim do assertSideCondition sym (m /= 0) DivideByZero return . VWord v . wordVal . mkBv v $! F2.pmod (fromInteger w) x m) , ("pdiv", PFinPoly \_u -> PFinPoly \_v -> PWordFun \(BV w x) -> PWordFun \(BV _ m) -> PPrim do assertSideCondition sym (m /= 0) DivideByZero return . VWord w . wordVal . mkBv w $! F2.pdiv (fromInteger w) x m) ] primeECPrims :: Map.Map PrimIdent (Prim Concrete) primeECPrims = Map.fromList $ map (\(n,v) -> (primeECPrim n, v)) [ ("ec_double", {-# SCC "PrimeEC::ec_double" #-} PFinPoly \p -> PFun \s -> PPrim do s' <- toProjectivePoint =<< s let r = PrimeEC.ec_double (PrimeEC.primeModulus p) s' fromProjectivePoint $! r) , ("ec_add_nonzero", {-# SCC "PrimeEC::ec_add_nonzero" #-} PFinPoly \p -> PFun \s -> PFun \t -> PPrim do s' <- toProjectivePoint =<< s t' <- toProjectivePoint =<< t let r = PrimeEC.ec_add_nonzero (PrimeEC.primeModulus p) s' t' fromProjectivePoint $! r) , ("ec_mult", {-# SCC "PrimeEC::ec_mult" #-} PFinPoly \p -> PFun \d -> PFun \s -> PPrim do d' <- fromVInteger <$> d s' <- toProjectivePoint =<< s let r = PrimeEC.ec_mult (PrimeEC.primeModulus p) d' s' fromProjectivePoint $! r) , ("ec_twin_mult", {-# SCC "PrimeEC::ec_twin_mult" #-} PFinPoly \p -> PFun \d0 -> PFun \s -> PFun \d1 -> PFun \t -> PPrim do d0' <- fromVInteger <$> d0 s' <- toProjectivePoint =<< s d1' <- fromVInteger <$> d1 t' <- toProjectivePoint =<< t let r = PrimeEC.ec_twin_mult (PrimeEC.primeModulus p) d0' s' d1' t' fromProjectivePoint $! r) ] toProjectivePoint :: Value -> Eval PrimeEC.ProjectivePoint toProjectivePoint v = PrimeEC.toProjectivePoint <$> f "x" <*> f "y" <*> f "z" where f nm = fromVInteger <$> lookupRecord nm v fromProjectivePoint :: PrimeEC.ProjectivePoint -> Eval Value fromProjectivePoint (PrimeEC.ProjectivePoint x y z) = pure . VRecord . recordFromFields $ [("x", f x), ("y", f y), ("z", f z)] where f i = pure (VInteger (PrimeEC.bigNatToInteger i)) suiteBPrims :: Map.Map PrimIdent (Prim Concrete) suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) [ ("processSHA2_224", {-# SCC "SuiteB::processSHA2_224" #-} PFinPoly \n -> PFun \xs -> PPrim do blks <- enumerateSeqMap n . fromVSeq <$> xs (SHA.SHA256S w0 w1 w2 w3 w4 w5 w6 _) <- foldM (\st blk -> seq st (SHA.processSHA256Block st <$> (toSHA256Block =<< blk))) SHA.initialSHA224State blks let f :: Word32 -> Eval Value f = pure . VWord 32 . wordVal . BV 32 . toInteger zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6]) seq zs (pure (VSeq 7 zs))) , ("processSHA2_256", {-# SCC "SuiteB::processSHA2_256" #-} PFinPoly \n -> PFun \xs -> PPrim do blks <- enumerateSeqMap n . fromVSeq <$> xs (SHA.SHA256S w0 w1 w2 w3 w4 w5 w6 w7) <- foldM (\st blk -> seq st (SHA.processSHA256Block st <$> (toSHA256Block =<< blk))) SHA.initialSHA256State blks let f :: Word32 -> Eval Value f = pure . VWord 32 . wordVal . BV 32 . toInteger zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7]) seq zs (pure (VSeq 8 zs))) , ("processSHA2_384", {-# SCC "SuiteB::processSHA2_384" #-} PFinPoly \n -> PFun \xs -> PPrim do blks <- enumerateSeqMap n . fromVSeq <$> xs (SHA.SHA512S w0 w1 w2 w3 w4 w5 _ _) <- foldM (\st blk -> seq st (SHA.processSHA512Block st <$> (toSHA512Block =<< blk))) SHA.initialSHA384State blks let f :: Word64 -> Eval Value f = pure . VWord 64 . wordVal . BV 64 . toInteger zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5]) seq zs (pure (VSeq 6 zs))) , ("processSHA2_512", {-# SCC "SuiteB::processSHA2_512" #-} PFinPoly \n -> PFun \xs -> PPrim do blks <- enumerateSeqMap n . fromVSeq <$> xs (SHA.SHA512S w0 w1 w2 w3 w4 w5 w6 w7) <- foldM (\st blk -> seq st (SHA.processSHA512Block st <$> (toSHA512Block =<< blk))) SHA.initialSHA512State blks let f :: Word64 -> Eval Value f = pure . VWord 64 . wordVal . BV 64 . toInteger zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7]) seq zs (pure (VSeq 8 zs))) , ("AESKeyExpand", {-# SCC "SuiteB::AESKeyExpand" #-} PFinPoly \k -> PFun \seed -> PPrim do ss <- fromVSeq <$> seed let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESInfKeyExpand" =<< lookupSeqMap ss i) let fromWord :: Word32 -> Eval Value fromWord = pure . VWord 32 . wordVal . BV 32 . toInteger kws <- mapM toWord [0 .. k-1] let ws = AES.keyExpansionWords k kws let len = 4*(k+7) pure (VSeq len (finiteSeqMap Concrete (map fromWord ws)))) , ("AESInvMixColumns", {-# SCC "SuiteB::AESInvMixColumns" #-} PFun \st -> PPrim do ss <- fromVSeq <$> st let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESInvMixColumns" =<< lookupSeqMap ss i) let fromWord :: Word32 -> Eval Value fromWord = pure . VWord 32 . wordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.invMixColumns ws pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') , ("AESEncRound", {-# SCC "SuiteB::AESEncRound" #-} PFun \st -> PPrim do ss <- fromVSeq <$> st let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESEncRound" =<< lookupSeqMap ss i) let fromWord :: Word32 -> Eval Value fromWord = pure . VWord 32 . wordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.aesRound ws pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') , ("AESEncFinalRound", {-# SCC "SuiteB::AESEncFinalRound" #-} PFun \st -> PPrim do ss <- fromVSeq <$> st let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESEncFinalRound" =<< lookupSeqMap ss i) let fromWord :: Word32 -> Eval Value fromWord = pure . VWord 32 . wordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.aesFinalRound ws pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') , ("AESDecRound", {-# SCC "SuiteB::AESDecRound" #-} PFun \st -> PPrim do ss <- fromVSeq <$> st let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESDecRound" =<< lookupSeqMap ss i) let fromWord :: Word32 -> Eval Value fromWord = pure . VWord 32 . wordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.aesInvRound ws pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') , ("AESDecFinalRound", {-# SCC "SuiteB::AESDecFinalRound" #-} PFun \st -> PPrim do ss <- fromVSeq <$> st let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESDecFinalRound" =<< lookupSeqMap ss i) let fromWord :: Word32 -> Eval Value fromWord = pure . VWord 32 . wordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.aesInvFinalRound ws pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') ] toSHA256Block :: Value -> Eval SHA.SHA256Block toSHA256Block blk = do let ws = fromVSeq blk let toWord i = fromInteger . bvVal <$> (fromVWord Concrete "toSHA256Block" =<< lookupSeqMap ws i) SHA.SHA256Block <$> (toWord 0) <*> (toWord 1) <*> (toWord 2) <*> (toWord 3) <*> (toWord 4) <*> (toWord 5) <*> (toWord 6) <*> (toWord 7) <*> (toWord 8) <*> (toWord 9) <*> (toWord 10) <*> (toWord 11) <*> (toWord 12) <*> (toWord 13) <*> (toWord 14) <*> (toWord 15) toSHA512Block :: Value -> Eval SHA.SHA512Block toSHA512Block blk = do let ws = fromVSeq blk let toWord i = fromInteger . bvVal <$> (fromVWord Concrete "toSHA512Block" =<< lookupSeqMap ws i) SHA.SHA512Block <$> (toWord 0) <*> (toWord 1) <*> (toWord 2) <*> (toWord 3) <*> (toWord 4) <*> (toWord 5) <*> (toWord 6) <*> (toWord 7) <*> (toWord 8) <*> (toWord 9) <*> (toWord 10) <*> (toWord 11) <*> (toWord 12) <*> (toWord 13) <*> (toWord 14) <*> (toWord 15) -- Sequence Primitives --------------------------------------------------------- indexFront_int :: Nat' -> TValue -> SeqMap Concrete (GenValue Concrete) -> TValue -> Integer -> Eval Value indexFront_int _mblen _a vs _ix idx = lookupSeqMap vs idx indexFront_segs :: Nat' -> TValue -> SeqMap Concrete (GenValue Concrete) -> TValue -> Integer -> [IndexSegment Concrete] -> Eval Value indexFront_segs _mblen _a vs _ix idx_bits segs = lookupSeqMap vs $! packSegments idx_bits segs packSegments :: Integer -> [IndexSegment Concrete] -> Integer packSegments = loop 0 where loop !val !n segs = case segs of [] -> val [WordIndexSegment (BV _ x)] -> val + x WordIndexSegment (BV xlen x) : bs -> let n' = n - xlen in loop (val + (x*2^n')) n' bs BitIndexSegment True : bs -> let n' = n - 1 in loop (val + 2^n') n' bs BitIndexSegment False : bs -> let n' = n - 1 in loop val n' bs updateFront :: Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> SeqMap Concrete (GenValue Concrete) {- ^ sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> Eval (SeqMap Concrete (GenValue Concrete)) updateFront _len _eltTy vs (Left idx) val = do return $ updateSeqMap vs idx val updateFront _len _eltTy vs (Right w) val = do idx <- bvVal <$> asWordVal Concrete w return $ updateSeqMap vs idx val updateFront_word :: Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> WordValue Concrete {- ^ bit sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> Eval (WordValue Concrete) updateFront_word _len _eltTy bs (Left idx) val = do updateWordValue Concrete bs idx (fromVBit <$> val) updateFront_word _len _eltTy bs (Right w) val = do idx <- bvVal <$> asWordVal Concrete w updateWordValue Concrete bs idx (fromVBit <$> val) updateBack :: Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> SeqMap Concrete (GenValue Concrete) {- ^ sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> Eval (SeqMap Concrete (GenValue Concrete)) updateBack Inf _eltTy _vs _w _val = evalPanic "Unexpected infinite sequence in updateEnd" [] updateBack (Nat n) _eltTy vs (Left idx) val = do return $ updateSeqMap vs (n - idx - 1) val updateBack (Nat n) _eltTy vs (Right w) val = do idx <- bvVal <$> asWordVal Concrete w return $ updateSeqMap vs (n - idx - 1) val updateBack_word :: Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> WordValue Concrete {- ^ bit sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> Eval (WordValue Concrete) updateBack_word Inf _eltTy _bs _w _val = evalPanic "Unexpected infinite sequence in updateEnd" [] updateBack_word (Nat n) _eltTy bs (Left idx) val = do updateWordValue Concrete bs (n - idx - 1) (fromVBit <$> val) updateBack_word (Nat n) _eltTy bs (Right w) val = do idx <- bvVal <$> asWordVal Concrete w updateWordValue Concrete bs (n - idx - 1) (fromVBit <$> val) cryptol-3.0.0/src/Cryptol/Eval/Env.hs0000644000000000000000000000563107346545000015602 0ustar0000000000000000-- | -- Module : Cryptol.Eval.Env -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} module Cryptol.Eval.Env where import Cryptol.Backend import Cryptol.Eval.Prims 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.IntMap.Strict as IntMap import Data.Semigroup import GHC.Generics (Generic) import Prelude () import Prelude.Compat -- Evaluation Environment ------------------------------------------------------ data GenEvalEnv sym = EvalEnv { envVars :: !(IntMap.IntMap (Either (Prim sym) (SEval sym (GenValue sym)))) , envTypes :: !TypeEnv } deriving Generic instance Semigroup (GenEvalEnv sym) where l <> r = EvalEnv { envVars = IntMap.union (envVars l) (envVars r) , envTypes = envTypes l <> envTypes r } instance Monoid (GenEvalEnv sym) where mempty = EvalEnv { envVars = IntMap.empty , envTypes = mempty } mappend = (<>) ppEnv :: Backend sym => sym -> PPOpts -> GenEvalEnv sym -> SEval sym Doc ppEnv sym opts env = brackets . fsep <$> mapM bind (IntMap.toList (envVars env)) where bind (k,Left _) = do return (int k <+> text "<>") bind (k,Right v) = do vdoc <- ppValue sym opts =<< v return (int k <+> text "->" <+> vdoc) -- | Evaluation environment with no bindings emptyEnv :: GenEvalEnv sym emptyEnv = mempty -- | Bind a variable in the evaluation environment. bindVar :: Backend sym => sym -> Name -> SEval sym (GenValue sym) -> GenEvalEnv sym -> SEval sym (GenEvalEnv sym) bindVar sym n val env = do let nm = show $ ppLocName n val' <- sDelayFill sym val Nothing nm return $ env{ envVars = IntMap.insert (nameUnique n) (Right val') (envVars env) } -- | Bind a variable to a value in the evaluation environment, without -- creating a thunk. bindVarDirect :: Backend sym => Name -> Prim sym -> GenEvalEnv sym -> GenEvalEnv sym bindVarDirect n val env = do env{ envVars = IntMap.insert (nameUnique n) (Left val) (envVars env) } -- | Lookup a variable in the environment. {-# INLINE lookupVar #-} lookupVar :: Name -> GenEvalEnv sym -> Maybe (Either (Prim sym) (SEval sym (GenValue sym))) lookupVar n env = IntMap.lookup (nameUnique n) (envVars env) -- | Bind a type variable of kind *. {-# INLINE bindType #-} bindType :: TVar -> Either Nat' TValue -> GenEvalEnv sym -> GenEvalEnv sym bindType p ty env = env{ envTypes = bindTypeVar p ty (envTypes env) } -- | Lookup a type variable. {-# INLINE lookupType #-} lookupType :: TVar -> GenEvalEnv sym -> Maybe (Either Nat' TValue) lookupType p env = lookupTypeVar p (envTypes env) cryptol-3.0.0/src/Cryptol/Eval/FFI.hs0000644000000000000000000004164007346545000015456 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -- | Evaluation of foreign functions. module Cryptol.Eval.FFI ( findForeignDecls , evalForeignDecls ) where import Cryptol.Backend.FFI import Cryptol.Backend.FFI.Error import Cryptol.Eval import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.FFI.FFIType #ifdef FFI_ENABLED import Control.Exception(bracket_) import Data.Either import Data.Foldable import Data.IORef import Data.Proxy import Data.Ratio import Data.Traversable import Data.Word import Foreign import Foreign.C.Types import GHC.Float import LibBF (bfFromDouble, bfToDouble, pattern NearEven) import Numeric.GMP.Raw.Unsafe import Numeric.GMP.Utils import Cryptol.Backend import Cryptol.Backend.Concrete import Cryptol.Backend.FloatHelpers import Cryptol.Backend.Monad import Cryptol.Backend.SeqMap import Cryptol.Eval.Env import Cryptol.Eval.Prims import Cryptol.Eval.Type import Cryptol.Eval.Value import Cryptol.ModuleSystem.Name import Cryptol.Utils.Ident import Cryptol.Utils.RecordMap #endif #ifdef FFI_ENABLED -- | Add the given foreign declarations to the environment, loading their -- implementations from the given 'ForeignSrc'. This is a separate pass from the -- main evaluation functions in "Cryptol.Eval" since it only works for the -- Concrete backend. evalForeignDecls :: ForeignSrc -> [(Name, FFIFunType)] -> EvalEnv -> Eval (Either [FFILoadError] EvalEnv) evalForeignDecls fsrc decls env = io do ePrims <- for decls \(name, ffiFunType) -> fmap ((name,) . foreignPrimPoly name ffiFunType) <$> loadForeignImpl fsrc (unpackIdent $ nameIdent name) pure case partitionEithers ePrims of ([], prims) -> Right $ foldr (uncurry bindVarDirect) env prims (errs, _) -> Left errs -- | Generate a 'Prim' value representing the given foreign function, containing -- all the code necessary to marshal arguments and return values and do the -- actual FFI call. foreignPrimPoly :: Name -> FFIFunType -> ForeignImpl -> Prim Concrete foreignPrimPoly name fft impl = buildNumPoly (ffiTParams fft) mempty where -- Add type lambdas for the type parameters and build a type environment -- that we can look up later to compute e.g. array sizes. -- -- Given [p1, p2, ..., pk] {}, returns -- PNumPoly \n1 -> PNumPoly \n2 -> ... PNumPoly \nk -> -- foreignPrim name fft impl {p1 = n1, p2 = n2, ..., pk = nk} buildNumPoly (tp:tps) tenv = PNumPoly \n -> buildNumPoly tps $ bindTypeVar (TVBound tp) (Left n) tenv buildNumPoly [] tenv = foreignPrim name fft impl tenv -- | Methods for obtaining a return value. The producer of this type must supply -- both 1) a polymorphic IO object directly containing a return value that the -- consumer can instantiate at any 'FFIRet' type, and 2) an effectful function -- that takes some output arguments and modifies what they are pointing at to -- store a return value. The consumer can choose which one to use. data GetRet = GetRet { getRetAsValue :: forall a. FFIRet a => IO a , getRetAsOutArgs :: [SomeFFIArg] -> IO () } -- | Operations needed for returning a basic reference type. data BasicRefRet a = BasicRefRet { -- | Initialize the object before passing to foreign function. initBasicRefRet :: Ptr a -> IO () -- | Free the object after returning from foreign function and obtaining -- return value. , clearBasicRefRet :: Ptr a -> IO () -- | Convert the object to a Cryptol value. , marshalBasicRefRet :: a -> Eval (GenValue Concrete) } -- | Generate the monomorphic part of the foreign 'Prim', given a 'TypeEnv' -- containing all the type arguments we have already received. foreignPrim :: Name -> FFIFunType -> ForeignImpl -> TypeEnv -> Prim Concrete foreignPrim name FFIFunType {..} impl tenv = buildFun ffiArgTypes [] where -- Build up the 'Prim' function for the FFI call. -- -- Given [t1, t2 ... tm] we return -- PStrict \v1 -> PStrict \v2 -> ... PStrict \vm -> PPrim $ -- marshalArg t1 v1 \a1 -> -- marshalArg t2 v2 \a2 -> ... marshalArg tm vm \am -> -- marshalRet ffiRetType GetRet -- { getRetAsValue = callForeignImpl impl [n1, ..., nk, a1, ..., am] -- , getRetAsOutArgs = \[o1, ..., ol] -> -- callForeignImpl impl [n1, ..., nk, a1, ..., am, o1, ..., ol] } buildFun :: [FFIType] -> [(FFIType, GenValue Concrete)] -> Prim Concrete buildFun (argType:argTypes) typesAndVals = PStrict \val -> buildFun argTypes $ typesAndVals ++ [(argType, val)] buildFun [] typesAndVals = PPrim $ marshalArgs typesAndVals \inArgs -> do tyArgs <- traverse marshalTyArg ffiTParams let tyInArgs = tyArgs ++ inArgs marshalRet ffiRetType GetRet { getRetAsValue = callForeignImpl impl tyInArgs , getRetAsOutArgs = callForeignImpl impl . (tyInArgs ++) } -- Look up the value of a type parameter in the type environment and marshal -- it. marshalTyArg :: TParam -> Eval SomeFFIArg marshalTyArg tp | n <= toInteger (maxBound :: CSize) = pure $ SomeFFIArg @CSize $ fromInteger n | otherwise = raiseError Concrete $ FFITypeNumTooBig name tp n where n = evalFinType $ TVar $ TVBound tp -- Marshal the given value as the given FFIType and call the given function -- with the results. A single Cryptol argument may correspond to any number of -- C arguments, so the callback takes a list. -- -- NOTE: the result must be used only in the callback since it may have a -- limited lifetime (e.g. pointer returned by alloca). marshalArg :: FFIType -> GenValue Concrete -> ([SomeFFIArg] -> Eval a) -> Eval a marshalArg FFIBool val f = f [SomeFFIArg @Word8 (fromBool (fromVBit val))] marshalArg (FFIBasic (FFIBasicVal t)) val f = getMarshalBasicValArg t \doExport -> do arg <- doExport val f [SomeFFIArg arg] marshalArg (FFIBasic (FFIBasicRef t)) val f = getMarshalBasicRefArg t \doExport -> -- Since we need to do Eval actions in an IO callback, we need to manually -- unwrap and wrap the Eval datatype Eval \stk -> doExport val \arg -> with arg \ptr -> runEval stk (f [SomeFFIArg ptr]) marshalArg (FFIArray (map evalFinType -> sizes) bt) val f = case bt of FFIBasicVal t -> getMarshalBasicValArg t \doExport -> -- Since we need to do Eval actions in an IO callback, -- we need to manually unwrap and wrap the Eval datatype Eval \stk -> marshalArrayArg stk \v k -> k =<< runEval stk (doExport v) FFIBasicRef t -> Eval \stk -> getMarshalBasicRefArg t \doExport -> marshalArrayArg stk doExport where marshalArrayArg stk doExport = allocaArray (fromInteger (product sizes)) \ptr -> do -- Traverse the nested sequences and write the elements to the -- array in order. -- ns is the dimensions of the values we are currently -- processing. -- vs is the values we are currently processing. -- nvss is the stack of previous ns and vs that we keep track of -- that we push onto when we start processing a nested sequence -- and pop off when we finish processing the current ones. -- i is the index into the array. let -- write next element of multi-dimensional array write (n:ns) (v:vs) nvss !i = do vs' <- traverse (runEval stk) (enumerateSeqMap n (fromVSeq v)) write ns vs' ((n, vs):nvss) i -- write next element in flat array write [] (v:vs) nvss !i = doExport v \rep -> do pokeElemOff ptr i rep write [] vs nvss (i + 1) -- finished with flat array, do next element of multi-d array write ns [] ((n, vs):nvss) !i = write (n:ns) vs nvss i -- done write _ _ [] _ = pure () write sizes [val] [] 0 runEval stk $ f [SomeFFIArg ptr] marshalArg (FFITuple types) val f = do vals <- sequence (fromVTuple val) marshalArgs (types `zip` vals) f marshalArg (FFIRecord typeMap) val f = do vals <- traverse (`lookupRecord` val) (displayOrder typeMap) marshalArgs (displayElements typeMap `zip` vals) f -- Call marshalArg on a bunch of arguments and collect the results together -- (in the order of the arguments). marshalArgs :: [(FFIType, GenValue Concrete)] -> ([SomeFFIArg] -> Eval a) -> Eval a marshalArgs typesAndVals f = go typesAndVals [] where go [] args = f (concat (reverse args)) go ((t, v):tvs) prevArgs = marshalArg t v \currArgs -> go tvs (currArgs : prevArgs) -- Given an FFIType and a GetRet, obtain a return value and convert it to a -- Cryptol value. The return value is obtained differently depending on the -- FFIType. marshalRet :: FFIType -> GetRet -> Eval (GenValue Concrete) marshalRet FFIBool gr = do rep <- io (getRetAsValue gr @Word8) pure (VBit (toBool rep)) marshalRet (FFIBasic (FFIBasicVal t)) gr = getMarshalBasicValRet t \doImport -> do rep <- io (getRetAsValue gr) doImport rep marshalRet (FFIBasic (FFIBasicRef t)) gr = getBasicRefRet t \how -> Eval \stk -> alloca \ptr -> bracket_ (initBasicRefRet how ptr) (clearBasicRefRet how ptr) do getRetAsOutArgs gr [SomeFFIArg ptr] rep <- peek ptr runEval stk (marshalBasicRefRet how rep) marshalRet (FFIArray (map evalFinType -> sizes) bt) gr = Eval \stk -> do let totalSize = fromInteger (product sizes) getResult marshal ptr = do getRetAsOutArgs gr [SomeFFIArg ptr] let build (n:ns) !i = do -- We need to be careful to actually run this here and not just -- stick the IO action into the sequence with io, or else we -- will read from the array after it is deallocated. vs <- for [0 .. fromInteger n - 1] \j -> build ns (i * fromInteger n + j) pure (VSeq n (finiteSeqMap Concrete (map pure vs))) build [] !i = peekElemOff ptr i >>= runEval stk . marshal build sizes 0 case bt of FFIBasicVal t -> getMarshalBasicValRet t \doImport -> allocaArray totalSize (getResult doImport) FFIBasicRef t -> getBasicRefRet t \how -> allocaArray totalSize \ptr -> do let forEach f = for_ [0 .. totalSize - 1] (f . advancePtr ptr) bracket_ (forEach (initBasicRefRet how)) (forEach (clearBasicRefRet how)) (getResult (marshalBasicRefRet how) ptr) marshalRet (FFITuple types) gr = VTuple <$> marshalMultiRet types gr marshalRet (FFIRecord typeMap) gr = VRecord . recordFromFields . zip (displayOrder typeMap) <$> marshalMultiRet (displayElements typeMap) gr -- Obtain multiple return values as output arguments for a composite return -- type. Each return value is fully evaluated but put back in an Eval since -- VTuple and VRecord expect it. marshalMultiRet :: [FFIType] -> GetRet -> Eval [Eval (GenValue Concrete)] -- Since IO callbacks are involved we just do the whole thing in IO and wrap -- it in an Eval at the end. This should be fine since we are not changing -- the (Cryptol) call stack. marshalMultiRet types gr = Eval \stk -> do -- We use this IORef hack here since we are calling marshalRet recursively -- but marshalRet doesn't let us return any extra information from the -- callback through to the result of the function. So we remember the result -- as a side effect. vals <- newIORef [] let go [] args = getRetAsOutArgs gr args go (t:ts) prevArgs = do val <- runEval stk $ marshalRet t $ getRetFromAsOutArgs \currArgs -> go ts (prevArgs ++ currArgs) modifyIORef' vals (val :) go types [] map pure <$> readIORef vals -- | Call the callback with a 'BasicRefRet' for the given type. getBasicRefRet :: FFIBasicRefType -> (forall a. Storable a => BasicRefRet a -> b) -> b getBasicRefRet (FFIInteger mbMod) f = f BasicRefRet { initBasicRefRet = mpz_init , clearBasicRefRet = mpz_clear , marshalBasicRefRet = \mpz -> do n <- io $ peekInteger' mpz VInteger <$> case mbMod of Nothing -> pure n Just m -> intToZn Concrete (evalFinType m) n } getBasicRefRet FFIRational f = f BasicRefRet { initBasicRefRet = mpq_init , clearBasicRefRet = mpq_clear , marshalBasicRefRet = \mpq -> do r <- io $ peekRational' mpq pure $ VRational $ SRational (numerator r) (denominator r) } -- Evaluate a finite numeric type expression. evalFinType :: Type -> Integer evalFinType = finNat' . evalNumType tenv -- | Given a way to 'getRetAsOutArgs', create a 'GetRet', where the -- 'getRetAsValue' simply allocates a temporary space to call 'getRetAsOutArgs' -- on. This is useful for return types that we know how to obtain directly as a -- value but need to obtain as an output argument when multiple return values -- are involved. getRetFromAsOutArgs :: ([SomeFFIArg] -> IO ()) -> GetRet getRetFromAsOutArgs f = GetRet { getRetAsValue = alloca \ptr -> do f [SomeFFIArg ptr] peek ptr , getRetAsOutArgs = f } -- | Given a 'FFIBasicValType', call the callback with a marshalling function -- that marshals values to the 'FFIArg' type corresponding to the -- 'FFIBasicValType'. The callback must be able to handle marshalling functions -- that marshal to any 'FFIArg' type. getMarshalBasicValArg :: FFIBasicValType -> (forall rep. FFIArg rep => (GenValue Concrete -> Eval rep) -> result) -> result getMarshalBasicValArg (FFIWord _ s) f = withWordType s \(_ :: p t) -> f @t $ fmap (fromInteger . bvVal) . fromVWord Concrete "getMarshalBasicValArg" getMarshalBasicValArg (FFIFloat _ _ s) f = case s of -- LibBF can only convert to 'Double' directly, so we do that first then -- convert to 'Float', which should not result in any loss of precision if -- the original data was 32-bit anyways. FFIFloat32 -> f $ pure . CFloat . double2Float . toDouble FFIFloat64 -> f $ pure . CDouble . toDouble where toDouble = fst . bfToDouble NearEven . bfValue . fromVFloat -- | Given a 'FFIBasicValType', call the callback with an unmarshalling function -- from the 'FFIRet' type corresponding to the 'FFIBasicValType' to Cryptol -- values. The callback must be able to handle unmarshalling functions from any -- 'FFIRet' type. getMarshalBasicValRet :: FFIBasicValType -> (forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b) -> b getMarshalBasicValRet (FFIWord n s) f = withWordType s \(_ :: p t) -> f @t $ word Concrete n . toInteger getMarshalBasicValRet (FFIFloat e p s) f = case s of FFIFloat32 -> f $ toValue . \case CFloat x -> float2Double x FFIFloat64 -> f $ toValue . \case CDouble x -> x where toValue = pure . VFloat . BF e p . bfFromDouble -- | Call the callback with the Word type corresponding to the given -- 'FFIWordSize'. withWordType :: FFIWordSize -> (forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b) -> b withWordType FFIWord8 f = f $ Proxy @Word8 withWordType FFIWord16 f = f $ Proxy @Word16 withWordType FFIWord32 f = f $ Proxy @Word32 withWordType FFIWord64 f = f $ Proxy @Word64 -- | Given a 'FFIBasicRefType', call the callback with a marshalling function -- that takes a Cryptol value and calls its callback with the 'Storable' type -- corresponding to the 'FFIBasicRefType'. getMarshalBasicRefArg :: FFIBasicRefType -> (forall rep. Storable rep => (GenValue Concrete -> (rep -> IO val) -> IO val) -> result) -> result getMarshalBasicRefArg (FFIInteger _) f = f \val g -> withInInteger' (fromVInteger val) g getMarshalBasicRefArg FFIRational f = f \val g -> do let SRational {..} = fromVRational val withInRational' (sNum % sDenom) g #else -- | Dummy implementation for when FFI is disabled. Does not add anything to -- the environment. evalForeignDecls :: ForeignSrc -> [(Name, FFIFunType)] -> EvalEnv -> Eval (Either [FFILoadError] EvalEnv) evalForeignDecls _ _ env = pure $ Right env #endif cryptol-3.0.0/src/Cryptol/Eval/FFI/0000755000000000000000000000000007346545000015115 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/Eval/FFI/GenHeader.hs0000644000000000000000000001655107346545000017303 0ustar0000000000000000{-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} -- | Generate C header files from foreign declarations. module Cryptol.Eval.FFI.GenHeader ( generateForeignHeader ) where import Control.Monad.Writer.Strict import Data.Functor import Data.Char(isAlphaNum) import Data.List import Data.Set (Set) import qualified Data.Set as Set import Language.C99.Pretty as C import qualified Language.C99.Simple as C import qualified Text.PrettyPrint as Pretty import Cryptol.ModuleSystem.Name import Cryptol.TypeCheck.FFI.FFIType import Cryptol.TypeCheck.Type import Cryptol.Utils.Ident import Cryptol.Utils.RecordMap -- | @Include foo@ represents an include statement @#include @ newtype Include = Include String deriving (Eq, Ord) -- | The monad for generating headers. We keep track of which headers we need to -- include and add them to the output at the end. type GenHeaderM = Writer (Set Include) -- | Generate a C header file from the given foreign declarations. generateForeignHeader :: [(Name, FFIFunType)] -> String generateForeignHeader decls = unlines (map renderInclude $ Set.toAscList incs) ++ Pretty.render (C.pretty $ C.translate (C.TransUnit cdecls [])) where (cdecls, incs) = runWriter $ traverse convertFun decls renderInclude :: Include -> String renderInclude (Include inc) = "#include <" ++ inc ++ ">" -- | The "direction" of a parameter (input or output). data ParamDir = In | Out -- | The result of converting a Cryptol type into its C representation. data ConvertResult = Direct C.Type -- ^ A type that can be directly returned if it is a return -- type and passed as a single parameter if it is a Cryptol -- parameter type. | Params [C.Param] -- ^ A type that is turned into a number of parameters, -- for both Cryptol parameter and return type cases. -- | Convert a Cryptol foreign declaration into a C function declaration. convertFun :: (Name, FFIFunType) -> GenHeaderM C.Decln convertFun (fName, FFIFunType {..}) = do let tpIdent = fmap nameIdent . tpName typeParams <- traverse convertTypeParam (pickNames (map tpIdent ffiTParams)) -- Name the input args in0, in1, etc let inPrefixes = case ffiArgTypes of [_] -> ["in"] _ -> ["in" ++ show @Integer i | i <- [0..]] inParams <- convertMultiType In $ zip inPrefixes ffiArgTypes (retType, outParams) <- convertType Out ffiRetType <&> \case Direct u -> (u, []) -- Name the output arg out Params ps -> (C.TypeSpec C.Void, map (prefixParam "out") ps) -- Avoid possible name collisions let params = snd $ mapAccumL renameParam Set.empty $ typeParams ++ inParams ++ outParams renameParam names (C.Param u name) = (Set.insert name' names, C.Param u name') where name' = until (`Set.notMember` names) (++ "_") name pure $ C.FunDecln Nothing retType (unpackIdent $ nameIdent fName) params -- | Convert a Cryptol type parameter to a C value parameter. convertTypeParam :: String -> GenHeaderM C.Param convertTypeParam name = (`C.Param` name) <$> sizeT -- | Convert a Cryptol parameter or return type to C. convertType :: ParamDir -> FFIType -> GenHeaderM ConvertResult convertType _ FFIBool = Direct <$> uint8T convertType _ (FFIBasic t) = convertBasicType t convertType _ (FFIArray _ t) = do u <- convertBasicTypeInArray t pure $ Params [C.Param (C.Ptr u) ""] convertType dir (FFITuple ts) = Params <$> convertMultiType dir -- We name the tuple components using their indices (zip (map (componentSuffix . show @Integer) [0..]) ts) convertType dir (FFIRecord tMap) = Params <$> convertMultiType dir (zip names ts) where (fs,ts) = unzip (displayFields tMap) names = map componentSuffix (pickNames (map Just fs)) -- | Convert many Cryptol types, each associated with a prefix, to C parameters -- named with their prefixes. convertMultiType :: ParamDir -> [(C.Ident, FFIType)] -> GenHeaderM [C.Param] convertMultiType dir = fmap concat . traverse \(prefix, t) -> convertType dir t <&> \case Direct u -> [C.Param u' prefix] where u' = case dir of In -> u -- Turn direct return types into pointer out parameters Out -> C.Ptr u Params ps -> map (prefixParam prefix) ps {- | Convert a basic Cryptol FFI type to a C type with its corresponding calling convention. At present all value types use the same calling convention no matter if they are inputs or outputs, so we don't need the 'ParamDir'. -} convertBasicType :: FFIBasicType -> GenHeaderM ConvertResult convertBasicType bt = case bt of FFIBasicVal bvt -> Direct <$> convertBasicValType bvt FFIBasicRef brt -> do t <- convertBasicRefType brt pure (Params [C.Param t ""]) -- | Convert a basic Cryptol FFI type to a C type. -- This is used when the type is stored in array. convertBasicTypeInArray :: FFIBasicType -> GenHeaderM C.Type convertBasicTypeInArray bt = case bt of FFIBasicVal bvt -> convertBasicValType bvt FFIBasicRef brt -> convertBasicRefType brt -- | Convert a basic Cryptol FFI type to a value C type. convertBasicValType :: FFIBasicValType -> GenHeaderM C.Type convertBasicValType (FFIWord _ s) = case s of FFIWord8 -> uint8T FFIWord16 -> uint16T FFIWord32 -> uint32T FFIWord64 -> uint64T convertBasicValType (FFIFloat _ _ s) = case s of FFIFloat32 -> pure $ C.TypeSpec C.Float FFIFloat64 -> pure $ C.TypeSpec C.Double -- | Convert a basic Cryptol FFI type to a reference C type. convertBasicRefType :: FFIBasicRefType -> GenHeaderM C.Type convertBasicRefType brt = case brt of FFIInteger {} -> mpzT FFIRational -> mpqT prefixParam :: C.Ident -> C.Param -> C.Param prefixParam pre (C.Param u name) = C.Param u (pre ++ name) -- | Create a suffix corresponding to some component name of some larger type. componentSuffix :: String -> C.Ident componentSuffix = ('_' :) sizeT, uint8T, uint16T, uint32T, uint64T, mpzT, mpqT :: GenHeaderM C.Type sizeT = typedefFromInclude stddefH "size_t" uint8T = typedefFromInclude stdintH "uint8_t" uint16T = typedefFromInclude stdintH "uint16_t" uint32T = typedefFromInclude stdintH "uint32_t" uint64T = typedefFromInclude stdintH "uint64_t" mpzT = typedefFromInclude gmpH "mpz_t" mpqT = typedefFromInclude gmpH "mpq_t" stddefH, stdintH, gmpH :: Include stddefH = Include "stddef.h" stdintH = Include "stdint.h" gmpH = Include "gmp.h" -- | Return a type with the given name, included from some header file. typedefFromInclude :: Include -> C.Ident -> GenHeaderM C.Type typedefFromInclude inc u = do tell $ Set.singleton inc pure $ C.TypeSpec $ C.TypedefName u -- | Given some Cryptol identifiers (normal ones, not operators) -- pick suitable unique C names for them pickNames :: [Maybe Ident] -> [String] pickNames xs = snd (mapAccumL add Set.empty xs) where add known x = let y = simplify x ys = y : [ y ++ show i | i <- [ 0 :: Int .. ] ] y' : _ = dropWhile (`Set.member` known) ys in (Set.insert y' known, y') simplify x = case x of Just i | let y = filter ok (unpackIdent i), not (null y) -> y _ -> "zz" ok x = x == '_' || isAlphaNum x cryptol-3.0.0/src/Cryptol/Eval/Generic.hs0000644000000000000000000021744707346545000016440 0ustar0000000000000000-- | -- Module : Cryptol.Eval.Generic -- Copyright : (c) 2013-2020 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE LambdaCase #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Cryptol.Eval.Generic where import qualified Control.Exception as X import Control.Monad(join) import Control.Monad.IO.Class (MonadIO(..)) import System.Random.TF.Gen (seedTFGen) import Data.Bits ((.&.), shiftR) import Data.Maybe (fromMaybe) import qualified Data.Map.Strict as Map import Data.Map(Map) import Data.Ratio ((%)) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Solver.InfNat (Nat'(..),nMul,nAdd) import Cryptol.Backend import Cryptol.Backend.Concrete (Concrete(..)) import Cryptol.Backend.Monad( Eval, evalPanic, EvalError(..), Unsupported(..) ) import Cryptol.Backend.SeqMap import Cryptol.Backend.WordValue import Cryptol.Testing.Random( randomValue ) import Cryptol.Eval.Prims import Cryptol.Eval.Type import Cryptol.Eval.Value import Cryptol.Utils.Ident (PrimIdent, prelPrim, floatPrim) import Cryptol.Utils.Logger(logPrint) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.PP import Cryptol.Utils.RecordMap {-# SPECIALIZE mkLit :: Concrete -> TValue -> Integer -> Eval (GenValue Concrete) #-} -- | Make a numeric literal value at the given type. mkLit :: Backend sym => sym -> TValue -> Integer -> SEval sym (GenValue sym) mkLit sym ty i = case ty of TVBit -> pure $ VBit (bitLit sym (i > 0)) TVInteger -> VInteger <$> integerLit sym i TVIntMod m | m == 0 -> evalPanic "mkLit" ["0 modulus not allowed"] | otherwise -> VInteger <$> integerLit sym (i `mod` m) TVFloat e p -> VFloat <$> fpLit sym e p (fromInteger i) TVSeq w TVBit -> word sym w i TVRational -> VRational <$> (intToRational sym =<< integerLit sym i) _ -> evalPanic "Cryptol.Eval.Prim.evalConst" [ "Invalid type for number" ] {-# SPECIALIZE ecNumberV :: Concrete -> Prim Concrete #-} -- | Make a numeric constant. ecNumberV :: Backend sym => sym -> Prim sym ecNumberV sym = PNumPoly \valT -> PTyPoly \ty -> PPrim case valT of Nat v -> mkLit sym ty v _ -> evalPanic "Cryptol.Eval.Prim.evalConst" ["Unexpected Inf in constant." , show valT , show ty ] {-# SPECIALIZE intV :: Concrete -> Integer -> TValue -> Eval (GenValue Concrete) #-} intV :: Backend sym => sym -> SInteger sym -> TValue -> SEval sym (GenValue sym) intV sym i = ringNullary sym (\w -> wordFromInt sym w i) (pure i) (\m -> intToZn sym m i) (intToRational sym i) (\e p -> fpRndMode sym >>= \r -> fpFromInteger sym e p r i) {-# SPECIALIZE ratioV :: Concrete -> Prim Concrete #-} ratioV :: Backend sym => sym -> Prim sym ratioV sym = PFun \x -> PFun \y -> PPrim do x' <- fromVInteger <$> x y' <- fromVInteger <$> y VRational <$> ratio sym x' y' {-# SPECIALIZE ecFractionV :: Concrete -> Prim Concrete #-} ecFractionV :: Backend sym => sym -> Prim sym ecFractionV sym = PFinPoly \n -> PFinPoly \d -> PFinPoly \_r -> PTyPoly \ty -> PPrim case ty of TVFloat e p -> VFloat <$> fpLit sym e p (n % d) TVRational -> do x <- integerLit sym n y <- integerLit sym d VRational <$> ratio sym x y _ -> evalPanic "ecFractionV" [ "Unexpected `FLiteral` type: " ++ show ty ] {-# SPECIALIZE fromZV :: Concrete -> Prim Concrete #-} fromZV :: Backend sym => sym -> Prim sym fromZV sym = PFinPoly \n -> PFun \v -> PPrim (VInteger <$> (znToInt sym n . fromVInteger =<< v)) -- Operation Lifting ----------------------------------------------------------- type Binary sym = TValue -> GenValue sym -> GenValue sym -> SEval sym (GenValue sym) {-# SPECIALIZE binary :: Binary Concrete -> Prim Concrete #-} binary :: Backend sym => Binary sym -> Prim sym binary f = PTyPoly \ty -> PFun \a -> PFun \b -> PPrim $ do x <- a y <- b f ty x y type Unary sym = TValue -> GenValue sym -> SEval sym (GenValue sym) {-# SPECIALIZE unary :: Unary Concrete -> Prim Concrete #-} unary :: Backend sym => Unary sym -> Prim sym unary f = PTyPoly \ty -> PFun \a -> PPrim (f ty =<< a) type BinWord sym = Integer -> SWord sym -> SWord sym -> SEval sym (SWord sym) {-# SPECIALIZE ringBinary :: Concrete -> BinWord Concrete -> (SInteger Concrete -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) -> (Integer -> SInteger Concrete -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) -> (SRational Concrete -> SRational Concrete -> SEval Concrete (SRational Concrete)) -> (SFloat Concrete -> SFloat Concrete -> SEval Concrete (SFloat Concrete)) -> Binary Concrete #-} ringBinary :: forall sym. Backend sym => sym -> BinWord sym -> (SInteger sym -> SInteger sym -> SEval sym (SInteger sym)) -> (Integer -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym)) -> (SRational sym -> SRational sym -> SEval sym (SRational sym)) -> (SFloat sym -> SFloat sym -> SEval sym (SFloat sym)) -> Binary sym ringBinary sym opw opi opz opq opfp = loop where loop' :: TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) loop' ty l r = join (loop ty <$> l <*> r) loop :: TValue -> GenValue sym -> GenValue sym -> SEval sym (GenValue sym) loop ty l r = case ty of TVBit -> evalPanic "ringBinary" ["Bit not in class Ring"] TVInteger -> VInteger <$> opi (fromVInteger l) (fromVInteger r) TVIntMod n -> VInteger <$> opz n (fromVInteger l) (fromVInteger r) TVFloat {} -> VFloat <$> opfp (fromVFloat l) (fromVFloat r) TVRational -> VRational <$> opq (fromVRational l) (fromVRational r) TVArray{} -> evalPanic "arithBinary" ["Array not in class Ring"] TVSeq w a -- words and finite sequences | isTBit a -> do lw <- fromVWord sym "ringLeft" l rw <- fromVWord sym "ringRight" r stk <- sGetCallStack sym VWord w . wordVal <$> (sWithCallStack sym stk (opw w lw rw)) | otherwise -> VSeq w <$> (join (zipSeqMap sym (loop a) (Nat w) <$> (fromSeq "ringBinary left" l) <*> (fromSeq "ringBinary right" r))) TVStream a -> -- streams VStream <$> (join (zipSeqMap sym (loop a) Inf <$> (fromSeq "ringBinary left" l) <*> (fromSeq "ringBinary right" r))) -- functions TVFun _ ety -> lam sym $ \ x -> loop' ety (fromVFun sym l x) (fromVFun sym r x) -- tuples TVTuple tys -> do ls <- mapM (sDelay sym) (fromVTuple l) rs <- mapM (sDelay sym) (fromVTuple r) return $ VTuple (zipWith3 loop' tys ls rs) -- records TVRec fs -> do VRecord <$> traverseRecordMap (\f fty -> sDelay sym (loop' fty (lookupRecord f l) (lookupRecord f r))) fs TVAbstract {} -> evalPanic "ringBinary" ["Abstract type not in `Ring`"] TVNewtype {} -> evalPanic "ringBinary" ["Newtype not in `Ring`"] type UnaryWord sym = Integer -> SWord sym -> SEval sym (SWord sym) {-# SPECIALIZE ringUnary :: Concrete -> UnaryWord Concrete -> (SInteger Concrete -> SEval Concrete (SInteger Concrete)) -> (Integer -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) -> (SRational Concrete -> SEval Concrete (SRational Concrete)) -> (SFloat Concrete -> SEval Concrete (SFloat Concrete)) -> Unary Concrete #-} ringUnary :: forall sym. Backend sym => sym -> UnaryWord sym -> (SInteger sym -> SEval sym (SInteger sym)) -> (Integer -> SInteger sym -> SEval sym (SInteger sym)) -> (SRational sym -> SEval sym (SRational sym)) -> (SFloat sym -> SEval sym (SFloat sym)) -> Unary sym ringUnary sym opw opi opz opq opfp = loop where loop' :: TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) loop' ty v = loop ty =<< v loop :: TValue -> GenValue sym -> SEval sym (GenValue sym) loop ty v = case ty of TVBit -> evalPanic "ringUnary" ["Bit not in class Ring"] TVInteger -> VInteger <$> opi (fromVInteger v) TVIntMod n -> VInteger <$> opz n (fromVInteger v) TVFloat {} -> VFloat <$> opfp (fromVFloat v) TVRational -> VRational <$> opq (fromVRational v) TVArray{} -> evalPanic "arithUnary" ["Array not in class Ring"] TVSeq w a -- words and finite sequences | isTBit a -> do wx <- fromVWord sym "ringUnary" v stk <- sGetCallStack sym VWord w . wordVal <$> sWithCallStack sym stk (opw w wx) | otherwise -> VSeq w <$> (mapSeqMap sym (loop a) (Nat w) =<< fromSeq "ringUnary" v) TVStream a -> VStream <$> (mapSeqMap sym (loop a) Inf =<< fromSeq "ringUnary" v) -- functions TVFun _ ety -> lam sym $ \ y -> loop' ety (fromVFun sym v y) -- tuples TVTuple tys -> do as <- mapM (sDelay sym) (fromVTuple v) return $ VTuple (zipWith loop' tys as) -- records TVRec fs -> VRecord <$> traverseRecordMap (\f fty -> sDelay sym (loop' fty (lookupRecord f v))) fs TVAbstract {} -> evalPanic "ringUnary" ["Abstract type not in `Ring`"] TVNewtype {} -> evalPanic "ringUnary" ["Newtype not in `Ring`"] {-# SPECIALIZE ringNullary :: Concrete -> (Integer -> SEval Concrete (SWord Concrete)) -> SEval Concrete (SInteger Concrete) -> (Integer -> SEval Concrete (SInteger Concrete)) -> SEval Concrete (SRational Concrete) -> (Integer -> Integer -> SEval Concrete (SFloat Concrete)) -> TValue -> SEval Concrete (GenValue Concrete) #-} ringNullary :: forall sym. Backend sym => sym -> (Integer -> SEval sym (SWord sym)) -> SEval sym (SInteger sym) -> (Integer -> SEval sym (SInteger sym)) -> SEval sym (SRational sym) -> (Integer -> Integer -> SEval sym (SFloat sym)) -> TValue -> SEval sym (GenValue sym) ringNullary sym opw opi opz opq opfp = loop where loop :: TValue -> SEval sym (GenValue sym) loop ty = case ty of TVBit -> evalPanic "ringNullary" ["Bit not in class Ring"] TVInteger -> VInteger <$> opi TVIntMod n -> VInteger <$> opz n TVFloat e p -> VFloat <$> opfp e p TVRational -> VRational <$> opq TVArray{} -> evalPanic "arithNullary" ["Array not in class Ring"] TVSeq w a -- words and finite sequences | isTBit a -> do stk <- sGetCallStack sym VWord w . wordVal <$> sWithCallStack sym stk (opw w) | otherwise -> do v <- sDelay sym (loop a) pure $ VSeq w $ indexSeqMap \_i -> v TVStream a -> do v <- sDelay sym (loop a) pure $ VStream $ indexSeqMap \_i -> v TVFun _ b -> do v <- sDelay sym (loop b) lam sym (const v) TVTuple tys -> do xs <- mapM (sDelay sym . loop) tys pure $ VTuple xs TVRec fs -> do xs <- traverse (sDelay sym . loop) fs pure $ VRecord xs TVAbstract {} -> evalPanic "ringNullary" ["Abstract type not in `Ring`"] TVNewtype {} -> evalPanic "ringNullary" ["Newtype not in `Ring`"] {-# SPECIALIZE integralBinary :: Concrete -> BinWord Concrete -> (SInteger Concrete -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) -> Binary Concrete #-} integralBinary :: forall sym. Backend sym => sym -> BinWord sym -> (SInteger sym -> SInteger sym -> SEval sym (SInteger sym)) -> Binary sym integralBinary sym opw opi ty l r = case ty of TVInteger -> VInteger <$> opi (fromVInteger l) (fromVInteger r) -- bitvectors TVSeq w a | isTBit a -> do wl <- fromVWord sym "integralBinary left" l wr <- fromVWord sym "integralBinary right" r stk <- sGetCallStack sym VWord w . wordVal <$> sWithCallStack sym stk (opw w wl wr) _ -> evalPanic "integralBinary" [show ty ++ " not int class `Integral`"] --------------------------------------------------------------------------- -- Ring {-# SPECIALIZE fromIntegerV :: Concrete -> Prim Concrete #-} -- | Convert an unbounded integer to a value in Ring fromIntegerV :: Backend sym => sym -> Prim sym fromIntegerV sym = PTyPoly \a -> PFun \v -> PPrim do i <- fromVInteger <$> v intV sym i a {-# INLINE addV #-} addV :: Backend sym => sym -> Binary sym addV sym = ringBinary sym opw opi opz opq opfp where opw _w x y = wordPlus sym x y opi x y = intPlus sym x y opz m x y = znPlus sym m x y opq x y = rationalAdd sym x y opfp x y = fpRndMode sym >>= \r -> fpPlus sym r x y {-# INLINE subV #-} subV :: Backend sym => sym -> Binary sym subV sym = ringBinary sym opw opi opz opq opfp where opw _w x y = wordMinus sym x y opi x y = intMinus sym x y opz m x y = znMinus sym m x y opq x y = rationalSub sym x y opfp x y = fpRndMode sym >>= \r -> fpMinus sym r x y {-# INLINE negateV #-} negateV :: Backend sym => sym -> Unary sym negateV sym = ringUnary sym opw opi opz opq opfp where opw _w x = wordNegate sym x opi x = intNegate sym x opz m x = znNegate sym m x opq x = rationalNegate sym x opfp x = fpNeg sym x {-# INLINE mulV #-} mulV :: Backend sym => sym -> Binary sym mulV sym = ringBinary sym opw opi opz opq opfp where opw _w x y = wordMult sym x y opi x y = intMult sym x y opz m x y = znMult sym m x y opq x y = rationalMul sym x y opfp x y = fpRndMode sym >>= \r -> fpMult sym r x y -------------------------------------------------- -- Integral {-# INLINE divV #-} divV :: Backend sym => sym -> Binary sym divV sym = integralBinary sym opw opi where opw _w x y = wordDiv sym x y opi x y = intDiv sym x y {-# SPECIALIZE expV :: Concrete -> Prim Concrete #-} expV :: Backend sym => sym -> Prim sym expV sym = PTyPoly \aty -> PTyPoly \ety -> PFun \am -> PFun \em -> PPrim do a <- am e <- em case ety of TVInteger -> let ei = fromVInteger e in case integerAsLit sym ei of Just n | n == 0 -> do onei <- integerLit sym 1 intV sym onei aty | n > 0 -> do (_,ebits) <- enumerateIntBits' sym n ei computeExponent sym aty a ebits | otherwise -> raiseError sym NegativeExponent Nothing -> liftIO (X.throw (UnsupportedSymbolicOp "integer exponentiation")) TVSeq _w el | isTBit el -> do ebits <- enumerateWordValue sym (fromWordVal "(^^)" e) computeExponent sym aty a ebits _ -> evalPanic "expV" [show ety ++ " not int class `Integral`"] {-# SPECIALIZE computeExponent :: Concrete -> TValue -> GenValue Concrete -> [SBit Concrete] -> SEval Concrete (GenValue Concrete) #-} computeExponent :: Backend sym => sym -> TValue -> GenValue sym -> [SBit sym] -> SEval sym (GenValue sym) computeExponent sym aty a bs0 = do onei <- integerLit sym 1 one <- intV sym onei aty loop one (dropLeadingZeros bs0) where dropLeadingZeros [] = [] dropLeadingZeros (b:bs) | Just False <- bitAsLit sym b = dropLeadingZeros bs | otherwise = (b:bs) loop acc [] = return acc loop acc (b:bs) = do sq <- mulV sym aty acc acc acc' <- iteValue sym b (mulV sym aty a sq) (pure sq) loop acc' bs {-# INLINE modV #-} modV :: Backend sym => sym -> Binary sym modV sym = integralBinary sym opw opi where opw _w x y = wordMod sym x y opi x y = intMod sym x y {-# SPECIALIZE toIntegerV :: Concrete -> Prim Concrete #-} -- | Convert a word to a non-negative integer. toIntegerV :: Backend sym => sym -> Prim sym toIntegerV sym = PTyPoly \a -> PFun \v -> PPrim case a of TVSeq _w el | isTBit el -> VInteger <$> (wordToInt sym =<< (fromVWord sym "toInteger" =<< v)) TVInteger -> v _ -> evalPanic "toInteger" [show a ++ " not in class `Integral`"] ----------------------------------------------------------------------------- -- Field {-# SPECIALIZE recipV :: Concrete -> Prim Concrete #-} recipV :: Backend sym => sym -> Prim sym recipV sym = PTyPoly \a -> PFun \x -> PPrim case a of TVRational -> VRational <$> (rationalRecip sym . fromVRational =<< x) TVFloat e p -> do one <- fpLit sym e p 1 r <- fpRndMode sym xv <- fromVFloat <$> x VFloat <$> fpDiv sym r one xv TVIntMod m -> VInteger <$> (znRecip sym m . fromVInteger =<< x) _ -> evalPanic "recip" [show a ++ "is not a Field"] {-# SPECIALIZE fieldDivideV :: Concrete -> Prim Concrete #-} fieldDivideV :: Backend sym => sym -> Prim sym fieldDivideV sym = PTyPoly \a -> PFun \x -> PFun \y -> PPrim case a of TVRational -> do x' <- fromVRational <$> x y' <- fromVRational <$> y VRational <$> rationalDivide sym x' y' TVFloat _e _p -> do xv <- fromVFloat <$> x yv <- fromVFloat <$> y r <- fpRndMode sym VFloat <$> fpDiv sym r xv yv TVIntMod m -> do x' <- fromVInteger <$> x y' <- fromVInteger <$> y yinv <- znRecip sym m y' VInteger <$> znMult sym m x' yinv _ -> evalPanic "recip" [show a ++ "is not a Field"] -------------------------------------------------------------- -- Round {-# SPECIALIZE roundOp :: Concrete -> String -> (SRational Concrete -> SEval Concrete (SInteger Concrete)) -> (SFloat Concrete -> SEval Concrete (SInteger Concrete)) -> Unary Concrete #-} roundOp :: Backend sym => sym -> String -> (SRational sym -> SEval sym (SInteger sym)) -> (SFloat sym -> SEval sym (SInteger sym)) -> Unary sym roundOp _sym nm qop opfp ty v = case ty of TVRational -> VInteger <$> (qop (fromVRational v)) TVFloat _ _ -> VInteger <$> opfp (fromVFloat v) _ -> evalPanic nm [show ty ++ " is not a Field"] {-# INLINE floorV #-} floorV :: Backend sym => sym -> Unary sym floorV sym = roundOp sym "floor" opq opfp where opq = rationalFloor sym opfp = \x -> fpRndRTN sym >>= \r -> fpToInteger sym "floor" r x {-# INLINE ceilingV #-} ceilingV :: Backend sym => sym -> Unary sym ceilingV sym = roundOp sym "ceiling" opq opfp where opq = rationalCeiling sym opfp = \x -> fpRndRTP sym >>= \r -> fpToInteger sym "ceiling" r x {-# INLINE truncV #-} truncV :: Backend sym => sym -> Unary sym truncV sym = roundOp sym "trunc" opq opfp where opq = rationalTrunc sym opfp = \x -> fpRndRTZ sym >>= \r -> fpToInteger sym "trunc" r x {-# INLINE roundAwayV #-} roundAwayV :: Backend sym => sym -> Unary sym roundAwayV sym = roundOp sym "roundAway" opq opfp where opq = rationalRoundAway sym opfp = \x -> fpRndRNA sym >>= \r -> fpToInteger sym "roundAway" r x {-# INLINE roundToEvenV #-} roundToEvenV :: Backend sym => sym -> Unary sym roundToEvenV sym = roundOp sym "roundToEven" opq opfp where opq = rationalRoundToEven sym opfp = \x -> fpRndRNE sym >>= \r -> fpToInteger sym "roundToEven" r x -------------------------------------------------------------- -- Logic {-# INLINE andV #-} andV :: Backend sym => sym -> Binary sym andV sym = logicBinary sym (bitAnd sym) (wordAnd sym) {-# INLINE orV #-} orV :: Backend sym => sym -> Binary sym orV sym = logicBinary sym (bitOr sym) (wordOr sym) {-# INLINE xorV #-} xorV :: Backend sym => sym -> Binary sym xorV sym = logicBinary sym (bitXor sym) (wordXor sym) {-# INLINE complementV #-} complementV :: Backend sym => sym -> Unary sym complementV sym = logicUnary sym (bitComplement sym) (wordComplement sym) -- Bitvector signed div and modulus {-# INLINE lg2V #-} lg2V :: Backend sym => sym -> Prim sym lg2V sym = PFinPoly \w -> PWordFun \x -> PPrim (VWord w . wordVal <$> wordLg2 sym x) {-# SPECIALIZE sdivV :: Concrete -> Prim Concrete #-} sdivV :: Backend sym => sym -> Prim sym sdivV sym = PFinPoly \w -> PWordFun \x -> PWordFun \y -> PPrim (VWord w . wordVal <$> wordSignedDiv sym x y) {-# SPECIALIZE smodV :: Concrete -> Prim Concrete #-} smodV :: Backend sym => sym -> Prim sym smodV sym = PFinPoly \w -> PWordFun \x -> PWordFun \y -> PPrim (VWord w . wordVal <$> wordSignedMod sym x y) {-# SPECIALIZE toSignedIntegerV :: Concrete -> Prim Concrete #-} toSignedIntegerV :: Backend sym => sym -> Prim sym toSignedIntegerV sym = PFinPoly \_w -> PWordFun \x -> PPrim (VInteger <$> wordToSignedInt sym x) -- Cmp ------------------------------------------------------------------------- {-# SPECIALIZE cmpValue :: Concrete -> (SBit Concrete -> SBit Concrete -> SEval Concrete a -> SEval Concrete a) -> (SWord Concrete -> SWord Concrete -> SEval Concrete a -> SEval Concrete a) -> (SInteger Concrete -> SInteger Concrete -> SEval Concrete a -> SEval Concrete a) -> (Integer -> SInteger Concrete -> SInteger Concrete -> SEval Concrete a -> SEval Concrete a) -> (SRational Concrete -> SRational Concrete -> SEval Concrete a -> SEval Concrete a) -> (SFloat Concrete -> SFloat Concrete -> SEval Concrete a -> SEval Concrete a) -> (TValue -> GenValue Concrete -> GenValue Concrete -> SEval Concrete a -> SEval Concrete a) #-} cmpValue :: Backend sym => sym -> (SBit sym -> SBit sym -> SEval sym a -> SEval sym a) -> (SWord sym -> SWord sym -> SEval sym a -> SEval sym a) -> (SInteger sym -> SInteger sym -> SEval sym a -> SEval sym a) -> (Integer -> SInteger sym -> SInteger sym -> SEval sym a -> SEval sym a) -> (SRational sym -> SRational sym -> SEval sym a -> SEval sym a) -> (SFloat sym -> SFloat sym -> SEval sym a -> SEval sym a) -> (TValue -> GenValue sym -> GenValue sym -> SEval sym a -> SEval sym a) cmpValue sym fb fw fi fz fq ff = cmp where cmp ty v1 v2 k = case ty of TVBit -> fb (fromVBit v1) (fromVBit v2) k TVInteger -> fi (fromVInteger v1) (fromVInteger v2) k TVFloat _ _ -> ff (fromVFloat v1) (fromVFloat v2) k TVIntMod n -> fz n (fromVInteger v1) (fromVInteger v2) k TVRational -> fq (fromVRational v1) (fromVRational v2) k TVArray{} -> panic "Cryptol.Prims.Value.cmpValue" [ "Arrays are not comparable" ] TVSeq n t | isTBit t -> do w1 <- fromVWord sym "cmpValue" v1 w2 <- fromVWord sym "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 -> cmpValues (recordElements fields) (recordElements (fromVRecord v1)) (recordElements (fromVRecord v2)) k TVAbstract {} -> evalPanic "cmpValue" [ "Abstract type not in `Cmp`" ] TVNewtype {} -> evalPanic "cmpValue" [ "Newtype 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 {-# INLINE bitLessThan #-} bitLessThan :: Backend sym => sym -> SBit sym -> SBit sym -> SEval sym (SBit sym) bitLessThan sym x y = do xnot <- bitComplement sym x bitAnd sym xnot y {-# INLINE bitGreaterThan #-} bitGreaterThan :: Backend sym => sym -> SBit sym -> SBit sym -> SEval sym (SBit sym) bitGreaterThan sym x y = bitLessThan sym y x {-# INLINE valEq #-} valEq :: Backend sym => sym -> TValue -> GenValue sym -> GenValue sym -> SEval sym (SBit sym) valEq sym ty v1 v2 = cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure $ bitLit sym True) where fb x y k = eqCombine sym (bitEq sym x y) k fw x y k = eqCombine sym (wordEq sym x y) k fi x y k = eqCombine sym (intEq sym x y) k fz m x y k = eqCombine sym (znEq sym m x y) k fq x y k = eqCombine sym (rationalEq sym x y) k ff x y k = eqCombine sym (fpEq sym x y) k {-# INLINE valLt #-} valLt :: Backend sym => sym -> TValue -> GenValue sym -> GenValue sym -> SBit sym -> SEval sym (SBit sym) valLt sym ty v1 v2 final = cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure final) where fb x y k = lexCombine sym (bitLessThan sym x y) (bitEq sym x y) k fw x y k = lexCombine sym (wordLessThan sym x y) (wordEq sym x y) k fi x y k = lexCombine sym (intLessThan sym x y) (intEq sym x y) k fz _ _ _ _ = panic "valLt" ["Z_n is not in `Cmp`"] fq x y k = lexCombine sym (rationalLessThan sym x y) (rationalEq sym x y) k ff x y k = lexCombine sym (fpLessThan sym x y) (fpEq sym x y) k {-# INLINE valGt #-} valGt :: Backend sym => sym -> TValue -> GenValue sym -> GenValue sym -> SBit sym -> SEval sym (SBit sym) valGt sym ty v1 v2 final = cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure final) where fb x y k = lexCombine sym (bitGreaterThan sym x y) (bitEq sym x y) k fw x y k = lexCombine sym (wordGreaterThan sym x y) (wordEq sym x y) k fi x y k = lexCombine sym (intGreaterThan sym x y) (intEq sym x y) k fz _ _ _ _ = panic "valGt" ["Z_n is not in `Cmp`"] fq x y k = lexCombine sym (rationalGreaterThan sym x y) (rationalEq sym x y) k ff x y k = lexCombine sym (fpGreaterThan sym x y) (fpEq sym x y) k {-# INLINE eqCombine #-} eqCombine :: Backend sym => sym -> SEval sym (SBit sym) -> SEval sym (SBit sym) -> SEval sym (SBit sym) eqCombine sym eq k = join (bitAnd sym <$> eq <*> k) {-# INLINE lexCombine #-} lexCombine :: Backend sym => sym -> SEval sym (SBit sym) -> SEval sym (SBit sym) -> SEval sym (SBit sym) -> SEval sym (SBit sym) lexCombine sym cmp eq k = do c <- cmp e <- eq bitOr sym c =<< bitAnd sym e =<< k {-# INLINE eqV #-} eqV :: Backend sym => sym -> Binary sym eqV sym ty v1 v2 = VBit <$> valEq sym ty v1 v2 {-# INLINE distinctV #-} distinctV :: Backend sym => sym -> Binary sym distinctV sym ty v1 v2 = VBit <$> (bitComplement sym =<< valEq sym ty v1 v2) {-# INLINE lessThanV #-} lessThanV :: Backend sym => sym -> Binary sym lessThanV sym ty v1 v2 = VBit <$> valLt sym ty v1 v2 (bitLit sym False) {-# INLINE lessThanEqV #-} lessThanEqV :: Backend sym => sym -> Binary sym lessThanEqV sym ty v1 v2 = VBit <$> valLt sym ty v1 v2 (bitLit sym True) {-# INLINE greaterThanV #-} greaterThanV :: Backend sym => sym -> Binary sym greaterThanV sym ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym False) {-# INLINE greaterThanEqV #-} greaterThanEqV :: Backend sym => sym -> Binary sym greaterThanEqV sym ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym True) {-# INLINE signedLessThanV #-} signedLessThanV :: Backend sym => sym -> Binary sym signedLessThanV sym ty v1 v2 = VBit <$> cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure $ bitLit sym False) where fb _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on bit type"] fw x y k = lexCombine sym (wordSignedLessThan sym x y) (wordEq sym x y) k fi _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on Integer type"] fz m _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on Z_" ++ show m ++ " type"] fq _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on Rational type"] ff _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on Float"] {-# SPECIALIZE zeroV :: Concrete -> TValue -> SEval Concrete (GenValue Concrete) #-} zeroV :: forall sym. Backend sym => sym -> TValue -> SEval sym (GenValue sym) zeroV sym ty = case ty of -- bits TVBit -> pure (VBit (bitLit sym False)) -- integers TVInteger -> VInteger <$> integerLit sym 0 -- integers mod n TVIntMod _ -> VInteger <$> integerLit sym 0 TVRational -> VRational <$> (intToRational sym =<< integerLit sym 0) TVArray{} -> evalPanic "zeroV" ["Array not in class Zero"] -- floating point TVFloat e p -> VFloat <$> fpLit sym e p 0 -- sequences TVSeq w ety | isTBit ety -> word sym w 0 | otherwise -> do z <- sDelay sym (zeroV sym ety) pure $ VSeq w (indexSeqMap \_i -> z) TVStream ety -> do z <- sDelay sym (zeroV sym ety) pure $ VStream (indexSeqMap \_i -> z) -- functions TVFun _ bty -> do z <- sDelay sym (zeroV sym bty) lam sym (const z) -- tuples TVTuple tys -> do xs <- mapM (sDelay sym . zeroV sym) tys pure $ VTuple xs -- records TVRec fields -> do xs <- traverse (sDelay sym . zeroV sym) fields pure $ VRecord xs TVAbstract {} -> evalPanic "zeroV" [ "Abstract type not in `Zero`" ] TVNewtype {} -> evalPanic "zeroV" [ "Newtype not in `Zero`" ] {-# SPECIALIZE joinSeq :: Concrete -> Nat' -> Integer -> TValue -> SEval Concrete (SeqMap Concrete (GenValue Concrete)) -> SEval Concrete (GenValue Concrete) #-} joinSeq :: Backend sym => sym -> Nat' -> Integer -> TValue -> SEval sym (SeqMap sym (GenValue sym)) -> SEval sym (GenValue sym) -- Special case for 0 length inner sequences. joinSeq sym _parts 0 a _val = zeroV sym (TVSeq 0 a) -- finite sequence of words joinSeq sym (Nat parts) each TVBit val = do w <- delayWordValue sym (parts*each) (joinWords sym parts each . fmap (fromWordVal "joinV") =<< val) pure (VWord (parts*each) w) -- infinite sequence of words joinSeq sym Inf each TVBit val = return $ VStream $ indexSeqMap $ \i -> do let (q,r) = divMod i each xs <- val ys <- fromWordVal "join seq" <$> lookupSeqMap xs q VBit <$> indexWordValue sym ys r -- finite or infinite sequence of non-words joinSeq _sym parts each _a val = return $ vSeq $ indexSeqMap $ \i -> do let (q,r) = divMod i each xs <- val 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 {-# INLINE joinV #-} -- | Join a sequence of sequences into a single sequence. joinV :: Backend sym => sym -> Nat' -> Integer -> TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) joinV sym parts each a val = do xs <- sDelay sym (fromSeq "joinV" =<< val) joinSeq sym parts each a xs {-# INLINE takeV #-} takeV :: Backend sym => sym -> Nat' -> Nat' -> TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) takeV sym front back a val = case front of Inf -> val Nat front' -> case back of Nat back' | isTBit a -> do w <- delayWordValue sym front' (takeWordVal sym front' back' =<< (fromWordVal "takeV" <$> val)) pure (VWord front' w) Inf | isTBit a -> do w <- delayWordValue sym front' (bitmapWordVal sym front' . fmap fromVBit =<< (fromSeq "takeV" =<< val)) pure (VWord front' w) _ -> do xs <- delaySeqMap sym (fromSeq "takeV" =<< val) pure (VSeq front' xs) {-# INLINE dropV #-} dropV :: Backend sym => sym -> Integer -> Nat' -> TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) dropV sym front back a val = case back of Nat back' | isTBit a -> do w <- delayWordValue sym back' (dropWordVal sym front back' =<< (fromWordVal "dropV" <$> val)) pure (VWord back' w) _ -> do xs <- delaySeqMap sym (dropSeqMap front <$> (fromSeq "dropV" =<< val)) mkSeq sym back a xs {-# INLINE splitV #-} -- | Split implementation. splitV :: Backend sym => sym -> Nat' -> Integer -> TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) splitV sym parts each a val = case (parts, each) of (Nat p, e) | isTBit a -> do val' <- sDelay sym (fromWordVal "splitV" <$> val) return $ VSeq p $ indexSeqMap $ \i -> VWord e <$> (extractWordVal sym e ((p-i-1)*e) =<< val') (Inf, e) | isTBit a -> do val' <- sDelay sym (fromSeq "splitV" =<< val) return $ VStream $ indexSeqMap $ \i -> VWord e <$> bitmapWordVal sym e (indexSeqMap $ \j -> let idx = i*e + toInteger j in idx `seq` do xs <- val' fromVBit <$> lookupSeqMap xs idx) (Nat p, e) -> do val' <- sDelay sym (fromSeq "splitV" =<< val) return $ VSeq p $ indexSeqMap $ \i -> return $ VSeq e $ indexSeqMap $ \j -> do xs <- val' lookupSeqMap xs (e * i + j) (Inf , e) -> do val' <- sDelay sym (fromSeq "splitV" =<< val) return $ VStream $ indexSeqMap $ \i -> return $ VSeq e $ indexSeqMap $ \j -> do xs <- val' lookupSeqMap xs (e * i + j) {-# INLINE reverseV #-} reverseV :: forall sym. Backend sym => sym -> Integer -> TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) reverseV sym n TVBit val = do w <- delayWordValue sym n (reverseWordVal sym . fromWordVal "reverseV" =<< val) pure (VWord n w) reverseV sym n _a val = do xs <- delaySeqMap sym (reverseSeqMap n <$> (fromSeq "reverseV" =<< val)) pure (VSeq n xs) {-# INLINE transposeV #-} transposeV :: Backend sym => sym -> Nat' -> Nat' -> TValue -> GenValue sym -> SEval sym (GenValue sym) transposeV sym a b c xs | isTBit c, Nat na <- a = -- Fin a => [a][b]Bit -> [b][a]Bit return $ bseq $ indexSeqMap $ \bi -> VWord na <$> bitmapWordVal sym na (indexSeqMap $ \ai -> do xs' <- fromSeq "transposeV" xs ys <- lookupSeqMap xs' ai case ys of VStream ys' -> fromVBit <$> lookupSeqMap ys' bi VWord _ wv -> indexWordValue sym wv bi _ -> 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 xs' <- fromSeq "transposeV" xs ys <- lookupSeqMap xs' ai case ys of VStream ys' -> lookupSeqMap ys' bi VWord _ wv -> VBit <$> indexWordValue sym wv bi _ -> evalPanic "transpose" ["expected sequence of bits"] | otherwise = -- [a][b]c -> [b][a]c return $ bseq $ indexSeqMap $ \bi -> return $ aseq $ indexSeqMap $ \ai -> do xs' <- fromSeq "transposeV 1" xs ys <- fromSeq "transposeV 2" =<< lookupSeqMap xs' ai z <- lookupSeqMap ys bi return z where bseq = case b of Nat nb -> VSeq nb Inf -> VStream aseq = case a of Nat na -> VSeq na Inf -> VStream {-# INLINE ccatV #-} ccatV :: Backend sym => sym -> Integer -> Nat' -> TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) -- Finite bitvectors ccatV sym front (Nat back) TVBit l r = do ml <- isReady sym l mr <- isReady sym r case (ml, mr) of (Just l', Just r') -> VWord (front+back) <$> joinWordVal sym (fromWordVal "ccatV left" l') (fromWordVal "ccatV right" r') _ -> VWord (front+back) <$> delayWordValue sym (front+back) (do l' <- fromWordVal "ccatV left" <$> l r' <- fromWordVal "ccatV right" <$> r joinWordVal sym l' r') -- Infinite bitstream ccatV sym front Inf TVBit l r = do l'' <- sDelay sym (asBitsMap sym . fromWordVal "ccatV left" <$> l) r'' <- sDelay sym (fromSeq "ccatV right" =<< r) pure $ VStream $ indexSeqMap $ \i -> if i < front then do ls <- l'' VBit <$> lookupSeqMap ls i else do rs <- r'' lookupSeqMap rs (i-front) -- streams/sequences of nonbits ccatV sym front back elty l r = do l'' <- sDelay sym (fromSeq "ccatV left" =<< l) r'' <- sDelay sym (fromSeq "ccatV right" =<< r) mkSeq sym (evalTF TCAdd [Nat front,back]) elty $ indexSeqMap $ \i -> if i < front then do ls <- l'' lookupSeqMap ls i else do rs <- r'' lookupSeqMap rs (i-front) {-# SPECIALIZE logicBinary :: Concrete -> (SBit Concrete -> SBit Concrete -> SEval Concrete (SBit Concrete)) -> (SWord Concrete -> SWord Concrete -> SEval Concrete (SWord Concrete)) -> Binary Concrete #-} -- | Merge two values given a binop. This is used for and, or and xor. logicBinary :: forall sym. Backend sym => sym -> (SBit sym -> SBit sym -> SEval sym (SBit sym)) -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) -> Binary sym logicBinary sym opb opw = loop where loop' :: TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) loop' ty l r = join (loop ty <$> l <*> r) loop :: TValue -> GenValue sym -> GenValue sym -> SEval sym (GenValue sym) loop ty l r = case ty of TVBit -> VBit <$> (opb (fromVBit l) (fromVBit r)) TVInteger -> evalPanic "logicBinary" ["Integer not in class Logic"] TVIntMod _ -> evalPanic "logicBinary" ["Z not in class Logic"] TVRational -> evalPanic "logicBinary" ["Rational not in class Logic"] TVArray{} -> evalPanic "logicBinary" ["Array not in class Logic"] TVFloat {} -> evalPanic "logicBinary" ["Float not in class Logic"] TVSeq w aty -- words | isTBit aty -> VWord w <$> delayWordValue sym w (wordValLogicOp sym opb opw (fromWordVal "logicBinary l" l) (fromWordVal "logicBinary r" r)) -- finite sequences | otherwise -> VSeq w <$> (join (zipSeqMap sym (loop aty) (Nat w) <$> (fromSeq "logicBinary left" l) <*> (fromSeq "logicBinary right" r))) TVStream aty -> VStream <$> (join (zipSeqMap sym (loop aty) Inf <$> (fromSeq "logicBinary left" l) <*> (fromSeq "logicBinary right" r))) TVTuple etys -> do ls <- mapM (sDelay sym) (fromVTuple l) rs <- mapM (sDelay sym) (fromVTuple r) return $ VTuple $ zipWith3 loop' etys ls rs TVFun _ bty -> lam sym $ \ a -> loop' bty (fromVFun sym l a) (fromVFun sym r a) TVRec fields -> VRecord <$> traverseRecordMap (\f fty -> sDelay sym (loop' fty (lookupRecord f l) (lookupRecord f r))) fields TVAbstract {} -> evalPanic "logicBinary" [ "Abstract type not in `Logic`" ] TVNewtype {} -> evalPanic "logicBinary" [ "Newtype not in `Logic`" ] {-# SPECIALIZE logicUnary :: Concrete -> (SBit Concrete -> SEval Concrete (SBit Concrete)) -> (SWord Concrete -> SEval Concrete (SWord Concrete)) -> Unary Concrete #-} logicUnary :: forall sym. Backend sym => sym -> (SBit sym -> SEval sym (SBit sym)) -> (SWord sym -> SEval sym (SWord sym)) -> Unary sym logicUnary sym opb opw = loop where loop' :: TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) loop' ty val = loop ty =<< val loop :: TValue -> GenValue sym -> SEval sym (GenValue sym) loop ty val = case ty of TVBit -> VBit <$> (opb (fromVBit val)) TVInteger -> evalPanic "logicUnary" ["Integer not in class Logic"] TVIntMod _ -> evalPanic "logicUnary" ["Z not in class Logic"] TVFloat {} -> evalPanic "logicUnary" ["Float not in class Logic"] TVRational -> evalPanic "logicBinary" ["Rational not in class Logic"] TVArray{} -> evalPanic "logicUnary" ["Array not in class Logic"] TVSeq w ety -- words | isTBit ety -> VWord w <$> delayWordValue sym w (wordValUnaryOp sym opb opw (fromWordVal "logicUnary" val)) -- finite sequences | otherwise -> VSeq w <$> (mapSeqMap sym (loop ety) (Nat w) =<< fromSeq "logicUnary" val) -- streams TVStream ety -> VStream <$> (mapSeqMap sym (loop ety) Inf =<< fromSeq "logicUnary" val) TVTuple etys -> do as <- mapM (sDelay sym) (fromVTuple val) return $ VTuple (zipWith loop' etys as) TVFun _ bty -> lam sym $ \ a -> loop' bty (fromVFun sym val a) TVRec fields -> VRecord <$> traverseRecordMap (\f fty -> sDelay sym (loop' fty (lookupRecord f val))) fields TVAbstract {} -> evalPanic "logicUnary" [ "Abstract type not in `Logic`" ] TVNewtype {} -> evalPanic "logicUnary" [ "Newtype not in `Logic`" ] {-# INLINE assertIndexInBounds #-} assertIndexInBounds :: Backend sym => sym -> Nat' {- ^ Sequence size bounds -} -> Either (SInteger sym) (WordValue sym) {- ^ Index value -} -> SEval sym () -- All nonnegative integers are in bounds for an infinite sequence assertIndexInBounds sym Inf (Left idx) = do ppos <- bitComplement sym =<< intLessThan sym idx =<< integerLit sym 0 assertSideCondition sym ppos (InvalidIndex (integerAsLit sym idx)) -- If the index is an integer, test that it -- is nonnegative and less than the concrete value of n. assertIndexInBounds sym (Nat n) (Left idx) = do n' <- integerLit sym n ppos <- bitComplement sym =<< intLessThan sym idx =<< integerLit sym 0 pn <- intLessThan sym idx n' p <- bitAnd sym ppos pn assertSideCondition sym p (InvalidIndex (integerAsLit sym idx)) -- Bitvectors can't index out of bounds for an infinite sequence assertIndexInBounds _sym Inf (Right _) = return () -- Can't index out of bounds for a sequence that is -- longer than the expressible index values assertIndexInBounds sym (Nat n) (Right idx) = assertWordValueInBounds sym n idx -- | Indexing operations. {-# INLINE indexPrim #-} indexPrim :: Backend sym => sym -> IndexDirection -> (Nat' -> TValue -> SeqMap sym (GenValue sym) -> TValue -> SInteger sym -> SEval sym (GenValue sym)) -> (Nat' -> TValue -> SeqMap sym (GenValue sym) -> TValue -> Integer -> [IndexSegment sym] -> SEval sym (GenValue sym)) -> Prim sym indexPrim sym dir int_op word_op = PNumPoly \len -> PTyPoly \eltTy -> PTyPoly \ix -> PFun \xs -> PFun \idx -> PPrim do vs <- xs >>= \case VWord _ w -> return $ indexSeqMap (\i -> VBit <$> indexWordValue sym w i) VSeq _ vs -> return vs VStream vs -> return vs _ -> evalPanic "Expected sequence value" ["indexPrim"] let vs' = case (len, dir) of (_ , IndexForward) -> vs (Nat n, IndexBackward) -> reverseSeqMap n vs (Inf , IndexBackward) -> evalPanic "Expected finite sequence" ["!"] idx' <- asIndex sym "index" ix <$> idx assertIndexInBounds sym len idx' case idx' of Left i -> int_op len eltTy vs' ix i Right w -> word_op len eltTy vs' ix (wordValueSize sym w) =<< enumerateIndexSegments sym w {-# INLINE updatePrim #-} updatePrim :: Backend sym => sym -> (Nat' -> TValue -> WordValue sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (WordValue sym)) -> (Nat' -> TValue -> SeqMap sym (GenValue sym) -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (SeqMap sym (GenValue sym))) -> Prim sym updatePrim sym updateWord updateSeq = PNumPoly \len -> PTyPoly \eltTy -> PTyPoly \ix -> PFun \xs -> PFun \idx -> PFun \val -> PPrim do idx' <- asIndex sym "update" ix <$> idx assertIndexInBounds sym len idx' case (len, eltTy) of (Nat n, TVBit) -> VWord n <$> delayWordValue sym n (do w <- fromWordVal "updatePrim" <$> xs; updateWord len eltTy w idx' val) (Nat n, _ ) -> VSeq n <$> delaySeqMap sym (do vs <- fromSeq "updatePrim" =<< xs; updateSeq len eltTy vs idx' val) (Inf , _ ) -> VStream <$> delaySeqMap sym (do vs <- fromSeq "updatePrim" =<< xs; updateSeq len eltTy vs idx' val) {-# INLINE fromToV #-} -- @[ 0 .. 10 ]@ fromToV :: Backend sym => sym -> Prim sym fromToV sym = PNumPoly \first -> PNumPoly \lst -> PTyPoly \ty -> PPrim let !f = mkLit sym ty in case (first, lst) of (Nat first', Nat lst') -> let len = 1 + (lst' - first') in mkSeq sym (Nat len) ty $ indexSeqMap $ \i -> f (first' + i) _ -> evalPanic "fromToV" ["invalid arguments"] {-# INLINE fromThenToV #-} -- @[ 0, 1 .. 10 ]@ fromThenToV :: Backend sym => sym -> Prim sym fromThenToV sym = PNumPoly \first -> PNumPoly \next -> PNumPoly \lst -> PTyPoly \ty -> PNumPoly \len -> PPrim let !f = mkLit sym ty in case (first, next, lst, len) of (Nat first', Nat next', Nat _lst', Nat len') -> let diff = next' - first' in mkSeq sym (Nat len') ty $ indexSeqMap $ \i -> f (first' + i*diff) _ -> evalPanic "fromThenToV" ["invalid arguments"] {-# INLINE fromToLessThanV #-} -- @[ 0 .. <10 ]@ fromToLessThanV :: Backend sym => sym -> Prim sym fromToLessThanV sym = PFinPoly \first -> PNumPoly \bound -> PTyPoly \ty -> PPrim let !f = mkLit sym ty ss = indexSeqMap $ \i -> f (first + i) in case bound of Inf -> return $ VStream ss Nat bound' -> mkSeq sym (Nat (bound' - first)) ty ss {-# INLINE fromToByV #-} -- @[ 0 .. 10 by 2 ]@ fromToByV :: Backend sym => sym -> Prim sym fromToByV sym = PFinPoly \first -> PFinPoly \lst -> PFinPoly \stride -> PTyPoly \ty -> PPrim let !f = mkLit sym ty ss = indexSeqMap $ \i -> f (first + i*stride) in mkSeq sym (Nat (1 + ((lst - first) `div` stride))) ty ss {-# INLINE fromToByLessThanV #-} -- @[ 0 .. <10 by 2 ]@ fromToByLessThanV :: Backend sym => sym -> Prim sym fromToByLessThanV sym = PFinPoly \first -> PNumPoly \bound -> PFinPoly \stride -> PTyPoly \ty -> PPrim let !f = mkLit sym ty ss = indexSeqMap $ \i -> f (first + i*stride) in case bound of Inf -> return $ VStream ss Nat bound' -> mkSeq sym (Nat ((bound' - first + stride - 1) `div` stride)) ty ss {-# INLINE fromToDownByV #-} -- @[ 10 .. 0 down by 2 ]@ fromToDownByV :: Backend sym => sym -> Prim sym fromToDownByV sym = PFinPoly \first -> PFinPoly \lst -> PFinPoly \stride -> PTyPoly \ty -> PPrim let !f = mkLit sym ty ss = indexSeqMap $ \i -> f (first - i*stride) in mkSeq sym (Nat (1 + ((first - lst) `div` stride))) ty ss {-# INLINE fromToDownByGreaterThanV #-} -- @[ 10 .. >0 down by 2 ]@ fromToDownByGreaterThanV :: Backend sym => sym -> Prim sym fromToDownByGreaterThanV sym = PFinPoly \first -> PFinPoly \bound -> PFinPoly \stride -> PTyPoly \ty -> PPrim let !f = mkLit sym ty ss = indexSeqMap $ \i -> f (first - i*stride) in mkSeq sym (Nat ((first - bound + stride - 1) `div` stride)) ty ss {-# INLINE infFromV #-} infFromV :: Backend sym => sym -> Prim sym infFromV sym = PTyPoly \ty -> PFun \x -> PPrim do mx <- sDelay sym x return $ VStream $ indexSeqMap $ \i -> do x' <- mx i' <- integerLit sym i addV sym ty x' =<< intV sym i' ty {-# INLINE infFromThenV #-} infFromThenV :: Backend sym => sym -> Prim sym infFromThenV sym = PTyPoly \ty -> PFun \first -> PFun \next -> PPrim do mxd <- sDelay sym (do x <- first y <- next d <- subV sym ty y x pure (x,d)) return $ VStream $ indexSeqMap $ \i -> do (x,d) <- mxd i' <- integerLit sym i addV sym ty x =<< mulV sym ty d =<< intV sym i' ty -- Shifting --------------------------------------------------- {-# INLINE shiftLeftReindex #-} shiftLeftReindex :: Nat' -> Integer -> Integer -> Maybe Integer shiftLeftReindex sz i shft = case sz of Nat n | i+shft >= n -> Nothing _ -> Just (i+shft) {-# INLINE shiftRightReindex #-} shiftRightReindex :: Nat' -> Integer -> Integer -> Maybe Integer shiftRightReindex _sz i shft = if i-shft < 0 then Nothing else Just (i-shft) {-# INLINE rotateLeftReindex #-} rotateLeftReindex :: Nat' -> Integer -> Integer -> Maybe Integer rotateLeftReindex sz i shft = case sz of Inf -> evalPanic "cannot rotate infinite sequence" [] Nat n -> Just ((i+shft) `mod` n) {-# INLINE rotateRightReindex #-} rotateRightReindex :: Nat' -> Integer -> Integer -> Maybe Integer rotateRightReindex sz i shft = case sz of Inf -> evalPanic "cannot rotate infinite sequence" [] Nat n -> Just ((i+n-shft) `mod` n) {-# INLINE logicShift #-} -- | Generic implementation of shifting. -- Uses the provided word-level operation to perform the shift, when -- possible. Otherwise falls back on a barrel shifter that uses -- the provided reindexing operation to implement the concrete -- shifting operations. The reindex operation is given the size -- of the sequence, the requested index value for the new output sequence, -- and the amount to shift. The return value is an index into the original -- sequence if in bounds, and Nothing otherwise. logicShift :: Backend sym => sym -> String -> (sym -> Nat' -> TValue -> SInteger sym -> SEval sym (SInteger sym)) {- ^ operation for range reduction on integers -} -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) {- ^ word shift operation for positive indices -} -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) {- ^ word shift operation for negative indices -} -> (Nat' -> Integer -> Integer -> Maybe Integer) {- ^ reindexing operation for positive indices (sequence size, starting index, shift amount -} -> (Nat' -> Integer -> Integer -> Maybe Integer) {- ^ reindexing operation for negative indices (sequence size, starting index, shift amount -} -> Prim sym logicShift sym nm shrinkRange wopPos wopNeg reindexPos reindexNeg = PNumPoly \m -> PTyPoly \ix -> PTyPoly \a -> PFun \xs -> PFun \y -> PPrim do xs' <- xs y' <- asIndex sym "shift" ix <$> y case y' of Left int_idx -> do pneg <- intLessThan sym int_idx =<< integerLit sym 0 iteValue sym pneg (intShifter sym nm wopNeg reindexNeg m a xs' =<< shrinkRange sym m ix =<< intNegate sym int_idx) (intShifter sym nm wopPos reindexPos m a xs' =<< shrinkRange sym m ix int_idx) Right idx -> wordShifter sym nm wopPos reindexPos m a xs' idx {-# INLINE intShifter #-} intShifter :: Backend sym => sym -> String -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) -> (Nat' -> Integer -> Integer -> Maybe Integer) -> Nat' -> TValue -> GenValue sym -> SInteger sym -> SEval sym (GenValue sym) intShifter sym nm wop reindex m a xs idx = case xs of VWord w x -> VWord w <$> shiftWordByInteger sym wop (reindex m) x idx VSeq w vs -> VSeq w <$> shiftSeqByInteger sym (mergeValue sym) (reindex m) (zeroV sym a) m vs idx VStream vs -> VStream <$> shiftSeqByInteger sym (mergeValue sym) (reindex m) (zeroV sym a) m vs idx _ -> evalPanic "expected sequence value in shift operation" [nm] {-# INLINE wordShifter #-} wordShifter :: Backend sym => sym -> String -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) -> (Nat' -> Integer -> Integer -> Maybe Integer) -> Nat' -> TValue -> GenValue sym -> WordValue sym -> SEval sym (GenValue sym) wordShifter sym nm wop reindex m a xs idx = case xs of VWord w x -> VWord w <$> shiftWordByWord sym wop (reindex m) x idx VSeq w vs -> VSeq w <$> shiftSeqByWord sym (mergeValue sym) (reindex m) (zeroV sym a) (Nat w) vs idx VStream vs -> VStream <$> shiftSeqByWord sym (mergeValue sym) (reindex m) (zeroV sym a) Inf vs idx _ -> evalPanic "expected sequence value in shift operation" [nm] {-# INLINE shiftShrink #-} shiftShrink :: Backend sym => sym -> Nat' -> TValue -> SInteger sym -> SEval sym (SInteger sym) shiftShrink _sym Inf _ x = return x shiftShrink sym (Nat w) _ x = do w' <- integerLit sym w p <- intLessThan sym w' x iteInteger sym p w' x {-# INLINE rotateShrink #-} rotateShrink :: Backend sym => sym -> Nat' -> TValue -> SInteger sym -> SEval sym (SInteger sym) rotateShrink _sym Inf _ _ = panic "rotateShrink" ["expected finite sequence in rotate"] rotateShrink sym (Nat 0) _ _ = integerLit sym 0 rotateShrink sym (Nat w) _ x = do w' <- integerLit sym w intMod sym x w' {-# INLINE sshrV #-} sshrV :: Backend sym => sym -> Prim sym sshrV sym = PFinPoly \n -> PTyPoly \ix -> PWordFun \x -> PStrict \y -> PPrim $ case asIndex sym ">>$" ix y of Left i -> do pneg <- intLessThan sym i =<< integerLit sym 0 VWord n <$> mergeWord' sym pneg (do i' <- shiftShrink sym (Nat n) ix =<< intNegate sym i amt <- wordFromInt sym n i' wordVal <$> wordShiftLeft sym x amt) (do i' <- shiftShrink sym (Nat n) ix i amt <- wordFromInt sym n i' wordVal <$> wordSignedShiftRight sym x amt) Right wv -> do amt <- asWordVal sym wv VWord n . wordVal <$> wordSignedShiftRight sym x amt -- Miscellaneous --------------------------------------------------------------- {-# SPECIALIZE errorV :: Concrete -> TValue -> String -> SEval Concrete (GenValue Concrete) #-} errorV :: forall sym. Backend sym => sym -> TValue -> String -> SEval sym (GenValue sym) errorV sym _ty msg = do stk <- sGetCallStack sym sWithCallStack sym stk (cryUserError sym msg) {-# INLINE valueToChar #-} -- | Expect a word value. Mask it to an 8-bits ASCII value -- and return the associated character, if it is concrete. -- Otherwise, return a '?' character valueToChar :: Backend sym => sym -> GenValue sym -> SEval sym Char valueToChar sym (VWord 8 wval) = do w <- asWordVal sym wval pure $! fromMaybe '?' (wordAsChar sym w) valueToChar _ _ = evalPanic "valueToChar" ["Not an 8-bit bitvector"] {-# INLINE valueToString #-} valueToString :: Backend sym => sym -> GenValue sym -> SEval sym String valueToString sym (VSeq n vals) = traverse (valueToChar sym =<<) (enumerateSeqMap n vals) valueToString _ _ = evalPanic "valueToString" ["Not a finite sequence"] foldlV :: Backend sym => sym -> Prim sym foldlV sym = PNumPoly \_n -> PTyPoly \_a -> PTyPoly \_b -> PFun \f -> PFun \z -> PStrict \v -> PPrim case v of VSeq n m -> go0 f z (enumerateSeqMap n m) VWord _n wv -> go0 f z . map (pure . VBit) =<< (enumerateWordValue sym wv) _ -> panic "Cryptol.Eval.Generic.foldlV" ["Expected finite sequence"] where go0 _f a [] = a go0 f a bs = do f' <- fromVFun sym <$> f go1 f' a bs go1 _f a [] = a go1 f a (b:bs) = do f' <- fromVFun sym <$> (f a) go1 f (f' b) bs foldl'V :: Backend sym => sym -> Prim sym foldl'V sym = PNumPoly \_n -> PTyPoly \_a -> PTyPoly \_b -> PFun \f -> PFun \z -> PStrict \v -> PPrim case v of VSeq n m -> go0 f z (enumerateSeqMap n m) VWord _n wv -> go0 f z . map (pure . VBit) =<< (enumerateWordValue sym wv) _ -> panic "Cryptol.Eval.Generic.foldlV" ["Expected finite sequence"] where go0 _f a [] = a go0 f a bs = do f' <- fromVFun sym <$> f a' <- sDelay sym a forceValue =<< a' go1 f' a' bs go1 _f a [] = a go1 f a (b:bs) = do f' <- fromVFun sym <$> (f a) a' <- sDelay sym (f' b) forceValue =<< a' go1 f a' bs -- scanl : {n, a, b} (a -> b -> a) -> a -> [n]b -> [1+n]a scanlV :: forall sym. Backend sym => sym -> Prim sym scanlV sym = PNumPoly \n -> PTyPoly \a -> PTyPoly \_b -> PFun \f -> PFun \z -> PStrict \v -> PPrim do sm <- case v of VSeq _ m -> scan n f z m VWord _ wv -> scan n f z (VBit <$> asBitsMap sym wv) VStream m -> scan n f z m _ -> panic "Cryptol.Eval.Generic.scanlV" ["Expected sequence"] mkSeq sym (nAdd (Nat 1) n) a sm where scan :: Nat' -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) -> (SeqMap sym (GenValue sym)) -> SEval sym (SeqMap sym (GenValue sym)) scan n f z m = do (result, fill) <- sDeclareHole sym "scanl" fill $ memoMap sym (nAdd (Nat 1) n) $ indexSeqMap $ \i -> if i == 0 then z else do r <- result f' <- fromVFun sym <$> f f'' <- fromVFun sym <$> f' (lookupSeqMap r (i-1)) f'' (lookupSeqMap m (i-1)) result -- Random Values --------------------------------------------------------------- {-# SPECIALIZE randomV :: Concrete -> TValue -> Integer -> SEval Concrete (GenValue Concrete) #-} -- | 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 :: Backend sym => sym -> TValue -> Integer -> SEval sym (GenValue sym) randomV sym ty seed = case randomValue sym ty of Nothing -> zeroV sym 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) = case take 4 (unpack seed) of [a', b', c', d'] -> (a', b', c', d') _ -> error "randomV: impossible (infinite seed is finite)" in fst $ gen 100 $ seedTFGen (a, b, c, d) -------------------------------------------------------------------------------- -- Experimental parallel primitives parmapV :: Backend sym => sym -> Prim sym parmapV sym = PTyPoly \_a -> PTyPoly \_b -> PFinPoly \_n -> PFun \f -> PFun \xs -> PPrim do f' <- fromVFun sym <$> f xs' <- xs case xs' of VWord n w -> do let m = asBitsMap sym w m' <- sparkParMap sym (\x -> f' (VBit <$> x)) n m VWord n <$> (bitmapWordVal sym n (fromVBit <$> m')) VSeq n m -> VSeq n <$> sparkParMap sym f' n m _ -> panic "parmapV" ["expected sequence!"] sparkParMap :: Backend sym => sym -> (SEval sym a -> SEval sym (GenValue sym)) -> Integer -> SeqMap sym a -> SEval sym (SeqMap sym (GenValue sym)) sparkParMap sym f n m = finiteSeqMap sym <$> mapM (sSpark sym . g) (enumerateSeqMap n m) where g x = do z <- sDelay sym (f x) forceValue =<< z z -------------------------------------------------------------------------------- -- Floating Point Operations -- | A helper for definitng floating point constants. fpConst :: Backend sym => (Integer -> Integer -> SEval sym (SFloat sym)) -> Prim sym fpConst mk = PFinPoly \e -> PNumPoly \ ~(Nat p) -> PPrim (VFloat <$> mk e p) -- | Make a Cryptol value for a binary arithmetic function. fpBinArithV :: Backend sym => sym -> FPArith2 sym -> Prim sym fpBinArithV sym fun = PFinPoly \_e -> PFinPoly \_p -> PWordFun \r -> PFloatFun \x -> PFloatFun \y -> PPrim (VFloat <$> fun sym r x y) -- | Rounding mode used in FP operations that do not specify it explicitly. fpRndMode, fpRndRNE, fpRndRNA, fpRndRTP, fpRndRTN, fpRndRTZ :: Backend sym => sym -> SEval sym (SWord sym) fpRndMode = fpRndRNE fpRndRNE sym = wordLit sym 3 0 {- to nearest, ties to even -} fpRndRNA sym = wordLit sym 3 1 {- to nearest, ties to away from 0 -} fpRndRTP sym = wordLit sym 3 2 {- to +inf -} fpRndRTN sym = wordLit sym 3 3 {- to -inf -} fpRndRTZ sym = wordLit sym 3 4 {- to 0 -} {-# SPECIALIZE genericFloatTable :: Concrete -> Map PrimIdent (Prim Concrete) #-} genericFloatTable :: Backend sym => sym -> Map PrimIdent (Prim sym) genericFloatTable sym = let (~>) = (,) in Map.fromList $ map (\(n, v) -> (floatPrim n, v)) [ "fpNaN" ~> fpConst (fpNaN sym) , "fpPosInf" ~> fpConst (fpPosInf sym) , "fpFromBits" ~> PFinPoly \e -> PFinPoly \p -> PWordFun \w -> PPrim (VFloat <$> fpFromBits sym e p w) , "fpToBits" ~> PFinPoly \e -> PFinPoly \p -> PFloatFun \x -> PPrim (VWord (e+p) . wordVal <$> fpToBits sym x) , "=.=" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PFloatFun \y -> PPrim (VBit <$> fpLogicalEq sym x y) , "fpIsNaN" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PPrim (VBit <$> fpIsNaN sym x) , "fpIsInf" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PPrim (VBit <$> fpIsInf sym x) , "fpIsZero" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PPrim (VBit <$> fpIsZero sym x) , "fpIsNeg" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PPrim (VBit <$> fpIsNeg sym x) , "fpIsNormal" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PPrim (VBit <$> fpIsNorm sym x) , "fpIsSubnormal" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PPrim (VBit <$> fpIsSubnorm sym x) , "fpAdd" ~> fpBinArithV sym fpPlus , "fpSub" ~> fpBinArithV sym fpMinus , "fpMul" ~> fpBinArithV sym fpMult , "fpDiv" ~> fpBinArithV sym fpDiv , "fpFMA" ~> PFinPoly \_ -> PFinPoly \_ -> PWordFun \r -> PFloatFun \x -> PFloatFun \y -> PFloatFun \z -> PPrim (VFloat <$> fpFMA sym r x y z) , "fpAbs" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PPrim (VFloat <$> fpAbs sym x) , "fpSqrt" ~> PFinPoly \_ -> PFinPoly \_ -> PWordFun \r -> PFloatFun \x -> PPrim (VFloat <$> fpSqrt sym r x) , "fpToRational" ~> PFinPoly \_e -> PFinPoly \_p -> PFloatFun \x -> PPrim (VRational <$> fpToRational sym x) , "fpFromRational" ~> PFinPoly \e -> PFinPoly \p -> PWordFun \r -> PFun \x -> PPrim do rat <- fromVRational <$> x VFloat <$> fpFromRational sym e p r rat ] {-# SPECIALIZE genericPrimTable :: Concrete -> IO EvalOpts -> Map PrimIdent (Prim Concrete) #-} genericPrimTable :: Backend sym => sym -> IO EvalOpts -> Map PrimIdent (Prim sym) genericPrimTable sym getEOpts = Map.fromList $ map (\(n, v) -> (prelPrim n, v)) [ -- Literals ("True" , PVal $ VBit (bitLit sym True)) , ("False" , PVal $ VBit (bitLit sym False)) , ("number" , {-# SCC "Prelude::number" #-} ecNumberV sym) , ("ratio" , {-# SCC "Prelude::ratio" #-} ratioV sym) , ("fraction" , ecFractionV sym) -- Zero , ("zero" , {-# SCC "Prelude::zero" #-} PTyPoly \ty -> PPrim (zeroV sym ty)) -- Logic , ("&&" , {-# SCC "Prelude::(&&)" #-} binary (andV sym)) , ("||" , {-# SCC "Prelude::(||)" #-} binary (orV sym)) , ("^" , {-# SCC "Prelude::(^)" #-} binary (xorV sym)) , ("complement" , {-# SCC "Prelude::complement" #-} unary (complementV sym)) -- Ring , ("fromInteger", {-# SCC "Prelude::fromInteger" #-} fromIntegerV sym) , ("+" , {-# SCC "Prelude::(+)" #-} binary (addV sym)) , ("-" , {-# SCC "Prelude::(-)" #-} binary (subV sym)) , ("*" , {-# SCC "Prelude::(*)" #-} binary (mulV sym)) , ("negate" , {-# SCC "Prelude::negate" #-} unary (negateV sym)) -- Integral , ("toInteger" , {-# SCC "Prelude::toInteger" #-} toIntegerV sym) , ("/" , {-# SCC "Prelude::(/)" #-} binary (divV sym)) , ("%" , {-# SCC "Prelude::(%)" #-} binary (modV sym)) , ("^^" , {-# SCC "Prelude::(^^)" #-} expV sym) , ("infFrom" , {-# SCC "Prelude::infFrom" #-} infFromV sym) , ("infFromThen", {-# SCC "Prelude::infFromThen" #-} infFromThenV sym) -- Field , ("recip" , {-# SCC "Prelude::recip" #-} recipV sym) , ("/." , {-# SCC "Prelude::(/.)" #-} fieldDivideV sym) -- Round , ("floor" , {-# SCC "Prelude::floor" #-} unary (floorV sym)) , ("ceiling" , {-# SCC "Prelude::ceiling" #-} unary (ceilingV sym)) , ("trunc" , {-# SCC "Prelude::trunc" #-} unary (truncV sym)) , ("roundAway" , {-# SCC "Prelude::roundAway" #-} unary (roundAwayV sym)) , ("roundToEven", {-# SCC "Prelude::roundToEven" #-} unary (roundToEvenV sym)) -- Bitvector specific operations , ("toSignedInteger" , {-# SCC "Prelude::toSignedInteger" #-} toSignedIntegerV sym) , ("/$" , {-# SCC "Prelude::(/$)" #-} sdivV sym) , ("%$" , {-# SCC "Prelude::(%$)" #-} smodV sym) , ("lg2" , {-# SCC "Prelude::lg2" #-} lg2V sym) -- Cmp , ("<" , {-# SCC "Prelude::(<)" #-} binary (lessThanV sym)) , (">" , {-# SCC "Prelude::(>)" #-} binary (greaterThanV sym)) , ("<=" , {-# SCC "Prelude::(<=)" #-} binary (lessThanEqV sym)) , (">=" , {-# SCC "Prelude::(>=)" #-} binary (greaterThanEqV sym)) , ("==" , {-# SCC "Prelude::(==)" #-} binary (eqV sym)) , ("!=" , {-# SCC "Prelude::(!=)" #-} binary (distinctV sym)) -- SignedCmp , ("<$" , {-# SCC "Prelude::(<$)" #-} binary (signedLessThanV sym)) -- Finite enumerations , ("fromTo" , {-# SCC "Prelude::fromTo" #-} fromToV sym) , ("fromThenTo" , {-# SCC "Prelude::fromThenTo" #-} fromThenToV sym) , ("fromToLessThan" , {-# SCC "Prelude::fromToLessThan" #-} fromToLessThanV sym) , ("fromToBy" , {-# SCC "Prelude::fromToBy" #-} fromToByV sym) , ("fromToByLessThan", {-# SCC "Prelude::fromToByLessThan" #-} fromToByLessThanV sym) , ("fromToDownBy", {-# SCC "Prelude::fromToDownBy" #-} fromToDownByV sym) , ("fromToDownByGreaterThan" , {-# SCC "Prelude::fromToDownByGreaterThan" #-} fromToDownByGreaterThanV sym) -- Sequence manipulations , ("#" , {-# SCC "Prelude::(#)" #-} PFinPoly \front -> PNumPoly \back -> PTyPoly \elty -> PFun \l -> PFun \r -> PPrim $ ccatV sym front back elty l r) , ("join" , {-# SCC "Prelude::join" #-} PNumPoly \parts -> PFinPoly \each -> PTyPoly \a -> PFun \x -> PPrim $ joinV sym parts each a x) , ("split" , {-# SCC "Prelude::split" #-} PNumPoly \parts -> PFinPoly \each -> PTyPoly \a -> PFun \val -> PPrim $ splitV sym parts each a val) , ("take" , {-# SCC "Preldue::take" #-} PNumPoly \front -> PNumPoly \back -> PTyPoly \a -> PFun \xs -> PPrim $ takeV sym front back a xs) , ("drop" , {-# SCC "Preldue::drop" #-} PFinPoly \front -> PNumPoly \back -> PTyPoly \a -> PFun \xs -> PPrim $ dropV sym front back a xs) , ("reverse" , {-# SCC "Prelude::reverse" #-} PFinPoly \a -> PTyPoly \b -> PFun \xs -> PPrim $ reverseV sym a b xs) , ("transpose" , {-# SCC "Prelude::transpose" #-} PNumPoly \a -> PNumPoly \b -> PTyPoly \c -> PFun \xs -> PPrim $ transposeV sym a b c =<< xs) -- Shifts and rotates , ("<<" , {-# SCC "Prelude::(<<)" #-} logicShift sym "<<" shiftShrink (wordShiftLeft sym) (wordShiftRight sym) shiftLeftReindex shiftRightReindex) , (">>" , {-# SCC "Prelude::(>>)" #-} logicShift sym ">>" shiftShrink (wordShiftRight sym) (wordShiftLeft sym) shiftRightReindex shiftLeftReindex) , ("<<<" , {-# SCC "Prelude::(<<<)" #-} logicShift sym "<<<" rotateShrink (wordRotateLeft sym) (wordRotateRight sym) rotateLeftReindex rotateRightReindex) , (">>>" , {-# SCC "Prelude::(>>>)" #-} logicShift sym ">>>" rotateShrink (wordRotateRight sym) (wordRotateLeft sym) rotateRightReindex rotateLeftReindex) , (">>$" , {-# SCC "Prelude::(>>$)" #-} sshrV sym) -- Misc -- {at,len} (fin len) => [len][8] -> at , ("error" , {-# SCC "Prelude::error" #-} PTyPoly \a -> PFinPoly \_ -> PStrict \s -> PPrim (errorV sym a =<< valueToString sym s)) , ("trace" , {-# SCC "Prelude::trace" #-} PNumPoly \_n -> PTyPoly \_a -> PTyPoly \_b -> PFun \s -> PFun \x -> PFun \y -> PPrim do msg <- valueToString sym =<< s EvalOpts { evalPPOpts, evalLogger } <- liftIO getEOpts doc <- ppValue sym evalPPOpts =<< x liftIO $ logPrint evalLogger $ if null msg then doc else text msg <+> doc y) , ("random" , {-# SCC "Prelude::random" #-} PTyPoly \a -> PWordFun \x -> PPrim case wordAsLit sym x of Just (_,i) -> randomV sym a i Nothing -> liftIO (X.throw (UnsupportedSymbolicOp "random"))) , ("foldl" , {-# SCC "Prelude::foldl" #-} foldlV sym) , ("foldl'" , {-# SCC "Prelude::foldl'" #-} foldl'V sym) , ("scanl" , {-# SCC "Prelude::scanl" #-} scanlV sym) , ("deepseq" , {-# SCC "Prelude::deepseq" #-} PTyPoly \_a -> PTyPoly \_b -> PFun \x -> PFun \y -> PPrim do _ <- forceValue =<< x y) , ("parmap" , {-# SCC "Prelude::parmap" #-} parmapV sym) , ("fromZ" , {-# SCC "Prelude::fromZ" #-} fromZV sym) ] cryptol-3.0.0/src/Cryptol/Eval/Prims.hs0000644000000000000000000000305507346545000016142 0ustar0000000000000000{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} module Cryptol.Eval.Prims where import Cryptol.Backend import Cryptol.Eval.Type import Cryptol.Eval.Value import Cryptol.ModuleSystem.Name import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) import Cryptol.Utils.Panic -- | This type provides a lightweight syntactic framework for defining -- Cryptol primitives. The main purpose of this type is to provide -- an abstraction barrier that insulates the definitions of primitives -- from possible changes in the representation of values. data Prim sym = PFun (SEval sym (GenValue sym) -> Prim sym) | PStrict (GenValue sym -> Prim sym) | PWordFun (SWord sym -> Prim sym) | PFloatFun (SFloat sym -> Prim sym) | PTyPoly (TValue -> Prim sym) | PNumPoly (Nat' -> Prim sym) | PFinPoly (Integer -> Prim sym) | PPrim (SEval sym (GenValue sym)) | PVal (GenValue sym) -- | Evaluate a primitive into a value computation evalPrim :: Backend sym => sym -> Name -> Prim sym -> SEval sym (GenValue sym) evalPrim sym nm p = case p of PFun f -> lam sym (evalPrim sym nm . f) PStrict f -> lam sym (\x -> evalPrim sym nm . f =<< x) PWordFun f -> lam sym (\x -> evalPrim sym nm . f =<< (fromVWord sym (show nm) =<< x)) PFloatFun f -> flam sym (evalPrim sym nm . f) PTyPoly f -> tlam sym (evalPrim sym nm . f) PNumPoly f -> nlam sym (evalPrim sym nm . f) PFinPoly f -> nlam sym (\case Inf -> panic "PFin" ["Unexpected `inf`", show nm]; Nat n -> evalPrim sym nm (f n)) PPrim m -> m PVal v -> pure v cryptol-3.0.0/src/Cryptol/Eval/Reference.lhs0000644000000000000000000020406207346545000017123 0ustar0000000000000000> -- | > -- Module : Cryptol.Eval.Reference > -- Description : The reference implementation of the Cryptol evaluation semantics. > -- Copyright : (c) 2013-2020 Galois, Inc. > -- License : BSD3 > -- Maintainer : cryptol@galois.com > -- Stability : provisional > -- Portability : portable > > {-# LANGUAGE BlockArguments #-} > {-# LANGUAGE PatternGuards #-} > {-# LANGUAGE LambdaCase #-} > {-# LANGUAGE NamedFieldPuns #-} > {-# LANGUAGE ViewPatterns #-} > > module Cryptol.Eval.Reference > ( Value(..) > , E(..) > , evaluate > , evalExpr > , evalDeclGroup > , ppValue > , ppEValue > ) where > > import Data.Bits > import Data.Ratio((%)) > import Data.List > (genericIndex, genericLength, genericReplicate, genericTake, sortBy) > import Data.Ord (comparing) > import Data.Map (Map) > import qualified Data.Map as Map > import qualified Data.Text as T (pack) > import LibBF (BigFloat) > import qualified LibBF as FP > import qualified GHC.Num.Compat as Integer > import qualified Data.List as List > > import Cryptol.ModuleSystem.Name (asPrim) > import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), nAdd, nMin, nMul) > import Cryptol.TypeCheck.AST > import Cryptol.Backend.FloatHelpers (BF(..)) > import qualified Cryptol.Backend.FloatHelpers as FP > import Cryptol.Backend.Monad (EvalError(..)) > import Cryptol.Eval.Type > (TValue(..), isTBit, evalValType, evalNumType, TypeEnv, bindTypeVar) > import Cryptol.Eval.Concrete (mkBv, ppBV, lg2) > import Cryptol.Utils.Ident (Ident,PrimIdent, prelPrim, floatPrim) > import Cryptol.Utils.Panic (panic) > import Cryptol.Utils.PP > import Cryptol.Utils.RecordMap > import Cryptol.Eval (checkProp) > import Cryptol.Eval.Type (evalType, lookupTypeVar, tNumTy, tValTy) > > import qualified Cryptol.ModuleSystem as M > import qualified Cryptol.ModuleSystem.Env as M (loadedModules,loadedNewtypes) 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` | | `Z n` | integers modulo n | `TVIntMod n` | | `Rational` | rationals | `TVRational` | | `Float e p` | floating point | `TVFloat` | | `Array` | arrays | `TVArray` | | `[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 (closed) Cryptol value type `t` as a complete partial order (cpo) *M*(`t`). The values of *M*(`t`) represent the _values_ present in the type `t`; we distinguish these from the _computations_ at type `t`. Operationally, the difference is that computations may raise errors or cause nontermination when evaluated; however, values are already evaluated, and will not cause errors or nontermination. Denotationally, we represent this difference via a monad (in the style of Moggi) called *E*. As an operation on CPOs, *E* adds a new bottom element representing nontermination, and a collection of erroneous values representing various runtime error conditions. To each Cryptol expression `e : t` we assign a meaning *M*(`e`) in *E*(*M*(`t`)); in particular, recursive Cryptol programs of type `t` are modeled as least fixed points in *E*(*M*(`t`)). In other words, this is a domain-theoretic denotational semantics. Note, we do not requre CPOs defined via *M*(`t`) to have bottom elements, which is why we must take fixpoints in *E*. We cannot directly represent values without bottom in Haskell, so instead we are careful in this document only to write clearly-terminating functions, unless they represent computations under *E*. *M*(`Bit`) is a discrete cpo with values for `True`, `False`, which we simply represent in Haskell as `Bool`. Similarly, *M*(`Integer`) is a discrete cpo with values for integers, which we model as Haskell's `Integer`. Likewise with the other base types. The value cpos for lists, tuples, and records are cartesian products of _computations_. For example *M*(`(a,b)`) = *E*(*M*(`a`)) × *E*(*M*(`b`)). The cpo ordering is pointwise. The trivial types `[0]t`, `()` and `{}` denote single-element cpos. *M*(`a -> b`) is the continuous function space *E*(*M*(`a`)) $\to$ *E*(*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 *E*(*M*(`t[t1/a1 ... tn/an]`)). Computation Monad ------------------ This monad represents either an evaluated thing of type `a` or an evaluation error. In the reference interpreter, only things under this monad should potentially result in errors or fail to terminate. > -- | Computation monad for the reference evaluator. > data E a = Value !a | Err EvalError > > instance Functor E where > fmap f (Value x) = Value (f x) > fmap _ (Err e) = Err e > instance Applicative E where > pure x = Value x > Err e <*> _ = Err e > Value _ <*> Err e = Err e > Value f <*> Value x = Value (f x) > instance Monad E where > m >>= f = > case m of > Value x -> f x > Err r -> Err r > > eitherToE :: Either EvalError a -> E a > eitherToE (Left e) = Err e > eitherToE (Right x) = pure x 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 !Bool -- ^ @ Bit @ booleans > | VInteger !Integer -- ^ @ Integer @ or @Z n@ integers > | VRational !Rational -- ^ @ Rational @ rationals > | VFloat !BF -- ^ Floating point numbers > | VList Nat' [E Value] -- ^ @ [n]a @ finite or infinite lists > | VTuple [E Value] -- ^ @ ( .. ) @ tuples > | VRecord [(Ident, E Value)] -- ^ @ { .. } @ records > | VFun (E Value -> E Value) -- ^ functions > | VPoly (TValue -> E Value) -- ^ polymorphic values (kind *) > | VNumPoly (Nat' -> E Value) -- ^ polymorphic values (kind #) Operations on Values -------------------- > -- | Destructor for @VBit@. > fromVBit :: Value -> Bool > fromVBit (VBit b) = b > fromVBit _ = evalPanic "fromVBit" ["Expected a bit"] > > -- | Destructor for @VInteger@. > fromVInteger :: Value -> Integer > fromVInteger (VInteger i) = i > fromVInteger _ = evalPanic "fromVInteger" ["Expected an integer"] > > -- | Destructor for @VRational@. > fromVRational :: Value -> Rational > fromVRational (VRational i) = i > fromVRational _ = evalPanic "fromVRational" ["Expected a rational"] > > fromVFloat :: Value -> BigFloat > fromVFloat = bfValue . fromVFloat' > > fromVFloat' :: Value -> BF > fromVFloat' v = > case v of > VFloat f -> f > _ -> evalPanic "fromVFloat" [ "Expected a floating point value." ] > > -- | Destructor for @VList@. > fromVList :: Value -> [E Value] > fromVList (VList _ vs) = vs > fromVList _ = evalPanic "fromVList" ["Expected a list"] > > -- | Destructor for @VTuple@. > fromVTuple :: Value -> [E Value] > fromVTuple (VTuple vs) = vs > fromVTuple _ = evalPanic "fromVTuple" ["Expected a tuple"] > > -- | Destructor for @VRecord@. > fromVRecord :: Value -> [(Ident, E Value)] > fromVRecord (VRecord fs) = fs > fromVRecord _ = evalPanic "fromVRecord" ["Expected a record"] > > -- | Destructor for @VFun@. > fromVFun :: Value -> (E Value -> E Value) > fromVFun (VFun f) = f > fromVFun _ = evalPanic "fromVFun" ["Expected a function"] > > -- | Look up a field in a record. > lookupRecord :: Ident -> Value -> E 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 -> E 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 (E Value)) > , envTypes :: !TypeEnv > } > > instance Semigroup Env where > l <> r = Env > { envVars = envVars l <> envVars r > , envTypes = envTypes l <> envTypes r > } > > instance Monoid Env where > mempty = Env > { envVars = mempty > , envTypes = mempty > } > mappend = (<>) > > -- | Bind a variable in the evaluation environment. > bindVar :: (Name, E 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 = bindTypeVar 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 > -> E Value > evalExpr env expr = > case expr of > > ELocated _ e -> evalExpr env e > > EList es _ty -> > pure $ VList (Nat (genericLength es)) [ evalExpr env e | e <- es ] > > ETuple es -> > pure $ VTuple [ evalExpr env e | e <- es ] > > ERec fields -> > pure $ VRecord [ (f, evalExpr env e) | (f, e) <- canonicalFields fields ] > > ESel e sel -> > evalSel sel =<< evalExpr env e > > ESet ty e sel v -> > evalSet (evalValType (envTypes env) ty) > (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 -> pure $ VPoly $ \ty -> > evalExpr (bindType (tpVar tv) (Right ty) env) b > KNum -> pure $ VNumPoly $ \n -> > evalExpr (bindType (tpVar tv) (Left n) env) b > k -> evalPanic "evalExpr" ["Invalid kind on type abstraction", show k] > > ETApp e ty -> > evalExpr env e >>= \case > VPoly f -> f $! (evalValType (envTypes env) ty) > VNumPoly f -> f $! (evalNumType (envTypes env) ty) > _ -> evalPanic "evalExpr" ["Expected a polymorphic value"] > > EApp e1 e2 -> appFun (evalExpr env e1) (evalExpr env e2) > EAbs n _ty b -> pure $ 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 > > EPropGuards guards _ty -> > case List.find (all (checkProp . evalProp env) . fst) guards of > Just (_, e) -> evalExpr env e > Nothing -> evalPanic "fromVBit" ["No guard constraint was satisfied"] > appFun :: E Value -> E Value -> E Value > appFun f v = f >>= \f' -> fromVFun f' v > -- | Evaluates a `Prop` in an `EvalEnv` by substituting all variables > -- according to `envTypes` and expanding all type synonyms via `tNoUser`. > evalProp :: Env -> Prop -> Prop > evalProp env@Env { envTypes } = \case > TCon tc tys -> TCon tc (toType . evalType envTypes <$> tys) > TVar tv | Just (toType -> ty) <- lookupTypeVar tv envTypes -> ty > prop@TUser {} -> evalProp env (tNoUser prop) > TVar tv | Nothing <- lookupTypeVar tv envTypes -> panic "evalProp" ["Could not find type variable `" ++ pretty tv ++ "` in the type evaluation environment"] > prop -> panic "evalProp" ["Cannot use the following as a type constraint: `" ++ pretty prop ++ "`"] > where > toType = either tNumTy tValTy Selectors --------- Apply the the given selector form to the given value. Note that record selectors work uniformly on both record types and on newtypes. > evalSel :: Selector -> Value -> E Value > evalSel sel val = > 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. Note that record selectors work uniformly on both record types and on newtypes. > evalSet :: TValue -> E Value -> Selector -> E Value -> E Value > evalSet tyv val sel fval = > case (tyv, sel) of > (TVTuple ts, TupleSel n _) -> updTupleAt ts n > (TVRec fs, RecordSel n _) -> updRecAt fs n > (TVNewtype _ _ fs, RecordSel n _) -> updRecAt fs n > (TVSeq len _, ListSel n _) -> updSeqAt len n > (_, _) -> evalPanic "evalSet" ["type/selector mismatch", show tyv, show sel] > where > updTupleAt ts n = > pure $ VTuple > [ if i == n then fval else > do vs <- fromVTuple <$> val > genericIndex vs i > | (i,_t) <- zip [0 ..] ts > ] > > updRecAt fs n = > pure $ VRecord > [ (f, if f == n then fval else lookupRecord f =<< val) > | (f, _t) <- canonicalFields fs > ] > > updSeqAt len n = > pure $ generateV (Nat len) $ \i -> > if i == toInteger n then fval else > do vs <- fromVList <$> val > indexFront (Nat len) vs i Conditionals ------------ Conditionals are explicitly lazy: Run-time errors in an untaken branch are ignored. > condValue :: E Bool -> E Value -> E Value -> E Value > condValue c l r = c >>= \b -> if b then l else r 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 nm len _ty expr -> [ bindVar (nm, get i) env | i <- idxs ] > where > get i = > do v <- evalExpr env expr > genericIndex (fromVList v) i > > idxs :: [Integer] > idxs = > case evalNumType (envTypes env) len of > Inf -> [0 ..] > Nat n -> [0 .. n-1] > 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 > -> E Value > evalComp env expr branches = > pure $ 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 (evalDecl env') ds > in env' > > evalDecl :: Env -> Decl -> (Name, E Value) > evalDecl env d = > case dDefinition d of > DPrim -> (dName d, pure (evalPrim (dName d))) > DForeign _ -> (dName d, cryError $ FFINotSupported $ dName d) > DExpr e -> (dName d, evalExpr env e) > Newtypes -------- At runtime, newtypes values are represented in exactly the same way as records. The constructor function for newtypes is thus basically just an identity function that consumes and ignores its type arguments. > evalNewtypeDecl :: Env -> Newtype -> Env > evalNewtypeDecl env nt = bindVar (ntConName nt, pure val) env > where > val = foldr tabs con (ntParams nt) > con = VFun (\x -> x) > tabs tp body = > case tpKind tp of > KType -> VPoly (\_ -> pure body) > KNum -> VNumPoly (\_ -> pure body) > k -> evalPanic "evalNewtypeDecl" ["illegal newtype parameter kind", show k] 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 (pp n)] Cryptol primitives fall into several groups, mostly delineated by corresponding type classes: * Literals: `True`, `False`, `number`, `ratio` * Zero: zero * Logic: `&&`, `||`, `^`, `complement` * Ring: `+`, `-`, `*`, `negate`, `fromInteger` * Integral: `/`, `%`, `^^`, `toInteger` * Bitvector: `/$` `%$`, `lg2`, `<=$` * Comparison: `<`, `>`, `<=`, `>=`, `==`, `!=` * Sequences: `#`, `join`, `split`, `take`, `drop`, `reverse`, `transpose` * Shifting: `<<`, `>>`, `<<<`, `>>>` * Indexing: `@`, `@@`, `!`, `!!`, `update`, `updateEnd` * Enumerations: `fromTo`, `fromThenTo`, `fromToLessThan`, `fromToBy`, `fromToByLessThan`, `fromToDownBy`, `fromToDownByGreaterThan`, `infFrom`, `infFromThen` * Polynomials: `pmult`, `pdiv`, `pmod` * Miscellaneous: `error`, `random`, `trace` > primTable :: Map PrimIdent Value > primTable = Map.unions > [ cryptolPrimTable > , floatPrimTable > ] > infixr 0 ~> > (~>) :: String -> a -> (String,a) > nm ~> v = (nm,v) > cryptolPrimTable :: Map PrimIdent Value > cryptolPrimTable = Map.fromList $ map (\(n, v) -> (prelPrim (T.pack n), v)) > > -- Literals > [ "True" ~> VBit True > , "False" ~> VBit False > , "number" ~> vFinPoly $ \val -> pure $ > VPoly $ \a -> > literal val a > , "fraction" ~> vFinPoly \top -> pure $ > vFinPoly \bot -> pure $ > vFinPoly \rnd -> pure $ > VPoly \a -> fraction top bot rnd a > -- Zero > , "zero" ~> VPoly (pure . zero) > > -- Logic (bitwise) > , "&&" ~> binary (logicBinary (&&)) > , "||" ~> binary (logicBinary (||)) > , "^" ~> binary (logicBinary (/=)) > , "complement" ~> unary (logicUnary not) > > -- Ring > , "+" ~> binary (ringBinary > (\x y -> pure (x + y)) > (\x y -> pure (x + y)) > (fpBin FP.bfAdd fpImplicitRound) > ) > , "-" ~> binary (ringBinary > (\x y -> pure (x - y)) > (\x y -> pure (x - y)) > (fpBin FP.bfSub fpImplicitRound) > ) > , "*" ~> binary ringMul > , "negate" ~> unary (ringUnary (\x -> pure (- x)) > (\x -> pure (- x)) > (\_ _ x -> pure (FP.bfNeg x))) > , "fromInteger"~> VPoly $ \a -> pure $ > VFun $ \x -> > ringNullary (fromVInteger <$> x) > (fromInteger . fromVInteger <$> x) > (\e p -> fpFromInteger e p . fromVInteger <$> x) > a > > -- Integral > , "toInteger" ~> VPoly $ \a -> pure $ > VFun $ \x -> > VInteger <$> cryToInteger a x > , "/" ~> binary (integralBinary divWrap) > , "%" ~> binary (integralBinary modWrap) > , "^^" ~> VPoly $ \aty -> pure $ > VPoly $ \ety -> pure $ > VFun $ \a -> pure $ > VFun $ \e -> > ringExp aty a =<< cryToInteger ety e > > -- Field > , "/." ~> binary (fieldBinary ratDiv zDiv > (fpBin FP.bfDiv fpImplicitRound) > ) > > , "recip" ~> unary (fieldUnary ratRecip zRecip fpRecip) > > -- Round > , "floor" ~> unary (roundUnary floor > (eitherToE . FP.floatToInteger "floor" FP.ToNegInf)) > > , "ceiling" ~> unary (roundUnary ceiling > (eitherToE . FP.floatToInteger "ceiling" FP.ToPosInf)) > > , "trunc" ~> unary (roundUnary truncate > (eitherToE . FP.floatToInteger "trunc" FP.ToZero)) > > , "roundAway" ~> unary (roundUnary roundAwayRat > (eitherToE . FP.floatToInteger "roundAway" FP.Away)) > > , "roundToEven"~> unary (roundUnary round > (eitherToE . FP.floatToInteger "roundToEven" FP.NearEven)) > > > -- 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 > > -- Bitvector > , "/$" ~> vFinPoly $ \n -> pure $ > VFun $ \l -> pure $ > VFun $ \r -> > vWord n <$> appOp2 divWrap > (fromSignedVWord =<< l) > (fromSignedVWord =<< r) > , "%$" ~> vFinPoly $ \n -> pure $ > VFun $ \l -> pure $ > VFun $ \r -> > vWord n <$> appOp2 modWrap > (fromSignedVWord =<< l) > (fromSignedVWord =<< r) > , ">>$" ~> signedShiftRV > , "lg2" ~> vFinPoly $ \n -> pure $ > VFun $ \v -> > vWord n <$> appOp1 lg2Wrap (fromVWord =<< v) > -- Rational > , "ratio" ~> VFun $ \l -> pure $ > VFun $ \r -> > VRational <$> appOp2 ratioOp > (fromVInteger <$> l) > (fromVInteger <$> r) > > -- Z n > , "fromZ" ~> vFinPoly $ \n -> pure $ > VFun $ \x -> > VInteger . flip mod n . fromVInteger <$> x > > -- Sequences > , "#" ~> vFinPoly $ \front -> pure $ > VNumPoly $ \back -> pure $ > VPoly $ \_elty -> pure $ > VFun $ \l -> pure $ > VFun $ \r -> > pure $ generateV (nAdd (Nat front) back) $ \i -> > if i < front then > do l' <- fromVList <$> l > indexFront (Nat front) l' i > else > do r' <- fromVList <$> r > indexFront back r' (i - front) > > , "join" ~> VNumPoly $ \parts -> pure $ > vFinPoly $ \each -> pure $ > VPoly $ \_a -> pure $ > VFun $ \v -> > pure $ generateV (nMul parts (Nat each)) $ \i -> > do let (q,r) = divMod i each > xss <- fromVList <$> v > xs <- fromVList <$> indexFront parts xss q > indexFront (Nat each) xs r > > , "split" ~> VNumPoly $ \parts -> pure $ > vFinPoly $ \each -> pure $ > VPoly $ \_a -> pure $ > VFun $ \val -> > pure $ generateV parts $ \i -> > pure $ generateV (Nat each) $ \j -> > do vs <- fromVList <$> val > indexFront (nMul parts (Nat each)) vs (i * each + j) > > , "take" ~> VNumPoly $ \front -> pure $ > VNumPoly $ \back -> pure $ > VPoly $ \_a -> pure $ > VFun $ \v -> > pure $ generateV front $ \i -> > do vs <- fromVList <$> v > indexFront (nAdd front back) vs i > > , "drop" ~> vFinPoly $ \front -> pure $ > VNumPoly $ \back -> pure $ > VPoly $ \_a -> pure $ > VFun $ \v -> > pure $ generateV back $ \i -> > do vs <- fromVList <$> v > indexFront (nAdd (Nat front) back) vs (front+i) > > , "reverse" ~> vFinPoly $ \n -> pure $ > VPoly $ \_a -> pure $ > VFun $ \v -> > pure $ generateV (Nat n) $ \i -> > do vs <- fromVList <$> v > indexBack (Nat n) vs i > > , "transpose" ~> VNumPoly $ \rows -> pure $ > VNumPoly $ \cols -> pure $ > VPoly $ \_a -> pure $ > VFun $ \val -> > pure $ generateV cols $ \c -> > pure $ generateV rows $ \r -> > do xss <- fromVList <$> val > xs <- fromVList <$> indexFront rows xss r > indexFront cols xs c > > -- Shifting: > , "<<" ~> shiftV shiftLV > , ">>" ~> shiftV shiftRV > , "<<<" ~> rotateV rotateLV > , ">>>" ~> rotateV rotateRV > > -- Indexing: > , "@" ~> indexPrimOne indexFront > , "!" ~> indexPrimOne indexBack > , "update" ~> updatePrim updateFront > , "updateEnd" ~> updatePrim updateBack > > -- Enumerations > , "fromTo" ~> vFinPoly $ \first -> pure $ > vFinPoly $ \lst -> pure $ > VPoly $ \ty -> pure $ > let f i = literal i ty in > VList (Nat (1 + lst - first)) (map f [first .. lst]) > > , "fromToLessThan" ~> > vFinPoly $ \first -> pure $ > VNumPoly $ \bound -> pure $ > VPoly $ \ty -> pure $ > let f i = literal i ty in > case bound of > Inf -> VList Inf (map f [first ..]) > Nat bound' -> > let len = bound' - first in > VList (Nat len) (map f (genericTake len [first ..])) > > , "fromToBy" ~> vFinPoly $ \first -> pure $ > vFinPoly $ \lst -> pure $ > vFinPoly $ \stride -> pure $ > VPoly $ \ty -> pure $ > let f i = literal i ty in > let vs = [ f (first + i*stride) | i <- [0..] ] in > let len = 1 + ((lst-first) `div` stride) in > VList (Nat len) (genericTake len vs) > > , "fromToByLessThan" ~> > vFinPoly $ \first -> pure $ > VNumPoly $ \bound -> pure $ > vFinPoly $ \stride -> pure $ > VPoly $ \ty -> pure $ > let f i = literal i ty in > let vs = [ f (first + i*stride) | i <- [0..] ] in > case bound of > Inf -> VList Inf vs > Nat bound' -> > let len = (bound'-first+stride-1) `div` stride in > VList (Nat len) (genericTake len vs) > > , "fromToDownBy" ~> > vFinPoly $ \first -> pure $ > vFinPoly $ \lst -> pure $ > vFinPoly $ \stride -> pure $ > VPoly $ \ty -> pure $ > let f i = literal i ty in > let vs = [ f (first - i*stride) | i <- [0..] ] in > let len = 1 + ((first-lst) `div` stride) in > VList (Nat len) (genericTake len vs) > > , "fromToDownByGreaterThan" ~> > vFinPoly $ \first -> pure $ > vFinPoly $ \lst -> pure $ > vFinPoly $ \stride -> pure $ > VPoly $ \ty -> pure $ > let f i = literal i ty in > let vs = [ f (first - i*stride) | i <- [0..] ] in > let len = (first-lst+stride-1) `div` stride in > VList (Nat len) (genericTake len vs) > > , "fromThenTo" ~> vFinPoly $ \first -> pure $ > vFinPoly $ \next -> pure $ > vFinPoly $ \_lst -> pure $ > VPoly $ \ty -> pure $ > vFinPoly $ \len -> pure $ > let f i = literal i ty in > VList (Nat len) > (map f (genericTake len [first, next ..])) > > , "infFrom" ~> VPoly $ \ty -> pure $ > VFun $ \first -> > do x <- cryToInteger ty first > let f i = literal (x + i) ty > pure $ VList Inf (map f [0 ..]) > > , "infFromThen"~> VPoly $ \ty -> pure $ > VFun $ \first -> pure $ > VFun $ \next -> > do x <- cryToInteger ty first > y <- cryToInteger ty next > let diff = y - x > f i = literal (x + diff * i) ty > pure $ VList Inf (map f [0 ..]) > > -- Miscellaneous: > , "parmap" ~> VPoly $ \_a -> pure $ > VPoly $ \_b -> pure $ > VNumPoly $ \n -> pure $ > VFun $ \f -> pure $ > VFun $ \xs -> > do f' <- fromVFun <$> f > xs' <- fromVList <$> xs > -- Note: the reference implementation simply > -- executes parmap sequentially > pure $ VList n (map f' xs') > > , "error" ~> VPoly $ \_a -> pure $ > VNumPoly $ \_ -> pure $ > VFun $ \s -> > do msg <- evalString s > cryError (UserError msg) > > , "random" ~> VPoly $ \_a -> pure $ > VFun $ \_seed -> cryError (UserError "random: unimplemented") > > , "trace" ~> VNumPoly $ \_n -> pure $ > VPoly $ \_a -> pure $ > VPoly $ \_b -> pure $ > VFun $ \s -> pure $ > VFun $ \x -> pure $ > VFun $ \y -> > do _ <- evalString s -- evaluate and ignore s > _ <- x -- evaluate and ignore x > y > ] > > > evalString :: E Value -> E String > evalString v = > do cs <- fromVList <$> v > ws <- mapM (fromVWord =<<) cs > pure (map (toEnum . fromInteger) ws) > > unary :: (TValue -> E Value -> E Value) -> Value > unary f = VPoly $ \ty -> pure $ > VFun $ \x -> f ty x > > binary :: (TValue -> E Value -> E Value -> E Value) -> Value > binary f = VPoly $ \ty -> pure $ > VFun $ \x -> pure $ > VFun $ \y -> f ty x y > > appOp1 :: (a -> E b) -> E a -> E b > appOp1 f x = > do x' <- x > f x' > > appOp2 :: (a -> b -> E c) -> E a -> E b -> E c > appOp2 f x y = > do x' <- x > y' <- y > f 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 -> E Integer > fromVWord v = bitsToInteger <$> traverse (fmap 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 -> E Integer > fromSignedVWord v = signedBitsToInteger <$> traverse (fmap 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. > vWord :: Integer -> Integer -> Value > vWord w e > | w > toInteger (maxBound :: Int) = > evalPanic "vWord" ["Word length too large", show w] > | otherwise = > VList (Nat w) [ mkBit i | i <- [w-1, w-2 .. 0 ] ] > where > mkBit i = pure (VBit (testBit e (fromInteger i))) Errors ------ > cryError :: EvalError -> E a > cryError e = Err e Zero ---- The `Zero` class has a single method `zero` which computes a zero value for all the built-in types for Cryptol. For bits, bitvectors and the base numeric types, this returns the obvious 0 representation. For sequences, records, and tuples, the zero method operates pointwise the underlying types. For functions, `zero` returns the constant function that returns `zero` in the codomain. > zero :: TValue -> Value > zero TVBit = VBit False > zero TVInteger = VInteger 0 > zero TVIntMod{} = VInteger 0 > zero TVRational = VRational 0 > zero (TVFloat e p) = VFloat (fpToBF e p FP.bfPosZero) > zero TVArray{} = evalPanic "zero" ["Array type not in `Zero`"] > zero (TVSeq n ety) = VList (Nat n) (genericReplicate n (pure (zero ety))) > zero (TVStream ety) = VList Inf (repeat (pure (zero ety))) > zero (TVTuple tys) = VTuple (map (pure . zero) tys) > zero (TVRec fields) = VRecord [ (f, pure (zero fty)) > | (f, fty) <- canonicalFields fields ] > zero (TVFun _ bty) = VFun (\_ -> pure (zero bty)) > zero (TVAbstract{}) = evalPanic "zero" ["Abstract type not in `Zero`"] > zero (TVNewtype{}) = evalPanic "zero" ["Newtype not in `Zero`"] Literals -------- Given a literal integer, construct a value of a type that can represent that literal. > literal :: Integer -> TValue -> E Value > literal i = go > where > go TVInteger = pure (VInteger i) > go TVRational = pure (VRational (fromInteger i)) > go (TVIntMod n) > | i < n = pure (VInteger i) > | otherwise = evalPanic "literal" > ["Literal out of range for type Z " ++ show n] > go (TVSeq w a) > | isTBit a = pure (vWord w i) > go ty = evalPanic "literal" [show ty ++ " cannot represent literals"] Given a fraction, construct a value of a type that can represent that literal. The rounding flag determines the behavior if the literal cannot be represented exactly: 0 means report and error, other numbers round to the nearest representable value. > -- TODO: we should probably be using the rounding mode here... > fraction :: Integer -> Integer -> Integer -> TValue -> E Value > fraction top btm _rnd ty = > case ty of > TVRational -> pure (VRational (top % btm)) > TVFloat e p -> pure $ VFloat $ fpToBF e p $ FP.fpCheckStatus val > where val = FP.bfDiv opts (FP.bfFromInteger top) (FP.bfFromInteger btm) > opts = FP.fpOpts e p fpImplicitRound > _ -> evalPanic "fraction" [show ty ++ " cannot represent " ++ > show top ++ "/" ++ show btm] Logic ----- Bitwise logic primitives are defined by recursion over the type structure. On type `Bit`, the operations are 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. > logicUnary :: (Bool -> Bool) -> TValue -> E Value -> E Value > logicUnary op = go > where > go :: TValue -> E Value -> E Value > go ty val = > case ty of > TVBit -> VBit . op . fromVBit <$> val > 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 -> > do val' <- val > pure $ VRecord [ (f, go fty (lookupRecord f val')) > | (f, fty) <- canonicalFields fields ] > TVFun _ bty -> pure $ VFun (\v -> go bty (appFun val v)) > TVInteger -> evalPanic "logicUnary" ["Integer not in class Logic"] > TVIntMod _ -> evalPanic "logicUnary" ["Z not in class Logic"] > TVArray{} -> evalPanic "logicUnary" ["Array not in class Logic"] > TVRational -> evalPanic "logicUnary" ["Rational not in class Logic"] > TVFloat{} -> evalPanic "logicUnary" ["Float not in class Logic"] > TVAbstract{} -> evalPanic "logicUnary" ["Abstract type not in `Logic`"] > TVNewtype{} -> evalPanic "logicUnary" ["Newtype not in `Logic`"] > logicBinary :: (Bool -> Bool -> Bool) -> TValue -> E Value -> E Value -> E Value > logicBinary op = go > where > go :: TValue -> E Value -> E Value -> E Value > go ty l r = > case ty of > TVBit -> > VBit <$> (op <$> (fromVBit <$> l) <*> (fromVBit <$> r)) > 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 -> > do l' <- l > r' <- r > pure $ VRecord > [ (f, go fty (lookupRecord f l') (lookupRecord f r')) > | (f, fty) <- canonicalFields fields > ] > TVFun _ bty -> pure $ VFun $ \v -> > do l' <- l > r' <- r > go bty (fromVFun l' v) (fromVFun r' v) > TVInteger -> evalPanic "logicBinary" ["Integer not in class Logic"] > TVIntMod _ -> evalPanic "logicBinary" ["Z not in class Logic"] > TVArray{} -> evalPanic "logicBinary" ["Array not in class Logic"] > TVRational -> evalPanic "logicBinary" ["Rational not in class Logic"] > TVFloat{} -> evalPanic "logicBinary" ["Float not in class Logic"] > TVAbstract{} -> evalPanic "logicBinary" ["Abstract type not in `Logic`"] > TVNewtype{} -> evalPanic "logicBinary" ["Newtype not in `Logic`"] Ring Arithmetic --------------- Ring primitives may be applied to any type that is made up of finite bitvectors or one of the numeric base types. 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"`. > ringNullary :: > E Integer -> > E Rational -> > (Integer -> Integer -> E BigFloat) -> > TValue -> E Value > ringNullary i q fl = go > where > go :: TValue -> E Value > go ty = > case ty of > TVBit -> > evalPanic "arithNullary" ["Bit not in class Ring"] > TVInteger -> > VInteger <$> i > TVIntMod n -> > VInteger . flip mod n <$> i > TVRational -> > VRational <$> q > TVFloat e p -> > VFloat . fpToBF e p <$> fl e p > TVArray{} -> > evalPanic "arithNullary" ["Array not in class Ring"] > TVSeq w a > | isTBit a -> vWord w <$> i > | otherwise -> pure $ VList (Nat w) (genericReplicate w (go a)) > TVStream a -> > pure $ VList Inf (repeat (go a)) > TVFun _ ety -> > pure $ VFun (const (go ety)) > TVTuple tys -> > pure $ VTuple (map go tys) > TVRec fs -> > pure $ VRecord [ (f, go fty) | (f, fty) <- canonicalFields fs ] > TVAbstract {} -> > evalPanic "arithNullary" ["Abstract type not in `Ring`"] > TVNewtype {} -> > evalPanic "arithNullary" ["Newtype type not in `Ring`"] > ringUnary :: > (Integer -> E Integer) -> > (Rational -> E Rational) -> > (Integer -> Integer -> BigFloat -> E BigFloat) -> > TValue -> E Value -> E Value > ringUnary iop qop flop = go > where > go :: TValue -> E Value -> E Value > go ty val = > case ty of > TVBit -> > evalPanic "arithUnary" ["Bit not in class Ring"] > TVInteger -> > VInteger <$> appOp1 iop (fromVInteger <$> val) > TVArray{} -> > evalPanic "arithUnary" ["Array not in class Ring"] > TVIntMod n -> > VInteger <$> appOp1 (\i -> flip mod n <$> iop i) (fromVInteger <$> val) > TVRational -> > VRational <$> appOp1 qop (fromVRational <$> val) > TVFloat e p -> > VFloat . fpToBF e p <$> appOp1 (flop e p) (fromVFloat <$> val) > TVSeq w a > | isTBit a -> vWord w <$> (iop =<< (fromVWord =<< val)) > | otherwise -> VList (Nat w) . map (go a) . fromVList <$> val > TVStream a -> > VList Inf . map (go a) . fromVList <$> val > TVFun _ ety -> > pure $ VFun (\x -> go ety (appFun val x)) > TVTuple tys -> > VTuple . zipWith go tys . fromVTuple <$> val > TVRec fs -> > do val' <- val > pure $ VRecord [ (f, go fty (lookupRecord f val')) > | (f, fty) <- canonicalFields fs ] > TVAbstract {} -> > evalPanic "arithUnary" ["Abstract type not in `Ring`"] > TVNewtype {} -> > evalPanic "arithUnary" ["Newtype not in `Ring`"] > ringBinary :: > (Integer -> Integer -> E Integer) -> > (Rational -> Rational -> E Rational) -> > (Integer -> Integer -> BigFloat -> BigFloat -> E BigFloat) -> > TValue -> E Value -> E Value -> E Value > ringBinary iop qop flop = go > where > go :: TValue -> E Value -> E Value -> E Value > go ty l r = > case ty of > TVBit -> > evalPanic "arithBinary" ["Bit not in class Ring"] > TVInteger -> > VInteger <$> appOp2 iop (fromVInteger <$> l) (fromVInteger <$> r) > TVIntMod n -> > VInteger <$> appOp2 (\i j -> flip mod n <$> iop i j) (fromVInteger <$> l) (fromVInteger <$> r) > TVRational -> > VRational <$> appOp2 qop (fromVRational <$> l) (fromVRational <$> r) > TVFloat e p -> > VFloat . fpToBF e p <$> > appOp2 (flop e p) (fromVFloat <$> l) (fromVFloat <$> r) > TVArray{} -> > evalPanic "arithBinary" ["Array not in class Ring"] > TVSeq w a > | isTBit a -> vWord w <$> appOp2 iop (fromVWord =<< l) (fromVWord =<< r) > | otherwise -> > VList (Nat w) <$> (zipWith (go a) <$> > (fromVList <$> l) <*> > (fromVList <$> r)) > TVStream a -> > VList Inf <$> (zipWith (go a) <$> > (fromVList <$> l) <*> > (fromVList <$> r)) > TVFun _ ety -> > pure $ VFun (\x -> go ety (appFun l x) (appFun r x)) > TVTuple tys -> > VTuple <$> (zipWith3 go tys <$> > (fromVTuple <$> l) <*> > (fromVTuple <$> r)) > TVRec fs -> > do l' <- l > r' <- r > pure $ VRecord > [ (f, go fty (lookupRecord f l') (lookupRecord f r')) > | (f, fty) <- canonicalFields fs ] > TVAbstract {} -> > evalPanic "arithBinary" ["Abstract type not in class `Ring`"] > TVNewtype {} -> > evalPanic "arithBinary" ["Newtype not in class `Ring`"] Integral --------- > cryToInteger :: TValue -> E Value -> E Integer > cryToInteger ty v = case ty of > TVInteger -> fromVInteger <$> v > TVSeq _ a | isTBit a -> fromVWord =<< v > _ -> evalPanic "toInteger" [show ty ++ " is not an integral type"] > > integralBinary :: > (Integer -> Integer -> E Integer) -> > TValue -> E Value -> E Value -> E Value > integralBinary op ty x y = case ty of > TVInteger -> > VInteger <$> appOp2 op (fromVInteger <$> x) (fromVInteger <$> y) > TVSeq w a | isTBit a -> > vWord w <$> appOp2 op (fromVWord =<< x) (fromVWord =<< y) > > _ -> evalPanic "integralBinary" [show ty ++ " is not an integral type"] > > ringExp :: TValue -> E Value -> Integer -> E Value > ringExp a v i = foldl (ringMul a) (literal 1 a) (genericReplicate i v) > > ringMul :: TValue -> E Value -> E Value -> E Value > ringMul = ringBinary (\x y -> pure (x * y)) > (\x y -> pure (x * y)) > (fpBin FP.bfMul fpImplicitRound) 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 -> E Integer > divWrap _ 0 = cryError DivideByZero > divWrap x y = pure (x `quot` y) > > modWrap :: Integer -> Integer -> E Integer > modWrap _ 0 = cryError DivideByZero > modWrap x y = pure (x `rem` y) > > lg2Wrap :: Integer -> E Integer > lg2Wrap x = if x < 0 then cryError LogNegative else pure (lg2 x) Field ----- Types that represent fields have, in addition to the ring operations, a reciprocal operator and a field division operator (not to be confused with integral division). > fieldUnary :: (Rational -> E Rational) -> > (Integer -> Integer -> E Integer) -> > (Integer -> Integer -> BigFloat -> E BigFloat) -> > TValue -> E Value -> E Value > fieldUnary qop zop flop ty v = case ty of > TVRational -> VRational <$> appOp1 qop (fromVRational <$> v) > TVIntMod m -> VInteger <$> appOp1 (zop m) (fromVInteger <$> v) > TVFloat e p -> VFloat . fpToBF e p <$> appOp1 (flop e p) (fromVFloat <$> v) > _ -> evalPanic "fieldUnary" [show ty ++ " is not a Field type"] > > fieldBinary :: > (Rational -> Rational -> E Rational) -> > (Integer -> Integer -> Integer -> E Integer) -> > (Integer -> Integer -> BigFloat -> BigFloat -> E BigFloat) -> > TValue -> E Value -> E Value -> E Value > fieldBinary qop zop flop ty l r = case ty of > TVRational -> VRational <$> > appOp2 qop (fromVRational <$> l) (fromVRational <$> r) > TVIntMod m -> VInteger <$> > appOp2 (zop m) (fromVInteger <$> l) (fromVInteger <$> r) > TVFloat e p -> VFloat . fpToBF e p <$> > appOp2 (flop e p) (fromVFloat <$> l) (fromVFloat <$> r) > _ -> evalPanic "fieldBinary" [show ty ++ " is not a Field type"] > > ratDiv :: Rational -> Rational -> E Rational > ratDiv _ 0 = cryError DivideByZero > ratDiv x y = pure (x / y) > > ratRecip :: Rational -> E Rational > ratRecip 0 = cryError DivideByZero > ratRecip x = pure (recip x) > > zRecip :: Integer -> Integer -> E Integer > zRecip m x = > case Integer.integerRecipMod x m of > Just r -> pure r > Nothing -> cryError DivideByZero > > zDiv :: Integer -> Integer -> Integer -> E Integer > zDiv m x y = f <$> zRecip m y > where f yinv = (x * yinv) `mod` m Round ----- > roundUnary :: (Rational -> Integer) -> > (BF -> E Integer) -> > TValue -> E Value -> E Value > roundUnary op flop ty v = case ty of > TVRational -> VInteger . op . fromVRational <$> v > TVFloat {} -> VInteger <$> (flop . fromVFloat' =<< v) > _ -> evalPanic "roundUnary" [show ty ++ " is not a Round type"] > Haskell's definition of "round" is slightly different, as it does "round to even" on ties. > roundAwayRat :: Rational -> Integer > roundAwayRat x > | x >= 0 = floor (x + 0.5) > | otherwise = ceiling (x - 0.5) Rational ---------- > ratioOp :: Integer -> Integer -> E Rational > ratioOp _ 0 = cryError DivideByZero > ratioOp x y = pure (fromInteger x / fromInteger y) Comparison ---------- Comparison primitives may be applied to any type that is constructed of out of base types and tuples, records and finite sequences. All such types are compared using a lexicographic ordering of components. On bits, we have `False` < `True`. Sequences and tuples are compared left-to-right, and record fields are compared in alphabetical order. Comparisons on base types 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 -> E Value -> E Value -> E Value > cmpOrder p ty l r = VBit . p <$> lexCompare ty l r > > -- | Lexicographic ordering on two values. > lexCompare :: TValue -> E Value -> E Value -> E 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) > TVRational -> > compare <$> (fromVRational <$> l) <*> (fromVRational <$> r) > TVFloat{} -> > compare <$> (fromVFloat <$> l) <*> (fromVFloat <$> r) > TVArray{} -> > evalPanic "lexCompare" ["invalid type"] > 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 -> > do let tys = map snd (canonicalFields fields) > ls <- map snd . sortBy (comparing fst) . fromVRecord <$> l > rs <- map snd . sortBy (comparing fst) . fromVRecord <$> r > lexList (zipWith3 lexCompare tys ls rs) > TVAbstract {} -> > evalPanic "lexCompare" ["Abstract type not in `Cmp`"] > TVNewtype {} -> > evalPanic "lexCompare" ["Newtype not in `Cmp`"] > > lexList :: [E Ordering] -> E Ordering > lexList [] = pure EQ > lexList (e : es) = > e >>= \case > LT -> pure LT > EQ -> lexList es > GT -> pure GT Signed comparisons may be applied to any type made up of non-empty bitvectors using finite sequences, tuples and records. 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 -> E Value -> E Value -> E Value > signedLessThan ty l r = VBit . (== LT) <$> (lexSignedCompare ty l r) > > -- | Lexicographic ordering on two signed values. > lexSignedCompare :: TValue -> E Value -> E Value -> E Ordering > lexSignedCompare ty l r = > case ty of > TVBit -> > evalPanic "lexSignedCompare" ["invalid type"] > TVInteger -> > evalPanic "lexSignedCompare" ["invalid type"] > TVIntMod _ -> > evalPanic "lexSignedCompare" ["invalid type"] > TVRational -> > evalPanic "lexSignedCompare" ["invalid type"] > TVFloat{} -> > evalPanic "lexSignedCompare" ["invalid type"] > TVArray{} -> > evalPanic "lexSignedCompare" ["invalid type"] > TVSeq _w ety > | isTBit ety -> > compare <$> (fromSignedVWord =<< l) <*> (fromSignedVWord =<< r) > | 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 -> > do let tys = map snd (canonicalFields fields) > ls <- map snd . sortBy (comparing fst) . fromVRecord <$> l > rs <- map snd . sortBy (comparing fst) . fromVRecord <$> r > lexList (zipWith3 lexSignedCompare tys ls rs) > TVAbstract {} -> > evalPanic "lexSignedCompare" ["Abstract type not in `Cmp`"] > TVNewtype {} -> > evalPanic "lexSignedCompare" ["Newtype type not in `Cmp`"] Sequences --------- > generateV :: Nat' -> (Integer -> E Value) -> Value > generateV len f = VList len [ f i | i <- idxs ] > where > idxs = case len of > Inf -> [ 0 .. ] > Nat n -> [ 0 .. n-1 ] 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' -> TValue -> E Value -> Integer -> Value) -> Value > shiftV op = > VNumPoly $ \n -> pure $ > VPoly $ \ix -> pure $ > VPoly $ \a -> pure $ > VFun $ \v -> pure $ > VFun $ \x -> > do i <- cryToInteger ix x > pure $ op n a v i > > shiftLV :: Nat' -> TValue -> E Value -> Integer -> Value > shiftLV w a v amt = > case w of > Inf -> generateV Inf $ \i -> > do vs <- fromVList <$> v > indexFront Inf vs (i + amt) > Nat n -> generateV (Nat n) $ \i -> > if i + amt < n then > do vs <- fromVList <$> v > indexFront (Nat n) vs (i + amt) > else > pure (zero a) > > shiftRV :: Nat' -> TValue -> E Value -> Integer -> Value > shiftRV w a v amt = > generateV w $ \i -> > if i < amt then > pure (zero a) > else > do vs <- fromVList <$> v > indexFront w vs (i - amt) > > rotateV :: (Integer -> E Value -> Integer -> E Value) -> Value > rotateV op = > vFinPoly $ \n -> pure $ > VPoly $ \ix -> pure $ > VPoly $ \_a -> pure $ > VFun $ \v -> pure $ > VFun $ \x -> > do i <- cryToInteger ix x > op n v i > > rotateLV :: Integer -> E Value -> Integer -> E Value > rotateLV 0 v _ = v > rotateLV w v amt = > pure $ generateV (Nat w) $ \i -> > do vs <- fromVList <$> v > indexFront (Nat w) vs ((i + amt) `mod` w) > > rotateRV :: Integer -> E Value -> Integer -> E Value > rotateRV 0 v _ = v > rotateRV w v amt = > pure $ generateV (Nat w) $ \i -> > do vs <- fromVList <$> v > indexFront (Nat w) vs ((i - amt) `mod` w) > > signedShiftRV :: Value > signedShiftRV = > VNumPoly $ \n -> pure $ > VPoly $ \ix -> pure $ > VFun $ \v -> pure $ > VFun $ \x -> > do amt <- cryToInteger ix x > pure $ generateV n $ \i -> > do vs <- fromVList <$> v > if i < amt then > indexFront n vs 0 > else > indexFront n vs (i - amt) Indexing -------- Indexing and update 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' -> [E Value] -> Integer -> E Value) -> Value > indexPrimOne op = > VNumPoly $ \n -> pure $ > VPoly $ \_a -> pure $ > VPoly $ \ix -> pure $ > VFun $ \l -> pure $ > VFun $ \r -> > do vs <- fromVList <$> l > i <- cryToInteger ix r > op n vs i > > indexFront :: Nat' -> [E Value] -> Integer -> E Value > indexFront w vs ix = > case w of > Nat n | 0 <= ix && ix < n -> genericIndex vs ix > Inf | 0 <= ix -> genericIndex vs ix > _ -> cryError (InvalidIndex (Just ix)) > > indexBack :: Nat' -> [E Value] -> Integer -> E Value > indexBack w vs ix = > case w of > Nat n | 0 <= ix && ix < n -> genericIndex vs (n - ix - 1) > | otherwise -> cryError (InvalidIndex (Just ix)) > Inf -> evalPanic "indexBack" ["unexpected infinite sequence"] > > updatePrim :: (Nat' -> Integer -> Integer) -> Value > updatePrim op = > VNumPoly $ \len -> pure $ > VPoly $ \_eltTy -> pure $ > VPoly $ \ix -> pure $ > VFun $ \xs -> pure $ > VFun $ \idx -> pure $ > VFun $ \val -> > do j <- cryToInteger ix idx > if Nat j < len then > pure $ generateV len $ \i -> > if i == op len j then > val > else > do xs' <- fromVList <$> xs > indexFront len xs' i > else > cryError (InvalidIndex (Just j)) > > updateFront :: Nat' -> Integer -> Integer > updateFront _ j = j > > updateBack :: Nat' -> Integer -> Integer > updateBack Inf _j = evalPanic "Unexpected infinite sequence in updateEnd" [] > updateBack (Nat n) j = n - j - 1 Floating Point Numbers ---------------------- Whenever we do operations that do not have an explicit rounding mode, we round towards the closest number, with ties resolved to the even one. > fpImplicitRound :: FP.RoundMode > fpImplicitRound = FP.NearEven We annotate floating point values with their precision. This is only used when pretty printing values. > fpToBF :: Integer -> Integer -> BigFloat -> BF > fpToBF e p x = BF { bfValue = x, bfExpWidth = e, bfPrecWidth = p } The following two functions convert between floaitng point numbers and integers. > fpFromInteger :: Integer -> Integer -> Integer -> BigFloat > fpFromInteger e p = FP.fpCheckStatus . FP.bfRoundFloat opts . FP.bfFromInteger > where opts = FP.fpOpts e p fpImplicitRound These functions capture the interactions with rationals. This just captures a common pattern for binary floating point primitives. > fpBin :: (FP.BFOpts -> BigFloat -> BigFloat -> (BigFloat,FP.Status)) -> > FP.RoundMode -> Integer -> Integer -> > BigFloat -> BigFloat -> E BigFloat > fpBin f r e p x y = pure (FP.fpCheckStatus (f (FP.fpOpts e p r) x y)) Computes the reciprocal of a floating point number via division. This assumes that 1 can be represented exactly, which should be true for all supported precisions. > fpRecip :: Integer -> Integer -> BigFloat -> E BigFloat > fpRecip e p x = pure (FP.fpCheckStatus (FP.bfDiv opts (FP.bfFromInteger 1) x)) > where opts = FP.fpOpts e p fpImplicitRound > floatPrimTable :: Map PrimIdent Value > floatPrimTable = Map.fromList $ map (\(n, v) -> (floatPrim (T.pack n), v)) > [ "fpNaN" ~> vFinPoly \e -> pure $ > vFinPoly \p -> > pure $ VFloat $ fpToBF e p FP.bfNaN > > , "fpPosInf" ~> vFinPoly \e -> pure $ > vFinPoly \p -> > pure $ VFloat $ fpToBF e p FP.bfPosInf > > , "fpFromBits" ~> vFinPoly \e -> pure $ > vFinPoly \p -> pure $ > VFun \bvv -> > VFloat . FP.floatFromBits e p <$> (fromVWord =<< bvv) > > , "fpToBits" ~> vFinPoly \e -> pure $ > vFinPoly \p -> pure $ > VFun \fpv -> > vWord (e + p) . FP.floatToBits e p . fromVFloat <$> fpv > > , "=.=" ~> vFinPoly \_ -> pure $ > vFinPoly \_ -> pure $ > VFun \xv -> pure $ > VFun \yv -> > do x <- fromVFloat <$> xv > y <- fromVFloat <$> yv > pure (VBit (FP.bfCompare x y == EQ)) > > , "fpIsFinite" ~> vFinPoly \_ -> pure $ > vFinPoly \_ -> pure $ > VFun \xv -> > do x <- fromVFloat <$> xv > pure (VBit (FP.bfIsFinite x)) > > , "fpAdd" ~> fpArith FP.bfAdd > , "fpSub" ~> fpArith FP.bfSub > , "fpMul" ~> fpArith FP.bfMul > , "fpDiv" ~> fpArith FP.bfDiv > > , "fpToRational" ~> > vFinPoly \_ -> pure $ > vFinPoly \_ -> pure $ > VFun \fpv -> > do fp <- fromVFloat' <$> fpv > VRational <$> (eitherToE (FP.floatToRational "fpToRational" fp)) > , "fpFromRational" ~> > vFinPoly \e -> pure $ > vFinPoly \p -> pure $ > VFun \rmv -> pure $ > VFun \rv -> > do rm <- fromVWord =<< rmv > rm' <- eitherToE (FP.fpRound rm) > rat <- fromVRational <$> rv > pure (VFloat (FP.floatFromRational e p rm' rat)) > ] > where > fpArith f = vFinPoly \e -> pure $ > vFinPoly \p -> pure $ > VFun \vr -> pure $ > VFun \xv -> pure $ > VFun \yv -> > do r <- fromVWord =<< vr > rnd <- eitherToE (FP.fpRound r) > x <- fromVFloat <$> xv > y <- fromVFloat <$> yv > VFloat . fpToBF e p <$> fpBin f rnd e p x 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 --------------- > ppEValue :: PPOpts -> E Value -> Doc > ppEValue _opts (Err e) = text (show e) > ppEValue opts (Value v) = ppValue opts v > > ppValue :: PPOpts -> Value -> Doc > ppValue opts val = > case val of > VBit b -> text (show b) > VInteger i -> text (show i) > VRational q -> text (show q) > VFloat fl -> text (show (FP.fpPP opts fl)) > VList l vs -> > case l of > Inf -> ppList (map (ppEValue 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 (ppEValue opts) vs) > where isBit v = case v of Value (VBit b) -> Just b > _ -> Nothing > VTuple vs -> ppTuple (map (ppEValue opts) vs) > VRecord fs -> ppRecord (map ppField fs) > where ppField (f,r) = pp f <+> char '=' <+> ppEValue 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 (E Value) > evaluate expr minp = return (Right (val, modEnv), []) > where > modEnv = M.minpModuleEnv minp > extDgs = concatMap mDecls (M.loadedModules modEnv) ++ M.deDecls (M.meDynEnv modEnv) > nts = Map.elems (M.loadedNewtypes modEnv) > env = foldl evalDeclGroup (foldl evalNewtypeDecl mempty nts) extDgs > val = evalExpr env expr cryptol-3.0.0/src/Cryptol/Eval/SBV.hs0000644000000000000000000001443507346545000015506 0ustar0000000000000000-- | -- Module : Cryptol.Eval.SBV -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} module Cryptol.Eval.SBV ( primTable ) where import qualified Control.Exception as X import Control.Monad.IO.Class (MonadIO(..)) import qualified Data.Map as Map import qualified Data.Text as T import Data.SBV.Dynamic as SBV import Cryptol.Backend import Cryptol.Backend.Monad (Unsupported(..), EvalError(..) ) import Cryptol.Backend.SBV import Cryptol.Backend.SeqMap import Cryptol.Backend.WordValue import Cryptol.Eval.Type (TValue(..)) import Cryptol.Eval.Generic import Cryptol.Eval.Prims import Cryptol.Eval.Value import Cryptol.TypeCheck.Solver.InfNat (Nat'(..)) import Cryptol.Utils.Ident -- Values ---------------------------------------------------------------------- type Value = GenValue SBV -- Primitives ------------------------------------------------------------------ -- See also Cryptol.Eval.Concrete.primTable primTable :: SBV -> IO EvalOpts -> Map.Map PrimIdent (Prim SBV) primTable sym getEOpts = Map.union (genericPrimTable sym getEOpts) $ Map.fromList $ map (\(n, v) -> (prelPrim (T.pack n), v)) [ -- Indexing and updates ("@" , indexPrim sym IndexForward (indexFront sym) (indexFront_segs sym)) , ("!" , indexPrim sym IndexBackward (indexFront sym) (indexFront_segs sym)) , ("update" , updatePrim sym (updateFrontSym_word sym) (updateFrontSym sym)) , ("updateEnd" , updatePrim sym (updateBackSym_word sym) (updateBackSym sym)) ] indexFront :: SBV -> Nat' -> TValue -> SeqMap SBV (GenValue SBV) -> TValue -> SVal -> SEval SBV Value indexFront sym mblen a xs _ix idx | Just i <- SBV.svAsInteger idx = lookupSeqMap xs i | Nat n <- mblen , TVSeq wlen TVBit <- a = do wvs <- traverse (fromWordVal "indexFront" <$>) (enumerateSeqMap n xs) asWordList sym wvs >>= \case Just ws -> do z <- wordLit sym wlen 0 return $ VWord wlen $ wordVal $ SBV.svSelect ws z idx Nothing -> folded' | otherwise = folded' where k = SBV.kindOf idx f n (Just y) = Just $ iteValue sym (SBV.svEqual idx (SBV.svInteger k n)) (lookupSeqMap xs n) y f n Nothing = Just $ lookupSeqMap xs n folded' = case folded of Nothing -> raiseError sym (InvalidIndex Nothing) Just m -> m folded = case k of KBounded _ w -> case mblen of Nat n | n < 2^w -> foldr f Nothing [0 .. n-1] _ -> foldr f Nothing [0 .. 2^w - 1] _ -> case mblen of Nat n -> foldr f Nothing [0 .. n-1] Inf -> Just (liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer indexing"))) indexFront_segs :: SBV -> Nat' -> TValue -> SeqMap SBV (GenValue SBV) -> TValue -> Integer -> [IndexSegment SBV] -> SEval SBV Value indexFront_segs sym mblen a xs ix _idx_bits [WordIndexSegment w] = indexFront sym mblen a xs ix w indexFront_segs sym mblen _a xs _ix idx_bits segs = do xs' <- barrelShifter sym (mergeValue sym) shiftOp mblen xs idx_bits segs lookupSeqMap xs' 0 where shiftOp vs amt = pure (indexSeqMap (\i -> lookupSeqMap vs $! amt+i)) updateFrontSym :: SBV -> Nat' -> TValue -> SeqMap SBV (GenValue SBV) -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> SEval SBV (SeqMap SBV (GenValue SBV)) updateFrontSym sym _len _eltTy vs (Left idx) val = case SBV.svAsInteger idx of Just i -> return $ updateSeqMap vs i val Nothing -> return $ indexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym i iteValue sym b val (lookupSeqMap vs i) updateFrontSym sym _len _eltTy vs (Right wv) val = wordValAsLit sym wv >>= \case Just j -> return $ updateSeqMap vs j val Nothing -> return $ indexSeqMap $ \i -> do b <- wordValueEqualsInteger sym wv i iteValue sym b val (lookupSeqMap vs i) updateFrontSym_word :: SBV -> Nat' -> TValue -> WordValue SBV -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> SEval SBV (WordValue SBV) updateFrontSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_bits"] updateFrontSym_word sym (Nat n) _eltTy w (Left idx) val = do idx' <- wordFromInt sym n idx updateWordByWord sym IndexForward w (wordVal idx') (fromVBit <$> val) updateFrontSym_word sym (Nat _n) _eltTy w (Right idx) val = updateWordByWord sym IndexForward w idx (fromVBit <$> val) updateBackSym :: SBV -> Nat' -> TValue -> SeqMap SBV (GenValue SBV) -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> SEval SBV (SeqMap SBV (GenValue SBV)) updateBackSym _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"] updateBackSym sym (Nat n) _eltTy vs (Left idx) val = case SBV.svAsInteger idx of Just i -> return $ updateSeqMap vs (n - 1 - i) val Nothing -> return $ indexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) updateBackSym sym (Nat n) _eltTy vs (Right wv) val = wordValAsLit sym wv >>= \case Just j -> return $ updateSeqMap vs (n - 1 - j) val Nothing -> return $ indexSeqMap $ \i -> do b <- wordValueEqualsInteger sym wv (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) updateBackSym_word :: SBV -> Nat' -> TValue -> WordValue SBV -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> SEval SBV (WordValue SBV) updateBackSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_bits"] updateBackSym_word sym (Nat n) _eltTy w (Left idx) val = do idx' <- wordFromInt sym n idx updateWordByWord sym IndexBackward w (wordVal idx') (fromVBit <$> val) updateBackSym_word sym (Nat _n) _eltTy w (Right idx) val = updateWordByWord sym IndexBackward w idx (fromVBit <$> val) cryptol-3.0.0/src/Cryptol/Eval/Type.hs0000644000000000000000000001716307346545000015776 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.Backend.Monad (evalPanic) 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 Cryptol.Utils.RecordMap import Cryptol.Utils.Types import Data.Maybe(fromMaybe) import qualified Data.IntMap.Strict as IntMap import GHC.Generics (Generic) 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 @ | TVFloat Integer Integer -- ^ @ Float e p @ | TVIntMod Integer -- ^ @ Z n @ | TVRational -- ^ @Rational@ | TVArray TValue TValue -- ^ @ Array a b @ | TVSeq Integer TValue -- ^ @ [n]a @ | TVStream TValue -- ^ @ [inf]t @ | TVTuple [TValue] -- ^ @ (a, b, c )@ | TVRec (RecordMap Ident TValue) -- ^ @ { x : a, y : b, z : c } @ | TVFun TValue TValue -- ^ @ a -> b @ | TVNewtype Newtype [Either Nat' TValue] (RecordMap Ident TValue) -- ^ a named newtype | TVAbstract UserTC [Either Nat' TValue] -- ^ an abstract type deriving (Generic, NFData, Eq) -- | Convert a type value back into a regular type tValTy :: TValue -> Type tValTy tv = case tv of TVBit -> tBit TVInteger -> tInteger TVFloat e p -> tFloat (tNum e) (tNum p) TVIntMod n -> tIntMod (tNum n) TVRational -> tRational TVArray a b -> tArray (tValTy a) (tValTy b) TVSeq n t -> tSeq (tNum n) (tValTy t) TVStream t -> tSeq tInf (tValTy t) TVTuple ts -> tTuple (map tValTy ts) TVRec fs -> tRec (fmap tValTy fs) TVFun t1 t2 -> tFun (tValTy t1) (tValTy t2) TVNewtype nt vs _ -> tNewtype nt (map tNumValTy vs) TVAbstract u vs -> tAbstract u (map tNumValTy vs) tNumTy :: Nat' -> Type tNumTy Inf = tInf tNumTy (Nat n) = tNum n tNumValTy :: Either Nat' TValue -> Type tNumValTy = either tNumTy tValTy 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 -- | The Cryptol @Float64@ type. tvFloat64 :: TValue tvFloat64 = uncurry TVFloat float64ExpPrec -- | 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 ------------------------------------------------------------- newtype TypeEnv = TypeEnv { envTypeMap :: IntMap.IntMap (Either Nat' TValue) } deriving (Show) instance Monoid TypeEnv where mempty = TypeEnv mempty instance Semigroup TypeEnv where l <> r = TypeEnv { envTypeMap = IntMap.union (envTypeMap l) (envTypeMap r) } lookupTypeVar :: TVar -> TypeEnv -> Maybe (Either Nat' TValue) lookupTypeVar tv env = IntMap.lookup (tvUnique tv) (envTypeMap env) bindTypeVar :: TVar -> Either Nat' TValue -> TypeEnv -> TypeEnv bindTypeVar tv ty env = env{ envTypeMap = IntMap.insert (tvUnique tv) ty (envTypeMap env) } -- | Evaluation for types (kind * or #). evalType :: TypeEnv -> Type -> Either Nat' TValue evalType env ty = case ty of TVar tv -> case lookupTypeVar tv env of Just v -> v Nothing -> evalPanic "evalType" ["type variable not bound", show tv] TUser _ _ ty' -> evalType env ty' TRec fields -> Right $ TVRec (fmap val fields) TNewtype nt ts -> Right $ TVNewtype nt tvs $ evalNewtypeBody env nt tvs where tvs = map (evalType env) ts TCon (TC c) ts -> case (c, ts) of (TCBit, []) -> Right $ TVBit (TCInteger, []) -> Right $ TVInteger (TCRational, []) -> Right $ TVRational (TCFloat, [e,p])-> Right $ TVFloat (inum e) (inum p) (TCIntMod, [n]) -> case num n of Inf -> evalPanic "evalType" ["invalid type Z inf"] Nat m -> Right $ TVIntMod m (TCArray, [a, b]) -> Right $ TVArray (val a) (val b) (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) ] _ -> 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 _) ts -> evalPanic "evalType" $ "Lingering invalid type" : map (show . pp) ts where val = evalValType env num = evalNumType env inum x = case num x of Nat i -> i Inf -> evalPanic "evalType" ["Expecting a finite size, but got `inf`"] -- | Evaluate the body of a newtype, given evaluated arguments evalNewtypeBody :: TypeEnv -> Newtype -> [Either Nat' TValue] -> RecordMap Ident TValue evalNewtypeBody env0 nt args = fmap (evalValType env') (ntFields nt) where env' = loop env0 (ntParams nt) args loop env [] [] = env loop env (p:ps) (a:as) = loop (bindTypeVar (TVBound p) a env) ps as loop _ _ _ = evalPanic "evalNewtype" ["type parameter/argument mismatch"] -- | Evaluation for value types (kind *). evalValType :: 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 :: 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 :: 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 (evalPanic "evalTF" ["type cannot be demoted", show (pp ty)]) ty = TCon (TF f) (map tNat' vs) cryptol-3.0.0/src/Cryptol/Eval/Value.hs0000644000000000000000000004260607346545000016131 0ustar0000000000000000-- | -- Module : Cryptol.Eval.Value -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Cryptol.Eval.Value ( -- * GenericValue GenValue(..) , forceValue , Backend(..) , asciiMode , EvalOpts(..) -- ** Value introduction operations , word , lam , flam , tlam , nlam , ilam , mkSeq -- ** Value eliminators , fromVBit , fromVInteger , fromVRational , fromVFloat , fromVSeq , fromSeq , fromWordVal , asIndex , fromVWord , vWordLen , tryFromBits , fromVFun , fromVPoly , fromVNumPoly , fromVTuple , fromVRecord , lookupRecord -- ** Pretty printing , defaultPPOpts , ppValue -- * Merge and if/then/else , iteValue , mergeValue ) where import Data.Ratio import Numeric (showIntAtBase) import Cryptol.Backend import Cryptol.Backend.SeqMap import qualified Cryptol.Backend.Arch as Arch import Cryptol.Backend.Monad ( evalPanic, wordTooWide, CallStack, combineCallStacks ) import Cryptol.Backend.FloatHelpers (fpPP) import Cryptol.Backend.WordValue import Cryptol.Eval.Type import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) import Cryptol.Utils.Ident (Ident) import Cryptol.Utils.Logger(Logger) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.PP import Cryptol.Utils.RecordMap import GHC.Generics (Generic) -- | Some options for evalutaion data EvalOpts = EvalOpts { evalLogger :: Logger -- ^ Where to print stuff (e.g., for @trace@) , evalPPOpts :: PPOpts -- ^ How to pretty print things. } -- Values ---------------------------------------------------------------------- -- | 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 sym = VRecord !(RecordMap Ident (SEval sym (GenValue sym))) -- ^ @ { .. } @ | VTuple ![SEval sym (GenValue sym)] -- ^ @ ( .. ) @ | VBit !(SBit sym) -- ^ @ Bit @ | VInteger !(SInteger sym) -- ^ @ Integer @ or @ Z n @ | VRational !(SRational sym) -- ^ @ Rational @ | VFloat !(SFloat sym) | VSeq !Integer !(SeqMap sym (GenValue sym)) -- ^ @ [n]a @ -- Invariant: VSeq is never a sequence of bits | VWord !Integer !(WordValue sym) -- ^ @ [n]Bit @ | VStream !(SeqMap sym (GenValue sym)) -- ^ @ [inf]a @ | VFun CallStack (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -- ^ functions | VPoly CallStack (TValue -> SEval sym (GenValue sym)) -- ^ polymorphic values (kind *) | VNumPoly CallStack (Nat' -> SEval sym (GenValue sym)) -- ^ polymorphic values (kind #) deriving Generic -- | Force the evaluation of a value forceValue :: Backend sym => GenValue sym -> SEval sym () forceValue v = case v of VRecord fs -> mapM_ (forceValue =<<) fs VTuple xs -> mapM_ (forceValue =<<) xs VSeq n xs -> mapM_ (forceValue =<<) (enumerateSeqMap n xs) VBit b -> seq b (return ()) VInteger i -> seq i (return ()) VRational q -> seq q (return ()) VFloat f -> seq f (return ()) VWord _ wv -> forceWordValue wv VStream _ -> return () VFun{} -> return () VPoly{} -> return () VNumPoly{} -> return () instance Show (GenValue sym) where show v = case v of VRecord fs -> "record:" ++ show (displayOrder fs) VTuple xs -> "tuple:" ++ show (length xs) VBit _ -> "bit" VInteger _ -> "integer" VRational _ -> "rational" VFloat _ -> "float" VSeq n _ -> "seq:" ++ show n VWord n _ -> "word:" ++ show n VStream _ -> "stream" VFun{} -> "fun" VPoly{} -> "poly" VNumPoly{} -> "numpoly" -- Pretty Printing ------------------------------------------------------------- ppValue :: forall sym. Backend sym => sym -> PPOpts -> GenValue sym -> SEval sym Doc ppValue x opts = loop where loop :: GenValue sym -> SEval sym Doc loop val = case val of VRecord fs -> do fs' <- traverse (>>= loop) fs return $ ppRecord (map ppField (fields fs')) where ppField (f,r) = pp f <+> char '=' <+> r VTuple vals -> do vals' <- traverse (>>=loop) vals return $ ppTuple vals' VBit b -> ppSBit x b VInteger i -> ppSInteger x i VRational q -> ppSRational x q VFloat i -> ppSFloat x opts i VSeq sz vals -> ppWordSeq sz vals VWord _ wv -> ppWordVal wv VStream vals -> do vals' <- traverse (>>=loop) $ enumerateSeqMap (useInfLength opts) vals return $ ppList ( vals' ++ [text "..."] ) VFun{} -> return $ text "" VPoly{} -> return $ text "" VNumPoly{} -> return $ text "" fields :: RecordMap Ident Doc -> [(Ident, Doc)] fields = case useFieldOrder opts of DisplayOrder -> displayFields CanonicalOrder -> canonicalFields ppWordVal :: WordValue sym -> SEval sym Doc ppWordVal w = ppSWord x opts =<< asWordVal x w ppWordSeq :: Integer -> SeqMap sym (GenValue sym) -> SEval sym 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 x "ppWordSeq") ws case traverse (wordAsChar x) vs of Just str -> return $ text (show str) _ -> do vs' <- mapM (ppSWord x opts) vs return $ ppList vs' _ -> do ws' <- traverse loop ws return $ ppList ws' ppSBit :: Backend sym => sym -> SBit sym -> SEval sym Doc ppSBit sym b = case bitAsLit sym b of Just True -> pure (text "True") Just False -> pure (text "False") Nothing -> pure (text "?") ppSInteger :: Backend sym => sym -> SInteger sym -> SEval sym Doc ppSInteger sym x = case integerAsLit sym x of Just i -> pure (integer i) Nothing -> pure (text "[?]") ppSFloat :: Backend sym => sym -> PPOpts -> SFloat sym -> SEval sym Doc ppSFloat sym opts x = case fpAsLit sym x of Just fp -> pure (fpPP opts fp) Nothing -> pure (text "[?]") ppSRational :: Backend sym => sym -> SRational sym -> SEval sym Doc ppSRational sym (SRational n d) | Just ni <- integerAsLit sym n , Just di <- integerAsLit sym d = let q = ni % di in pure (text "(ratio" <+> integer (numerator q) <+> (integer (denominator q) <> text ")")) | otherwise = do n' <- ppSInteger sym n d' <- ppSInteger sym d pure (text "(ratio" <+> n' <+> (d' <> text ")")) ppSWord :: Backend sym => sym -> PPOpts -> SWord sym -> SEval sym Doc ppSWord sym opts bv | asciiMode opts width = case wordAsLit sym bv of Just (_,i) -> pure (text (show (toEnum (fromInteger i) :: Char))) Nothing -> pure (text "?") | otherwise = case wordAsLit sym bv of Just (_,i) -> let val = value i in pure (prefix (length val) <.> text val) Nothing | base == 2 -> sliceDigits 1 "0b" | base == 8 -> sliceDigits 3 "0o" | base == 16 -> sliceDigits 4 "0x" | otherwise -> pure (text "[?]") where width = wordLen sym bv base = if useBase opts > 36 then 10 else useBase opts padding bitsPerDigit len = text (replicate padLen '0') where padLen | m > 0 = d + 1 | otherwise = d (d,m) = (fromInteger width - (len * bitsPerDigit)) `divMod` bitsPerDigit prefix len = case base of 2 -> text "0b" <.> padding 1 len 8 -> text "0o" <.> padding 3 len 10 -> mempty 16 -> text "0x" <.> padding 4 len _ -> text "0" <.> char '<' <.> int base <.> char '>' value i = showIntAtBase (toInteger base) (digits !!) i "" digits = "0123456789abcdefghijklmnopqrstuvwxyz" toDigit w = case wordAsLit sym w of Just (_,i) | i <= 36 -> digits !! fromInteger i _ -> '?' sliceDigits bits pfx = do ws <- goDigits bits [] bv let ds = map toDigit ws pure (text pfx <.> text ds) goDigits bits ds w | wordLen sym w > bits = do (hi,lo) <- splitWord sym (wordLen sym w - bits) bits w goDigits bits (lo:ds) hi | wordLen sym w > 0 = pure (w:ds) | otherwise = pure ds -- Value Constructors ---------------------------------------------------------- -- | Create a packed word of n bits. word :: Backend sym => sym -> Integer -> Integer -> SEval sym (GenValue sym) word sym n i | n >= Arch.maxBigIntWidth = wordTooWide n | otherwise = VWord n . wordVal <$> wordLit sym n i -- | Construct a function value lam :: Backend sym => sym -> (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym) lam sym f = VFun <$> sGetCallStack sym <*> pure f -- | Functions that assume floating point inputs flam :: Backend sym => sym -> (SFloat sym -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym) flam sym f = VFun <$> sGetCallStack sym <*> pure (\arg -> arg >>= f . fromVFloat) -- | A type lambda that expects a 'Type'. tlam :: Backend sym => sym -> (TValue -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym) tlam sym f = VPoly <$> sGetCallStack sym <*> pure f -- | A type lambda that expects a 'Type' of kind #. nlam :: Backend sym => sym -> (Nat' -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym) nlam sym f = VNumPoly <$> sGetCallStack sym <*> pure f -- | A type lambda that expects a finite numeric type. ilam :: Backend sym => sym -> (Integer -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym) ilam sym f = nlam sym (\n -> case n of Nat i -> f i Inf -> panic "ilam" [ "Unexpected `inf`" ]) -- | 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 :: Backend sym => sym -> Nat' -> TValue -> SeqMap sym (GenValue sym) -> SEval sym (GenValue sym) mkSeq sym len elty vals = case len of Nat n | isTBit elty -> VWord n <$> bitmapWordVal sym n (fromVBit <$> vals) | otherwise -> pure $ VSeq n vals Inf -> pure $ VStream vals -- Value Destructors ----------------------------------------------------------- -- | Extract a bit value. fromVBit :: GenValue sym -> SBit sym fromVBit val = case val of VBit b -> b _ -> evalPanic "fromVBit" ["not a Bit", show val] -- | Extract an integer value. fromVInteger :: GenValue sym -> SInteger sym fromVInteger val = case val of VInteger i -> i _ -> evalPanic "fromVInteger" ["not an Integer", show val] -- | Extract a rational value. fromVRational :: GenValue sym -> SRational sym fromVRational val = case val of VRational q -> q _ -> evalPanic "fromVRational" ["not a Rational", show val] -- | Extract a finite sequence value. fromVSeq :: GenValue sym -> SeqMap sym (GenValue sym) fromVSeq val = case val of VSeq _ vs -> vs _ -> evalPanic "fromVSeq" ["not a sequence", show val] -- | Extract a sequence. fromSeq :: Backend sym => String -> GenValue sym -> SEval sym (SeqMap sym (GenValue sym)) fromSeq msg val = case val of VSeq _ vs -> return vs VStream vs -> return vs _ -> evalPanic "fromSeq" ["not a sequence", msg, show val] fromWordVal :: Backend sym => String -> GenValue sym -> WordValue sym fromWordVal _msg (VWord _ wval) = wval fromWordVal msg val = evalPanic "fromWordVal" ["not a word value", msg, show val] asIndex :: Backend sym => sym -> String -> TValue -> GenValue sym -> Either (SInteger sym) (WordValue sym) asIndex _sym _msg TVInteger (VInteger i) = Left i asIndex _sym _msg _ (VWord _ wval) = Right wval asIndex _sym msg _ val = evalPanic "asIndex" ["not an index value", msg, show val] -- | Extract a packed word. fromVWord :: Backend sym => sym -> String -> GenValue sym -> SEval sym (SWord sym) fromVWord sym _msg (VWord _ wval) = asWordVal sym wval fromVWord _ msg val = evalPanic "fromVWord" ["not a word", msg, show val] vWordLen :: Backend sym => GenValue sym -> 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 :: Backend sym => sym -> [SEval sym (GenValue sym)] -> SEval sym (Maybe (SWord sym)) tryFromBits sym = go id where go f [] = Just <$> (packWord sym (f [])) go f (v : vs) = isReady sym v >>= \case Just v' -> go (f . ((fromVBit v'):)) vs Nothing -> pure Nothing -- | Extract a function from a value. fromVFun :: Backend sym => sym -> GenValue sym -> (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) fromVFun sym val = case val of VFun fnstk f -> \x -> sModifyCallStack sym (\stk -> combineCallStacks stk fnstk) (f x) _ -> evalPanic "fromVFun" ["not a function", show val] -- | Extract a polymorphic function from a value. fromVPoly :: Backend sym => sym -> GenValue sym -> (TValue -> SEval sym (GenValue sym)) fromVPoly sym val = case val of VPoly fnstk f -> \x -> sModifyCallStack sym (\stk -> combineCallStacks stk fnstk) (f x) _ -> evalPanic "fromVPoly" ["not a polymorphic value", show val] -- | Extract a polymorphic function from a value. fromVNumPoly :: Backend sym => sym -> GenValue sym -> (Nat' -> SEval sym (GenValue sym)) fromVNumPoly sym val = case val of VNumPoly fnstk f -> \x -> sModifyCallStack sym (\stk -> combineCallStacks stk fnstk) (f x) _ -> evalPanic "fromVNumPoly" ["not a polymorphic value", show val] -- | Extract a tuple from a value. fromVTuple :: GenValue sym -> [SEval sym (GenValue sym)] fromVTuple val = case val of VTuple vs -> vs _ -> evalPanic "fromVTuple" ["not a tuple", show val] -- | Extract a record from a value. fromVRecord :: GenValue sym -> RecordMap Ident (SEval sym (GenValue sym)) fromVRecord val = case val of VRecord fs -> fs _ -> evalPanic "fromVRecord" ["not a record", show val] fromVFloat :: GenValue sym -> SFloat sym fromVFloat val = case val of VFloat x -> x _ -> evalPanic "fromVFloat" ["not a Float", show val] -- | Lookup a field in a record. lookupRecord :: Ident -> GenValue sym -> SEval sym (GenValue sym) lookupRecord f val = case lookupField f (fromVRecord val) of Just x -> x Nothing -> evalPanic "lookupRecord" ["malformed record", show val] -- Merge and if/then/else {-# INLINE iteValue #-} iteValue :: Backend sym => sym -> SBit sym -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) iteValue sym b x y | Just True <- bitAsLit sym b = x | Just False <- bitAsLit sym b = y | otherwise = mergeValue' sym b x y {-# INLINE mergeValue' #-} mergeValue' :: Backend sym => sym -> SBit sym -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) mergeValue' sym = mergeEval sym (mergeValue sym) mergeValue :: Backend sym => sym -> SBit sym -> GenValue sym -> GenValue sym -> SEval sym (GenValue sym) mergeValue sym c v1 v2 = case (v1, v2) of (VRecord fs1 , VRecord fs2 ) -> do let res = zipRecords (\_lbl -> mergeValue' sym c) fs1 fs2 case res of Left f -> panic "Cryptol.Eval.Value" [ "mergeValue: incompatible record values", show f ] Right r -> pure (VRecord r) (VTuple vs1 , VTuple vs2 ) | length vs1 == length vs2 -> pure $ VTuple $ zipWith (mergeValue' sym c) vs1 vs2 (VBit b1 , VBit b2 ) -> VBit <$> iteBit sym c b1 b2 (VInteger i1 , VInteger i2 ) -> VInteger <$> iteInteger sym c i1 i2 (VRational q1, VRational q2) -> VRational <$> iteRational sym c q1 q2 (VFloat f1 , VFloat f2) -> VFloat <$> iteFloat sym c f1 f2 (VWord n1 w1 , VWord n2 w2 ) | n1 == n2 -> VWord n1 <$> mergeWord sym c w1 w2 (VSeq n1 vs1 , VSeq n2 vs2 ) | n1 == n2 -> VSeq n1 <$> memoMap sym (Nat n1) (mergeSeqMapVal sym c vs1 vs2) (VStream vs1 , VStream vs2 ) -> VStream <$> memoMap sym Inf (mergeSeqMapVal sym c vs1 vs2) (f1@VFun{} , f2@VFun{} ) -> lam sym $ \x -> mergeValue' sym c (fromVFun sym f1 x) (fromVFun sym f2 x) (f1@VPoly{} , f2@VPoly{} ) -> tlam sym $ \x -> mergeValue' sym c (fromVPoly sym f1 x) (fromVPoly sym f2 x) (_ , _ ) -> panic "Cryptol.Eval.Value" [ "mergeValue: incompatible values", show v1, show v2 ] {-# INLINE mergeSeqMapVal #-} mergeSeqMapVal :: Backend sym => sym -> SBit sym -> SeqMap sym (GenValue sym)-> SeqMap sym (GenValue sym)-> SeqMap sym (GenValue sym) mergeSeqMapVal sym c x y = indexSeqMap $ \i -> iteValue sym c (lookupSeqMap x i) (lookupSeqMap y i) cryptol-3.0.0/src/Cryptol/Eval/What4.hs0000644000000000000000000006437007346545000016046 0ustar0000000000000000-- | -- Module : Cryptol.Eval.What4 -- Copyright : (c) 2020 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Cryptol.Eval.What4 ( Value , primTable ) where import qualified Control.Exception as X import Control.Concurrent.MVar import Control.Monad (foldM) import Control.Monad.IO.Class import qualified Data.Map as Map import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import Data.Parameterized.Context import Data.Parameterized.TraversableFC import Data.Parameterized.Some import qualified Data.BitVector.Sized as BV import qualified What4.Interface as W4 import qualified What4.SWord as SW import qualified What4.Utils.AbstractDomains as W4 import Cryptol.Backend import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..) ) import Cryptol.Backend.SeqMap import Cryptol.Backend.WordValue import Cryptol.Backend.What4 import Cryptol.Eval.Generic import Cryptol.Eval.Prims import Cryptol.Eval.Type (TValue(..)) import Cryptol.Eval.Value import qualified Cryptol.SHA as SHA import Cryptol.TypeCheck.Solver.InfNat( Nat'(..) ) import Cryptol.Utils.Ident import Cryptol.Utils.Panic import Cryptol.Utils.RecordMap type Value sym = GenValue (What4 sym) -- See also Cryptol.Prims.Eval.primTable primTable :: W4.IsSymExprBuilder sym => What4 sym -> IO EvalOpts -> Map.Map PrimIdent (Prim (What4 sym)) primTable sym getEOpts = Map.union (suiteBPrims sym) $ Map.union (primeECPrims sym) $ Map.union (genericFloatTable sym) $ Map.union (genericPrimTable sym getEOpts) $ Map.fromList $ map (\(n, v) -> (prelPrim n, v)) [ -- Indexing and updates ("@" , indexPrim sym IndexForward (indexFront_int sym) (indexFront_segs sym)) , ("!" , indexPrim sym IndexBackward (indexFront_int sym) (indexFront_segs sym)) , ("update" , updatePrim sym (updateFrontSym_word sym) (updateFrontSym sym)) , ("updateEnd" , updatePrim sym (updateBackSym_word sym) (updateBackSym sym)) ] primeECPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Prim (What4 sym)) primeECPrims sym = Map.fromList $ [ (primeECPrim n, v) | (n,v) <- prims ] where (~>) = (,) prims = [ -- {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p "ec_double" ~> PFinPoly \p -> PFun \s -> PPrim do p' <- integerLit sym p s' <- toProjectivePoint sym =<< s addUninterpWarning sym "Prime ECC" fn <- liftIO $ getUninterpFn sym "ec_double" (Empty :> W4.BaseIntegerRepr :> projectivePointRepr) projectivePointRepr z <- liftIO $ W4.applySymFn (w4 sym) fn (Empty :> p' :> s') fromProjectivePoint sym z -- {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p -> ProjectivePoint p , "ec_add_nonzero" ~> PFinPoly \p -> PFun \s -> PFun \t -> PPrim do p' <- integerLit sym p s' <- toProjectivePoint sym =<< s t' <- toProjectivePoint sym =<< t addUninterpWarning sym "Prime ECC" fn <- liftIO $ getUninterpFn sym "ec_add_nonzero" (Empty :> W4.BaseIntegerRepr :> projectivePointRepr :> projectivePointRepr) projectivePointRepr z <- liftIO $ W4.applySymFn (w4 sym) fn (Empty :> p' :> s' :> t') fromProjectivePoint sym z -- {p} (prime p, p > 3) => Z p -> ProjectivePoint p -> ProjectivePoint p , "ec_mult" ~> PFinPoly \p -> PFun \k -> PFun \s -> PPrim do p' <- integerLit sym p k' <- fromVInteger <$> k s' <- toProjectivePoint sym =<< s addUninterpWarning sym "Prime ECC" fn <- liftIO $ getUninterpFn sym "ec_mult" (Empty :> W4.BaseIntegerRepr :> W4.BaseIntegerRepr :> projectivePointRepr) projectivePointRepr z <- liftIO $ W4.applySymFn (w4 sym) fn (Empty :> p' :> k' :> s') fromProjectivePoint sym z -- {p} (prime p, p > 3) => Z p -> ProjectivePoint p -> Z p -> ProjectivePoint p -> ProjectivePoint p , "ec_twin_mult" ~> PFinPoly \p -> PFun \j -> PFun \s -> PFun \k -> PFun \t -> PPrim do p' <- integerLit sym p j' <- fromVInteger <$> j s' <- toProjectivePoint sym =<< s k' <- fromVInteger <$> k t' <- toProjectivePoint sym =<< t addUninterpWarning sym "Prime ECC" fn <- liftIO $ getUninterpFn sym "ec_twin_mult" (Empty :> W4.BaseIntegerRepr :> W4.BaseIntegerRepr :> projectivePointRepr :> W4.BaseIntegerRepr :> projectivePointRepr) projectivePointRepr z <- liftIO $ W4.applySymFn (w4 sym) fn (Empty :> p' :> j' :> s' :> k' :> t') fromProjectivePoint sym z ] type ProjectivePoint = W4.BaseStructType (EmptyCtx ::> W4.BaseIntegerType ::> W4.BaseIntegerType ::> W4.BaseIntegerType) projectivePointRepr :: W4.BaseTypeRepr ProjectivePoint projectivePointRepr = W4.knownRepr toProjectivePoint :: W4.IsSymExprBuilder sym => What4 sym -> Value sym -> SEval (What4 sym) (W4.SymExpr sym ProjectivePoint) toProjectivePoint sym v = do x <- fromVInteger <$> lookupRecord "x" v y <- fromVInteger <$> lookupRecord "y" v z <- fromVInteger <$> lookupRecord "z" v liftIO $ W4.mkStruct (w4 sym) (Empty :> x :> y :> z) fromProjectivePoint :: W4.IsSymExprBuilder sym => What4 sym -> W4.SymExpr sym ProjectivePoint -> SEval (What4 sym) (Value sym) fromProjectivePoint sym p = liftIO $ do x <- VInteger <$> W4.structField (w4 sym) p (natIndex @0) y <- VInteger <$> W4.structField (w4 sym) p (natIndex @1) z <- VInteger <$> W4.structField (w4 sym) p (natIndex @2) pure $ VRecord $ recordFromFields [ (packIdent "x",pure x), (packIdent "y",pure y),(packIdent "z",pure z) ] suiteBPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Prim (What4 sym)) suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ] where (~>) = (,) prims = [ "AESEncRound" ~> PFun \st -> PPrim do addUninterpWarning sym "AES encryption" applyAESStateFunc sym "AESEncRound" =<< st , "AESEncFinalRound" ~> PFun \st -> PPrim do addUninterpWarning sym "AES encryption" applyAESStateFunc sym "AESEncFinalRound" =<< st , "AESDecRound" ~> PFun \st -> PPrim do addUninterpWarning sym "AES decryption" applyAESStateFunc sym "AESDecRound" =<< st , "AESDecFinalRound" ~> PFun \st -> PPrim do addUninterpWarning sym "AES decryption" applyAESStateFunc sym "AESDecFinalRound" =<< st , "AESInvMixColumns" ~> PFun \st -> PPrim do addUninterpWarning sym "AES key expansion" applyAESStateFunc sym "AESInvMixColumns" =<< st -- {k} (fin k, k >= 4, 8 >= k) => [k][32] -> [4*(k+7)][32] , "AESKeyExpand" ~> PFinPoly \k -> PFun \st -> PPrim do ss <- fromVSeq <$> st -- pack the arguments into a k-tuple of 32-bit values Some ws <- generateSomeM (fromInteger k) (\i -> Some <$> toWord32 sym "AESKeyExpand" ss (toInteger i)) -- get the types of the arguments let args = fmapFC W4.exprType ws -- compute the return type which is a tuple of @4*(k+7)@ 32-bit values Some ret <- pure $ generateSome (4*(fromInteger k + 7)) (\_ -> Some (W4.BaseBVRepr (W4.knownNat @32))) -- retrieve the relevant uninterpreted function and apply it to the arguments addUninterpWarning sym "AES key expansion" fn <- liftIO $ getUninterpFn sym ("AESKeyExpand" <> Text.pack (show k)) args (W4.BaseStructRepr ret) z <- liftIO $ W4.applySymFn (w4 sym) fn ws -- compute a sequence that projects the relevant fields from the outout tuple pure $ VSeq (4*(k+7)) $ indexSeqMap $ \i -> case intIndex (fromInteger i) (size ret) of Just (Some idx) | Just W4.Refl <- W4.testEquality (ret!idx) (W4.BaseBVRepr (W4.knownNat @32)) -> fromWord32 =<< liftIO (W4.structField (w4 sym) z idx) _ -> evalPanic "AESKeyExpand" ["Index out of range", show k, show i] -- {n} (fin n) => [n][16][32] -> [7][32] , "processSHA2_224" ~> PFinPoly \n -> PFun \xs -> PPrim do blks <- enumerateSeqMap n . fromVSeq <$> xs addUninterpWarning sym "SHA-224" initSt <- liftIO (mkSHA256InitialState sym SHA.initialSHA224State) finalSt <- foldM (\st blk -> processSHA256Block sym st =<< blk) initSt blks pure $ VSeq 7 $ indexSeqMap \i -> case intIndex (fromInteger i) (knownSize :: Size SHA256State) of Just (Some idx) -> do z <- liftIO $ W4.structField (w4 sym) finalSt idx case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @32)) of Just W4.Refl -> fromWord32 z Nothing -> evalPanic "processSHA2_224" ["Index out of range", show i] Nothing -> evalPanic "processSHA2_224" ["Index out of range", show i] -- {n} (fin n) => [n][16][32] -> [8][32] , "processSHA2_256" ~> PFinPoly \n -> PFun \xs -> PPrim do blks <- enumerateSeqMap n . fromVSeq <$> xs addUninterpWarning sym "SHA-256" initSt <- liftIO (mkSHA256InitialState sym SHA.initialSHA256State) finalSt <- foldM (\st blk -> processSHA256Block sym st =<< blk) initSt blks pure $ VSeq 8 $ indexSeqMap \i -> case intIndex (fromInteger i) (knownSize :: Size SHA256State) of Just (Some idx) -> do z <- liftIO $ W4.structField (w4 sym) finalSt idx case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @32)) of Just W4.Refl -> fromWord32 z Nothing -> evalPanic "processSHA2_256" ["Index out of range", show i] Nothing -> evalPanic "processSHA2_256" ["Index out of range", show i] -- {n} (fin n) => [n][16][64] -> [6][64] , "processSHA2_384" ~> PFinPoly \n -> PFun \xs -> PPrim do blks <- enumerateSeqMap n . fromVSeq <$> xs addUninterpWarning sym "SHA-384" initSt <- liftIO (mkSHA512InitialState sym SHA.initialSHA384State) finalSt <- foldM (\st blk -> processSHA512Block sym st =<< blk) initSt blks pure $ VSeq 6 $ indexSeqMap \i -> case intIndex (fromInteger i) (knownSize :: Size SHA512State) of Just (Some idx) -> do z <- liftIO $ W4.structField (w4 sym) finalSt idx case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @64)) of Just W4.Refl -> fromWord64 z Nothing -> evalPanic "processSHA2_384" ["Index out of range", show i] Nothing -> evalPanic "processSHA2_384" ["Index out of range", show i] -- {n} (fin n) => [n][16][64] -> [8][64] , "processSHA2_512" ~> PFinPoly \n -> PFun \xs -> PPrim do blks <- enumerateSeqMap n . fromVSeq <$> xs addUninterpWarning sym "SHA-512" initSt <- liftIO (mkSHA512InitialState sym SHA.initialSHA512State) finalSt <- foldM (\st blk -> processSHA512Block sym st =<< blk) initSt blks pure $ VSeq 8 $ indexSeqMap \i -> case intIndex (fromInteger i) (knownSize :: Size SHA512State) of Just (Some idx) -> do z <- liftIO $ W4.structField (w4 sym) finalSt idx case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @64)) of Just W4.Refl -> fromWord64 z Nothing -> evalPanic "processSHA2_512" ["Index out of range", show i] Nothing -> evalPanic "processSHA2_512" ["Index out of range", show i] ] type SHA256State = EmptyCtx ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 type SHA512State = EmptyCtx ::> W4.BaseBVType 64 ::> W4.BaseBVType 64 ::> W4.BaseBVType 64 ::> W4.BaseBVType 64 ::> W4.BaseBVType 64 ::> W4.BaseBVType 64 ::> W4.BaseBVType 64 ::> W4.BaseBVType 64 mkSHA256InitialState :: W4.IsSymExprBuilder sym => What4 sym -> SHA.SHA256State -> IO (W4.SymExpr sym (W4.BaseStructType SHA256State)) mkSHA256InitialState sym (SHA.SHA256S s0 s1 s2 s3 s4 s5 s6 s7) = do z0 <- lit s0 z1 <- lit s1 z2 <- lit s2 z3 <- lit s3 z4 <- lit s4 z5 <- lit s5 z6 <- lit s6 z7 <- lit s7 W4.mkStruct (w4 sym) (Empty :> z0 :> z1 :> z2 :> z3 :> z4 :> z5 :> z6 :> z7) where lit w = W4.bvLit (w4 sym) (W4.knownNat @32) (BV.word32 w) mkSHA512InitialState :: W4.IsSymExprBuilder sym => What4 sym -> SHA.SHA512State -> IO (W4.SymExpr sym (W4.BaseStructType SHA512State)) mkSHA512InitialState sym (SHA.SHA512S s0 s1 s2 s3 s4 s5 s6 s7) = do z0 <- lit s0 z1 <- lit s1 z2 <- lit s2 z3 <- lit s3 z4 <- lit s4 z5 <- lit s5 z6 <- lit s6 z7 <- lit s7 W4.mkStruct (w4 sym) (Empty :> z0 :> z1 :> z2 :> z3 :> z4 :> z5 :> z6 :> z7) where lit w = W4.bvLit (w4 sym) (W4.knownNat @64) (BV.word64 w) processSHA256Block :: W4.IsSymExprBuilder sym => What4 sym -> W4.SymExpr sym (W4.BaseStructType SHA256State) -> Value sym -> SEval (What4 sym) (W4.SymExpr sym (W4.BaseStructType SHA256State)) processSHA256Block sym st blk = do let ss = fromVSeq blk b0 <- toWord32 sym "processSHA256Block" ss 0 b1 <- toWord32 sym "processSHA256Block" ss 1 b2 <- toWord32 sym "processSHA256Block" ss 2 b3 <- toWord32 sym "processSHA256Block" ss 3 b4 <- toWord32 sym "processSHA256Block" ss 4 b5 <- toWord32 sym "processSHA256Block" ss 5 b6 <- toWord32 sym "processSHA256Block" ss 6 b7 <- toWord32 sym "processSHA256Block" ss 7 b8 <- toWord32 sym "processSHA256Block" ss 8 b9 <- toWord32 sym "processSHA256Block" ss 9 b10 <- toWord32 sym "processSHA256Block" ss 10 b11 <- toWord32 sym "processSHA256Block" ss 11 b12 <- toWord32 sym "processSHA256Block" ss 12 b13 <- toWord32 sym "processSHA256Block" ss 13 b14 <- toWord32 sym "processSHA256Block" ss 14 b15 <- toWord32 sym "processSHA256Block" ss 15 let args = Empty :> st :> b0 :> b1 :> b2 :> b3 :> b4 :> b5 :> b6 :> b7 :> b8 :> b9 :> b10 :> b11 :> b12 :> b13 :> b14 :> b15 let ret = W4.exprType st fn <- liftIO $ getUninterpFn sym "processSHA256Block" (fmapFC W4.exprType args) ret liftIO $ W4.applySymFn (w4 sym) fn args processSHA512Block :: W4.IsSymExprBuilder sym => What4 sym -> W4.SymExpr sym (W4.BaseStructType SHA512State) -> Value sym -> SEval (What4 sym) (W4.SymExpr sym (W4.BaseStructType SHA512State)) processSHA512Block sym st blk = do let ss = fromVSeq blk b0 <- toWord64 sym "processSHA512Block" ss 0 b1 <- toWord64 sym "processSHA512Block" ss 1 b2 <- toWord64 sym "processSHA512Block" ss 2 b3 <- toWord64 sym "processSHA512Block" ss 3 b4 <- toWord64 sym "processSHA512Block" ss 4 b5 <- toWord64 sym "processSHA512Block" ss 5 b6 <- toWord64 sym "processSHA512Block" ss 6 b7 <- toWord64 sym "processSHA512Block" ss 7 b8 <- toWord64 sym "processSHA512Block" ss 8 b9 <- toWord64 sym "processSHA512Block" ss 9 b10 <- toWord64 sym "processSHA512Block" ss 10 b11 <- toWord64 sym "processSHA512Block" ss 11 b12 <- toWord64 sym "processSHA512Block" ss 12 b13 <- toWord64 sym "processSHA512Block" ss 13 b14 <- toWord64 sym "processSHA512Block" ss 14 b15 <- toWord64 sym "processSHA512Block" ss 15 let args = Empty :> st :> b0 :> b1 :> b2 :> b3 :> b4 :> b5 :> b6 :> b7 :> b8 :> b9 :> b10 :> b11 :> b12 :> b13 :> b14 :> b15 let ret = W4.exprType st fn <- liftIO $ getUninterpFn sym "processSHA512Block" (fmapFC W4.exprType args) ret liftIO $ W4.applySymFn (w4 sym) fn args addUninterpWarning :: MonadIO m => What4 sym -> Text -> m () addUninterpWarning sym nm = liftIO (modifyMVar_ (w4uninterpWarns sym) (pure . Set.insert nm)) -- | Retrieve the named uninterpreted function, with the given argument types and -- return type, from a cache. Create a fresh function if it has not previously -- been requested. A particular named function is required to be used with -- consistent types every time it is requested; otherwise this function will panic. getUninterpFn :: W4.IsSymExprBuilder sym => What4 sym -> Text {- ^ Function name -} -> Assignment W4.BaseTypeRepr args {- ^ function argument types -} -> W4.BaseTypeRepr ret {- ^ function return type -} -> IO (W4.SymFn sym args ret) getUninterpFn sym funNm args ret = modifyMVar (w4funs sym) $ \m -> case Map.lookup funNm m of Nothing -> do fn <- W4.freshTotalUninterpFn (w4 sym) (W4.safeSymbol (Text.unpack funNm)) args ret let m' = Map.insert funNm (SomeSymFn fn) m return (m', fn) Just (SomeSymFn fn) | Just W4.Refl <- W4.testEquality args (W4.fnArgTypes fn) , Just W4.Refl <- W4.testEquality ret (W4.fnReturnType fn) -> return (m, fn) | otherwise -> panic "getUninterpFn" [ "Function" ++ show funNm ++ "used at incompatible types" , "Created with types:" , show (W4.fnArgTypes fn) ++ " -> " ++ show (W4.fnReturnType fn) , "Requested at types:" , show args ++ " -> " ++ show ret ] toWord32 :: W4.IsSymExprBuilder sym => What4 sym -> String -> SeqMap (What4 sym) (GenValue (What4 sym)) -> Integer -> SEval (What4 sym) (W4.SymBV sym 32) toWord32 sym nm ss i = do x <- fromVWord sym nm =<< lookupSeqMap ss i case x of SW.DBV x' | Just W4.Refl <- W4.testEquality (W4.bvWidth x') (W4.knownNat @32) -> pure x' _ -> panic nm ["Unexpected word size", show (SW.bvWidth x)] fromWord32 :: W4.IsSymExprBuilder sym => W4.SymBV sym 32 -> SEval (What4 sym) (Value sym) fromWord32 = pure . VWord 32 . wordVal . SW.DBV toWord64 :: W4.IsSymExprBuilder sym => What4 sym -> String -> SeqMap (What4 sym) (GenValue (What4 sym)) -> Integer -> SEval (What4 sym) (W4.SymBV sym 64) toWord64 sym nm ss i = do x <- fromVWord sym nm =<< lookupSeqMap ss i case x of SW.DBV x' | Just W4.Refl <- W4.testEquality (W4.bvWidth x') (W4.knownNat @64) -> pure x' _ -> panic nm ["Unexpected word size", show (SW.bvWidth x)] fromWord64 :: W4.IsSymExprBuilder sym => W4.SymBV sym 64 -> SEval (What4 sym) (Value sym) fromWord64 = pure . VWord 64 . wordVal . SW.DBV -- | Apply the named uninterpreted function to a sequence of @[4][32]@ values, -- and return a sequence of @[4][32]@ values. This shape of function is used -- for most of the SuiteB AES primitives. applyAESStateFunc :: forall sym. W4.IsSymExprBuilder sym => What4 sym -> Text -> Value sym -> SEval (What4 sym) (Value sym) applyAESStateFunc sym funNm x = do let ss = fromVSeq x w0 <- toWord32 sym nm ss 0 w1 <- toWord32 sym nm ss 1 w2 <- toWord32 sym nm ss 2 w3 <- toWord32 sym nm ss 3 fn <- liftIO $ getUninterpFn sym funNm argCtx (W4.BaseStructRepr argCtx) z <- liftIO $ W4.applySymFn (w4 sym) fn (Empty :> w0 :> w1 :> w2 :> w3) pure $ VSeq 4 $ indexSeqMap \i -> if | i == 0 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @0)) | i == 1 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @1)) | i == 2 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @2)) | i == 3 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @3)) | otherwise -> evalPanic "applyAESStateFunc" ["Index out of range", show funNm, show i] where nm = Text.unpack funNm argCtx :: Assignment W4.BaseTypeRepr (EmptyCtx ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32) argCtx = W4.knownRepr indexFront_int :: W4.IsSymExprBuilder sym => What4 sym -> Nat' -> TValue -> SeqMap (What4 sym) (GenValue (What4 sym)) -> TValue -> SInteger (What4 sym) -> SEval (What4 sym) (Value sym) indexFront_int sym mblen _a xs _ix idx | Just i <- W4.asInteger idx = lookupSeqMap xs i | (lo, Just hi) <- bounds = case foldr f Nothing [lo .. hi] of Nothing -> raiseError sym (InvalidIndex Nothing) Just m -> m | otherwise = liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer indexing")) where w4sym = w4 sym f n (Just y) = Just $ do p <- liftIO (W4.intEq w4sym idx =<< W4.intLit w4sym n) iteValue sym p (lookupSeqMap xs n) y f n Nothing = Just $ lookupSeqMap xs n bounds = (case W4.rangeLowBound (W4.integerBounds idx) of W4.Inclusive l -> max l 0 _ -> 0 , case (maxIdx, W4.rangeHiBound (W4.integerBounds idx)) of (Just n, W4.Inclusive h) -> Just (min n h) (Just n, _) -> Just n _ -> Nothing ) -- Maximum possible in-bounds index given the length -- of the sequence. If the sequence is infinite, there -- isn't much we can do. maxIdx = case mblen of Nat n -> Just (n - 1) Inf -> Nothing indexFront_segs :: W4.IsSymExprBuilder sym => What4 sym -> Nat' -> TValue -> SeqMap (What4 sym) (GenValue (What4 sym)) -> TValue -> Integer -> [IndexSegment (What4 sym)] -> SEval (What4 sym) (Value sym) indexFront_segs sym mblen _a xs _ix _idx_bits [WordIndexSegment idx] | Just i <- SW.bvAsUnsignedInteger idx = lookupSeqMap xs i | otherwise = case foldr f Nothing idxs of Nothing -> raiseError sym (InvalidIndex Nothing) Just m -> m where w4sym = w4 sym w = SW.bvWidth idx f n (Just y) = Just $ do p <- liftIO (SW.bvEq w4sym idx =<< SW.bvLit w4sym w n) iteValue sym p (lookupSeqMap xs n) y f n Nothing = Just $ lookupSeqMap xs n -- maximum possible in-bounds index given the bitwidth -- of the index value and the length of the sequence maxIdx = case mblen of Nat n | n < 2^w -> n-1 _ -> 2^w - 1 -- concrete indices to consider, intersection of the -- range of values the index value might take with -- the legal values idxs = case SW.unsignedBVBounds idx of Just (lo, hi) -> [lo .. min hi maxIdx] _ -> [0 .. maxIdx] indexFront_segs sym mblen _a xs _ix idx_bits segs = do xs' <- barrelShifter sym (mergeValue sym) shiftOp mblen xs idx_bits segs lookupSeqMap xs' 0 where shiftOp vs amt = pure (indexSeqMap (\i -> lookupSeqMap vs $! amt+i)) updateFrontSym :: W4.IsSymExprBuilder sym => What4 sym -> Nat' -> TValue -> SeqMap (What4 sym) (GenValue (What4 sym)) -> Either (SInteger (What4 sym)) (WordValue (What4 sym)) -> SEval (What4 sym) (Value sym) -> SEval (What4 sym) (SeqMap (What4 sym) (GenValue (What4 sym))) updateFrontSym sym _len _eltTy vs (Left idx) val = case W4.asInteger idx of Just i -> return $ updateSeqMap vs i val Nothing -> return $ indexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym i iteValue sym b val (lookupSeqMap vs i) updateFrontSym sym len _eltTy vs (Right wv) val = wordValAsLit sym wv >>= \case Just j -> return $ updateSeqMap vs j val Nothing -> memoMap sym len $ indexSeqMap $ \i -> do b <- wordValueEqualsInteger sym wv i iteValue sym b val (lookupSeqMap vs i) updateBackSym :: W4.IsSymExprBuilder sym => What4 sym -> Nat' -> TValue -> SeqMap (What4 sym) (GenValue (What4 sym)) -> Either (SInteger (What4 sym)) (WordValue (What4 sym)) -> SEval (What4 sym) (Value sym) -> SEval (What4 sym) (SeqMap (What4 sym) (GenValue (What4 sym))) updateBackSym _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"] updateBackSym sym (Nat n) _eltTy vs (Left idx) val = case W4.asInteger idx of Just i -> return $ updateSeqMap vs (n - 1 - i) val Nothing -> return $ indexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) updateBackSym sym (Nat n) _eltTy vs (Right wv) val = wordValAsLit sym wv >>= \case Just j -> return $ updateSeqMap vs (n - 1 - j) val Nothing -> memoMap sym (Nat n) $ indexSeqMap $ \i -> do b <- wordValueEqualsInteger sym wv (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) updateFrontSym_word :: W4.IsSymExprBuilder sym => What4 sym -> Nat' -> TValue -> WordValue (What4 sym) -> Either (SInteger (What4 sym)) (WordValue (What4 sym)) -> SEval (What4 sym) (GenValue (What4 sym)) -> SEval (What4 sym) (WordValue (What4 sym)) updateFrontSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_word"] updateFrontSym_word sym (Nat n) _eltTy w (Left idx) val = do idx' <- wordFromInt sym n idx updateWordByWord sym IndexForward w (wordVal idx') (fromVBit <$> val) updateFrontSym_word sym (Nat _n) _eltTy w (Right idx) val = updateWordByWord sym IndexForward w idx (fromVBit <$> val) updateBackSym_word :: W4.IsSymExprBuilder sym => What4 sym -> Nat' -> TValue -> WordValue (What4 sym) -> Either (SInteger (What4 sym)) (WordValue (What4 sym)) -> SEval (What4 sym) (GenValue (What4 sym)) -> SEval (What4 sym) (WordValue (What4 sym)) updateBackSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_word"] updateBackSym_word sym (Nat n) _eltTy w (Left idx) val = do idx' <- wordFromInt sym n idx updateWordByWord sym IndexBackward w (wordVal idx') (fromVBit <$> val) updateBackSym_word sym (Nat _n) _eltTy w (Right idx) val = updateWordByWord sym IndexBackward w idx (fromVBit <$> val) cryptol-3.0.0/src/Cryptol/F2.hs0000644000000000000000000000257107346545000014432 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} module Cryptol.F2 where import Data.Bits import Cryptol.TypeCheck.Solver.InfNat (widthInteger) pmult :: Int -> Integer -> Integer -> Integer pmult w x y = go (w-1) 0 where go !i !z | i >= 0 = go (i-1) (if testBit x i then (z `shiftL` 1) `xor` y else (z `shiftL` 1)) | otherwise = z pdiv :: Int -> Integer -> Integer -> Integer pdiv w x m = go (w-1) 0 0 where degree :: Int degree = fromInteger (widthInteger m - 1) reduce :: Integer -> Integer reduce u = if testBit u degree then u `xor` m else u {-# INLINE reduce #-} go !i !z !r | i >= 0 = go (i-1) z' r' | otherwise = r where zred = reduce z z' = if testBit x i then (zred `shiftL` 1) .|. 1 else zred `shiftL` 1 r' = if testBit z' degree then (r `shiftL` 1) .|. 1 else r `shiftL` 1 pmod :: Int -> Integer -> Integer -> Integer pmod w x m = go degree (x .&. mask) (clearBit m degree) where degree :: Int degree = fromInteger (widthInteger m - 1) reduce :: Integer -> Integer reduce u = if testBit u degree then u `xor` m else u {-# INLINE reduce #-} mask = bit degree - 1 -- invariant: z and p are in the range [0..mask] go !i !z !p | i < w = go (i+1) (if testBit x i then z `xor` p else z) (reduce (p `shiftL` 1)) | otherwise = z cryptol-3.0.0/src/Cryptol/IR/0000755000000000000000000000000007346545000014134 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/IR/FreeVars.hs0000644000000000000000000001253207346545000016210 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 Cryptol.TypeCheck.AST import Cryptol.Utils.RecordMap 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 = (<>) 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 DForeign _ -> mempty DExpr e -> freeVars e instance FreeVars Expr where freeVars expr = case expr of ELocated _r t -> freeVars t EList es t -> freeVars es <> freeVars t ETuple es -> freeVars es ERec fs -> freeVars (recordElements fs) ESel e _ -> freeVars e ESet ty e _ v -> freeVars ty <> 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 foldFree mss) 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 -> foldFree ds <> rmVals (defs ds) (freeVars e) EPropGuards guards _ -> mconcat [ freeVars e | (_, e) <- guards ] where foldFree :: (FreeVars a, Defs a) => [a] -> Deps foldFree = foldr updateFree mempty updateFree x rest = freeVars x <> rmVals (defs x) rest 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 (recordElements fs) TNewtype nt ts -> freeVars nt <> freeVars ts instance FreeVars TVar where freeVars tv = case tv of TVBound p -> mempty { tyParams = Set.singleton p } _ -> mempty instance FreeVars TCon where freeVars _tc = mempty instance FreeVars Newtype where freeVars nt = foldr rmTParam base (ntParams nt) where base = freeVars (ntConstraints nt) <> freeVars (recordElements (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-3.0.0/src/Cryptol/IR/TraverseNames.hs0000644000000000000000000002427007346545000017254 0ustar0000000000000000{-# Language ImplicitParams #-} module Cryptol.IR.TraverseNames where import Data.Set(Set) import qualified Data.Set as Set import Data.Functor.Identity import Cryptol.ModuleSystem.Name(nameUnique) import Cryptol.Utils.RecordMap(traverseRecordMap) import Cryptol.Parser.Position(Located(..)) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.FFI.FFIType traverseNames :: (TraverseNames t, Applicative f) => (Name -> f Name) -> (t -> f t) traverseNames f = let ?name = f in traverseNamesIP mapNames :: (TraverseNames t) => (Name -> Name) -> t -> t mapNames f x = result where Identity result = let ?name = pure . f in traverseNamesIP x class TraverseNames t where traverseNamesIP :: (Applicative f, ?name :: Name -> f Name) => t -> f t instance TraverseNames a => TraverseNames [a] where traverseNamesIP = traverse traverseNamesIP instance TraverseNames a => TraverseNames (Maybe a) where traverseNamesIP = traverse traverseNamesIP instance (Ord a, TraverseNames a) => TraverseNames (Set a) where traverseNamesIP = fmap Set.fromList . traverseNamesIP . Set.toList instance TraverseNames a => TraverseNames (Located a) where traverseNamesIP (Located r a) = Located r <$> traverseNamesIP a instance TraverseNames Name where traverseNamesIP = ?name instance (Ord a, TraverseNames a) => TraverseNames (ExportSpec a) where traverseNamesIP (ExportSpec mp) = ExportSpec <$> traverse traverseNamesIP mp instance TraverseNames Expr where traverseNamesIP expr = case expr of EList es t -> EList <$> traverseNamesIP es <*> traverseNamesIP t ETuple es -> ETuple <$> traverseNamesIP es ERec mp -> ERec <$> traverseRecordMap (\_ -> traverseNamesIP) mp ESel e l -> (`ESel` l) <$> traverseNamesIP e ESet t e1 l e2 -> ESet <$> traverseNamesIP t <*> traverseNamesIP e1 <*> pure l <*> traverseNamesIP e2 EIf e1 e2 e3 -> EIf <$> traverseNamesIP e1 <*> traverseNamesIP e2 <*> traverseNamesIP e3 EComp t1 t2 e mss -> EComp <$> traverseNamesIP t1 <*> traverseNamesIP t2 <*> traverseNamesIP e <*> traverseNamesIP mss EVar x -> EVar <$> traverseNamesIP x ETAbs tp e -> ETAbs <$> traverseNamesIP tp <*> traverseNamesIP e ETApp e t -> ETApp <$> traverseNamesIP e <*> traverseNamesIP t EApp e1 e2 -> EApp <$> traverseNamesIP e1 <*> traverseNamesIP e2 EAbs x t e -> EAbs <$> traverseNamesIP x <*> traverseNamesIP t <*> traverseNamesIP e ELocated r e -> ELocated r <$> traverseNamesIP e EProofAbs p e -> EProofAbs <$> traverseNamesIP p <*> traverseNamesIP e EProofApp e -> EProofApp <$> traverseNamesIP e EWhere e ds -> EWhere <$> traverseNamesIP e <*> traverseNamesIP ds EPropGuards gs t -> EPropGuards <$> traverse doG gs <*> traverseNamesIP t where doG (xs, e) = (,) <$> traverseNamesIP xs <*> traverseNamesIP e instance TraverseNames Match where traverseNamesIP mat = case mat of From x t1 t2 e -> From <$> traverseNamesIP x <*> traverseNamesIP t1 <*> traverseNamesIP t2 <*> traverseNamesIP e Let d -> Let <$> traverseNamesIP d instance TraverseNames DeclGroup where traverseNamesIP dg = case dg of NonRecursive d -> NonRecursive <$> traverseNamesIP d Recursive ds -> Recursive <$> traverseNamesIP ds instance TraverseNames Decl where traverseNamesIP decl = mk <$> traverseNamesIP (dName decl) <*> traverseNamesIP (dSignature decl) <*> traverseNamesIP (dDefinition decl) where mk nm sig def = decl { dName = nm , dSignature = sig , dDefinition = def } instance TraverseNames DeclDef where traverseNamesIP d = case d of DPrim -> pure d DForeign t -> DForeign <$> traverseNamesIP t DExpr e -> DExpr <$> traverseNamesIP e instance TraverseNames Schema where traverseNamesIP (Forall as ps t) = Forall <$> traverseNamesIP as <*> traverseNamesIP ps <*> traverseNamesIP t instance TraverseNames TParam where traverseNamesIP tp = mk <$> traverseNamesIP (tpFlav tp) <*> traverseNamesIP (tpInfo tp) -- XXX: module parameters should probably be represented directly -- as (abstract) user-defined types, rather than type variables. where mk f i = case f of TPModParam x -> tp { tpUnique = nameUnique x, tpFlav = f, tpInfo = i } _ -> tp { tpFlav = f, tpInfo = i } instance TraverseNames TPFlavor where traverseNamesIP tpf = case tpf of TPModParam x -> TPModParam <$> traverseNamesIP x TPUnifyVar -> pure tpf TPSchemaParam x -> TPSchemaParam <$> traverseNamesIP x TPTySynParam x -> TPTySynParam <$> traverseNamesIP x TPPropSynParam x -> TPPropSynParam <$> traverseNamesIP x TPNewtypeParam x -> TPNewtypeParam <$> traverseNamesIP x TPPrimParam x -> TPPrimParam <$> traverseNamesIP x instance TraverseNames TVarInfo where traverseNamesIP (TVarInfo r s) = TVarInfo r <$> traverseNamesIP s instance TraverseNames TypeSource where traverseNamesIP src = case src of TVFromModParam x -> TVFromModParam <$> traverseNamesIP x TVFromSignature x -> TVFromSignature <$> traverseNamesIP x TypeWildCard -> pure src TypeOfRecordField {} -> pure src TypeOfTupleField {} -> pure src TypeOfSeqElement -> pure src LenOfSeq -> pure src TypeParamInstNamed x i -> TypeParamInstNamed <$> traverseNamesIP x <*> pure i TypeParamInstPos x i -> TypeParamInstPos <$> traverseNamesIP x <*> pure i DefinitionOf x -> DefinitionOf <$> traverseNamesIP x LenOfCompGen -> pure src TypeOfArg arg -> TypeOfArg <$> traverseNamesIP arg TypeOfRes -> pure src FunApp -> pure src TypeOfIfCondExpr -> pure src TypeFromUserAnnotation -> pure src GeneratorOfListComp -> pure src TypeErrorPlaceHolder -> pure src instance TraverseNames ArgDescr where traverseNamesIP arg = mk <$> traverseNamesIP (argDescrFun arg) where mk n = arg { argDescrFun = n } instance TraverseNames Type where traverseNamesIP ty = case ty of TCon tc ts -> TCon <$> traverseNamesIP tc <*> traverseNamesIP ts TVar x -> TVar <$> traverseNamesIP x TUser x ts t -> TUser <$> traverseNamesIP x <*> traverseNamesIP ts <*> traverseNamesIP t TRec rm -> TRec <$> traverseRecordMap (\_ -> traverseNamesIP) rm TNewtype nt ts -> TNewtype <$> traverseNamesIP nt <*> traverseNamesIP ts instance TraverseNames TCon where traverseNamesIP tcon = case tcon of TC tc -> TC <$> traverseNamesIP tc _ -> pure tcon instance TraverseNames TC where traverseNamesIP tc = case tc of TCAbstract ut -> TCAbstract <$> traverseNamesIP ut _ -> pure tc instance TraverseNames UserTC where traverseNamesIP (UserTC x k) = UserTC <$> traverseNamesIP x <*> pure k instance TraverseNames TVar where traverseNamesIP tvar = case tvar of TVFree x k ys i -> TVFree x k <$> traverseNamesIP ys <*> traverseNamesIP i TVBound x -> TVBound <$> traverseNamesIP x instance TraverseNames Newtype where traverseNamesIP nt = mk <$> traverseNamesIP (ntName nt) <*> traverseNamesIP (ntParams nt) <*> traverseNamesIP (ntConstraints nt) <*> traverseNamesIP (ntConName nt) <*> traverseRecordMap (\_ -> traverseNamesIP) (ntFields nt) where mk a b c d e = nt { ntName = a , ntParams = b , ntConstraints = c , ntConName = d , ntFields = e } instance TraverseNames ModTParam where traverseNamesIP nt = mk <$> traverseNamesIP (mtpName nt) where mk x = nt { mtpName = x } instance TraverseNames ModVParam where traverseNamesIP nt = mk <$> traverseNamesIP (mvpName nt) <*> traverseNamesIP (mvpType nt) where mk x t = nt { mvpName = x, mvpType = t } instance TraverseNames FFIFunType where traverseNamesIP fi = mk <$> traverseNamesIP (ffiArgTypes fi) <*> traverseNamesIP (ffiRetType fi) where mk as b = FFIFunType { ffiTParams = ffiTParams fi , ffiArgTypes = as , ffiRetType = b } instance TraverseNames FFIType where traverseNamesIP ft = case ft of FFIBool -> pure ft FFIBasic _ -> pure ft -- assumes no names here FFIArray sz t -> (`FFIArray` t) <$> traverseNamesIP sz FFITuple ts -> FFITuple <$> traverseNamesIP ts FFIRecord mp -> FFIRecord <$> traverseRecordMap (\_ -> traverseNamesIP) mp instance TraverseNames TySyn where traverseNamesIP ts = mk <$> traverseNamesIP (tsName ts) <*> traverseNamesIP (tsParams ts) <*> traverseNamesIP (tsConstraints ts) <*> traverseNamesIP (tsDef ts) where mk n ps cs t = TySyn { tsName = n , tsParams = ps , tsConstraints = cs , tsDef = t , tsDoc = tsDoc ts } cryptol-3.0.0/src/Cryptol/ModuleSystem.hs0000644000000000000000000001314007346545000016607 0ustar0000000000000000-- | -- Module : Cryptol.ModuleSystem -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BlockArguments #-} module Cryptol.ModuleSystem ( -- * Module System ModuleEnv(..), initialModuleEnv , DynamicEnv(..) , ModuleError(..), ModuleWarning(..) , ModuleCmd, ModuleRes , ModuleInput(..) , findModule , loadModuleByPath , loadModuleByName , checkModuleByPath , checkExpr , evalExpr , benchmarkExpr , checkDecls , evalDecls , noPat , focusedEnv , getPrimMap , renameVar , renameType -- * Interfaces , Iface, IfaceG(..), IfaceDecls(..), T.genIface, IfaceDecl(..) -- * Dependencies , getFileDependencies , getModuleDependencies ) where import Data.Map (Map) import qualified Cryptol.Eval.Concrete as Concrete 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.TypeCheck.Interface as T import Cryptol.Utils.Benchmark (BenchmarkStats) import qualified Cryptol.Utils.Ident as M -- Public Interface ------------------------------------------------------------ type ModuleCmd a = ModuleInput IO -> 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.TCTopEntity) loadModuleByPath path minp = do moduleEnv' <- resetModuleEnv $ minpModuleEnv minp runModuleM minp{ minpModuleEnv = moduleEnv' } $ do unloadModule ((InFile path ==) . lmFilePath) m <- Base.loadModuleByPath True path setFocusedModule (T.tcTopEntitytName m) return (InFile path,m) -- | Load the given parsed module. loadModuleByName :: P.ModName -> ModuleCmd (ModulePath,T.TCTopEntity) loadModuleByName n minp = do moduleEnv' <- resetModuleEnv $ minpModuleEnv minp runModuleM minp{ minpModuleEnv = moduleEnv' } $ do unloadModule ((n ==) . lmName) (path,m') <- Base.loadModuleFrom False (FromModule n) setFocusedModule (T.tcTopEntitytName m') return (path,m') -- | Parse and typecheck a module, but don't evaluate or change the environment. checkModuleByPath :: FilePath -> ModuleCmd (ModulePath, T.TCTopEntity) checkModuleByPath path minp = do (res, warns) <- runModuleM minp $ Base.loadModuleByPath False path -- restore the old environment let res1 = do (x,_newEnv) <- res pure ((InFile path, x), minpModuleEnv minp) pure (res1, warns) -- 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 Concrete.Value evalExpr e env = runModuleM env (interactive (Base.evalExpr e)) -- | Benchmark an expression. benchmarkExpr :: Double -> T.Expr -> ModuleCmd BenchmarkStats benchmarkExpr period e env = runModuleM env (interactive (Base.benchmarkExpr period e)) -- | Typecheck top-level declarations. checkDecls :: [P.TopDecl PName] -> ModuleCmd (R.NamingEnv,[T.DeclGroup], Map Name T.TySyn) 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)) -- | Rename a *use* of a value name. The distinction between uses and -- binding is used to keep track of dependencies. renameVar :: R.NamingEnv -> PName -> ModuleCmd Name renameVar names n env = runModuleM env $ interactive $ Base.rename M.interactiveName names (R.renameVar R.NameUse n) -- | Rename a *use* of a type name. The distinction between uses and -- binding is used to keep track of dependencies. renameType :: R.NamingEnv -> PName -> ModuleCmd Name renameType names n env = runModuleM env $ interactive $ Base.rename M.interactiveName names (R.renameType R.NameUse n) -------------------------------------------------------------------------------- -- Dependencies -- | Get information about the dependencies of a file. getFileDependencies :: FilePath -> ModuleCmd (ModulePath, FileInfo) getFileDependencies f env = runModuleM env (Base.findDepsOf (InFile f)) -- | Get information about the dependencies of a module. getModuleDependencies :: M.ModName -> ModuleCmd (ModulePath, FileInfo) getModuleDependencies m env = runModuleM env (Base.findDepsOfModule m) cryptol-3.0.0/src/Cryptol/ModuleSystem/0000755000000000000000000000000007346545000016254 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/ModuleSystem/Base.hs0000644000000000000000000006600307346545000017467 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 FlexibleContexts #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-} module Cryptol.ModuleSystem.Base where import qualified Control.Exception as X import Control.Monad (unless,forM) import Data.Set(Set) import qualified Data.Set as Set import Data.Maybe (fromMaybe) import Data.List(sortBy,groupBy) import Data.Function(on) import Data.Monoid ((<>),Endo(..), Any(..)) import Data.Text.Encoding (decodeUtf8') import System.Directory (doesFileExist, canonicalizePath) import System.FilePath ( addExtension , isAbsolute , joinPath , () , normalise , takeDirectory , takeFileName ) import qualified System.IO.Error as IOE import qualified Data.Map as Map import Prelude () import Prelude.Compat hiding ( (<>) ) import Cryptol.ModuleSystem.Fingerprint import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Monad import Cryptol.ModuleSystem.Name (Name,liftSupply,PrimMap,ModPath(..),nameIdent) import Cryptol.ModuleSystem.Env ( DynamicEnv(..),FileInfo(..),fileInfo , lookupModule , lookupTCEntity , LoadedModuleG(..), lmInterface , meCoreLint, CoreLint(..) , ModContext(..), ModContextParams(..) , ModulePath(..), modulePathLabel) import Cryptol.Backend.FFI import qualified Cryptol.Eval as E import qualified Cryptol.Eval.Concrete as Concrete import Cryptol.Eval.Concrete (Concrete(..)) import Cryptol.Eval.FFI 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 qualified Cryptol.Parser.ExpandPropGuards as ExpandPropGuards ( expandPropGuards, runExpandPropGuardsM ) 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 qualified Cryptol.Backend.FFI.Error as FFI import Cryptol.Utils.Ident ( preludeName, floatName, arrayName, suiteBName, primeECName , preludeReferenceName, interactiveName, modNameChunks , modNameToNormalModName ) import Cryptol.Utils.PP (pretty) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.Logger(logPutStrLn, logPrint) import Cryptol.Utils.Benchmark import Cryptol.Prelude ( preludeContents, floatContents, arrayContents , suiteBContents, primeECContents, preludeReferenceContents ) import Cryptol.Transform.MonoValues (rewModule) -- Renaming -------------------------------------------------------------------- rename :: ModName -> R.NamingEnv -> R.RenameM a -> ModuleM a rename modName env m = do ifaces <- getIfaces (res,ws) <- liftSupply $ \ supply -> let info = R.RenamerInfo { renSupply = supply , renContext = TopModule modName , renEnv = env , renIfaces = ifaces } in case R.runRenamer info 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 R.RenamedModule renameModule m = rename (thing (mName m)) mempty (R.renameModule m) -- 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' -- ExpandPropGuards ------------------------------------------------------------ -- | Run the expandPropGuards pass. expandPropGuards :: Module PName -> ModuleM (Module PName) expandPropGuards a = case ExpandPropGuards.runExpandPropGuardsM $ ExpandPropGuards.expandPropGuards a of Left err -> expandPropGuardsError err Right a' -> pure a' -- Parsing --------------------------------------------------------------------- -- | Parse a module and expand includes -- Returns a fingerprint of the module, and a set of dependencies due -- to `include` directives. parseModule :: ModulePath -> ModuleM (Fingerprint, Set FilePath, [P.Module PName]) parseModule path = do getBytes <- getByteReader bytesRes <- case path of InFile p -> io (X.try (getBytes 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 pms -> do let fp = fingerprint bytes (pm1,deps) <- case path of InFile p -> do r <- getByteReader (mo,d) <- unzip <$> forM pms \pm -> do mb <- io (removeIncludesModule r p pm) case mb of Right ok -> pure ok Left err -> noIncludeErrors err pure (mo, Set.unions d) {- We don't do "include" resolution for in-memory files because at the moment the include resolution pass requires the path to the file to be known---this is used when looking for other inlcude files. This could be generalized, but we can do it once we have a concrete use case as it would help guide the design. -} InMem {} -> pure (pms, Set.empty) {- case path of InFile {} -> io $ print (T.vcat (map T.pp pm1)) InMem {} -> pure () --} fp `seq` return (fp, deps, pm1) Left err -> moduleParseError path err -- Top Level Modules and Signatures -------------------------------------------- -- | Load a module by its path. loadModuleByPath :: Bool {- ^ evaluate declarations in the module -} -> FilePath -> ModuleM T.TCTopEntity loadModuleByPath eval path = withPrependedSearchPath [ takeDirectory path ] $ do let fileName = takeFileName path foundPath <- findFile fileName (fp, deps, pms) <- parseModule (InFile foundPath) last <$> forM pms \pm -> do 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 lookupTCEntity n env of -- loadModule will calculate the canonical path again Nothing -> doLoadModule eval False (FromModule n) (InFile foundPath) fp deps pm Just lm | path' == loaded -> return (lmData lm) | otherwise -> duplicateModuleName n path' loaded where loaded = lmModuleId lm -- | Load a module, unless it was previously loaded. loadModuleFrom :: Bool {- ^ quiet mode -} -> ImportSource -> ModuleM (ModulePath,T.TCTopEntity) loadModuleFrom quiet isrc = do let n = importedModule isrc mb <- getLoadedMaybe n case mb of Just m -> return (lmFilePath m, lmData m) Nothing -> do path <- findModule n errorInFile path $ do (fp, deps, pms) <- parseModule path ms <- mapM (doLoadModule True quiet isrc path fp deps) pms return (path,last ms) -- | Load dependencies, typecheck, and add to the eval environment. doLoadModule :: Bool {- ^ evaluate declarations in the module -} -> Bool {- ^ quiet mode: true suppresses the "loading module" message -} -> ImportSource -> ModulePath -> Fingerprint -> Set FilePath {- ^ `include` dependencies -} -> P.Module PName -> ModuleM T.TCTopEntity doLoadModule eval quiet isrc path fp incDeps pm0 = loading isrc $ do let pm = addPrelude pm0 impDeps <- loadDeps pm let what = case P.mDef pm of P.InterfaceModule {} -> "interface module" _ -> "module" unless quiet $ withLogger logPutStrLn ("Loading " ++ what ++ " " ++ pretty (P.thing (P.mName pm))) (nameEnv,tcm) <- checkModule isrc pm -- extend the eval env, unless a functor. tbl <- Concrete.primTable <$> getEvalOptsAction let ?evalPrim = \i -> Right <$> Map.lookup i tbl callStacks <- getCallStacks let ?callStacks = callStacks let shouldEval = case tcm of T.TCTopModule m | eval && not (T.isParametrizedModule m) -> Just m _ -> Nothing foreignSrc <- case shouldEval of Just m -> do fsrc <- evalForeign m modifyEvalEnv (E.moduleEnv Concrete m) pure fsrc Nothing -> pure Nothing let fi = fileInfo fp incDeps impDeps foreignSrc loadedModule path fi nameEnv foreignSrc tcm return tcm where evalForeign tcm | not (null foreignFs) = ffiLoadErrors (T.mName tcm) (map FFI.FFIInFunctor foreignFs) | not (null dups) = ffiLoadErrors (T.mName tcm) (map FFI.FFIDuplicates dups) | null foreigns = pure Nothing | otherwise = case path of InFile p -> io (canonicalizePath p >>= loadForeignSrc) >>= \case Right fsrc -> do unless quiet $ case getForeignSrcPath fsrc of Just fpath -> withLogger logPutStrLn $ "Loading dynamic library " ++ takeFileName fpath Nothing -> pure () modifyEvalEnvM (evalForeignDecls fsrc foreigns) >>= \case Right () -> pure $ Just fsrc Left errs -> ffiLoadErrors (T.mName tcm) errs Left err -> ffiLoadErrors (T.mName tcm) [err] InMem m _ -> panic "doLoadModule" ["Can't find foreign source of in-memory module", m] where foreigns = findForeignDecls tcm foreignFs = T.findForeignDeclsInFunctors tcm dups = [ d | d@(_ : _ : _) <- groupBy ((==) `on` nameIdent) $ sortBy (compare `on` nameIdent) $ map fst foreigns ] -- | 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) } 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) | m == floatName -> pure (InMem "Float" floatContents) | m == arrayName -> pure (InMem "Array" arrayContents) | m == suiteBName -> pure (InMem "SuiteB" suiteBContents) | m == primeECName -> pure (InMem "PrimeEC" primeECContents) | m == preludeReferenceName -> pure (InMem "Cryptol::Reference" preludeReferenceContents) _ -> 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 | otherwise = do paths <- getSearchPath loop (possibleFiles paths) where loop paths = case paths of path' : rest -> do b <- io (doesFileExist path') if b then return (normalise 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 { mDef = newDef } where newDef = case mDef m of NormalModule ds -> NormalModule (P.DImport prel : ds) FunctorInstance f as ins -> FunctorInstance f as ins InterfaceModule s -> InterfaceModule s { sigImports = prel : sigImports s } importedMods = map (P.iModule . P.thing) (P.mImports m) prel = P.Located { P.srcRange = emptyRange , P.thing = P.Import { iModule = P.ImpTop preludeName , iAs = Nothing , iSpec = Nothing , iInst = Nothing } } -- | Load the dependencies of a module into the environment. loadDeps :: P.ModuleG mname name -> ModuleM (Set ModName) loadDeps m = do let ds = findDeps m mapM_ (loadModuleFrom False) ds pure (Set.fromList (map importedModule ds)) -- | Find all imports in a module. findDeps :: P.ModuleG mname name -> [ImportSource] findDeps m = appEndo (snd (findDeps' m)) [] findDepsOfModule :: ModName -> ModuleM (ModulePath, FileInfo) findDepsOfModule m = do mpath <- findModule m findDepsOf mpath findDepsOf :: ModulePath -> ModuleM (ModulePath, FileInfo) findDepsOf mpath' = do mpath <- case mpath' of InFile file -> InFile <$> io (canonicalizePath file) InMem {} -> pure mpath' (fp, incs, ms) <- parseModule mpath let (anyF,imps) = mconcat (map (findDeps' . addPrelude) ms) fpath <- if getAny anyF then do mb <- io case mpath of InFile can -> foreignLibPath can InMem {} -> pure Nothing pure case mb of Nothing -> Set.empty Just f -> Set.singleton f else pure Set.empty pure ( mpath , FileInfo { fiFingerprint = fp , fiIncludeDeps = incs , fiImportDeps = Set.fromList (map importedModule (appEndo imps [])) , fiForeignDeps = fpath } ) -- | Find the set of top-level modules imported by a module. findModuleDeps :: P.ModuleG mname name -> Set P.ModName findModuleDeps = Set.fromList . map importedModule . findDeps -- | A helper `findDeps` and `findModuleDeps` that actually does the searching. findDeps' :: P.ModuleG mname name -> (Any, Endo [ImportSource]) findDeps' m = case mDef m of NormalModule ds -> mconcat (map depsOfDecl ds) FunctorInstance f as _ -> let fds = loadImpName FromModuleInstance f ads = case as of DefaultInstArg a -> loadInstArg a DefaultInstAnonArg ds -> mconcat (map depsOfDecl ds) NamedInstArgs args -> mconcat (map loadNamedInstArg args) in fds <> ads InterfaceModule s -> mconcat (map loadImpD (sigImports s)) where loadI i = (mempty, Endo (i:)) loadImpName src l = case thing l of ImpTop f -> loadI (src l { thing = f }) _ -> mempty loadImpD li = loadImpName (FromImport . new) (iModule <$> li) where new i = i { thing = (thing li) { iModule = thing i } } loadNamedInstArg (ModuleInstanceNamedArg _ f) = loadInstArg f loadInstArg f = case thing f of ModuleArg mo -> loadImpName FromModuleInstance f { thing = mo } _ -> mempty depsOfDecl d = case d of DImport li -> loadImpD li DModule TopLevel { tlValue = NestedModule nm } -> findDeps' nm DModParam mo -> loadImpName FromSigImport s where s = mpSignature mo Decl dd -> depsOfDecl' (tlValue dd) _ -> mempty depsOfDecl' d = case d of DLocated d' _ -> depsOfDecl' d' DBind b -> case thing (bDef b) of DForeign {} -> (Any True, mempty) _ -> mempty _ -> mempty -- Type Checking --------------------------------------------------------------- -- | 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 fe <- getFocusedEnv let params = mctxParams fe decls = mctxDecls fe names = mctxNames fe -- 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], Map.Map Name T.TySyn) checkDecls ds = do fe <- getFocusedEnv let params = mctxParams fe decls = mctxDecls fe names = mctxNames fe (declsEnv,rds) <- rename interactiveName names $ R.renameTopDecls interactiveName ds prims <- getPrimMap let act = TCAction { tcAction = T.tcDecls, tcLinter = declsLinter , tcPrims = prims } (ds',tyMap) <- typecheck act rds params decls return (declsEnv,ds',tyMap) -- | 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 let mkPrims = ifacePrimMap . lmInterface mp `alsoPrimFrom` m = case lookupModule m env of Nothing -> mp Just lm -> mkPrims lm <> mp case lookupModule preludeName env of Just prel -> return $ mkPrims prel `alsoPrimFrom` floatName Nothing -> panic "Cryptol.ModuleSystem.Base.getPrimMap" [ "Unable to find the prelude" ] -- | Typecheck a single module. -- Note: we assume that @include@s have already been processed checkModule :: ImportSource {- ^ why are we loading this -} -> P.Module PName {- ^ module to check -} -> ModuleM (R.NamingEnv,T.TCTopEntity) checkModule isrc m = do -- check that the name of the module matches expectations let nm = importedModule isrc unless (modNameToNormalModName nm == modNameToNormalModName (thing (P.mName m))) (moduleNameMismatch nm (mName m)) -- remove pattern bindings npm <- noPat m -- run expandPropGuards epgm <- expandPropGuards npm -- rename everything renMod <- renameModule epgm {- -- dump renamed unless (thing (mName (R.rmModule renMod)) == preludeName) do (io $ print (T.pp renMod)) -- io $ exitSuccess --} -- 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 (R.rmDefines renMod)) else getPrimMap -- typecheck let act = TCAction { tcAction = T.tcModule , tcLinter = tcTopEntitytLinter (P.thing (P.mName m)) , tcPrims = prims } tcm <- typecheck act (R.rmModule renMod) NoParams (R.rmImported renMod) rewMod <- case tcm of T.TCTopModule mo -> T.TCTopModule <$> liftSupply (`rewModule` mo) T.TCTopSignature {} -> pure tcm pure (R.rmInScope renMod,rewMod) data TCLinter o = TCLinter { lintCheck :: o -> T.InferInput -> Either (Range, 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.SameIf os' <- TcSanity.same s s1 -> Right (map T.tMono os' ++ os) | otherwise -> Left ( fromMaybe emptyRange (getLoc e') , TcSanity.TypeMismatch "exprLinter" s s1 ) , lintModule = Nothing } declsLinter :: TCLinter ([ T.DeclGroup ], a) 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 } tcTopEntitytLinter :: P.ModName -> TCLinter T.TCTopEntity tcTopEntitytLinter m = TCLinter { lintCheck = \m' i -> case m' of T.TCTopModule mo -> lintCheck (moduleLinter m) mo i T.TCTopSignature {} -> Right [] -- XXX: what can we lint about module interfaces , 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 -> ModContextParams -> 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 nameMap warns seeds supply' o -> do setNameSeeds seeds setSupply supply' typeCheckWarnings nameMap 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 (TcSanity.onlyNonTrivial as) Left (loc,err) -> panic "Core lint failed:" [ "Location: " ++ show (T.pp loc) , show (T.pp err) ] return o T.InferFailed nameMap warns errs -> do typeCheckWarnings nameMap warns typeCheckingFailed nameMap errs -- | Generate input for the typechecker. genInferInput :: Range -> PrimMap -> ModContextParams -> IfaceDecls -> ModuleM T.InferInput genInferInput r prims params env = do seeds <- getNameSeeds monoBinds <- getMonoBinds solver <- getTCSolver supply <- getSupply searchPath <- getSearchPath callStacks <- getCallStacks topMods <- getAllLoaded topSigs <- getAllLoadedSignatures 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.inpSignatures = ifSignatures env , T.inpNameSeeds = seeds , T.inpMonoBinds = monoBinds , T.inpCallStacks = callStacks , T.inpSearchPath = searchPath , T.inpSupply = supply , T.inpParams = case params of NoParams -> T.allParamNames mempty FunctorParams ps -> T.allParamNames ps InterfaceParams ps -> ps , T.inpPrimNames = prims , T.inpSolver = solver , T.inpTopModules = topMods , T.inpTopSignatures = topSigs } -- Evaluation ------------------------------------------------------------------ evalExpr :: T.Expr -> ModuleM Concrete.Value evalExpr e = do env <- getEvalEnv denv <- getDynEnv evopts <- getEvalOptsAction let tbl = Concrete.primTable evopts let ?evalPrim = \i -> Right <$> Map.lookup i tbl let ?range = emptyRange callStacks <- getCallStacks let ?callStacks = callStacks io $ E.runEval mempty (E.evalExpr Concrete (env <> deEnv denv) e) benchmarkExpr :: Double -> T.Expr -> ModuleM BenchmarkStats benchmarkExpr period e = do env <- getEvalEnv denv <- getDynEnv evopts <- getEvalOptsAction let env' = env <> deEnv denv let tbl = Concrete.primTable evopts let ?evalPrim = \i -> Right <$> Map.lookup i tbl let ?range = emptyRange callStacks <- getCallStacks let ?callStacks = callStacks let eval expr = E.runEval mempty $ E.evalExpr Concrete env' expr >>= E.forceValue io $ benchmark period eval e evalDecls :: [T.DeclGroup] -> ModuleM () evalDecls dgs = do env <- getEvalEnv denv <- getDynEnv evOpts <- getEvalOptsAction let env' = env <> deEnv denv let tbl = Concrete.primTable evOpts let ?evalPrim = \i -> Right <$> Map.lookup i tbl callStacks <- getCallStacks let ?callStacks = callStacks deEnv' <- io $ E.runEval mempty (E.evalDecls Concrete dgs env') let denv' = denv { deDecls = deDecls denv ++ dgs , deEnv = deEnv' } setDynEnv denv' cryptol-3.0.0/src/Cryptol/ModuleSystem/Binds.hs0000644000000000000000000003516307346545000017657 0ustar0000000000000000{-# Language BlockArguments #-} {-# Language RecordWildCards #-} {-# Language FlexibleInstances #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} module Cryptol.ModuleSystem.Binds ( BindsNames , TopDef(..) , Mod(..) , ModKind(..) , modNested , modBuilder , topModuleDefs , topDeclsDefs , newModParam , InModule(..) , ifaceToMod , ifaceSigToMod , modToMap , defsOf ) where import Data.Map(Map) import qualified Data.Map as Map import Data.Set(Set) import qualified Data.Set as Set import Data.Maybe(fromMaybe) import Control.Monad(foldM) import qualified MonadLib as M import Cryptol.Utils.Panic (panic) import Cryptol.Utils.Ident(allNamespaces) import Cryptol.Parser.Position import Cryptol.Parser.Name(isGeneratedName) import Cryptol.Parser.AST import Cryptol.ModuleSystem.Exports(exportedDecls,exported) import Cryptol.ModuleSystem.Renamer.Error import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.Names import Cryptol.ModuleSystem.NamingEnv import Cryptol.ModuleSystem.Interface import Cryptol.TypeCheck.Type(ModParamNames(..)) data TopDef = TopMod ModName (Mod ()) | TopInst ModName (ImpName PName) (ModuleInstanceArgs PName) -- | Things defined by a module data Mod a = Mod { modImports :: [ ImportG (ImpName PName) ] , modKind :: ModKind , modInstances :: Map Name (ImpName PName, ModuleInstanceArgs PName) , modMods :: Map Name (Mod a) -- ^ this includes signatures , modDefines :: NamingEnv {- ^ Things defined by this module. Note the for normal modules we really just need the public names, however for things within functors we need all defined names, so that we can generate fresh names in instantiations -} , modPublic :: !(Set Name) -- ^ These are the exported names , modState :: a {- ^ Used in the import loop to track the current state of processing. The reason this is here, rather than just having a pair in the other algorithm is because this type is recursive (for nested modules) and it is conveninet to keep track for all modules at once -} } modNested :: Mod a -> Set Name modNested m = Set.unions [ Map.keysSet (modInstances m) , Map.keysSet (modMods m) ] instance Functor Mod where fmap f m = m { modState = f (modState m) , modMods = fmap f <$> modMods m } -- | Generate a map from this module and all modules nested in it. modToMap :: ImpName Name -> Mod () -> Map (ImpName Name) (Mod ()) -> Map (ImpName Name) (Mod ()) modToMap x m mp = Map.insert x m (Map.foldrWithKey add mp (modMods m)) where add n = modToMap (ImpNested n) -- | Make a `Mod` from the public declarations in an interface. -- This is used to handle imports. ifaceToMod :: IfaceG name -> Mod () ifaceToMod iface = ifaceNamesToMod iface (ifaceIsFunctor iface) (ifNames iface) ifaceNamesToMod :: IfaceG topname -> Bool -> IfaceNames name -> Mod () ifaceNamesToMod iface params names = Mod { modKind = if params then AFunctor else AModule , modMods = (ifaceNamesToMod iface False <$> ifModules decls) `Map.union` (ifaceToMod <$> ifFunctors decls) `Map.union` (ifaceSigToMod <$> ifSignatures decls) , modDefines = namingEnvFromNames defs , modPublic = ifsPublic names , modImports = [] , modInstances = mempty , modState = () } where defs = ifsDefines names isLocal x = x `Set.member` defs decls = filterIfaceDecls isLocal (ifDefines iface) ifaceSigToMod :: ModParamNames -> Mod () ifaceSigToMod ps = Mod { modImports = [] , modKind = ASignature , modInstances = mempty , modMods = mempty , modDefines = env , modPublic = namingEnvNames env , modState = () } where env = modParamsNamingEnv ps type ModBuilder = SupplyT (M.StateT [RenamerError] M.Id) modBuilder :: ModBuilder a -> Supply -> ((a, [RenamerError]),Supply) modBuilder m s = ((a,errs),s1) where ((a,s1),errs) = M.runId (M.runStateT [] (runSupplyT s m)) defErr :: RenamerError -> ModBuilder () defErr a = M.lift (M.sets_ (a:)) defNames :: BuildNamingEnv -> ModBuilder NamingEnv defNames b = liftSupply \s -> M.runId (runSupplyT s (runBuild b)) topModuleDefs :: Module PName -> ModBuilder TopDef topModuleDefs m = case mDef m of NormalModule ds -> TopMod mname <$> declsToMod (Just (TopModule mname)) ds FunctorInstance f as _ -> pure (TopInst mname (thing f) as) InterfaceModule s -> TopMod mname <$> sigToMod (TopModule mname) s where mname = thing (mName m) topDeclsDefs :: ModPath -> [TopDecl PName] -> ModBuilder (Mod ()) topDeclsDefs = declsToMod . Just sigToMod :: ModPath -> Signature PName -> ModBuilder (Mod ()) sigToMod mp sig = do env <- defNames (signatureDefs mp sig) pure Mod { modImports = map thing (sigImports sig) , modKind = ASignature , modInstances = mempty , modMods = mempty , modDefines = env , modPublic = namingEnvNames env , modState = () } declsToMod :: Maybe ModPath -> [TopDecl PName] -> ModBuilder (Mod ()) declsToMod mbPath ds = do defs <- defNames (foldMap (namingEnv . InModule mbPath) ds) let expSpec = exportedDecls ds let pub = Set.fromList [ name | ns <- allNamespaces , pname <- Set.toList (exported ns expSpec) , name <- lookupListNS ns pname defs ] case findAmbig defs of bad@(_ : _) : _ -> -- defErr (MultipleDefinitions mbPath (nameIdent f) (map nameLoc bad)) defErr (OverlappingSyms bad) _ -> pure () let mo = Mod { modImports = [ thing i | DImport i <- ds ] , modKind = if any isParamDecl ds then AFunctor else AModule , modInstances = mempty , modMods = mempty , modDefines = defs , modPublic = pub , modState = () } foldM (checkNest defs) mo ds where checkNest defs mo d = case d of DModule tl -> do let NestedModule nmod = tlValue tl pname = thing (mName nmod) name = case lookupNS NSModule pname defs of Just xs -> anyOne xs _ -> panic "declsToMod" ["undefined name", show pname] case mbPath of Nothing -> do defErr (UnexpectedNest (srcRange (mName nmod)) pname) pure mo Just path -> case mDef nmod of NormalModule xs -> do m <- declsToMod (Just (Nested path (nameIdent name))) xs pure mo { modMods = Map.insert name m (modMods mo) } FunctorInstance f args _ -> pure mo { modInstances = Map.insert name (thing f, args) (modInstances mo) } InterfaceModule sig -> do m <- sigToMod (Nested path (nameIdent name)) sig pure mo { modMods = Map.insert name m (modMods mo) } _ -> pure mo -- | These are the names "owned" by the signature. These names are -- used when resolving the signature. They are also used to figure out what -- names to instantuate when the signature is used. signatureDefs :: ModPath -> Signature PName -> BuildNamingEnv signatureDefs m sig = mconcat [ namingEnv (InModule loc p) | p <- sigTypeParams sig ] <> mconcat [ namingEnv (InModule loc p) | p <- sigFunParams sig ] <> mconcat [ namingEnv (InModule loc p) | p <- sigDecls sig ] where loc = Just m -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- Computes the names introduced by various declarations. -- | Things that define exported names. class BindsNames a where namingEnv :: a -> BuildNamingEnv newtype BuildNamingEnv = BuildNamingEnv { runBuild :: SupplyT M.Id NamingEnv } buildNamingEnv :: BuildNamingEnv -> Supply -> (NamingEnv,Supply) buildNamingEnv b supply = M.runId $ runSupplyT supply $ runBuild b -- | Generate a 'NamingEnv' using an explicit supply. defsOf :: BindsNames a => a -> Supply -> (NamingEnv,Supply) defsOf = buildNamingEnv . 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) 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 #-} -- | Introduce the name instance BindsNames (InModule (Bind PName)) where namingEnv (InModule mb b) = BuildNamingEnv $ do let Located { .. } = bName b n <- case mb of Just m -> newTop NSValue m thing (bFixity b) srcRange Nothing -> newLocal NSValue thing srcRange -- local fixitiies? return (singletonNS NSValue 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 NSType tpName range return (singletonNS NSType tpName n) 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)) DParamDecl {} -> mempty Include _ -> mempty DImport {} -> mempty -- see 'openLoop' in the renamer DModule m -> namingEnv (InModule ns (tlValue m)) DModParam {} -> mempty -- shouldn't happen DInterfaceConstraint {} -> mempty -- handled in the renamer as we need to resolve -- the signature name first (similar to import) instance BindsNames (InModule (NestedModule PName)) where namingEnv (InModule ~(Just m) (NestedModule mdef)) = BuildNamingEnv $ do let pnmame = mName mdef nm <- newTop NSModule m (thing pnmame) Nothing (srcRange pnmame) pure (singletonNS NSModule (thing pnmame) nm) instance BindsNames (InModule (PrimType PName)) where namingEnv (InModule ~(Just m) PrimType { .. }) = BuildNamingEnv $ do let Located { .. } = primTName nm <- newTop NSType m thing primTFixity srcRange pure (singletonNS NSType thing nm) instance BindsNames (InModule (ParameterFun PName)) where namingEnv (InModule ~(Just ns) ParameterFun { .. }) = BuildNamingEnv $ do let Located { .. } = pfName ntName <- newTop NSValue ns thing pfFixity srcRange return (singletonNS NSValue thing ntName) instance BindsNames (InModule (ParameterType PName)) where namingEnv (InModule ~(Just ns) ParameterType { .. }) = BuildNamingEnv $ -- XXX: we don't seem to have a fixity environment at the type level do let Located { .. } = ptName ntName <- newTop NSType ns thing Nothing srcRange return (singletonNS NSType thing ntName) instance BindsNames (InModule (Newtype PName)) where namingEnv (InModule ~(Just ns) Newtype { .. }) = BuildNamingEnv $ do let Located { .. } = nName ntName <- newTop NSType ns thing Nothing srcRange ntConName <- newTop NSValue ns thing Nothing srcRange return (singletonNS NSType thing ntName `mappend` singletonNS NSValue thing ntConName) -- | The naming environment for a single declaration. instance BindsNames (InModule (Decl PName)) where namingEnv (InModule pfx d) = case d of DBind b -> namingEnv (InModule pfx b) 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') DRec {} -> panic "namingEnv" [ "DRec" ] DPatBind _pat _e -> panic "namingEnv" ["Unexpected pattern binding"] DFixity{} -> panic "namingEnv" ["Unexpected fixity declaration"] where mkName ns ln fx = case pfx of Just m -> newTop ns m (thing ln) fx (srcRange ln) Nothing -> newLocal ns (thing ln) (srcRange ln) qualBind ln = BuildNamingEnv $ do n <- mkName NSValue ln Nothing return (singletonNS NSValue (thing ln) n) qualType ln f = BuildNamingEnv $ do n <- mkName NSType ln f return (singletonNS NSType (thing ln) n) instance BindsNames (InModule (SigDecl PName)) where namingEnv (InModule m d) = case d of SigTySyn ts _ -> namingEnv (InModule m (DType ts)) SigPropSyn ps _ -> namingEnv (InModule m (DProp ps)) -------------------------------------------------------------------------------- -- Helpers newTop :: FreshM m => Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name newTop ns m thing fx rng = liftSupply (mkDeclared ns m src (getIdent thing) fx rng) where src = if isGeneratedName thing then SystemName else UserName newLocal :: FreshM m => Namespace -> PName -> Range -> m Name newLocal ns thing rng = liftSupply (mkLocal ns (getIdent thing) rng) -- | Given a name in a signature, make a name for the parameter corresponding -- to the signature. newModParam :: FreshM m => ModPath -> Ident -> Range -> Name -> m Name newModParam m i rng n = liftSupply (mkModParam m i rng n) {- | Do something in the context of a module. If `Nothing` than we are working with a local declaration. Otherwise we are at the top-level of the given module. By wrapping types with this, we can pass the module path to methods that need the extra information. -} data InModule a = InModule (Maybe ModPath) a deriving (Functor,Traversable,Foldable,Show) cryptol-3.0.0/src/Cryptol/ModuleSystem/Env.hs0000644000000000000000000004762107346545000017352 0ustar0000000000000000-- | -- Module : Cryptol.ModuleSystem.Env -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE CPP #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module Cryptol.ModuleSystem.Env where #ifndef RELOCATABLE import Paths_cryptol (getDataDir) #endif import Cryptol.Backend.FFI (ForeignSrc, unloadForeignSrc, getForeignSrcPath) import Cryptol.Eval (EvalEnv) import Cryptol.ModuleSystem.Fingerprint import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Name (Name,Supply,emptySupply) import qualified Cryptol.ModuleSystem.NamingEnv as R import Cryptol.Parser.AST import qualified Cryptol.TypeCheck as T import qualified Cryptol.TypeCheck.Interface 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 Data.Set(Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map import Data.Semigroup import Data.Maybe(fromMaybe) import System.Directory (getAppUserDataDirectory, getCurrentDirectory) import System.Environment(getExecutablePath) import System.FilePath ((), normalise, joinPath, splitPath, takeDirectory) import qualified Data.List as List import Data.Foldable import GHC.Generics (Generic) import Control.DeepSeq import Prelude () import Prelude.Compat import Cryptol.Utils.Panic(panic) import Cryptol.Utils.PP(pp) -- 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. , 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 where rnf x = meLoadedModules x `seq` meEvalEnv x `seq` meDynEnv x `seq` () -- | Should we run the linter? data CoreLint = NoCoreLint -- ^ Don't run core lint | CoreLint -- ^ Run core lint deriving (Generic, NFData) resetModuleEnv :: ModuleEnv -> IO ModuleEnv resetModuleEnv env = do for_ (getLoadedModules $ meLoadedModules env) $ \lm -> case lmForeignSrc (lmData lm) of Just fsrc -> unloadForeignSrc fsrc _ -> pure () pure 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 , 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 loadedNewtypes :: ModuleEnv -> Map Name T.Newtype loadedNewtypes menv = Map.unions [ ifNewtypes (ifDefines i) <> ifNewtypes (ifDefines i) | i <- map lmInterface (getLoadedModules (meLoadedModules menv)) ] -- | Are any parameterized modules loaded? hasParamModules :: ModuleEnv -> Bool hasParamModules = not . null . lmLoadedParamModules . meLoadedModules allDeclGroups :: ModuleEnv -> [T.DeclGroup] allDeclGroups = concatMap T.mDecls . loadedNonParamModules data ModContextParams = InterfaceParams T.ModParamNames | FunctorParams T.FunctorParams | NoParams modContextParamNames :: ModContextParams -> T.ModParamNames modContextParamNames mp = case mp of InterfaceParams ps -> ps FunctorParams ps -> T.allParamNames ps NoParams -> T.allParamNames mempty -- | Contains enough information to browse what's in scope, -- or type check new expressions. data ModContext = ModContext { mctxParams :: ModContextParams -- T.FunctorParams , mctxExported :: Set Name , mctxDecls :: IfaceDecls -- ^ Should contain at least names in NamingEnv, but may have more , mctxNames :: R.NamingEnv -- ^ What's in scope inside the module , mctxNameDisp :: NameDisp } -- This instance is a bit bogus. It is mostly used to add the dynamic -- environemnt to an existing module, and it makes sense for that use case. instance Semigroup ModContext where x <> y = ModContext { mctxParams = jnPs (mctxParams x) (mctxParams y) , mctxExported = mctxExported x <> mctxExported y , mctxDecls = mctxDecls x <> mctxDecls y , mctxNames = names , mctxNameDisp = R.toNameDisp names } where names = mctxNames x `R.shadowing` mctxNames y jnPs as bs = case (as,bs) of (NoParams,_) -> bs (_,NoParams) -> as (FunctorParams xs, FunctorParams ys) -> FunctorParams (xs <> ys) _ -> panic "(<>) @ ModContext" ["Can't combine parameters"] instance Monoid ModContext where mempty = ModContext { mctxParams = NoParams , mctxDecls = mempty , mctxExported = mempty , mctxNames = mempty , mctxNameDisp = R.toNameDisp mempty } modContextOf :: ModName -> ModuleEnv -> Maybe ModContext modContextOf mname me = do lm <- lookupModule mname me let localIface = lmInterface lm localNames = lmNamingEnv lm -- XXX: do we want only public ones here? loadedDecls = map (ifDefines . lmInterface) $ getLoadedModules (meLoadedModules me) params = ifParams localIface pure ModContext { mctxParams = if Map.null params then NoParams else FunctorParams params , mctxExported = ifsPublic (ifNames localIface) , mctxDecls = mconcat (ifDefines localIface : loadedDecls) , mctxNames = localNames , mctxNameDisp = R.toNameDisp localNames } `mplus` do lm <- lookupSignature mname me let localNames = lmNamingEnv lm -- XXX: do we want only public ones here? loadedDecls = map (ifDefines . lmInterface) $ getLoadedModules (meLoadedModules me) pure ModContext { mctxParams = InterfaceParams (lmData lm) , mctxExported = Set.empty , mctxDecls = mconcat loadedDecls , mctxNames = localNames , mctxNameDisp = R.toNameDisp localNames } dynModContext :: ModuleEnv -> ModContext dynModContext me = mempty { mctxNames = dynNames , mctxNameDisp = R.toNameDisp dynNames , mctxDecls = deIfaceDecls (meDynEnv me) } where dynNames = deNames (meDynEnv me) -- | Given the state of the environment, compute information about what's -- in scope on the REPL. This includes what's in the focused module, plus any -- additional definitions from the REPL (e.g., let bound names, and @it@). focusedEnv :: ModuleEnv -> ModContext focusedEnv me = case meFocusedModule me of Nothing -> dynModContext me Just fm -> case modContextOf fm me of Just c -> dynModContext me <> c Nothing -> panic "focusedEnv" [ "Focused modules not loaded: " ++ show (pp fm) ] -- 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 -- | In-memory things are compared by label. instance Ord ModulePath where compare p1 p2 = case (p1,p2) of (InFile x, InFile y) -> compare x y (InMem a _, InMem b _) -> compare a b (InMem {}, InFile {}) -> LT (InFile {}, InMem {}) -> GT 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. , lmLoadedSignatures :: ![LoadedSignature] } deriving (Show, Generic, NFData) data LoadedEntity = ALoadedModule LoadedModule | ALoadedFunctor LoadedModule | ALoadedInterface LoadedSignature getLoadedEntities :: LoadedModules -> Map ModName LoadedEntity getLoadedEntities lm = Map.fromList $ [ (lmName x, ALoadedModule x) | x <- lmLoadedModules lm ] ++ [ (lmName x, ALoadedFunctor x) | x <- lmLoadedParamModules lm ] ++ [ (lmName x, ALoadedInterface x) | x <- lmLoadedSignatures lm ] getLoadedModules :: LoadedModules -> [LoadedModule] getLoadedModules x = lmLoadedParamModules x ++ lmLoadedModules x getLoadedNames :: LoadedModules -> Set ModName getLoadedNames lm = Set.fromList $ map lmName (lmLoadedModules lm) ++ map lmName (lmLoadedParamModules lm) ++ map lmName (lmLoadedSignatures lm) instance Semigroup LoadedModules where l <> r = LoadedModules { lmLoadedModules = List.unionBy ((==) `on` lmName) (lmLoadedModules l) (lmLoadedModules r) , lmLoadedParamModules = lmLoadedParamModules l ++ lmLoadedParamModules r , lmLoadedSignatures = lmLoadedSignatures l ++ lmLoadedSignatures r } instance Monoid LoadedModules where mempty = LoadedModules { lmLoadedModules = [] , lmLoadedParamModules = [] , lmLoadedSignatures = [] } mappend = (<>) -- | A generic type for loaded things. -- The things can be either modules or signatures. data LoadedModuleG a = LoadedModule { lmName :: ModName -- ^ The name of this module. Should match what's in 'lmModule' , 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. , lmNamingEnv :: !R.NamingEnv -- ^ What's in scope in this module , lmFileInfo :: !FileInfo , lmData :: a } deriving (Show, Generic, NFData) type LoadedModule = LoadedModuleG LoadedModuleData lmModule :: LoadedModule -> T.Module lmModule = lmdModule . lmData lmInterface :: LoadedModule -> Iface lmInterface = lmdInterface . lmData data LoadedModuleData = LoadedModuleData { lmdInterface :: Iface -- ^ The module's interface. , lmdModule :: T.Module -- ^ The actual type-checked module , lmForeignSrc :: Maybe ForeignSrc -- ^ The dynamically loaded source for any foreign functions in the module } deriving (Show, Generic, NFData) type LoadedSignature = LoadedModuleG T.ModParamNames -- | Has this module been loaded already. isLoaded :: ModName -> LoadedModules -> Bool isLoaded mn lm = mn `Set.member` getLoadedNames lm -- | Is this a loaded parameterized module. isLoadedParamMod :: ModName -> LoadedModules -> Bool isLoadedParamMod mn ln = any ((mn ==) . lmName) (lmLoadedParamModules ln) -- | Is this a loaded interface module. isLoadedInterface :: ModName -> LoadedModules -> Bool isLoadedInterface mn ln = any ((mn ==) . lmName) (lmLoadedSignatures ln) lookupTCEntity :: ModName -> ModuleEnv -> Maybe (LoadedModuleG T.TCTopEntity) lookupTCEntity m env = case lookupModule m env of Just lm -> pure lm { lmData = T.TCTopModule (lmModule lm) } Nothing -> do lm <- lookupSignature m env pure lm { lmData = T.TCTopSignature m (lmData lm) } -- | 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)) lookupSignature :: ModName -> ModuleEnv -> Maybe LoadedSignature lookupSignature mn me = List.find ((mn ==) . lmName) (lmLoadedSignatures (meLoadedModules me)) addLoadedSignature :: ModulePath -> String -> FileInfo -> R.NamingEnv -> ModName -> T.ModParamNames -> LoadedModules -> LoadedModules addLoadedSignature path ident fi nameEnv nm si lm | isLoaded nm lm = lm | otherwise = lm { lmLoadedSignatures = loaded : lmLoadedSignatures lm } where loaded = LoadedModule { lmName = nm , lmFilePath = path , lmModuleId = ident , lmNamingEnv = nameEnv , lmData = si , lmFileInfo = fi } -- | Add a freshly loaded module. If it was previously loaded, then -- the new version is ignored. addLoadedModule :: ModulePath -> String -> FileInfo -> R.NamingEnv -> Maybe ForeignSrc -> T.Module -> LoadedModules -> LoadedModules addLoadedModule path ident fi nameEnv fsrc 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 , lmNamingEnv = nameEnv , lmData = LoadedModuleData { lmdInterface = T.genIface tm , lmdModule = tm , lmForeignSrc = fsrc } , lmFileInfo = fi } -- | Remove a previously loaded module. -- Note that this removes exactly the modules specified by the predicate. -- One should be carfule to preserve the invariant on 'LoadedModules'. removeLoadedModule :: (forall a. LoadedModuleG a -> Bool) -> LoadedModules -> LoadedModules removeLoadedModule rm lm = LoadedModules { lmLoadedModules = filter (not . rm) (lmLoadedModules lm) , lmLoadedParamModules = filter (not . rm) (lmLoadedParamModules lm) , lmLoadedSignatures = filter (not . rm) (lmLoadedSignatures lm) } -- FileInfo -------------------------------------------------------------------- data FileInfo = FileInfo { fiFingerprint :: Fingerprint , fiIncludeDeps :: Set FilePath , fiImportDeps :: Set ModName , fiForeignDeps :: Set FilePath } deriving (Show,Generic,NFData) fileInfo :: Fingerprint -> Set FilePath -> Set ModName -> Maybe ForeignSrc -> FileInfo fileInfo fp incDeps impDeps fsrc = FileInfo { fiFingerprint = fp , fiIncludeDeps = incDeps , fiImportDeps = impDeps , fiForeignDeps = fromMaybe Set.empty do src <- fsrc Set.singleton <$> getForeignSrcPath src } -- 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] , deTySyns :: Map Name T.TySyn , deEnv :: EvalEnv } deriving Generic instance Semigroup DynamicEnv where de1 <> de2 = DEnv { deNames = deNames de1 <> deNames de2 , deDecls = deDecls de1 <> deDecls de2 , deTySyns = deTySyns de1 <> deTySyns de2 , deEnv = deEnv de1 <> deEnv de2 } instance Monoid DynamicEnv where mempty = DEnv { deNames = mempty , deDecls = mempty , deTySyns = mempty , deEnv = mempty } mappend = (<>) -- | Build 'IfaceDecls' that correspond to all of the bindings in the -- dynamic environment. -- -- XXX: if we add newtypes, etc. at the REPL, revisit -- this. deIfaceDecls :: DynamicEnv -> IfaceDecls deIfaceDecls DEnv { deDecls = dgs, deTySyns = tySyns } = IfaceDecls { ifTySyns = tySyns , ifNewtypes = Map.empty , ifAbstractTypes = Map.empty , ifDecls = decls , ifModules = Map.empty , ifFunctors = Map.empty , ifSignatures = Map.empty } where decls = mconcat [ Map.singleton (ifDeclName ifd) ifd | decl <- concatMap T.groupDecls dgs , let ifd = T.mkIfaceDecl decl ] cryptol-3.0.0/src/Cryptol/ModuleSystem/Exports.hs0000644000000000000000000000563507346545000020265 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Safe #-} module Cryptol.ModuleSystem.Exports where import Data.Set(Set) import qualified Data.Set as Set import Data.Map(Map) import qualified Data.Map as Map import Data.Foldable(fold) import Control.DeepSeq(NFData) import GHC.Generics (Generic) import Cryptol.Parser.AST import Cryptol.Parser.Names(namesD,tnamesD,namesNT,tnamesNT) import Cryptol.ModuleSystem.Name exportedDecls :: Ord name => [TopDecl name] -> ExportSpec name exportedDecls ds = fold (concat [ exportedNames d | d <- ds ]) exportedNames :: Ord name => TopDecl name -> [ExportSpec name] exportedNames decl = case decl of Decl td -> map exportBind (names namesD td) ++ map exportType (names tnamesD td) DPrimType t -> [ exportType (thing . primTName <$> t) ] TDNewtype nt -> map exportType (names tnamesNT nt) ++ map exportBind (names namesNT nt) Include {} -> [] DImport {} -> [] DParamDecl {} -> [] DInterfaceConstraint {} -> [] DModule nested -> case tlValue nested of NestedModule x -> [exportName NSModule nested { tlValue = thing (mName x) }] DModParam {} -> [] where names by td = [ td { tlValue = thing n } | n <- fst (by (tlValue td)) ] newtype ExportSpec name = ExportSpec (Map Namespace (Set name)) deriving (Show, Generic) instance NFData name => NFData (ExportSpec name) instance Ord name => Semigroup (ExportSpec name) where ExportSpec l <> ExportSpec r = ExportSpec (Map.unionWith Set.union l r) instance Ord name => Monoid (ExportSpec name) where mempty = ExportSpec Map.empty exportName :: Ord name => Namespace -> TopLevel name -> ExportSpec name exportName ns n | tlExport n == Public = ExportSpec $ Map.singleton ns $ Set.singleton (tlValue n) | otherwise = mempty allExported :: Ord name => ExportSpec name -> Set name allExported (ExportSpec mp) = Set.unions (Map.elems mp) exported :: Namespace -> ExportSpec name -> Set name exported ns (ExportSpec mp) = Map.findWithDefault Set.empty ns mp -- | Add a binding name to the export list, if it should be exported. exportBind :: Ord name => TopLevel name -> ExportSpec name exportBind = exportName NSValue -- | Add a type synonym name to the export list, if it should be exported. exportType :: Ord name => TopLevel name -> ExportSpec name exportType = exportName NSType isExported :: Ord name => Namespace -> name -> ExportSpec name -> Bool isExported ns x (ExportSpec s) = case Map.lookup ns s of Nothing -> False Just mp -> Set.member x mp -- | Check to see if a binding is exported. isExportedBind :: Ord name => name -> ExportSpec name -> Bool isExportedBind = isExported NSValue -- | Check to see if a type synonym is exported. isExportedType :: Ord name => name -> ExportSpec name -> Bool isExportedType = isExported NSType cryptol-3.0.0/src/Cryptol/ModuleSystem/Fingerprint.hs0000644000000000000000000000272007346545000021100 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 , fingerprintHexString ) where import Control.DeepSeq (NFData (rnf)) import Crypto.Hash.SHA1 (hash) import Data.ByteString (ByteString) import Control.Exception (try) import qualified Data.ByteString as B import qualified Data.Vector as Vector 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 fingerprintHexString :: Fingerprint -> String fingerprintHexString (Fingerprint bs) = B.foldr hex "" bs where digits = Vector.fromList "0123456789ABCDEF" digit x = digits Vector.! fromIntegral x hex b cs = let (x,y) = divMod b 16 in digit x : digit y : cs cryptol-3.0.0/src/Cryptol/ModuleSystem/Interface.hs0000644000000000000000000002106707346545000020516 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 RecordWildCards #-} {-# LANGUAGE Safe #-} module Cryptol.ModuleSystem.Interface ( Iface , IfaceG(..) , IfaceDecls(..) , IfaceDecl(..) , IfaceNames(..) , ifModName , emptyIface , ifacePrimMap , ifaceForgetName , ifaceIsFunctor , filterIfaceDecls , ifaceDeclsNames , ifaceOrigNameMap ) where import Data.Set(Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map import Data.Semigroup import Data.Text (Text) import GHC.Generics (Generic) import Control.DeepSeq import Prelude () import Prelude.Compat import Cryptol.ModuleSystem.Name import Cryptol.Utils.Ident (ModName, OrigName(..)) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Fixity(Fixity) import Cryptol.Parser.AST(Pragma) import Cryptol.TypeCheck.Type type Iface = IfaceG ModName -- | The interface repersenting a typecheck top-level module. data IfaceG name = Iface { ifNames :: IfaceNames name -- ^ Info about names in this module , ifParams :: FunctorParams -- ^ Module parameters, if any , ifDefines :: IfaceDecls -- ^ All things defines in the module -- (includes nested definitions) } deriving (Show, Generic, NFData) -- | Remove the name of a module. This is useful for dealing with collections -- of modules, as in `Map (ImpName Name) (IfaceG ())`. ifaceForgetName :: IfaceG name -> IfaceG () ifaceForgetName i = i { ifNames = newNames } where newNames = (ifNames i) { ifsName = () } -- | Access the name of a module. ifModName :: IfaceG name -> name ifModName = ifsName . ifNames -- | Information about the names in a module. data IfaceNames name = IfaceNames { ifsName :: name -- ^ Name of this submodule , ifsNested :: Set Name -- ^ Things nested in this module , ifsDefines :: Set Name -- ^ Things defined in this module , ifsPublic :: Set Name -- ^ Subset of `ifsDefines` that is public , ifsDoc :: !(Maybe Text) -- ^ Documentation } deriving (Show, Generic, NFData) -- | Is this interface for a functor. ifaceIsFunctor :: IfaceG name -> Bool ifaceIsFunctor = not . Map.null . ifParams emptyIface :: ModName -> Iface emptyIface nm = Iface { ifNames = IfaceNames { ifsName = nm , ifsDefines = mempty , ifsPublic = mempty , ifsNested = mempty , ifsDoc = Nothing } , ifParams = mempty , ifDefines = mempty } -- | Declarations in a module. Note that this includes things from nested -- modules, but not things from nested functors, which are in `ifFunctors`. data IfaceDecls = IfaceDecls { ifTySyns :: Map.Map Name TySyn , ifNewtypes :: Map.Map Name Newtype , ifAbstractTypes :: Map.Map Name AbstractType , ifDecls :: Map.Map Name IfaceDecl , ifModules :: !(Map.Map Name (IfaceNames Name)) , ifSignatures :: !(Map.Map Name ModParamNames) , ifFunctors :: !(Map.Map Name (IfaceG Name)) {- ^ XXX: Maybe arg info? Also, with the current implementation we aim to complete remove functors by essentially inlining them. To achieve this with just interfaces we'd have to store here the entire module, not just its interface. At the moment we work around this by passing all loaded modules to the type checker, so it looks up functors there, instead of in the interfaces, but we'd need to change this if we want better support for separate compilation. -} } deriving (Show, Generic, NFData) filterIfaceDecls :: (Name -> Bool) -> IfaceDecls -> IfaceDecls filterIfaceDecls p ifs = IfaceDecls { ifTySyns = filterMap (ifTySyns ifs) , ifNewtypes = filterMap (ifNewtypes ifs) , ifAbstractTypes = filterMap (ifAbstractTypes ifs) , ifDecls = filterMap (ifDecls ifs) , ifModules = filterMap (ifModules ifs) , ifFunctors = filterMap (ifFunctors ifs) , ifSignatures = filterMap (ifSignatures ifs) } where filterMap :: Map.Map Name a -> Map.Map Name a filterMap = Map.filterWithKey (\k _ -> p k) ifaceDeclsNames :: IfaceDecls -> Set Name ifaceDeclsNames i = Set.unions [ Map.keysSet (ifTySyns i) , Map.keysSet (ifNewtypes i) , Map.keysSet (ifAbstractTypes i) , Map.keysSet (ifDecls i) , Map.keysSet (ifModules i) , Map.keysSet (ifFunctors i) , Map.keysSet (ifSignatures i) ] 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) , ifModules = Map.union (ifModules l) (ifModules r) , ifFunctors = Map.union (ifFunctors l) (ifFunctors r) , ifSignatures = ifSignatures l <> ifSignatures r } instance Monoid IfaceDecls where mempty = IfaceDecls { ifTySyns = mempty , ifNewtypes = mempty , ifAbstractTypes = mempty , ifDecls = mempty , ifModules = mempty , ifFunctors = mempty , ifSignatures = mempty } mappend = (<>) 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) , ifModules = Map.unions (map ifModules ds) , ifFunctors = Map.unions (map ifFunctors ds) , ifSignatures = Map.unions (map ifSignatures ds) } data IfaceDecl = IfaceDecl { ifDeclName :: !Name -- ^ Name of thing , ifDeclSig :: Schema -- ^ Type , ifDeclIsPrim :: !Bool , ifDeclPragmas :: [Pragma] -- ^ Pragmas , ifDeclInfix :: Bool -- ^ Is this an infix thing , ifDeclFixity :: Maybe Fixity -- ^ Fixity information , ifDeclDoc :: Maybe Text -- ^ Documentation } deriving (Show, Generic, NFData) -- | Produce a PrimMap from an interface. -- -- NOTE: the map will expose /both/ public and private names. -- NOTE: this is a bit misnamed, as it is used to resolve known names -- that Cryptol introduces (e.g., during type checking). These -- names need not be primitives. A better way to do this in the future -- might be to use original names instead (see #1522). ifacePrimMap :: Iface -> PrimMap ifacePrimMap = ifaceDeclsPrimMap . ifDefines ifaceDeclsPrimMap :: IfaceDecls -> PrimMap ifaceDeclsPrimMap IfaceDecls { .. } = PrimMap { primDecls = Map.fromList (newtypes ++ exprs) , primTypes = Map.fromList (newtypes ++ types) } where entry n = case asPrim n of Just pid -> (pid,n) Nothing -> panic "ifaceDeclsPrimMap" [ "Top level name not declared in a module?" , show n ] newtypes = map entry (Map.keys ifNewtypes) exprs = map entry (Map.keys ifDecls) types = map entry (Map.keys ifTySyns) -- | Given an interface computing a map from original names to actual names, -- grouped by namespace. ifaceOrigNameMap :: IfaceG name -> Map Namespace (Map OrigName Name) ifaceOrigNameMap ifa = Map.unionsWith Map.union (here : nested) where here = Map.fromList $ [ (NSValue, toMap vaNames) | not (Set.null vaNames) ] ++ [ (NSType, toMap tyNames) | not (Set.null tyNames) ] ++ [ (NSValue, toMap moNames) | not (Set.null moNames) ] nested = map ifaceOrigNameMap (Map.elems (ifFunctors decls)) toMap names = Map.fromList [ (og,x) | x <- Set.toList names, Just og <- [ asOrigName x ] ] decls = ifDefines ifa from f = Map.keysSet (f decls) tyNames = Set.unions [ from ifTySyns, from ifNewtypes, from ifAbstractTypes ] moNames = Set.unions [ from ifModules, from ifSignatures, from ifFunctors ] vaNames = Set.unions [ newtypeCons, from ifDecls ] newtypeCons = Set.fromList (map ntConName (Map.elems (ifNewtypes decls))) cryptol-3.0.0/src/Cryptol/ModuleSystem/Monad.hs0000644000000000000000000004700207346545000017651 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 #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BlockArguments #-} module Cryptol.ModuleSystem.Monad where import Cryptol.Eval (EvalEnv,EvalOpts(..)) import Cryptol.Backend.FFI (ForeignSrc) import Cryptol.Backend.FFI.Error import qualified Cryptol.Backend.Monad as E import Cryptol.ModuleSystem.Env import qualified Cryptol.ModuleSystem.Env as MEnv import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Name (FreshM(..),Supply) import Cryptol.ModuleSystem.Renamer (RenamerError(),RenamerWarning()) import Cryptol.ModuleSystem.NamingEnv(NamingEnv) import qualified Cryptol.Parser as Parser import qualified Cryptol.Parser.AST as P import Cryptol.Utils.Panic (panic) import qualified Cryptol.Parser.NoPat as NoPat import qualified Cryptol.Parser.ExpandPropGuards as ExpandPropGuards import qualified Cryptol.Parser.NoInclude as NoInc import qualified Cryptol.TypeCheck as T import qualified Cryptol.TypeCheck.AST as T import qualified Cryptol.TypeCheck.Solver.SMT as SMT import Cryptol.Parser.Position (Range, Located) import Cryptol.Utils.Ident (interactiveName, noModuleName) import Cryptol.Utils.PP import Cryptol.Utils.Logger(Logger) import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class import Control.Exception (IOException) import Data.ByteString (ByteString) import Data.Function (on) import Data.Functor.Identity import Data.Map (Map) import Data.Text.Encoding.Error (UnicodeException) import Data.Traversable 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) | FromSigImport (Located P.ModName) | 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)) FromSigImport l -> text "import of interface" <+> pp (P.thing l) 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 FromSigImport 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 | ExpandPropGuardsError ImportSource ExpandPropGuards.Error -- ^ Problems during the ExpandPropGuards phase | NoIncludeErrors ImportSource [NoInc.IncludeError] -- ^ Problems during the NoInclude phase | TypeCheckingFailed ImportSource T.NameMap [(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 | FFILoadErrors P.ModName [FFILoadError] -- ^ Errors loading foreign function implementations | 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` () ExpandPropGuardsError src err -> src `deepseq` err `deepseq` () NoIncludeErrors src errs -> src `deepseq` errs `deepseq` () TypeCheckingFailed nm src errs -> nm `deepseq` 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` () FFILoadErrors x errs -> x `deepseq` errs `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) ExpandPropGuardsError _src err -> pp err NoIncludeErrors _src errs -> vcat (map NoInc.ppIncludeError errs) TypeCheckingFailed _src nm errs -> vcat (map (T.ppNamedError nm) errs) ModuleNameMismatch expected found -> hang (text "[error]" <+> pp (P.srcRange found) <.> char ':') 4 (vcat [ text "File name does not match module name:" , text " Actual:" <+> 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 FFILoadErrors x errs -> hang (text "[error] Failed to load foreign implementations for module" <+> pp x <.> colon) 4 (vcat $ map pp errs) 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)) expandPropGuardsError :: ExpandPropGuards.Error -> ModuleM a expandPropGuardsError err = do src <- getImportSource ModuleT (raise (ExpandPropGuardsError src err)) noIncludeErrors :: [NoInc.IncludeError] -> ModuleM a noIncludeErrors errs = do src <- getImportSource ModuleT (raise (NoIncludeErrors src errs)) typeCheckingFailed :: T.NameMap -> [(Range,T.Error)] -> ModuleM a typeCheckingFailed nameMap errs = do src <- getImportSource ModuleT (raise (TypeCheckingFailed src nameMap 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)) ffiLoadErrors :: P.ModName -> [FFILoadError] -> ModuleM a ffiLoadErrors x errs = ModuleT (raise (FFILoadErrors x errs)) -- | 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 T.NameMap [(Range,T.Warning)] | RenamerWarnings [RenamerWarning] deriving (Show, Generic, NFData) instance PP ModuleWarning where ppPrec _ w = case w of TypeCheckWarnings nm ws -> vcat (map (T.ppNamedWarning nm) ws) RenamerWarnings ws -> vcat (map pp ws) warn :: [ModuleWarning] -> ModuleM () warn = ModuleT . put typeCheckWarnings :: T.NameMap -> [(Range,T.Warning)] -> ModuleM () typeCheckWarnings nameMap ws | null ws = return () | otherwise = warn [TypeCheckWarnings nameMap ws] renamerWarnings :: [RenamerWarning] -> ModuleM () renamerWarnings ws | null ws = return () | otherwise = warn [RenamerWarnings ws] -- Module System Monad --------------------------------------------------------- data RO m = RO { roLoading :: [ImportSource] , roEvalOpts :: m EvalOpts , roCallStacks :: Bool , roFileReader :: FilePath -> m ByteString , roTCSolver :: SMT.Solver } emptyRO :: ModuleInput m -> RO m emptyRO minp = RO { roLoading = [] , roEvalOpts = minpEvalOpts minp , roCallStacks = minpCallStacks minp , roFileReader = minpByteReader minp , roTCSolver = minpTCSolver minp } newtype ModuleT m a = ModuleT { unModuleT :: ReaderT (RO m) (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 = pure {-# INLINE (>>=) #-} m >>= f = ModuleT (unModuleT m >>= unModuleT . f) instance Fail.MonadFail m => Fail.MonadFail (ModuleT m) where {-# 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 data ModuleInput m = ModuleInput { minpCallStacks :: Bool , minpEvalOpts :: m EvalOpts , minpByteReader :: FilePath -> m ByteString , minpModuleEnv :: ModuleEnv , minpTCSolver :: SMT.Solver } runModuleT :: Monad m => ModuleInput m -> ModuleT m a -> m (Either ModuleError (a, ModuleEnv), [ModuleWarning]) runModuleT minp m = runWriterT $ runExceptionT $ runStateT (minpModuleEnv minp) $ runReaderT (emptyRO minp) $ unModuleT m type ModuleM = ModuleT IO runModuleM :: ModuleInput IO -> ModuleM a -> IO (Either ModuleError (a,ModuleEnv),[ModuleWarning]) runModuleM = runModuleT io :: BaseM m IO => IO a -> ModuleT m a io m = ModuleT (inBase m) getByteReader :: Monad m => ModuleT m (FilePath -> m ByteString) getByteReader = ModuleT $ do RO { roFileReader = readFileBytes } <- ask return readFileBytes getCallStacks :: Monad m => ModuleT m Bool getCallStacks = ModuleT (roCallStacks <$> ask) readBytes :: Monad m => FilePath -> ModuleT m ByteString readBytes fn = do fileReader <- getByteReader ModuleT $ lift $ lift $ lift $ lift $ fileReader fn getModuleEnv :: Monad m => ModuleT m ModuleEnv getModuleEnv = ModuleT get getTCSolver :: Monad m => ModuleT m SMT.Solver getTCSolver = ModuleT (roTCSolver <$> ask) 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 (LoadedModuleG T.TCTopEntity)) getLoadedMaybe mn = ModuleT $ do env <- get return (lookupTCEntity mn env) -- | This checks if the given name is loaded---it might refer to either -- a module or a signature. isLoaded :: P.ModName -> ModuleM Bool isLoaded mn = do env <- ModuleT get pure (MEnv.isLoaded mn (meLoadedModules env)) 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 new = src : roLoading ro -- check for recursive modules when (src `elem` roLoading ro) (raise (RecursiveModules new)) local ro { roLoading = new } (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) getIfaces :: ModuleM (Map P.ModName (Either T.ModParamNames Iface)) getIfaces = toMap <$> ModuleT get where toMap env = cvt <$> getLoadedEntities (meLoadedModules env) cvt ent = case ent of ALoadedInterface ifa -> Left (lmData ifa) ALoadedFunctor mo -> Right (lmdInterface (lmData mo)) ALoadedModule mo -> Right (lmdInterface (lmData mo)) 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) ] getAllLoaded :: ModuleM (P.ModName -> Maybe (T.ModuleG (), IfaceG ())) getAllLoaded = ModuleT do env <- get pure \nm -> do lm <- lookupModule nm env pure ( (lmModule lm) { T.mName = () } , ifaceForgetName (lmInterface lm) ) getAllLoadedSignatures :: ModuleM (P.ModName -> Maybe T.ModParamNames) getAllLoadedSignatures = ModuleT do env <- get pure \nm -> lmData <$> lookupSignature nm env 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 :: (forall a. LoadedModuleG a -> Bool) -> ModuleM () unloadModule rm = ModuleT $ do env <- get set $! env { meLoadedModules = removeLoadedModule rm (meLoadedModules env) } loadedModule :: ModulePath -> FileInfo -> NamingEnv -> Maybe ForeignSrc -> T.TCTopEntity -> ModuleM () loadedModule path fi nameEnv fsrc m = ModuleT $ do env <- get ident <- case path of InFile p -> unModuleT $ io (canonicalizePath p) InMem l _ -> pure l let newLM = case m of T.TCTopModule mo -> addLoadedModule path ident fi nameEnv fsrc mo T.TCTopSignature x s -> addLoadedSignature path ident fi nameEnv x s set $! env { meLoadedModules = newLM (meLoadedModules env) } modifyEvalEnvM :: Traversable t => (EvalEnv -> E.Eval (t EvalEnv)) -> ModuleM (t ()) modifyEvalEnvM f = ModuleT $ do env <- get let evalEnv = meEvalEnv env tenv <- inBase (E.runEval mempty (f evalEnv)) traverse (\evalEnv' -> set $! env { meEvalEnv = evalEnv' }) tenv modifyEvalEnv :: (EvalEnv -> E.Eval EvalEnv) -> ModuleM () modifyEvalEnv = fmap runIdentity . modifyEvalEnvM . (fmap Identity .) getEvalEnv :: ModuleM EvalEnv getEvalEnv = ModuleT (meEvalEnv `fmap` get) getEvalOptsAction :: ModuleM (IO EvalOpts) getEvalOptsAction = ModuleT (roEvalOpts `fmap` ask) getEvalOpts :: ModuleM EvalOpts getEvalOpts = do act <- getEvalOptsAction liftIO act getNewtypes :: ModuleM (Map T.Name T.Newtype) getNewtypes = ModuleT (loadedNewtypes <$> get) 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 getFocusedEnv :: ModuleM ModContext 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 } -- | 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-3.0.0/src/Cryptol/ModuleSystem/Name.hs0000644000000000000000000003340107346545000017471 0ustar0000000000000000-- | -- Module : Cryptol.ModuleSystem.Name -- Copyright : (c) 2015-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE RankNTypes #-} -- for the instances of RunM and BaseM {-# LANGUAGE UndecidableInstances #-} module Cryptol.ModuleSystem.Name ( -- * Names Name(), NameInfo(..) , NameSource(..) , nameUnique , nameIdent , mapNameIdent , nameInfo , nameLoc , nameFixity , nameNamespace , asPrim , asOrigName , nameModPath , nameModPathMaybe , nameTopModule , nameTopModuleMaybe , ppLocName , Namespace(..) , ModPath(..) , cmpNameDisplay -- ** Creation , mkDeclared , mkLocal , asLocal , mkModParam -- ** Unique Supply , FreshM(..), nextUniqueM , SupplyT(), runSupplyT, runSupply , Supply(), emptySupply, nextUnique , freshNameFor -- ** PrimMap , PrimMap(..) , lookupPrimDecl , lookupPrimType ) where import Control.DeepSeq import qualified Data.Map as Map import qualified Data.Monoid as M import Data.Functor.Identity(runIdentity) import GHC.Generics (Generic) import MonadLib import Prelude () import Prelude.Compat import qualified Data.Text as Text import Data.Char(isAlpha,toUpper) import Cryptol.Parser.Position (Range,Located(..)) import Cryptol.Utils.Fixity import Cryptol.Utils.Ident import Cryptol.Utils.Panic import Cryptol.Utils.PP data NameInfo = GlobalName NameSource OrigName | LocalName Namespace Ident deriving (Generic, NFData, Show) -- Names ----------------------------------------------------------------------- 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 , 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 by the way they would be displayed. -- This is used to order names nicely when showing what's in scope cmpNameDisplay :: NameDisp -> Name -> Name -> Ordering cmpNameDisplay disp l r = case (asOrigName l, asOrigName r) of (Just ogl, Just ogr) -> -- XXX: uses system name info? case cmpText (fmtPref ogl) (fmtPref ogr) of EQ -> cmpName l r cmp -> cmp (Nothing,Nothing) -> cmpName l r (Just ogl,Nothing) -> case cmpText (fmtPref ogl) (identText (nameIdent r)) of EQ -> GT cmp -> cmp (Nothing,Just ogr) -> case cmpText (identText (nameIdent l)) (fmtPref ogr) of EQ -> LT cmp -> cmp where cmpName xs ys = cmpIdent (nameIdent xs) (nameIdent ys) cmpIdent xs ys = cmpText (identText xs) (identText ys) --- let pfxl = fmtModName nsl (getNameFormat nsl (nameIdent l) disp) fmtPref og = case getNameFormat og disp of UnQualified -> "" Qualified q -> modNameToText q NotInScope -> let m = Text.pack (show (pp (ogModule og))) in case ogSource og of FromModParam q -> m <> "::" <> Text.pack (show (pp q)) _ -> m -- 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 parentheses. ppName :: Name -> Doc ppName nm = case nInfo nm of GlobalName _ og -> pp og LocalName _ i -> pp i <.> withPPCfg \cfg -> if ppcfgShowNameUniques cfg then "_" <.> int (nameUnique nm) else mempty instance PP Name where ppPrec _ = ppPrefixName instance PPName Name where ppNameFixity n = nameFixity n ppInfixName n | isInfixIdent (nameIdent n) = ppName n | otherwise = panic "Name" [ "Non-infix name used infix" , show (nameIdent n) ] ppPrefixName n = optParens (isInfixIdent (nameIdent n)) (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 nameInfo :: Name -> NameInfo nameInfo = nInfo nameIdent :: Name -> Ident nameIdent n = case nInfo n of GlobalName _ og -> ogName og LocalName _ i -> i mapNameIdent :: (Ident -> Ident) -> Name -> Name mapNameIdent f n = n { nInfo = case nInfo n of GlobalName x og -> GlobalName x og { ogName = f (ogName og) } LocalName x i -> LocalName x (f i) } nameNamespace :: Name -> Namespace nameNamespace n = case nInfo n of GlobalName _ og -> ogNamespace og LocalName ns _ -> ns nameLoc :: Name -> Range nameLoc = nLoc nameFixity :: Name -> Maybe Fixity nameFixity = nFixity -- | Primtiives must be in a top level module, at least for now. asPrim :: Name -> Maybe PrimIdent asPrim n = case nInfo n of GlobalName _ og | TopModule m <- ogModule og, not (ogFromModParam og) -> Just $ PrimIdent m $ identText $ ogName og _ -> Nothing asOrigName :: Name -> Maybe OrigName asOrigName n = case nInfo n of GlobalName _ og -> Just og LocalName {} -> Nothing -- | Get the module path for the given name. nameModPathMaybe :: Name -> Maybe ModPath nameModPathMaybe n = ogModule <$> asOrigName n -- | Get the module path for the given name. -- The name should be a top-level name. nameModPath :: Name -> ModPath nameModPath n = case nameModPathMaybe n of Just p -> p Nothing -> panic "nameModPath" [ "Not a top-level name: ", show n ] -- | Get the name of the top-level module that introduced this name. nameTopModuleMaybe :: Name -> Maybe ModName nameTopModuleMaybe = fmap topModuleFor . nameModPathMaybe -- | Get the name of the top-level module that introduced this name. -- Works only for top-level names (i.e., that have original names) nameTopModule :: Name -> ModName nameTopModule = topModuleFor . nameModPath -- 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 runSupply :: Supply -> (forall m. FreshM m => m a) -> (a,Supply) runSupply s m = runIdentity (runSupplyT 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 #-} -- | 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 -- XXX: do we have these anymore? 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 :: Namespace -> ModPath -> NameSource -> Ident -> Maybe Fixity -> Range -> Supply -> (Name,Supply) mkDeclared ns m sys ident fixity loc s = (name, s') where (u,s') = nextUnique s name = Name { nUnique = u , nFixity = fixity , nLoc = loc , nInfo = GlobalName sys OrigName { ogNamespace = ns , ogModule = m , ogName = ident , ogSource = FromDefinition } } -- | Make a new parameter name. mkLocal :: Namespace -> Ident -> Range -> Supply -> (Name,Supply) mkLocal ns ident loc s = (name, s') where (u,s') = nextUnique s name = Name { nUnique = u , nLoc = loc , nFixity = Nothing , nInfo = LocalName ns ident } {- | Make a local name derived from the given name. This is a bit questionable, but it is used by the translation to SAW Core -} asLocal :: Namespace -> Name -> Name asLocal ns x = case nameInfo x of GlobalName _ og -> x { nInfo = LocalName ns (ogName og) } LocalName {} -> x mkModParam :: ModPath {- ^ Module containing the parameter -} -> Ident {- ^ Name of the module parameter -} -> Range {- ^ Location -} -> Name {- ^ Name in the signature -} -> Supply -> (Name, Supply) mkModParam own pname rng n s = (name, s') where (u,s') = nextUnique s name = Name { nUnique = u , nInfo = GlobalName UserName OrigName { ogModule = own , ogName = nameIdent n , ogNamespace = nameNamespace n , ogSource = FromModParam pname } , nFixity = nFixity n , nLoc = rng } -- | This is used when instantiating functors freshNameFor :: ModPath -> Name -> Supply -> (Name,Supply) freshNameFor mpath x s = (newName, s1) where (u,s1) = nextUnique s newName = x { nUnique = u , nInfo = case nInfo x of GlobalName src og -> GlobalName src og { ogModule = mpath , ogSource = FromFunctorInst } LocalName {} -> panic "freshNameFor" ["Unexpected local",show x] } -- Prim Maps ------------------------------------------------------------------- -- | A mapping from an identifier defined in some module to its real name. data PrimMap = PrimMap { primDecls :: Map.Map PrimIdent Name , primTypes :: Map.Map PrimIdent Name } deriving (Show, Generic, NFData) instance Semigroup PrimMap where x <> y = PrimMap { primDecls = Map.union (primDecls x) (primDecls y) , primTypes = Map.union (primTypes x) (primTypes y) } lookupPrimDecl, lookupPrimType :: PrimIdent -> 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-3.0.0/src/Cryptol/ModuleSystem/Names.hs0000644000000000000000000000467607346545000017670 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE BlockArguments #-} module Cryptol.ModuleSystem.Names where import Data.Set(Set) import qualified Data.Set as Set import Control.DeepSeq(NFData) import GHC.Generics (Generic) import Cryptol.Utils.Panic (panic) import Cryptol.ModuleSystem.Name -- | A non-empty collection of names used by the renamer. data Names = One Name | Ambig (Set Name) -- ^ Non-empty deriving (Show,Generic,NFData) namesToList :: Names -> [Name] namesToList xs = case xs of One x -> [x] Ambig ns -> Set.toList ns anyOne :: Names -> Name anyOne = head . namesToList instance Semigroup Names where xs <> ys = case (xs,ys) of (One x, One y) | x == y -> One x | otherwise -> Ambig $! Set.fromList [x,y] (One x, Ambig as) -> Ambig $! Set.insert x as (Ambig as, One x) -> Ambig $! Set.insert x as (Ambig as, Ambig bs) -> Ambig $! Set.union as bs namesFromSet :: Set Name {- ^ Non-empty -} -> Names namesFromSet xs = case Set.minView xs of Just (a,ys) -> if Set.null ys then One a else Ambig xs Nothing -> panic "namesFromSet" ["empty set"] unionManyNames :: [Names] -> Maybe Names unionManyNames xs = case xs of [] -> Nothing _ -> Just (foldr1 (<>) xs) mapNames :: (Name -> Name) -> Names -> Names mapNames f xs = case xs of One x -> One (f x) Ambig as -> namesFromSet (Set.map f as) filterNames :: (Name -> Bool) -> Names -> Maybe Names filterNames p names = case names of One x -> if p x then Just (One x) else Nothing Ambig xs -> do let ys = Set.filter p xs (y,zs) <- Set.minView ys if Set.null zs then Just (One y) else Just (Ambig ys) travNames :: Applicative f => (Name -> f Name) -> Names -> f Names travNames f xs = case xs of One x -> One <$> f x Ambig as -> namesFromSet . Set.fromList <$> traverse f (Set.toList as) -- Names that are in the first but not the second diffNames :: Names -> Names -> Maybe Names diffNames x y = case x of One a -> case y of One b -> if a == b then Nothing else Just (One a) Ambig xs -> if a `Set.member` xs then Nothing else Just (One a) Ambig xs -> do (a,rest) <- Set.minView ys pure if Set.null rest then One a else Ambig xs where ys = case y of One z -> Set.delete z xs Ambig zs -> Set.difference xs zs cryptol-3.0.0/src/Cryptol/ModuleSystem/NamingEnv.hs0000644000000000000000000002564007346545000020501 0ustar0000000000000000-- | -- Module : Cryptol.ModuleSystem.NamingEnv -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Cryptol.ModuleSystem.NamingEnv where import Data.Maybe (mapMaybe,maybeToList) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set import Data.Foldable(foldl') import GHC.Generics (Generic) import Control.DeepSeq(NFData) import Cryptol.Utils.PP import Cryptol.Utils.Panic (panic) import Cryptol.Utils.Ident(allNamespaces) import Cryptol.Parser.AST import qualified Cryptol.TypeCheck.AST as T import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.Names import Cryptol.ModuleSystem.Interface -- | The 'NamingEnv' is used by the renamer to determine what -- identifiers refer to. newtype NamingEnv = NamingEnv (Map Namespace (Map PName Names)) deriving (Show,Generic,NFData) instance Monoid NamingEnv where mempty = NamingEnv Map.empty {-# INLINE mempty #-} instance Semigroup NamingEnv where NamingEnv l <> NamingEnv r = NamingEnv (Map.unionWith (Map.unionWith (<>)) l r) instance PP NamingEnv where ppPrec _ (NamingEnv mps) = vcat $ map ppNS $ Map.toList mps where ppNS (ns,xs) = nest 2 (vcat (pp ns : map ppNm (Map.toList xs))) ppNm (x,as) = pp x <+> "->" <+> commaSep (map pp (namesToList as)) {- | This "joins" two naming environments by matching the text name. The result maps the unique names from the first environment with the matching names in the second. This is used to compute the naming for an instantiated functor: * if the left environment has the defined names of the functor, and * the right one has the defined names of the instantiation, then * the result maps functor names to instance names. -} zipByTextName :: NamingEnv -> NamingEnv -> Map Name Name zipByTextName (NamingEnv k) (NamingEnv v) = Map.fromList $ doInter doNS k v where doInter :: Ord k => (a -> b -> [c]) -> Map k a -> Map k b -> [c] doInter f a b = concat (Map.elems (Map.intersectionWith f a b)) doNS :: Map PName Names -> Map PName Names -> [(Name,Name)] doNS as bs = doInter doPName as bs doPName :: Names -> Names -> [(Name,Name)] doPName xs ys = [ (x,y) | x <- namesToList xs, y <- namesToList ys ] -- NOTE: we'd exepct that there are no ambiguities in the environments. -- | Keep only the bindings in the 1st environment that are *NOT* in the second. without :: NamingEnv -> NamingEnv -> NamingEnv NamingEnv keep `without` NamingEnv remove = NamingEnv result where result = Map.differenceWith rmInNS keep remove rmInNS a b = let c = Map.differenceWith diffNames a b in if Map.null c then Nothing else Just c -- | All names mentioned in the environment namingEnvNames :: NamingEnv -> Set Name namingEnvNames (NamingEnv xs) = case unionManyNames (mapMaybe (unionManyNames . Map.elems) (Map.elems xs)) of Nothing -> Set.empty Just (One x) -> Set.singleton x Just (Ambig as) -> as -- | Get a unqualified naming environment for the given names namingEnvFromNames :: Set Name -> NamingEnv namingEnvFromNames xs = NamingEnv (foldl' add mempty xs) where add mp x = let ns = nameNamespace x txt = nameIdent x in Map.insertWith (Map.unionWith (<>)) ns (Map.singleton (mkUnqual txt) (One x)) mp -- | Get the names in a given namespace namespaceMap :: Namespace -> NamingEnv -> Map PName Names namespaceMap ns (NamingEnv env) = Map.findWithDefault Map.empty ns env -- | Resolve a name in the given namespace. lookupNS :: Namespace -> PName -> NamingEnv -> Maybe Names lookupNS ns x env = Map.lookup x (namespaceMap ns env) -- | Resolve a name in the given namespace. lookupListNS :: Namespace -> PName -> NamingEnv -> [Name] lookupListNS ns x env = case lookupNS ns x env of Nothing -> [] Just as -> namesToList as -- | Singleton renaming environment for the given namespace. singletonNS :: Namespace -> PName -> Name -> NamingEnv singletonNS ns pn n = NamingEnv (Map.singleton ns (Map.singleton pn (One n))) -- | Generate a mapping from 'PrimIdent' to 'Name' for a -- given naming environment. toPrimMap :: NamingEnv -> PrimMap toPrimMap env = PrimMap { primDecls = fromNS NSValue , primTypes = fromNS NSType } where fromNS ns = Map.fromList [ entry x | xs <- Map.elems (namespaceMap ns env) , x <- namesToList xs ] entry n = case asPrim n of Just p -> (p,n) Nothing -> panic "toPrimMap" [ "Not a declared name?" , show n ] -- | Generate a display format based on a naming environment. toNameDisp :: NamingEnv -> NameDisp toNameDisp env = NameDisp (`Map.lookup` names) where names = Map.fromList [ (og, qn) | ns <- allNamespaces , (pn,xs) <- Map.toList (namespaceMap ns env) , x <- namesToList xs , og <- maybeToList (asOrigName x) , let qn = case getModName pn of Just q -> Qualified q 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 -> Map Namespace (Set Name) visibleNames (NamingEnv env) = check <$> env where check mp = Set.fromList [ a | One a <- Map.elems mp ] -- | Qualify all symbols in a 'NamingEnv' with the given prefix. qualify :: ModName -> NamingEnv -> NamingEnv qualify pfx (NamingEnv env) = NamingEnv (Map.mapKeys toQual <$> env) where -- We don't qualify fresh names, because they should not be directly -- visible to the end users (i.e., they shouldn't really be exported) toQual (Qual _ n) = Qual pfx n toQual (UnQual n) = Qual pfx n toQual n@NewName{} = n filterPNames :: (PName -> Bool) -> NamingEnv -> NamingEnv filterPNames p (NamingEnv env) = NamingEnv (Map.mapMaybe checkNS env) where checkNS nsMap = let new = Map.filterWithKey (\n _ -> p n) nsMap in if Map.null new then Nothing else Just new filterUNames :: (Name -> Bool) -> NamingEnv -> NamingEnv filterUNames p (NamingEnv env) = NamingEnv (Map.mapMaybe check env) where check nsMap = let new = Map.mapMaybe (filterNames p) nsMap in if Map.null new then Nothing else Just new -- | Find the ambiguous entries in an environmet. -- A name is ambiguous if it might refer to multiple entities. findAmbig :: NamingEnv -> [ [Name] ] findAmbig (NamingEnv ns) = [ Set.toList xs | mp <- Map.elems ns , Ambig xs <- Map.elems mp ] -- | Get the subset of the first environment that shadows something -- in the second one. findShadowing :: NamingEnv -> NamingEnv -> [ (PName,Name,[Name]) ] findShadowing (NamingEnv lhs) rhs = [ (p, anyOne xs, namesToList ys) | (ns,mp) <- Map.toList lhs , (p,xs) <- Map.toList mp , Just ys <- [ lookupNS ns p rhs ] ] -- | Do an arbitrary choice for ambiguous names. -- We do this to continue checking afetr we've reported an ambiguity error. forceUnambig :: NamingEnv -> NamingEnv forceUnambig (NamingEnv mp) = NamingEnv (fmap (One . anyOne) <$> mp) -- | Like mappend, but when merging, prefer values on the lhs. shadowing :: NamingEnv -> NamingEnv -> NamingEnv shadowing (NamingEnv l) (NamingEnv r) = NamingEnv (Map.unionWith Map.union l r) mapNamingEnv :: (Name -> Name) -> NamingEnv -> NamingEnv mapNamingEnv f (NamingEnv mp) = NamingEnv (fmap (mapNames f) <$> mp) travNamingEnv :: Applicative f => (Name -> f Name) -> NamingEnv -> f NamingEnv travNamingEnv f (NamingEnv mp) = NamingEnv <$> traverse (traverse (travNames f)) mp isEmptyNamingEnv :: NamingEnv -> Bool isEmptyNamingEnv (NamingEnv mp) = Map.null mp -- This assumes that we've been normalizing away empty maps, hopefully -- we've been doing it everywhere. -- | Compute an unqualified naming environment, containing the various module -- parameters. modParamsNamingEnv :: T.ModParamNames -> NamingEnv modParamsNamingEnv T.ModParamNames { .. } = NamingEnv $ Map.fromList [ (NSValue, Map.fromList $ map fromFu $ Map.keys mpnFuns) , (NSType, Map.fromList $ map fromTS (Map.elems mpnTySyn) ++ map fromTy (Map.elems mpnTypes)) ] where toPName n = mkUnqual (nameIdent n) fromTy tp = let nm = T.mtpName tp in (toPName nm, One nm) fromFu f = (toPName f, One f) fromTS ts = (toPName (T.tsName ts), One (T.tsName ts)) -- | 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, mods, sigs ] where toPName n = mkUnqual (nameIdent n) exprs = mconcat [ singletonNS NSValue (toPName n) n | n <- Map.keys ifDecls ] tySyns = mconcat [ singletonNS NSType (toPName n) n | n <- Map.keys ifTySyns ] ntTypes = mconcat [ n | nt <- Map.elems ifNewtypes , let tname = T.ntName nt cname = T.ntConName nt , n <- [ singletonNS NSType (toPName tname) tname , singletonNS NSValue (toPName cname) cname ] ] absTys = mconcat [ singletonNS NSType (toPName n) n | n <- Map.keys ifAbstractTypes ] ntExprs = mconcat [ singletonNS NSValue (toPName n) n | n <- Map.keys ifNewtypes ] mods = mconcat [ singletonNS NSModule (toPName n) n | n <- Map.keys ifModules ] sigs = mconcat [ singletonNS NSModule (toPName n) n | n <- Map.keys ifSignatures ] -- | Adapt the things exported by something to the specific import/open. interpImportEnv :: ImportG name {- ^ The import declarations -} -> NamingEnv {- ^ All public things coming in -} -> NamingEnv interpImportEnv imp public = 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 = filterPNames (\qn -> not (getIdent qn `elem` ns)) public | Just (Only ns) <- iSpec imp = filterPNames (\qn -> getIdent qn `elem` ns) public | otherwise = public cryptol-3.0.0/src/Cryptol/ModuleSystem/Renamer.hs0000644000000000000000000014333607346545000020213 0ustar0000000000000000-- | -- Module : Cryptol.ModuleSystem.Renamer -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# Language RecordWildCards #-} {-# Language FlexibleInstances #-} {-# Language FlexibleContexts #-} {-# Language BlockArguments #-} {-# Language OverloadedStrings #-} module Cryptol.ModuleSystem.Renamer ( NamingEnv(), shadowing , BindsNames, InModule(..) , shadowNames , Rename(..), runRenamer, RenameM() , RenamerError(..) , RenamerWarning(..) , renameVar , renameType , renameModule , renameTopDecls , RenamerInfo(..) , NameType(..) , RenamedModule(..) ) where import Prelude () import Prelude.Compat import Data.Either(partitionEithers) import Data.Maybe(mapMaybe) import Data.List(find,groupBy,sortBy) import Data.Function(on) import Data.Foldable(toList) import Data.Map(Map) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.Graph(SCC(..)) import Data.Graph.SCC(stronglyConnComp) import MonadLib hiding (mapM, mapM_) import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.Names import Cryptol.ModuleSystem.NamingEnv import Cryptol.ModuleSystem.Exports import Cryptol.Parser.Position(Range) import Cryptol.Parser.AST import Cryptol.Parser.Selector(selName) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.RecordMap import Cryptol.Utils.Ident(allNamespaces,OrigName(..),modPathCommon, undefinedModName) import Cryptol.Utils.PP import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Renamer.Error import Cryptol.ModuleSystem.Binds import Cryptol.ModuleSystem.Renamer.Monad import Cryptol.ModuleSystem.Renamer.Imports import Cryptol.ModuleSystem.Renamer.ImplicitImports {- The Renamer Algorithm ===================== 1. Add implicit imports for visible nested modules 2. Compute what each module defines (see "Cryptol.ModuleSystem.Binds") - This assigns unique names to names introduces by various declarations - Here we detect repeated top-level definitions in a module. - Module instantiations also get a name, but are not yet resolved, so we don't know what's defined by them. - We do not generate unique names for functor parameters---those will be matched textually to the arguments when applied. - We *do* generate unique names for declarations in "signatures" * those are only really needed when renaming the signature (step 4) (e.g., to determine if a name refers to something declared in the signature or something else). * when validating a module against a signature the names of the declarations are matched textually, *not* using the unique names (e.g., `x` in a signature is matched with the thing named `x` in a module, even though these two `x`s will have different unique `id`s) 3. Resolve imports and instantiations (see "Cryptol.ModuleSystem.Imports") - Resolves names in submodule imports - Resolves functor instantiations: * generate new names for declarations in the functors. * this includes any nested modules, and things nested within them. - At this point we have enough information to know what's exported by each module. 4. Do the renaming (this module) - Using step 3 we compute the scoping environment for each module/signature - We traverse all declarations and replace the parser names with the corresponding names in scope: * Here we detect ambiguity and undefined errors * During this pass is also where we keep track of information of what names are used by declarations: - this is used to compute the dependencies between declarations - which are in turn used to order the declarations in dependency order * this is assumed by the TC * here we also report errors about invalid recursive dependencies * During this stage we also issue warning about unused type names (and we should probably do unused value names too one day) - During the rewriting we also do: - rebalance expression trees using the operator fixities - desugar record update notation -} -- | The result of renaming a module data RenamedModule = RenamedModule { rmModule :: Module Name -- ^ The renamed module , rmDefines :: NamingEnv -- ^ What this module defines , rmInScope :: NamingEnv -- ^ What's in scope in this module , rmImported :: IfaceDecls -- ^ Imported declarations. This provides the types for external -- names (used by the type-checker). } -- | Entry point. This is used for renaming a top-level module. renameModule :: Module PName -> RenameM RenamedModule renameModule m0 = do -- Step 1: add implicit imports let m = m0 { mDef = case mDef m0 of NormalModule ds -> NormalModule (addImplicitNestedImports ds) FunctorInstance f as i -> FunctorInstance f as i InterfaceModule s -> InterfaceModule s } -- Step 2: compute what's defined (defs,errs) <- liftSupply (modBuilder (topModuleDefs m)) mapM_ recordError errs -- Step 3: resolve imports extern <- getExternal resolvedMods <- liftSupply (resolveImports extern defs) let pathToName = Map.fromList [ (Nested (nameModPath x) (nameIdent x), x) | ImpNested x <- Map.keys resolvedMods ] let mname = ImpTop (thing (mName m)) setResolvedLocals resolvedMods $ setNestedModule pathToName do (ifs,(inScope,m1)) <- collectIfaceDeps (renameModule' mname m) env <- rmodDefines <$> lookupResolved mname pure RenamedModule { rmModule = m1 , rmDefines = env , rmInScope = inScope , rmImported = ifs -- XXX: maybe we should keep the nested defines too? } {- | Entry point. Rename a list of top-level declarations. This is used for declaration that don't live in a module (e.g., define on the command line.) We assume that these declarations do not contain any nested modules. -} renameTopDecls :: ModName -> [TopDecl PName] -> RenameM (NamingEnv,[TopDecl Name]) renameTopDecls m ds0 = do -- Step 1: add implicit imports let ds = addImplicitNestedImports ds0 -- Step 2: compute what's defined (defs,errs) <- liftSupply (modBuilder (topDeclsDefs (TopModule m) ds)) mapM_ recordError errs -- Step 3: resolve imports extern <- getExternal resolvedMods <- liftSupply (resolveImports extern (TopMod m defs)) let pathToName = Map.fromList [ (Nested (nameModPath x) (nameIdent x), x) | ImpNested x <- Map.keys resolvedMods ] setResolvedLocals resolvedMods $ setNestedModule pathToName do env <- rmodDefines <$> lookupResolved (ImpTop m) -- we already checked for duplicates in Step 2 ds1 <- shadowNames' CheckNone env (renameTopDecls' ds) -- record a use of top-level names to avoid -- unused name warnings let exports = exportedDecls ds1 mapM_ recordUse (exported NSType exports) pure (env,ds1) -------------------------------------------------------------------------------- -- Stuff below is related to Step 4 of the algorithm. class Rename f where rename :: f PName -> RenameM (f Name) -- | This is used for both top-level and nested modules. -- Returns: -- -- * Things defined in the module -- * Renamed module renameModule' :: ImpName Name {- ^ Resolved name for this module -} -> ModuleG mname PName -> RenameM (NamingEnv, ModuleG mname Name) renameModule' mname m = setCurMod case mname of ImpTop r -> TopModule r ImpNested r -> Nested (nameModPath r) (nameIdent r) do resolved <- lookupResolved mname shadowNames' CheckNone (rmodImports resolved) case mDef m of NormalModule ds -> do let env = rmodDefines resolved (paramEnv,params) <- shadowNames' CheckNone env (doModParams (mModParams m)) -- we check that defined names and ones that came -- from parameters do not clash, as this would be -- very confusing. shadowNames' CheckOverlap (env <> paramEnv) $ setModParams params do ds1 <- renameTopDecls' ds let exports = exportedDecls ds1 mapM_ recordUse (exported NSType exports) inScope <- getNamingEnv pure (inScope, m { mDef = NormalModule ds1 }) -- The things defined by this module are the *results* -- of the instantiation, so we should *not* add them -- in scope when resolving. FunctorInstance f as _ -> do f' <- rnLocated rename f as' <- rename as checkFunctorArgs as' let l = Just (srcRange f') imap <- mkInstMap l mempty (thing f') mname {- Now we need to compute what's "in scope" of the instantiated module. This is used when the module is loaded at the command line and users want to evalute things in the context of the module -} fuEnv <- if isFakeName (thing f') then pure mempty else lookupDefines (thing f') let ren x = Map.findWithDefault x x imap -- XXX: This is not quite right as it only considers the things -- defined in the module to be in scope. It misses things -- that are *imported* by the functor, in particular the Cryptol -- library -- is missing. See #1455. inScope <- shadowNames' CheckNone (mapNamingEnv ren fuEnv) getNamingEnv pure (inScope, m { mDef = FunctorInstance f' as' imap }) InterfaceModule s -> shadowNames' CheckNone (rmodDefines resolved) do d <- InterfaceModule <$> renameIfaceModule mname s inScope <- getNamingEnv pure (inScope, m { mDef = d }) checkFunctorArgs :: ModuleInstanceArgs Name -> RenameM () checkFunctorArgs args = case args of DefaultInstAnonArg {} -> panic "checkFunctorArgs" ["Nested DefaultInstAnonArg"] DefaultInstArg l -> checkArg l NamedInstArgs as -> mapM_ checkNamedArg as where checkNamedArg (ModuleInstanceNamedArg _ l) = checkArg l checkArg l = case thing l of ModuleArg m | isFakeName m -> pure () | otherwise -> checkIsModule (srcRange l) m AModule ParameterArg {} -> pure () -- we check these in the type checker AddParams -> pure () mkInstMap :: Maybe Range -> Map Name Name -> ImpName Name -> ImpName Name -> RenameM (Map Name Name) mkInstMap checkFun acc0 ogname iname | isFakeName ogname = pure Map.empty | otherwise = do case checkFun of Nothing -> pure () Just r -> checkIsModule r ogname AFunctor (onames,osubs) <- lookupDefinesAndSubs ogname inames <- lookupDefines iname let mp = zipByTextName onames inames subs = [ (ImpNested k, ImpNested v) | k <- Set.toList osubs, Just v <- [Map.lookup k mp] ] foldM doSub (Map.union mp acc0) subs where doSub acc (k,v) = mkInstMap Nothing acc k v -- | This is used to rename local declarations (e.g. `where`) renameDecls :: [Decl PName] -> RenameM [Decl Name] renameDecls ds = do (ds1,deps) <- depGroup (traverse rename ds) let toNode d = let x = NamedThing (declName d) in ((d,x), x, map NamedThing $ Set.toList $ Map.findWithDefault Set.empty x deps) ordered = toList (stronglyConnComp (map toNode ds1)) fromSCC x = case x of AcyclicSCC (d,_) -> pure [d] CyclicSCC ds_xs -> let (rds,xs) = unzip ds_xs in case mapM validRecursiveD rds of Nothing -> do recordError (InvalidDependency xs) pure rds Just bs -> do checkSameModule xs pure [DRec bs] concat <$> mapM fromSCC ordered -- | Rename declarations in a signature (i.e., type/prop synonyms) renameSigDecls :: [SigDecl PName] -> RenameM [SigDecl Name] renameSigDecls ds = do (ds1,deps) <- depGroup (traverse rename ds) let toNode d = let nm = case d of SigTySyn ts _ -> thing (tsName ts) SigPropSyn ps _ -> thing (psName ps) x = NamedThing nm in ((d,x), x, map NamedThing $ Set.toList $ Map.findWithDefault Set.empty x deps) ordered = toList (stronglyConnComp (map toNode ds1)) fromSCC x = case x of AcyclicSCC (d,_) -> pure [d] CyclicSCC ds_xs -> do let (rds,xs) = unzip ds_xs recordError (InvalidDependency xs) pure rds concat <$> mapM fromSCC ordered validRecursiveD :: Decl name -> Maybe (Bind name) validRecursiveD d = case d of DBind b -> Just b DLocated d' _ -> validRecursiveD d' _ -> Nothing checkSameModule :: [DepName] -> RenameM () checkSameModule xs = case ms of a : as | let bad = [ fst b | b <- as, snd a /= snd b ] , not (null bad) -> recordError (InvalidDependency $ map NamedThing $ fst a : bad) _ -> pure () where ms = [ (x,ogModule og) | NamedThing x <- xs, GlobalName _ og <- [ nameInfo x ] ] {- NOTE: Dependencies on Top Level Constraints =========================================== For the new module system, things using a parameter depend on the parameter declaration (i.e., `import signature`), which depends on the signature, so dependencies on constraints in there should be OK. However, we'd like to have a mechanism for declaring top level constraints in a functor, that can impose constraints across types from *different* parameters. For the moment, we reuse `parameter type constraint C` for this. Such constraints need to be: 1. After the signature import 2. After any type synonyms/newtypes using the parameters 3. Before any value or type declarations that need to use the parameters. Note that type declarations used by a constraint cannot use the constraint, so they need to be well formed without it. For other types, we use the following rule to determine if they use a constraint: If: 1. We have a constraint and type declaration 2. They both mention the same type parameter 3. There is no explicit dependency of the constraint on the DECL Then: The type declaration depends on the constraint. Example: type T = 10 // Does not depend on anything so can go first signature A where type n : # import signature A // Depends on A, so need to be after A parameter type constraint n > T // Depends on the import (for @n@) and T type Q = [n-T] // Depends on the top-level constraint -} -- This assumes imports have already been processed renameTopDecls' :: [TopDecl PName] -> RenameM [TopDecl Name] renameTopDecls' ds = do -- rename and compute what names we depend on (ds1,deps) <- depGroup (traverse rename ds) fromParams <- getNamesFromModParams localParams <- getLocalModParamDeps let rawDepsFor x = Map.findWithDefault Set.empty x deps isTyParam x = nameNamespace x == NSType && x `Map.member` fromParams (noNameDs,nameDs) = partitionEithers (map topDeclName ds1) ctrs = [ nm | (_,nm@(ConstratintAt {}),_) <- nameDs ] indirect = Map.fromList [ (y,x) | (_,x,ys) <- nameDs, y <- ys ] mkDepName x = case Map.lookup x fromParams of Just dn -> dn Nothing -> NamedThing x depsFor x = [ Map.findWithDefault (mkDepName y) (NamedThing y) indirect | y <- Set.toList (Map.findWithDefault Set.empty x deps) ] {- See [NOTE: Dependencies on Top Level Constraints] -} addCtr nm ctr = case nm of NamedThing x | nameNamespace x == NSType , let ctrDeps = rawDepsFor ctr tyDeps = rawDepsFor nm , not (x `Set.member` ctrDeps) , not (Set.null (Set.intersection (Set.filter isTyParam ctrDeps) (Set.filter isTyParam tyDeps))) -> Just ctr _ -> Nothing addCtrs (d,x) | usesCtrs d = ctrs | otherwise = mapMaybe (addCtr x) ctrs addModParams d = case d of DModule tl | NestedModule m <- tlValue tl , FunctorInstance _ as _ <- mDef m -> case as of DefaultInstArg arg -> depsOfArg arg NamedInstArgs args -> concatMap depsOfNamedArg args DefaultInstAnonArg {} -> [] where depsOfNamedArg (ModuleInstanceNamedArg _ a) = depsOfArg a depsOfArg a = case thing a of AddParams -> [] ModuleArg {} -> [] ParameterArg p -> case Map.lookup p localParams of Just i -> [i] Nothing -> [] _ -> [] toNode (d,x,_) = ((d,x),x, addCtrs (d,x) ++ addModParams d ++ depsFor x) ordered = stronglyConnComp (map toNode nameDs) fromSCC x = case x of AcyclicSCC (d,_) -> pure [d] CyclicSCC ds_xs -> let (rds,xs) = unzip ds_xs in case mapM valid rds of Nothing -> do recordError (InvalidDependency xs) pure rds Just bs -> do checkSameModule xs pure [Decl TopLevel { tlDoc = Nothing , tlExport = Public , tlValue = DRec bs }] where valid d = case d of Decl tl -> validRecursiveD (tlValue tl) _ -> Nothing rds <- mapM fromSCC ordered pure (concat (noNameDs:rds)) where -- This indicates if a declaration might depend on the constraints in scope. -- Since uses of constraints are not implicitly named, value declarations -- are assumed to potentially use the constraints. -- XXX: This is inaccurate, and *I think* it amounts to checking that something -- is in the value namespace. Perhaps the rule should be that a value -- depends on a parameter constraint if it mentions at least one -- type parameter somewhere. -- XXX: Besides, types might need constraints for well-formedness... -- This is just bogus -- Although not that type/prop synonyms may be defined wherever as they -- keep the validity constraints they need and emit them at the *use* sites. usesCtrs td = case td of Decl tl -> isValDecl (tlValue tl) DPrimType {} -> False TDNewtype {} -> False DParamDecl {} -> False DInterfaceConstraint {} -> False DModule tl -> any usesCtrs (mDecls m) where NestedModule m = tlValue tl DImport {} -> False DModParam {} -> False -- no definitions here Include {} -> bad "Include" isValDecl d = case d of DLocated d' _ -> isValDecl d' DBind {} -> True DRec {} -> True DType {} -> False DProp {} -> False DSignature {} -> bad "DSignature" DFixity {} -> bad "DFixity" DPragma {} -> bad "DPragma" DPatBind {} -> bad "DPatBind" bad msg = panic "renameTopDecls'" [msg] declName :: Decl Name -> Name declName decl = case decl of DLocated d _ -> declName d DBind b -> thing (bName b) DType (TySyn x _ _ _) -> thing x DProp (PropSyn x _ _ _) -> thing x DSignature {} -> bad "DSignature" DFixity {} -> bad "DFixity" DPragma {} -> bad "DPragma" DPatBind {} -> bad "DPatBind" DRec {} -> bad "DRec" where bad x = panic "declName" [x] topDeclName :: TopDecl Name -> Either (TopDecl Name) (TopDecl Name, DepName, [DepName]) topDeclName topDecl = case topDecl of Decl d -> hasName (declName (tlValue d)) DPrimType d -> hasName (thing (primTName (tlValue d))) TDNewtype d -> hasName' (thing (nName (tlValue d))) [ nConName (tlValue d) ] DModule d -> hasName (thing (mName m)) where NestedModule m = tlValue d DInterfaceConstraint _ ds -> special (ConstratintAt (srcRange ds)) DImport {} -> noName DModParam m -> special (ModParamName (srcRange (mpSignature m)) (mpName m)) Include {} -> bad "Include" DParamDecl {} -> bad "DParamDecl" where noName = Left topDecl hasName n = hasName' n [] hasName' n ms = Right (topDecl, NamedThing n, map NamedThing ms) special x = Right (topDecl, x, []) bad x = panic "topDeclName" [x] {- | Compute the names introduced by a module parameter. This should be run in a context containing everything that's in scope except for the module parameters. We don't need to compute a fixed point here because the signatures (and hence module parameters) cannot contain signatures. The resulting naming environment contains the new names introduced by this parameter. -} doModParam :: ModParam PName -> RenameM (NamingEnv, RenModParam) doModParam mp = do let sigName = mpSignature mp loc = srcRange sigName withLoc loc do me <- getCurMod (sigName',isFake) <- case thing sigName of ImpTop t -> pure (ImpTop t, False) -- XXX: should we record a dependency here? -- Not sure what the dependencies are for.. ImpNested n -> do mb <- resolveNameMaybe NameUse NSModule n (nm,isFake) <- case mb of Just rnm -> pure (rnm,False) Nothing -> do rnm <- reportUnboundName NSModule n pure (rnm,True) case modPathCommon me (nameModPath nm) of Just (_,[],_) -> recordError (InvalidDependency [ModPath me, NamedThing nm]) _ -> pure () pure (ImpNested nm, isFake) unless isFake (checkIsModule (srcRange sigName) sigName' ASignature) sigEnv <- if isFake then pure mempty else lookupDefines sigName' {- XXX: It seems a bit odd to use "newModParam" for the names to be used for the instantiated type synonyms, but what other name could we use? -} let newP x = do y <- lift (newModParam me (mpName mp) loc x) sets_ (Map.insert y x) pure y (newEnv',nameMap) <- runStateT Map.empty (travNamingEnv newP sigEnv) let paramName = mpAs mp let newEnv = case paramName of Nothing -> newEnv' Just q -> qualify q newEnv' pure ( newEnv , RenModParam { renModParamName = mpName mp , renModParamRange = loc , renModParamSig = sigName' , renModParamInstance = nameMap } ) {- | Process the parameters of a module. Should be executed in a context where everything's already in the context, except the module parameters. -} doModParams :: [ModParam PName] -> RenameM (NamingEnv, [RenModParam]) doModParams srcParams = do (paramEnvs,params) <- unzip <$> mapM doModParam srcParams let repeated = groupBy ((==) `on` renModParamName) $ sortBy (compare `on` renModParamName) params forM_ repeated \ps -> case ps of [_] -> pure () ~(p : _) -> recordError (MultipleModParams (renModParamName p) (map renModParamRange ps)) pure (mconcat paramEnvs,params) -------------------------------------------------------------------------------- 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 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) DModule m -> DModule <$> traverse rename m DImport li -> DImport <$> renI li DModParam mp -> DModParam <$> rename mp DInterfaceConstraint d ds -> depsOf (ConstratintAt (srcRange ds)) (DInterfaceConstraint d <$> rnLocated (mapM rename) ds) DParamDecl {} -> panic "rename" ["DParamDecl"] renI :: Located (ImportG (ImpName PName)) -> RenameM (Located (ImportG (ImpName Name))) renI li = withLoc (srcRange li) do m <- rename (iModule i) unless (isFakeName m) (recordImport (srcRange li) m) pure li { thing = i { iModule = m } } where i = thing li instance Rename ModParam where rename mp = do x <- rnLocated rename (mpSignature mp) depsOf (ModParamName (srcRange (mpSignature mp)) (mpName mp)) do ren <- renModParamInstance <$> getModParam (mpName mp) {- Here we add 2 "uses" to all type-level names introduced, so that we don't get unused warnings for type parameters. -} mapM_ recordUse [ s | t <- Map.keys ren, nameNamespace t == NSType , s <- [t,t] ] pure mp { mpSignature = x, mpRenaming = ren } renameIfaceModule :: ImpName Name -> Signature PName -> RenameM (Signature Name) renameIfaceModule nm sig = do env <- rmodDefines <$> lookupResolved nm let depName = case nm of ImpNested n -> NamedThing n ImpTop t -> ModPath (TopModule t) shadowNames' CheckOverlap env $ depsOf depName do imps <- traverse renI (sigImports sig) tps <- traverse rename (sigTypeParams sig) ds <- renameSigDecls (sigDecls sig) cts <- traverse (rnLocated rename) (sigConstraints sig) fun <- traverse rename (sigFunParams sig) -- we record a use here to avoid getting a warning in interfaces -- that declare only types, and so appear "unused". forM_ tps \tp -> recordUse (thing (ptName tp)) forM_ ds \d -> recordUse $ case d of SigTySyn ts _ -> thing (tsName ts) SigPropSyn ps _ -> thing (psName ps) pure Signature { sigImports = imps , sigTypeParams = tps , sigDecls = ds , sigConstraints = cts , sigFunParams = fun } instance Rename ImpName where rename i = case i of ImpTop m -> pure (ImpTop m) ImpNested m -> ImpNested <$> resolveName NameUse NSModule m instance Rename ModuleInstanceArgs where rename args = case args of DefaultInstArg a -> DefaultInstArg <$> rnLocated rename a NamedInstArgs xs -> NamedInstArgs <$> traverse rename xs DefaultInstAnonArg {} -> panic "rename" ["DefaultInstAnonArg"] instance Rename ModuleInstanceNamedArg where rename (ModuleInstanceNamedArg x m) = ModuleInstanceNamedArg x <$> rnLocated rename m instance Rename ModuleInstanceArg where rename arg = case arg of ModuleArg m -> ModuleArg <$> rename m ParameterArg a -> pure (ParameterArg a) AddParams -> pure AddParams instance Rename NestedModule where rename (NestedModule m) = do let lnm = mName m nm = thing lnm n <- resolveName NameBind NSModule nm depsOf (NamedThing n) do -- XXX: we should store in scope somewhere if we want to browse -- nested modules properly let m' = m { mName = ImpNested <$> mName m } (_inScope,m1) <- renameModule' (ImpNested n) m' pure (NestedModule m1 { mName = lnm { thing = n } }) instance Rename PrimType where rename pt = do x <- rnLocated (renameType NameBind) (primTName pt) depsOf (NamedThing (thing x)) do let (as,ps) = primTCts pt (_,cts) <- renameQual as ps $ \as' ps' -> pure (as',ps') -- Record an additional use for each parameter since we checked -- earlier that all the parameters are used exactly once in the -- body of the signature. This prevents incorrect warnings -- about unused names. mapM_ (recordUse . tpName) (fst cts) pure pt { primTCts = cts, primTName = x } instance Rename ParameterType where rename a = do n' <- rnLocated (renameType NameBind) (ptName a) return a { ptName = n' } instance Rename ParameterFun where rename a = do n' <- rnLocated (renameVar NameBind) (pfName a) depsOf (NamedThing (thing n')) do sig' <- renameSchema (pfSchema a) return a { pfName = n', pfSchema = snd sig' } instance Rename SigDecl where rename decl = case decl of SigTySyn ts mb -> SigTySyn <$> rename ts <*> pure mb SigPropSyn ps mb -> SigPropSyn <$> rename ps <*> pure mb instance Rename Decl where rename d = case d of DBind b -> DBind <$> rename b DType syn -> DType <$> rename syn DProp syn -> DProp <$> rename syn DLocated d' r -> withLoc r $ DLocated <$> rename d' <*> pure r DFixity{} -> panic "rename" [ "DFixity" ] DSignature {} -> panic "rename" [ "DSignature" ] DPragma {} -> panic "rename" [ "DPragma" ] DPatBind {} -> panic "rename" [ "DPatBind " ] DRec {} -> panic "rename" [ "DRec" ] instance Rename Newtype where rename n = shadowNames (nParams n) $ do nameT <- rnLocated (renameType NameBind) (nName n) nameC <- renameVar NameBind (nConName n) depsOf (NamedThing nameC) (addDep (thing nameT)) depsOf (NamedThing (thing nameT)) $ do ps' <- traverse rename (nParams n) body' <- traverse (traverse rename) (nBody n) return Newtype { nName = nameT , nConName = nameC , nParams = ps' , nBody = body' } -- | Try to resolve a name resolveNameMaybe :: NameType -> Namespace -> PName -> RenameM (Maybe Name) resolveNameMaybe nt expected qn = do ro <- RenameM ask let lkpIn here = Map.lookup qn (namespaceMap here (roNames ro)) use = case expected of NSType -> recordUse _ -> const (pure ()) case lkpIn expected of Just xs -> case xs of One n -> do case nt of NameBind -> pure () NameUse -> addDep n use n -- for warning return (Just n) Ambig symSet -> do let syms = Set.toList symSet mapM_ use syms -- mark as used to avoid unused warnings n <- located qn recordError (MultipleSyms n syms) return (Just (head syms)) Nothing -> pure Nothing reportUnboundName :: Namespace -> PName -> RenameM Name reportUnboundName expected qn = do ro <- RenameM ask let lkpIn here = Map.lookup qn (namespaceMap here (roNames ro)) others = [ ns | ns <- allNamespaces , ns /= expected , Just _ <- [lkpIn ns] ] nm <- located qn case others of -- name exists in a different namespace actual : _ -> recordError (WrongNamespace expected actual nm) -- the value is just missing [] -> recordError (UnboundName expected nm) mkFakeName expected qn isFakeName :: ImpName Name -> Bool isFakeName m = case m of ImpTop x -> x == undefinedModName ImpNested x -> case nameTopModuleMaybe x of Just y -> y == undefinedModName Nothing -> False -- | Resolve a name, and report error on failure resolveName :: NameType -> Namespace -> PName -> RenameM Name resolveName nt expected qn = do mb <- resolveNameMaybe nt expected qn case mb of Just n -> pure n Nothing -> reportUnboundName expected qn renameVar :: NameType -> PName -> RenameM Name renameVar nt = resolveName nt NSValue renameType :: NameType -> PName -> RenameM Name renameType nt = resolveName nt NSType -- | Assuming an error has been recorded already, construct a fake name that's -- not expected to make it out of the renamer. mkFakeName :: Namespace -> PName -> RenameM Name mkFakeName ns pn = do ro <- RenameM ask liftSupply (mkDeclared ns (TopModule undefinedModName) SystemName (getIdent pn) Nothing (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 (defsOf 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 NameBind tpName return TParam { tpName = n, .. } instance Rename Prop where rename (CType t) = CType <$> rename t instance Rename Type where rename ty0 = case ty0 of TFun a b -> TFun <$> rename a <*> rename b TSeq n a -> TSeq <$> rename n <*> rename a TBit -> return TBit TNum c -> return (TNum c) TChar c -> return (TChar c) TUser qn ps -> TUser <$> renameType NameUse qn <*> traverse rename ps TTyApp fs -> TTyApp <$> traverse (traverse rename) fs TRecord fs -> TRecord <$> traverse (traverse rename) fs TTuple fs -> TTuple <$> traverse rename fs TWild -> return TWild TLocated t' r -> withLoc r (TLocated <$> rename t' <*> pure r) TParens t' k -> (`TParens` k) <$> rename t' TInfix a o _ b -> do o' <- renameTypeOp o a' <- rename a b' <- rename b mkTInfix a' o' b' mkTInfix :: Type Name -> (Located Name, Fixity) -> Type Name -> RenameM (Type Name) mkTInfix t@(TInfix x o1 f1 y) op@(o2,f2) z = case compareFixity f1 f2 of FCLeft -> return (TInfix t o2 f2 z) FCRight -> do r <- mkTInfix y op z return (TInfix x o1 f1 r) FCError -> do recordError (FixityError o1 f1 o2 f2) return (TInfix t o2 f2 z) mkTInfix (TLocated t' _) op z = mkTInfix t' op z mkTInfix t (o,f) z = return (TInfix t o f z) -- | Rename a binding. instance Rename Bind where rename b = do n' <- rnLocated (renameVar NameBind) (bName b) depsOf (NamedThing (thing n')) do 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 DForeign = return DForeign rename (DExpr e) = DExpr <$> rename e rename (DPropGuards cases) = DPropGuards <$> traverse rename cases instance Rename PropGuardCase where rename g = PropGuardCase <$> traverse (rnLocated rename) (pgcProps g) <*> rename (pgcExpr g) -- NOTE: this only renames types within the pattern. instance Rename Pattern where rename p = case p of PVar lv -> PVar <$> rnLocated (renameVar NameBind) lv PWild -> pure PWild PTuple ps -> PTuple <$> traverse rename ps PRecord nps -> PRecord <$> traverse (traverse 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 emptyFunDesc [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 FunDesc where rename (FunDesc nm offset) = do nm' <- traverse (renameVar NameBind) nm pure (FunDesc nm' offset) instance Rename Expr where rename expr = case expr of EVar n -> EVar <$> renameVar NameUse n ELit l -> return (ELit l) EGenerate e -> EGenerate <$> rename e ETuple es -> ETuple <$> traverse rename es ERecord fs -> ERecord <$> traverse (traverse 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 EFromToBy isStrict s e b t -> EFromToBy isStrict <$> rename s <*> rename e <*> rename b <*> traverse rename t EFromToDownBy isStrict s e b t -> EFromToDownBy isStrict <$> rename s <*> rename e <*> rename b <*> traverse rename t EFromToLessThan s e t -> EFromToLessThan <$> rename s <*> 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 -> shadowNames (map (InModule Nothing) ds) $ EWhere <$> rename e' <*> renameDecls ds ETyped e' ty -> ETyped <$> rename e' <*> rename ty ETypeVal ty -> ETypeVal<$> rename ty EFun desc ps e' -> do desc' <- rename desc (env,ps') <- renamePats ps -- NOTE: renamePats will generate warnings, so we don't -- need to duplicate them here shadowNames' CheckNone env (EFun desc' 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' EPrefix op e -> EPrefix op <$> rename e 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' -> recordError (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 recordError (FixityError o1 f1 o2 f2) return (EInfix e o2 f2 z) mkEInfix e@(EPrefix o1 x) op@(o2, f2) y = case compareFixity (prefixFixity o1) f2 of FCRight -> do let warning = PrefixAssocChanged o1 x o2 f2 y RenameM $ sets_ (\rw -> rw {rwWarnings = warning : rwWarnings rw}) r <- mkEInfix x op y return (EPrefix o1 r) -- Even if the fixities conflict, we make the prefix operator take -- precedence. _ -> return (EInfix e o2 f2 y) -- Note that for prefix operator on RHS of infix operator we make the prefix -- operator always have precedence, so we allow a * -b instead of requiring -- a * (-b). 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 NameUse (thing ln) fixity <- lookupFixity n return (ln { thing = n }, fixity) renameTypeOp :: Located PName -> RenameM (Located Name, Fixity) renameTypeOp ln = withLoc ln $ do n <- renameType NameUse (thing ln) fixity <- lookupFixity n return (ln { thing = n }, fixity) lookupFixity :: Name -> RenameM Fixity lookupFixity n = case nameFixity n of Just fixity -> return fixity Nothing -> return defaultFixity -- FIXME: should we raise an error instead? 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 be <- liftSupply (defsOf (InModule Nothing 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 (mkLocal NSValue (getIdent thing) srcRange) -- XXX: for deps, we should record a use return (singletonNS NSValue thing n) go PWild = return mempty go (PTuple ps) = bindVars ps go (PRecord fs) = bindVars (fmap snd (recordElements 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 <- resolveNameMaybe NameUse NSType 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 (mkLocal NSType (getIdent pn) loc) return (singletonNS NSType 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 recordError (UnboundName NSType (Located loc pn)) n <- liftSupply (mkLocal NSType (getIdent pn) loc) return (singletonNS NSType pn n) typeEnv (TRecord fs) = bindTypes (map snd (recordElements fs)) typeEnv (TTyApp 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 -> shadowNames (InModule Nothing b) (MatchLet <$> rename b) instance Rename TySyn where rename (TySyn n f ps ty) = shadowNames ps do n' <- rnLocated (renameType NameBind) n depsOf (NamedThing (thing n')) $ TySyn n' <$> pure f <*> traverse rename ps <*> rename ty instance Rename PropSyn where rename (PropSyn n f ps cs) = shadowNames ps do n' <- rnLocated (renameType NameBind) n PropSyn n' <$> pure f <*> traverse rename ps <*> traverse rename cs -------------------------------------------------------------------------------- instance PP RenamedModule where ppPrec _ rn = updPPCfg (\cfg -> cfg { ppcfgShowNameUniques = True }) doc where doc = vcat [ "// --- Defines -----------------------------" , pp (rmDefines rn) , "// --- In scope ----------------------------" , pp (rmInScope rn) , "// -- Module -------------------------------" , pp (rmModule rn) , "// -----------------------------------------" ] cryptol-3.0.0/src/Cryptol/ModuleSystem/Renamer/0000755000000000000000000000000007346545000017645 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/ModuleSystem/Renamer/Error.hs0000644000000000000000000002052207346545000021273 0ustar0000000000000000-- | -- Module : Cryptol.ModuleSystem.Renamer -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# Language DeriveGeneric, DeriveAnyClass #-} {-# Language OverloadedStrings #-} module Cryptol.ModuleSystem.Renamer.Error where import Data.List(intersperse) import Cryptol.ModuleSystem.Name import Cryptol.Parser.AST import Cryptol.Parser.Position import Cryptol.Parser.Selector(ppNestedSels) import Cryptol.Utils.PP import Cryptol.Utils.Ident(modPathSplit) import GHC.Generics (Generic) import Control.DeepSeq import Prelude () import Prelude.Compat -- Errors ---------------------------------------------------------------------- data RenamerError = MultipleSyms (Located PName) [Name] -- ^ Multiple imported symbols contain this name | UnboundName Namespace (Located PName) -- ^ Some name not bound to any definition | OverlappingSyms [Name] -- ^ An environment has produced multiple overlapping symbols | WrongNamespace Namespace Namespace (Located PName) -- ^ expected, actual. -- When a name is missing from the expected namespace, but exists in another | FixityError (Located Name) Fixity (Located Name) Fixity -- ^ When the fixity of two operators conflict | OverlappingRecordUpdate (Located [Selector]) (Located [Selector]) -- ^ When record updates overlap (e.g., @{ r | x = e1, x.y = e2 }@) | InvalidDependency [DepName] -- ^ Things that can't depend on each other | MultipleModParams Ident [Range] -- ^ Module parameters with the same name | InvalidFunctorImport (ImpName Name) -- ^ Can't import functors directly | UnexpectedNest Range PName -- ^ Nested modules were not supposed to appear here | ModuleKindMismatch Range (ImpName Name) ModKind ModKind -- ^ Exepcted one kind (first one) but found the other (second one) deriving (Show, Generic, NFData, Eq, Ord) {- | We use this to name dependencies. In addition to normal names we have a way to refer to module parameters and top-level module constraints, which have no explicit names -} data DepName = NamedThing Name -- ^ Something with a name | ModPath ModPath -- ^ The module at this path | ModParamName Range Ident {- ^ Note that the range is important not just for error reporting but to distinguish module parameters with the same name (e.g., in nested functors) -} | ConstratintAt Range -- ^ Identifed by location in source deriving (Eq,Ord,Show,Generic,NFData) depNameLoc :: DepName -> Maybe Range depNameLoc x = case x of NamedThing n -> Just (nameLoc n) ConstratintAt r -> Just r ModParamName r _ -> Just r ModPath {} -> Nothing data ModKind = AFunctor | ASignature | AModule deriving (Show, Generic, NFData, Eq, Ord) instance PP ModKind where ppPrec _ e = case e of AFunctor -> "a functor" ASignature -> "an interface" AModule -> "a module" instance PP RenamerError where ppPrec _ e = case e of MultipleSyms lqn qns -> hang (text "[error] at" <+> pp (srcRange lqn)) 4 $ (text "Multiple definitions for symbol:" <+> pp (thing lqn)) $$ vcat (map ppLocName qns) UnboundName ns lqn -> hang (text "[error] at" <+> pp (srcRange lqn)) 4 (something <+> "not in scope:" <+> pp (thing lqn)) where something = case ns of NSValue -> "Value" NSType -> "Type" NSModule -> "Module" OverlappingSyms qns -> hang (text "[error]") 4 $ text "Overlapping symbols defined:" $$ vcat (map ppLocName qns) WrongNamespace expected actual lqn -> hang ("[error] at" <+> pp (srcRange lqn )) 4 (fsep $ [ "Expected a", sayNS expected, "named", quotes (pp (thing lqn)) , "but found a", sayNS actual, "instead" ] ++ suggestion) where sayNS ns = case ns of NSValue -> "value" NSType -> "type" NSModule -> "module" suggestion = case (expected,actual) of (NSValue,NSType) -> ["Did you mean `(" <.> pp (thing lqn) <.> text")?"] _ -> [] FixityError o1 f1 o2 f2 -> hang (text "[error] at" <+> pp (srcRange o1) <+> text "and" <+> pp (srcRange o2)) 4 (vsep [ text "The fixities of" , indent 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." ]) OverlappingRecordUpdate xs ys -> hang "[error] Overlapping record updates:" 4 (vcat [ ppLab xs, ppLab ys ]) where ppLab as = ppNestedSels (thing as) <+> "at" <+> pp (srcRange as) InvalidDependency ds -> hang "[error] Invalid recursive dependency:" 4 (vcat [ "•" <+> pp x <.> case depNameLoc x of Just r -> ", defined at" <+> ppR r Nothing -> mempty | x <- ds ]) where ppR r = pp (from r) <.> "--" <.> pp (to r) MultipleModParams x rs -> hang ("[error] Multiple parameters with name" <+> backticks (pp x)) 4 (vcat [ "•" <+> pp r | r <- rs ]) InvalidFunctorImport x -> hang ("[error] Invalid import of functor" <+> backticks (pp x)) 4 "• Functors need to be instantiated before they can be imported." UnexpectedNest s x -> hang ("[error] at" <+> pp s) 4 ("submodule" <+> backticks (pp x) <+> "may not be defined here.") ModuleKindMismatch r x expected actual -> hang ("[error] at" <+> pp r) 4 (vcat [ "• Expected" <+> pp expected , "•" <+> backticks (pp x) <+> "is" <+> pp actual ]) instance PP DepName where ppPrec _ d = case d of ConstratintAt r -> "constraint at" <+> pp r NamedThing n -> case nameNamespace n of NSModule -> "submodule" <+> pp n NSType -> "type" <+> pp n NSValue -> pp n ModParamName _r i -> "module parameter" <+> pp i ModPath mp -> case modPathSplit mp of (m,[]) -> "module" <+> pp m (_,is) -> "submodule" <+> hcat (intersperse "::" (map pp is)) -- Warnings -------------------------------------------------------------------- data RenamerWarning = SymbolShadowed PName Name [Name] | UnusedName Name | PrefixAssocChanged PrefixOp (Expr Name) (Located Name) Fixity (Expr Name) deriving (Show, Generic, NFData) instance Eq RenamerWarning where x == y = compare x y == EQ -- used to determine in what order to show things instance Ord RenamerWarning where compare w1 w2 = case (w1, w2) of (SymbolShadowed x y _, SymbolShadowed x' y' _) -> compare (byStart y, x) (byStart y', x') (UnusedName x, UnusedName x') -> compare (byStart x) (byStart x') (PrefixAssocChanged _ _ op _ _, PrefixAssocChanged _ _ op' _ _) -> compare (from $ srcRange op) (from $ srcRange op') _ -> compare (priority w1) (priority w2) where byStart = from . nameLoc priority SymbolShadowed {} = 0 :: Int priority UnusedName {} = 1 priority PrefixAssocChanged {} = 2 instance PP RenamerWarning where ppPrec _ (SymbolShadowed k x os) = hang (text "[warning] at" <+> loc) 4 $ fsep [ "This binding for" <+> backticks (pp k) , "shadows the existing binding" <.> plural , text "at" ] $$ vcat (map (pp . nameLoc) os) where plural | length os > 1 = char 's' | otherwise = mempty loc = pp (nameLoc x) ppPrec _ (UnusedName x) = hang (text "[warning] at" <+> pp (nameLoc x)) 4 (text "Unused name:" <+> pp x) ppPrec _ (PrefixAssocChanged prefixOp x infixOp infixFixity y) = hang (text "[warning] at" <+> pp (srcRange infixOp)) 4 $ fsep [ backticks (pp old) , "is now parsed as" , backticks (pp new) ] where old = EInfix (EPrefix prefixOp x) infixOp infixFixity y new = EPrefix prefixOp (EInfix x infixOp infixFixity y) cryptol-3.0.0/src/Cryptol/ModuleSystem/Renamer/ImplicitImports.hs0000644000000000000000000000636207346545000023340 0ustar0000000000000000{- | We add implicit imports are for public nested modules. This allows using definitions from nested modules without having to explicitly import them, for example: module A where submodule B where x = 0x20 y = x // This works because of the implicit import of `B` Restriction: ============ We only add impicit imports of modules that are syntactically visiable in the source code. Consider the following example: module A where submodule M = F {X} -- F,X are external modules (e.g., top-level) We will add an implicit import for `M`, but *NO* implicit imports for any modules imported vial `M` as those are not sytnactically visible in the source (i.e., we have to know what `F` refers to). This restriction allows us to add implicit imports before doing the `Imports` pass. -} module Cryptol.ModuleSystem.Renamer.ImplicitImports ( addImplicitNestedImports ) where import Data.List(partition) import Cryptol.Parser.Position(Range) import Cryptol.Utils.Ident(packModName) import Cryptol.Parser.AST {- | Add additional imports for modules nested withing this one -} addImplicitNestedImports :: [TopDecl PName] -> [TopDecl PName] addImplicitNestedImports = snd . addImplicitNestedImports' {- | Returns: * declarations with additional imports and * the public module names of this module and its children. -} addImplicitNestedImports' :: [TopDecl PName] -> ([[Ident]], [TopDecl PName]) addImplicitNestedImports' decls = (concat exportedMods, concat newDecls ++ other) where (mods,other) = partition isNestedMod decls (newDecls,exportedMods) = unzip (map processModule mods) processModule :: TopDecl PName -> ([TopDecl PName], [[Ident]]) processModule ~dcl@(DModule m) = let NestedModule m1 = tlValue m in case mDef m1 of NormalModule ds -> let (childExs, ds1) = addImplicitNestedImports' ds mname = getIdent (thing (mName m1)) imps = map (mname :) ([] : childExs) -- this & nested loc = srcRange (mName m1) in ( DModule m { tlValue = NestedModule m1 { mDef = NormalModule ds1 } } : map (mkImp loc) imps , case tlExport m of Public -> imps Private -> [] ) FunctorInstance {} -> ([dcl], []) InterfaceModule {} -> ([dcl], []) isNestedMod :: TopDecl name -> Bool isNestedMod d = case d of DModule tl -> case tlValue tl of NestedModule m -> not (mIsFunctor m) _ -> False -- | Make a name qualifier out of a list of identifiers. isToQual :: [Ident] -> ModName isToQual is = packModName (map identText is) -- | Make a module name out of a list of identifier. -- This is the name of the module we are implicitly importing. isToName :: [Ident] -> PName isToName is = case is of [i] -> mkUnqual i _ -> mkQual (isToQual (init is)) (last is) -- | Make an implicit import declaration. mkImp :: Range -> [Ident] -> TopDecl PName mkImp loc xs = DImport Located { srcRange = loc , thing = Import { iModule = ImpNested (isToName xs) , iAs = Just (isToQual xs) , iSpec = Nothing , iInst = Nothing } } cryptol-3.0.0/src/Cryptol/ModuleSystem/Renamer/Imports.hs0000644000000000000000000004565607346545000021656 0ustar0000000000000000{- | This module deals with imports of nested modules (@import submodule@). This is more complex than it might seem at first because to resolve a declaration like @import submodule X@ we need to resolve what @X@ referes to before we know what it will import. Even triciker is the case for functor instantiations: module M = F { X } import M In this case, even if we know what `M` referes to, we first need to resolve `F`, so that we can generate the instantiation and generate fresh names for names defined by `M`. If we want to support applicative semantics, then before instantiation `M` we also need to resolve `X` so that we know if this instantiation has already been generated. An overall guiding principle of the design is that we assume that declarations can be ordered in dependency order, and submodules can be processed one at a time. In particular, this does not allow recursion across modules, or functor instantiations depending on their arguments. Thus, the following is OK: module A where x = 0x2 submodule B where y = x z = B::y However, this is not OK: submodule A = F X submodule F where import A -} {-# Language BlockArguments #-} {-# Language TypeSynonymInstances, FlexibleInstances #-} module Cryptol.ModuleSystem.Renamer.Imports ( resolveImports , ResolvedModule(..) , ModKind(..) , ResolvedLocal , ResolvedExt ) where import Data.Maybe(fromMaybe) import Data.Set(Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map import Data.List(foldl') import Control.Monad(when) import qualified MonadLib as M import Cryptol.Utils.PP(pp) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Ident(ModName,ModPath(..),Namespace(..),OrigName(..)) import Cryptol.Parser.AST ( ImportG(..),PName, ModuleInstanceArgs(..), ImpName(..) ) import Cryptol.ModuleSystem.Binds (Mod(..), TopDef(..), modNested, ModKind(..)) import Cryptol.ModuleSystem.Name ( Name, Supply, SupplyT, runSupplyT, liftSupply, freshNameFor , asOrigName, nameIdent, nameTopModule ) import Cryptol.ModuleSystem.Names(Names(..)) import Cryptol.ModuleSystem.NamingEnv ( NamingEnv(..), lookupNS, shadowing, travNamingEnv , interpImportEnv, zipByTextName, filterUNames ) {- | This represents a resolved module or signaure. The type parameter helps us distinguish between two types of resolved modules: 1. Resolved modules that are *inputs* to the algorithm (i.e., they are defined outside the current module). For such modules the type parameter is @imps@ is () 2. Resolved modules that are *outputs* of the algorithm (i.e., they are defined within the current module). For such modules the type parameter @imps@ contains the naming environment for things that came in through the import. Note that signaures are never "imported", however we do need to keep them here so that signatures in a functor are properly instantiated when the functor is instantiated. -} data ResolvedModule imps = ResolvedModule { rmodDefines :: NamingEnv -- ^ Things defined by the module/signature. , rmodPublic :: !(Set Name) -- ^ Exported names , rmodKind :: ModKind -- ^ What sort of thing are we , rmodNested :: Set Name -- ^ Modules and signatures nested in this one , rmodImports :: imps {- ^ Resolved imports. External modules need not specify this field, it is just part of the thing we compute for local modules. -} } -- | A resolved module that's defined in (or is) the current top-level module type ResolvedLocal = ResolvedModule NamingEnv -- | A resolved module that's not defined in the current top-level module type ResolvedExt = ResolvedModule () resolveImports :: (ImpName Name -> Mod ()) -> TopDef -> Supply -> (Map (ImpName Name) ResolvedLocal, Supply) resolveImports ext def su = case def of TopMod m mo -> do let cur = todoModule mo newS = doModuleStep CurState { curMod = cur , curTop = m , externalModules = ext , doneModules = mempty , nameSupply = su , changes = False } case tryFinishCurMod cur newS of Just r -> add m r newS Nothing -> add m r s1 where (r,s1) = forceFinish newS TopInst m f as -> do let s = CurState { curMod = () , curTop = m , externalModules = ext , doneModules = mempty , nameSupply = su , changes = False } case tryInstanceMaybe s (ImpTop m) (f,as) of Just (r,newS) -> add m r newS Nothing -> (Map.singleton (ImpTop m) forceResolveInst, su) where toNest m = Map.fromList [ (ImpNested k, v) | (k,v) <- Map.toList m ] add m r s = ( Map.insert (ImpTop m) r (toNest (doneModules s)) , nameSupply s ) -------------------------------------------------------------------------------- -- | This keeps track of the current state of resolution of a module. type Todo = Mod ModState data ModState = ModState { modOuter :: NamingEnv -- ^ Things which come in scope from outer modules , modImported :: NamingEnv -- ^ Things which come in scope via imports. These shadow outer names. } -- | Initial state of a module that needs processing. todoModule :: Mod () -> Todo todoModule = fmap (const emptyModState) where emptyModState = ModState { modOuter = mempty , modImported = mempty } {- | A module is fully processed when we are done with all its: * submodule imports * instantiations * nested things (signatures and modules) -} isDone :: Todo -> Bool isDone m = null (modImports m) && Map.null (modInstances m) && Map.null (modMods m) -- | Finish up all unfinished modules as best as we can forceFinish :: CurState -> (ResolvedLocal,CurState) forceFinish s0 = let this = curMod s0 add k v s = s { doneModules = Map.insert k v (doneModules s) } s1 = foldl' (\s k -> add k forceResolveInst s) s0 (Map.keys (modInstances this)) doNestMod s (k,m) = let (r,s') = forceFinish s { curMod = m } in add k r s' in ( forceResolveMod this , foldl' doNestMod s1 (Map.toList (modMods this)) ) -- | A place-holder entry for instnatitations we couldn't resolve. forceResolveInst :: ResolvedLocal forceResolveInst = ResolvedModule { rmodDefines = mempty , rmodPublic = mempty , rmodKind = AModule , rmodNested = Set.empty , rmodImports = mempty } -- | Finish up unresolved modules as well as we can, in situations where -- the program contains an error. forceResolveMod :: Todo -> ResolvedLocal forceResolveMod todo = ResolvedModule { rmodDefines = modDefines todo , rmodPublic = modPublic todo , rmodKind = modKind todo , rmodNested = Map.keysSet (modMods todo) , rmodImports = modImported (modState todo) } pushImport :: ImportG (ImpName PName) -> Todo -> Todo pushImport i m = m { modImports = i : modImports m } pushInst :: Name -> (ImpName PName, ModuleInstanceArgs PName) -> Todo -> Todo pushInst k v m = m { modInstances = Map.insert k v (modInstances m) } pushMod :: Name -> Todo -> Todo -> Todo pushMod k v m = m { modMods = Map.insert k v (modMods m) } updMS :: (ModState -> ModState) -> Todo -> Todo updMS f m = m { modState = f (modState m) } -------------------------------------------------------------------------------- externalMod :: Mod () -> ResolvedExt externalMod m = ResolvedModule { rmodDefines = modDefines m , rmodPublic = modPublic m , rmodKind = modKind m , rmodNested = modNested m , rmodImports = () } {- | This is used when we need to use a local resolved module as an input to another module. -} forget :: ResolvedLocal -> ResolvedExt forget r = r { rmodImports = () } type CurState = CurState' Todo data CurState' a = CurState { curMod :: a -- ^ This is what needs to be done , curTop :: !ModName {- ^ The top-level module we are working on. This does not change throught the algorithm, it is just convenient to pass it here with all the other stuff. -} , externalModules :: ImpName Name -> Mod () -- ^ Modules defined outside the current top-level modules , doneModules :: Map Name ResolvedLocal {- ^ Nested modules/signatures in the current top-level modules. These may be either defined locally, or be the result of instantiating a functor. Note that the functor itself may be either local or external. -} , nameSupply :: Supply -- ^ Use this to instantiate functors , changes :: Bool -- ^ True if something changed on the last iteration } updCur :: CurState -> (Todo -> Todo) -> CurState updCur m f = m { curMod = f (curMod m) } updCurMS :: CurState -> (ModState -> ModState) -> CurState updCurMS s f = updCur s (updMS f) class HasCurScope a where curScope :: CurState' a -> NamingEnv instance HasCurScope () where curScope _ = mempty instance HasCurScope Todo where curScope s = modDefines m `shadowing` modImported ms `shadowing` modOuter ms where m = curMod s ms = modState m -- | Keep applying a transformation while things are changing doStep :: (CurState -> CurState) -> (CurState -> CurState) doStep f s0 = go (changes s0) s0 where go ch s = let s1 = f s { changes = False } in if changes s1 then go True s1 else s { changes = ch } -- | Is this a known name for a module in the current scope? knownPName :: HasCurScope a => CurState' a -> PName -> Maybe Name knownPName s x = do ns <- lookupNS NSModule x (curScope s) case ns of One n -> pure n {- NOTE: since we build up what's in scope incrementally, it is possible that this would eventually be ambiguous, which we'll detect during actual renaming. -} Ambig {} -> Nothing {- We treat ambiguous imports as undefined, which may lead to spurious "undefined X" errors. To avoid this we should prioritize reporting "ambiguous X" errors. -} -- | Is the module mentioned in this import known in the current scope? knownImpName :: HasCurScope a => CurState' a -> ImpName PName -> Maybe (ImpName Name) knownImpName s i = case i of ImpTop m -> pure (ImpTop m) ImpNested m -> ImpNested <$> knownPName s m -- | Is the module mentioned in the import already resolved? knownModule :: HasCurScope a => CurState' a -> ImpName Name -> Maybe ResolvedExt knownModule s x | root == curTop s = case x of ImpNested y -> forget <$> Map.lookup y (doneModules s) ImpTop {} -> Nothing -- or panic? recursive import | otherwise = Just (externalMod (externalModules s x)) where root = case x of ImpTop r -> r ImpNested n -> nameTopModule n -------------------------------------------------------------------------------- {- | Try to resolve an import. If the imported module can be resolved, and it refers to a module that's already been resolved, then we do the import and extend the current scoping environment. Otherwise, we just queue the import back on the @modImports@ of the current module to be tried again later.-} tryImport :: CurState -> ImportG (ImpName PName) -> CurState tryImport s imp = fromMaybe (updCur s (pushImport imp)) -- not ready, put it back on the q do let srcName = iModule imp mname <- knownImpName s srcName ext <- knownModule s mname let isPub x = x `Set.member` rmodPublic ext new = case rmodKind ext of AModule -> interpImportEnv imp (filterUNames isPub (rmodDefines ext)) AFunctor -> mempty ASignature -> mempty pure $ updCurMS s { changes = True } \ms -> ms { modImported = new <> modImported ms } -- | Resolve all imports in the current modules doImportStep :: CurState -> CurState doImportStep s = foldl' tryImport s1 (modImports (curMod s)) where s1 = updCur s \m -> m { modImports = [] } {- | Try to instantiate a functor. This succeeds if we can resolve the functor and the arguments and the both refer to already resolved names. Note: at the moment we ignore the arguments, but we'd have to do that in order to implment applicative behavior with caching. -} tryInstanceMaybe :: HasCurScope a => CurState' a -> ImpName Name -> (ImpName PName, ModuleInstanceArgs PName) {- ^ Functor and arguments -} -> Maybe (ResolvedLocal,CurState' a) tryInstanceMaybe s mn (f,_xs) = do fn <- knownImpName s f let path = case mn of ImpTop m -> TopModule m ImpNested m -> case asOrigName m of Just og -> Nested (ogModule og) (ogName og) Nothing -> panic "tryInstanceMaybe" [ "Not a top-level name" ] doInstantiateByName False path fn s {- | Try to instantiate a functor. If successful, then the newly instantiated module (and all things nested in it) are going to be added to the @doneModules@ field. Otherwise, we queue up the instantiatation in @curMod@ for later processing -} tryInstance :: CurState -> Name -> (ImpName PName, ModuleInstanceArgs PName) -> CurState tryInstance s mn (f,xs) = case tryInstanceMaybe s (ImpNested mn) (f,xs) of Nothing -> updCur s (pushInst mn (f,xs)) Just (def,s1) -> s1 { changes = True , doneModules = Map.insert mn def (doneModules s1) } {- | Generate a fresh instance for the functor with the given name. -} doInstantiateByName :: HasCurScope a => Bool {- ^ This indicates if the result is a functor or not. When instantiating a functor applied to some arguments the result is not a functor. However, if we are instantiating a functor nested within some functor that's being instantiated, then the result is still a functor. -} -> ModPath {- ^ Path for instantiated names -} -> ImpName Name {- ^ Name of the functor/module being instantiated -} -> CurState' a -> Maybe (ResolvedLocal,CurState' a) doInstantiateByName keepArgs mpath fname s = do def <- knownModule s fname pure (doInstantiate keepArgs mpath def s) {- | Generate a new instantiation of the given module/signature. Note that the module might not be a functor itself (e.g., if we are instantiating something nested in a functor -} doInstantiate :: HasCurScope a => Bool {- ^ See `doInstantiateByName` -} -> ModPath {- ^ Path for instantiated names -} -> ResolvedExt {- ^ The thing being instantiated -} -> CurState' a -> (ResolvedLocal,CurState' a) doInstantiate keepArgs mpath def s = (newDef, Set.foldl' doSub newS nestedToDo) where ((newEnv,newNameSupply),nestedToDo) = M.runId $ M.runStateT Set.empty $ runSupplyT (nameSupply s) $ travNamingEnv instName $ rmodDefines def newS = s { nameSupply = newNameSupply } pub = let inst = zipByTextName (rmodDefines def) newEnv in Set.fromList [ case Map.lookup og inst of Just newN -> newN Nothing -> panic "doInstantiate.pub" [ "Lost a name", show og ] | og <- Set.toList (rmodPublic def) ] newDef = ResolvedModule { rmodDefines = newEnv , rmodPublic = pub , rmodKind = case rmodKind def of AFunctor -> if keepArgs then AFunctor else AModule ASignature -> ASignature AModule -> AModule , rmodNested = Set.map snd nestedToDo , rmodImports = mempty {- we don't do name resolution on the instantiation the usual way: instead the functor and the arguments are renamed separately, then we we do a pass where we replace: defined names of functor by instantiations parameter by actual names in arguments. -} } doSub st (oldSubName,newSubName) = case doInstantiateByName True (Nested mpath (nameIdent newSubName)) (ImpNested oldSubName) st of Just (idef,st1) -> st1 { doneModules = Map.insert newSubName idef (doneModules st1) } Nothing -> panic "doInstantiate.doSub" [ "Missing nested module:", show (pp oldSubName) ] instName :: Name -> SupplyT (M.StateT (Set (Name,Name)) M.Id) Name instName x = do y <- liftSupply (freshNameFor mpath x) when (x `Set.member` rmodNested def) (M.lift (M.sets_ (Set.insert (x,y)))) pure y -- | Try to make progress on all instantiations. doInstancesStep :: CurState -> CurState doInstancesStep s = Map.foldlWithKey' tryInstance s0 (modInstances (curMod s)) where s0 = updCur s \m' -> m' { modInstances = Map.empty } tryFinishCurMod :: Todo -> CurState -> Maybe ResolvedLocal tryFinishCurMod m newS | isDone newM = Just ResolvedModule { rmodDefines = modDefines m , rmodPublic = modPublic m , rmodKind = modKind m , rmodNested = Set.unions [ Map.keysSet (modInstances m) , Map.keysSet (modMods m) ] , rmodImports = modImported (modState newM) } | otherwise = Nothing where newM = curMod newS -- | Try to resolve the "normal" module with the given name. tryModule :: CurState -> Name -> Todo -> CurState tryModule s nm m = case tryFinishCurMod m newS of Just rMod -> newS { curMod = curMod s , doneModules = Map.insert nm rMod (doneModules newS) , changes = True } Nothing -> newS { curMod = pushMod nm newM (curMod s) } where s1 = updCur s \_ -> updMS (\ms -> ms { modOuter = curScope s }) m newS = doModuleStep s1 newM = curMod newS -- | Process all submodules of a module. doModulesStep :: CurState -> CurState doModulesStep s = Map.foldlWithKey' tryModule s0 (modMods m) where m = curMod s s0 = s { curMod = m { modMods = mempty } } -- | All steps involved in processing a module. doModuleStep :: CurState -> CurState doModuleStep = doStep step where step = doStep doModulesStep . doStep doInstancesStep . doStep doImportStep cryptol-3.0.0/src/Cryptol/ModuleSystem/Renamer/Monad.hs0000644000000000000000000004264107346545000021246 0ustar0000000000000000-- | -- Module : Cryptol.ModuleSystem.Renamer -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# Language RecordWildCards #-} {-# Language FlexibleContexts #-} {-# Language BlockArguments #-} {-# Language OverloadedStrings #-} module Cryptol.ModuleSystem.Renamer.Monad where import Data.List(sort,foldl') import Data.Set(Set) import qualified Data.Set as Set import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map import qualified Data.Semigroup as S import MonadLib hiding (mapM, mapM_) import Prelude () import Prelude.Compat import Cryptol.Utils.PP(pp) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Ident(modPathCommon,OrigName(..),OrigSource(..)) import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.NamingEnv import Cryptol.ModuleSystem.Binds import Cryptol.ModuleSystem.Interface import Cryptol.Parser.AST import Cryptol.TypeCheck.AST(ModParamNames) import Cryptol.Parser.Position import Cryptol.ModuleSystem.Renamer.Error import Cryptol.ModuleSystem.Renamer.Imports (ResolvedLocal,rmodKind,rmodDefines,rmodNested) -- | Indicates if a name is in a binding poisition or a use site data NameType = NameBind | NameUse -- | Information needed to do some renaming. data RenamerInfo = RenamerInfo { renSupply :: Supply -- ^ Use to make new names , renContext :: ModPath -- ^ We are renaming things in here , renEnv :: NamingEnv -- ^ This is what's in scope , renIfaces :: Map ModName (Either ModParamNames Iface) -- ^ External modules } newtype RenameM a = RenameM { unRenameM :: ReaderT RO (StateT RW Lift) a } data RO = RO { roLoc :: Range , roNames :: NamingEnv , roExternal :: Map ModName (Maybe Iface, Map (ImpName Name) (Mod ())) -- ^ Externally loaded modules. `Mod` is defined in 'Cryptol.Renamer.Binds'. , roCurMod :: ModPath -- ^ Current module we are working on , roNestedMods :: Map ModPath Name {- ^ Maps module paths to the actual name for it. This is used for dependency tracking, to find the name of a containing module. See the note on `addDep`. -} , roResolvedModules :: Map (ImpName Name) ResolvedLocal -- ^ Info about locally defined modules , roModParams :: Map Ident RenModParam {- ^ Module parameters. These are used when rename the module parameters, and only refer to the parameters of the current module (i.e., no outer parameters as those are not needed) -} , roFromModParam :: Map Name DepName -- ^ Keeps track of which names were introduce by module parameters -- and which one. The `DepName` is always a `ModParamName`. } data RW = RW { rwWarnings :: ![RenamerWarning] , rwErrors :: !(Set RenamerError) , rwSupply :: !Supply , rwNameUseCount :: !(Map Name Int) -- ^ How many times did we refer to each name. -- Used to generate warnings for unused definitions. , rwCurrentDeps :: Set Name -- ^ keeps track of names *used* by something. -- see 'depsOf' , rwDepGraph :: Map DepName (Set Name) -- ^ keeps track of the dependencies for things. -- see 'depsOf' , rwExternalDeps :: !IfaceDecls -- ^ Info about imported things, from external modules } data RenModParam = RenModParam { renModParamName :: Ident , renModParamRange :: Range , renModParamSig :: ImpName Name , renModParamInstance :: Map Name Name {- ^ Maps names that come into scope through this parameter to the names in the *module interface*. This is for functors, NOT functor instantantiations. -} } 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 = pure {-# 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 :: RenamerInfo -> RenameM a -> ( Either [RenamerError] (a,Supply) , [RenamerWarning] ) runRenamer info m = (res, warns) where warns = sort (rwWarnings rw ++ warnUnused (renContext info) (renEnv info) rw) (a,rw) = runM (unRenameM m) ro RW { rwErrors = Set.empty , rwWarnings = [] , rwSupply = renSupply info , rwNameUseCount = Map.empty , rwExternalDeps = mempty , rwCurrentDeps = Set.empty , rwDepGraph = Map.empty } ro = RO { roLoc = emptyRange , roNames = renEnv info , roExternal = Map.mapWithKey toModMap (renIfaces info) , roCurMod = renContext info , roNestedMods = Map.empty , roResolvedModules = mempty , roModParams = mempty , roFromModParam = mempty } res | Set.null (rwErrors rw) = Right (a,rwSupply rw) | otherwise = Left (Set.toList (rwErrors rw)) toModMap t ent = case ent of Left ps -> (Nothing, Map.singleton (ImpTop t) (ifaceSigToMod ps)) Right i -> (Just i, modToMap (ImpTop t) (ifaceToMod i) mempty) setCurMod :: ModPath -> RenameM a -> RenameM a setCurMod mpath (RenameM m) = RenameM $ mapReader (\ro -> ro { roCurMod = mpath }) m getCurMod :: RenameM ModPath getCurMod = RenameM $ asks roCurMod getNamingEnv :: RenameM NamingEnv getNamingEnv = RenameM (asks roNames) setResolvedLocals :: Map (ImpName Name) ResolvedLocal -> RenameM a -> RenameM a setResolvedLocals mp (RenameM m) = RenameM $ mapReader (\ro -> ro { roResolvedModules = mp }) m lookupResolved :: ImpName Name -> RenameM ResolvedLocal lookupResolved nm = do mp <- RenameM (roResolvedModules <$> ask) pure case Map.lookup nm mp of Just r -> r -- XXX: could this happen because we couldn't resolve a module? Nothing -> panic "lookupResolved" [ "Missing module: " ++ show nm ] setModParams :: [RenModParam] -> RenameM a -> RenameM a setModParams ps (RenameM m) = do let pmap = Map.fromList [ (renModParamName p, p) | p <- ps ] newFrom = foldLoop ps mempty \p mp -> let nm = ModParamName (renModParamRange p) (renModParamName p) in foldLoop (Map.keys (renModParamInstance p)) mp \x -> Map.insert x nm upd ro = ro { roModParams = pmap , roFromModParam = newFrom <> roFromModParam ro } RenameM (mapReader upd m) foldLoop :: [a] -> b -> (a -> b -> b) -> b foldLoop xs b f = foldl' (flip f) b xs getModParam :: Ident -> RenameM RenModParam getModParam p = do ps <- RenameM (roModParams <$> ask) case Map.lookup p ps of Just r -> pure r Nothing -> panic "getModParam" [ "Missing module paramter", show p ] getNamesFromModParams :: RenameM (Map Name DepName) getNamesFromModParams = RenameM (roFromModParam <$> ask) getLocalModParamDeps :: RenameM (Map Ident DepName) getLocalModParamDeps = do ps <- RenameM (roModParams <$> ask) let toName mp = ModParamName (renModParamRange mp) (renModParamName mp) pure (toName <$> ps) setNestedModule :: Map ModPath Name -> RenameM a -> RenameM a setNestedModule mp (RenameM m) = RenameM $ mapReader (\ro -> ro { roNestedMods = mp }) m nestedModuleOrig :: ModPath -> RenameM (Maybe Name) nestedModuleOrig x = RenameM (asks (Map.lookup x . roNestedMods)) -- | Record an error. recordError :: RenamerError -> RenameM () recordError f = RenameM $ do RW { .. } <- get set RW { rwErrors = Set.insert f rwErrors, .. } recordWarning :: RenamerWarning -> RenameM () recordWarning w = RenameM $ sets_ \rw -> rw { rwWarnings = w : rwWarnings rw } collectIfaceDeps :: RenameM a -> RenameM (IfaceDecls,a) collectIfaceDeps (RenameM m) = RenameM do ds <- sets \s -> (rwExternalDeps s, s { rwExternalDeps = mempty }) a <- m ds' <- sets \s -> (rwExternalDeps s, s { rwExternalDeps = ds }) pure (ds',a) -- | Rename something. All name uses in the sub-computation are assumed -- to be dependenices of the thing. depsOf :: DepName -> RenameM a -> RenameM a depsOf x (RenameM m) = RenameM do ds <- sets \rw -> (rwCurrentDeps rw, rw { rwCurrentDeps = Set.empty }) a <- m sets_ \rw -> rw { rwCurrentDeps = Set.union (rwCurrentDeps rw) ds , rwDepGraph = Map.insert x (rwCurrentDeps rw) (rwDepGraph rw) } pure a -- | This is used when renaming a group of things. The result contains -- dependencies between names defined in the group, and is intended to -- be used to order the group members in dependency order. depGroup :: RenameM a -> RenameM (a, Map DepName (Set Name)) depGroup (RenameM m) = RenameM do ds <- sets \rw -> (rwDepGraph rw, rw { rwDepGraph = Map.empty }) a <- m ds1 <- sets \rw -> (rwDepGraph rw, rw { rwDepGraph = ds }) pure (a,ds1) -- | 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 -- | 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) -- | Report errors if the given naming environemnt contains multiple -- definitions for the same symbol checkOverlap :: NamingEnv -> RenameM NamingEnv checkOverlap env = case findAmbig env of [] -> pure env ambig -> do mapM_ recordError [ OverlappingSyms xs | xs <- ambig ] pure (forceUnambig env) -- | Issue warnings if entries in the first environment would -- shadow something in the second. checkShadowing :: NamingEnv -> NamingEnv -> RenameM () checkShadowing envNew envOld = mapM_ recordWarning [ SymbolShadowed p x xs | (p,x,xs) <- findShadowing envNew envOld ] -- | Shadow the current naming environment with some more names. -- XXX: The checks are really confusing shadowNames' :: BindsNames env => EnvCheck -> env -> RenameM a -> RenameM a shadowNames' check names m = do do env <- liftSupply (defsOf names) envOld <- RenameM (roNames <$> ask) env1 <- case check of CheckNone -> pure env CheckOverlap -> checkOverlap env CheckAll -> do checkShadowing env envOld checkOverlap env RenameM do ro <- ask let ro' = ro { roNames = env1 `shadowing` envOld } local ro' (unRenameM m) recordUse :: Name -> RenameM () recordUse x = RenameM $ sets_ $ \rw -> rw { rwNameUseCount = Map.insertWith (+) x 1 (rwNameUseCount rw) } {- NOTE: we don't distinguish between bindings and uses here, because the situation is complicated by the pattern signatures where the first "use" site is actually the binding site. Instead we just count them all, and something is considered unused if it is used only once (i.e, just the binding site) -} -- | Mark something as a dependency. This is similar but different from -- `recordUse`, in particular: -- * We only record use sites, not bindings -- * We record all namespaces, not just types -- * We only keep track of actual uses mentioned in the code. -- Otoh, `recordUse` also considers exported entities to be used. -- * If we depend on a name from a sibling submodule we add a dependency on -- the module in our common ancestor. Examples: -- - @A::B::x@ depends on @A::B::C::D::y@, @x@ depends on @A::B::C@ -- - @A::B::x@ depends on @A::P::Q::y@@, @x@ depends on @A::P@ addDep :: Name -> RenameM () addDep x = do cur <- getCurMod deps <- case nameInfo x of GlobalName _ OrigName { ogModule = m } | Just (c,_,i:_) <- modPathCommon cur m -> do mb <- nestedModuleOrig (Nested c i) pure case mb of Just y -> Set.fromList [x,y] Nothing -> Set.singleton x _ -> pure (Set.singleton x) RenameM $ sets_ \rw -> rw { rwCurrentDeps = Set.union deps (rwCurrentDeps rw) } warnUnused :: ModPath -> NamingEnv -> RW -> [RenamerWarning] warnUnused m0 env rw = map UnusedName $ Map.keys $ Map.filterWithKey keep $ rwNameUseCount rw where keep nm count = count == 1 && isLocal nm oldNames = Map.findWithDefault Set.empty NSType (visibleNames env) -- returns true iff the name comes from a definition in a nested module, -- including the current module isNestd og = case modPathCommon m0 (ogModule og) of Just (_,[],_) | FromDefinition <- ogSource og -> True _ -> False isLocal nm = case nameInfo nm of GlobalName sys og -> sys == UserName && isNestd og && nm `Set.notMember` oldNames LocalName {} -> True getExternal :: RenameM (ImpName Name -> Mod ()) getExternal = do mp <- roExternal <$> RenameM ask pure \nm -> let mb = do t <- case nm of ImpTop t -> pure t ImpNested x -> nameTopModuleMaybe x (_,mp1) <- Map.lookup t mp Map.lookup nm mp1 in case mb of Just m -> m Nothing -> panic "getExternal" ["Missing external name", show (pp nm) ] getExternalMod :: ImpName Name -> RenameM (Mod ()) getExternalMod nm = ($ nm) <$> getExternal -- | Returns `Nothing` if the name does not refer to a module (i.e., it is a sig) getTopModuleIface :: ImpName Name -> RenameM (Maybe Iface) getTopModuleIface nm = do mp <- roExternal <$> RenameM ask let t = case nm of ImpTop t' -> t' ImpNested x -> nameTopModule x case Map.lookup t mp of Just (mb, _) -> pure mb Nothing -> panic "getTopModuleIface" ["Missing external module", show (pp nm) ] {- | Record an import: * record external dependency if the name refers to an external import * record an error if the imported thing is a functor -} recordImport :: Range -> ImpName Name -> RenameM () recordImport r i = do ro <- RenameM ask case Map.lookup i (roResolvedModules ro) of Just loc -> case rmodKind loc of AModule -> pure () k -> recordError (ModuleKindMismatch r i AModule k) Nothing -> do mb <- getTopModuleIface i case mb of Nothing -> recordError (ModuleKindMismatch r i AModule ASignature) Just iface | ifaceIsFunctor iface -> recordError (ModuleKindMismatch r i AModule AFunctor) | otherwise -> RenameM $ sets_ \s -> s { rwExternalDeps = ifDefines iface <> rwExternalDeps s } -- | Lookup a name either in the locally resolved thing or in an external module lookupModuleThing :: ImpName Name -> RenameM (Either ResolvedLocal (Mod ())) lookupModuleThing nm = do ro <- RenameM ask case Map.lookup nm (roResolvedModules ro) of Just loc -> pure (Left loc) Nothing -> Right <$> getExternalMod nm lookupDefines :: ImpName Name -> RenameM NamingEnv lookupDefines nm = do thing <- lookupModuleThing nm pure case thing of Left loc -> rmodDefines loc Right e -> modDefines e checkIsModule :: Range -> ImpName Name -> ModKind -> RenameM () checkIsModule r nm expect = do thing <- lookupModuleThing nm let actual = case thing of Left rmod -> rmodKind rmod Right mo -> modKind mo unless (actual == expect) (recordError (ModuleKindMismatch r nm expect actual)) lookupDefinesAndSubs :: ImpName Name -> RenameM (NamingEnv, Set Name) lookupDefinesAndSubs nm = do thing <- lookupModuleThing nm pure case thing of Left rmod -> ( rmodDefines rmod, rmodNested rmod) Right m -> ( modDefines m , Set.unions [ Map.keysSet (modMods m) , Map.keysSet (modInstances m) ] ) cryptol-3.0.0/src/Cryptol/Parser.y0000644000000000000000000011753307346545000015262 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.List.NonEmpty ( NonEmpty(..), cons ) 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.Token import Cryptol.Parser.ParserUtils import Cryptol.Parser.Unlit(PreProc(..), guessPreProc) import Cryptol.Utils.RecordMap(RecordMap) import Paths_cryptol } {- state 202 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 {}) _))} FRAC { $$@(Located _ (Token (Frac {}) _))} STRLIT { $$@(Located _ (Token (StrLit {}) _))} CHARLIT { $$@(Located _ (Token (ChrLit {}) _))} IDENT { $$@(Located _ (Token (Ident [] _) _))} QIDENT { $$@(Located _ (Token Ident{} _))} SELECTOR { $$@(Located _ (Token (Selector _) _))} '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 ) _)} 'submodule' { Located $$ (Token (KW KW_submodule ) _)} '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 ) _)} 'interface' { Located $$ (Token (KW KW_interface) _)} 'x' { Located $$ (Token (KW KW_x) _)} 'down' { Located $$ (Token (KW KW_down) _)} 'by' { Located $$ (Token (KW KW_by) _)} 'primitive' { Located $$ (Token (KW KW_primitive) _)} 'constraint'{ Located $$ (Token (KW KW_constraint) _)} 'foreign' { Located $$ (Token (KW KW_foreign) _)} '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 DotDotLt) _)} '..>' { Located $$ (Token (Sym DotDotGt) _)} '|' { Located $$ (Token (Sym Bar ) _)} '<' { Located $$ (Token (Sym Lt ) _)} '>' { Located $$ (Token (Sym Gt ) _)} '(' { 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 top_module top_module %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 '#' %% top_module :: { [Module PName] } : 'module' module_def {% mkTopMods $2 } | 'v{' vmod_body 'v}' {% mkAnonymousModule $2 } | 'interface' 'module' modName 'where' 'v{' sig_body 'v}' { mkTopSig $3 $6 } module_def :: { Module PName } : modName 'where' 'v{' vmod_body 'v}' { mkModule $1 $4 } | modName '=' impName 'where' 'v{' vmod_body 'v}' { mkModuleInstanceAnon $1 $3 $6 } | modName '=' impName '{' modInstParams '}' { mkModuleInstance $1 $3 $5 } modInstParams :: { ModuleInstanceArgs PName } : modInstParam { DefaultInstArg $1 } | namedModInstParams { NamedInstArgs $1 } namedModInstParams :: { [ ModuleInstanceNamedArg PName ] } : namedModInstParam { [$1] } | namedModInstParams ',' namedModInstParam { $3 : $1 } namedModInstParam :: { ModuleInstanceNamedArg PName } : ident '=' modInstParam { ModuleInstanceNamedArg $1 $3 } modInstParam :: { Located (ModuleInstanceArg PName) } : impName { fmap ModuleArg $1 } | 'interface' ident { fmap ParameterArg $2 } | '_' { Located { thing = AddParams , srcRange = $1 } } vmod_body :: { [TopDecl PName] } : vtop_decls { reverse $1 } | {- empty -} { [] } -- inverted imports1 :: { [ Located (ImportG (ImpName PName)) ] } : imports1 'v;' import { $3 : $1 } | imports1 ';' import { $3 : $1 } | import { [$1] } import :: { Located (ImportG (ImpName PName)) } : 'import' impName optInst mbAs mbImportSpec optImportWhere {% mkImport $1 $2 $3 $4 $5 $6 } | 'import' impNameBT mbAs mbImportSpec {% mkBacktickImport $1 $2 $3 $4 } optImportWhere :: { Maybe (Located [Decl PName]) } : 'where' whereClause { Just $2 } | {- empty -} { Nothing } optInst :: { Maybe (ModuleInstanceArgs PName) } : '{' modInstParams '}' { Just $2 } | {- empty -} { Nothing } impName :: { Located (ImpName PName) } : 'submodule' qname { ImpNested `fmap` $2 } | modName { ImpTop `fmap` $1 } impNameBT :: { Located (ImpName PName) } : 'submodule' '`' qname { ImpNested `fmap` $3 } | '`' modName { ImpTop `fmap` $2 } 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 ',' var { fmap getIdent $3 : $1 } | var { [fmap getIdent $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 } | foreign_bind { $1 } | private_decls { $1 } | mbDoc 'interface' 'constraint' type {% mkInterfaceConstraint $1 $4 } | parameter_decls { [ $1 ] } | mbDoc 'submodule' module_def {% ((:[]) . exportModule $1) `fmap` mkNested $3 } | mbDoc sig_def { [mkSigDecl $1 $2] } | mod_param_decl { [DModParam $1] } | mbDoc import { [DImport $2] } -- we allow for documentation here to avoid conflicts with module paramaters -- currently that odcumentation is just discarded sig_def :: { (Located PName, Signature PName) } : 'interface' 'submodule' name 'where' 'v{' sig_body 'v}' { ($3, $6) } sig_body :: { Signature PName } : par_decls {% mkInterface [] $1 } | imports1 'v;' par_decls {% mkInterface (reverse $1) $3 } | imports1 ';' par_decls {% mkInterface (reverse $1) $3 } mod_param_decl :: { ModParam PName } : mbDoc 'import' 'interface' impName mbAs { ModParam { mpSignature = $4 , mpAs = fmap thing $5 , mpName = mkModParamName $4 $5 , mpDoc = $1 , mpRenaming = mempty } } 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 } foreign_bind :: { [TopDecl PName] } : mbDoc 'foreign' name ':' schema {% mkForeignDecl $1 $3 $5 } parameter_decls :: { TopDecl PName } : 'parameter' 'v{' par_decls 'v}' { mkParDecls (reverse $3) } | doc 'parameter' 'v{' par_decls 'v}' { mkParDecls (reverse $4) } -- Reversed par_decls :: { [ParamDecl PName] } : par_decl { [$1] } | par_decls ';' par_decl { $3 : $1 } | par_decls 'v;' par_decl { $3 : $1 } par_decl :: { ParamDecl PName } : mbDoc name ':' schema { mkParFun $1 $2 $4 } | mbDoc 'type' name ':' kind {% mkParType $1 $3 $5 } | mbDoc typeOrPropSyn { mkIfacePropSyn (thing `fmap` $1) $2 } | mbDoc topTypeConstraint { DParameterConstraint (distrLoc $2) } doc :: { Located Text } : DOC { mkDoc (fmap tokenText $1) } mbDoc :: { Maybe (Located Text) } : 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 propguards_cases {% mkPropGuardsDecl $1 $2 $3 } | var propguards_cases {% mkConstantPropGuardsDecl $1 $2 } | 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 , bExport = Public } } | typeOrPropSyn { $1 } | '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_decls :: { [Decl PName] } : let_decl { [$1] } | let_decl ';' { [$1] } | let_decl ';' let_decls { ($1:$3) } let_decl :: { Decl PName } : 'let' ipat '=' expr { at ($2,$4) $ DPatBind $2 $4 } | 'let' var apats_indices '=' expr { at ($2,$5) $ mkIndexedDecl $2 $3 $5 } | 'let' '(' op ')' '=' expr { at ($2,$6) $ DPatBind (PVar $3) $6 } | 'let' apat pat_op apat '=' expr { at ($2,$6) $ DBind $ Bind { bName = $3 , bParams = [$2,$4] , bDef = at $6 (Located emptyRange (DExpr $6)) , bSignature = Nothing , bPragmas = [] , bMono = False , bInfix = True , bFixity = Nothing , bDoc = Nothing , bExport = Public } } | 'let' vars_comma ':' schema { at (head $2,$4) $ DSignature (reverse $2) $4 } | typeOrPropSyn { $1 } | 'infixl' NUM ops {% mkFixity LeftAssoc $2 (reverse $3) } | 'infixr' NUM ops {% mkFixity RightAssoc $2 (reverse $3) } | 'infix' NUM ops {% mkFixity NonAssoc $2 (reverse $3) } typeOrPropSyn :: { Decl PName } : 'type' 'constraint' type '=' type {% mkPropSyn $3 $5 } | 'type' type '=' type {% mkTySyn $2 $4 } topTypeConstraint :: { Located [Prop PName] } : 'type' 'constraint' type {% mkProp $3 } propguards_cases :: { [PropGuardCase PName] } : propguards_cases propguards_case { $2 : $1 } | propguards_case { [$1] } propguards_case :: { PropGuardCase PName } : '|' propguards_quals '=>' expr { PropGuardCase $2 $4 } propguards_quals :: { [Located (Prop PName)] } : type {% mkPropGuards $1 } newtype :: { Newtype PName } : 'newtype' type '=' newtype_body {% mkNewtype $2 $4 } newtype_body :: { Located (RecordMap Ident (Range, Type PName)) } : '{' '}' {% mkRecord (rComb $1 $2) (Located emptyRange) [] } | '{' field_types '}' {% mkRecord (rComb $1 $3) (Located emptyRange) $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) } opt_apats_indices :: { ([Pattern PName], [Pattern PName]) } : {- empty -} { ([],[]) } | apats_indices { $1 } 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_decls { LetInput $1 } | {- empty -} { EmptyInput } -------------------------------------------------------------------------------- -- 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 "^^" } | '<' { 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 { 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 { 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 emptyFunDesc (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) (EPrefix PrefixNeg $2) } | '~' simpleApp { at ($1,$2) (EPrefix PrefixComplement $2) } | simpleApp { $1 } longRHS :: { Expr PName } : '-' longApp { at ($1,$2) (EPrefix PrefixNeg $2) } | '~' longApp { at ($1,$2) (EPrefix PrefixComplement $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 :: { NonEmpty (Expr PName) } : aexpr { $1 :| [] } | aexprs aexpr { cons $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 (thing $1) } | FRAC { at $1 $ fracLit (thing $1) } | STRLIT { at $1 $ ELit $ ECString $ getStr $1 } | CHARLIT { at $1 $ ELit $ ECChar $ getChr $1 } | '_' { at $1 $ EVar $ mkUnqual $ mkIdent "_" } | '(' expr ')' { at ($1,$3) $ EParens $2 } | '(' tuple_exprs ')' { at ($1,$3) $ ETuple (reverse $2) } | '(' ')' { at ($1,$2) $ ETuple [] } | '{' '}' {% mkRecord (rComb $1 $2) ERecord [] } | '{' rec_expr '}' {% case $2 of { Left upd -> pure $ at ($1,$3) upd; Right fs -> mkRecord (rComb $1 $3) ERecord fs; }} | '[' ']' { 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,$2) $ ESel $1 (thing $2) } | sel_expr selector { at ($1,$2) $ ESel $1 (thing $2) } selector :: { Located Selector } : SELECTOR { mkSelector `fmap` $1 } 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) } tuple_exprs :: { [Expr PName] } : expr ',' expr { [ $3, $1] } | tuple_exprs ',' expr { $3 : $1 } rec_expr :: { Either (Expr PName) [Named (Expr PName)] } : aexpr '|' field_exprs { Left (EUpd (Just $1) (reverse $3)) } | '_' '|' field_exprs { Left (EUpd Nothing (reverse $3)) } | field_exprs {% Right `fmap` mapM ufToNamed $1 } field_exprs :: { [UpdField PName] } : field_expr { [$1] } | field_exprs ',' field_expr { $3 : $1 } field_expr :: { UpdField PName } : field_path opt_apats_indices field_how expr { UpdField $3 $1 (mkIndexedExpr $2 $4) } field_path :: { [Located Selector] } : aexpr {% exprToFieldPath $1 } field_how :: { UpdHow } : '=' { UpdSet } | '->' { UpdFun } 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 '..' '<' expr {% eFromToLessThan $2 $1 $4 } | expr '..<' expr {% eFromToLessThan $2 $1 $3 } | expr '..' expr 'by' expr {% eFromToBy $2 $1 $3 $5 False } | expr '..' '<' expr 'by' expr {% eFromToBy $2 $1 $4 $6 True } | expr '..<' expr 'by' expr {% eFromToBy $2 $1 $3 $5 True } | expr '..' expr 'down' 'by' expr {% eFromToDownBy $2 $1 $3 $6 False } | expr '..' '>' expr 'down' 'by' expr {% eFromToDownBy $2 $1 $4 $7 True } | expr '..>' expr 'down' 'by' expr {% eFromToDownBy $2 $1 $3 $6 True } | 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) } | '{' '}' {% mkRecord (rComb $1 $2) PRecord [] } | '{' field_pats '}' {% mkRecord (rComb $1 $3) PRecord $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 } 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 (getChr $1) } | '[' type ']' { at ($1,$3) $ TSeq $2 TBit } | '(' ktype ')' { at ($1,$3) $2 } | '(' ')' { at ($1,$2) $ TTuple [] } | '(' tuple_types ')' { at ($1,$3) $ TTuple (reverse $2) } | '{' '}' {% mkRecord (rComb $1 $2) TRecord [] } | '{' field_types '}' {% mkRecord (rComb $1 $3) TRecord $2 } | '_' { at $1 TWild } ktype :: { Type PName } : type ':' kind { TParens $1 (Just (thing $3)) } | type { TParens $1 Nothing } 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 } | 'module' smodName { $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. -} 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) (TTyApp []) } | '{' field_ty_vals '}' { at ($1,$3) (TTyApp (reverse $2)) } | '{' type '}' { anonTyApp (getLoc ($1,$3)) [$2] } | '{' tuple_types '}' { anonTyApp (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 } top_module 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-3.0.0/src/Cryptol/Parser/0000755000000000000000000000000007346545000015056 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/Parser/AST.hs0000644000000000000000000015301707346545000016050 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 #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleInstances #-} 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 , ModuleG(..) , mDecls -- XXX: Temporary , mImports , mModParams , mIsFunctor , isParamDecl , ModuleDefinition(..) , ModuleInstanceArgs(..) , ModuleInstanceNamedArg(..) , ModuleInstanceArg(..) , ModuleInstance , emptyModuleInstance , Program(..) , TopDecl(..) , Decl(..) , Fixity(..), defaultFixity , FixityCmp(..), compareFixity , TySyn(..) , PropSyn(..) , Bind(..) , BindDef(..), LBindDef , Pragma(..) , ExportType(..) , TopLevel(..) , Import, ImportG(..), ImportSpec(..), ImpName(..) , Newtype(..) , PrimType(..) , ParameterType(..) , ParameterFun(..) , NestedModule(..) , Signature(..) , SigDecl(..) , ModParam(..) , ParamDecl(..) , PropGuardCase(..) -- * Interactive , ReplInput(..) -- * Expressions , Expr(..) , Literal(..), NumInfo(..), FracInfo(..) , Match(..) , Pattern(..) , Selector(..) , TypeInst(..) , UpdField(..) , UpdHow(..) , FunDesc(..) , emptyFunDesc , PrefixOp(..) , prefixFixity , asEApps -- * Positions , Located(..) , LPName, LString, LIdent , NoPos(..) -- * Pretty-printing , cppKind, ppSelector ) where import Cryptol.Parser.Name import Cryptol.Parser.Position import Cryptol.Parser.Selector import Cryptol.Utils.Fixity import Cryptol.Utils.Ident import Cryptol.Utils.RecordMap import Cryptol.Utils.PP import Data.Map(Map) import qualified Data.Map as Map import Data.List(intersperse) import Data.Bits(shiftR) import Data.Maybe (catMaybes,mapMaybe) import Data.Ratio(numerator,denominator) import Data.Text (Text) import Numeric(showIntAtBase,showFloat,showHFloat) 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 -- | A record with located ident fields type Rec e = RecordMap Ident (Range, e) newtype Program name = Program [TopDecl name] deriving (Show) {- | A module for the pre-typechecker phasese. The two parameters are: * @mname@ the type of module names. This is because top-level and nested modules use differnt types to identify a module. * @name@ the type of identifiers used by declarations. In the parser this starts off as `PName` and after resolving names in the renamer, this becomes `Name`. -} data ModuleG mname name = Module { mName :: Located mname -- ^ Name of the module , mDef :: ModuleDefinition name } deriving (Show, Generic, NFData) -- | Different flavours of module we have. data ModuleDefinition name = NormalModule [TopDecl name] | FunctorInstance (Located (ImpName name)) (ModuleInstanceArgs name) (ModuleInstance name) -- ^ The instance is filled in by the renamer | InterfaceModule (Signature name) deriving (Show, Generic, NFData) {- | Maps names in the original functor with names in the instnace. Does *NOT* include the parameters, just names for the definitions. This *DOES* include entrirs for all the name in the instantiated functor, including names in modules nested inside the functor. -} type ModuleInstance name = Map name name emptyModuleInstance :: Ord name => ModuleInstance name emptyModuleInstance = mempty -- XXX: Review all places this is used, that it actually makes sense -- Probably shouldn't exist mDecls :: ModuleG mname name -> [TopDecl name] mDecls m = case mDef m of NormalModule ds -> ds FunctorInstance _ _ _ -> [] InterfaceModule {} -> [] -- | Imports of top-level (i.e. "file" based) modules. mImports :: ModuleG mname name -> [ Located Import ] mImports m = case mDef m of NormalModule ds -> mapMaybe topImp [ li | DImport li <- ds ] FunctorInstance {} -> [] InterfaceModule sig -> mapMaybe topImp (sigImports sig) where topImp li = case iModule i of ImpTop n -> Just li { thing = i { iModule = n } } _ -> Nothing where i = thing li -- | Get the module parameters of a module (new module system) mModParams :: ModuleG mname name -> [ ModParam name ] mModParams m = [ p | DModParam p <- mDecls m ] mIsFunctor :: ModuleG mname nmae -> Bool mIsFunctor m = any isParamDecl (mDecls m) isParamDecl :: TopDecl a -> Bool isParamDecl d = case d of DModParam {} -> True DParamDecl {} -> True _ -> False -- | A top-level module type Module = ModuleG ModName -- | A nested module. newtype NestedModule name = NestedModule (ModuleG name name) 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 = "" }) ] -- | A declaration that may only appear at the top level of a module. -- The module may be nested, however. data TopDecl name = Decl (TopLevel (Decl name)) | DPrimType (TopLevel (PrimType name)) | TDNewtype (TopLevel (Newtype name)) -- ^ @newtype T as = t | Include (Located FilePath) -- ^ @include File@ (until NoInclude) | DParamDecl Range (Signature name) -- ^ @parameter ...@ (parser only) | DModule (TopLevel (NestedModule name)) -- ^ @submodule M where ...@ | DImport (Located (ImportG (ImpName name))) -- ^ @import X@ | DModParam (ModParam name) -- ^ @import interface X ...@ | DInterfaceConstraint (Maybe Text) (Located [Prop name]) -- ^ @interface constraint@ deriving (Show, Generic, NFData) -- | Things that maybe appear in an interface/parameter block. -- These only exist during parsering. data ParamDecl name = DParameterType (ParameterType name) -- ^ @parameter type T : #@ (parser only) | DParameterFun (ParameterFun name) -- ^ @parameter someVal : [256]@ -- (parser only) | DParameterDecl (SigDecl name) -- ^ A delcaration in an interface | DParameterConstraint [Located (Prop name)] -- ^ @parameter type constraint (fin T)@ deriving (Show, Generic, NFData) -- | All arguments in a functor instantiation data ModuleInstanceArgs name = DefaultInstArg (Located (ModuleInstanceArg name)) -- ^ Single parameter instantitaion | DefaultInstAnonArg [TopDecl name] -- ^ Single parameter instantitaion using this anonymous module. -- (parser only) | NamedInstArgs [ModuleInstanceNamedArg name] deriving (Show, Generic, NFData) -- | A named argument in a functor instantiation data ModuleInstanceNamedArg name = ModuleInstanceNamedArg (Located Ident) (Located (ModuleInstanceArg name)) deriving (Show, Generic, NFData) -- | An argument in a functor instantiation data ModuleInstanceArg name = ModuleArg (ImpName name) -- ^ An argument that is a module | ParameterArg Ident -- ^ An argument that is a parameter | AddParams -- ^ Arguments adds extra parameters to decls. -- ("backtick" import) deriving (Show, Generic, NFData) -- | The name of an imported module data ImpName name = ImpTop ModName -- ^ A top-level module | ImpNested name -- ^ The module in scope with the given name deriving (Show, Generic, NFData, Eq, Ord) -- | A simple declaration. Generally these are things that can appear -- both at the top-level of a module and in `where` clauses. data Decl name = DSignature [Located name] (Schema name) -- ^ A type signature. Eliminated in NoPat--after NoPat -- signatures are in their associated Bind | DFixity !Fixity [Located name] -- ^ A fixity declaration. Eliminated in NoPat---after NoPat -- fixities are in their associated Bind | DPragma [Located name] Pragma -- ^ A pragma declaration. Eliminated in NoPat---after NoPat -- fixities are in their associated Bind | DBind (Bind name) -- ^ A non-recursive binding. | DRec [Bind name] -- ^ A group of recursive bindings. Introduced by the renamer. | DPatBind (Pattern name) (Expr name) -- ^ A pattern binding. Eliminated in NoPat---after NoPat -- fixities are in their associated Bind | DType (TySyn name) -- ^ A type synonym. | DProp (PropSyn name) -- ^ A constraint synonym. | DLocated (Decl name) Range -- ^ Keeps track of the location of a declaration. deriving (Eq, Show, Generic, NFData, Functor) -- | A type parameter for a module. data ParameterType name = ParameterType { ptName :: Located name -- ^ name of type parameter , ptKind :: Kind -- ^ kind of parameter , ptDoc :: Maybe Text -- ^ optional documentation , ptFixity :: Maybe Fixity -- ^ info for infix use , ptNumber :: !Int -- ^ number of the parameter } deriving (Eq,Show,Generic,NFData) -- | A value parameter for a module. data ParameterFun name = ParameterFun { pfName :: Located name -- ^ name of value parameter , pfSchema :: Schema name -- ^ schema for parameter , pfDoc :: Maybe Text -- ^ optional documentation , pfFixity :: Maybe Fixity -- ^ info for infix use } deriving (Eq,Show,Generic,NFData) {- | Interface Modules (aka types of functor arguments) IMPORTANT: Interface Modules are a language construct and are different from the notion of "interface" in the Cryptol implementation. Note that the names *defined* in an interface module are only really used in the other members of the interface module. When an interface module is "imported" as a functor parameter these names are instantiated to new names, because there could be multiple paramers using the same interface. -} data Signature name = Signature { sigImports :: ![Located (ImportG (ImpName name))] -- ^ Add things in scope , sigTypeParams :: [ParameterType name] -- ^ Type parameters , sigConstraints :: [Located (Prop name)] -- ^ Constraints on the type parameters and type synonyms. , sigDecls :: [SigDecl name] -- ^ Type and constraint synonyms , sigFunParams :: [ParameterFun name] -- ^ Value parameters } deriving (Show,Generic,NFData) -- | A constraint or type synonym declared in an interface. data SigDecl name = SigTySyn (TySyn name) (Maybe Text) | SigPropSyn (PropSyn name) (Maybe Text) deriving (Show,Generic,NFData) {- | A module parameter declaration. > import interface A > import interface A as B The name of the parameter is derived from the `as` clause. If there is no `as` clause then it is derived from the name of the interface module. If there is no `as` clause, then the type/value parameters are unqualified, and otherwise they are qualified. -} data ModParam name = ModParam { mpSignature :: Located (ImpName name) -- ^ Signature for parameter , mpAs :: Maybe ModName -- ^ Qualified for actual params , mpName :: !Ident {- ^ Parameter name (for inst.) Note that this is not resolved in the renamer, and is only used when instantiating a functor. -} , mpDoc :: Maybe (Located Text) -- ^ Optional documentation , mpRenaming :: !(Map name name) {- ^ Filled in by the renamer. Maps the actual (value/type) parameter names to the names in the interface module. -} } deriving (Eq,Show,Generic,NFData) -- | An import declaration. data ImportG mname = Import { iModule :: !mname , iAs :: Maybe ModName , iSpec :: Maybe ImportSpec , iInst :: !(Maybe (ModuleInstanceArgs PName)) -- ^ `iInst' exists only during parsing } deriving (Show, Generic, NFData) type Import = ImportG ModName -- | The list of names following an import. 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 Text -- ^ Optional doc string , bExport :: !ExportType } deriving (Eq, Generic, NFData, Functor, Show) type LBindDef = Located (BindDef PName) data BindDef name = DPrim | DForeign | DExpr (Expr name) | DPropGuards [PropGuardCase name] deriving (Eq, Show, Generic, NFData, Functor) data PropGuardCase name = PropGuardCase { pgcProps :: [Located (Prop name)] , pgcExpr :: Expr name } deriving (Eq,Generic,NFData,Functor,Show) data Pragma = PragmaNote String | PragmaProperty deriving (Eq, Show, Generic, NFData) data Newtype name = Newtype { nName :: Located name -- ^ Type name , nParams :: [TParam name] -- ^ Type params , nConName :: !name -- ^ Constructor function name , nBody :: Rec (Type name) -- ^ Body } 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 be an expression, a @let@ -- statement, or empty (possibly a comment). data ReplInput name = ExprInput (Expr name) | LetInput [Decl name] | EmptyInput 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 Text) , tlValue :: a } deriving (Show, Generic, NFData, Functor, Foldable, Traversable) -- | Infromation about the representation of a numeric constant. data NumInfo = BinLit Text Int -- ^ n-digit binary literal | OctLit Text Int -- ^ n-digit octal literal | DecLit Text -- ^ overloaded decimal literal | HexLit Text Int -- ^ n-digit hex literal | PolyLit Int -- ^ polynomial literal deriving (Eq, Show, Generic, NFData) -- | Information about fractional literals. data FracInfo = BinFrac Text | OctFrac Text | DecFrac Text | HexFrac Text deriving (Eq,Show,Generic,NFData) -- | Literals. data Literal = ECNum Integer NumInfo -- ^ @0x10@ (HexLit 2) | ECChar Char -- ^ @'a'@ | ECFrac Rational FracInfo -- ^ @1.2e3@ | ECString String -- ^ @\"hello\"@ deriving (Eq, Show, Generic, NFData) data Expr n = EVar n -- ^ @ x @ | ELit Literal -- ^ @ 0x10 @ | EGenerate (Expr n) -- ^ @ generate f @ | ETuple [Expr n] -- ^ @ (1,2,3) @ | ERecord (Rec (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] @ | EFromToBy Bool (Type n) (Type n) (Type n) (Maybe (Type n)) -- ^ @ [1 .. 10 by 2 : t ] @ | EFromToDownBy Bool (Type n) (Type n) (Type n) (Maybe (Type n)) -- ^ @ [10 .. 1 down by 2 : t ] @ | EFromToLessThan (Type n) (Type n) (Maybe (Type n)) -- ^ @ [ 1 .. < 10 : 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 (FunDesc n) [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) | EPrefix PrefixOp (Expr n) -- ^ @ -1, ~1 @ deriving (Eq, Show, Generic, NFData, Functor) -- | Prefix operator. data PrefixOp = PrefixNeg -- ^ @ - @ | PrefixComplement -- ^ @ ~ @ deriving (Eq, Show, Generic, NFData) prefixFixity :: PrefixOp -> Fixity prefixFixity op = Fixity { fAssoc = LeftAssoc, .. } where fLevel = case op of PrefixNeg -> 80 PrefixComplement -> 100 -- | Description of functions. Only trivial information is provided here -- by the parser. The NoPat pass fills this in as required. data FunDesc n = FunDesc { funDescrName :: Maybe n -- ^ Name of this function, if it has one , funDescrArgOffset :: Int -- ^ number of previous arguments to this function -- bound in surrounding lambdas (defaults to 0) } deriving (Eq, Show, Generic, NFData, Functor) emptyFunDesc :: FunDesc n emptyFunDesc = FunDesc Nothing 0 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 (Rec (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 | TTyApp [Named (Type n)] -- ^ @`{ x = [8], y = Integer }@ | TRecord (Rec (Type n)) -- ^ @{ x : [8], y : [32] }@ | TTuple [Type n] -- ^ @([8], [32])@ | TWild -- ^ @_@, just some type. | TLocated (Type n) Range -- ^ Location information | TParens (Type n) (Maybe Kind) -- ^ @ (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 x@ELocated{} _ = x addLoc x r = ELocated x r 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 DModule d -> getLoc d DImport d -> getLoc d DModParam d -> getLoc d DParamDecl r _ -> Just r DInterfaceConstraint _ ds -> getLoc ds instance HasLoc (ParamDecl name) where getLoc pd = case pd of DParameterType d -> getLoc d DParameterFun d -> getLoc d DParameterDecl d -> getLoc d DParameterConstraint d -> getLoc d instance HasLoc (SigDecl name) where getLoc decl = case decl of SigTySyn ts _ -> getLoc ts SigPropSyn ps _ -> getLoc ps instance HasLoc (ModParam name) where getLoc mp = getLoc (mpSignature mp) 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 (ModuleG mname 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 (NestedModule name) where getLoc (NestedModule m) = getLoc m instance HasLoc (Newtype name) where getLoc n | null locs = Nothing | otherwise = Just (rCombs locs) where locs = catMaybes ([ getLoc (nName n)] ++ map (Just . fst . snd) (displayFields (nBody n))) instance HasLoc (TySyn name) where getLoc (TySyn x _ _ _) = getLoc x instance HasLoc (PropSyn name) where getLoc (PropSyn x _ _ _) = getLoc x -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- 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) ppNamed' :: PP a => String -> (Ident, (Range, a)) -> Doc ppNamed' s (i,(_,v)) = pp i <+> text s <+> pp v instance (Show name, PPName mname, PPName name) => PP (ModuleG mname name) where ppPrec _ = ppModule "module" instance (Show name, PPName name) => PP (NestedModule name) where ppPrec _ (NestedModule m) = ppModule "submodule" m ppModule :: (Show name, PPName mname, PPName name) => Doc -> ModuleG mname name -> Doc ppModule kw m = kw' <+> ppL (mName m) <+> pp (mDef m) where kw' = case mDef m of InterfaceModule {} -> "interface" <+> kw _ -> kw instance (Show name, PPName name) => PP (ModuleDefinition name) where ppPrec _ def = case def of NormalModule ds -> "where" $$ indent 2 (vcat (map pp ds)) FunctorInstance f as inst -> vcat ( ("=" <+> pp (thing f) <+> pp as) : ppInst ) where ppInst = if null inst then [] else [ indent 2 (vcat ("/* Instance:" : instLines ++ [" */"])) ] instLines = [ " *" <+> pp k <+> "->" <+> pp v | (k,v) <- Map.toList inst ] InterfaceModule s -> ppInterface "where" s instance (Show name, PPName name) => PP (ModuleInstanceArgs name) where ppPrec _ arg = case arg of DefaultInstArg x -> braces (pp (thing x)) DefaultInstAnonArg ds -> "where" $$ indent 2 (vcat (map pp ds)) NamedInstArgs xs -> braces (commaSep (map pp xs)) instance (Show name, PPName name) => PP (ModuleInstanceNamedArg name) where ppPrec _ (ModuleInstanceNamedArg x y) = pp (thing x) <+> "=" <+> pp (thing y) instance (Show name, PPName name) => PP (ModuleInstanceArg name) where ppPrec _ arg = case arg of ModuleArg x -> pp x ParameterArg i -> "parameter" <+> pp i AddParams -> "{}" 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)) DModule d -> pp d DImport i -> pp (thing i) DModParam s -> pp s DParamDecl _ ds -> ppInterface "parameter" ds DInterfaceConstraint _ ds -> "interface constraint" <+> case map pp (thing ds) of [x] -> x [] -> "()" xs -> nest 1 (parens (commaSepFill xs)) instance (Show name, PPName name) => PP (ParamDecl name) where ppPrec _ pd = case pd of DParameterFun d -> pp d DParameterType d -> pp d DParameterDecl d -> pp d DParameterConstraint d -> "type constraint" <+> parens (commaSep (map (pp . thing) d)) ppInterface :: (Show name, PPName name) => Doc -> Signature name -> Doc ppInterface kw sig = kw $$ indent 2 (vcat (is ++ ds)) where is = map pp (sigImports sig) cs = case sigConstraints sig of [] -> [] cs' -> ["type constraint" <+> parens (commaSep (map (pp . thing) cs'))] ds = map pp (sigTypeParams sig) ++ map pp (sigDecls sig) ++ cs ++ map pp (sigFunParams sig) instance (Show name, PPName name) => PP (SigDecl name) where ppPrec p decl = case decl of SigTySyn ts _ -> ppPrec p ts SigPropSyn ps _ -> ppPrec p ps instance (Show name, PPName name) => PP (ModParam name) where ppPrec _ mp = vcat ( mbDoc ++ [ "import interface" <+> pp (thing (mpSignature mp)) <+> mbAs ] ++ mbRen ) where mbDoc = case mpDoc mp of Nothing -> [] Just d -> [pp d] mbAs = case mpAs mp of Nothing -> mempty Just d -> "as" <+> pp d mbRen | Map.null (mpRenaming mp) = [] | otherwise = [ indent 2 $ vcat $ "/* Parameters" : [ " *" <+> pp x <+> "->" <+> pp y | (x,y) <- Map.toList (mpRenaming mp) ] ++ [" */"] ] 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 "type" <+> ppPrefixName (ptName a) <+> text ":" <+> pp (ptKind a) instance (Show name, PPName name) => PP (ParameterFun name) where ppPrec _ a = 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 DRec bs -> nest 2 (vcat ("recursive" : map (ppPrec n) bs)) 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 = nest 2 $ sep [ fsep $ [text "newtype", ppL (nName nt)] ++ map pp (nParams nt) ++ [char '='] , ppRecord (map (ppNamed' ":") (displayFields (nBody nt))) ] instance (PP mname) => PP (ImportG mname) where ppPrec _ d = vcat [ text "import" <+> sep ([pp (iModule d)] ++ mbInst ++ mbAs ++ mbSpec) , indent 2 mbWhere ] where mbAs = maybe [] (\ name -> [text "as" <+> pp name]) (iAs d) mbSpec = maybe [] (\x -> [pp x]) (iSpec d) mbInst = case iInst d of Just (DefaultInstArg x) -> [ braces (pp (thing x)) ] Just (NamedInstArgs xs) -> [ braces (commaSep (map pp xs)) ] _ -> [] mbWhere = case iInst d of Just (DefaultInstAnonArg ds) -> "where" $$ vcat (map pp ds) _ -> mempty instance PP name => PP (ImpName name) where ppPrec _ nm = case nm of ImpTop x -> pp x ImpNested x -> "submodule" <+> pp x 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 = vcat (sig ++ [ 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 -> [] Just s -> [pp (DSignature [f] s)] eq = if bMono b then text ":=" else text "=" lhs = fsep (ppL f : (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 _ DForeign = text "" ppPrec p (DExpr e) = ppPrec p e ppPrec _p (DPropGuards _guards) = text "propguards" instance PPName name => PP (TySyn name) where ppPrec _ (TySyn x _ xs t) = nest 2 $ sep $ [ fsep $ [text "type", ppL x] ++ map (ppPrec 1) xs ++ [text "="] , pp t ] instance PPName name => PP (PropSyn name) where ppPrec _ (PropSyn x _ xs ps) = nest 2 $ sep $ [ fsep $ [text "constraint", ppL x] ++ 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 ECChar c -> text (show c) ECFrac n i -> ppFracLit n i ECString s -> text (show s) ppFracLit :: Rational -> FracInfo -> Doc ppFracLit x i | toRational dbl == x = case i of BinFrac _ -> frac OctFrac _ -> frac DecFrac _ -> text (showFloat dbl "") HexFrac _ -> text (showHFloat dbl "") | otherwise = frac where dbl = fromRational x :: Double frac = "fraction`" <.> braces (commaSep (map integer [ numerator x, denominator x ])) ppNumLit :: Integer -> NumInfo -> Doc ppNumLit n info = case info of DecLit _ -> integer n 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 = optParens (myPrec < contextPrec) 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 EGenerate x -> wrap n 3 (text "generate" <+> ppPrec 4 x) ETuple es -> parens (commaSep (map pp es)) ERecord fs -> braces (commaSep (map (ppNamed' "=") (displayFields fs))) EList es -> brackets (commaSep (map pp es)) EFromTo e1 e2 e3 t1 -> brackets (pp e1 <.> step <+> text ".." <+> end) where step = maybe mempty (\e -> comma <+> pp e) e2 end = maybe (pp e3) (\t -> pp e3 <+> colon <+> pp t) t1 EFromToBy isStrict e1 e2 e3 t1 -> brackets (pp e1 <+> dots <+> pp e2 <+> text "by" <+> end) where end = maybe (pp e3) (\t -> pp e3 <+> colon <+> pp t) t1 dots | isStrict = text ".. <" | otherwise = text ".." EFromToDownBy isStrict e1 e2 e3 t1 -> brackets (pp e1 <+> dots <+> pp e2 <+> text "down by" <+> end) where end = maybe (pp e3) (\t -> pp e3 <+> colon <+> pp t) t1 dots | isStrict = text ".. >" | otherwise = text ".." EFromToLessThan e1 e2 t1 -> brackets (strt <+> text ".. <" <+> end) where strt = maybe (pp e1) (\t -> pp e1 <+> colon <+> pp t) t1 end = pp e2 EInfFrom e1 e2 -> brackets (pp e1 <.> step <+> text "...") where step = maybe mempty (\e -> comma <+> pp e) e2 EComp e mss -> brackets (pp e <> align (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 $ align $ vsep [ pp e , hang "where" 2 (vcat (map pp ds)) ] -- 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) -- NOTE: these don't produce correctly parenthesized expressions without -- explicit EParens nodes when necessary, since we don't check the actual -- fixities of the operators. EInfix e1 op _ e2 -> wrap n 0 (pp e1 <+> ppInfixName (thing op) <+> pp e2) EPrefix op e -> wrap n 3 (text (prefixText op) <.> ppPrec 4 e) where isInfix (EApp (EApp (EVar ieOp) ieLeft) ieRight) = do ieFixity <- ppNameFixity ieOp return Infix { .. } isInfix _ = Nothing prefixText PrefixNeg = "-" prefixText PrefixComplement = "~" 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 -> ppTuple (map pp ps) PRecord fs -> ppRecord (map (ppNamed' "=") (displayFields fs)) PList ps -> ppList (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 [] -> [] _ -> [nest 1 (braces (commaSepFill (map pp xs)))] preds = case ps of [] -> [] _ -> [nest 1 (parens (commaSepFill (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 TTyApp fs -> braces $ commaSep $ map (ppNamed " = ") fs TRecord fs -> braces $ commaSep $ map (ppNamed' ":") (displayFields 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 mb -> parens case mb of Nothing -> pp t Just k -> pp t <+> ":" <+> pp k 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 instance PPName name => PP [Prop name] where ppPrec n props = parens . commaSep . fmap (ppPrec n) $ props -------------------------------------------------------------------------------- -- 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 Range where noPos _ = Range { from = Position 0 0, to = Position 0 0, source = "" } instance NoPos t => NoPos [t] where noPos = fmap noPos instance NoPos t => NoPos (Maybe t) where noPos = fmap noPos instance (NoPos a, NoPos b) => NoPos (a,b) where noPos (a,b) = (noPos a, noPos b) instance NoPos (Program name) where noPos (Program x) = Program (noPos x) instance NoPos (ModuleG mname name) where noPos m = Module { mName = mName m , mDef = noPos (mDef m) } instance NoPos (ModuleDefinition name) where noPos m = case m of NormalModule ds -> NormalModule (noPos ds) FunctorInstance f as ds -> FunctorInstance (noPos f) (noPos as) ds InterfaceModule s -> InterfaceModule (noPos s) instance NoPos (ModuleInstanceArgs name) where noPos as = case as of DefaultInstArg a -> DefaultInstArg (noPos a) DefaultInstAnonArg ds -> DefaultInstAnonArg (noPos ds) NamedInstArgs xs -> NamedInstArgs (noPos xs) instance NoPos (ModuleInstanceNamedArg name) where noPos (ModuleInstanceNamedArg x y) = ModuleInstanceNamedArg (noPos x) (noPos y) instance NoPos (NestedModule name) where noPos (NestedModule m) = NestedModule (noPos 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) DModule d -> DModule (noPos d) DImport d -> DImport (noPos d) DModParam d -> DModParam (noPos d) DParamDecl _ ds -> DParamDecl rng (noPos ds) where rng = Range { from = Position 0 0, to = Position 0 0, source = "" } DInterfaceConstraint d ds -> DInterfaceConstraint d (noPos (noPos <$> ds)) instance NoPos (ParamDecl name) where noPos pd = case pd of DParameterFun d -> DParameterFun (noPos d) DParameterType d -> DParameterType (noPos d) DParameterDecl d -> DParameterDecl (noPos d) DParameterConstraint d -> DParameterConstraint (noPos d) instance NoPos (Signature name) where noPos sig = Signature { sigImports = sigImports sig , sigTypeParams = map noPos (sigTypeParams sig) , sigDecls = map noPos (sigDecls sig) , sigConstraints = map noPos (sigConstraints sig) , sigFunParams = map noPos (sigFunParams sig) } instance NoPos (SigDecl name) where noPos decl = case decl of SigTySyn ts mb -> SigTySyn (noPos ts) mb SigPropSyn ps mb -> SigPropSyn (noPos ps) mb instance NoPos (ModParam name) where noPos mp = ModParam { mpSignature = noPos (mpSignature mp) , mpAs = mpAs mp , mpName = mpName mp , mpDoc = noPos <$> mpDoc mp , mpRenaming = mpRenaming mp } 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) DRec bs -> DRec (map noPos bs) 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 , nConName = nConName n , nBody = fmap 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 , bExport = bExport 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 EGenerate x -> EGenerate (noPos x) ETuple x -> ETuple (noPos x) ERecord x -> ERecord (fmap 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) EFromToBy isStrict x y z t -> EFromToBy isStrict (noPos x) (noPos y) (noPos z) (noPos t) EFromToDownBy isStrict x y z t -> EFromToDownBy isStrict (noPos x) (noPos y) (noPos z) (noPos t) EFromToLessThan x y t -> EFromToLessThan (noPos x) (noPos y) (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 dsc x y -> EFun dsc (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) EPrefix op x -> EPrefix op (noPos x) 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 (fmap 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) TTyApp x -> TTyApp (noPos x) TRecord x -> TRecord (fmap 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 k -> TParens (noPos x) k TInfix x y f z-> TInfix (noPos x) y f (noPos z) instance NoPos (Prop name) where noPos (CType t) = CType (noPos t) cryptol-3.0.0/src/Cryptol/Parser/ExpandPropGuards.hs0000644000000000000000000001117007346545000020640 0ustar0000000000000000{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -- | -- Module : Cryptol.Parser.PropGuards -- Copyright : (c) 2022 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable -- -- Expands PropGuards into a top-level definition for each case, and rewrites -- the body of each case to be an appropriate call to the respectively generated -- function. module Cryptol.Parser.ExpandPropGuards where import Control.DeepSeq import Cryptol.Parser.AST import Cryptol.Utils.PP import Cryptol.Utils.Panic (panic) import Data.Text (pack) import GHC.Generics (Generic) -- | Monad type ExpandPropGuardsM a = Either Error a runExpandPropGuardsM :: ExpandPropGuardsM a -> Either Error a runExpandPropGuardsM m = m -- | Error data Error = NoSignature (Located PName) deriving (Show, Generic, NFData) instance PP Error where ppPrec _ err = case err of NoSignature x -> text "At" <+> pp (srcRange x) <.> colon <+> text "Declarations using constraint guards require an explicit type signature." expandPropGuards :: ModuleG mname PName -> ExpandPropGuardsM (ModuleG mname PName) expandPropGuards m = do def <- expandModuleDef (mDef m) pure m { mDef = def } expandModuleDef :: ModuleDefinition PName -> ExpandPropGuardsM (ModuleDefinition PName) expandModuleDef m = case m of NormalModule ds -> NormalModule . concat <$> mapM expandTopDecl ds FunctorInstance {} -> pure m InterfaceModule {} -> pure m expandTopDecl :: TopDecl PName -> ExpandPropGuardsM [TopDecl PName] expandTopDecl topDecl = case topDecl of Decl topLevelDecl -> do ds <- expandDecl (tlValue topLevelDecl) pure [ Decl topLevelDecl { tlValue = d } | d <- ds ] DModule tl | NestedModule m <- tlValue tl -> do m1 <- expandPropGuards m pure [DModule tl { tlValue = NestedModule m1 }] _ -> pure [topDecl] expandDecl :: Decl PName -> ExpandPropGuardsM [Decl PName] expandDecl decl = case decl of DBind bind -> do bs <- expandBind bind pure (map DBind bs) _ -> pure [decl] expandBind :: Bind PName -> ExpandPropGuardsM [Bind PName] expandBind bind = case thing (bDef bind) of DPropGuards guards -> do Forall params props t rng <- case bSignature bind of Just schema -> pure schema Nothing -> Left . NoSignature $ bName bind let goGuard :: PropGuardCase PName -> ExpandPropGuardsM (PropGuardCase PName, Bind PName) goGuard (PropGuardCase props' e) = do bName' <- newName (bName bind) (thing <$> props') -- call to generated function tParams <- case bSignature bind of Just (Forall tps _ _ _) -> pure tps Nothing -> Left $ NoSignature (bName bind) typeInsts <- (\(TParam n _ _) -> Right . PosInst $ TUser n []) `traverse` tParams let e' = foldl EApp (EAppT (EVar $ thing bName') typeInsts) (patternToExpr <$> bParams bind) pure ( PropGuardCase props' e', bind { bName = bName', -- include guarded props in signature bSignature = Just (Forall params (props <> map thing props') t rng), -- keeps same location at original bind -- i.e. "on top of" original bind bDef = (bDef bind) {thing = DExpr e} } ) (guards', binds') <- unzip <$> mapM goGuard guards pure $ bind {bDef = DPropGuards guards' <$ bDef bind} : binds' _ -> pure [bind] patternToExpr :: Pattern PName -> Expr PName patternToExpr (PVar locName) = EVar (thing locName) patternToExpr _ = panic "patternToExpr" ["Unimplemented: patternToExpr of anything other than PVar"] newName :: Located PName -> [Prop PName] -> ExpandPropGuardsM (Located PName) newName locName props = pure case thing locName of Qual modName ident -> let txt = identText ident txt' = pack $ show $ pp props in Qual modName (mkIdent $ txt <> txt') <$ locName UnQual ident -> let txt = identText ident txt' = pack $ show $ pp props in UnQual (mkIdent $ txt <> txt') <$ locName NewName _ _ -> panic "mkName" [ "During expanding prop guards" , "tried to make new name from NewName case of PName" ] cryptol-3.0.0/src/Cryptol/Parser/Layout.hs0000644000000000000000000002002707346545000016670 0ustar0000000000000000{-# Language BlockArguments #-} {-# Language OverloadedStrings #-} module Cryptol.Parser.Layout where import Cryptol.Utils.Panic(panic) import Cryptol.Parser.Position import Cryptol.Parser.Token {- We assume the existence of an explicit EOF token at the end of the input. This token is *less* indented than all other tokens (i.e., it is at column 0) Explicit Layout Blocks * The symbols `(`, `{`, and `[` start an explicit layout block. * While in an explicit layout block we pass through tokens, except: - We may start new implicit or explicit layout blocks - A `,` terminates any *nested* layout blocks - We terminate the current layout block if we encounter the matching closing symbol `)`, `}`, `]` Implicit Layout Blocks * The keywords `where`, `private`, and `parameter` start an implicit layout block. * The layout block starts at the column of the *following* token and we insert "virtual start block" between the current and the following tokens. * While in an implicit layout block: - We may start new implicit or explicit layout blocks - We insert a "virtual separator" before tokens starting at the same column as the layout block, EXCEPT: * we do not insert a separator if the previous token was a "documentation comment" * we do not insert a separator before the first token in the block - The implicit layout block is ended by: * a token than is less indented that the block, or * `)`, `}`, `]`, or * ',' but only if there is an outer paren block block's column. - When an implicit layout block ends, we insert a "virtual end block" token just before the token that caused the block to end. Examples: f = x where x = 0x1 -- end implicit layout by layout g = 0x3 -- (`g` is less indented than `x`) f (x where x = 2) -- end implicit layout by `)` [ x where x = 2, 3 ] -- end implicit layout by `,` module A where -- two implicit layout blocks with the private -- *same* indentation (`where` and `private`) x = 0x2 -} layout :: Bool -> [Located Token] -> [Located Token] layout isMod ts0 -- Star an implicit layout block at the top of the module | let t = head ts0 rng = srcRange t blockCol = max 1 (col (from rng)) -- see startImplicitBlock implictMod = case map (tokenType . thing) ts0 of KW KW_module : _ -> False KW KW_interface : KW KW_module : _ -> False _ -> True , isMod && implictMod = virt rng VCurlyL : go [ Virtual blockCol ] blockCol True ts0 | otherwise = go [] 0 False ts0 where {- State parameters for `go`: stack: The stack of implicit and explicit blocks lastVirt: The indentation of the outer most implicit block, or 0 if none. This can be computed from the stack but we cache it here as we need to check it on each token. noVirtSep: Do not emit a virtual separator even if token matches block alignment. This is enabled at the beginning of a block, or after a doc string, or if we just emitted a separtor, but have not yet consumed the next token. tokens: remaining tokens to process -} go stack lastVirt noVirtSep tokens -- End implicit layout due to indentation. If the outermost block -- is a lyout block we just end it. If the outermost block is an -- explicit layout block we report a lexical error. | col curLoc < lastVirt = endImplictBlock -- End implicit layout block due to a symbol | Just (Virtual {}) <- curBlock, endsLayout curTokTy = endImplictBlock -- End implicit layout block due to a comma | Just (Virtual {}) <- curBlock , Sym Comma <- curTokTy , not (null [ () | Explicit _ <- popStack ]) = endImplictBlock -- Insert a virtual separator | Just (Virtual {}) <- curBlock , col curLoc == lastVirt && not noVirtSep = virt curRange VSemi : go stack lastVirt True tokens -- Start a new implicit layout. Advances token position. | startsLayout curTokTy = startImplicitBlock -- Start a paren block. Advances token position | Just close <- startsParenBlock curTokTy = curTok : go (Explicit close : stack) lastVirt False advanceTokens -- End a paren block. Advances token position | Just (Explicit close) <- curBlock, close == curTokTy = curTok : go popStack lastVirt False advanceTokens -- Disable virtual separator after doc string. Advances token position | White DocStr <- curTokTy = curTok : go stack lastVirt True advanceTokens -- Check to see if we are done. Note that if we got here, implicit layout -- blocks should have already been closed, as `EOF` is less indented than -- all other tokens | EOF <- curTokTy = [curTok] -- Any other token, just emit. Advances token position | otherwise = curTok : go stack lastVirt False advanceTokens where (curTok, advanceTokens) = case tokens of (curTok' : advanceTokens') -> (curTok', advanceTokens') [] -> error "layout: Unexpected empty list of tokens" curTokTy = tokenType (thing curTok) curRange = srcRange curTok curLoc = from curRange (curBlock,popStack) = case stack of a : b -> (Just a,b) [] -> (Nothing, panic "layout" ["pop empty stack"]) startImplicitBlock = let nextRng = srcRange (head advanceTokens) nextLoc = from nextRng blockCol = max 1 (col nextLoc) -- the `max` ensuraes that indentation is always at least 1, -- in case we are starting a block at the very end of the input in curTok : virt nextRng VCurlyL : go (Virtual blockCol : stack) blockCol True advanceTokens endImplictBlock = case curBlock of Just (Virtual {}) -> virt curRange VCurlyR : go popStack newVirt False tokens where newVirt = case [ n | Virtual n <- popStack ] of n : _ -> n _ -> 0 Just (Explicit c) -> errTok curRange (InvalidIndentation c) : advanceTokens Nothing -> panic "layout" ["endImplictBlock with empty stack"] -------------------------------------------------------------------------------- data Block = Virtual Int -- ^ Virtual layout block | Explicit TokenT -- ^ An explicit layout block, expecting this ending token. deriving (Show) -- | These tokens start an implicit layout block startsLayout :: TokenT -> Bool startsLayout ty = case ty of KW KW_where -> True KW KW_private -> True KW KW_parameter -> True _ -> False -- | These tokens end an implicit layout block endsLayout :: TokenT -> Bool endsLayout ty = case ty of Sym BracketR -> True Sym ParenR -> True Sym CurlyR -> True _ -> False -- | These tokens start an explicit "paren" layout block. -- If so, the result contains the corresponding closing paren. startsParenBlock :: TokenT -> Maybe TokenT startsParenBlock ty = case ty of Sym BracketL -> Just (Sym BracketR) Sym ParenL -> Just (Sym ParenR) Sym CurlyL -> Just (Sym CurlyR) _ -> Nothing -------------------------------------------------------------------------------- -- | Make a virtual token of the given type virt :: Range -> TokenV -> Located Token virt rng x = Located { srcRange = rng { to = from rng }, thing = t } where t = Token (Virt x) case x of VCurlyL -> "beginning of layout block" VCurlyR -> "end of layout block" VSemi -> "layout block separator" errTok :: Range -> TokenErr -> Located Token errTok rng x = Located { srcRange = rng { to = from rng }, thing = t } where t = Token { tokenType = Err x, tokenText = "" } cryptol-3.0.0/src/Cryptol/Parser/Lexer.x0000644000000000000000000002104507346545000016330 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 , dbgLex ) where import Cryptol.Parser.Position import Cryptol.Parser.Token import Cryptol.Parser.LexerUtils import qualified Cryptol.Parser.Layout as L 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 @num = [0-9] @id_next* @fnum = [0-9] @id_next* "." (@id_next | [pPeE][\+\-])+ @selector = "." @id_next+ @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 } "if" { emit $ KW KW_if } "private" { emit $ KW KW_private } "include" { emit $ KW KW_include } "module" { emit $ KW KW_module } "submodule" { emit $ KW KW_submodule } "interface" { emit $ KW KW_interface } "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 } "down" { emit $ KW KW_down } "by" { emit $ KW KW_by } "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 } "foreign" { emit $ KW KW_foreign } "Prop" { emit $ KW KW_Prop } @num { emitS numToken } @fnum { emitFancy fnumTokens } "_" { emit $ Sym Underscore } @id { mkIdent } @selector { emitS selectorToken } "\" { emit $ Sym Lambda } "->" { emit $ Sym ArrR } "<-" { emit $ Sym ArrL } "=>" { emit $ Sym FatArrR } "=" { emit $ Sym EqDef } "," { emit $ Sym Comma } ";" { emit $ Sym Semi } ":" { emit $ Sym Colon } "`" { emit $ Sym BackTick } ".." { emit $ Sym DotDot } "..." { emit $ Sym DotDotDot } "..<" { emit $ Sym DotDotLt } "..>" { emit $ Sym DotDotGt } "|" { 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 ) } -- < can appear in the enumeration syntax `[ x .. < y ] "<" { emit $ Sym Lt } -- > can appear in the enumeration syntax `[ x .. > y down by n ] ">" { emit $ Sym Gt } -- 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 -> L.layout (cfgModuleScope 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 = cfgStart cfg , 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 (mtok ++ rest, pos) dbgLex file = do txt <- readFile file let (ts,_) = lexer defaultConfig (Text.pack txt) mapM_ (print . thing) ts -- vim: ft=haskell } cryptol-3.0.0/src/Cryptol/Parser/LexerUtils.hs0000644000000000000000000003253207346545000017517 0ustar0000000000000000-- | -- Module : Cryptol.Parser.LexerUtils -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE OverloadedStrings #-} module Cryptol.Parser.LexerUtils where import Control.Monad(guard) import Data.Char(toLower,generalCategory,isAscii,ord,isSpace, isAlphaNum,isAlpha) import qualified Data.Char as Char import Data.Text(Text) import qualified Data.Text as T import qualified Data.Text.Read as T import Data.Word(Word8) import Cryptol.Utils.Panic import Cryptol.Parser.Position import Cryptol.Parser.Token import Cryptol.Parser.Unlit(PreProc(None)) data Config = Config { cfgSource :: !FilePath -- ^ File that we are working on , cfgStart :: !Position -- ^ Starting position for the parser , 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 = "" , cfgStart = start , cfgLayout = Layout , cfgPreProc = None , cfgAutoInclude = [] , cfgModuleScope = True } type Action = Config -> Position -> Text -> LexS -> ([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 = ([], 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 -> ([mkToken d f cs], Normal) InComment d _ (q:qs) cs -> ([], 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 = ([], 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 -> ([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 -> ([], InComment d p1 ps (txt : cs)) _ -> panic "[Lexer] startEndComment" ["in string or char?"] startString :: Action startString _ p txt _ = ([],InString p txt) endString :: Action endString cfg pe txt s = case s of InString ps str -> ([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 -> ([],InString p (str `T.append` txt)) _ -> panic "[Lexer] addToString" ["outside string"] startChar :: Action startChar _ p txt _ = ([],InChar p txt) endChar :: Action endChar cfg pe txt s = case s of InChar ps str -> ([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 -> ([],InChar p (str `T.append` txt)) _ -> panic "[Lexer] addToChar" ["outside character"] mkIdent :: Action mkIdent cfg p s z = ([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 = ([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 = ([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 = ([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 emitFancy :: (FilePath -> Position -> Text -> [Located Token]) -> Action emitFancy f = \cfg p s z -> (f (cfgSource 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 :: Text -> TokenT numToken ds = case toVal of Just v -> Num v rad (T.length ds') Nothing -> Err MalformedLiteral where rad | "0b" `T.isPrefixOf` ds = 2 | "0o" `T.isPrefixOf` ds = 8 | "0x" `T.isPrefixOf` ds = 16 | otherwise = 10 ds1 = if rad == 10 then ds else T.drop 2 ds ds' = T.filter (/= '_') ds1 toVal = T.foldl' step (Just 0) ds' irad = toInteger rad step mb x = do soFar <- mb d <- fromDigit irad x pure $! (irad * soFar + d) fromDigit :: Integer -> Char -> Maybe Integer fromDigit r x' = do d <- v guard (d < r) pure d where x = toLower x' v | '0' <= x && x <= '9' = Just $ toInteger $ fromEnum x - fromEnum '0' | 'a' <= x && x <= 'z' = Just $ toInteger $ 10 + fromEnum x - fromEnum 'a' | otherwise = Nothing -- | Interpret something either as a fractional token, -- a number followed by a selector, or an error. fnumTokens :: FilePath -> Position -> Text -> [Located Token] fnumTokens file pos ds = case wholeNum of Nothing -> [ tokFrom pos ds (Err MalformedLiteral) ] Just i | Just f <- fracNum, Just e <- expNum -> [ tokFrom pos ds (Frac ((fromInteger i + f) * (eBase ^^ e)) rad) ] | otherwise -> [ tokFrom pos whole (Num i rad (T.length whole)) , tokFrom afterWhole rest (selectorToken rest) ] where tokFrom tpos txt t = Located { srcRange = Range { from = tpos, to = moves tpos txt, source = file } , thing = Token { tokenText = txt, tokenType = t } } afterWhole = moves pos whole rad | "0b" `T.isPrefixOf` ds = 2 | "0o" `T.isPrefixOf` ds = 8 | "0x" `T.isPrefixOf` ds = 16 | otherwise = 10 radI = fromIntegral rad :: Integer radR = fromIntegral rad :: Rational (whole,rest) = T.break (== '.') (if rad == 10 then ds else T.drop 2 ds) digits = T.filter (/= '_') expSym e = if rad == 10 then toLower e == 'e' else toLower e == 'p' (frac,mbExp) = T.break expSym (T.drop 1 rest) wholeStep mb c = do soFar <- mb d <- fromDigit radI c pure $! (radI * soFar + d) wholeNum = T.foldl' wholeStep (Just 0) (digits whole) fracStep mb c = do soFar <- mb d <- fromInteger <$> fromDigit radI c pure $! ((soFar + d) / radR) fracNum = do let fds = T.reverse (digits frac) guard (T.length fds > 0) T.foldl' fracStep (Just 0) fds expNum = case T.uncons mbExp of Nothing -> Just (0 :: Integer) Just (_,es) -> case T.uncons es of Just ('+', more) -> readDecimal more Just ('-', more) -> negate <$> readDecimal more _ -> readDecimal es eBase = if rad == 10 then 10 else 2 :: Rational -- assumes we start with a dot selectorToken :: Text -> TokenT selectorToken txt | Just n <- readDecimal body, n >= 0 = Selector (TupleSelectorTok n) | Just (x,xs) <- T.uncons body , id_first x , T.all id_next xs = Selector (RecordSelectorTok body) | otherwise = Err MalformedSelector where body = T.drop 1 txt id_first x = isAlpha x || x == '_' id_next x = isAlphaNum x || x == '_' || x == '\'' readDecimal :: Integral a => Text -> Maybe a readDecimal txt = case T.decimal txt of Right (a,more) | T.null more -> Just a _ -> Nothing ------------------------------------------------------------------------------- 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 -- | 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-3.0.0/src/Cryptol/Parser/Name.hs0000644000000000000000000000454507346545000016302 0ustar0000000000000000-- | -- Module : Cryptol.Parser.Name -- Copyright : (c) 2015-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Safe #-} module Cryptol.Parser.Name where import Cryptol.Utils.Fixity 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 | ExpandPropGuards String 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" ExpandPropGuards _ -> "epg" 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 (Fixity 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 -> mempty 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 -> mempty cryptol-3.0.0/src/Cryptol/Parser/Names.hs0000644000000000000000000002541607346545000016465 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. {-# LANGUAGE Safe #-} module Cryptol.Parser.Names ( tnamesNT , tnamesT , tnamesC , namesD , tnamesD , namesB , namesP , namesNT , boundNames , boundNamesSet ) where import Cryptol.Parser.AST import Cryptol.Utils.RecordMap 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 ], ()) namesNT :: Newtype name -> ([Located name], ()) namesNT x = ([ (nName x) { thing = nConName 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 DRec bs -> let (xs,ys) = unzip (map namesB bs) in (concat xs, Set.unions ys) -- remove binders? 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 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 DForeign = Set.empty namesDef (DExpr e) = namesE e namesDef (DPropGuards guards) = Set.unions (map (namesE . pgcExpr) guards) -- | 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 EGenerate e -> namesE e ETuple es -> Set.unions (map namesE es) ERecord fs -> Set.unions (map (namesE . snd) (recordElements 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 EFromToBy{} -> Set.empty EFromToDownBy{} -> Set.empty EFromToLessThan{} -> 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)) EPrefix _ e -> namesE e 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 snd (recordElements 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) DRec bs -> ([], Set.unions (map tnamesB bs)) 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 DForeign = Set.empty tnamesDef (DExpr e) = tnamesE e tnamesDef (DPropGuards guards) = Set.unions (map tnamesPropGuardCase guards) tnamesPropGuardCase :: Ord name => PropGuardCase name -> Set name tnamesPropGuardCase c = Set.unions (tnamesE (pgcExpr c) : map (tnamesC . thing) (pgcProps c)) -- | 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 EGenerate e -> tnamesE e ETuple es -> Set.unions (map tnamesE es) ERecord fs -> Set.unions (map (tnamesE . snd) (recordElements 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 EFromToBy _ a b c t -> Set.unions [ tnamesT a, tnamesT b, tnamesT c, maybe Set.empty tnamesT t ] EFromToDownBy _ a b c t -> Set.unions [ tnamesT a, tnamesT b, tnamesT c, maybe Set.empty tnamesT t ] EFromToLessThan a b t -> tnamesT a `Set.union` tnamesT b `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) EPrefix _ e -> tnamesE e 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 . snd) (recordElements 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 . snd) (recordElements fs)) TTyApp 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-3.0.0/src/Cryptol/Parser/NoInclude.hs0000644000000000000000000001774507346545000017310 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 #-} {-# LANGUAGE BlockArguments #-} module Cryptol.Parser.NoInclude ( removeIncludesModule , IncludeError(..), ppIncludeError ) where import qualified Control.Applicative as A import Control.DeepSeq import qualified Control.Exception as X import qualified Control.Monad.Fail as Fail import Data.Set(Set) import qualified Data.Set as Set import Data.ByteString (ByteString) import Data.Either (partitionEithers) import Data.Text(Text) import qualified Data.Text.Encoding as T (decodeUtf8') import Data.Text.Encoding.Error (UnicodeException) import GHC.Generics (Generic) import MonadLib import System.Directory (makeAbsolute) import System.FilePath (takeDirectory,(),isAbsolute) import Cryptol.Utils.PP hiding (()) import Cryptol.Parser (parseProgramWith) import Cryptol.Parser.AST import Cryptol.Parser.LexerUtils (Config(..),defaultConfig) import Cryptol.Parser.ParserUtils import Cryptol.Parser.Unlit (guessPreProc) removeIncludesModule :: (FilePath -> IO ByteString) -> FilePath -> Module PName -> IO (Either [IncludeError] (Module PName, Set FilePath)) removeIncludesModule reader modPath m = runNoIncM reader modPath (noIncludeModule m) data IncludeError = IncludeFailed (Located FilePath) | IncludeDecodeFailed (Located FilePath) UnicodeException | 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" IncludeDecodeFailed lp err -> (char '`' <.> text (thing lp) <.> char '`') <+> text "included at" <+> pp (srcRange lp) <+> text "contains invalid UTF-8." <+> text "Details:" $$ nest 2 (vcat (map text (lines (X.displayException err)))) 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] ( StateT Deps IO )) a } type Deps = Set FilePath data Env = Env { envSeen :: [Located FilePath] -- ^ Files that have been loaded , envIncPath :: FilePath -- ^ The path that includes are relative to , envFileReader :: FilePath -> IO ByteString -- ^ How to load files } runNoIncM :: (FilePath -> IO ByteString) -> FilePath -> NoIncM a -> IO (Either [IncludeError] (a,Deps)) runNoIncM reader sourcePath m = do incPath <- getIncPath sourcePath (mb,s) <- runM (unM m) Env { envSeen = [] , envIncPath = incPath , envFileReader = reader } Set.empty pure do ok <- mb pure (ok,s) 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) addDep :: FilePath -> NoIncM () addDep path = M do s <- get let s1 = Set.insert path s s1 `seq` set s1 instance Functor NoIncM where fmap = liftM instance A.Applicative NoIncM where pure x = M (pure x) (<*>) = ap instance Monad NoIncM where return = pure m >>= f = M (unM m >>= unM . f) instance Fail.MonadFail NoIncM where 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 :: ModuleG mname PName -> NoIncM (ModuleG mname PName) noIncludeModule m = do newDef <- case mDef m of NormalModule ds -> NormalModule <$> doDecls ds FunctorInstance f as is -> pure (FunctorInstance f as is) InterfaceModule s -> pure (InterfaceModule s) pure m { mDef = newDef } where doDecls = fmap concat . collectErrors noIncTopDecl -- | 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 _ -> pure [td] DPrimType {} -> pure [td] TDNewtype _-> pure [td] DParamDecl {} -> pure [td] DInterfaceConstraint {} -> pure [td] Include lf -> resolveInclude lf DModule tl -> case tlValue tl of NestedModule m -> do m1 <- noIncludeModule m pure [ DModule tl { tlValue = NestedModule m1 } ] DImport {} -> pure [td] DModParam {} -> pure [td] -- | 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 let cfg = defaultConfig { cfgSource = thing lf , cfgPreProc = guessPreProc (thing lf) } case parseProgramWith cfg source of Right prog -> do Program ds <- do path <- fromIncPath (thing lf) withIncPath path (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 readBytes <- envFileReader <$> M ask file <- fromIncPath (thing path) addDep file sourceBytes <- readBytes file `failsWith` handler sourceText <- X.evaluate (T.decodeUtf8' sourceBytes) `failsWith` handler case sourceText of Left encodingErr -> M (raise [IncludeDecodeFailed path encodingErr]) Right txt -> return txt where handler :: X.IOException -> NoIncM a handler _ = includeFailed path cryptol-3.0.0/src/Cryptol/Parser/NoPat.hs0000644000000000000000000005451107346545000016441 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, fixities, -- and pragmas with the names to which they belong. {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BlockArguments #-} 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 Cryptol.Utils.RecordMap import MonadLib hiding (mapM) import Data.Maybe(maybeToList) import qualified Data.Map as Map import Data.Text (Text) import GHC.Generics (Generic) import Control.DeepSeq 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 (ModuleG mname PName) where removePatterns m = runNoPatM (noPatModule m) instance RemovePatterns [Decl PName] where removePatterns ds = runNoPatM (noPatDs ds) instance RemovePatterns (NestedModule PName) where removePatterns (NestedModule m) = (NestedModule m1,errs) where (m1,errs) = removePatterns m 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 , bExport = Public } 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 let (shape, els) = unzip (canonicalFields fs) (as,dss) <- unzip `fmap` mapM (noPat . snd) els x <- newName r <- getRange let ty = TRecord (fmap (\(rng,_) -> (rng,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 EGenerate e -> EGenerate <$> noPatE e ETuple es -> ETuple <$> mapM noPatE es ERecord es -> ERecord <$> traverse (traverse noPatE) 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 EFromToBy {} -> return expr EFromToDownBy {} -> return expr EFromToLessThan{} -> 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 desc ps e -> noPatFun (funDescrName desc) (funDescrArgOffset desc) ps e 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 EPrefix op e -> EPrefix op <$> noPatE e noPatUF :: UpdField PName -> NoPatM (UpdField PName) noPatUF (UpdField h ls e) = UpdField h ls <$> noPatE e -- Desugar lambdas with multiple patterns into a sequence of -- lambdas with a single, simple pattern each. Bindings required -- to simplify patterns are placed inside "where" blocks that are -- interspersed into the lambdas to ensure that the lexical -- structure is reliable, with names on the right shadowing names -- on the left. noPatFun :: Maybe PName -> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName) noPatFun _ _ [] e = noPatE e noPatFun mnm offset (p:ps) e = do (p',ds) <- noPat p e' <- noPatFun mnm (offset+1) ps e let body = case ds of [] -> e' _ -> EWhere e' $ map DBind (reverse ds) -- ^ -- This reverse isn't strictly necessary, but yields more sensible -- variable ordering results from type inference. I'm not entirely -- sure why. let desc = FunDesc mnm offset return (EFun desc [p'] 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 ] DForeign | null (bParams b) -> return b | otherwise -> panic "NoPat" [ "noMatchB: foreign with params" , show b ] DExpr e -> do e' <- noPatFun (Just (thing (bName b))) 0 (bParams b) e return b { bParams = [], bDef = DExpr e' <$ bDef b } DPropGuards guards -> do let nm = thing (bName b) ps = bParams b gs <- mapM (noPatPropGuardCase nm ps) guards pure b { bParams = [], bDef = DPropGuards gs <$ bDef b } noPatPropGuardCase :: PName -> [Pattern PName] -> PropGuardCase PName -> NoPatM (PropGuardCase PName) noPatPropGuardCase f xs pc = do e <- noPatFun (Just f) 0 xs (pgcExpr pc) pure pc { pgcExpr = e } 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] DRec {} -> panic "noMatchD" [ "DRec" ] 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 , bExport = Public } : 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 :: ModuleG mname PName -> NoPatM (ModuleG mname PName) noPatModule m = do def <- case mDef m of NormalModule ds -> NormalModule <$> noPatTopDs ds FunctorInstance f as i -> pure (FunctorInstance f as i) InterfaceModule s -> pure (InterfaceModule s) pure m { mDef = def } -------------------------------------------------------------------------------- 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 Text ] } 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 DParamDecl {} -> (d :) <$> annotTopDs ds DInterfaceConstraint {} -> (d :) <$> annotTopDs ds -- XXX: we may want to add pragmas to newtypes? TDNewtype {} -> (d :) <$> annotTopDs ds Include {} -> (d :) <$> annotTopDs ds DModule m -> case removePatterns (tlValue m) of (m1,errs) -> do lift (mapM_ recordError errs) (DModule m { tlValue = m1 } :) <$> annotTopDs ds DImport {} -> (d :) <$> annotTopDs ds DModParam {} -> (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) DRec {} -> panic "annotD" [ "DRec" ] 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 } -- | 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 Text] -> NoPatM (Maybe Text) 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 Text])] 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]) ] DRec {} -> panic "toDocs" [ "DRec" ] 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 x = M (pure x) (<*>) = ap instance Monad NoPatM where return = pure 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-3.0.0/src/Cryptol/Parser/ParserUtils.hs0000644000000000000000000013415307346545000017676 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 BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Cryptol.Parser.ParserUtils where import qualified Data.Text as Text import Data.Char(isAlphaNum) import Data.Maybe(fromMaybe) import Data.Bits(testBit,setBit) import Data.Maybe(mapMaybe) import Data.List(foldl') import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE import Control.Monad(liftM,ap,unless,guard,msum) import qualified Control.Monad.Fail as Fail import Data.Text(Text) import qualified Data.Text as T import qualified Data.Map as Map import Text.Read(readMaybe) import GHC.Generics (Generic) import Control.DeepSeq import Prelude () import Prelude.Compat import Cryptol.Parser.AST import Cryptol.Parser.Lexer import Cryptol.Parser.Token(SelectorType(..)) import Cryptol.Parser.Position import Cryptol.Parser.Utils (translateExprToNumT,widthIdent) import Cryptol.Utils.Ident( packModName,packIdent,modNameChunks , identAnonArg, identAnonIfaceMod , modNameArg, modNameIfaceMod , modNameToText, modNameIsNormal , modNameToNormalModName , unpackIdent ) import Cryptol.Utils.PP import Cryptol.Utils.Panic import Cryptol.Utils.RecordMap 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) MalformedLiteral -> "malformed literal: " ++ T.unpack (tokenText it) MalformedSelector -> "malformed selector: " ++ T.unpack (tokenText it) InvalidIndentation c -> "invalid indentation, unmatched " ++ case c of Sym CurlyR -> "{ ... } " Sym ParenR -> "( ... )" Sym BracketR -> "[ ... ]" _ -> show c -- basically panic ] 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 $$ indent 2 "Documentation comments need to be followed by something to document." | otherwise = text "Parse error at" <+> text path <.> char ':' <.> pp pos <.> comma $$ indent 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 xs) = text "Parse error at" <+> pp p $$ indent 2 (vcat (map text xs)) ppError (HappyUnexpected path ltok e) = nest 2 $ vcat $ [ text "Parse error at" <+> text path <.> char ':' <.> pp pos <.> comma ] ++ unexp ++ ["expected:" <+> text e] where (unexp,pos) = case ltok of Nothing -> ( [] ,start) Just t -> ( ["unexpected:" <+> text (T.unpack (tokenText (thing t)))] , from (srcRange t) ) instance Functor ParseM where fmap = liftM instance Applicative ParseM where pure a = P (\_ _ s -> Right (a,s)) (<*>) = ap instance Monad ParseM where return = pure 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) instance Fail.MonadFail ParseM where fail s = panic "[Parser] fail" [s] 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 xs = P $ \_ _ _ -> Left (HappyErrorMsg r xs) 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 -- | This is how we derive the name of a module parameter from the -- @import source@ declaration. mkModParamName :: Located (ImpName PName) -> Maybe (Located ModName) -> Ident mkModParamName lsig qual = case qual of Nothing -> case thing lsig of ImpTop t | modNameIsNormal t -> packIdent (last (modNameChunks t)) | otherwise -> identAnonIfaceMod $ packIdent $ last $ modNameChunks $ modNameToNormalModName t ImpNested nm -> case nm of UnQual i -> i Qual _ i -> i NewName {} -> panic "mkModParamName" ["Unexpected NewName",show lsig] Just m -> packIdent (last (modNameChunks (thing m))) -- 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] getChr :: Located Token -> Char getChr l = case thing l of Token (ChrLit x) _ -> x _ -> panic "[Parser] getChr" ["not a char:", 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 :: Token -> Expr PName numLit Token { tokenText = txt, tokenType = Num x base digs } | base == 2 = ELit $ ECNum x (BinLit txt digs) | base == 8 = ELit $ ECNum x (OctLit txt digs) | base == 10 = ELit $ ECNum x (DecLit txt) | base == 16 = ELit $ ECNum x (HexLit txt digs) numLit x = panic "[Parser] numLit" ["invalid numeric literal", show x] fracLit :: Token -> Expr PName fracLit tok = case tokenType tok of Frac x base | base == 2 -> ELit $ ECFrac x $ BinFrac $ tokenText tok | base == 8 -> ELit $ ECFrac x $ OctFrac $ tokenText tok | base == 10 -> ELit $ ECFrac x $ DecFrac $ tokenText tok | base == 16 -> ELit $ ECFrac x $ HexFrac $ tokenText tok _ -> panic "[Parser] fracLit" [ "Invalid fraction", show tok ] 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) 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" TTyApp {} -> bad "Explicit type application" 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 mb -> case mb of Nothing -> validDemotedType rng t Just _ -> bad "kind annotation" TInfix{} -> ok where bad x = errorMessage rng [x ++ " cannot be demoted."] ok = return $ at rng ty -- | Input fields are reversed! mkRecord :: AddLoc b => Range -> (RecordMap Ident (Range, a) -> b) -> [Named a] -> ParseM b mkRecord rng f xs = case res of Left (nm,(nmRng,_)) -> errorMessage nmRng ["Record has repeated field: " ++ show (pp nm)] Right r -> pure $ at rng (f r) where res = recordFromFieldsErr ys ys = map (\ (Named (Located r nm) x) -> (nm,(r,x))) (reverse xs) -- | Input expression are reversed mkEApp :: NonEmpty (Expr PName) -> ParseM (Expr PName) mkEApp es@(eLast :| _) = do f :| xs <- cvtTypeParams eFirst rest pure (at (eFirst,eLast) $ foldl EApp f xs) where eFirst :| rest = NE.reverse es {- Type applications are parsed as `ETypeVal (TTyApp 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 ] The parser associates field and tuple projectors that follow an explicit type application onto the TTyApp term, so we also have to unwind those projections and reapply them. For example: [ f, x, `{ a = 2 }.f.2, y ] becomes [ f, (x`{ a = 2 }).f.2, y ] -} cvtTypeParams e [] = pure (e :| []) cvtTypeParams e (p : ps) = case toTypeParam p Nothing of Nothing -> NE.cons e <$> cvtTypeParams p ps Just (fs,ss,rng) -> if checkAppExpr e then let e' = foldr (flip ESel) (EAppT e fs) ss e'' = case rCombMaybe (getLoc e) rng of Just r -> ELocated e' r Nothing -> e' in cvtTypeParams e'' ps else errorMessage (fromMaybe emptyRange (getLoc e)) [ "Explicit type applications can only be applied to named values." , "Unexpected: " ++ show (pp e) ] {- Check if the given expression is a legal target for explicit type application. This is basically only variables, but we also allow the parenthesis and the phantom "located" AST node. -} checkAppExpr e = case e of ELocated e' _ -> checkAppExpr e' EParens e' -> checkAppExpr e' EVar{} -> True _ -> False {- Look under a potential chain of selectors to see if we have a TTyApp. If so, return the ty app information and the collected selectors to reapply. -} toTypeParam e mr = case e of ELocated e' rng -> toTypeParam e' (rCombMaybe mr (Just rng)) ETypeVal t -> toTypeParam' t mr ESel e' s -> ( \(fs,ss,r) -> (fs,s:ss,r) ) <$> toTypeParam e' mr _ -> Nothing toTypeParam' t mr = case t of TLocated t' rng -> toTypeParam' t' (rCombMaybe mr (Just rng)) TTyApp fs -> Just (map mkTypeInst fs, [], mr) _ -> Nothing 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."] eFromToBy :: Range -> Expr PName -> Expr PName -> Expr PName -> Bool -> ParseM (Expr PName) eFromToBy r e1 e2 e3 isStrictBound = case (asETyped e1, asETyped e2, asETyped e3) of (Just (e1', t), Nothing, Nothing) -> eFromToByTyped r e1' e2 e3 (Just t) isStrictBound (Nothing, Just (e2', t), Nothing) -> eFromToByTyped r e1 e2' e3 (Just t) isStrictBound (Nothing, Nothing, Just (e3', t)) -> eFromToByTyped r e1 e2 e3' (Just t) isStrictBound (Nothing, Nothing, Nothing) -> eFromToByTyped r e1 e2 e3 Nothing isStrictBound _ -> errorMessage r ["A sequence enumeration may have at most one element type annotation."] eFromToByTyped :: Range -> Expr PName -> Expr PName -> Expr PName -> Maybe (Type PName) -> Bool -> ParseM (Expr PName) eFromToByTyped r e1 e2 e3 t isStrictBound = EFromToBy isStrictBound <$> exprToNumT r e1 <*> exprToNumT r e2 <*> exprToNumT r e3 <*> pure t eFromToDownBy :: Range -> Expr PName -> Expr PName -> Expr PName -> Bool -> ParseM (Expr PName) eFromToDownBy r e1 e2 e3 isStrictBound = case (asETyped e1, asETyped e2, asETyped e3) of (Just (e1', t), Nothing, Nothing) -> eFromToDownByTyped r e1' e2 e3 (Just t) isStrictBound (Nothing, Just (e2', t), Nothing) -> eFromToDownByTyped r e1 e2' e3 (Just t) isStrictBound (Nothing, Nothing, Just (e3', t)) -> eFromToDownByTyped r e1 e2 e3' (Just t) isStrictBound (Nothing, Nothing, Nothing) -> eFromToDownByTyped r e1 e2 e3 Nothing isStrictBound _ -> errorMessage r ["A sequence enumeration may have at most one element type annotation."] eFromToDownByTyped :: Range -> Expr PName -> Expr PName -> Expr PName -> Maybe (Type PName) -> Bool -> ParseM (Expr PName) eFromToDownByTyped r e1 e2 e3 t isStrictBound = EFromToDownBy isStrictBound <$> exprToNumT r e1 <*> exprToNumT r e2 <*> exprToNumT r e3 <*> pure t asETyped :: Expr n -> Maybe (Expr n, Type n) 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 eFromToLessThan :: Range -> Expr PName -> Expr PName -> ParseM (Expr PName) eFromToLessThan r e1 e2 = case asETyped e2 of Just _ -> errorMessage r ["The exclusive upper bound of an enumeration may not have a type annotation."] Nothing -> case asETyped e1 of Nothing -> eFromToLessThanType r e1 e2 Nothing Just (e1',t) -> eFromToLessThanType r e1' e2 (Just t) eFromToLessThanType :: Range -> Expr PName -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName) eFromToLessThanType r e1 e2 t = EFromToLessThan <$> exprToNumT r e1 <*> exprToNumT r e2 <*> 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)) [ "The boundaries of .. sequences should be valid numeric types." , "The expression `" ++ show (pp expr) ++ "` is not." ] -- | WARNING: This is a bit of a hack. -- It is used to represent anonymous type applications. anonTyApp :: Maybe Range -> [Type PName] -> Type PName anonTyApp ~(Just r) ts = TLocated (TTyApp (map toField ts)) r where noName = Located { srcRange = r, thing = mkIdent (T.pack "") } toField t = Named { name = noName, value = t } exportDecl :: Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName exportDecl mbDoc e d = Decl TopLevel { tlExport = e , tlDoc = mbDoc , tlValue = d } exportNewtype :: ExportType -> Maybe (Located Text) -> Newtype PName -> TopDecl PName exportNewtype e d n = TDNewtype TopLevel { tlExport = e , tlDoc = d , tlValue = n } exportModule :: Maybe (Located Text) -> NestedModule PName -> TopDecl PName exportModule mbDoc m = DModule TopLevel { tlExport = Public , tlDoc = mbDoc , tlValue = m } mkParFun :: Maybe (Located Text) -> Located PName -> Schema PName -> ParamDecl PName mkParFun mbDoc n s = DParameterFun ParameterFun { pfName = n , pfSchema = s , pfDoc = thing <$> mbDoc , pfFixity = Nothing } mkParType :: Maybe (Located Text) -> Located PName -> Located Kind -> ParseM (ParamDecl 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 = case decl of Decl d -> Decl d { tlExport = e } DPrimType t -> DPrimType t { tlExport = e } TDNewtype n -> TDNewtype n { tlExport = e } DModule m -> DModule m { tlExport = e } DModParam {} -> decl Include{} -> decl DImport{} -> decl DParamDecl{} -> decl DInterfaceConstraint {} -> decl 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 :: Type PName -> Type PName -> ParseM (Decl PName) mkTySyn thead tdef = do (nm,params) <- typeToDecl thead pure (DType (TySyn nm Nothing params tdef)) mkPropSyn :: Type PName -> Type PName -> ParseM (Decl PName) mkPropSyn thead tdef = do (nm,params) <- typeToDecl thead ps <- thing <$> mkProp tdef pure (DProp (PropSyn nm Nothing params ps)) mkNewtype :: Type PName -> Located (RecordMap Ident (Range, Type PName)) -> ParseM (Newtype PName) mkNewtype thead def = do (nm,params) <- typeToDecl thead pure (Newtype nm params (thing nm) (thing def)) typeToDecl :: Type PName -> ParseM (Located PName, [TParam PName]) typeToDecl ty0 = case ty0 of TLocated ty loc -> goD loc ty _ -> panic "typeToDecl" ["Type location is missing."] where bad loc = errorMessage loc ["Invalid type declaration"] badP loc = errorMessage loc ["Invalid declaration parameter"] goN loc n = case n of UnQual {} -> pure () _ -> errorMessage loc ["Invalid declaration name"] goP loc ty = case ty of TLocated ty1 loc1 -> goP loc1 ty1 TUser f [] -> do goN loc f pure TParam { tpName = f, tpKind = Nothing, tpRange = Just loc } TParens t mb -> case mb of Nothing -> badP loc Just k -> do p <- goP loc t case tpKind p of Nothing -> pure p { tpKind = Just k } Just {} -> badP loc TInfix {} -> badP loc TUser {} -> badP loc TFun {} -> badP loc TSeq {} -> badP loc TBit {} -> badP loc TNum {} -> badP loc TChar {} -> badP loc TRecord {} -> badP loc TWild {} -> badP loc TTyApp {} -> badP loc TTuple {} -> badP loc goD loc ty = case ty of TLocated ty1 loc1 -> goD loc1 ty1 TUser f ts -> do goN loc f ps <- mapM (goP loc) ts pure (Located { thing = f, srcRange = loc },ps) TInfix l f _ r -> do goN (srcRange f) (thing f) a <- goP loc l b <- goP loc r pure (f,[a,b]) TFun {} -> bad loc TSeq {} -> bad loc TBit {} -> bad loc TNum {} -> bad loc TChar {} -> bad loc TRecord {} -> bad loc TWild {} -> bad loc TTyApp {} -> bad loc TTuple {} -> bad loc TParens {} -> bad loc 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 | w <= toInteger (maxBound :: Int) = mk 0 (map fromInteger bits) | otherwise = errorMessage rng ["Polynomial literal too large: " ++ show w] where w = case terms of [] -> 0 _ -> 1 + maximum (map snd terms) bits = [ n | (True,n) <- terms ] mk :: Integer -> [Int] -> ParseM (Expr PName) mk res [] = return $ ELit $ ECNum res (PolyLit (fromInteger w :: Int)) 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 = at (f,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 , bExport = Public } -- 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 , bExport = Public } where rhs :: Expr PName rhs = mkGenerate (reverse ixs) e -- NOTE: The lists of patterns are reversed! mkPropGuardsDecl :: LPName -> ([Pattern PName], [Pattern PName]) -> [PropGuardCase PName] -> ParseM (Decl PName) mkPropGuardsDecl f (ps, ixs) guards = do unless (null ixs) $ errorMessage (srcRange f) ["Indexed sequence definitions may not use constraint guards"] let gs = reverse guards pure $ DBind Bind { bName = f , bParams = reverse ps , bDef = Located (srcRange f) (DPropGuards gs) , bSignature = Nothing , bPragmas = [] , bMono = False , bInfix = False , bFixity = Nothing , bDoc = Nothing , bExport = Public } mkConstantPropGuardsDecl :: LPName -> [PropGuardCase PName] -> ParseM (Decl PName) mkConstantPropGuardsDecl f guards = mkPropGuardsDecl f ([],[]) guards -- 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 emptyFunDesc (reverse ps) (mkGenerate (reverse ixs) body) mkGenerate :: [Pattern PName] -> Expr PName -> Expr PName mkGenerate pats body = foldr (\pat e -> EGenerate (EFun emptyFunDesc [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 mkPrimDecl :: Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName] mkPrimDecl = mkNoImplDecl DPrim mkForeignDecl :: Maybe (Located Text) -> LPName -> Schema PName -> ParseM [TopDecl PName] mkForeignDecl mbDoc nm ty = do let txt = unpackIdent (getIdent (thing nm)) unless (all isOk txt) (errorMessage (srcRange nm) [ "`" ++ txt ++ "` is not a valid foreign name." , "The name should contain only alpha-numeric characters or '_'." ]) pure (mkNoImplDecl DForeign mbDoc nm ty) where isOk c = c == '_' || isAlphaNum c -- | Generate a signature and a binding for value declarations with no -- implementation (i.e. primitive or foreign declarations). The reason for -- generating both instead of just adding the signature at this point is that it -- means the 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 and foreigns. mkNoImplDecl :: BindDef PName -> Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName] mkNoImplDecl def mbDoc ln sig = [ exportDecl mbDoc Public $ DBind Bind { bName = ln , bParams = [] , bDef = at sig (Located emptyRange def) , bSignature = Nothing , bPragmas = [] , bMono = False , bInfix = isInfixIdent (getIdent (thing ln)) , bFixity = Nothing , bDoc = Nothing , bExport = Public } , exportDecl Nothing Public $ DSignature [ln] sig ] mkPrimTypeDecl :: Maybe (Located Text) -> 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 parameters."] 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 Text mkDoc ltxt = ltxt { thing = docStr } where docStr = T.unlines $ 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) whitespaceChar :: Char -> Bool whitespaceChar 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 -> whitespaceChar c -- end-of-line matches any whitespace distrLoc :: Located [a] -> [Located a] distrLoc x = [ Located { srcRange = r, thing = a } | a <- thing x ] where r = srcRange x mkPropGuards :: Type PName -> ParseM [Located (Prop PName)] mkPropGuards ty = do lp <- mkProp ty pure [ lp { thing = p } | p <- thing lp ] 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' mb -> case mb of Nothing -> props r t' Just _ -> err TLocated t' r' -> props r' t' TFun{} -> err TSeq{} -> err TBit{} -> err TNum{} -> err TChar{} -> err TWild -> err TRecord{} -> err TTyApp{} -> err where err = errorMessage r ["Invalid constraint"] -- | Make an ordinary module mkModule :: Located ModName -> [TopDecl PName] -> Module PName mkModule nm ds = Module { mName = nm , mDef = NormalModule ds } mkNested :: Module PName -> ParseM (NestedModule PName) mkNested m = case modNameChunks (thing nm) of [c] -> pure (NestedModule m { mName = nm { thing = mkUnqual (packIdent c)}}) _ -> errorMessage r ["Nested modules names should be a simple identifier."] where nm = mName m r = srcRange nm mkSigDecl :: Maybe (Located Text) -> (Located PName,Signature PName) -> TopDecl PName mkSigDecl doc (nm,sig) = DModule TopLevel { tlExport = Public , tlDoc = doc , tlValue = NestedModule Module { mName = nm , mDef = InterfaceModule sig } } mkInterfaceConstraint :: Maybe (Located Text) -> Type PName -> ParseM [TopDecl PName] mkInterfaceConstraint mbDoc ty = do ps <- mkProp ty pure [DInterfaceConstraint (thing <$> mbDoc) ps] mkParDecls :: [ParamDecl PName] -> TopDecl PName mkParDecls ds = DParamDecl loc (mkInterface' [] ds) where loc = rCombs (mapMaybe getLoc ds) onlySimpleImports :: [Located (ImportG (ImpName PName))] -> ParseM () onlySimpleImports = mapM_ check where check i = case iInst (thing i) of Nothing -> pure () Just _ -> errorMessage (srcRange i) [ "Functor instantiations are not supported in this context." , "The imported entity needs to be just the name of a module." , "A workaround would be to do the instantion in the outer context." ] mkInterface' :: [Located (ImportG (ImpName PName))] -> [ParamDecl PName] -> Signature PName mkInterface' is = foldl' add Signature { sigImports = is , sigTypeParams = [] , sigDecls = [] , sigConstraints = [] , sigFunParams = [] } where add s d = case d of DParameterType pt -> s { sigTypeParams = pt : sigTypeParams s } DParameterConstraint ps -> s { sigConstraints = ps ++ sigConstraints s } DParameterDecl pd -> s { sigDecls = pd : sigDecls s } DParameterFun pf -> s { sigFunParams = pf : sigFunParams s } mkInterface :: [Located (ImportG (ImpName PName))] -> [ParamDecl PName] -> ParseM (Signature PName) mkInterface is ps = do onlySimpleImports is pure (mkInterface' is ps) mkIfacePropSyn :: Maybe Text -> Decl PName -> ParamDecl PName mkIfacePropSyn mbDoc d = case d of DLocated d1 _ -> mkIfacePropSyn mbDoc d1 DType ts -> DParameterDecl (SigTySyn ts mbDoc) DProp ps -> DParameterDecl (SigPropSyn ps mbDoc) _ -> panic "mkIfacePropSyn" [ "Unexpected declaration", show (pp d) ] -- | Make an unnamed module---gets the name @Main@. mkAnonymousModule :: [TopDecl PName] -> ParseM [Module PName] mkAnonymousModule = mkTopMods . mkModule Located { srcRange = emptyRange , thing = mkModName [T.pack "Main"] } -- | Make a module which defines a functor instance. mkModuleInstanceAnon :: Located ModName -> Located (ImpName PName) -> [TopDecl PName] -> Module PName mkModuleInstanceAnon nm fun ds = Module { mName = nm , mDef = FunctorInstance fun (DefaultInstAnonArg ds) mempty } mkModuleInstance :: Located ModName -> Located (ImpName PName) -> ModuleInstanceArgs PName -> Module PName mkModuleInstance m f as = Module { mName = m , mDef = FunctorInstance f as emptyModuleInstance } 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?"] exprToFieldPath :: Expr PName -> ParseM [Located Selector] exprToFieldPath 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 (DecLit {})) -> pure [ Located { thing = TupleSel (fromInteger n) Nothing , srcRange = loc } ] ELit (ECFrac _ (DecFrac txt)) | (as,bs') <- T.break (== '.') txt , Just a <- readMaybe (T.unpack as) , Just (_,bs) <- T.uncons bs' , Just b <- readMaybe (T.unpack bs) , let fromP = from loc , let midP = fromP { col = col fromP + T.length as + 1 } -> -- these are backward because we reverse above pure [ Located { thing = TupleSel b Nothing , srcRange = loc { from = midP } } , Located { thing = TupleSel a Nothing , srcRange = loc { to = midP } } ] _ -> errorMessage loc ["Invalid label in record update."] mkSelector :: Token -> Selector mkSelector tok = case tokenType tok of Selector (TupleSelectorTok n) -> TupleSel n Nothing Selector (RecordSelectorTok t) -> RecordSel (mkIdent t) Nothing _ -> panic "mkSelector" [ "Unexpected selector token", show tok ] mkBacktickImport :: Range -> Located (ImpName PName) -> Maybe (Located ModName) -> Maybe (Located ImportSpec) -> ParseM (Located (ImportG (ImpName PName))) mkBacktickImport loc impName mbAs mbImportSpec = mkImport loc impName (Just inst) mbAs mbImportSpec Nothing where inst = DefaultInstArg (fmap (const AddParams) impName) mkImport :: Range -> Located (ImpName PName) -> Maybe (ModuleInstanceArgs PName) -> Maybe (Located ModName) -> Maybe (Located ImportSpec) -> Maybe (Located [Decl PName]) -> ParseM (Located (ImportG (ImpName PName))) mkImport loc impName optInst mbAs mbImportSpec optImportWhere = do i <- getInst let end = fromMaybe (srcRange impName) $ msum [ srcRange <$> optImportWhere , srcRange <$> mbImportSpec , srcRange <$> mbAs ] pure Located { srcRange = rComb loc end , thing = Import { iModule = thing impName , iAs = thing <$> mbAs , iSpec = thing <$> mbImportSpec , iInst = i } } where getInst = case (optInst,optImportWhere) of (Just _, Just _) -> errorMessage loc [ "Invalid instantiating import." , "Import should have at most one of:" , " * { } instantiation, or" , " * where instantiation" ] (Just a, Nothing) -> pure (Just a) (Nothing, Just a) -> pure (Just (DefaultInstAnonArg (map instTop (thing a)))) where instTop d = Decl TopLevel { tlExport = Public , tlDoc = Nothing , tlValue = d } (Nothing, Nothing) -> pure Nothing mkTopMods :: Module PName -> ParseM [Module PName] mkTopMods = desugarMod mkTopSig :: Located ModName -> Signature PName -> [Module PName] mkTopSig nm sig = [ Module { mName = nm , mDef = InterfaceModule sig } ] class MkAnon t where mkAnon :: AnonThing -> t -> t toImpName :: t -> ImpName PName data AnonThing = AnonArg | AnonIfaceMod instance MkAnon ModName where mkAnon what = case what of AnonArg -> modNameArg AnonIfaceMod -> modNameIfaceMod toImpName = ImpTop instance MkAnon PName where mkAnon what = mkUnqual . case what of AnonArg -> identAnonArg AnonIfaceMod -> identAnonIfaceMod . getIdent toImpName = ImpNested desugarMod :: MkAnon name => ModuleG name PName -> ParseM [ModuleG name PName] desugarMod mo = case mDef mo of FunctorInstance f as _ | DefaultInstAnonArg lds <- as -> do (ms,lds') <- desugarTopDs (mName mo) lds case ms of m : _ | InterfaceModule si <- mDef m , l : _ <- map (srcRange . ptName) (sigTypeParams si) ++ map (srcRange . pfName) (sigFunParams si) ++ [ srcRange (mName mo) ] -> errorMessage l [ "Instantiation of a parameterized module may not itself be " ++ "parameterized" ] _ -> pure () let i = mkAnon AnonArg (thing (mName mo)) nm = Located { srcRange = srcRange (mName mo), thing = i } as' = DefaultInstArg (ModuleArg . toImpName <$> nm) pure [ Module { mName = nm, mDef = NormalModule lds' } , mo { mDef = FunctorInstance f as' mempty } ] NormalModule ds -> do (newMs, newDs) <- desugarTopDs (mName mo) ds pure (newMs ++ [ mo { mDef = NormalModule newDs } ]) _ -> pure [mo] desugarTopDs :: MkAnon name => Located name -> [TopDecl PName] -> ParseM ([ModuleG name PName], [TopDecl PName]) desugarTopDs ownerName = go emptySig where isEmpty s = null (sigTypeParams s) && null (sigConstraints s) && null (sigFunParams s) emptySig = Signature { sigImports = [] , sigTypeParams = [] , sigDecls = [] , sigConstraints = [] , sigFunParams = [] } jnSig s1 s2 = Signature { sigImports = j sigImports , sigTypeParams = j sigTypeParams , sigDecls = j sigDecls , sigConstraints = j sigConstraints , sigFunParams = j sigFunParams } where j f = f s1 ++ f s2 addI i s = s { sigImports = i : sigImports s } go sig ds = case ds of [] | isEmpty sig -> pure ([],[]) | otherwise -> do let nm = mkAnon AnonIfaceMod <$> ownerName pure ( [ Module { mName = nm , mDef = InterfaceModule sig } ] , [ DModParam ModParam { mpSignature = toImpName <$> nm , mpAs = Nothing , mpName = mkModParamName (toImpName <$> nm) Nothing , mpDoc = Nothing , mpRenaming = mempty } ] ) d : more -> let cont emit sig' = do (ms,ds') <- go sig' more pure (ms, emit ++ ds') in case d of DImport i | ImpTop _ <- iModule (thing i) , Nothing <- iInst (thing i) -> cont [d] (addI i sig) DImport i | Just inst <- iInst (thing i) -> do newDs <- desugarInstImport i inst cont newDs sig DParamDecl _ ds' -> cont [] (jnSig ds' sig) DModule tl | NestedModule mo <- tlValue tl -> do ms <- desugarMod mo cont [ DModule tl { tlValue = NestedModule m } | m <- ms ] sig _ -> cont [d] sig desugarInstImport :: Located (ImportG (ImpName PName)) {- ^ The import -} -> ModuleInstanceArgs PName {- ^ The insantiation -} -> ParseM [TopDecl PName] desugarInstImport i inst = do ms <- desugarMod Module { mName = i { thing = iname } , mDef = FunctorInstance (iModule <$> i) inst emptyModuleInstance } pure (DImport (newImp <$> i) : map modTop ms) where imp = thing i iname = mkUnqual $ mkIdent $ "import of " <> nm <> " at " <> Text.pack (show (pp (srcRange i))) where nm = case iModule imp of ImpTop f -> modNameToText f ImpNested n -> "submodule " <> Text.pack (show (pp n)) newImp d = d { iModule = ImpNested iname , iInst = Nothing } modTop m = DModule TopLevel { tlExport = Private , tlDoc = Nothing , tlValue = NestedModule m } cryptol-3.0.0/src/Cryptol/Parser/Position.hs0000644000000000000000000001010707346545000017215 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 DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# 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, Ord, Show, Generic, NFData , Functor, Foldable, Traversable ) data Position = Position { line :: !Int, col :: !Int } deriving (Eq, Ord, Show, Generic, NFData) data Range = Range { from :: !Position , to :: !Position , source :: FilePath } deriving (Eq, Ord, Show, Generic, NFData) -- | Returns `True` if the first range is contained in the second one. rangeWithin :: Range -> Range -> Bool a `rangeWithin` b = source a == source b && from a >= from b && to a <= to b -- | 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) rCombMaybe :: Maybe Range -> Maybe Range -> Maybe Range rCombMaybe Nothing y = y rCombMaybe x Nothing = x rCombMaybe (Just x) (Just y) = Just (rComb x y) rCombs :: [Range] -> Range rCombs = foldl1 rComb -------------------------------------------------------------------------------- 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-3.0.0/src/Cryptol/Parser/Selector.hs0000644000000000000000000000507407346545000017200 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 -> sep (int x : ppSig tupleSig sig) RecordSel x sig -> sep (pp x : ppSig recordSig sig) ListSel x sig -> sep (int x : ppSig listSig sig) where tupleSig n = int n recordSig xs = ppRecord $ map pp xs listSig n = int n ppSig f = maybe [] (\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-3.0.0/src/Cryptol/Parser/Token.hs0000644000000000000000000000745707346545000016507 0ustar0000000000000000{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Safe #-} module Cryptol.Parser.Token where import Data.Text(Text) import qualified Data.Text as Text import Control.DeepSeq import GHC.Generics import Cryptol.Utils.PP 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_fin | KW_if | KW_private | KW_include | KW_inf | KW_lg2 | KW_lengthFromThen | KW_lengthFromThenTo | KW_max | KW_min | KW_module | KW_submodule | 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_interface | KW_foreign | KW_Prop | KW_by | KW_down 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 [Text] Text deriving (Eq, Show, Generic, NFData) data TokenSym = Bar | ArrL | ArrR | FatArrR | Lambda | EqDef | Comma | Semi | Dot | DotDot | DotDotDot | DotDotLt | DotDotGt | Colon | BackTick | ParenL | ParenR | BracketL | BracketR | CurlyL | CurlyR | TriL | TriR | Lt | Gt | Underscore deriving (Eq, Show, Generic, NFData) data TokenErr = UnterminatedComment | UnterminatedString | UnterminatedChar | InvalidString | InvalidChar | LexicalError | MalformedLiteral | MalformedSelector | InvalidIndentation TokenT -- expected closing paren deriving (Eq, Show, Generic, NFData) data SelectorType = RecordSelectorTok Text | TupleSelectorTok Int deriving (Eq, Show, Generic, NFData) data TokenT = Num !Integer !Int !Int -- ^ value, base, number of digits | Frac !Rational !Int -- ^ value, base. | ChrLit !Char -- ^ character literal | Ident ![Text] !Text -- ^ (qualified) identifier | StrLit !String -- ^ string literal | Selector !SelectorType -- ^ .hello or .123 | 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 (Text.unpack s) cryptol-3.0.0/src/Cryptol/Parser/Unlit.hs0000644000000000000000000001202607346545000016506 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 | RST knownExts :: [String] knownExts = [ "cry" , "tex" , "markdown" , "md" , "rst" ] guessPreProc :: FilePath -> PreProc guessPreProc file = case takeExtension file of ".tex" -> LaTeX ".markdown" -> Markdown ".md" -> Markdown ".rst" -> RST _ -> 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 RST -> rst 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) | Just op <- isOpenFence l = mk Comment (l : current) ++ fenced op [] ls | isBlank l = blanks (l : current) ls | otherwise = comment (l : current) ls blanks current [] = mk Comment current blanks current (l : ls) | Just op <- isOpenFence l = mk Comment (l : current) ++ fenced op [] ls | isCodeLine l = mk Comment current ++ code [l] 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.dropWhile isSpace (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` Text.dropWhile isSpace 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 rst :: [Text] -> [Block] rst = comment [] where isBeginCode l = case filter (not . Text.null) (Text.split isSpace l) of ["..", dir, "cryptol"] -> dir == "code-block::" || dir == "sourcecode::" _ -> False isEmpty = Text.all isSpace isCode l = case Text.uncons l of Just (c, _) -> isSpace c Nothing -> True comment acc ls = case ls of [] -> mk Comment acc l : ls1 | isBeginCode l -> codeOptions (l : acc) ls1 | otherwise -> comment (l : acc) ls1 codeOptions acc ls = case ls of [] -> mk Comment acc l : ls1 | isEmpty l -> mk Comment (l : acc) ++ code [] ls1 | otherwise -> codeOptions (l : acc) ls1 code acc ls = case ls of [] -> mk Code acc l : ls1 | isCode l -> code (l : acc) ls1 | otherwise -> mk Code acc ++ comment [] ls cryptol-3.0.0/src/Cryptol/Parser/Utils.hs0000644000000000000000000000322607346545000016515 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 #-} {-# LANGUAGE Safe #-} 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) _ -> 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 _) = return (TNum n) cvtLit (ECChar c) = return (TChar c) cvtLit (ECFrac {}) = Nothing cvtLit (ECString _) = Nothing cryptol-3.0.0/src/Cryptol/Prelude.hs0000644000000000000000000000232307346545000015556 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 , preludeReferenceContents , floatContents , arrayContents , suiteBContents , primeECContents , 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|] preludeReferenceContents :: ByteString preludeReferenceContents = B.pack [there|lib/Cryptol/Reference.cry|] floatContents :: ByteString floatContents = B.pack [there|lib/Float.cry|] arrayContents :: ByteString arrayContents = B.pack [there|lib/Array.cry|] suiteBContents :: ByteString suiteBContents = B.pack [there|lib/SuiteB.cry|] primeECContents :: ByteString primeECContents = B.pack [there|lib/PrimeEC.cry|] cryptolTcContents :: String cryptolTcContents = [there|lib/CryptolTC.z3|] cryptol-3.0.0/src/Cryptol/PrimeEC.hs0000644000000000000000000004331407346545000015447 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Cryptol.PrimeEC -- Copyright : (c) Galois, Inc. -- License : BSD3 -- Maintainer: rdockins@galois.com -- Stability : experimental -- -- This module provides fast primitives for elliptic curve cryptography -- defined on @Z p@ for prime @p > 3@. These are exposed in cryptol -- by importing the built-in module "PrimeEC". The primary primitives -- exposed here are the doubling and addition primitives in the ECC group -- as well as scalar multiplication and the "twin" multiplication primitive, -- which simultaneously computes the addition of two scalar multiplies. -- -- This module makes heavy use of some GHC internals regarding the -- representation of the Integer type, and the underlying GMP primitives -- in order to speed up the basic modular arithmetic operations. ----------------------------------------------------------------------------- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UnboxedTuples #-} #if __GLASGOW_HASKELL__ >= 900 -- On GHC 9.0 or later—that is, when building with ghc-bignum—BigNum# is an -- unlifted type, so we need UnliftedNewtypes to declare a newtype on top of -- it. On older versions of GHC, BigNat# is simply a synonym for BigNat. BigNat -- is lifted, so declaring a newtype on top of it works out of the box. {-# LANGUAGE UnliftedNewtypes #-} #endif module Cryptol.PrimeEC ( PrimeModulus , primeModulus , ProjectivePoint(..) , toProjectivePoint , BN.integerToBigNat , BN.bigNatToInteger , ec_double , ec_add_nonzero , ec_mult , ec_twin_mult ) where import GHC.Num.Compat (BigNat#) import qualified GHC.Num.Compat as BN import GHC.Exts import Cryptol.TypeCheck.Solver.InfNat (widthInteger) import Cryptol.Utils.Panic -- | Points in the projective plane represented in -- homogenous coordinates. data ProjectivePoint = ProjectivePoint { px :: !BigNat# , py :: !BigNat# , pz :: !BigNat# } toProjectivePoint :: Integer -> Integer -> Integer -> ProjectivePoint toProjectivePoint x y z = ProjectivePoint (BN.integerToBigNat x) (BN.integerToBigNat y) (BN.integerToBigNat z) -- | The projective "point at infinity", which represents the zero element -- of the ECC group. zro :: ProjectivePoint zro = ProjectivePoint (BN.oneBigNat (# #)) (BN.oneBigNat (# #)) (BN.zeroBigNat (# #)) -- | Simple newtype wrapping the @BigNat@ value of the -- modulus of the underlying field Z p. This modulus -- is required to be prime. newtype PrimeModulus = PrimeModulus { primeMod :: BigNat# } -- | Inject an integer value into the @PrimeModulus@ type. -- This modulus is required to be prime. primeModulus :: Integer -> PrimeModulus primeModulus x = PrimeModulus (BN.integerToBigNat x) {-# INLINE primeModulus #-} -- | Modular addition of two values. The inputs are -- required to be in reduced form, and will output -- a value in reduced form. mod_add :: PrimeModulus -> BigNat# -> BigNat# -> BigNat# mod_add p x y = let r = BN.bigNatAdd x y in case BN.bigNatSub r (primeMod p) of (# (# #) | #) -> r (# | rmp #) -> rmp -- | Compute the "half" value of a modular integer. For a given input @x@ -- this is a value @y@ such that @y+y == x@. Such values must exist -- in @Z p@ when @p > 2@. The input @x@ is required to be in reduced form, -- and will output a value in reduced form. mod_half :: PrimeModulus -> BigNat# -> BigNat# mod_half p x = if BN.testBitBigNat x 0# then qodd else qeven where qodd = (BN.bigNatAdd x (primeMod p)) `BN.shiftRBigNat` 1# qeven = x `BN.shiftRBigNat` 1# -- | Compute the modular multiplication of two input values. Currently, this -- uses naive modular reduction, and does not require the inputs to be in -- reduced form. The output is in reduced form. mod_mul :: PrimeModulus -> BigNat# -> BigNat# -> BigNat# mod_mul p x y = (BN.bigNatMul x y) `BN.bigNatRem` (primeMod p) -- | Compute the modular difference of two input values. The inputs are -- required to be in reduced form, and will output a value in reduced form. mod_sub :: PrimeModulus -> BigNat# -> BigNat# -> BigNat# mod_sub p x y = case BN.bigNatSub (primeMod p) y of (# | y' #) -> mod_add p x y' (# (# #) | #) -> x -- BOGUS! -- | Compute the modular square of an input value @x@; that is, @x*x@. -- The input is not required to be in reduced form, and the output -- will be in reduced form. mod_square :: PrimeModulus -> BigNat# -> BigNat# mod_square p x = BN.bigNatSqr x `BN.bigNatRem` primeMod p -- | Compute the modular scalar multiplication @2x = x+x@. -- The input is required to be in reduced form and the output -- will be in reduced form. mul2 :: PrimeModulus -> BigNat# -> BigNat# mul2 p x = let r = x `BN.shiftLBigNat` 1# in case BN.bigNatSub r (primeMod p) of (# (# #) | #) -> r (# | rmp #) -> rmp -- | Compute the modular scalar multiplication @3x = x+x+x@. -- The input is required to be in reduced form and the output -- will be in reduced form. mul3 :: PrimeModulus -> BigNat# -> BigNat# mul3 p x = mod_add p x (mul2 p x) -- | Compute the modular scalar multiplication @4x = x+x+x+x@. -- The input is required to be in reduced form and the output -- will be in reduced form. mul4 :: PrimeModulus -> BigNat# -> BigNat# mul4 p x = mul2 p (mul2 p x) -- | Compute the modular scalar multiplication @8x = x+x+x+x+x+x+x+x@. -- The input is required to be in reduced form and the output -- will be in reduced form. mul8 :: PrimeModulus -> BigNat# -> BigNat# mul8 p x = mul2 p (mul4 p x) -- | Compute the elliptic curve group doubling operation. -- In other words, if @S@ is a projective point on a curve, -- this operation computes @S+S@ in the ECC group. -- -- In geometric terms, this operation computes a tangent line -- to the curve at @S@ and finds the (unique) intersection point of this -- line with the curve, @R@; then returns the point @R'@, which is @R@ -- reflected across the x axis. ec_double :: PrimeModulus -> ProjectivePoint -> ProjectivePoint ec_double p (ProjectivePoint sx sy sz) = if BN.bigNatIsZero sz then zro else ProjectivePoint r18 r23 r13 where r7 = mod_square p sz {- 7: t4 <- (t3)^2 -} r8 = mod_sub p sx r7 {- 8: t5 <- t1 - t4 -} r9 = mod_add p sx r7 {- 9: t4 <- t1 + t4 -} r10 = mod_mul p r9 r8 {- 10: t5 <- t4 * t5 -} r11 = mul3 p r10 {- 11: t4 <- 3 * t5 -} r12 = mod_mul p sz sy {- 12: t3 <- t3 * t2 -} r13 = mul2 p r12 {- 13: t3 <- 2 * t3 -} r14 = mod_square p sy {- 14: t2 <- (t2)^2 -} r15 = mod_mul p sx r14 {- 15: t5 <- t1 * t2 -} r16 = mul4 p r15 {- 16: t5 <- 4 * t5 -} r17 = mod_square p r11 {- 17: t1 <- (t4)^2 -} r18 = mod_sub p r17 (mul2 p r16) {- 18: t1 <- t1 - 2 * t5 -} r19 = mod_square p r14 {- 19: t2 <- (t2)^2 -} r20 = mul8 p r19 {- 20: t2 <- 8 * t2 -} r21 = mod_sub p r16 r18 {- 21: t5 <- t5 - t1 -} r22 = mod_mul p r11 r21 {- 22: t5 <- t4 * t5 -} r23 = mod_sub p r22 r20 {- 23: t2 <- t5 - t2 -} -- | Compute the elliptic curve group addition operation, including the special -- case for adding points which might be the identity. ec_add :: PrimeModulus -> ProjectivePoint -> ProjectivePoint -> ProjectivePoint ec_add p s t | BN.bigNatIsZero (pz s) = t | BN.bigNatIsZero (pz t) = s | otherwise = ec_add_nonzero p s t {-# INLINE ec_add #-} -- | Compute the elliptic curve group subtraction operation, including the special -- cases for subtracting points which might be the identity. ec_sub :: PrimeModulus -> ProjectivePoint -> ProjectivePoint -> ProjectivePoint ec_sub p s t = ec_add p s u where u = case BN.bigNatSub (primeMod p) (py t) of (# | y' #) -> t{ py = y' } (# (# #) | #) -> panic "ec_sub" ["cooridnate not in reduced form!", show (BN.bigNatToInteger (py t))] {-# INLINE ec_sub #-} ec_negate :: PrimeModulus -> ProjectivePoint -> ProjectivePoint ec_negate p s = s{ py = BN.bigNatSubUnsafe (primeMod p) (py s) } {-# INLINE ec_negate #-} -- | Compute the elliptic curve group addition operation -- for values known not to be the identity. -- In other words, if @S@ and @T@ are projective points on a curve, -- with nonzero @z@ coordinate this operation computes @S+T@ in the ECC group. -- -- In geometric terms, this operation computes a line that passes through -- @S@ and @T@, and finds the (unique) other point @R@ where the line intersects -- the curve; then returns the point @R'@, which is @R@ reflected across the x axis. -- In the special case where @S == T@, we instead call the @ec_double@ operation, -- which instead computes a tangent line to @S@ . ec_add_nonzero :: PrimeModulus -> ProjectivePoint -> ProjectivePoint -> ProjectivePoint ec_add_nonzero p s@(ProjectivePoint sx sy sz) (ProjectivePoint tx ty tz) = if BN.bigNatIsZero r13 then if BN.bigNatIsZero r14 then ec_double p s else zro else ProjectivePoint r32 r37 r27 where tNormalized = BN.bigNatIsOne tz tz2 = mod_square p tz tz3 = mod_mul p tz tz2 r5 = if tNormalized then sx else mod_mul p sx tz2 r7 = if tNormalized then sy else mod_mul p sy tz3 r9 = mod_square p sz {- 9: t7 <- (t3)^2 -} r10 = mod_mul p tx r9 {- 10: t4 <- t4 * t7 -} r11 = mod_mul p sz r9 {- 11: t7 <- t3 * t7 -} r12 = mod_mul p ty r11 {- 12: t5 <- t5 * t7 -} r13 = mod_sub p r5 r10 {- 13: t4 <- t1 - t4 -} r14 = mod_sub p r7 r12 {- 14: t5 <- t2 - t5 -} r22 = mod_sub p (mul2 p r5) r13 {- 22: t1 <- 2*t1 - t4 -} r23 = mod_sub p (mul2 p r7) r14 {- 23: t2 <- 2*t2 - t5 -} r25 = if tNormalized then sz else mod_mul p sz tz r27 = mod_mul p r25 r13 {- 27: t3 <- t3 * t4 -} r28 = mod_square p r13 {- 28: t7 <- (t4)^2 -} r29 = mod_mul p r13 r28 {- 29: t4 <- t4 * t7 -} r30 = mod_mul p r22 r28 {- 30: t7 <- t1 * t7 -} r31 = mod_square p r14 {- 31: t1 <- (t5)^2 -} r32 = mod_sub p r31 r30 {- 32: t1 <- t1 - t7 -} r33 = mod_sub p r30 (mul2 p r32) {- 33: t7 <- t7 - 2*t1 -} r34 = mod_mul p r14 r33 {- 34: t5 <- t5 * t7 -} r35 = mod_mul p r23 r29 {- 35: t4 <- t2 * t4 -} r36 = mod_sub p r34 r35 {- 36: t2 <- t5 - t4 -} r37 = mod_half p r36 {- 37: t2 <- t2/2 -} -- | Given a nonidentity projective point, normalize it so that -- its z component is 1. This helps to avoid some modular -- multiplies in @ec_add@, and may be a win if the point will -- be added many times. ec_normalize :: PrimeModulus -> ProjectivePoint -> ProjectivePoint ec_normalize p s@(ProjectivePoint x y z) | BN.bigNatIsOne z = s | otherwise = ProjectivePoint x' y' (BN.oneBigNat (# #)) where m = primeMod p l = BN.recipModBigNat z m l2 = BN.bigNatSqr l l3 = BN.bigNatMul l l2 x' = (BN.bigNatMul x l2) `BN.bigNatRem` m y' = (BN.bigNatMul y l3) `BN.bigNatRem` m -- | Given an integer @k@ and a projective point @S@, compute -- the scalar multiplication @kS@, which is @S@ added to itself -- @k@ times. ec_mult :: PrimeModulus -> Integer -> ProjectivePoint -> ProjectivePoint ec_mult p d s | d == 0 = zro | d == 1 = s | BN.bigNatIsZero (pz s) = zro | otherwise = case m of 0# -> panic "ec_mult" ["modulus too large", show (BN.bigNatToInteger (primeMod p))] _ -> go m zro where s' = ec_normalize p s h = 3*d d' = BN.integerToBigNat d h' = BN.integerToBigNat h m = case widthInteger h of BN.IS mint -> mint _ -> 0# go :: Int# -> ProjectivePoint -> ProjectivePoint go i !r | tagToEnum# (i ==# 0#) = r | otherwise = go (i -# 1#) r' where h_i = BN.testBitBigNat h' i d_i = BN.testBitBigNat d' i r' = if h_i then if d_i then r2 else ec_add p r2 s' else if d_i then ec_sub p r2 s' else r2 r2 = ec_double p r {-# INLINE normalizeForTwinMult #-} -- | Compute the sum and difference of the given points, -- and normalize all four values. This can be done jointly -- in a more efficient way than computing the necessary -- field inverses separately. -- When given points S and T, the returned tuple contains -- normalized representations for (S, T, S+T, S-T). -- -- Note there are some special cases that must be handled separately. normalizeForTwinMult :: PrimeModulus -> ProjectivePoint -> ProjectivePoint -> (ProjectivePoint, ProjectivePoint, ProjectivePoint, ProjectivePoint) normalizeForTwinMult p s t -- S == 0 && T == 0 | BN.bigNatIsZero a && BN.bigNatIsZero b = (zro, zro, zro, zro) -- S == 0 && T != 0 | BN.bigNatIsZero a = let tnorm = ec_normalize p t in (zro, tnorm, tnorm, ec_negate p tnorm) -- T == 0 && S != 0 | BN.bigNatIsZero b = let snorm = ec_normalize p s in (snorm, zro, snorm, snorm) -- S+T == 0, both != 0 | BN.bigNatIsZero c = let snorm = ec_normalize p s in (snorm, ec_negate p snorm, zro, ec_double p snorm) -- S-T == 0, both != 0 | BN.bigNatIsZero d = let snorm = ec_normalize p s in (snorm, snorm, ec_double p snorm, zro) -- S, T, S+T and S-T all != 0 | otherwise = (s',t',spt',smt') where spt = ec_add p s t smt = ec_sub p s t m = primeMod p a = pz s b = pz t c = pz spt d = pz smt ab = mod_mul p a b cd = mod_mul p c d abc = mod_mul p ab c abd = mod_mul p ab d acd = mod_mul p a cd bcd = mod_mul p b cd abcd = mod_mul p a bcd e = BN.recipModBigNat abcd m a_inv = mod_mul p e bcd b_inv = mod_mul p e acd c_inv = mod_mul p e abd d_inv = mod_mul p e abc a_inv2 = mod_square p a_inv a_inv3 = mod_mul p a_inv a_inv2 b_inv2 = mod_square p b_inv b_inv3 = mod_mul p b_inv b_inv2 c_inv2 = mod_square p c_inv c_inv3 = mod_mul p c_inv c_inv2 d_inv2 = mod_square p d_inv d_inv3 = mod_mul p d_inv d_inv2 s' = ProjectivePoint (mod_mul p (px s) a_inv2) (mod_mul p (py s) a_inv3) (BN.oneBigNat (# #)) t' = ProjectivePoint (mod_mul p (px t) b_inv2) (mod_mul p (py t) b_inv3) (BN.oneBigNat (# #)) spt' = ProjectivePoint (mod_mul p (px spt) c_inv2) (mod_mul p (py spt) c_inv3) (BN.oneBigNat (# #)) smt' = ProjectivePoint (mod_mul p (px smt) d_inv2) (mod_mul p (py smt) d_inv3) (BN.oneBigNat (# #)) -- | Given an integer @j@ and a projective point @S@, together with -- another integer @k@ and point @T@ compute the "twin" scalar -- the scalar multiplication @jS + kT@. This computation can be done -- essentially the same number of modular arithmetic operations -- as a single scalar multiplication by doing some additional bookkeeping -- and setup. ec_twin_mult :: PrimeModulus -> Integer -> ProjectivePoint -> Integer -> ProjectivePoint -> ProjectivePoint ec_twin_mult p (BN.integerToBigNat -> d0) s (BN.integerToBigNat -> d1) t = case m of 0# -> panic "ec_twin_mult" ["modulus too large", show (BN.bigNatToInteger (primeMod p))] _ -> go m init_c0 init_c1 zro where (s',t',spt',smt') = normalizeForTwinMult p s t m = case max 4 (widthInteger (BN.bigNatToInteger (primeMod p))) of BN.IS mint -> mint _ -> 0# -- if `m` doesn't fit into an Int, should be impossible init_c0 = C False False (tst d0 (m -# 1#)) (tst d0 (m -# 2#)) (tst d0 (m -# 3#)) (tst d0 (m -# 4#)) init_c1 = C False False (tst d1 (m -# 1#)) (tst d1 (m -# 2#)) (tst d1 (m -# 3#)) (tst d1 (m -# 4#)) tst x i | isTrue# (i >=# 0#) = BN.testBitBigNat x i | otherwise = False f i = if isTrue# (i <# 18#) then if isTrue# (i <# 12#) then if isTrue# (i <# 4#) then 12# else 14# else if isTrue# (i <# 14#) then 12# else 10# else if isTrue# (i <# 22#) then 9# else if isTrue# (i <# 24#) then 11# else 12# go !k !c0 !c1 !r = if isTrue# (k <# 0#) then r else go (k -# 1#) c0' c1' r' where h0 = cStateToH c0 h1 = cStateToH c1 u0 = if isTrue# (h0 <# f h1) then 0# else (if cHead c0 then -1# else 1#) u1 = if isTrue# (h1 <# f h0) then 0# else (if cHead c1 then -1# else 1#) c0' = cStateUpdate u0 c0 (tst d0 (k -# 5#)) c1' = cStateUpdate u1 c1 (tst d1 (k -# 5#)) r2 = ec_double p r r' = case u0 of -1# -> case u1 of -1# -> ec_sub p r2 spt' 1# -> ec_sub p r2 smt' _ -> ec_sub p r2 s' 1# -> case u1 of -1# -> ec_add p r2 smt' 1# -> ec_add p r2 spt' _ -> ec_add p r2 s' _ -> case u1 of -1# -> ec_sub p r2 t' 1# -> ec_add p r2 t' _ -> r2 data CState = C !Bool !Bool !Bool !Bool !Bool !Bool {-# INLINE cHead #-} cHead :: CState -> Bool cHead (C c0 _ _ _ _ _) = c0 {-# INLINE cStateToH #-} cStateToH :: CState -> Int# cStateToH c@(C c0 _ _ _ _ _) = if c0 then 31# -# cStateToInt c else cStateToInt c {-# INLINE cStateToInt #-} cStateToInt :: CState -> Int# cStateToInt (C _ c1 c2 c3 c4 c5) = (dataToTag# c1 `uncheckedIShiftL#` 4#) +# (dataToTag# c2 `uncheckedIShiftL#` 3#) +# (dataToTag# c3 `uncheckedIShiftL#` 2#) +# (dataToTag# c4 `uncheckedIShiftL#` 1#) +# (dataToTag# c5) {-# INLINE cStateUpdate #-} cStateUpdate :: Int# -> CState -> Bool -> CState cStateUpdate u (C _ c1 c2 c3 c4 c5) e = case u of 0# -> C c1 c2 c3 c4 c5 e _ -> C (not c1) c2 c3 c4 c5 e cryptol-3.0.0/src/Cryptol/REPL/0000755000000000000000000000000007346545000014364 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/REPL/Browse.hs0000644000000000000000000001276707346545000016176 0ustar0000000000000000{-# Language OverloadedStrings, BlockArguments #-} module Cryptol.REPL.Browse (BrowseHow(..), browseModContext) where import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe(mapMaybe) import Data.List(sortBy) import Data.Void (Void) import qualified Prettyprinter as PP import Cryptol.Parser.AST(Pragma(..)) import qualified Cryptol.TypeCheck.Type as T import Cryptol.Utils.PP import Cryptol.Utils.Ident (OrigName(..), modPathIsNormal, identIsNormal) import Cryptol.ModuleSystem.Env(ModContext(..),ModContextParams(..)) import Cryptol.ModuleSystem.NamingEnv(namingEnvNames) import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.Interface data BrowseHow = BrowseExported | BrowseInScope browseModContext :: BrowseHow -> ModContext -> PP.Doc Void browseModContext how mc = runDoc (env disp) (vcat sections) where sections = concat [ browseMParams (env disp) (mctxParams mc) , browseSignatures disp decls , browseMods disp decls , browseFunctors disp decls , browseTSyns disp decls , browsePrimTys disp decls , browseNewtypes disp decls , browseVars disp decls ] disp = DispInfo { dispHow = how, env = mctxNameDisp mc } decls = filterIfaceDecls (`Set.member` visNames) (mctxDecls mc) allNames = namingEnvNames (mctxNames mc) notAnon nm = identIsNormal (nameIdent nm) && case nameModPathMaybe nm of Just p -> modPathIsNormal p _ -> True -- shouldn't happen? visNames = Set.filter notAnon case how of BrowseInScope -> allNames BrowseExported -> mctxExported mc data DispInfo = DispInfo { dispHow :: BrowseHow, env :: NameDisp } -------------------------------------------------------------------------------- browseMParams :: NameDisp -> ModContextParams -> [Doc] browseMParams disp pars = case pars of NoParams -> [] FunctorParams params -> ppSectionHeading "Module Parameters" $ [ "parameter" <+> pp (T.mpName p) <+> ":" <+> "interface" <+> pp (T.mpIface p) $$ indent 2 (vcat $ map ppParamTy (sortByName disp (Map.toList (T.mpnTypes names))) ++ map ppParamFu (sortByName disp (Map.toList (T.mpnFuns names))) ) | p <- Map.elems params , let names = T.mpParameters p ] ++ [" "] InterfaceParams ps -> [pp ps] -- XXX where ppParamTy p = nest 2 (sep ["type", pp (T.mtpName p) <+> ":", pp (T.mtpKind p)]) ppParamFu p = nest 2 (sep [pp (T.mvpName p) <+> ":", pp (T.mvpType p)]) -- XXX: should we print the constraints somewhere too? browseMods :: DispInfo -> IfaceDecls -> [Doc] browseMods disp decls = ppSection disp "Submodules" ppM (ifModules decls) where ppM m = pp (ifsName m) browseFunctors :: DispInfo -> IfaceDecls -> [Doc] browseFunctors disp decls = ppSection disp "Parameterized Submodules" ppM (ifFunctors decls) where ppM m = pp (ifModName m) browseSignatures :: DispInfo -> IfaceDecls -> [Doc] browseSignatures disp decls = ppSection disp "Interface Submodules" ppS (Map.mapWithKey (,) (ifSignatures decls)) where ppS (x,s) = pp x browseTSyns :: DispInfo -> IfaceDecls -> [Doc] browseTSyns disp decls = ppSection disp "Type Synonyms" pp tss ++ ppSection disp "Constraint Synonyms" pp cts where (cts,tss) = Map.partition isCtrait (ifTySyns decls) isCtrait t = T.kindResult (T.kindOf (T.tsDef t)) == T.KProp browsePrimTys :: DispInfo -> IfaceDecls -> [Doc] browsePrimTys disp decls = ppSection disp "Primitive Types" ppA (ifAbstractTypes decls) where ppA a = nest 2 (sep [pp (T.atName a) <+> ":", pp (T.atKind a)]) browseNewtypes :: DispInfo -> IfaceDecls -> [Doc] browseNewtypes disp decls = ppSection disp "Newtypes" T.ppNewtypeShort (ifNewtypes decls) browseVars :: DispInfo -> IfaceDecls -> [Doc] browseVars disp decls = ppSection disp "Properties" ppVar props ++ ppSection disp "Symbols" ppVar syms where isProp p = PragmaProperty `elem` ifDeclPragmas p (props,syms) = Map.partition isProp (ifDecls decls) ppVar d = nest 2 (sep [pp (ifDeclName d) <+> ":", pp (ifDeclSig d)]) -------------------------------------------------------------------------------- ppSection :: DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc] ppSection disp heading ppThing mp = ppSectionHeading heading case dispHow disp of BrowseExported | [(_,xs)] <- grouped -> ppThings xs _ -> concatMap ppMod grouped where grouped = groupDecls (env disp) mp ppThings xs = map ppThing xs ++ [" "] ppMod (nm,things) = [ "From" <+> pp nm , "-----" <.> text (map (const '-') (show (runDoc (env disp) (pp nm)))) , " " , indent 2 (vcat (ppThings things)) ] ppSectionHeading :: String -> [Doc] -> [Doc] ppSectionHeading heading body | null body = [] | otherwise = [ text heading , text (map (const '=') heading) , " " , indent 2 (vcat body) ] -- | Organize by module where defined, then sort by name. groupDecls :: NameDisp -> Map Name a -> [(ModPath,[a])] groupDecls disp = Map.toList . fmap (sortByName disp) . Map.fromListWith (++) . mapMaybe toEntry . Map.toList where toEntry (n,a) = case nameInfo n of GlobalName _ og -> Just (ogModule og,[(n,a)]) _ -> Nothing sortByName :: NameDisp -> [(Name,a)] -> [a] sortByName disp = map snd . sortBy cmpByDispName where cmpByDispName (x,_) (y,_) = cmpNameDisplay disp x y cryptol-3.0.0/src/Cryptol/REPL/Command.hs0000644000000000000000000020222707346545000016303 0ustar0000000000000000-- | -- Module : Cryptol.REPL.Command -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 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 , TestReport(..) , qcExpr, qcCmd, QCMode(..) , satCmd , proveCmd , onlineProveSat , offlineProveSat -- Misc utilities , handleCtrlC , sanitize , withRWTempFile -- To support Notebook interface (might need to refactor) , replParse , liftModuleCmd , moduleCmdResult ) where import Cryptol.REPL.Monad import Cryptol.REPL.Trie import Cryptol.REPL.Browse import Cryptol.REPL.Help 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, PrefixAssocChanged)) import qualified Cryptol.Utils.Ident as M import qualified Cryptol.ModuleSystem.Env as M import Cryptol.ModuleSystem.Fingerprint(fingerprintHexString) import Cryptol.Backend.FloatHelpers as FP import qualified Cryptol.Backend.Monad as E import qualified Cryptol.Backend.SeqMap as E import Cryptol.Eval.Concrete( Concrete(..) ) import qualified Cryptol.Eval.Concrete as Concrete import qualified Cryptol.Eval.Env as E import Cryptol.Eval.FFI import Cryptol.Eval.FFI.GenHeader import qualified Cryptol.Eval.Type as E import qualified Cryptol.Eval.Value as E import qualified Cryptol.Eval.Reference as R import Cryptol.Testing.Random import qualified Cryptol.Testing.Random as TestR import Cryptol.Parser (parseExprWith,parseReplWith,ParseError(),Config(..),defaultConfig ,parseModName,parseHelpName) import Cryptol.Parser.Position (Position(..),Range(..),HasLoc(..)) 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 Cryptol.TypeCheck.PP (dump) import qualified Cryptol.Utils.Benchmark as Bench import Cryptol.Utils.PP hiding (()) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.RecordMap import qualified Cryptol.Parser.AST as P import qualified Cryptol.Transform.Specialize as S import Cryptol.Symbolic ( ProverCommand(..), QueryType(..) , ProverStats,ProverResult(..),CounterExampleType(..) ) import qualified Cryptol.Symbolic.SBV as SBV import qualified Cryptol.Symbolic.What4 as W4 import Cryptol.Version (displayVersion) import qualified Control.Exception as X import Control.Monad hiding (mapM, mapM) import qualified Control.Monad.Catch as Ex import Control.Monad.IO.Class(liftIO) import Text.Read (readMaybe) import Control.Applicative ((<|>)) import qualified Data.Set as Set import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.Bits (shiftL, (.&.), (.|.)) import Data.Char (isSpace,isPunctuation,isSymbol,isAlphaNum,isAscii) import Data.Function (on) import Data.List (intercalate, nub, isPrefixOf) 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 System.IO (Handle,hFlush,stdout,openTempFile,hClose,openFile ,IOMode(..),hGetContents,hSeek,SeekMode(..)) import qualified System.Random.TF as TF import qualified System.Random.TF.Instances as TFI import Numeric (showFFloat) import qualified Data.Text as T import Data.IORef(newIORef,readIORef,writeIORef) import GHC.Float (log1p, expm1) import Prelude () import Prelude.Compat import qualified Data.SBV.Internals as SBV (showTDiff) -- Commands -------------------------------------------------------------------- -- | Commands. data Command = Command (Int -> Maybe FilePath -> 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 , cLongHelp :: 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 -> (Int,Int) -> Maybe FilePath -> REPL ()) | FileExprArg (FilePath -> String -> (Int,Int) -> Maybe FilePath -> 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 information about loaded modules." (unlines [ "With no arguent, :browse shows information about the names in scope." , "With an argument M, shows information about the names exported from M" ] ) , CommandDescr [ ":version"] [] (NoArg versionCmd) "Display the version of this Cryptol executable" "" , CommandDescr [ ":?", ":help" ] ["[ TOPIC ]"] (HelpArg helpCmd) "Display a brief description of a function, type, or command. (e.g. :help :help)" (unlines [ "TOPIC can be any of:" , " * Specific REPL colon-commands (e.g. :help :prove)" , " * Functions (e.g. :help join)" , " * Infix operators (e.g. :help +)" , " * Type constructors (e.g. :help Z)" , " * Type constraints (e.g. :help fin)" , " * :set-able options (e.g. :help :set base)" ]) , CommandDescr [ ":s", ":set" ] ["[ OPTION [ = VALUE ] ]"] (OptionArg setOptionCmd) "Set an environmental option (:set on its own displays current values)." "" , CommandDescr [ ":check" ] ["[ EXPR ]"] (ExprArg (qcCmd QCRandom)) "Use random testing to check that the argument always returns true.\n(If no argument, check all properties.)" "" , CommandDescr [ ":exhaust" ] ["[ EXPR ]"] (ExprArg (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 [ ":safe" ] ["[ EXPR ]"] (ExprArg safeCmd) "Use an external solver to prove that an expression is safe\n(does not encounter run-time errors) for all inputs." "" , 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." "" , CommandDescr [ ":time" ] ["EXPR"] (ExprArg timeCmd) "Measure the time it takes to evaluate the given expression." (unlines [ "The expression will be evaluated many times to get accurate results." , "Note that the first evaluation of a binding may take longer due to" , " laziness, and this may affect the reported time. If this is not" , " desired then make sure to evaluate the expression once first before" , " running :time." , "The amount of time to spend collecting measurements can be changed" , " with the timeMeasurementPeriod option." , "Reports the average wall clock time, CPU time, and cycles." , " (Cycles are in unspecified units that may be CPU cycles.)" , "Binds the result to" , " it : { avgTime : Float64" , " , avgCpuTime : Float64" , " , avgCycles : Integer }" ]) , CommandDescr [ ":set-seed" ] ["SEED"] (OptionArg seedCmd) "Seed the random number generator for operations using randomness" (unlines [ "A seed takes the form of either a single integer or a 4-tuple" , "of unsigned 64-bit integers. Examples of commands using randomness" , "are dumpTests and check." ]) , CommandDescr [ ":new-seed"] [] (NoArg newSeedCmd) "Randomly generate and set a new seed for the random number generator" "" ] 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." ]) "" , CommandDescr [ ":generate-foreign-header" ] ["FILE"] (FilenameArg genHeaderCmd) "Generate a C header file from foreign declarations in a Cryptol file." (unlines [ "Converts all foreign declarations in the given Cryptol file into C" , "function declarations, and writes them to a file with the same name" , "but with a .h extension." ]) , CommandDescr [ ":file-deps" ] [ "FILE" ] (FilenameArg (moduleInfoCmd True)) "Show information about the dependencies of a file" "" , CommandDescr [ ":module-deps" ] [ "MODULE" ] (ModNameArg (moduleInfoCmd False)) "Show information about the dependencies of a module" "" ] 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 :: Int -> Maybe FilePath -> Command -> REPL CommandExitCode runCommand lineNum mbBatch c = case c of Command cmd -> (cmd lineNum mbBatch >> 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 evalCmd :: String -> Int -> Maybe FilePath -> REPL () evalCmd str lineNum mbBatch = do ri <- replParseInput str lineNum mbBatch case ri of P.ExprInput expr -> do (val,_ty) <- replEvalExpr expr ppOpts <- getPPValOpts valDoc <- rEvalRethrow (E.ppValue Concrete 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 ds -> do -- explicitly make this a top-level declaration, so that it will -- be generalized if mono-binds is enabled replEvalDecls ds P.EmptyInput -> -- comment or empty input does nothing pure () printCounterexample :: CounterExampleType -> Doc -> [Concrete.Value] -> REPL () printCounterexample cexTy exprDoc vs = do ppOpts <- getPPValOpts docs <- mapM (rEval . E.ppValue Concrete ppOpts) vs let cexRes = case cexTy of SafetyViolation -> [text "~> ERROR"] PredicateFalsified -> [text "= False"] rPrint $ nest 2 (sep ([exprDoc] ++ docs ++ cexRes)) printSatisfyingModel :: Doc -> [Concrete.Value] -> REPL () printSatisfyingModel exprDoc vs = do ppOpts <- getPPValOpts docs <- mapM (rEval . E.ppValue Concrete ppOpts) vs rPrint $ nest 2 (sep ([exprDoc] ++ docs ++ [text "= True"])) dumpTestsCmd :: FilePath -> String -> (Int,Int) -> Maybe FilePath -> REPL () dumpTestsCmd outFile str pos fnm = do expr <- replParseExpr str pos fnm (val, ty) <- replEvalExpr expr ppopts <- getPPValOpts testNum <- getKnownUser "tests" :: REPL Int tenv <- E.envTypes . M.deEnv <$> getDynEnv let tyv = E.evalValType tenv ty gens <- case TestR.dumpableType tyv of Nothing -> raise (TypeNotTestable ty) Just gens -> return gens tests <- withRandomGen (\g -> io $ TestR.returnTests' g gens val testNum) out <- forM tests $ \(args, x) -> do argOut <- mapM (rEval . E.ppValue Concrete ppopts) args resOut <- rEval (E.ppValue Concrete 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 -> (Int,Int) -> Maybe FilePath -> REPL () qcCmd qcMode "" _pos _fnm = 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,d) -> do let str = nameStr x rPutStr $ "property " ++ str ++ " " let texpr = T.EVar x let schema = M.ifDeclSig d nd <- M.mctxNameDisp <$> getFocusedEnv let doc = fixNameDisp nd (pp texpr) void (qcExpr qcMode doc texpr schema) qcCmd qcMode str pos fnm = do expr <- replParseExpr str pos fnm (_,texpr,schema) <- replCheckExpr expr nd <- M.mctxNameDisp <$> getFocusedEnv let doc = fixNameDisp nd (ppPrec 3 expr) -- function application has precedence 3 void (qcExpr qcMode doc texpr schema) data TestReport = TestReport { reportExpr :: Doc , reportResult :: TestResult , reportTestsRun :: Integer , reportTestsPossible :: Maybe Integer } qcExpr :: QCMode -> Doc -> T.Expr -> T.Schema -> REPL TestReport qcExpr qcMode exprDoc texpr schema = do (val,ty) <- replEvalCheckedExpr texpr schema >>= \mb_res -> case mb_res of Just res -> pure res -- If instance is not found, doesn't necessarily mean that there is no instance. -- And due to nondeterminism in result from the solver (for finding solution to -- numeric type constraints), `:check` can get to this exception sometimes, but -- successfully find an instance and test with it other times. Nothing -> raise (InstantiationsNotFound schema) testNum <- (toInteger :: Int -> Integer) <$> getKnownUser "tests" tenv <- E.envTypes . M.deEnv <$> getDynEnv let tyv = E.evalValType tenv ty -- tv has already had polymorphism instantiated percentRef <- io $ newIORef Nothing testsRef <- io $ newIORef 0 case testableType tyv of Just (Just sz,tys,vss,_gens) | qcMode == QCExhaust || sz <= testNum -> do rPutStrLn "Using exhaustive testing." prt testingMsg (res,num) <- Ex.catch (exhaustiveTests (\n -> ppProgress percentRef testsRef n sz) val vss) (\ex -> do rPutStrLn "\nTest interrupted..." num <- io $ readIORef testsRef let report = TestReport exprDoc Pass num (Just sz) ppReport tys False report rPutStrLn $ interruptedExhaust num sz Ex.throwM (ex :: Ex.SomeException)) let report = TestReport exprDoc res num (Just sz) delProgress delTesting ppReport tys True report return report Just (sz,tys,_,gens) | qcMode == QCRandom -> do rPutStrLn "Using random testing." prt testingMsg (res,num) <- withRandomGen (randomTests' (\n -> ppProgress percentRef testsRef n testNum) testNum val gens) `Ex.catch` (\ex -> do rPutStrLn "\nTest interrupted..." num <- io $ readIORef testsRef let report = TestReport exprDoc Pass num sz ppReport tys False report case sz of Just n -> rPutStrLn $ coverageString num n _ -> return () Ex.throwM (ex :: Ex.SomeException)) let report = TestReport exprDoc res num sz delProgress delTesting ppReport tys False report case sz of Just n | isPass res -> rPutStrLn $ coverageString testNum n _ -> return () return report _ -> raise (TypeNotTestable ty) where testingMsg = "Testing... " interruptedExhaust testNum sz = let percent = (100.0 :: Double) * (fromInteger testNum) / fromInteger sz showValNum | sz > 2 ^ (20::Integer) = "2^^" ++ show (lg2 sz) | otherwise = show sz in "Test coverage: " ++ showFFloat (Just 2) percent "% (" ++ show testNum ++ " of " ++ showValNum ++ " values)" 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) ppProgress percentRef testsRef this tot = do io $ writeIORef testsRef this let percent = show (div (100 * this) tot) ++ "%" width = length percent pad = replicate (totProgressWidth - width) ' ' unlessBatch $ do oldPercent <- io $ readIORef percentRef case oldPercent of Nothing -> do io $ writeIORef percentRef (Just percent) prt (pad ++ percent) Just p | p /= percent -> do io $ writeIORef percentRef (Just percent) delProgress prt (pad ++ percent) _ -> return () del n = unlessBatch $ prt (replicate n '\BS' ++ replicate n ' ' ++ replicate n '\BS') delTesting = del (length testingMsg) delProgress = del totProgressWidth ppReport :: [E.TValue] -> Bool -> TestReport -> REPL () ppReport _tys isExhaustive (TestReport _exprDoc Pass testNum _testPossible) = do rPutStrLn ("Passed " ++ show testNum ++ " tests.") when isExhaustive (rPutStrLn "Q.E.D.") ppReport tys _ (TestReport exprDoc failure _testNum _testPossible) = do ppFailure tys exprDoc failure ppFailure :: [E.TValue] -> Doc -> TestResult -> REPL () ppFailure tys exprDoc failure = do ~(EnvBool showEx) <- getUser "showExamples" vs <- case failure of FailFalse vs -> do rPutStrLn "Counterexample" when showEx (printCounterexample PredicateFalsified exprDoc vs) pure vs FailError err vs | null vs || not showEx -> do rPutStrLn "ERROR" rPrint (pp err) pure vs | otherwise -> do rPutStrLn "ERROR for the following inputs:" printCounterexample SafetyViolation exprDoc vs rPrint (pp err) pure vs Pass -> panic "Cryptol.REPL.Command" ["unexpected Test.Pass"] -- bind the 'it' variable case (tys,vs) of ([t],[v]) -> bindItVariableVal t v _ -> let fs = [ M.packIdent ("arg" ++ show (i::Int)) | i <- [ 1 .. ] ] t = E.TVRec (recordFromFields (zip fs tys)) v = E.VRecord (recordFromFields (zip fs (map return vs))) in bindItVariableVal t v -- | 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 :: Integer -> 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 -> (Int,Int) -> Maybe FilePath -> REPL () satCmd = cmdProveSat True proveCmd = cmdProveSat False showProverStats :: Maybe String -> 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.catches` hs) where hs = [ X.Handler $ \ (X.ErrorCallWithLocation s _) -> X.throwIO (SBVError s) , X.Handler $ \ e -> X.throwIO (SBVException e) , X.Handler $ \ e -> X.throwIO (SBVPortfolioException e) , X.Handler $ \ e -> X.throwIO (W4Exception e) ] -- | Attempts to prove the given term is safe for all inputs safeCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL () safeCmd str pos fnm = do proverName <- getKnownUser "prover" fileName <- getKnownUser "smtFile" let mfile = if fileName == "-" then Nothing else Just fileName pexpr <- replParseExpr str pos fnm nd <- M.mctxNameDisp <$> getFocusedEnv let exprDoc = fixNameDisp nd (ppPrec 3 pexpr) -- function application has precedence 3 let rng = fromMaybe (mkInteractiveRange pos fnm) (getLoc pexpr) (_,texpr,schema) <- replCheckExpr pexpr if proverName `elem` ["offline","sbv-offline","w4-offline"] then offlineProveSat proverName SafetyQuery texpr schema mfile else do (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat proverName SafetyQuery texpr schema mfile) case result of EmptyResult -> panic "REPL.Command" [ "got EmptyResult for online prover query" ] ProverError msg -> rPutStrLn msg ThmResult _ts -> rPutStrLn "Safe" CounterExample cexType tevs -> do rPutStrLn "Counterexample" let tes = map ( \(t,e,_) -> (t,e)) tevs vs = map ( \(_,_,v) -> v) tevs (t,e) <- mkSolverResult "counterexample" rng False (Right tes) ~(EnvBool yes) <- getUser "showExamples" when yes $ printCounterexample cexType exprDoc vs when yes $ printSafetyViolation texpr schema vs void $ bindItVariable t e AllSatResult _ -> do panic "REPL.Command" ["Unexpected AllSAtResult for ':safe' call"] seeStats <- getUserShowProverStats when seeStats (showProverStats firstProver stats) -- | 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 -> (Int,Int) -> Maybe FilePath -> REPL () cmdProveSat isSat "" _pos _fnm = 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,d) -> do let str = nameStr x if isSat then rPutStr $ ":sat " ++ str ++ "\n\t" else rPutStr $ ":prove " ++ str ++ "\n\t" let texpr = T.EVar x let schema = M.ifDeclSig d nd <- M.mctxNameDisp <$> getFocusedEnv let doc = fixNameDisp nd (pp texpr) proveSatExpr isSat (M.nameLoc x) doc texpr schema cmdProveSat isSat str pos fnm = do pexpr <- replParseExpr str pos fnm nd <- M.mctxNameDisp <$> getFocusedEnv let doc = fixNameDisp nd (ppPrec 3 pexpr) -- function application has precedence 3 (_,texpr,schema) <- replCheckExpr pexpr let rng = fromMaybe (mkInteractiveRange pos fnm) (getLoc pexpr) proveSatExpr isSat rng doc texpr schema proveSatExpr :: Bool -> Range -> Doc -> T.Expr -> T.Schema -> REPL () proveSatExpr isSat rng exprDoc texpr schema = do let cexStr | isSat = "satisfying assignment" | otherwise = "counterexample" qtype <- if isSat then SatQuery <$> getUserSatNum else pure ProveQuery proverName <- getKnownUser "prover" fileName <- getKnownUser "smtFile" let mfile = if fileName == "-" then Nothing else Just fileName if proverName `elem` ["offline","sbv-offline","w4-offline"] then offlineProveSat proverName qtype texpr schema mfile else do (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat proverName qtype texpr schema mfile) case result of EmptyResult -> panic "REPL.Command" [ "got EmptyResult for online prover query" ] ProverError msg -> rPutStrLn msg ThmResult ts -> do rPutStrLn (if isSat then "Unsatisfiable" else "Q.E.D.") (t, e) <- mkSolverResult cexStr rng (not isSat) (Left ts) void $ bindItVariable t e CounterExample cexType tevs -> do rPutStrLn "Counterexample" let tes = map ( \(t,e,_) -> (t,e)) tevs vs = map ( \(_,_,v) -> v) tevs (t,e) <- mkSolverResult cexStr rng isSat (Right tes) ~(EnvBool yes) <- getUser "showExamples" when yes $ printCounterexample cexType exprDoc vs -- if there's a safety violation, evalute the counterexample to -- find and print the actual concrete error case cexType of SafetyViolation -> when yes $ printSafetyViolation texpr schema vs _ -> return () void $ bindItVariable t e AllSatResult tevss -> do rPutStrLn "Satisfiable" let tess = map (map $ \(t,e,_) -> (t,e)) tevss vss = map (map $ \(_,_,v) -> v) tevss resultRecs <- mapM (mkSolverResult cexStr rng 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 ~(EnvBool yes) <- getUser "showExamples" when yes $ forM_ vss (printSatisfyingModel exprDoc) let numModels = length tevss when (numModels > 1) (rPutStrLn ("Models found: " ++ show numModels)) case exprs of [e] -> void $ bindItVariable ty e _ -> bindItVariables ty exprs seeStats <- getUserShowProverStats when seeStats (showProverStats firstProver stats) printSafetyViolation :: T.Expr -> T.Schema -> [E.GenValue Concrete] -> REPL () printSafetyViolation texpr schema vs = catch (do fn <- replEvalCheckedExpr texpr schema >>= \mb_res -> case mb_res of Just (fn, _) -> pure fn Nothing -> raise (EvalPolyError schema) rEval (E.forceValue =<< foldM (\f v -> E.fromVFun Concrete f (pure v)) fn vs)) (\case EvalError eex -> rPutStrLn (show (pp eex)) ex -> raise ex) onlineProveSat :: String -> QueryType -> T.Expr -> T.Schema -> Maybe FilePath -> REPL (Maybe String,ProverResult,ProverStats) onlineProveSat proverName qtype expr schema mfile = do verbose <- getKnownUser "debug" modelValidate <- getUserProverValidate validEvalContext expr validEvalContext schema decls <- fmap M.deDecls getDynEnv timing <- io (newIORef 0) ~(EnvBool ignoreSafety) <- getUser "ignoreSafety" let cmd = ProverCommand { pcQueryType = qtype , pcProverName = proverName , pcVerbose = verbose , pcValidate = modelValidate , pcProverStats = timing , pcExtraDecls = decls , pcSmtFile = mfile , pcExpr = expr , pcSchema = schema , pcIgnoreSafety = ignoreSafety } (firstProver, res) <- getProverConfig >>= \case Left sbvCfg -> liftModuleCmd $ SBV.satProve sbvCfg cmd Right w4Cfg -> do ~(EnvBool hashConsing) <- getUser "hashConsing" ~(EnvBool warnUninterp) <- getUser "warnUninterp" liftModuleCmd $ W4.satProve w4Cfg hashConsing warnUninterp cmd stas <- io (readIORef timing) return (firstProver,res,stas) offlineProveSat :: String -> QueryType -> T.Expr -> T.Schema -> Maybe FilePath -> REPL () offlineProveSat proverName qtype expr schema mfile = do verbose <- getKnownUser "debug" modelValidate <- getUserProverValidate decls <- fmap M.deDecls getDynEnv timing <- io (newIORef 0) ~(EnvBool ignoreSafety) <- getUser "ignoreSafety" let cmd = ProverCommand { pcQueryType = qtype , pcProverName = proverName , pcVerbose = verbose , pcValidate = modelValidate , pcProverStats = timing , pcExtraDecls = decls , pcSmtFile = mfile , pcExpr = expr , pcSchema = schema , pcIgnoreSafety = ignoreSafety } put <- getPutStr let putLn x = put (x ++ "\n") let displayMsg = do let filename = fromMaybe "standard output" mfile let satWord = case qtype of SatQuery _ -> "satisfiability" ProveQuery -> "validity" SafetyQuery -> "safety" putLn $ "Writing to SMT-Lib file " ++ filename ++ "..." putLn $ "To determine the " ++ satWord ++ " of the expression, use an external SMT solver." getProverConfig >>= \case Left sbvCfg -> do result <- liftModuleCmd $ SBV.satProveOffline sbvCfg cmd case result of Left msg -> rPutStrLn msg Right smtlib -> do io $ displayMsg case mfile of Just path -> io $ writeFile path smtlib Nothing -> rPutStr smtlib Right _w4Cfg -> do ~(EnvBool hashConsing) <- getUser "hashConsing" ~(EnvBool warnUninterp) <- getUser "warnUninterp" result <- liftModuleCmd $ W4.satProveOffline hashConsing warnUninterp cmd $ \f -> do displayMsg case mfile of Just path -> X.bracket (openFile path WriteMode) hClose f Nothing -> withRWTempFile "smtOutput.tmp" $ \h -> do f h hSeek h AbsoluteSeek 0 hGetContents h >>= put case result of Just msg -> rPutStrLn msg Nothing -> return () 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 -> Range -> Bool -> Either [E.TValue] [(E.TValue, T.Expr)] -> REPL (E.TValue, T.Expr) mkSolverResult thing rng result earg = do prims <- getPrimMap let addError t = (t, T.ELocated rng (T.eError prims (E.tValTy t) ("no " ++ thing ++ " available"))) argF = case earg of Left ts -> mkArgs (map addError ts) Right tes -> mkArgs tes eTrue = T.ePrim prims (M.prelPrim "True") eFalse = T.ePrim prims (M.prelPrim "False") resultE = if result then eTrue else eFalse rty = E.TVRec (recordFromFields $ [(rIdent, E.TVBit)] ++ map fst argF) re = T.ERec (recordFromFields $ [(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 -> (Int,Int) -> Maybe FilePath -> REPL () specializeCmd str pos fnm = do parseExpr <- replParseExpr str pos fnm (_, 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 -> (Int,Int) -> Maybe FilePath -> REPL () refEvalCmd str pos fnm = do parseExpr <- replParseExpr str pos fnm (_, expr, schema) <- replCheckExpr parseExpr validEvalContext expr validEvalContext schema val <- liftModuleCmd (rethrowEvalError . R.evaluate expr) opts <- getPPValOpts rPrint $ R.ppEValue opts val astOfCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL () astOfCmd str pos fnm = do expr <- replParseExpr str pos fnm (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 -> (Int,Int) -> Maybe FilePath -> REPL () typeOfCmd str pos fnm = do expr <- replParseExpr str pos fnm (_re,def,sig) <- replCheckExpr expr -- XXX need more warnings from the module system whenDebug (rPutStrLn (dump def)) fDisp <- M.mctxNameDisp <$> getFocusedEnv -- type annotation ':' has precedence 2 rPrint $ runDoc fDisp $ group $ hang (ppPrec 2 expr <+> text ":") 2 (pp sig) timeCmd :: String -> (Int, Int) -> Maybe FilePath -> REPL () timeCmd str pos fnm = do period <- getKnownUser "timeMeasurementPeriod" :: REPL Int quiet <- getKnownUser "timeQuiet" unless quiet $ rPutStrLn $ "Measuring for " ++ show period ++ " seconds" pExpr <- replParseExpr str pos fnm (_, def, sig) <- replCheckExpr pExpr replPrepareCheckedExpr def sig >>= \case Nothing -> raise (EvalPolyError sig) Just (_, expr) -> do Bench.BenchmarkStats {..} <- liftModuleCmd (rethrowEvalError . M.benchmarkExpr (fromIntegral period) expr) unless quiet $ rPutStrLn $ "Avg time: " ++ Bench.secs benchAvgTime ++ " Avg CPU time: " ++ Bench.secs benchAvgCpuTime ++ " Avg cycles: " ++ show benchAvgCycles let mkStatsRec time cpuTime cycles = recordFromFields [("avgTime", time), ("avgCpuTime", cpuTime), ("avgCycles", cycles)] itType = E.TVRec $ mkStatsRec E.tvFloat64 E.tvFloat64 E.TVInteger itVal = E.VRecord $ mkStatsRec (pure $ E.VFloat $ FP.floatFromDouble benchAvgTime) (pure $ E.VFloat $ FP.floatFromDouble benchAvgCpuTime) (pure $ E.VInteger $ toInteger benchAvgCycles) bindItVariableVal itType itVal 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 val = byteStringToInteger bs let len = BS.length bs let split = T.ePrim pm (M.prelPrim "split") let number = T.ePrim pm (M.prelPrim "number") let f = T.EProofApp (foldl T.ETApp split [T.tNum len, T.tNum (8::Integer), T.tBit]) let t = T.tWord (T.tNum (toInteger len * 8)) let x = T.EProofApp (T.ETApp (T.ETApp number (T.tNum val)) t) let expr = T.EApp f x void $ bindItVariable (E.TVSeq (toInteger len) (E.TVSeq 8 E.TVBit)) expr -- | Convert a 'ByteString' (big-endian) of length @n@ to an 'Integer' -- with @8*n@ bits. This function uses a balanced binary fold to -- achieve /O(n log n)/ total memory allocation and run-time, in -- contrast to the /O(n^2)/ that would be required by a naive -- left-fold. byteStringToInteger :: BS.ByteString -> Integer -- byteStringToInteger = BS.foldl' (\a b -> a `shiftL` 8 .|. toInteger b) 0 byteStringToInteger bs | l == 0 = 0 | l == 1 = toInteger (BS.head bs) | otherwise = x1 `shiftL` (l2 * 8) .|. x2 where l = BS.length bs l1 = l `div` 2 l2 = l - l1 (bs1, bs2) = BS.splitAt l1 bs x1 = byteStringToInteger bs1 x2 = byteStringToInteger bs2 writeFileCmd :: FilePath -> String -> (Int,Int) -> Maybe FilePath -> REPL () writeFileCmd file str pos fnm = do expr <- replParseExpr str pos fnm (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 Concrete "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 (Concrete.BV _ v) = fromIntegral (v .&. 0xFF) rEval :: E.Eval a -> REPL a rEval m = io (E.runEval mempty m) rEvalRethrow :: E.Eval a -> REPL a rEvalRethrow m = io $ rethrowEvalError $ E.runEval mempty m reloadCmd :: REPL () reloadCmd = do mb <- getLoadedMod case mb of Just lm -> 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 withRWTempFile :: String -> (Handle -> IO a) -> IO a withRWTempFile name k = X.bracket (do tmp <- getTemporaryDirectory let esc c = if isAscii c && isAlphaNum c then c else '_' openTempFile tmp (map esc name)) (\(nm,h) -> hClose h >> removeFile nm) (k . snd) 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 -> do mpath <- liftModuleCmd (M.findModule m) case mpath of M.InFile file -> do setEditPath file setLoadedMod LoadedModule { lName = Just m, lPath = mpath } loadHelper (M.loadModuleByPath file) M.InMem {} -> 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.TCTopEntity) -> REPL () loadHelper how = do clearLoadedMod (path,ent) <- liftModuleCmd how whenDebug (rPutStrLn (dump ent)) setLoadedMod LoadedModule { lName = Just (T.tcTopEntitytName ent) , 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 genHeaderCmd :: FilePath -> REPL () genHeaderCmd path | null path = pure () | otherwise = do (mPath, m) <- liftModuleCmd $ M.checkModuleByPath path let decls = case m of T.TCTopModule mo -> findForeignDecls mo T.TCTopSignature {} -> [] if null decls then rPutStrLn $ "No foreign declarations in " ++ pretty mPath else do let header = generateForeignHeader decls case mPath of M.InFile p -> do let hPath = p -<.> "h" rPutStrLn $ "Writing header to " ++ hPath replWriteFileString hPath header (rPutStrLn . show) M.InMem _ _ -> rPutStrLn header versionCmd :: REPL () versionCmd = displayVersion rPutStrLn quitCmd :: REPL () quitCmd = stop browseCmd :: String -> REPL () browseCmd input | null input = do fe <- getFocusedEnv rPrint (browseModContext BrowseInScope fe) | otherwise = case parseModName input of Nothing -> rPutStrLn "Invalid module name" Just m -> do mb <- M.modContextOf m <$> getModuleEnv case mb of Nothing -> rPutStrLn ("Module " ++ show input ++ " is not loaded") Just fe -> rPrint (browseModContext BrowseExported fe) 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 1 Nothing (Unknown cmd0) [c] -> showCmdHelp c args cs -> void $ runCommand 1 Nothing (Ambiguous cmd0 (concatMap cNames cs)) | otherwise = case parseHelpName cmd of Just qname -> helpForNamed qname Nothing -> rPutStrLn ("Unable to parse name: " ++ cmd) where 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 "" when (not (null (cLongHelp c))) $ do rPutStrLn (cLongHelp 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" resetTCSolver return a -- Utilities ------------------------------------------------------------------- -- | 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 -> Int -> Maybe FilePath -> REPL (P.ReplInput P.PName) replParseInput str lineNum fnm = replParse (parseReplWith cfg . T.pack) str where cfg = case fnm of Nothing -> interactiveConfig{ cfgStart = Position lineNum 1 } Just f -> defaultConfig { cfgSource = f , cfgStart = Position lineNum 1 } replParseExpr :: String -> (Int,Int) -> Maybe FilePath -> REPL (P.Expr P.PName) replParseExpr str (l,c) fnm = replParse (parseExprWith cfg. T.pack) str where cfg = case fnm of Nothing -> interactiveConfig{ cfgStart = Position l c } Just f -> defaultConfig { cfgSource = f , cfgStart = Position l c } mkInteractiveRange :: (Int,Int) -> Maybe FilePath -> Range mkInteractiveRange (l,c) mb = Range p p src where p = Position l c src = case mb of Nothing -> "" Just b -> b interactiveConfig :: Config interactiveConfig = defaultConfig { cfgSource = "" } getPrimMap :: REPL M.PrimMap getPrimMap = liftModuleCmd M.getPrimMap liftModuleCmd :: M.ModuleCmd a -> REPL a liftModuleCmd cmd = do evo <- getEvalOptsAction env <- getModuleEnv callStacks <- getCallStacks tcSolver <- getTCSolver let minp = M.ModuleInput { minpCallStacks = callStacks , minpEvalOpts = evo , minpByteReader = BS.readFile , minpModuleEnv = env , minpTCSolver = tcSolver } moduleCmdResult =<< io (cmd minp) -- TODO: add filter for my exhaustie prop guards warning here moduleCmdResult :: M.ModuleRes a -> REPL a moduleCmdResult (res,ws0) = do warnDefaulting <- getKnownUser "warnDefaulting" warnShadowing <- getKnownUser "warnShadowing" warnPrefixAssoc <- getKnownUser "warnPrefixAssoc" warnNonExhConGrds <- getKnownUser "warnNonExhaustiveConstraintGuards" -- XXX: let's generalize this pattern let isShadowWarn (M.SymbolShadowed {}) = True isShadowWarn _ = False isPrefixAssocWarn (M.PrefixAssocChanged {}) = True isPrefixAssocWarn _ = False filterRenamer True _ w = Just w filterRenamer _ check (M.RenamerWarnings xs) = case filter (not . check) xs of [] -> Nothing ys -> Just (M.RenamerWarnings ys) filterRenamer _ _ w = Just w -- ignore certain warnings during typechecking filterTypecheck :: M.ModuleWarning -> Maybe M.ModuleWarning filterTypecheck (M.TypeCheckWarnings nameMap xs) = case filter (allow . snd) xs of [] -> Nothing ys -> Just (M.TypeCheckWarnings nameMap ys) where allow :: T.Warning -> Bool allow = \case T.DefaultingTo _ _ | not warnDefaulting -> False T.NonExhaustivePropGuards _ | not warnNonExhConGrds -> False _ -> True filterTypecheck w = Just w let ws = mapMaybe (filterRenamer warnShadowing isShadowWarn) . mapMaybe (filterRenamer warnPrefixAssoc isPrefixAssocWarn) . mapMaybe filterTypecheck $ ws0 names <- M.mctxNameDisp <$> 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',tyMap) <- liftModuleCmd (M.checkDecls (map mkTop npds)) -- extend the naming env and type synonym maps denv <- getDynEnv setDynEnv denv { M.deNames = names `M.shadowing` M.deNames denv , M.deTySyns = tyMap <> M.deTySyns denv } return ds' replSpecExpr :: T.Expr -> REPL T.Expr replSpecExpr e = liftModuleCmd $ S.specialize e replEvalExpr :: P.Expr P.PName -> REPL (Concrete.Value, T.Type) replEvalExpr expr = do (_,def,sig) <- replCheckExpr expr replEvalCheckedExpr def sig >>= \case Just res -> pure res Nothing -> raise (EvalPolyError sig) replEvalCheckedExpr :: T.Expr -> T.Schema -> REPL (Maybe (Concrete.Value, T.Type)) replEvalCheckedExpr def sig = replPrepareCheckedExpr def sig >>= traverse \(tys, def1) -> do let su = T.listParamSubst tys let ty = T.apSubst su (T.sType sig) whenDebug (rPutStrLn (dump def1)) tenv <- E.envTypes . M.deEnv <$> getDynEnv let tyv = E.evalValType tenv ty -- add "it" to the namespace via a new declaration itVar <- bindItVariable tyv def1 let itExpr = case getLoc def of Nothing -> T.EVar itVar Just rng -> T.ELocated rng (T.EVar itVar) -- evaluate the it variable val <- liftModuleCmd (rethrowEvalError . M.evalExpr itExpr) return (val,ty) -- | Check that we are in a valid evaluation context and apply defaulting. replPrepareCheckedExpr :: T.Expr -> T.Schema -> REPL (Maybe ([(T.TParam, T.Type)], T.Expr)) replPrepareCheckedExpr def sig = do validEvalContext def validEvalContext sig s <- getTCSolver mbDef <- io (defaultReplExpr s def sig) case mbDef of Nothing -> pure Nothing Just (tys, def1) -> do warnDefaults tys pure $ Just (tys, def1) where warnDefaults ts = case ts of [] -> return () _ -> 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 = replWriteFileWith BS.writeFile replWriteFileString :: FilePath -> String -> (X.SomeException -> REPL ()) -> REPL () replWriteFileString = replWriteFileWith writeFile replWriteFileWith :: (FilePath -> a -> IO ()) -> FilePath -> a -> (X.SomeException -> REPL ()) -> REPL () replWriteFileWith write fp contents handler = do x <- io $ X.catch (write fp contents >> 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. The fresh name generated -- is returned. bindItVariable :: E.TValue -> T.Expr -> REPL T.Name bindItVariable ty expr = do freshIt <- freshName itIdent M.UserName let schema = T.Forall { T.sVars = [] , T.sProps = [] , T.sType = E.tValTy 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.singletonNS M.NSValue (P.UnQual itIdent) freshIt `M.shadowing` M.deNames denv setDynEnv $ denv { M.deNames = nenv' } return freshIt -- | 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 :: E.TValue -> Concrete.Value -> REPL () bindItVariableVal ty val = do prims <- getPrimMap mb <- rEval (Concrete.toExpr prims ty val) case mb of Nothing -> return () Just expr -> void $ 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 :: E.TValue -> [T.Expr] -> REPL () bindItVariables ty exprs = void $ bindItVariable seqTy seqExpr where len = length exprs seqTy = E.TVSeq (toInteger len) ty seqExpr = T.EList exprs (E.tValTy ty) replEvalDecls :: [P.Decl P.PName] -> REPL () replEvalDecls ds = do dgs <- replCheckDecls ds 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 newSeedCmd :: REPL () newSeedCmd = do seed <- createAndSetSeed rPutStrLn "Seed initialized to:" rPutStrLn (show seed) where createAndSetSeed = withRandomGen $ \g0 -> let (s1, g1) = TFI.random g0 (s2, g2) = TFI.random g1 (s3, g3) = TFI.random g2 (s4, _) = TFI.random g3 seed = (s1, s2, s3, s4) in pure (seed, TF.seedTFGen seed) seedCmd :: String -> REPL () seedCmd s = case mbGen of Nothing -> rPutStrLn "Could not parse seed argument - expecting an integer or 4-tuple of integers." Just gen -> setRandomGen gen where mbGen = (TF.mkTFGen <$> readMaybe s) <|> (TF.seedTFGen <$> readMaybe s) -- 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 (Int,String,String) splitCommand = go 0 where go !len (c : more) | isSpace c = go (len+1) more go !len (':': more) | (as,bs) <- span (\x -> isPunctuation x || isSymbol x) more , (ws,cs) <- span isSpace bs , not (null as) = Just (len+1+length as+length ws, ':' : as, cs) | (as,bs) <- break isSpace more , (ws,cs) <- span isSpace bs , not (null as) = Just (len+1+length as+length ws, ':' : as, cs) | otherwise = Nothing go !len expr | null expr = Nothing | otherwise = Just (len+length expr, 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 (cmdLen,cmd,args) <- splitCommand line let args' = sanitizeEnd args case findCmd cmd of [c] -> case cBody c of ExprArg body -> Just (Command \l fp -> (body args' (l,cmdLen+1) fp)) 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 -> do (fpLen,fp,expr) <- extractFilePath args' Just (Command \l fp' -> do let col = cmdLen + fpLen + 1 hm <- expandHome fp body hm expr (l,col) fp') [] -> 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) -> (length a + 2, a, drop 1 b)) . break (== q) in case ipt of "" -> Nothing '\'':rest -> Just $ quoted '\'' rest '"':rest -> Just $ quoted '"' rest _ -> let (a,b) = break isSpace ipt in if null a then Nothing else Just (length a, a, b) moduleInfoCmd :: Bool -> String -> REPL () moduleInfoCmd isFile name | isFile = showInfo =<< liftModuleCmd (M.getFileDependencies name) | otherwise = case parseModName name of Just m -> showInfo =<< liftModuleCmd (M.getModuleDependencies m) Nothing -> rPutStrLn "Invalid module name." where showInfo (p,fi) = do rPutStr "{ \"source\": " case p of M.InFile f -> rPutStrLn (show f) M.InMem l _ -> rPutStrLn ("{ \"internal\": " ++ show l ++ " }") rPutStrLn (", \"fingerprint\": \"0x" ++ fingerprintHexString (M.fiFingerprint fi) ++ "\"") let depList f x ys = do rPutStr (", " ++ show (x :: String) ++ ":") case ys of [] -> rPutStrLn " []" i : is -> do rPutStrLn "" rPutStrLn (" [ " ++ f i) mapM_ (\j -> rPutStrLn (" , " ++ f j)) is rPutStrLn " ]" depList show "includes" (Set.toList (M.fiIncludeDeps fi)) depList (show . show . pp) "imports" (Set.toList (M.fiImportDeps fi)) depList show "foreign" (Set.toList (M.fiForeignDeps fi)) rPutStrLn "}" cryptol-3.0.0/src/Cryptol/REPL/Help.hs0000644000000000000000000003043107346545000015611 0ustar0000000000000000{-# Language BlockArguments #-} {-# Language OverloadedStrings #-} {-# Language RecordWildCards #-} module Cryptol.REPL.Help (helpForNamed) where import Data.Text (Text) import qualified Data.Text as Text import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe(fromMaybe) import Data.List(intersperse) import Control.Monad(when,guard,unless,msum,mplus) import Cryptol.Utils.PP import Cryptol.Utils.Ident(OrigName(..),identIsNormal) import qualified Cryptol.Parser.AST as P import qualified Cryptol.ModuleSystem as M import qualified Cryptol.ModuleSystem.Name as M import qualified Cryptol.ModuleSystem.NamingEnv as M import qualified Cryptol.ModuleSystem.Env as M import qualified Cryptol.ModuleSystem.Interface as M import qualified Cryptol.ModuleSystem.Renamer.Error as M (ModKind(..)) import qualified Cryptol.TypeCheck.AST as T import Cryptol.TypeCheck.PP(emptyNameMap,ppWithNames) import Cryptol.REPL.Monad helpForNamed :: P.PName -> REPL () helpForNamed qname = do fe <- getFocusedEnv let params = M.mctxParams fe env = M.mctxDecls fe rnEnv = M.mctxNames fe disp = M.mctxNameDisp fe vNames = M.lookupListNS M.NSValue qname rnEnv tNames = M.lookupListNS M.NSType qname rnEnv mNames = M.lookupListNS M.NSModule qname rnEnv let helps = map (showTypeHelp params env disp) tNames ++ map (showValHelp params env disp qname) vNames ++ map (showModHelp env disp) mNames separ = rPutStrLn " ---------" sequence_ (intersperse separ helps) when (null (vNames ++ tNames ++ mNames)) $ rPrint $ "Undefined name:" <+> pp qname noInfo :: NameDisp -> M.Name -> REPL () noInfo nameEnv name = case M.nameInfo name of M.GlobalName _ og -> rPrint (runDoc nameEnv ("Name defined in module" <+> pp (ogModule og))) M.LocalName {} -> rPutStrLn "// No documentation is available." -- | Show help for something in the module namespace. showModHelp :: M.IfaceDecls -> NameDisp -> M.Name -> REPL () showModHelp env nameEnv name = fromMaybe (noInfo nameEnv name) $ msum [ attempt M.ifModules showModuleHelp , attempt M.ifFunctors showFunctorHelp , attempt M.ifSignatures showSigHelp ] where attempt :: (M.IfaceDecls -> Map M.Name a) -> (M.IfaceDecls -> NameDisp -> M.Name -> a -> REPL ()) -> Maybe (REPL ()) attempt inMap doShow = do th <- Map.lookup name (inMap env) pure (doShow env nameEnv name th) showModuleHelp :: M.IfaceDecls -> NameDisp -> M.Name -> M.IfaceNames M.Name -> REPL () showModuleHelp env _nameEnv name info = showSummary M.AModule name (M.ifsDoc info) (ifaceSummary env info) ifaceSummary :: M.IfaceDecls -> M.IfaceNames M.Name -> ModSummary ifaceSummary env info = foldr addName emptySummary (Set.toList (M.ifsPublic info)) where addName x ns = fromMaybe ns $ msum [ addT <$> msum [fromTS, fromNT, fromAT] , addV <$> fromD , addM <$> msum [ fromM, fromS, fromF ] ] where addT (k,d) = ns { msTypes = T.ModTParam { T.mtpName = x , T.mtpKind = k , T.mtpDoc = d } : msTypes ns } addV (t,d,f) = ns { msVals = T.ModVParam { T.mvpName = x , T.mvpType = t , T.mvpDoc = d , T.mvpFixity = f } : msVals ns } addM (k,d)= ns { msMods = (x, k, d) : msMods ns } fromTS = do def <- Map.lookup x (M.ifTySyns env) pure (T.kindOf def, T.tsDoc def) fromNT = do def <- Map.lookup x (M.ifNewtypes env) pure (T.kindOf def, T.ntDoc def) fromAT = do def <- Map.lookup x (M.ifAbstractTypes env) pure (T.kindOf def, T.atDoc def) fromD = do def <- Map.lookup x (M.ifDecls env) pure (M.ifDeclSig def, M.ifDeclDoc def, M.ifDeclFixity def) fromM = do def <- Map.lookup x (M.ifModules env) pure (M.AModule, M.ifsDoc def) fromF = do def <- Map.lookup x (M.ifFunctors env) pure (M.AFunctor, M.ifsDoc (M.ifNames def)) fromS = do def <- Map.lookup x (M.ifSignatures env) pure (M.ASignature, T.mpnDoc def) showFunctorHelp :: M.IfaceDecls -> NameDisp -> M.Name -> M.IfaceG M.Name -> REPL () showFunctorHelp _env _nameEnv name info = showSummary M.AFunctor name (M.ifsDoc ns) summary where ns = M.ifNames info summary = (ifaceSummary (M.ifDefines info) ns) { msParams = [ (T.mpName p, T.mpIface p) | p <- Map.elems (M.ifParams info) ] } showSigHelp :: M.IfaceDecls -> NameDisp -> M.Name -> T.ModParamNames -> REPL () showSigHelp _env _nameEnv name info = showSummary M.ASignature name (T.mpnDoc info) emptySummary { msTypes = Map.elems (T.mpnTypes info) , msVals = Map.elems (T.mpnFuns info) , msConstraints = map P.thing (T.mpnConstraints info) } -------------------------------------------------------------------------------- data ModSummary = ModSummary { msParams :: [(P.Ident, P.ImpName M.Name)] , msConstraints :: [T.Prop] , msTypes :: [T.ModTParam] , msVals :: [T.ModVParam] , msMods :: [ (M.Name, M.ModKind, Maybe Text) ] } emptySummary :: ModSummary emptySummary = ModSummary { msParams = [] , msConstraints = [] , msTypes = [] , msVals = [] , msMods = [] } showSummary :: M.ModKind -> M.Name -> Maybe Text -> ModSummary -> REPL () showSummary k name doc info = do rPutStrLn "" rPrint $ runDoc disp case k of M.AModule -> vcat [ "Module" <+> pp name <+> "exports:" , indent 2 $ vcat [ ppTPs, ppFPs ] ] M.ASignature -> vcat [ "Interface" <+> pp name <+> "requires:" , indent 2 $ vcat [ ppTPs, ppCtrs, ppFPs ] ] M.AFunctor -> vcat [ "Parameterized module" <+> pp name <+> "requires:" , indent 2 $ ppPs , " ", "and exports:" , indent 2 $ vcat [ ppTPs, ppFPs ] ] doShowDocString doc where -- qualifying stuff is too noisy disp = NameDisp \_ -> Just UnQualified withMaybeNest mb x = case mb of Nothing -> x Just d -> vcat [x, indent 2 d] withDoc mb = withMaybeNest (pp <$> mb) withFix mb = withMaybeNest (text . ppFixity <$> mb) ppMany xs = case xs of [] -> mempty _ -> vcat (" " : xs) ppPs = ppMany (map ppP (msParams info)) ppP (x,y) | identIsNormal x = pp x <+> ": interface" <+> pp y | otherwise = "(anonymous parameter)" ppTPs = ppMany (map ppTP (msTypes info)) ppTP x = withDoc (T.mtpDoc x) $ hsep ["type", pp (T.mtpName x), ":", pp (T.mtpKind x)] ppCtrs = ppMany (map pp (msConstraints info)) ppFPs = ppMany (map ppFP (msVals info)) ppFP x = withFix (T.mvpFixity x) $ withDoc (T.mvpDoc x) $ hsep [pp (T.mvpName x), ":" <+> pp (T.mvpType x) ] -------------------------------------------------------------------------------- showTypeHelp :: M.ModContextParams -> M.IfaceDecls -> NameDisp -> T.Name -> REPL () showTypeHelp ctxparams env nameEnv name = fromMaybe (noInfo nameEnv name) $ msum [ fromTySyn, fromPrimType, fromNewtype, fromTyParam ] where fromTySyn = do ts <- msum [ Map.lookup name (M.ifTySyns env) , Map.lookup name (T.mpnTySyn (M.modContextParamNames ctxparams)) ] 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 $ indent 4 $ backticks (ppWithNames ns example) <+> "requires:" $$ indent 2 (vcat rs) doShowFix (T.atFixitiy a) doShowDocString (T.atDoc a) allParamNames = case ctxparams of M.NoParams -> mempty M.FunctorParams fparams -> Map.unions [ (\x -> (Just p,x)) <$> T.mpnTypes (T.mpParameters ps) | (p, ps) <- Map.toList fparams ] M.InterfaceParams ps -> (\x -> (Nothing ,x)) <$> T.mpnTypes ps fromTyParam = do (x,p) <- Map.lookup name allParamNames pure do rPutStrLn "" case x of Just src -> doShowParameterSource src Nothing -> pure () let ty = "type" <+> pp name <+> ":" <+> pp (T.mtpKind p) rPrint (runDoc nameEnv (indent 4 ty)) doShowDocString (T.mtpDoc p) doShowTyHelp :: NameDisp -> Doc -> Maybe Text -> REPL () doShowTyHelp nameEnv decl doc = do rPutStrLn "" rPrint (runDoc nameEnv (nest 4 decl)) doShowDocString doc showValHelp :: M.ModContextParams -> M.IfaceDecls -> NameDisp -> P.PName -> T.Name -> REPL () showValHelp ctxparams 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 = [] rPrint $ runDoc nameEnv $ indent 4 $ hsep $ property ++ [pp qname, colon, pp (ifDeclSig)] doShowFix $ ifDeclFixity `mplus` (guard ifDeclInfix >> return P.defaultFixity) doShowDocString ifDeclDoc fromNewtype = do _ <- Map.lookup name (M.ifNewtypes env) return $ return () allParamNames = case ctxparams of M.NoParams -> mempty M.FunctorParams fparams -> Map.unions [ (\x -> (Just p,x)) <$> T.mpnFuns (T.mpParameters ps) | (p, ps) <- Map.toList fparams ] M.InterfaceParams ps -> (\x -> (Nothing,x)) <$> T.mpnFuns ps fromParameter = do (x,p) <- Map.lookup name allParamNames pure do rPutStrLn "" case x of Just src -> doShowParameterSource src Nothing -> pure () let ty = pp name <+> ":" <+> pp (T.mvpType p) rPrint (runDoc nameEnv (indent 4 ty)) doShowFix (T.mvpFixity p) doShowDocString (T.mvpDoc p) doShowParameterSource :: P.Ident -> REPL () doShowParameterSource i = do rPutStrLn (Text.unpack msg) rPutStrLn "" where msg | identIsNormal i = "Provided by module parameter " <> P.identText i <> "." | otherwise = "Provided by `parameters` declaration." doShowDocString :: Maybe Text -> REPL () doShowDocString doc = case doc of Nothing -> pure () Just d -> rPutStrLn ('\n' : Text.unpack d) ppFixity :: T.Fixity -> String ppFixity f = "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." doShowFix :: Maybe T.Fixity -> REPL () doShowFix fx = case fx of Just f -> rPutStrLn ('\n' : ppFixity f) Nothing -> return () cryptol-3.0.0/src/Cryptol/REPL/Monad.hs0000644000000000000000000011252507346545000015764 0ustar0000000000000000-- | -- Module : Cryptol.REPL.Monad -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} 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 , getCallStacks , getTCSolver , resetTCSolver , uniqify, freshName , whenDebug , getEvalOptsAction , getPPValOpts , getExprNames , getTypeNames , getPropertyNames , getModNames , LoadedModule(..), getLoadedMod, setLoadedMod, clearLoadedMod , setEditPath, getEditPath, clearEditPath , setSearchPath, prependSearchPath , getPrompt , shouldContinue , unlessBatch , asBatch , validEvalContext , updateREPLTitle , setUpdateREPLTitle , withRandomGen , setRandomGen , getRandomGen -- ** Config Options , EnvVal(..) , OptionDescr(..) , setUser, getUser, getKnownUser, tryGetUser , userOptions , userOptionsWithAliases , getUserSatNum , getUserShowProverStats , getUserProverValidate , parsePPFloatFormat , parseFieldOrder , getProverConfig , parseSearchPath -- ** Configurable Output , getPutStr , getLogger , setPutStr -- ** Smoke Test , smokeTest , Smoke(..) ) where import Cryptol.REPL.Trie import Cryptol.Eval (EvalErrorEx, Unsupported, WordTooWide,EvalOpts(..)) 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.TypeCheck.Solver.SMT as SMT 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 (SatNum(..)) import Cryptol.Symbolic.SBV (SBVPortfolioException) import Cryptol.Symbolic.What4 (W4Exception) import qualified Cryptol.Symbolic.SBV as SBV (proverNames, setupProver, defaultProver, SBVProverConfig) import qualified Cryptol.Symbolic.What4 as W4 (proverNames, setupProver, W4ProverConfig) import Control.Monad (ap,unless,when) import Control.Monad.Base import qualified Control.Monad.Catch as Ex import Control.Monad.IO.Class import Control.Monad.Trans.Control import Data.Char (isSpace, toLower) import Data.IORef (IORef,newIORef,readIORef,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 System.FilePath (splitSearchPath, searchPathSeparator) 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 (SBVException) import qualified System.Random.TF as TF 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 , eCallStacks :: Bool , eUpdateTitle :: REPL () -- ^ Execute this every time we load a module. -- This is used to change the title of terminal when loading a module. , eProverConfig :: Either SBV.SBVProverConfig W4.W4ProverConfig , eTCConfig :: T.SolverConfig -- ^ Solver configuration to be used for typechecking , eTCSolver :: Maybe SMT.Solver -- ^ Solver instance to be used for typechecking , eTCSolverRestarts :: !Int -- ^ Counts how many times we've restarted the solver. -- Used as a kind of id for the current solver, which helps avoid -- a race condition where the callback of a dead solver runs after -- a new one has been started. , eRandomGen :: TF.TFGen -- ^ Random number generator for things like QC and dumpTests } -- | Initial, empty environment. defaultRW :: Bool -> Bool -> Logger -> IO RW defaultRW isBatch callStacks l = do env <- M.initialModuleEnv rng <- TF.newTFGen let searchPath = M.meSearchPath env let solverConfig = T.defaultSolverConfig searchPath return RW { eLoadedMod = Nothing , eEditFile = Nothing , eContinue = True , eIsBatch = isBatch , eModuleEnv = env , eUserEnv = mkUserEnv userOptions , eLogger = l , eCallStacks = callStacks , eUpdateTitle = return () , eProverConfig = Left SBV.defaultProver , eTCConfig = solverConfig , eTCSolver = Nothing , eTCSolverRestarts = 0 , eRandomGen = rng } -- | Build up the prompt for the REPL. mkPrompt :: RW -> String mkPrompt rw | eIsBatch rw = "" | detailedPrompt = withEdit ++ "> " | otherwise = modLn ++ "> " where detailedPrompt = id False modLn = case lName =<< eLoadedMod rw of Nothing -> show (pp I.preludeName) Just m | M.isLoadedParamMod m loaded -> modName ++ "(parameterized)" | M.isLoadedInterface m loaded -> modName ++ "(interface)" | otherwise -> modName where modName = pretty m loaded = M.meLoadedModules (eModuleEnv rw) 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 -> Bool -> Logger -> REPL a -> IO a runREPL isBatch callStacks l m = do Ex.bracket (newIORef =<< defaultRW isBatch callStacks l) (unREPL resetTCSolver) (unREPL m) instance Functor REPL where {-# INLINE fmap #-} fmap f m = REPL (\ ref -> fmap f (unREPL m ref)) instance Applicative REPL where {-# INLINE pure #-} pure x = REPL (\_ -> pure x) {-# INLINE (<*>) #-} (<*>) = ap instance Monad REPL where {-# INLINE return #-} return = pure {-# 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) instance Ex.MonadThrow REPL where throwM e = liftIO $ X.throwIO e instance Ex.MonadCatch REPL where catch op handler = control $ \runInBase -> Ex.catch (runInBase op) (runInBase . handler) instance Ex.MonadMask REPL where mask op = REPL $ \ref -> Ex.mask $ \u -> unREPL (op (q u)) ref where q u (REPL b) = REPL (\ref -> u (b ref)) uninterruptibleMask op = REPL $ \ref -> Ex.uninterruptibleMask $ \u -> unREPL (op (q u)) ref where q u (REPL b) = REPL (\ref -> u (b ref)) generalBracket acq rls op = control $ \runInBase -> Ex.generalBracket (runInBase acq) (\saved -> \e -> runInBase (restoreM saved >>= \a -> rls a e)) (\saved -> runInBase (restoreM saved >>= op)) -- Exceptions ------------------------------------------------------------------ -- | REPL exceptions. data REPLException = ParseError ParseError | FileNotFound FilePath | DirectoryNotFound FilePath | NoPatError [Error] | NoIncludeError [IncludeError] | EvalError EvalErrorEx | TooWide WordTooWide | Unsupported Unsupported | ModuleSystemError NameDisp M.ModuleError | EvalPolyError T.Schema | InstantiationsNotFound T.Schema | TypeNotTestable T.Type | EvalInParamModule [T.TParam] [M.Name] | SBVError String | SBVException SBVException | SBVPortfolioException SBVPortfolioException | W4Exception W4Exception 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 Unsupported e -> pp e TooWide e -> pp e EvalPolyError s -> text "Cannot evaluate polymorphic value." $$ text "Type:" <+> pp s InstantiationsNotFound s -> text "Cannot find instantiations for some type variables." $$ text "Type:" <+> pp s TypeNotTestable t -> text "The expression is not of a testable type." $$ text "Type:" <+> pp t EvalInParamModule as xs -> nest 2 $ vsep $ [ text "Expression depends on definitions from a parameterized module:" ] ++ map pp as ++ map pp xs SBVError s -> text "SBV error:" $$ text s SBVException e -> text "SBV exception:" $$ text (show e) SBVPortfolioException e -> text "SBV exception:" $$ text (show e) W4Exception e -> text "What4 exception:" $$ text (show e) -- | 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 `X.catch` rethrowTooWide `X.catch` rethrowUnsupported where run = do a <- m return $! a rethrow :: EvalErrorEx -> IO a rethrow exn = X.throwIO (EvalError exn) rethrowTooWide :: WordTooWide -> IO a rethrowTooWide exn = X.throwIO (TooWide exn) rethrowUnsupported :: Unsupported -> IO a rethrowUnsupported exn = X.throwIO (Unsupported 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 -> atomicModifyIORef ref (\x -> (f x, ()))) -- | Construct the prompt for the current environment. getPrompt :: REPL String getPrompt = mkPrompt `fmap` getRW getCallStacks :: REPL Bool getCallStacks = eCallStacks <$> getRW -- This assumes that we are not starting solvers in parallel, otherwise -- there are a bunch of race conditions here. getTCSolver :: REPL SMT.Solver getTCSolver = do rw <- getRW case eTCSolver rw of Just s -> return s Nothing -> do ref <- REPL (\ref -> pure ref) let now = eTCSolverRestarts rw + 1 upd new = if eTCSolverRestarts new == now then new { eTCSolver = Nothing } else new onExit = atomicModifyIORef ref (\s -> (upd s, ())) s <- io (SMT.startSolver onExit (eTCConfig rw)) modifyRW_ (\rw' -> rw'{ eTCSolver = Just s , eTCSolverRestarts = now }) return s resetTCSolver :: REPL () resetTCSolver = do mtc <- eTCSolver <$> getRW case mtc of Nothing -> return () Just s -> do io (SMT.stopSolver s) modifyRW_ (\rw -> rw{ eTCSolver = Nothing }) -- Get the setting we should use for displaying values. getPPValOpts :: REPL PPOpts getPPValOpts = do base <- getKnownUser "base" ascii <- getKnownUser "ascii" infLength <- getKnownUser "infLength" fpBase <- getKnownUser "fpBase" fpFmtTxt <- getKnownUser "fpFormat" fieldOrder <- getKnownUser "fieldOrder" let fpFmt = case parsePPFloatFormat fpFmtTxt of Just f -> f Nothing -> panic "getPPOpts" [ "Failed to parse fp-format" ] return PPOpts { useBase = base , useAscii = ascii , useInfLength = infLength , useFPBase = fpBase , useFPFormat = fpFmt , useFieldOrder = fieldOrder } getEvalOptsAction :: REPL (IO EvalOpts) getEvalOptsAction = REPL $ \rwRef -> pure $ do ppOpts <- unREPL getPPValOpts rwRef l <- unREPL getLogger rwRef return EvalOpts { evalPPOpts = ppOpts, evalLogger = l } 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 } setUserDirect "path" (EnvString (renderSearchPath path)) prependSearchPath :: [FilePath] -> REPL () prependSearchPath path = do me <- getModuleEnv let path' = path ++ M.meSearchPath me setModuleEnv $ me { M.meSearchPath = path' } setUserDirect "path" (EnvString (renderSearchPath path')) getProverConfig :: REPL (Either SBV.SBVProverConfig W4.W4ProverConfig) getProverConfig = eProverConfig <$> getRW 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 -- | 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) badTs = T.tyParams ds badName nm bs = case M.nameInfo nm of -- XXX: Changes if focusing on nested modules M.GlobalName _ I.OrigName { ogModule = I.TopModule m } | M.isLoadedParamMod m (M.meLoadedModules me) -> Set.insert nm bs | M.isLoadedInterface m (M.meLoadedModules me) -> Set.insert nm bs _ -> bs unless (Set.null bad && Set.null badTs) $ raise (EvalInParamModule (Set.toList badTs) (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.ModContext getFocusedEnv = M.focusedEnv <$> getModuleEnv -- | Get visible variable names. -- This is used for command line completition. getExprNames :: REPL [String] getExprNames = do fNames <- M.mctxNames <$> getFocusedEnv return (map (show . pp) (Map.keys (M.namespaceMap M.NSValue fNames))) -- | Get visible type signature names. -- This is used for command line completition. getTypeNames :: REPL [String] getTypeNames = do fNames <- M.mctxNames <$> getFocusedEnv return (map (show . pp) (Map.keys (M.namespaceMap M.NSType fNames))) -- | Return a list of property names, sorted by position in the file. getPropertyNames :: REPL ([(M.Name,M.IfaceDecl)],NameDisp) getPropertyNames = do fe <- getFocusedEnv let xs = M.ifDecls (M.mctxDecls fe) ps = sortBy (comparing (from . M.nameLoc . fst)) [ (x,d) | (x,d) <- Map.toList xs, T.PragmaProperty `elem` M.ifDeclPragmas d ] return (ps, M.mctxNameDisp fe) 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 }) getRandomGen :: REPL TF.TFGen getRandomGen = eRandomGen <$> getRW setRandomGen :: TF.TFGen -> REPL () setRandomGen rng = modifyRW_ (\s -> s { eRandomGen = rng }) withRandomGen :: (TF.TFGen -> REPL (a, TF.TFGen)) -> REPL a withRandomGen repl = do g <- getRandomGen (result, g') <- repl g setRandomGen g' pure result -- | 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.GlobalName s og -> M.liftSupply (M.mkDeclared (M.nameNamespace name) (I.ogModule og) s (M.nameIdent name) (M.nameFixity name) (M.nameLoc name)) M.LocalName {} -> 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.NSValue mpath sys i Nothing emptyRange) where mpath = M.TopModule I.interactiveName parseSearchPath :: String -> [String] parseSearchPath path = 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 renderSearchPath :: [String] -> String renderSearchPath pathSegs = path #if defined(mingw32_HOST_OS) || defined(__MINGW32__) -- Windows paths search from end to beginning where path = intercalate [searchPathSeparator] (reverse pathSegs) #else where path = intercalate [searchPathSeparator] pathSegs #endif -- 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 userOptionsWithAliases 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) <- 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"] setUserDirect :: String -> EnvVal -> REPL () setUserDirect optName val = do modifyRW_ (\rw -> rw { eUserEnv = Map.insert optName val (eUserEnv rw) }) 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" instance IsEnvVal FieldOrder where fromEnvVal x = case x of EnvString s | Just o <- parseFieldOrder s -> o _ -> badIsEnv "display` or `canonical" badIsEnv :: String -> a badIsEnv x = panic "fromEnvVal" [ "[REPL] Expected a `" ++ x ++ "` value." ] getUserShowProverStats :: REPL Bool getUserShowProverStats = getKnownUser "proverStats" getUserProverValidate :: REPL Bool getUserProverValidate = getKnownUser "proverValidate" -- 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 -> REPL (Maybe String, [String]) noCheck :: Checker noCheck _ = return (Nothing, []) noWarns :: Maybe String -> REPL (Maybe String, [String]) noWarns mb = return (mb, []) data OptionDescr = OptionDescr { optName :: String , optAliases :: [String] , optDefault :: EnvVal , optCheck :: Checker , optHelp :: String , optEff :: EnvVal -> REPL () } simpleOpt :: String -> [String] -> EnvVal -> Checker -> String -> OptionDescr simpleOpt optName optAliases optDefault optCheck optHelp = OptionDescr { optEff = \ _ -> return (), .. } userOptionsWithAliases :: OptionMap userOptionsWithAliases = foldl insert userOptions (leaves userOptions) where insert m d = foldl (\m' n -> insertTrie n d m') m (optAliases d) 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" ["inf-length"] (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" ["sat-num"] (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" ["warn-defaulting"] (EnvBool False) noCheck "Choose whether to display warnings when defaulting." , simpleOpt "warnShadowing" ["warn-shadowing"] (EnvBool True) noCheck "Choose whether to display warnings when shadowing symbols." , simpleOpt "warnPrefixAssoc" ["warn-prefix-assoc"] (EnvBool True) noCheck "Choose whether to display warnings when expression association has changed due to new prefix operator fixities." , simpleOpt "warnUninterp" ["warn-uninterp"] (EnvBool True) noCheck "Choose whether to issue a warning when uninterpreted functions are used to implement primitives in the symbolic simulator." , simpleOpt "warnNonExhaustiveConstraintGuards" ["warn-nonexhaustive-constraintguards"] (EnvBool True) noCheck "Choose whether to issue a warning when a use of constraint guards is not determined to be exhaustive." , simpleOpt "smtFile" ["smt-file"] (EnvString "-") noCheck "The file to use for SMT-Lib scripts (for debugging or offline proving).\nUse \"-\" for stdout." , OptionDescr "path" [] (EnvString "") noCheck "The search path for finding named Cryptol modules." $ \case EnvString path -> do let segs = parseSearchPath path me <- getModuleEnv setModuleEnv me { M.meSearchPath = segs } _ -> return () , OptionDescr "monoBinds" ["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 "tcSolver" ["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 modifyRW_ (\rw -> rw { eTCConfig = (eTCConfig rw) { T.solverPath = prog , T.solverArgs = args }}) resetTCSolver _ -> return () , OptionDescr "tcDebug" ["tc-debug"] (EnvNum 0) noCheck (unlines [ "Enable type-checker debugging output:" , " * 0 no debug output" , " * 1 show type-checker debug info" , " * >1 show type-checker debug info and interactions with SMT solver"]) $ \case EnvNum n -> do changed <- modifyRW (\rw -> ( rw{ eTCConfig = (eTCConfig rw){ T.solverVerbose = n } } , n /= T.solverVerbose (eTCConfig rw) )) when changed resetTCSolver _ -> return () , OptionDescr "coreLint" ["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 "hashConsing" ["hash-consing"] (EnvBool True) noCheck "Enable hash-consing in the What4 symbolic backends." , simpleOpt "proverStats" ["prover-stats"] (EnvBool True) noCheck "Enable prover timing statistics." , simpleOpt "proverValidate" ["prover-validate"] (EnvBool False) noCheck "Validate :sat examples and :prove counter-examples for correctness." , simpleOpt "showExamples" ["show-examples"] (EnvBool True) noCheck "Print the (counter) example after :sat or :prove" , simpleOpt "fpBase" ["fp-base"] (EnvNum 16) checkBase "The base to display floating point numbers at (2, 8, 10, or 16)." , simpleOpt "fpFormat" ["fp-format"] (EnvString "free") checkPPFloatFormat $ unlines [ "Specifies the format to use when showing floating point numbers:" , " * free show using as many digits as needed" , " * free+exp like `free` but always show exponent" , " * .NUM show NUM (>=1) digits after floating point" , " * NUM show using NUM (>=1) significant digits" , " * NUM+exp like NUM but always show exponent" ] , simpleOpt "ignoreSafety" ["ignore-safety"] (EnvBool False) noCheck "Ignore safety predicates when performing :sat or :prove checks" , simpleOpt "fieldOrder" ["field-order"] (EnvString "display") checkFieldOrder $ unlines [ "The order that record fields are displayed in." , " * display try to match the order they were written in the source code" , " * canonical use a predictable, canonical order" ] , simpleOpt "timeMeasurementPeriod" ["time-measurement-period"] (EnvNum 10) checkTimeMeasurementPeriod $ unlines [ "The period of time in seconds to spend collecting measurements when" , " running :time." , "This is a lower bound and the actual time taken might be higher if the" , " evaluation takes a long time." ] , simpleOpt "timeQuiet" ["time-quiet"] (EnvBool False) noCheck "Suppress output of :time command and only bind result to `it`." ] parsePPFloatFormat :: String -> Maybe PPFloatFormat parsePPFloatFormat s = case s of "free" -> Just $ FloatFree AutoExponent "free+exp" -> Just $ FloatFree ForceExponent '.' : xs -> FloatFrac <$> readMaybe xs _ | (as,res) <- break (== '+') s , Just n <- readMaybe as , Just e <- case res of "+exp" -> Just ForceExponent "" -> Just AutoExponent _ -> Nothing -> Just (FloatFixed n e) _ -> Nothing checkPPFloatFormat :: Checker checkPPFloatFormat val = case val of EnvString s | Just _ <- parsePPFloatFormat s -> noWarns Nothing _ -> noWarns $ Just "Failed to parse `fp-format`" parseFieldOrder :: String -> Maybe FieldOrder parseFieldOrder "canonical" = Just CanonicalOrder parseFieldOrder "display" = Just DisplayOrder parseFieldOrder _ = Nothing checkFieldOrder :: Checker checkFieldOrder val = case val of EnvString s | Just _ <- parseFieldOrder s -> noWarns Nothing _ -> noWarns $ Just "Failed to parse field-order (expected one of \"canonical\" or \"display\")" -- | 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 (map toLower -> s) | s `elem` W4.proverNames -> io (W4.setupProver s) >>= \case Left msg -> noWarns (Just msg) Right (ws, cfg) -> do modifyRW_ (\rw -> rw{ eProverConfig = Right cfg }) return (Nothing, ws) | s `elem` SBV.proverNames -> io (SBV.setupProver s) >>= \case Left msg -> noWarns (Just msg) Right (ws, cfg) -> do modifyRW_ (\rw -> rw{ eProverConfig = Left cfg }) return (Nothing, ws) | otherwise -> noWarns $ Just $ "Prover must be " ++ proverListString _ -> noWarns $ Just "unable to parse a value for prover" allProvers :: [String] allProvers = SBV.proverNames ++ W4.proverNames proverListString :: String proverListString = concatMap (++ ", ") (init allProvers) ++ "or " ++ last allProvers 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" ] checkTimeMeasurementPeriod :: Checker checkTimeMeasurementPeriod (EnvNum n) | n >= 1 = noWarns Nothing | otherwise = noWarns $ Just "timeMeasurementPeriod must be a positive integer" checkTimeMeasurementPeriod _ = noWarns $ Just "unable to parse value for timeMeasurementPeriod" -- 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-3.0.0/src/Cryptol/REPL/Trie.hs0000644000000000000000000000346707346545000015635 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 Data.Char (toLower) 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, forcing the key value to lower case. -- 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) (toLower 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 (toLower 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 (toLower 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-3.0.0/src/Cryptol/SHA.hs0000644000000000000000000006104207346545000014574 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, FlexibleInstances #-} -- |Pure implementations of the SHA suite of hash functions. The implementation -- is basically an unoptimized translation of FIPS 180-2 into Haskell. If you're -- looking for performance, you probably won't find it here. module Cryptol.SHA ( SHA256State(..), SHA512State(..) , SHA256Block(..), SHA512Block(..) -- * Raw SHA block functions , processSHA512Block , processSHA256Block , initialSHA224State , initialSHA256State , initialSHA384State , initialSHA512State -- * Internal routines included for testing , toBigEndianSBS, fromBigEndianSBS , calc_k , padSHA1, padSHA512 , padSHA1Chunks, padSHA512Chunks ) where import Data.Bits import Data.ByteString.Lazy(ByteString) import Data.Word (Word32, Word64) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString as SBS -- -------------------------------------------------------------------------- -- -- State Definitions and Initial States -- -- -------------------------------------------------------------------------- data SHA256State = SHA256S !Word32 !Word32 !Word32 !Word32 !Word32 !Word32 !Word32 !Word32 initialSHA224State :: SHA256State initialSHA224State = SHA256S 0xc1059ed8 0x367cd507 0x3070dd17 0xf70e5939 0xffc00b31 0x68581511 0x64f98fa7 0xbefa4fa4 initialSHA256State :: SHA256State initialSHA256State = SHA256S 0x6a09e667 0xbb67ae85 0x3c6ef372 0xa54ff53a 0x510e527f 0x9b05688c 0x1f83d9ab 0x5be0cd19 data SHA512State = SHA512S !Word64 !Word64 !Word64 !Word64 !Word64 !Word64 !Word64 !Word64 initialSHA384State :: SHA512State initialSHA384State = SHA512S 0xcbbb9d5dc1059ed8 0x629a292a367cd507 0x9159015a3070dd17 0x152fecd8f70e5939 0x67332667ffc00b31 0x8eb44a8768581511 0xdb0c2e0d64f98fa7 0x47b5481dbefa4fa4 initialSHA512State :: SHA512State initialSHA512State = SHA512S 0x6a09e667f3bcc908 0xbb67ae8584caa73b 0x3c6ef372fe94f82b 0xa54ff53a5f1d36f1 0x510e527fade682d1 0x9b05688c2b3e6c1f 0x1f83d9abfb41bd6b 0x5be0cd19137e2179 -- -------------------------------------------------------------------------- -- -- Padding -- -- -------------------------------------------------------------------------- padSHA1 :: ByteString -> ByteString padSHA1 = generic_pad 448 512 64 padSHA1Chunks :: Int -> [SBS.ByteString] padSHA1Chunks = generic_pad_chunks 448 512 64 padSHA512 :: ByteString -> ByteString padSHA512 = generic_pad 896 1024 128 padSHA512Chunks :: Int -> [SBS.ByteString] padSHA512Chunks = generic_pad_chunks 896 1024 128 generic_pad :: Word64 -> Word64 -> Int -> ByteString -> ByteString generic_pad a b lSize bs = BS.fromChunks $! go 0 chunks where chunks = BS.toChunks bs -- Generates the padded ByteString at the same time it computes the length -- of input. If the length is computed before the computation of the hash, it -- will break the lazy evaluation of the input and no longer run in constant -- memory space. go !len [] = generic_pad_chunks a b lSize len go !len (c:cs) = c : go (len + SBS.length c) cs generic_pad_chunks :: Word64 -> Word64 -> Int -> Int -> [SBS.ByteString] generic_pad_chunks a b lSize len = let lenBits = fromIntegral $ len * 8 k = calc_k a b lenBits -- INVARIANT: k is necessarily > 0, and (k + 1) is a multiple of 8. kBytes = (k + 1) `div` 8 nZeroBytes = fromIntegral $! kBytes - 1 padLength = toBigEndianSBS lSize lenBits in [SBS.singleton 0x80, SBS.replicate nZeroBytes 0, padLength] -- Given a, b, and l, calculate the smallest k such that (l + 1 + k) mod b = a. calc_k :: Word64 -> Word64 -> Word64 -> Word64 calc_k a b l = if r <= -1 then fromIntegral r + b else fromIntegral r where r = toInteger a - toInteger l `mod` toInteger b - 1 toBigEndianSBS :: (Integral a, Bits a) => Int -> a -> SBS.ByteString toBigEndianSBS s val = SBS.pack $ map getBits [s - 8, s - 16 .. 0] where getBits x = fromIntegral $ (val `shiftR` x) .&. 0xFF fromBigEndianSBS :: (Integral a, Bits a) => SBS.ByteString -> a fromBigEndianSBS = SBS.foldl (\ acc x -> (acc `shiftL` 8) + fromIntegral x) 0 -- -------------------------------------------------------------------------- -- -- SHA Functions -- -- -------------------------------------------------------------------------- {-# SPECIALIZE ch :: Word32 -> Word32 -> Word32 -> Word32 #-} {-# SPECIALIZE ch :: Word64 -> Word64 -> Word64 -> Word64 #-} ch :: Bits a => a -> a -> a -> a ch x y z = (x .&. y) `xor` (complement x .&. z) {-# SPECIALIZE maj :: Word32 -> Word32 -> Word32 -> Word32 #-} {-# SPECIALIZE maj :: Word64 -> Word64 -> Word64 -> Word64 #-} maj :: Bits a => a -> a -> a -> a maj x y z = (x .&. (y .|. z)) .|. (y .&. z) -- note: -- the original functions is (x & y) ^ (x & z) ^ (y & z) -- if you fire off truth tables, this is equivalent to -- (x & y) | (x & z) | (y & z) -- which you can the use distribution on: -- (x & (y | z)) | (y & z) -- which saves us one operation. bsig256_0 :: Word32 -> Word32 bsig256_0 x = rotateR x 2 `xor` rotateR x 13 `xor` rotateR x 22 bsig256_1 :: Word32 -> Word32 bsig256_1 x = rotateR x 6 `xor` rotateR x 11 `xor` rotateR x 25 lsig256_0 :: Word32 -> Word32 lsig256_0 x = rotateR x 7 `xor` rotateR x 18 `xor` shiftR x 3 lsig256_1 :: Word32 -> Word32 lsig256_1 x = rotateR x 17 `xor` rotateR x 19 `xor` shiftR x 10 bsig512_0 :: Word64 -> Word64 bsig512_0 x = rotateR x 28 `xor` rotateR x 34 `xor` rotateR x 39 bsig512_1 :: Word64 -> Word64 bsig512_1 x = rotateR x 14 `xor` rotateR x 18 `xor` rotateR x 41 lsig512_0 :: Word64 -> Word64 lsig512_0 x = rotateR x 1 `xor` rotateR x 8 `xor` shiftR x 7 lsig512_1 :: Word64 -> Word64 lsig512_1 x = rotateR x 19 `xor` rotateR x 61 `xor` shiftR x 6 -- -------------------------------------------------------------------------- -- -- Message Schedules -- -- -------------------------------------------------------------------------- data SHA256Block = SHA256Block !Word32 !Word32 !Word32 !Word32 !Word32 -- 00-04 !Word32 !Word32 !Word32 !Word32 !Word32 -- 05-09 !Word32 !Word32 !Word32 !Word32 !Word32 -- 10-14 !Word32 data SHA256Sched = SHA256Sched !Word32 !Word32 !Word32 !Word32 !Word32 -- 00-04 !Word32 !Word32 !Word32 !Word32 !Word32 -- 05-09 !Word32 !Word32 !Word32 !Word32 !Word32 -- 10-14 !Word32 !Word32 !Word32 !Word32 !Word32 -- 15-19 !Word32 !Word32 !Word32 !Word32 !Word32 -- 20-24 !Word32 !Word32 !Word32 !Word32 !Word32 -- 25-29 !Word32 !Word32 !Word32 !Word32 !Word32 -- 30-34 !Word32 !Word32 !Word32 !Word32 !Word32 -- 35-39 !Word32 !Word32 !Word32 !Word32 !Word32 -- 40-44 !Word32 !Word32 !Word32 !Word32 !Word32 -- 45-49 !Word32 !Word32 !Word32 !Word32 !Word32 -- 50-54 !Word32 !Word32 !Word32 !Word32 !Word32 -- 55-59 !Word32 !Word32 !Word32 !Word32 -- 60-63 getSHA256Sched :: SHA256Block -> SHA256Sched getSHA256Sched (SHA256Block w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 w10 w11 w12 w13 w14 w15) = let w16 = lsig256_1 w14 + w09 + lsig256_0 w01 + w00 w17 = lsig256_1 w15 + w10 + lsig256_0 w02 + w01 w18 = lsig256_1 w16 + w11 + lsig256_0 w03 + w02 w19 = lsig256_1 w17 + w12 + lsig256_0 w04 + w03 w20 = lsig256_1 w18 + w13 + lsig256_0 w05 + w04 w21 = lsig256_1 w19 + w14 + lsig256_0 w06 + w05 w22 = lsig256_1 w20 + w15 + lsig256_0 w07 + w06 w23 = lsig256_1 w21 + w16 + lsig256_0 w08 + w07 w24 = lsig256_1 w22 + w17 + lsig256_0 w09 + w08 w25 = lsig256_1 w23 + w18 + lsig256_0 w10 + w09 w26 = lsig256_1 w24 + w19 + lsig256_0 w11 + w10 w27 = lsig256_1 w25 + w20 + lsig256_0 w12 + w11 w28 = lsig256_1 w26 + w21 + lsig256_0 w13 + w12 w29 = lsig256_1 w27 + w22 + lsig256_0 w14 + w13 w30 = lsig256_1 w28 + w23 + lsig256_0 w15 + w14 w31 = lsig256_1 w29 + w24 + lsig256_0 w16 + w15 w32 = lsig256_1 w30 + w25 + lsig256_0 w17 + w16 w33 = lsig256_1 w31 + w26 + lsig256_0 w18 + w17 w34 = lsig256_1 w32 + w27 + lsig256_0 w19 + w18 w35 = lsig256_1 w33 + w28 + lsig256_0 w20 + w19 w36 = lsig256_1 w34 + w29 + lsig256_0 w21 + w20 w37 = lsig256_1 w35 + w30 + lsig256_0 w22 + w21 w38 = lsig256_1 w36 + w31 + lsig256_0 w23 + w22 w39 = lsig256_1 w37 + w32 + lsig256_0 w24 + w23 w40 = lsig256_1 w38 + w33 + lsig256_0 w25 + w24 w41 = lsig256_1 w39 + w34 + lsig256_0 w26 + w25 w42 = lsig256_1 w40 + w35 + lsig256_0 w27 + w26 w43 = lsig256_1 w41 + w36 + lsig256_0 w28 + w27 w44 = lsig256_1 w42 + w37 + lsig256_0 w29 + w28 w45 = lsig256_1 w43 + w38 + lsig256_0 w30 + w29 w46 = lsig256_1 w44 + w39 + lsig256_0 w31 + w30 w47 = lsig256_1 w45 + w40 + lsig256_0 w32 + w31 w48 = lsig256_1 w46 + w41 + lsig256_0 w33 + w32 w49 = lsig256_1 w47 + w42 + lsig256_0 w34 + w33 w50 = lsig256_1 w48 + w43 + lsig256_0 w35 + w34 w51 = lsig256_1 w49 + w44 + lsig256_0 w36 + w35 w52 = lsig256_1 w50 + w45 + lsig256_0 w37 + w36 w53 = lsig256_1 w51 + w46 + lsig256_0 w38 + w37 w54 = lsig256_1 w52 + w47 + lsig256_0 w39 + w38 w55 = lsig256_1 w53 + w48 + lsig256_0 w40 + w39 w56 = lsig256_1 w54 + w49 + lsig256_0 w41 + w40 w57 = lsig256_1 w55 + w50 + lsig256_0 w42 + w41 w58 = lsig256_1 w56 + w51 + lsig256_0 w43 + w42 w59 = lsig256_1 w57 + w52 + lsig256_0 w44 + w43 w60 = lsig256_1 w58 + w53 + lsig256_0 w45 + w44 w61 = lsig256_1 w59 + w54 + lsig256_0 w46 + w45 w62 = lsig256_1 w60 + w55 + lsig256_0 w47 + w46 w63 = lsig256_1 w61 + w56 + lsig256_0 w48 + w47 in SHA256Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 w10 w11 w12 w13 w14 w15 w16 w17 w18 w19 w20 w21 w22 w23 w24 w25 w26 w27 w28 w29 w30 w31 w32 w33 w34 w35 w36 w37 w38 w39 w40 w41 w42 w43 w44 w45 w46 w47 w48 w49 w50 w51 w52 w53 w54 w55 w56 w57 w58 w59 w60 w61 w62 w63 data SHA512Block = SHA512Block !Word64 !Word64 !Word64 !Word64 !Word64 -- 0- 4 !Word64 !Word64 !Word64 !Word64 !Word64 -- 5- 9 !Word64 !Word64 !Word64 !Word64 !Word64 -- 10-14 !Word64 -- 15 data SHA512Sched = SHA512Sched !Word64 !Word64 !Word64 !Word64 !Word64 -- 0- 4 !Word64 !Word64 !Word64 !Word64 !Word64 -- 5- 9 !Word64 !Word64 !Word64 !Word64 !Word64 -- 10-14 !Word64 !Word64 !Word64 !Word64 !Word64 -- 15-19 !Word64 !Word64 !Word64 !Word64 !Word64 -- 20-24 !Word64 !Word64 !Word64 !Word64 !Word64 -- 25-29 !Word64 !Word64 !Word64 !Word64 !Word64 -- 30-34 !Word64 !Word64 !Word64 !Word64 !Word64 -- 35-39 !Word64 !Word64 !Word64 !Word64 !Word64 -- 40-44 !Word64 !Word64 !Word64 !Word64 !Word64 -- 45-49 !Word64 !Word64 !Word64 !Word64 !Word64 -- 50-54 !Word64 !Word64 !Word64 !Word64 !Word64 -- 55-59 !Word64 !Word64 !Word64 !Word64 !Word64 -- 60-64 !Word64 !Word64 !Word64 !Word64 !Word64 -- 65-69 !Word64 !Word64 !Word64 !Word64 !Word64 -- 70-74 !Word64 !Word64 !Word64 !Word64 !Word64 -- 75-79 getSHA512Sched :: SHA512Block -> SHA512Sched getSHA512Sched (SHA512Block w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 w10 w11 w12 w13 w14 w15) = let w16 = lsig512_1 w14 + w09 + lsig512_0 w01 + w00 w17 = lsig512_1 w15 + w10 + lsig512_0 w02 + w01 w18 = lsig512_1 w16 + w11 + lsig512_0 w03 + w02 w19 = lsig512_1 w17 + w12 + lsig512_0 w04 + w03 w20 = lsig512_1 w18 + w13 + lsig512_0 w05 + w04 w21 = lsig512_1 w19 + w14 + lsig512_0 w06 + w05 w22 = lsig512_1 w20 + w15 + lsig512_0 w07 + w06 w23 = lsig512_1 w21 + w16 + lsig512_0 w08 + w07 w24 = lsig512_1 w22 + w17 + lsig512_0 w09 + w08 w25 = lsig512_1 w23 + w18 + lsig512_0 w10 + w09 w26 = lsig512_1 w24 + w19 + lsig512_0 w11 + w10 w27 = lsig512_1 w25 + w20 + lsig512_0 w12 + w11 w28 = lsig512_1 w26 + w21 + lsig512_0 w13 + w12 w29 = lsig512_1 w27 + w22 + lsig512_0 w14 + w13 w30 = lsig512_1 w28 + w23 + lsig512_0 w15 + w14 w31 = lsig512_1 w29 + w24 + lsig512_0 w16 + w15 w32 = lsig512_1 w30 + w25 + lsig512_0 w17 + w16 w33 = lsig512_1 w31 + w26 + lsig512_0 w18 + w17 w34 = lsig512_1 w32 + w27 + lsig512_0 w19 + w18 w35 = lsig512_1 w33 + w28 + lsig512_0 w20 + w19 w36 = lsig512_1 w34 + w29 + lsig512_0 w21 + w20 w37 = lsig512_1 w35 + w30 + lsig512_0 w22 + w21 w38 = lsig512_1 w36 + w31 + lsig512_0 w23 + w22 w39 = lsig512_1 w37 + w32 + lsig512_0 w24 + w23 w40 = lsig512_1 w38 + w33 + lsig512_0 w25 + w24 w41 = lsig512_1 w39 + w34 + lsig512_0 w26 + w25 w42 = lsig512_1 w40 + w35 + lsig512_0 w27 + w26 w43 = lsig512_1 w41 + w36 + lsig512_0 w28 + w27 w44 = lsig512_1 w42 + w37 + lsig512_0 w29 + w28 w45 = lsig512_1 w43 + w38 + lsig512_0 w30 + w29 w46 = lsig512_1 w44 + w39 + lsig512_0 w31 + w30 w47 = lsig512_1 w45 + w40 + lsig512_0 w32 + w31 w48 = lsig512_1 w46 + w41 + lsig512_0 w33 + w32 w49 = lsig512_1 w47 + w42 + lsig512_0 w34 + w33 w50 = lsig512_1 w48 + w43 + lsig512_0 w35 + w34 w51 = lsig512_1 w49 + w44 + lsig512_0 w36 + w35 w52 = lsig512_1 w50 + w45 + lsig512_0 w37 + w36 w53 = lsig512_1 w51 + w46 + lsig512_0 w38 + w37 w54 = lsig512_1 w52 + w47 + lsig512_0 w39 + w38 w55 = lsig512_1 w53 + w48 + lsig512_0 w40 + w39 w56 = lsig512_1 w54 + w49 + lsig512_0 w41 + w40 w57 = lsig512_1 w55 + w50 + lsig512_0 w42 + w41 w58 = lsig512_1 w56 + w51 + lsig512_0 w43 + w42 w59 = lsig512_1 w57 + w52 + lsig512_0 w44 + w43 w60 = lsig512_1 w58 + w53 + lsig512_0 w45 + w44 w61 = lsig512_1 w59 + w54 + lsig512_0 w46 + w45 w62 = lsig512_1 w60 + w55 + lsig512_0 w47 + w46 w63 = lsig512_1 w61 + w56 + lsig512_0 w48 + w47 w64 = lsig512_1 w62 + w57 + lsig512_0 w49 + w48 w65 = lsig512_1 w63 + w58 + lsig512_0 w50 + w49 w66 = lsig512_1 w64 + w59 + lsig512_0 w51 + w50 w67 = lsig512_1 w65 + w60 + lsig512_0 w52 + w51 w68 = lsig512_1 w66 + w61 + lsig512_0 w53 + w52 w69 = lsig512_1 w67 + w62 + lsig512_0 w54 + w53 w70 = lsig512_1 w68 + w63 + lsig512_0 w55 + w54 w71 = lsig512_1 w69 + w64 + lsig512_0 w56 + w55 w72 = lsig512_1 w70 + w65 + lsig512_0 w57 + w56 w73 = lsig512_1 w71 + w66 + lsig512_0 w58 + w57 w74 = lsig512_1 w72 + w67 + lsig512_0 w59 + w58 w75 = lsig512_1 w73 + w68 + lsig512_0 w60 + w59 w76 = lsig512_1 w74 + w69 + lsig512_0 w61 + w60 w77 = lsig512_1 w75 + w70 + lsig512_0 w62 + w61 w78 = lsig512_1 w76 + w71 + lsig512_0 w63 + w62 w79 = lsig512_1 w77 + w72 + lsig512_0 w64 + w63 in SHA512Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 w10 w11 w12 w13 w14 w15 w16 w17 w18 w19 w20 w21 w22 w23 w24 w25 w26 w27 w28 w29 w30 w31 w32 w33 w34 w35 w36 w37 w38 w39 w40 w41 w42 w43 w44 w45 w46 w47 w48 w49 w50 w51 w52 w53 w54 w55 w56 w57 w58 w59 w60 w61 w62 w63 w64 w65 w66 w67 w68 w69 w70 w71 w72 w73 w74 w75 w76 w77 w78 w79 -- -------------------------------------------------------------------------- -- -- SHA Block Processors -- -- -------------------------------------------------------------------------- processSHA256Block :: SHA256State -> SHA256Block -> SHA256State processSHA256Block !s00@(SHA256S a00 b00 c00 d00 e00 f00 g00 h00) !blk = do let (SHA256Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 w10 w11 w12 w13 w14 w15 w16 w17 w18 w19 w20 w21 w22 w23 w24 w25 w26 w27 w28 w29 w30 w31 w32 w33 w34 w35 w36 w37 w38 w39 w40 w41 w42 w43 w44 w45 w46 w47 w48 w49 w50 w51 w52 w53 w54 w55 w56 w57 w58 w59 w60 w61 w62 w63) = getSHA256Sched blk s01 = step256 s00 0x428a2f98 w00 s02 = step256 s01 0x71374491 w01 s03 = step256 s02 0xb5c0fbcf w02 s04 = step256 s03 0xe9b5dba5 w03 s05 = step256 s04 0x3956c25b w04 s06 = step256 s05 0x59f111f1 w05 s07 = step256 s06 0x923f82a4 w06 s08 = step256 s07 0xab1c5ed5 w07 s09 = step256 s08 0xd807aa98 w08 s10 = step256 s09 0x12835b01 w09 s11 = step256 s10 0x243185be w10 s12 = step256 s11 0x550c7dc3 w11 s13 = step256 s12 0x72be5d74 w12 s14 = step256 s13 0x80deb1fe w13 s15 = step256 s14 0x9bdc06a7 w14 s16 = step256 s15 0xc19bf174 w15 s17 = step256 s16 0xe49b69c1 w16 s18 = step256 s17 0xefbe4786 w17 s19 = step256 s18 0x0fc19dc6 w18 s20 = step256 s19 0x240ca1cc w19 s21 = step256 s20 0x2de92c6f w20 s22 = step256 s21 0x4a7484aa w21 s23 = step256 s22 0x5cb0a9dc w22 s24 = step256 s23 0x76f988da w23 s25 = step256 s24 0x983e5152 w24 s26 = step256 s25 0xa831c66d w25 s27 = step256 s26 0xb00327c8 w26 s28 = step256 s27 0xbf597fc7 w27 s29 = step256 s28 0xc6e00bf3 w28 s30 = step256 s29 0xd5a79147 w29 s31 = step256 s30 0x06ca6351 w30 s32 = step256 s31 0x14292967 w31 s33 = step256 s32 0x27b70a85 w32 s34 = step256 s33 0x2e1b2138 w33 s35 = step256 s34 0x4d2c6dfc w34 s36 = step256 s35 0x53380d13 w35 s37 = step256 s36 0x650a7354 w36 s38 = step256 s37 0x766a0abb w37 s39 = step256 s38 0x81c2c92e w38 s40 = step256 s39 0x92722c85 w39 s41 = step256 s40 0xa2bfe8a1 w40 s42 = step256 s41 0xa81a664b w41 s43 = step256 s42 0xc24b8b70 w42 s44 = step256 s43 0xc76c51a3 w43 s45 = step256 s44 0xd192e819 w44 s46 = step256 s45 0xd6990624 w45 s47 = step256 s46 0xf40e3585 w46 s48 = step256 s47 0x106aa070 w47 s49 = step256 s48 0x19a4c116 w48 s50 = step256 s49 0x1e376c08 w49 s51 = step256 s50 0x2748774c w50 s52 = step256 s51 0x34b0bcb5 w51 s53 = step256 s52 0x391c0cb3 w52 s54 = step256 s53 0x4ed8aa4a w53 s55 = step256 s54 0x5b9cca4f w54 s56 = step256 s55 0x682e6ff3 w55 s57 = step256 s56 0x748f82ee w56 s58 = step256 s57 0x78a5636f w57 s59 = step256 s58 0x84c87814 w58 s60 = step256 s59 0x8cc70208 w59 s61 = step256 s60 0x90befffa w60 s62 = step256 s61 0xa4506ceb w61 s63 = step256 s62 0xbef9a3f7 w62 s64 = step256 s63 0xc67178f2 w63 SHA256S a64 b64 c64 d64 e64 f64 g64 h64 = s64 in SHA256S (a00 + a64) (b00 + b64) (c00 + c64) (d00 + d64) (e00 + e64) (f00 + f64) (g00 + g64) (h00 + h64) {-# INLINE step256 #-} step256 :: SHA256State -> Word32 -> Word32 -> SHA256State step256 !(SHA256S a b c d e f g h) k w = SHA256S a' b' c' d' e' f' g' h' where t1 = h + bsig256_1 e + ch e f g + k + w t2 = bsig256_0 a + maj a b c h' = g g' = f f' = e e' = d + t1 d' = c c' = b b' = a a' = t1 + t2 processSHA512Block :: SHA512State -> SHA512Block -> SHA512State processSHA512Block !s00@(SHA512S a00 b00 c00 d00 e00 f00 g00 h00) !blk = let (SHA512Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 w10 w11 w12 w13 w14 w15 w16 w17 w18 w19 w20 w21 w22 w23 w24 w25 w26 w27 w28 w29 w30 w31 w32 w33 w34 w35 w36 w37 w38 w39 w40 w41 w42 w43 w44 w45 w46 w47 w48 w49 w50 w51 w52 w53 w54 w55 w56 w57 w58 w59 w60 w61 w62 w63 w64 w65 w66 w67 w68 w69 w70 w71 w72 w73 w74 w75 w76 w77 w78 w79) = getSHA512Sched blk s01 = step512 s00 0x428a2f98d728ae22 w00 s02 = step512 s01 0x7137449123ef65cd w01 s03 = step512 s02 0xb5c0fbcfec4d3b2f w02 s04 = step512 s03 0xe9b5dba58189dbbc w03 s05 = step512 s04 0x3956c25bf348b538 w04 s06 = step512 s05 0x59f111f1b605d019 w05 s07 = step512 s06 0x923f82a4af194f9b w06 s08 = step512 s07 0xab1c5ed5da6d8118 w07 s09 = step512 s08 0xd807aa98a3030242 w08 s10 = step512 s09 0x12835b0145706fbe w09 s11 = step512 s10 0x243185be4ee4b28c w10 s12 = step512 s11 0x550c7dc3d5ffb4e2 w11 s13 = step512 s12 0x72be5d74f27b896f w12 s14 = step512 s13 0x80deb1fe3b1696b1 w13 s15 = step512 s14 0x9bdc06a725c71235 w14 s16 = step512 s15 0xc19bf174cf692694 w15 s17 = step512 s16 0xe49b69c19ef14ad2 w16 s18 = step512 s17 0xefbe4786384f25e3 w17 s19 = step512 s18 0x0fc19dc68b8cd5b5 w18 s20 = step512 s19 0x240ca1cc77ac9c65 w19 s21 = step512 s20 0x2de92c6f592b0275 w20 s22 = step512 s21 0x4a7484aa6ea6e483 w21 s23 = step512 s22 0x5cb0a9dcbd41fbd4 w22 s24 = step512 s23 0x76f988da831153b5 w23 s25 = step512 s24 0x983e5152ee66dfab w24 s26 = step512 s25 0xa831c66d2db43210 w25 s27 = step512 s26 0xb00327c898fb213f w26 s28 = step512 s27 0xbf597fc7beef0ee4 w27 s29 = step512 s28 0xc6e00bf33da88fc2 w28 s30 = step512 s29 0xd5a79147930aa725 w29 s31 = step512 s30 0x06ca6351e003826f w30 s32 = step512 s31 0x142929670a0e6e70 w31 s33 = step512 s32 0x27b70a8546d22ffc w32 s34 = step512 s33 0x2e1b21385c26c926 w33 s35 = step512 s34 0x4d2c6dfc5ac42aed w34 s36 = step512 s35 0x53380d139d95b3df w35 s37 = step512 s36 0x650a73548baf63de w36 s38 = step512 s37 0x766a0abb3c77b2a8 w37 s39 = step512 s38 0x81c2c92e47edaee6 w38 s40 = step512 s39 0x92722c851482353b w39 s41 = step512 s40 0xa2bfe8a14cf10364 w40 s42 = step512 s41 0xa81a664bbc423001 w41 s43 = step512 s42 0xc24b8b70d0f89791 w42 s44 = step512 s43 0xc76c51a30654be30 w43 s45 = step512 s44 0xd192e819d6ef5218 w44 s46 = step512 s45 0xd69906245565a910 w45 s47 = step512 s46 0xf40e35855771202a w46 s48 = step512 s47 0x106aa07032bbd1b8 w47 s49 = step512 s48 0x19a4c116b8d2d0c8 w48 s50 = step512 s49 0x1e376c085141ab53 w49 s51 = step512 s50 0x2748774cdf8eeb99 w50 s52 = step512 s51 0x34b0bcb5e19b48a8 w51 s53 = step512 s52 0x391c0cb3c5c95a63 w52 s54 = step512 s53 0x4ed8aa4ae3418acb w53 s55 = step512 s54 0x5b9cca4f7763e373 w54 s56 = step512 s55 0x682e6ff3d6b2b8a3 w55 s57 = step512 s56 0x748f82ee5defb2fc w56 s58 = step512 s57 0x78a5636f43172f60 w57 s59 = step512 s58 0x84c87814a1f0ab72 w58 s60 = step512 s59 0x8cc702081a6439ec w59 s61 = step512 s60 0x90befffa23631e28 w60 s62 = step512 s61 0xa4506cebde82bde9 w61 s63 = step512 s62 0xbef9a3f7b2c67915 w62 s64 = step512 s63 0xc67178f2e372532b w63 s65 = step512 s64 0xca273eceea26619c w64 s66 = step512 s65 0xd186b8c721c0c207 w65 s67 = step512 s66 0xeada7dd6cde0eb1e w66 s68 = step512 s67 0xf57d4f7fee6ed178 w67 s69 = step512 s68 0x06f067aa72176fba w68 s70 = step512 s69 0x0a637dc5a2c898a6 w69 s71 = step512 s70 0x113f9804bef90dae w70 s72 = step512 s71 0x1b710b35131c471b w71 s73 = step512 s72 0x28db77f523047d84 w72 s74 = step512 s73 0x32caab7b40c72493 w73 s75 = step512 s74 0x3c9ebe0a15c9bebc w74 s76 = step512 s75 0x431d67c49c100d4c w75 s77 = step512 s76 0x4cc5d4becb3e42b6 w76 s78 = step512 s77 0x597f299cfc657e2a w77 s79 = step512 s78 0x5fcb6fab3ad6faec w78 s80 = step512 s79 0x6c44198c4a475817 w79 SHA512S a80 b80 c80 d80 e80 f80 g80 h80 = s80 in SHA512S (a00 + a80) (b00 + b80) (c00 + c80) (d00 + d80) (e00 + e80) (f00 + f80) (g00 + g80) (h00 + h80) {-# INLINE step512 #-} step512 :: SHA512State -> Word64 -> Word64 -> SHA512State step512 !(SHA512S a b c d e f g h) k w = SHA512S a' b' c' d' e' f' g' h' where t1 = h + bsig512_1 e + ch e f g + k + w t2 = bsig512_0 a + maj a b c h' = g g' = f f' = e e' = d + t1 d' = c c' = b b' = a a' = t1 + t2 cryptol-3.0.0/src/Cryptol/Symbolic.hs0000644000000000000000000003274607346545000015753 0ustar0000000000000000-- | -- Module : Cryptol.Symbolic -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} module Cryptol.Symbolic ( ProverCommand(..) , QueryType(..) , SatNum(..) , ProverResult(..) , ProverStats , CounterExampleType(..) -- * FinType , FinType(..) , finType , unFinType , predArgTypes -- * VarShape , VarShape(..) , varShapeToValue , freshVar , computeModel , FreshVarFns(..) , modelPred , varModelPred , varToExpr , flattenShape , flattenShapes ) where import Control.Monad (foldM) import Data.IORef(IORef) import Data.List (genericReplicate) import Data.Ratio import qualified LibBF as FP import Cryptol.Backend import Cryptol.Backend.FloatHelpers(bfValue) import Cryptol.Backend.SeqMap (finiteSeqMap) import Cryptol.Backend.WordValue (wordVal) import qualified Cryptol.Eval.Concrete as Concrete import Cryptol.Eval.Value import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Solver.InfNat import Cryptol.Eval.Type (TValue(..), evalType,tValTy,tNumValTy) import Cryptol.Utils.Ident (Ident,prelPrim,floatPrim) import Cryptol.Utils.RecordMap import Cryptol.Utils.Panic import Cryptol.Utils.PP import Prelude () import Prelude.Compat import Data.Time (NominalDiffTime) type SatResult = [(TValue, Expr, Concrete.Value)] data SatNum = AllSat | SomeSat Int deriving (Show) data QueryType = SatQuery SatNum | ProveQuery | SafetyQuery 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@ , pcIgnoreSafety :: Bool -- ^ Should we ignore safety predicates? } type ProverStats = NominalDiffTime -- | A @:prove@ command can fail either because some -- input causes the predicate to violate a safety assertion, -- or because the predicate returns false for some input. data CounterExampleType = SafetyViolation | PredicateFalsified -- | 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 [TValue] | CounterExample CounterExampleType SatResult | EmptyResult | ProverError String predArgTypes :: QueryType -> Schema -> Either String [FinType] predArgTypes qtype schema@(Forall ts ps ty) | null ts && null ps = case go <$> (evalType mempty ty) of Right (Just fts) -> Right fts _ | SafetyQuery <- qtype -> Left $ "Expected finite result type:\n" ++ show (pp schema) | otherwise -> 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 TVBit = Just [] go (TVFun ty1 ty2) = (:) <$> finType ty1 <*> go ty2 go tv | Just _ <- finType tv , SafetyQuery <- qtype = Just [] | otherwise = Nothing data FinType = FTBit | FTInteger | FTIntMod Integer | FTRational | FTFloat Integer Integer | FTSeq Integer FinType | FTTuple [FinType] | FTRecord (RecordMap Ident FinType) | FTNewtype Newtype [Either Nat' TValue] (RecordMap Ident FinType) finType :: TValue -> Maybe FinType finType ty = case ty of TVBit -> Just FTBit TVInteger -> Just FTInteger TVIntMod n -> Just (FTIntMod n) TVRational -> Just FTRational TVFloat e p -> Just (FTFloat e p) TVSeq n t -> FTSeq n <$> finType t TVTuple ts -> FTTuple <$> traverse finType ts TVRec fields -> FTRecord <$> traverse finType fields TVNewtype u ts body -> FTNewtype u ts <$> traverse finType body TVAbstract {} -> Nothing TVArray{} -> Nothing TVStream{} -> Nothing TVFun{} -> Nothing finTypeToType :: FinType -> Type finTypeToType fty = case fty of FTBit -> tBit FTInteger -> tInteger FTIntMod n -> tIntMod (tNum n) FTRational -> tRational FTFloat e p -> tFloat (tNum e) (tNum p) FTSeq l ety -> tSeq (tNum l) (finTypeToType ety) FTTuple ftys -> tTuple (finTypeToType <$> ftys) FTRecord fs -> tRec (finTypeToType <$> fs) FTNewtype u ts _ -> tNewtype u (map unArg ts) where unArg (Left Inf) = tInf unArg (Left (Nat n)) = tNum n unArg (Right t) = tValTy t unFinType :: FinType -> TValue unFinType fty = case fty of FTBit -> TVBit FTInteger -> TVInteger FTIntMod n -> TVIntMod n FTRational -> TVRational FTFloat e p -> TVFloat e p FTSeq n ety -> TVSeq n (unFinType ety) FTTuple ftys -> TVTuple (unFinType <$> ftys) FTRecord fs -> TVRec (unFinType <$> fs) FTNewtype u ts fs -> TVNewtype u ts (unFinType <$> fs) data VarShape sym = VarBit (SBit sym) | VarInteger (SInteger sym) | VarRational (SInteger sym) (SInteger sym) | VarFloat (SFloat sym) | VarWord (SWord sym) | VarFinSeq Integer [VarShape sym] | VarTuple [VarShape sym] | VarRecord (RecordMap Ident (VarShape sym)) ppVarShape :: Backend sym => sym -> VarShape sym -> Doc ppVarShape _sym (VarBit _b) = text "" ppVarShape _sym (VarInteger _i) = text "" ppVarShape _sym (VarFloat _f) = text "" ppVarShape _sym (VarRational _n _d) = text "" ppVarShape sym (VarWord w) = text " integer (wordLen sym w) <> text ">" ppVarShape sym (VarFinSeq _ xs) = ppList (map (ppVarShape sym) xs) ppVarShape sym (VarTuple xs) = ppTuple (map (ppVarShape sym) xs) ppVarShape sym (VarRecord fs) = ppRecord (map ppField (displayFields fs)) where ppField (f,v) = pp f <+> char '=' <+> ppVarShape sym v -- | Flatten structured shapes (like tuples and sequences), leaving only -- a sequence of variable shapes of base type. flattenShapes :: [VarShape sym] -> [VarShape sym] -> [VarShape sym] flattenShapes [] tl = tl flattenShapes (x:xs) tl = flattenShape x (flattenShapes xs tl) flattenShape :: VarShape sym -> [VarShape sym] -> [VarShape sym] flattenShape x tl = case x of VarBit{} -> x : tl VarInteger{} -> x : tl VarRational{} -> x : tl VarWord{} -> x : tl VarFloat{} -> x : tl VarFinSeq _ vs -> flattenShapes vs tl VarTuple vs -> flattenShapes vs tl VarRecord fs -> flattenShapes (recordElements fs) tl varShapeToValue :: Backend sym => sym -> VarShape sym -> GenValue sym varShapeToValue sym var = case var of VarBit b -> VBit b VarInteger i -> VInteger i VarRational n d -> VRational (SRational n d) VarWord w -> VWord (wordLen sym w) (wordVal w) VarFloat f -> VFloat f VarFinSeq n vs -> VSeq n (finiteSeqMap sym (map (pure . varShapeToValue sym) vs)) VarTuple vs -> VTuple (map (pure . varShapeToValue sym) vs) VarRecord fs -> VRecord (fmap (pure . varShapeToValue sym) fs) data FreshVarFns sym = FreshVarFns { freshBitVar :: IO (SBit sym) , freshWordVar :: Integer -> IO (SWord sym) , freshIntegerVar :: Maybe Integer -> Maybe Integer -> IO (SInteger sym) , freshFloatVar :: Integer -> Integer -> IO (SFloat sym) } freshVar :: Backend sym => FreshVarFns sym -> FinType -> IO (VarShape sym) freshVar fns tp = case tp of FTBit -> VarBit <$> freshBitVar fns FTInteger -> VarInteger <$> freshIntegerVar fns Nothing Nothing FTRational -> VarRational <$> freshIntegerVar fns Nothing Nothing <*> freshIntegerVar fns (Just 1) Nothing FTIntMod 0 -> panic "freshVariable" ["0 modulus not allowed"] FTIntMod m -> VarInteger <$> freshIntegerVar fns (Just 0) (Just (m-1)) FTFloat e p -> VarFloat <$> freshFloatVar fns e p FTSeq n FTBit -> VarWord <$> freshWordVar fns (toInteger n) FTSeq n t -> VarFinSeq (toInteger n) <$> sequence (genericReplicate n (freshVar fns t)) FTTuple ts -> VarTuple <$> mapM (freshVar fns) ts FTRecord fs -> VarRecord <$> traverse (freshVar fns) fs FTNewtype _ _ fs -> VarRecord <$> traverse (freshVar fns) fs computeModel :: PrimMap -> [FinType] -> [VarShape Concrete.Concrete] -> [(TValue, Expr, Concrete.Value)] computeModel _ [] [] = [] computeModel primMap (t:ts) (v:vs) = do let v' = varShapeToValue Concrete.Concrete v let t' = unFinType t let e = varToExpr primMap t v let zs = computeModel primMap ts vs in ((t',e,v'):zs) computeModel _ _ _ = panic "computeModel" ["type/value list mismatch"] modelPred :: Backend sym => sym -> [VarShape sym] -> [VarShape Concrete.Concrete] -> SEval sym (SBit sym) modelPred sym vs xs = do ps <- mapM (varModelPred sym) (zip vs xs) foldM (bitAnd sym) (bitLit sym True) ps varModelPred :: Backend sym => sym -> (VarShape sym, VarShape Concrete.Concrete) -> SEval sym (SBit sym) varModelPred sym vx = case vx of (VarBit b, VarBit blit) -> bitEq sym b (bitLit sym blit) (VarInteger i, VarInteger ilit) -> intEq sym i =<< integerLit sym ilit (VarRational n d, VarRational nlit dlit) -> do n' <- integerLit sym nlit d' <- integerLit sym dlit rationalEq sym (SRational n d) (SRational n' d') (VarWord w, VarWord (Concrete.BV len wlit)) -> wordEq sym w =<< wordLit sym len wlit (VarFloat f, VarFloat flit) -> fpLogicalEq sym f =<< fpExactLit sym flit (VarFinSeq _n vs, VarFinSeq _ xs) -> modelPred sym vs xs (VarTuple vs, VarTuple xs) -> modelPred sym vs xs (VarRecord vs, VarRecord xs) -> modelPred sym (recordElements vs) (recordElements xs) _ -> panic "varModelPred" ["variable shape mismatch!"] varToExpr :: PrimMap -> FinType -> VarShape Concrete.Concrete -> Expr varToExpr prims = go where prim n = ePrim prims (prelPrim n) go :: FinType -> VarShape Concrete.Concrete -> Expr go ty val = case (ty,val) of (FTNewtype nt ts tfs, VarRecord vfs) -> let res = zipRecords (\_lbl v t -> go t v) vfs tfs in case res of Left _ -> mismatch -- different fields Right efs -> let f = foldl (\x t -> ETApp x (tNumValTy t)) (EVar (ntConName nt)) ts in EApp f (ERec efs) (FTRecord tfs, VarRecord vfs) -> let res = zipRecords (\_lbl v t -> go t v) vfs tfs in case res of Left _ -> mismatch -- different fields Right efs -> ERec efs (FTTuple ts, VarTuple tvs) -> ETuple (zipWith go ts tvs) (FTBit, VarBit b) -> prim (if b then "True" else "False") (FTInteger, VarInteger i) -> -- This works uniformly for values of type Integer or Z n ETApp (ETApp (prim "number") (tNum i)) (finTypeToType ty) (FTIntMod _, VarInteger i) -> -- This works uniformly for values of type Integer or Z n ETApp (ETApp (prim "number") (tNum i)) (finTypeToType ty) (FTRational, VarRational n d) -> let n' = ETApp (ETApp (prim "number") (tNum n)) tInteger d' = ETApp (ETApp (prim "number") (tNum d)) tInteger in EApp (EApp (prim "ratio") n') d' (FTFloat e p, VarFloat f) -> floatToExpr prims e p (bfValue f) (FTSeq _ FTBit, VarWord (Concrete.BV _ v)) -> ETApp (ETApp (prim "number") (tNum v)) (finTypeToType ty) (FTSeq _ t, VarFinSeq _ svs) -> EList (map (go t) svs) (finTypeToType t) _ -> mismatch where mismatch = panic "Cryptol.Symbolic.varToExpr" ["type mismatch:" , show (pp (finTypeToType ty)) , show (ppVarShape Concrete.Concrete val) ] floatToExpr :: PrimMap -> Integer -> Integer -> FP.BigFloat -> Expr floatToExpr prims e p f = case FP.bfToRep f of FP.BFNaN -> mkP "fpNaN" FP.BFRep sign num -> case (sign,num) of (FP.Pos, FP.Zero) -> mkP "fpPosZero" (FP.Neg, FP.Zero) -> mkP "fpNegZero" (FP.Pos, FP.Inf) -> mkP "fpPosInf" (FP.Neg, FP.Inf) -> mkP "fpNegInf" (_, FP.Num m ex) -> let r = toRational m * (2 ^^ ex) in EProofApp $ ePrim prims (prelPrim "fraction") `ETApp` tNum (numerator r) `ETApp` tNum (denominator r) `ETApp` tNum (0 :: Int) `ETApp` tFloat (tNum e) (tNum p) where mkP n = EProofApp $ ePrim prims (floatPrim n) `ETApp` (tNum e) `ETApp` (tNum p) cryptol-3.0.0/src/Cryptol/Symbolic/0000755000000000000000000000000007346545000015403 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/Symbolic/SBV.hs0000644000000000000000000005273007346545000016400 0ustar0000000000000000-- | -- Module : Cryptol.Symbolic.SBV -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} module Cryptol.Symbolic.SBV ( SBVProverConfig , defaultProver , proverNames , setupProver , satProve , satProveOffline , SBVPortfolioException(..) ) where import Control.Applicative import Control.Concurrent.Async import Control.Concurrent.MVar import Control.Monad.IO.Class import Control.Monad (when, foldM, forM_) import Data.Maybe (fromMaybe) import qualified Data.Map as Map import qualified Control.Exception as X import System.Exit (ExitCode(ExitSuccess)) import LibBF(bfNaN) import qualified Data.SBV as SBV (sObserve, symbolicEnv) import qualified Data.SBV.Internals as SBV (SBV(..)) import qualified Data.SBV.Dynamic as SBV import Data.SBV (Timing(SaveTiming)) 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 qualified Cryptol.ModuleSystem.Name as M import Cryptol.Backend.SBV import qualified Cryptol.Backend.FloatHelpers as FH import qualified Cryptol.Eval as Eval import qualified Cryptol.Eval.Concrete as Concrete import qualified Cryptol.Eval.Value as Eval import Cryptol.Eval.SBV import Cryptol.Parser.Position (emptyRange) import Cryptol.Symbolic import Cryptol.TypeCheck.AST import Cryptol.Utils.Ident (preludeReferenceName, prelPrim, identText) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Logger(logPutStrLn) import Cryptol.Utils.RecordMap import Prelude () import Prelude.Compat doSBVEval :: MonadIO m => SBVEval a -> m (SBV.SVal, a) doSBVEval m = (liftIO $ Eval.runEval mempty (sbvEval m)) >>= \case SBVError err -> liftIO (X.throwIO err) SBVResult p x -> pure (p, x) -- External interface ---------------------------------------------------------- proverConfigs :: [(String, SBV.SMTConfig)] proverConfigs = [ ("cvc4" , SBV.cvc4 ) , ("cvc5" , SBV.cvc5 ) , ("yices" , SBV.yices ) , ("z3" , SBV.z3 ) , ("boolector", SBV.boolector) , ("mathsat" , SBV.mathSAT ) , ("abc" , SBV.abc ) , ("offline" , SBV.defaultSMTCfg ) , ("any" , SBV.defaultSMTCfg ) , ("sbv-cvc4" , SBV.cvc4 ) , ("sbv-cvc5" , SBV.cvc5 ) , ("sbv-yices" , SBV.yices ) , ("sbv-z3" , SBV.z3 ) , ("sbv-boolector", SBV.boolector) , ("sbv-mathsat" , SBV.mathSAT ) , ("sbv-abc" , SBV.abc ) , ("sbv-offline" , SBV.defaultSMTCfg ) , ("sbv-any" , SBV.defaultSMTCfg ) ] newtype SBVPortfolioException = SBVPortfolioException [Either X.SomeException (Maybe String,String)] instance Show SBVPortfolioException where show (SBVPortfolioException exs) = unlines ("All solvers in the portfolio failed!" : map f exs) where f (Left e) = X.displayException e f (Right (Nothing, msg)) = msg f (Right (Just nm, msg)) = nm ++ ": " ++ msg instance X.Exception SBVPortfolioException data SBVProverConfig = SBVPortfolio [SBV.SMTConfig] | SBVProverConfig SBV.SMTConfig defaultProver :: SBVProverConfig defaultProver = SBVProverConfig SBV.z3 -- | The names of all the solvers supported by SBV proverNames :: [String] proverNames = map fst proverConfigs setupProver :: String -> IO (Either String ([String], SBVProverConfig)) setupProver nm | nm `elem` ["any","sbv-any"] = #if MIN_VERSION_sbv(8,9,0) do ps <- SBV.getAvailableSolvers #else do ps <- SBV.sbvAvailableSolvers #endif case ps of [] -> pure (Left "SBV could not find any provers") _ -> let msg = "SBV found the following solvers: " ++ show (map (SBV.name . SBV.solver) ps) in pure (Right ([msg], SBVPortfolio ps)) -- special case, we search for two different yices binaries | nm `elem` ["yices","sbv-yices"] = tryCfgs SBV.yices ["yices-smt2", "yices_smt2"] | otherwise = case lookup nm proverConfigs of Just cfg -> tryCfgs cfg [] Nothing -> pure (Left ("unknown solver name: " ++ nm)) where tryCfgs cfg (e:es) = do let cfg' = cfg{ SBV.solver = (SBV.solver cfg){ SBV.executable = e } } ok <- SBV.sbvCheckSolverInstallation cfg' if ok then pure (Right ([], SBVProverConfig cfg')) else tryCfgs cfg es tryCfgs cfg [] = do ok <- SBV.sbvCheckSolverInstallation cfg pure (Right (ws ok, SBVProverConfig cfg)) ws ok = if ok then [] else notFound notFound = ["Warning: " ++ nm ++ " installation not found"] satSMTResults :: SBV.SatResult -> [SBV.SMTResult] satSMTResults (SBV.SatResult r) = [r] allSatSMTResults :: SBV.AllSatResult -> [SBV.SMTResult] #if MIN_VERSION_sbv(8,8,0) allSatSMTResults (SBV.AllSatResult {allSatResults = rs}) = rs #else allSatSMTResults (SBV.AllSatResult (_, _, _, rs)) = rs #endif thmSMTResults :: SBV.ThmResult -> [SBV.SMTResult] thmSMTResults (SBV.ThmResult r) = [r] proverError :: String -> M.ModuleCmd (Maybe String, ProverResult) proverError msg minp = return (Right ((Nothing, ProverError msg), M.minpModuleEnv minp), []) isFailedResult :: [SBV.SMTResult] -> Maybe String isFailedResult [] = Just "Solver returned no results!" isFailedResult (r:_) = case r of SBV.Unknown _cfg rsn -> Just ("Solver returned UNKNOWN " ++ show rsn) SBV.ProofError _ ms _ -> Just (unlines ("Solver error" : ms)) _ -> Nothing runSingleProver :: ProverCommand -> (String -> IO ()) -> SBV.SMTConfig -> (SBV.SMTConfig -> SBV.Symbolic SBV.SVal -> IO res) -> (res -> [SBV.SMTResult]) -> SBV.Symbolic SBV.SVal -> IO (Maybe String, [SBV.SMTResult]) runSingleProver ProverCommand{..} lPutStrLn prover callSolver processResult e = do when pcVerbose $ lPutStrLn $ "Trying proof with " ++ show (SBV.name (SBV.solver prover)) res <- callSolver prover e when pcVerbose $ lPutStrLn $ "Got result from " ++ show (SBV.name (SBV.solver prover)) return (Just (show (SBV.name (SBV.solver prover))), processResult res) runMultiProvers :: ProverCommand -> (String -> IO ()) -> [SBV.SMTConfig] -> (SBV.SMTConfig -> SBV.Symbolic SBV.SVal -> IO res) -> (res -> [SBV.SMTResult]) -> SBV.Symbolic SBV.SVal -> IO (Maybe String, [SBV.SMTResult]) runMultiProvers pc lPutStrLn provers callSolver processResult e = do as <- mapM async [ runSingleProver pc lPutStrLn p callSolver processResult e | p <- provers ] waitForResults [] as where waitForResults exs [] = X.throw (SBVPortfolioException exs) waitForResults exs as = do (winner, result) <- waitAnyCatch as let others = filter (/= winner) as case result of Left ex -> waitForResults (Left ex:exs) others Right r@(nm, rs) | Just msg <- isFailedResult rs -> waitForResults (Right (nm, msg) : exs) others | otherwise -> do forM_ others (\a -> X.throwTo (asyncThreadId a) ExitSuccess) return r -- | Select the appropriate solver or solvers from the given prover command, -- and invoke those solvers on the given symbolic value. runProver :: SBVProverConfig -> ProverCommand -> (String -> IO ()) -> SBV.Symbolic SBV.SVal -> IO (Maybe String, [SBV.SMTResult]) runProver proverConfig pc@ProverCommand{..} lPutStrLn x = do let mSatNum = case pcQueryType of SatQuery (SomeSat n) -> Just n SatQuery AllSat -> Nothing ProveQuery -> Nothing SafetyQuery -> Nothing case proverConfig of SBVPortfolio ps -> let ps' = [ p { SBV.transcript = pcSmtFile , SBV.timing = SaveTiming pcProverStats , SBV.verbose = pcVerbose , SBV.validateModel = pcValidate } | p <- ps ] in case pcQueryType of ProveQuery -> runMultiProvers pc lPutStrLn ps' SBV.proveWith thmSMTResults x SafetyQuery -> runMultiProvers pc lPutStrLn ps' SBV.proveWith thmSMTResults x SatQuery (SomeSat 1) -> runMultiProvers pc lPutStrLn ps' SBV.satWith satSMTResults x _ -> return (Nothing, [SBV.ProofError p [":sat with option prover=any requires option satNum=1"] Nothing | p <- ps]) SBVProverConfig p -> let p' = p { SBV.transcript = pcSmtFile , SBV.allSatMaxModelCount = mSatNum , SBV.timing = SaveTiming pcProverStats , SBV.verbose = pcVerbose , SBV.validateModel = pcValidate } in case pcQueryType of ProveQuery -> runSingleProver pc lPutStrLn p' SBV.proveWith thmSMTResults x SafetyQuery -> runSingleProver pc lPutStrLn p' SBV.proveWith thmSMTResults x SatQuery (SomeSat 1) -> runSingleProver pc lPutStrLn p' SBV.satWith satSMTResults x SatQuery _ -> runSingleProver pc lPutStrLn p' SBV.allSatWith allSatSMTResults x -- | Prepare a symbolic query by symbolically simulating the expression found in -- the @ProverQuery@. The result will either be an error or a list of the types -- of the symbolic inputs and the symbolic value to supply to the solver. -- -- Note that the difference between sat and prove queries is reflected later -- in `runProver` where we call different SBV methods depending on the mode, -- so we do _not_ negate the goal here. Moreover, assumptions are added -- using conjunction for sat queries and implication for prove queries. -- -- For safety properties, we want to add them as an additional goal -- when we do prove queries, and an additional assumption when we do -- sat queries. In both cases, the safety property is combined with -- the main goal via a conjunction. prepareQuery :: Eval.EvalOpts -> ProverCommand -> M.ModuleT IO (Either String ([FinType], SBV.Symbolic SBV.SVal)) prepareQuery evo ProverCommand{..} = do ds <- do (_mp, ent) <- M.loadModuleFrom True (M.FromModule preludeReferenceName) let m = tcTopEntityToModule ent let decls = mDecls m let nms = fst <$> Map.toList (M.ifDecls (M.ifDefines (M.genIface m))) let ds = Map.fromList [ (prelPrim (identText (M.nameIdent nm)), EWhere (EVar nm) decls) | nm <- nms ] pure ds modEnv <- M.getModuleEnv let extDgs = M.allDeclGroups modEnv ++ pcExtraDecls callStacks <- M.getCallStacks let ?callStacks = callStacks getEOpts <- M.getEvalOptsAction ntEnv <- M.getNewtypes -- The `addAsm` function is used to combine assumptions that -- arise from the types of symbolic variables (e.g. Z n values -- are assumed to be integers in the range `0 <= x < n`) with -- the main content of the query. We use conjunction or implication -- depending on the type of query. let addAsm = case pcQueryType of ProveQuery -> \x y -> SBV.svOr (SBV.svNot x) y SafetyQuery -> \x y -> SBV.svOr (SBV.svNot x) y SatQuery _ -> \x y -> SBV.svAnd x y case predArgTypes pcQueryType pcSchema of Left msg -> return (Left msg) Right ts -> M.io $ do when pcVerbose $ logPutStrLn (Eval.evalLogger evo) "Simulating..." pure $ Right $ (ts, do sbvState <- SBV.symbolicEnv stateMVar <- liftIO (newMVar sbvState) defRelsVar <- liftIO (newMVar SBV.svTrue) let sym = SBV stateMVar defRelsVar let tbl = primTable sym getEOpts let ?evalPrim = \i -> (Right <$> Map.lookup i tbl) <|> (Left <$> Map.lookup i ds) let ?range = emptyRange -- Compute the symbolic inputs, and any domain constraints needed -- according to their types. args <- map (pure . varShapeToValue sym) <$> liftIO (mapM (freshVar (sbvFreshFns sym)) ts) -- Run the main symbolic computation. First we populate the -- evaluation environment, then we compute the value, finally -- we apply it to the symbolic inputs. (safety,b) <- doSBVEval $ do env <- Eval.evalDecls sym extDgs =<< Eval.evalNewtypeDecls sym ntEnv mempty v <- Eval.evalExpr sym env pcExpr appliedVal <- foldM (Eval.fromVFun sym) v args case pcQueryType of SafetyQuery -> do Eval.forceValue appliedVal pure SBV.svTrue _ -> pure (Eval.fromVBit appliedVal) -- Ignore the safety condition if the flag is set and we are not -- doing a safety query let safety' = case pcQueryType of SafetyQuery -> safety _ | pcIgnoreSafety -> SBV.svTrue | otherwise -> safety -- "observe" the value of the safety predicate. This makes its value -- avaliable in the resulting model. SBV.sObserve "safety" (SBV.SBV safety' :: SBV.SBV Bool) -- read any definitional relations that were asserted defRels <- liftIO (readMVar defRelsVar) return (addAsm defRels (SBV.svAnd safety' b))) -- | Turn the SMT results from SBV into a @ProverResult@ that is ready for the Cryptol REPL. -- There may be more than one result if we made a multi-sat query. processResults :: ProverCommand -> [FinType] {- ^ Types of the symbolic inputs -} -> [SBV.SMTResult] {- ^ Results from the solver -} -> M.ModuleT IO ProverResult processResults ProverCommand{..} ts results = do let isSat = case pcQueryType of ProveQuery -> False SafetyQuery -> False SatQuery _ -> True prims <- M.getPrimMap case results of -- allSat can return more than one as long as -- they're satisfiable (SBV.Satisfiable {} : _) | isSat -> do tevss <- map snd <$> mapM (mkTevs prims) results return $ AllSatResult tevss -- prove should only have one counterexample [r@SBV.Satisfiable{}] -> do (safety, res) <- mkTevs prims r let cexType = if safety then PredicateFalsified else SafetyViolation return $ CounterExample cexType res -- 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) #if MIN_VERSION_sbv(10,0,0) where rshow | isSat = show . (SBV.AllSatResult False False False) -- sbv-10.0.0 removes the `allSatHasPrefixExistentials` field #elif MIN_VERSION_sbv(8,8,0) where rshow | isSat = show . (SBV.AllSatResult False False False False) #else where rshow | isSat = show . SBV.AllSatResult . (False,False,False,) #endif | otherwise = show . SBV.ThmResult . head where mkTevs prims result = do -- It's a bit fragile, but the value of the safety predicate seems -- to always be the first value in the model assignment list. let (safetyCV, cvs) = case SBV.getModelAssignment result of Right (_, (safetyCV' : cvs')) -> (safetyCV', cvs') _ -> error "processResults: SBV.getModelAssignment failure" safety = SBV.cvToBool safetyCV (vs, _) = parseValues ts cvs mdl = computeModel prims ts vs return (safety, mdl) -- | Execute a symbolic ':prove' or ':sat' command. -- -- This command returns a pair: the first element is the name of the -- solver that completes the given query (if any) along with the result -- of executing the query. satProve :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Maybe String, ProverResult) satProve proverCfg pc = protectStack proverError $ \minp -> M.runModuleM minp $ do evo <- liftIO (M.minpEvalOpts minp) let lPutStrLn = logPutStrLn (Eval.evalLogger evo) prepareQuery evo pc >>= \case Left msg -> return (Nothing, ProverError msg) Right (ts, q) -> do (firstProver, results) <- M.io (runProver proverCfg pc lPutStrLn q) esatexprs <- processResults pc ts results return (firstProver, esatexprs) -- | Execute a symbolic ':prove' or ':sat' command when the prover is -- set to offline. This only prepares the SMT input file for the -- solver and does not actually invoke the solver. -- -- This method returns either an error message or the text of -- the SMT input file corresponding to the given prover command. satProveOffline :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Either String String) satProveOffline _proverCfg pc@ProverCommand {..} = protectStack (\msg minp -> return (Right (Left msg, M.minpModuleEnv minp), [])) $ \minp -> M.runModuleM minp $ do let isSat = case pcQueryType of ProveQuery -> False SafetyQuery -> False SatQuery _ -> True #if MIN_VERSION_sbv(10,0,0) generateSMTBenchmark | isSat = SBV.generateSMTBenchmarkSat | otherwise = SBV.generateSMTBenchmarkProof #else generateSMTBenchmark = SBV.generateSMTBenchmark isSat #endif evo <- liftIO (M.minpEvalOpts minp) prepareQuery evo pc >>= \case Left msg -> return (Left msg) Right (_ts, q) -> Right <$> M.io (generateSMTBenchmark q) 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 -- | Given concrete values from the solver and a collection of finite types, -- reconstruct Cryptol concrete values, and return any unused solver -- values. parseValues :: [FinType] -> [SBV.CV] -> ([VarShape Concrete.Concrete], [SBV.CV]) parseValues [] cvs = ([], cvs) parseValues (t : ts) cvs = (v : vs, cvs'') where (v, cvs') = parseValue t cvs (vs, cvs'') = parseValues ts cvs' -- | Parse a single value of a finite type by consuming some number of -- solver values. The parsed Cryptol values is returned along with -- any solver values not consumed. parseValue :: FinType -> [SBV.CV] -> (VarShape Concrete.Concrete, [SBV.CV]) parseValue FTBit [] = panic "Cryptol.Symbolic.parseValue" [ "empty FTBit" ] parseValue FTBit (cv : cvs) = (VarBit (SBV.cvToBool cv), cvs) parseValue FTInteger cvs = case SBV.genParse SBV.KUnbounded cvs of Just (x, cvs') -> (VarInteger x, cvs') Nothing -> panic "Cryptol.Symbolic.parseValue" [ "no integer" ] parseValue (FTIntMod _) cvs = parseValue FTInteger cvs parseValue FTRational cvs = fromMaybe (panic "Cryptol.Symbolic.parseValue" ["no rational"]) $ do (n,cvs') <- SBV.genParse SBV.KUnbounded cvs (d,cvs'') <- SBV.genParse SBV.KUnbounded cvs' return (VarRational n d, cvs'') parseValue (FTSeq 0 FTBit) cvs = (VarWord (Concrete.mkBv 0 0), cvs) parseValue (FTSeq n FTBit) cvs = case SBV.genParse (SBV.KBounded False (fromInteger n)) cvs of Just (x, cvs') -> (VarWord (Concrete.mkBv (toInteger n) x), cvs') Nothing -> panic "Cryptol.Symbolic.parseValue" ["no bitvector"] parseValue (FTSeq n t) cvs = (VarFinSeq (toInteger n) vs, cvs') where (vs, cvs') = parseValues (replicate (fromInteger n) t) cvs parseValue (FTTuple ts) cvs = (VarTuple vs, cvs') where (vs, cvs') = parseValues ts cvs parseValue (FTRecord r) cvs = (VarRecord r', cvs') where (ns, ts) = unzip $ canonicalFields r (vs, cvs') = parseValues ts cvs fs = zip ns vs r' = recordFromFieldsWithDisplay (displayOrder r) fs parseValue (FTNewtype _ _ r) cvs = parseValue (FTRecord r) cvs parseValue (FTFloat e p) cvs = (VarFloat FH.BF { FH.bfValue = bfNaN , FH.bfExpWidth = e , FH.bfPrecWidth = p } , cvs ) -- XXX: NOT IMPLEMENTED freshBoundedInt :: SBV -> Maybe Integer -> Maybe Integer -> IO SBV.SVal freshBoundedInt sym lo hi = do x <- freshSInteger_ sym case lo of Just l -> addDefEqn sym (SBV.svLessEq (SBV.svInteger SBV.KUnbounded l) x) Nothing -> pure () case hi of Just h -> addDefEqn sym (SBV.svLessEq x (SBV.svInteger SBV.KUnbounded h)) Nothing -> pure () return x freshBitvector :: SBV -> Integer -> IO SBV.SVal freshBitvector sym w | w == 0 = pure (SBV.svInteger (SBV.KBounded False 0) 0) | otherwise = freshBV_ sym (fromInteger w) sbvFreshFns :: SBV -> FreshVarFns SBV sbvFreshFns sym = FreshVarFns { freshBitVar = freshSBool_ sym , freshWordVar = freshBitvector sym , freshIntegerVar = freshBoundedInt sym , freshFloatVar = \_ _ -> return () -- TODO } cryptol-3.0.0/src/Cryptol/Symbolic/What4.hs0000644000000000000000000006467007346545000016743 0ustar0000000000000000-- | -- Module : Cryptol.Symbolic.What4 -- Copyright : (c) 2013-2020 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} module Cryptol.Symbolic.What4 ( W4ProverConfig , defaultProver , proverNames , setupProver , satProve , satProveOffline , W4Exception(..) ) where import Control.Applicative import Control.Concurrent.Async import Control.Concurrent.MVar import Control.Monad.IO.Class import Control.Monad (when, foldM, forM_, void) import qualified Control.Exception as X import System.IO (Handle, IOMode(..), withFile) import Data.Time import Data.IORef import Data.List (intercalate, tails, inits) import Data.List.NonEmpty (NonEmpty(..)) import Data.Proxy import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import qualified Data.List.NonEmpty as NE import System.Exit 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 qualified Cryptol.ModuleSystem.Name as M import qualified Cryptol.Backend.FloatHelpers as FH import Cryptol.Backend.What4 import qualified Cryptol.Eval as Eval import qualified Cryptol.Eval.Concrete as Concrete import qualified Cryptol.Eval.Value as Eval import Cryptol.Eval.Type (TValue) import Cryptol.Eval.What4 import Cryptol.Parser.Position (emptyRange) import Cryptol.Symbolic import Cryptol.TypeCheck.AST import Cryptol.Utils.Logger(logPutStrLn,logPutStr,Logger) import Cryptol.Utils.Ident (preludeReferenceName, prelPrim, identText) import qualified What4.Config as W4 import qualified What4.Interface as W4 import qualified What4.Expr.Builder as W4 import qualified What4.Expr.GroundEval as W4 import qualified What4.SatResult as W4 import qualified What4.SFloat as W4 import qualified What4.SWord as SW import What4.Solver import qualified What4.Solver.Boolector as W4 import qualified What4.Solver.CVC4 as W4 import qualified What4.Solver.CVC5 as W4 import qualified What4.Solver.ExternalABC as W4 import qualified What4.Solver.Yices as W4 import qualified What4.Solver.Z3 as W4 import qualified What4.Solver.Adapter as W4 import qualified What4.Protocol.Online as W4 import qualified What4.Protocol.SMTLib2 as W4 import qualified What4.ProblemFeatures as W4 import qualified Data.BitVector.Sized as BV import Data.Parameterized.Nonce import Prelude () import Prelude.Compat data W4Exception = W4Ex X.SomeException | W4PortfolioFailure [ (Either X.SomeException (Maybe String, String)) ] instance Show W4Exception where show (W4Ex e) = X.displayException e show (W4PortfolioFailure exs) = unlines ("All solveres in the portfolio failed!":map f exs) where f (Left e) = X.displayException e f (Right (Nothing, msg)) = msg f (Right (Just nm, msg)) = nm ++ ": " ++ msg instance X.Exception W4Exception rethrowW4Exception :: IO a -> IO a rethrowW4Exception m = X.catchJust f m (X.throwIO . W4Ex) where f e | Just ( _ :: X.AsyncException) <- X.fromException e = Nothing | Just ( _ :: Eval.Unsupported) <- X.fromException e = Nothing | otherwise = Just e protectStack :: (String -> M.ModuleCmd a) -> M.ModuleCmd a -> M.ModuleCmd a protectStack mkErr cmd modEnv = rethrowW4Exception $ X.catchJust isOverflow (cmd modEnv) handler where isOverflow X.StackOverflow = Just () isOverflow _ = Nothing msg = "Symbolic evaluation failed to terminate." handler () = mkErr msg modEnv -- | Returns definitions, together with the value and it safety predicate. doW4Eval :: (W4.IsExprBuilder sym, MonadIO m) => sym -> W4Eval sym a -> m (W4.Pred sym, a) doW4Eval sym m = do res <- liftIO $ Eval.runEval mempty (w4Eval m sym) case res of W4Error err -> liftIO (X.throwIO err) W4Result p x -> pure (p,x) data AnAdapter = AnAdapter (forall st. SolverAdapter st) | forall s. W4.OnlineSolver s => AnOnlineAdapter String W4.ProblemFeatures [W4.ConfigDesc] (Proxy s) data W4ProverConfig = W4ProverConfig AnAdapter | W4OfflineConfig | W4Portfolio (NonEmpty AnAdapter) proverConfigs :: [(String, W4ProverConfig)] proverConfigs = [ ("w4-cvc4" , W4ProverConfig cvc4OnlineAdapter) , ("w4-cvc5" , W4ProverConfig cvc5OnlineAdapter) , ("w4-yices" , W4ProverConfig yicesOnlineAdapter) , ("w4-z3" , W4ProverConfig z3OnlineAdapter) , ("w4-boolector" , W4ProverConfig boolectorOnlineAdapter) , ("w4-abc" , W4ProverConfig (AnAdapter W4.externalABCAdapter)) , ("w4-offline" , W4OfflineConfig ) , ("w4-any" , allSolvers) ] z3OnlineAdapter :: AnAdapter z3OnlineAdapter = AnOnlineAdapter "Z3" W4.z3Features W4.z3Options (Proxy :: Proxy (W4.Writer W4.Z3)) yicesOnlineAdapter :: AnAdapter yicesOnlineAdapter = AnOnlineAdapter "Yices" W4.yicesDefaultFeatures W4.yicesOptions (Proxy :: Proxy W4.Connection) cvc4OnlineAdapter :: AnAdapter cvc4OnlineAdapter = AnOnlineAdapter "CVC4" W4.cvc4Features W4.cvc4Options (Proxy :: Proxy (W4.Writer W4.CVC4)) cvc5OnlineAdapter :: AnAdapter cvc5OnlineAdapter = AnOnlineAdapter "CVC5" W4.cvc5Features W4.cvc5Options (Proxy :: Proxy (W4.Writer W4.CVC5)) boolectorOnlineAdapter :: AnAdapter boolectorOnlineAdapter = AnOnlineAdapter "Boolector" W4.boolectorFeatures W4.boolectorOptions (Proxy :: Proxy (W4.Writer W4.Boolector)) allSolvers :: W4ProverConfig allSolvers = W4Portfolio $ z3OnlineAdapter :| [ cvc4OnlineAdapter , cvc5OnlineAdapter , boolectorOnlineAdapter , yicesOnlineAdapter , AnAdapter W4.externalABCAdapter ] defaultProver :: W4ProverConfig defaultProver = W4ProverConfig z3OnlineAdapter proverNames :: [String] proverNames = map fst proverConfigs setupProver :: String -> IO (Either String ([String], W4ProverConfig)) setupProver nm = rethrowW4Exception $ case lookup nm proverConfigs of Just cfg@(W4ProverConfig p) -> do st <- tryAdapter p let ws = case st of Nothing -> [] Just ex -> [ "Warning: solver interaction failed with " ++ nm, " " ++ show ex ] pure (Right (ws, cfg)) Just (W4Portfolio ps) -> filterAdapters (NE.toList ps) >>= \case [] -> pure (Left "What4 could not communicate with any provers!") (p:ps') -> let msg = "What4 found the following solvers: " ++ show (adapterNames (p:ps')) in pure (Right ([msg], W4Portfolio (p:|ps'))) Just W4OfflineConfig -> pure (Right ([], W4OfflineConfig)) Nothing -> pure (Left ("unknown solver name: " ++ nm)) where adapterNames [] = [] adapterNames (AnAdapter adpt : ps) = solver_adapter_name adpt : adapterNames ps adapterNames (AnOnlineAdapter n _ _ _ : ps) = n : adapterNames ps filterAdapters [] = pure [] filterAdapters (p:ps) = tryAdapter p >>= \case Just _err -> filterAdapters ps Nothing -> (p:) <$> filterAdapters ps tryAdapter :: AnAdapter -> IO (Maybe X.SomeException) tryAdapter (AnAdapter adpt) = do sym <- W4.newExprBuilder W4.FloatIEEERepr CryptolState globalNonceGenerator W4.extendConfig (W4.solver_adapter_config_options adpt) (W4.getConfiguration sym) W4.smokeTest sym adpt tryAdapter (AnOnlineAdapter _ fs opts (_ :: Proxy s)) = test `X.catch` (pure . Just) where test = do sym <- W4.newExprBuilder W4.FloatIEEERepr CryptolState globalNonceGenerator W4.extendConfig opts (W4.getConfiguration sym) (proc :: W4.SolverProcess GlobalNonceGenerator s) <- W4.startSolverProcess fs Nothing sym res <- W4.checkSatisfiable proc "smoke test" (W4.falsePred sym) case res of W4.Unsat () -> return () _ -> fail "smoke test failed, expected UNSAT!" void (W4.shutdownSolverProcess proc) return Nothing proverError :: String -> M.ModuleCmd (Maybe String, ProverResult) proverError msg minp = return (Right ((Nothing, ProverError msg), M.minpModuleEnv minp), []) data CryptolState t = CryptolState setupAdapterOptions :: W4ProverConfig -> W4.ExprBuilder t CryptolState fs -> IO () setupAdapterOptions cfg sym = case cfg of W4ProverConfig p -> setupAnAdapter p W4Portfolio ps -> mapM_ setupAnAdapter ps W4OfflineConfig -> return () where setupAnAdapter (AnAdapter adpt) = W4.extendConfig (W4.solver_adapter_config_options adpt) (W4.getConfiguration sym) setupAnAdapter (AnOnlineAdapter _n _fs opts _p) = W4.extendConfig opts (W4.getConfiguration sym) what4FreshFns :: W4.IsSymExprBuilder sym => sym -> FreshVarFns (What4 sym) what4FreshFns sym = FreshVarFns { freshBitVar = W4.freshConstant sym W4.emptySymbol W4.BaseBoolRepr , freshWordVar = SW.freshBV sym W4.emptySymbol , freshIntegerVar = W4.freshBoundedInt sym W4.emptySymbol , freshFloatVar = W4.fpFresh sym } -- | Simulate and manipulate query into a form suitable to be sent -- to a solver. prepareQuery :: W4.IsSymExprBuilder sym => What4 sym -> ProverCommand -> M.ModuleT IO (Either String ([FinType],[VarShape (What4 sym)],W4.Pred sym, W4.Pred sym) ) prepareQuery sym ProverCommand { .. } = do ntEnv <- M.getNewtypes case predArgTypes pcQueryType pcSchema of Left msg -> pure (Left msg) Right ts -> do args <- liftIO (mapM (freshVar (what4FreshFns (w4 sym))) ts) (safety,b) <- simulate ntEnv args liftIO do -- Ignore the safety condition if the flag is set let safety' = if pcIgnoreSafety then W4.truePred (w4 sym) else safety defs <- readMVar (w4defs sym) Right <$> case pcQueryType of ProveQuery -> do q <- W4.notPred (w4 sym) =<< W4.andPred (w4 sym) safety' b q' <- W4.andPred (w4 sym) defs q pure (ts,args,safety',q') SafetyQuery -> do q <- W4.notPred (w4 sym) safety q' <- W4.andPred (w4 sym) defs q pure (ts,args,safety,q') SatQuery _ -> do q <- W4.andPred (w4 sym) safety' b q' <- W4.andPred (w4 sym) defs q pure (ts,args,safety',q') where simulate ntEnv args = do let lPutStrLn = M.withLogger logPutStrLn when pcVerbose (lPutStrLn "Simulating...") ds <- do (_mp, ent) <- M.loadModuleFrom True (M.FromModule preludeReferenceName) let m = tcTopEntityToModule ent let decls = mDecls m let nms = fst <$> Map.toList (M.ifDecls (M.ifDefines (M.genIface m))) let ds = Map.fromList [ (prelPrim (identText (M.nameIdent nm)), EWhere (EVar nm) decls) | nm <- nms ] pure ds getEOpts <- M.getEvalOptsAction let tbl = primTable sym getEOpts let ?evalPrim = \i -> (Right <$> Map.lookup i tbl) <|> (Left <$> Map.lookup i ds) let ?range = emptyRange callStacks <- M.getCallStacks let ?callStacks = callStacks modEnv <- M.getModuleEnv let extDgs = M.allDeclGroups modEnv ++ pcExtraDecls doW4Eval (w4 sym) do env <- Eval.evalDecls sym extDgs =<< Eval.evalNewtypeDecls sym ntEnv mempty v <- Eval.evalExpr sym env pcExpr appliedVal <- foldM (Eval.fromVFun sym) v (map (pure . varShapeToValue sym) args) case pcQueryType of SafetyQuery -> do Eval.forceValue appliedVal pure (W4.truePred (w4 sym)) _ -> pure (Eval.fromVBit appliedVal) satProve :: W4ProverConfig -> Bool {- ^ hash consing -} -> Bool {- ^ warn on uninterpreted functions -} -> ProverCommand -> M.ModuleCmd (Maybe String, ProverResult) satProve solverCfg hashConsing warnUninterp pc@ProverCommand {..} = protectStack proverError \modIn -> M.runModuleM modIn do w4sym <- liftIO makeSym defVar <- liftIO (newMVar (W4.truePred w4sym)) funVar <- liftIO (newMVar mempty) uninterpWarnVar <- liftIO (newMVar mempty) let sym = What4 w4sym defVar funVar uninterpWarnVar logData <- M.withLogger doLog () start <- liftIO getCurrentTime query <- prepareQuery sym ProverCommand { .. } primMap <- M.getPrimMap when warnUninterp (M.withLogger printUninterpWarn =<< liftIO (readMVar uninterpWarnVar)) liftIO do result <- runProver sym logData primMap query end <- getCurrentTime writeIORef pcProverStats (diffUTCTime end start) return result where makeSym = do w4sym <- W4.newExprBuilder W4.FloatIEEERepr CryptolState globalNonceGenerator setupAdapterOptions solverCfg w4sym when hashConsing (W4.startCaching w4sym) pure w4sym doLog lg () = pure defaultLogData { logCallbackVerbose = \i msg -> when (i > 2) (logPutStrLn lg msg) , logReason = "solver query" } runProver sym logData primMap q = case q of Left msg -> pure (Nothing, ProverError msg) Right (ts,args,safety,query) -> case pcQueryType of ProveQuery -> singleQuery sym solverCfg pc primMap logData ts args (Just safety) query SafetyQuery -> singleQuery sym solverCfg pc primMap logData ts args (Just safety) query SatQuery num -> multiSATQuery sym solverCfg pc primMap logData ts args query num printUninterpWarn :: Logger -> Set Text -> IO () printUninterpWarn lg uninterpWarns = case Set.toList uninterpWarns of [] -> pure () [x] -> logPutStrLn lg ("[Warning] Uninterpreted functions used to represent " ++ Text.unpack x ++ " operations.") xs -> logPutStr lg $ unlines [ "[Warning] Uninterpreted functions used to represent the following operations:" , " " ++ intercalate ", " (map Text.unpack xs) ] satProveOffline :: Bool {- ^ hash consing -} -> Bool {- ^ warn on uninterpreted functions -} -> ProverCommand -> ((Handle -> IO ()) -> IO ()) -> M.ModuleCmd (Maybe String) satProveOffline hashConsing warnUninterp ProverCommand{ .. } outputContinuation = protectStack onError \modIn -> M.runModuleM modIn do w4sym <- liftIO makeSym defVar <- liftIO (newMVar (W4.truePred w4sym)) funVar <- liftIO (newMVar mempty) uninterpWarnVar <- liftIO (newMVar mempty) let sym = What4 w4sym defVar funVar uninterpWarnVar ok <- prepareQuery sym ProverCommand { .. } when warnUninterp (M.withLogger printUninterpWarn =<< liftIO (readMVar uninterpWarnVar)) liftIO case ok of Left msg -> return (Just msg) Right (_ts,_args,_safety,query) -> do outputContinuation (\hdl -> W4.writeZ3SMT2File w4sym hdl [query]) return Nothing where makeSym = do sym <- W4.newExprBuilder W4.FloatIEEERepr CryptolState globalNonceGenerator W4.extendConfig W4.z3Options (W4.getConfiguration sym) when hashConsing (W4.startCaching sym) pure sym onError msg minp = pure (Right (Just msg, M.minpModuleEnv minp), []) {- decSatNum :: SatNum -> SatNum decSatNum (SomeSat n) | n > 0 = SomeSat (n-1) decSatNum n = n -} multiSATQuery :: forall sym t fm. sym ~ W4.ExprBuilder t CryptolState fm => What4 sym -> W4ProverConfig -> ProverCommand -> PrimMap -> W4.LogData -> [FinType] -> [VarShape (What4 sym)] -> W4.Pred sym -> SatNum -> IO (Maybe String, ProverResult) multiSATQuery sym solverCfg pc primMap logData ts args query (SomeSat n) | n <= 1 = singleQuery sym solverCfg pc primMap logData ts args Nothing query multiSATQuery _sym W4OfflineConfig _pc _primMap _logData _ts _args _query _satNum = fail "What4 offline solver cannot be used for multi-SAT queries" multiSATQuery _sym (W4Portfolio _) _pc _primMap _logData _ts _args _query _satNum = fail "What4 portfolio solver cannot be used for multi-SAT queries" multiSATQuery _sym (W4ProverConfig (AnAdapter adpt)) _pc _primMap _logData _ts _args _query _satNum = fail ("Solver " ++ solver_adapter_name adpt ++ " does not support incremental solving and " ++ "cannot be used for multi-SAT queries.") multiSATQuery sym (W4ProverConfig (AnOnlineAdapter nm fs _opts (_ :: Proxy s))) ProverCommand{..} primMap _logData ts args query satNum0 = withMaybeFile pcSmtFile WriteMode $ \smtFileHdl -> X.bracket (W4.startSolverProcess fs smtFileHdl (w4 sym)) (void . W4.shutdownSolverProcess) (\ (proc :: W4.SolverProcess t s) -> do W4.assume (W4.solverConn proc) query res <- W4.checkAndGetModel proc "query" case res of W4.Unknown -> return (Just nm, ProverError "Solver returned UNKNOWN") W4.Unsat _ -> return (Just nm, ThmResult (map unFinType ts)) W4.Sat evalFn -> do xs <- mapM (varShapeToConcrete evalFn) args let mdl = computeModel primMap ts xs -- NB, we flatten these shapes to make sure that we can split -- our search across all of the atomic variables let vs = flattenShapes args [] let cs = flattenShapes xs [] mdls <- runMultiSat satNum0 $ do yield mdl computeMoreModels proc vs cs return (Just nm, AllSatResult mdls)) where -- This search procedure uses incremental solving and push/pop to split on the concrete -- values of variables, while also helping to prevent the accumulation of unhelpful -- lemmas in the solver state. This algorithm is basically taken from: -- http://theory.stanford.edu/%7Enikolaj/programmingz3.html#sec-blocking-evaluations computeMoreModels :: W4.SolverProcess t s -> [VarShape (What4 sym)] -> [VarShape Concrete.Concrete] -> MultiSat () computeMoreModels proc vs cs = -- Enumerate all the ways to split up the current model forM_ (computeSplits vs cs) $ \ (prefix, vi, ci, suffix) -> do -- open a new solver frame liftIO $ W4.push proc -- force the selected pair to be different liftIO $ W4.assume (W4.solverConn proc) =<< W4.notPred (w4 sym) =<< computeModelPred sym vi ci -- force the prefix values to be the same liftIO $ forM_ prefix $ \(v,c) -> W4.assume (W4.solverConn proc) =<< computeModelPred sym v c -- under these assumptions, find all the remaining models findMoreModels proc (vi:suffix) -- pop the current assumption frame liftIO $ W4.pop proc findMoreModels :: W4.SolverProcess t s -> [VarShape (What4 sym)] -> MultiSat () findMoreModels proc vs = -- see if our current assumptions are consistent do res <- liftIO (W4.checkAndGetModel proc "find model") case res of -- if the solver gets stuck, drop all the way out and stop search W4.Unknown -> done -- if our assumptions are already unsatisfiable, stop search and return W4.Unsat _ -> return () W4.Sat evalFn -> -- We found a model. Record it and then use it to split the remaining -- search variables some more. do xs <- liftIO (mapM (varShapeToConcrete evalFn) args) yield (computeModel primMap ts xs) cs <- liftIO (mapM (varShapeToConcrete evalFn) vs) computeMoreModels proc vs cs -- == Support operations for multi-SAT == type Models = [[(TValue, Expr, Concrete.Value)]] newtype MultiSat a = MultiSat { unMultiSat :: Models -> SatNum -> (a -> Models -> SatNum -> IO Models) -> IO Models } instance Functor MultiSat where fmap f m = MultiSat (\ms satNum k -> unMultiSat m ms satNum (k . f)) instance Applicative MultiSat where pure x = MultiSat (\ms satNum k -> k x ms satNum) mf <*> mx = mf >>= \f -> fmap f mx instance Monad MultiSat where m >>= f = MultiSat (\ms satNum k -> unMultiSat m ms satNum (\x ms' satNum' -> unMultiSat (f x) ms' satNum' k)) instance MonadIO MultiSat where liftIO m = MultiSat (\ms satNum k -> do x <- m; k x ms satNum) runMultiSat :: SatNum -> MultiSat a -> IO Models runMultiSat satNum m = reverse <$> unMultiSat m [] satNum (\_ ms _ -> return ms) done :: MultiSat a done = MultiSat (\ms _satNum _k -> return ms) yield :: [(TValue, Expr, Concrete.Value)] -> MultiSat () yield mdl = MultiSat (\ms satNum k -> case satNum of SomeSat n | n > 1 -> k () (mdl:ms) (SomeSat (n-1)) | otherwise -> return (mdl:ms) _ -> k () (mdl:ms) satNum) -- Compute all the ways to split a sequences of variables -- and concrete values for those variables. Each element -- of the list consists of a prefix of (varaible,value) -- pairs whose values we will fix, a single (varaible,value) -- pair that we will force to be different, and a list of -- additional unconstrained variables. computeSplits :: [VarShape (What4 sym)] -> [VarShape Concrete.Concrete] -> [ ( [(VarShape (What4 sym), VarShape Concrete.Concrete)] , VarShape (What4 sym) , VarShape Concrete.Concrete , [VarShape (What4 sym)] ) ] computeSplits vs cs = reverse [ (prefix, v, c, tl) | prefix <- inits (zip vs cs) | v <- vs | c <- cs | tl <- tail (tails vs) ] -- == END Support operations for multi-SAT == singleQuery :: sym ~ W4.ExprBuilder t CryptolState fm => What4 sym -> W4ProverConfig -> ProverCommand -> PrimMap -> W4.LogData -> [FinType] -> [VarShape (What4 sym)] -> Maybe (W4.Pred sym) {- ^ optional safety predicate. Nothing = SAT query -} -> W4.Pred sym -> IO (Maybe String, ProverResult) singleQuery _ W4OfflineConfig _pc _primMap _logData _ts _args _msafe _query = -- this shouldn't happen... fail "What4 offline solver cannot be used for direct queries" singleQuery sym (W4Portfolio ps) pc primMap logData ts args msafe query = do as <- mapM async [ singleQuery sym (W4ProverConfig p) pc primMap logData ts args msafe query | p <- NE.toList ps ] waitForResults [] as where waitForResults exs [] = X.throwIO (W4PortfolioFailure exs) waitForResults exs as = do (winner, result) <- waitAnyCatch as let others = filter (/= winner) as case result of Left ex -> waitForResults (Left ex:exs) others Right (nm, ProverError err) -> waitForResults (Right (nm,err) : exs) others Right r -> do forM_ others (\a -> X.throwTo (asyncThreadId a) ExitSuccess) return r singleQuery sym (W4ProverConfig (AnAdapter adpt)) _pc primMap logData ts args msafe query = do pres <- W4.solver_adapter_check_sat adpt (w4 sym) logData [query] $ \res -> case res of W4.Unknown -> return (ProverError "Solver returned UNKNOWN") W4.Unsat _ -> return (ThmResult (map unFinType ts)) W4.Sat (evalFn,_) -> do xs <- mapM (varShapeToConcrete evalFn) args let model = computeModel primMap ts xs case msafe of Just s -> do s' <- W4.groundEval evalFn s let cexType = if s' then PredicateFalsified else SafetyViolation return (CounterExample cexType model) Nothing -> return (AllSatResult [ model ]) return (Just (W4.solver_adapter_name adpt), pres) singleQuery sym (W4ProverConfig (AnOnlineAdapter nm fs _opts (_ :: Proxy s))) ProverCommand{..} primMap _logData ts args msafe query = withMaybeFile pcSmtFile WriteMode $ \smtFileHdl -> X.bracket (W4.startSolverProcess fs smtFileHdl (w4 sym)) (void . W4.shutdownSolverProcess) (\ (proc :: W4.SolverProcess t s) -> do W4.assume (W4.solverConn proc) query res <- W4.checkAndGetModel proc "query" case res of W4.Unknown -> return (Just nm, ProverError "Solver returned UNKNOWN") W4.Unsat _ -> return (Just nm, ThmResult (map unFinType ts)) W4.Sat evalFn -> do xs <- mapM (varShapeToConcrete evalFn) args let model = computeModel primMap ts xs case msafe of Just s -> do s' <- W4.groundEval evalFn s let cexType = if s' then PredicateFalsified else SafetyViolation return (Just nm, CounterExample cexType model) Nothing -> return (Just nm, AllSatResult [ model ]) ) -- | Like 'withFile', but lifted to work over 'Maybe'. withMaybeFile :: Maybe FilePath -> IOMode -> (Maybe Handle -> IO r) -> IO r withMaybeFile mbFP mode action = case mbFP of Just fp -> withFile fp mode (action . Just) Nothing -> action Nothing computeModelPred :: sym ~ W4.ExprBuilder t CryptolState fm => What4 sym -> VarShape (What4 sym) -> VarShape Concrete.Concrete -> IO (W4.Pred sym) computeModelPred sym v c = snd <$> doW4Eval (w4 sym) (varModelPred sym (v, c)) varShapeToConcrete :: W4.GroundEvalFn t -> VarShape (What4 (W4.ExprBuilder t CryptolState fm)) -> IO (VarShape Concrete.Concrete) varShapeToConcrete evalFn v = case v of VarBit b -> VarBit <$> W4.groundEval evalFn b VarInteger i -> VarInteger <$> W4.groundEval evalFn i VarRational n d -> VarRational <$> W4.groundEval evalFn n <*> W4.groundEval evalFn d VarWord SW.ZBV -> pure (VarWord (Concrete.mkBv 0 0)) VarWord (SW.DBV x) -> let w = W4.intValue (W4.bvWidth x) in VarWord . Concrete.mkBv w . BV.asUnsigned <$> W4.groundEval evalFn x VarFloat fv@(W4.SFloat f) -> let (e,p) = W4.fpSize fv in VarFloat . FH.BF e p <$> W4.groundEval evalFn f VarFinSeq n vs -> VarFinSeq n <$> mapM (varShapeToConcrete evalFn) vs VarTuple vs -> VarTuple <$> mapM (varShapeToConcrete evalFn) vs VarRecord fs -> VarRecord <$> traverse (varShapeToConcrete evalFn) fs cryptol-3.0.0/src/Cryptol/Testing/0000755000000000000000000000000007346545000015237 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/Testing/Random.hs0000644000000000000000000004174707346545000017030 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 FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} module Cryptol.Testing.Random ( Gen , randomValue , dumpableType , testableType , TestResult(..) , isPass , returnTests , returnTests' , exhaustiveTests , randomTests , randomTests' ) where import qualified Control.Exception as X import Control.Monad (liftM2) import Control.Monad.IO.Class (MonadIO(..)) import Data.Bits import Data.List (unfoldr, genericTake, genericIndex, genericReplicate) import qualified Data.Sequence as Seq import System.Random.TF.Gen import System.Random.TF.Instances import Cryptol.Backend (Backend(..), SRational(..)) import Cryptol.Backend.FloatHelpers (floatFromBits) import Cryptol.Backend.Monad (runEval,Eval,EvalErrorEx(..)) import Cryptol.Backend.Concrete import Cryptol.Backend.SeqMap (indexSeqMap, finiteSeqMap) import Cryptol.Backend.WordValue (wordVal) import Cryptol.Eval.Type (TValue(..)) import Cryptol.Eval.Value (GenValue(..), ppValue, defaultPPOpts, fromVFun) import Cryptol.TypeCheck.Solver.InfNat (widthInteger) import Cryptol.Utils.Ident (Ident) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.RecordMap type Gen g x = Integer -> g -> (SEval x (GenValue x), g) type Value = GenValue Concrete {- | 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 => Value -- ^ Function under test -> [Gen g Concrete] -- ^ Argument generators -> Integer -- ^ Size -> g -> IO (TestResult, g) runOneTest 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') args' <- runEval mempty (sequence args) result <- evalTest fun args' return (result, g1) returnOneTest :: RandomGen g => Value -- ^ Function to be used to calculate tests -> [Gen g Concrete] -- ^ Argument generators -> Integer -- ^ Size -> g -- ^ Initial random state -> IO ([Value], Value, g) -- ^ Arguments, result, and new random state returnOneTest 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') args' <- runEval mempty (sequence args) result <- runEval mempty (go fun args') return (args', result, g1) where go f@VFun{} (v : vs) = do f' <- fromVFun Concrete f (pure v) go f' 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 returnTests :: RandomGen g => g -- ^ The random generator state -> [Gen g Concrete] -- ^ 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 -- as well as the new state of the RNG returnTests g gens fun num = fst <$> returnTests' g gens fun num -- | Return a collection of random tests. returnTests' :: RandomGen g => g -- ^ The random generator state -> [Gen g Concrete] -- ^ Generators for the function arguments -> Value -- ^ The function itself -> Int -- ^ How many tests? -> IO ([([Value], Value)], g) -- ^ A list of pairs of random arguments and computed outputs -- as well as the new state of the RNG returnTests' g gens fun num = go gens g 0 where go args g0 n | n >= num = return ([], g0) | otherwise = do let sz = toInteger (div (100 * (1 + n)) num) (inputs, output, g1) <- returnOneTest fun args sz g0 (more, g2) <- go args g1 (n + 1) return ((inputs, output) : more, g2) {- | Given a (function) type, compute generators for the function's arguments. -} dumpableType :: forall g. RandomGen g => TValue -> Maybe [Gen g Concrete] dumpableType (TVFun t1 t2) = do g <- randomValue Concrete t1 as <- dumpableType t2 return (g : as) dumpableType ty = do (_ :: Gen g Concrete) <- randomValue Concrete ty return [] {-# SPECIALIZE randomValue :: RandomGen g => Concrete -> TValue -> Maybe (Gen g Concrete) #-} {- | A generator for values of the given type. This fails if we are given a type that lacks a suitable random value generator. -} randomValue :: (Backend sym, RandomGen g) => sym -> TValue -> Maybe (Gen g sym) randomValue sym ty = case ty of TVBit -> Just (randomBit sym) TVInteger -> Just (randomInteger sym) TVRational -> Just (randomRational sym) TVIntMod m -> Just (randomIntMod sym m) TVFloat e p -> Just (randomFloat sym e p) TVSeq n TVBit -> Just (randomWord sym n) TVSeq n el -> do mk <- randomValue sym el return (randomSequence n mk) TVStream el -> do mk <- randomValue sym el return (randomStream mk) TVTuple els -> do mks <- mapM (randomValue sym) els return (randomTuple mks) TVRec fs -> do gs <- traverse (randomValue sym) fs return (randomRecord gs) TVNewtype _ _ fs -> do gs <- traverse (randomValue sym) fs return (randomRecord gs) TVArray{} -> Nothing TVFun{} -> Nothing TVAbstract{} -> Nothing {-# INLINE randomBit #-} -- | Generate a random bit value. randomBit :: (Backend sym, RandomGen g) => sym -> Gen g sym randomBit sym _ g = let (b,g1) = random g in (pure (VBit (bitLit sym b)), g1) {-# INLINE randomSize #-} 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 {-# INLINE randomInteger #-} -- | 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 :: (Backend sym, RandomGen g) => sym -> Gen g sym randomInteger sym w g = let (n, g1) = if w < 100 then (fromInteger w, g) else randomSize 8 100 g (i, g2) = randomR (- 256^n, 256^n) g1 in (VInteger <$> integerLit sym i, g2) {-# INLINE randomIntMod #-} randomIntMod :: (Backend sym, RandomGen g) => sym -> Integer -> Gen g sym randomIntMod sym modulus _ g = let (i, g') = randomR (0, modulus-1) g in (VInteger <$> integerLit sym i, g') {-# INLINE randomRational #-} randomRational :: (Backend sym, RandomGen g) => sym -> Gen g sym randomRational sym w g = let (sz, g1) = if w < 100 then (fromInteger w, g) else randomSize 8 100 g (n, g2) = randomR (- 256^sz, 256^sz) g1 (d, g3) = randomR ( 1, 256^sz) g2 in (do n' <- integerLit sym n d' <- integerLit sym d pure (VRational (SRational n' d')) , g3) {-# INLINE randomWord #-} -- | 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 :: (Backend sym, RandomGen g) => sym -> Integer -> Gen g sym randomWord sym w _sz g = let (val, g1) = randomR (0,2^w-1) g in (VWord w . wordVal <$> wordLit sym w val, g1) {-# INLINE randomStream #-} -- | Generate a random infinite stream value. randomStream :: (Backend sym, RandomGen g) => Gen g sym -> Gen g sym randomStream mkElem sz g = let (g1,g2) = split g in (pure $ VStream $ indexSeqMap $ genericIndex (unfoldr (Just . mkElem sz) g1), g2) {-# INLINE randomSequence #-} {- | Generate a random sequence. This should be used for sequences other than bits. For sequences of bits use "randomWord". -} randomSequence :: (Backend sym, RandomGen g) => Integer -> Gen g sym -> Gen g sym randomSequence w mkElem sz g0 = do let (g1,g2) = split g0 let f g = let (x,g') = mkElem sz g in seq x (Just (x, g')) let xs = Seq.fromList $ genericTake w $ unfoldr f g1 let v = VSeq w $ indexSeqMap $ \i -> Seq.index xs (fromInteger i) seq xs (pure v, g2) {-# INLINE randomTuple #-} -- | Generate a random tuple value. randomTuple :: (Backend sym, RandomGen g) => [Gen g sym] -> Gen g sym randomTuple gens sz = go [] gens where go els [] g = (pure $ VTuple (reverse els), g) go els (mkElem : more) g = let (v, g1) = mkElem sz g in seq v (go (v : els) more g1) {-# INLINE randomRecord #-} -- | Generate a random record value. randomRecord :: (Backend sym, RandomGen g) => RecordMap Ident (Gen g sym) -> Gen g sym randomRecord gens sz g0 = let (g', m) = recordMapAccum mk g0 gens in (pure $ VRecord m, g') where mk g gen = let (v, g') = gen sz g in seq v (g', v) randomFloat :: (Backend sym, RandomGen g) => sym -> Integer {- ^ Exponent width -} -> Integer {- ^ Precision width -} -> Gen g sym randomFloat sym e p w g0 = let sz = max 0 (min 100 w) ( x, g') = randomR (0, 10*(sz+1)) g0 in if | x < 2 -> (VFloat <$> fpNaN sym e p, g') | x < 4 -> (VFloat <$> fpPosInf sym e p, g') | x < 6 -> (VFloat <$> (fpNeg sym =<< fpPosInf sym e p), g') | x < 8 -> (VFloat <$> fpLit sym e p 0, g') | x < 10 -> (VFloat <$> (fpNeg sym =<< fpLit sym e p 0), g') | x <= sz -> genSubnormal g' -- about 10% of the time | x <= 4*(sz+1) -> genBinary g' -- about 40% | otherwise -> genNormal (toInteger sz) g' -- remaining ~50% where emax = bit (fromInteger e) - 1 smax = bit (fromInteger p) - 1 -- generates floats uniformly chosen from among all bitpatterns genBinary g = let (v, g1) = randomR (0, bit (fromInteger (e+p)) - 1) g in (VFloat <$> (fpFromBits sym e p =<< wordLit sym (e+p) v), g1) -- generates floats corresponding to subnormal values. These are -- values with 0 biased exponent and nonzero mantissa. genSubnormal g = let (sgn, g1) = random g (v, g2) = randomR (1, bit (fromInteger p) - 1) g1 in (VFloat <$> ((if sgn then fpNeg sym else pure) =<< fpFromBits sym e p =<< wordLit sym (e+p) v), g2) -- generates floats where the exponent and mantissa are scaled by the size genNormal sz g = let (sgn, g1) = random g (ex, g2) = randomR ((1-emax)*sz `div` 100, (sz*emax) `div` 100) g1 (mag, g3) = randomR (1, max 1 ((sz*smax) `div` 100)) g2 r = fromInteger mag ^^ (ex - widthInteger mag) r' = if sgn then negate r else r in (VFloat <$> fpLit sym e p r', g3) -- | 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 EvalErrorEx [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. evalTest :: Value -> [Value] -> IO TestResult evalTest v0 vs0 = run `X.catch` handle where run = do result <- runEval mempty (go v0 vs0) if result then return Pass else return (FailFalse vs0) handle e = return (FailError e vs0) go :: Value -> [Value] -> Eval Bool go f@VFun{} (v : vs) = do f' <- fromVFun Concrete f (pure v) go f' vs go VFun{} [] = panic "Not enough arguments while applying function" [] go (VBit b) [] = return b go v vs = do vdoc <- ppValue Concrete defaultPPOpts v vsdocs <- mapM (ppValue Concrete defaultPPOpts) vs panic "Type error while running test" $ [ "Function:" , show vdoc , "Arguments:" ] ++ map show vsdocs {- | Given a (function) type, compute data necessary for random or exhaustive testing. The first returned component is a count of the number of possible input test vectors, if the input types are finite. The second component is a list of all the types of the function inputs. The third component is a list of all input test vectors for exhaustive testing. This will be empty unless the input types are finite. The final argument is a list of generators for the inputs of the function. This function will return @Nothing@ if the input type does not eventually return @Bit@, or if we cannot compute a generator for one of the inputs. -} testableType :: RandomGen g => TValue -> Maybe (Maybe Integer, [TValue], [[Value]], [Gen g Concrete]) testableType (TVFun t1 t2) = do let sz = typeSize t1 g <- randomValue Concrete t1 (tot,ts,vss,gs) <- testableType t2 let tot' = liftM2 (*) sz tot let vss' = [ v : vs | v <- typeValues t1, vs <- vss ] return (tot', t1:ts, vss', g:gs) testableType TVBit = return (Just 1, [], [[]], []) testableType _ = 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 :: TValue -> Maybe Integer typeSize ty = case ty of TVBit -> Just 2 TVInteger -> Nothing TVRational -> Nothing TVIntMod n -> Just n TVFloat e p -> Just (2 ^ (e+p)) TVArray{} -> Nothing TVStream{} -> Nothing TVSeq n el -> (^ n) <$> typeSize el TVTuple els -> product <$> mapM typeSize els TVRec fs -> product <$> traverse typeSize fs TVFun{} -> Nothing TVAbstract{} -> Nothing TVNewtype _ _ tbody -> typeSize (TVRec tbody) {- | Returns all the values in a type. Returns an empty list of values, for types where 'typeSize' returned 'Nothing'. -} typeValues :: TValue -> [Value] typeValues ty = case ty of TVBit -> [ VBit False, VBit True ] TVInteger -> [] TVRational -> [] TVIntMod n -> [ VInteger x | x <- [ 0 .. (n-1) ] ] TVFloat e p -> [ VFloat (floatFromBits e p v) | v <- [0 .. 2^(e+p) - 1] ] TVArray{} -> [] TVStream{} -> [] TVSeq n TVBit -> [ VWord n (wordVal (BV n x)) | x <- [ 0 .. 2^n - 1 ] ] TVSeq n el -> [ VSeq n (finiteSeqMap Concrete (map pure xs)) | xs <- sequence (genericReplicate n (typeValues el)) ] TVTuple ts -> [ VTuple (map pure xs) | xs <- sequence (map typeValues ts) ] TVRec fs -> [ VRecord (fmap pure xs) | xs <- traverse typeValues fs ] TVFun{} -> [] TVAbstract{} -> [] TVNewtype _ _ tbody -> typeValues (TVRec tbody) -------------------------------------------------------------------------------- -- Driver function exhaustiveTests :: MonadIO m => (Integer -> m ()) {- ^ progress callback -} -> Value {- ^ function under test -} -> [[Value]] {- ^ exhaustive set of test values -} -> m (TestResult, Integer) exhaustiveTests ppProgress val = go 0 where go !testNum [] = return (Pass, testNum) go !testNum (vs:vss) = do ppProgress testNum res <- liftIO (evalTest val vs) case res of Pass -> go (testNum+1) vss failure -> return (failure, testNum) randomTests :: (MonadIO m, RandomGen g) => (Integer -> m ()) {- ^ progress callback -} -> Integer {- ^ Maximum number of tests to run -} -> Value {- ^ function under test -} -> [Gen g Concrete] {- ^ input value generators -} -> g {- ^ Inital random generator -} -> m (TestResult, Integer) randomTests ppProgress maxTests val gens g = fst <$> randomTests' ppProgress maxTests val gens g randomTests' :: (MonadIO m, RandomGen g) => (Integer -> m ()) {- ^ progress callback -} -> Integer {- ^ Maximum number of tests to run -} -> Value {- ^ function under test -} -> [Gen g Concrete] {- ^ input value generators -} -> g {- ^ Inital random generator -} -> m ((TestResult, Integer), g) randomTests' ppProgress maxTests val gens = go 0 where go !testNum g | testNum >= maxTests = return ((Pass, testNum), g) | otherwise = do ppProgress testNum let sz' = div (100 * (1 + testNum)) maxTests (res, g') <- liftIO (runOneTest val gens sz' g) case res of Pass -> go (testNum+1) g' failure -> return ((failure, testNum), g) cryptol-3.0.0/src/Cryptol/Transform/0000755000000000000000000000000007346545000015575 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/Transform/MonoValues.hs0000644000000000000000000003024507346545000020225 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(..),ModPath(..)) import Cryptol.Parser.Position (emptyRange) import Cryptol.TypeCheck.AST hiding (splitTApp) -- XXX: just use this one import Cryptol.TypeCheck.TypeMap import Cryptol.Utils.Ident(Namespace(..)) import Data.List(sortBy) import Data.Either(partitionEithers) import Data.Map (Map) import qualified Data.List.NonEmpty as NE 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 (TopModule (mName m)) s where body = do ds <- mapM (rewDeclGroup emptyTM) (mDecls m) return m { mDecls = ds } -------------------------------------------------------------------------------- type M = ReaderT RO (SupplyT Id) type RO = ModPath -- | Produce a fresh top-level name. newName :: M Name newName = do ns <- ask liftSupply (mkDeclared NSValue 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 ELocated r t -> ELocated r <$> go t EList es t -> EList <$> mapM go es <*> return t ETuple es -> ETuple <$> mapM go es ERec fs -> ERec <$> traverse go fs ESel e s -> ESel <$> go e <*> return s ESet ty e s v -> ESet ty <$> 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) EPropGuards guards ty -> EPropGuards <$> (\(props, e) -> (,) <$> pure props <*> go e) `traverse` guards <*> pure ty 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 rewDef _ (DForeign t) = return $ DForeign t 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 = NE.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 DForeign _ -> 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 (NE.toList ds) $ \(d,_,_,e) -> do x <- newName return (d, x, e) let (_,tps,props,_) NE.:| _ = 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-3.0.0/src/Cryptol/Transform/Specialize.hs0000644000000000000000000003325507346545000020231 0ustar0000000000000000-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | -- 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 Cryptol.Utils.Ident(OrigName(..)) import Cryptol.Eval (checkProp) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (catMaybes) import qualified Data.List as List import MonadLib hiding (mapM) import Cryptol.ModuleSystem.Base (getPrimMap) -- 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 minp = run $ do let extDgs = allDeclGroups (M.minpModuleEnv minp) let (tparams, expr') = destETAbs expr spec' <- specializeEWhere expr' extDgs return (foldr ETAbs spec' tparams) where run = M.runModuleT minp . fmap fst . runSpecT Map.empty specializeExpr :: Expr -> SpecM Expr specializeExpr expr = case expr of ELocated r e -> ELocated r <$> specializeExpr e EList es t -> EList <$> traverse specializeExpr es <*> pure t ETuple es -> ETuple <$> traverse specializeExpr es ERec fs -> ERec <$> traverse specializeExpr fs ESel e s -> ESel <$> specializeExpr e <*> pure s ESet ty e s v -> ESet ty <$> 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 -- The type should be monomorphic, and the guarded expressions should -- already be normalized, so we just need to choose the first expression -- that's true. EPropGuards guards ty -> case List.find (all checkProp . fst) guards of Just (_, e) -> specializeExpr e Nothing -> do pm <- liftSpecT getPrimMap pure $ eError pm ty "no constraint guard was satisfied" 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 DForeign t -> return $ DForeign t 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 GlobalName s og -> liftSupply (mkDeclared ns (ogModule og) s ident fx loc) LocalName {} -> liftSupply (mkLocal ns ident loc) where ns = nameNamespace n 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 (singleTParamSubst 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-3.0.0/src/Cryptol/TypeCheck.hs0000644000000000000000000001071107346545000016035 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 , tcExpr , tcDecls , InferInput(..) , InferOutput(..) , SolverConfig(..) , defaultSolverConfig , NameSeeds , nameSeeds , Error(..) , Warning(..) , ppWarning , ppError , WithNames(..) , NameMap , ppNamedWarning , ppNamedError ) where import Data.Map(Map) import Cryptol.ModuleSystem.Name (liftSupply,mkDeclared,NameSource(..),ModPath(..)) import qualified Cryptol.Parser.AST as P import Cryptol.Parser.Position(Range,emptyRange) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Error import Cryptol.TypeCheck.Monad ( runInferM , InferInput(..) , InferOutput(..) , NameSeeds , nameSeeds , lookupVar , newLocalScope, endLocalScope ) import Cryptol.TypeCheck.Infer (inferTopModule, inferBinds, checkTopDecls) import Cryptol.TypeCheck.InferTypes(VarType(..), SolverConfig(..), defaultSolverConfig) import Cryptol.TypeCheck.Solve(proveModuleTopLevel) -- import Cryptol.TypeCheck.Monad(withParamType,withParameterConstraints) import Cryptol.TypeCheck.PP(WithNames(..),NameMap) import Cryptol.Utils.Ident (exprModName,packIdent,Namespace(..)) import Cryptol.Utils.PP import Cryptol.Utils.Panic(panic) tcModule :: P.Module Name -> InferInput -> IO (InferOutput TCTopEntity) tcModule m inp = runInferM inp (inferTopModule m) 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' -> do (te, sch) <- go loc' e pure $! if inpCallStacks inp then (ELocated loc' te, sch) else (te,sch) 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 NSValue (TopModule 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 , P.bExport = Public } ] 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 :: [P.TopDecl Name] -> InferInput -> IO (InferOutput ([DeclGroup],Map Name TySyn)) tcDecls ds inp = runInferM inp $ do newLocalScope checkTopDecls ds proveModuleTopLevel endLocalScope ppWarning :: (Range,Warning) -> Doc ppWarning (r,w) = nest 2 (text "[warning] at" <+> pp r <.> colon $$ pp w) ppError :: (Range,Error) -> Doc ppError (r,w) = nest 2 (text "[error] at" <+> pp r <.> colon $$ pp w) ppNamedWarning :: NameMap -> (Range,Warning) -> Doc ppNamedWarning nm (r,w) = nest 2 (text "[warning] at" <+> pp r <.> colon $$ pp (WithNames w nm)) ppNamedError :: NameMap -> (Range,Error) -> Doc ppNamedError nm (r,e) = nest 2 (text "[error] at" <+> pp r <.> colon $$ pp (WithNames e nm)) cryptol-3.0.0/src/Cryptol/TypeCheck/0000755000000000000000000000000007346545000015501 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/TypeCheck/AST.hs0000644000000000000000000004060207346545000016466 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 #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ViewPatterns #-} module Cryptol.TypeCheck.AST ( module Cryptol.TypeCheck.AST , Name() , TFun(..) , Selector(..) , Import, ImportG(..), ImpName(..) , ImportSpec(..) , ExportType(..) , ExportSpec(..), isExportedBind, isExportedType, isExported , Pragma(..) , Fixity(..) , PrimMap(..) , module Cryptol.TypeCheck.Type ) where import Data.Maybe(mapMaybe) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,PrimIdent,prelPrim) import Cryptol.Parser.Position(Located,Range,HasLoc(..)) import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Exports(ExportSpec(..) , isExportedBind, isExportedType, isExported) import Cryptol.Parser.AST ( Selector(..),Pragma(..) , Import , ImportG(..), ImportSpec(..), ExportType(..) , Fixity(..) , ImpName(..) ) import Cryptol.Utils.RecordMap import Cryptol.TypeCheck.FFI.FFIType import Cryptol.TypeCheck.PP import Cryptol.TypeCheck.Type import GHC.Generics (Generic) import Control.DeepSeq import Data.Set (Set) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Data.Text (Text) data TCTopEntity = TCTopModule (ModuleG ModName) | TCTopSignature ModName ModParamNames deriving (Show, Generic, NFData) tcTopEntitytName :: TCTopEntity -> ModName tcTopEntitytName ent = case ent of TCTopModule m -> mName m TCTopSignature m _ -> m -- | Panics if the entity is not a module tcTopEntityToModule :: TCTopEntity -> Module tcTopEntityToModule ent = case ent of TCTopModule m -> m TCTopSignature {} -> panic "tcTopEntityToModule" [ "Not a module" ] -- | A Cryptol module. data ModuleG mname = Module { mName :: !mname , mDoc :: !(Maybe Text) , mExports :: ExportSpec Name -- Functors: , mParamTypes :: Map Name ModTParam , mParamFuns :: Map Name ModVParam , mParamConstraints :: [Located Prop] , mParams :: FunctorParams -- ^ Parameters grouped by "import". , mFunctors :: Map Name (ModuleG Name) -- ^ Functors directly nested in this module. -- Things further nested are in the modules in the -- elements of the map. , mNested :: !(Set Name) -- ^ Submodules, functors, and interfaces nested directly -- in this module -- These have everything from this module and all submodules , mTySyns :: Map Name TySyn , mNewtypes :: Map Name Newtype , mPrimTypes :: Map Name AbstractType , mDecls :: [DeclGroup] , mSubmodules :: Map Name (IfaceNames Name) , mSignatures :: !(Map Name ModParamNames) } deriving (Show, Generic, NFData) emptyModule :: mname -> ModuleG mname emptyModule nm = Module { mName = nm , mDoc = Nothing , mExports = mempty , mParams = mempty , mParamTypes = mempty , mParamConstraints = mempty , mParamFuns = mempty , mNested = mempty , mTySyns = mempty , mNewtypes = mempty , mPrimTypes = mempty , mDecls = mempty , mFunctors = mempty , mSubmodules = mempty , mSignatures = mempty } -- | Find all the foreign declarations in the module and return their names and FFIFunTypes. findForeignDecls :: ModuleG mname -> [(Name, FFIFunType)] findForeignDecls = mapMaybe getForeign . mDecls where getForeign (NonRecursive Decl { dName, dDefinition = DForeign ffiType }) = Just (dName, ffiType) -- Recursive DeclGroups can't have foreign decls getForeign _ = Nothing -- | Find all the foreign declarations that are in functors. -- This is used to report an error findForeignDeclsInFunctors :: ModuleG mname -> [Name] findForeignDeclsInFunctors = concatMap fromM . Map.elems . mFunctors where fromM m = map fst (findForeignDecls m) ++ findForeignDeclsInFunctors m type Module = ModuleG ModName -- | Is this a parameterized module? isParametrizedModule :: ModuleG mname -> Bool isParametrizedModule m = not (null (mParams m) && null (mParamTypes m) && null (mParamConstraints m) && null (mParamFuns m)) data Expr = EList [Expr] Type -- ^ List value (with type of elements) | ETuple [Expr] -- ^ Tuple value | ERec (RecordMap Ident Expr) -- ^ Record value | ESel Expr Selector -- ^ Elimination for tuple/record/list | ESet Type Expr Selector Expr -- ^ Change the value of a field. -- The included type gives the type of the record being updated | 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 | ELocated Range Expr -- ^ Source location information {- | 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] | EPropGuards [([Prop], Expr)] Type 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 Text } deriving (Generic, NFData, Show) data DeclDef = DPrim | DForeign FFIFunType | DExpr Expr deriving (Show, Generic, NFData) -------------------------------------------------------------------------------- -- | Construct a primitive, given a map to the unique primitive name. ePrim :: PrimMap -> PrimIdent -> 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 (prelPrim "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 (prelPrim "number")) (tNum v)) (tWord (tNum w)) where v = fromEnum c w = 8 :: Int instance PP TCTopEntity where ppPrec _ te = case te of TCTopModule m -> pp m TCTopSignature x p -> ("interface" <+> pp x <+> "where") $$ nest 2 (pp p) instance PP (WithNames Expr) where ppPrec prec (WithNames expr nm) = case expr of ELocated _ t -> ppWP prec t EList [] t -> optParens (prec > 0) $ text "[]" <+> colon <+> ppWP prec t EList es _ -> ppList $ map ppW es ETuple es -> ppTuple $ map ppW es ERec fs -> ppRecord [ pp f <+> text "=" <+> ppW e | (f,e) <- displayFields fs ] ESel e sel -> ppWP 4 e <.> text "." <.> pp sel ESet _ty 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 <+> (align (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 5 t EWhere e ds -> optParens (prec > 0) $ align $ vsep $ [ ppW e , hang "where" 2 (vcat (map ppW ds)) ] EPropGuards guards _ -> parens (text "propguards" <+> vsep (ppGuard <$> guards)) where ppGuard (props, e) = indent 1 $ pipe <+> commaSep (ppW <$> props) <+> text "=>" <+> ppW e where ppW x = ppWithNames nm x ppWP x = ppWithNamesPrec nm x ppLam :: NameMap -> Int -> [TParam] -> [Prop] -> [(Name,Type)] -> Expr -> Doc ppLam nm prec [] [] [] e = nest 2 (ppWithNamesPrec nm prec e) ppLam nm prec ts ps xs e = optParens (prec > 0) $ nest 2 $ sep [ text "\\" <.> hsep (tsD ++ psD ++ xsD ++ [text "->"]) , ppWithNames ns1 e ] where ns1 = addTNames ts nm tsD = if null ts then [] else [braces $ commaSep $ map ppT ts] psD = if null ps then [] else [parens $ commaSep $ map ppP ps] xsD = if null xs then [] 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) splitLoc :: Expr -> Maybe (Range, Expr) splitLoc expr = case expr of ELocated r e -> Just (r,e) _ -> Nothing -- | Remove outermost locations dropLocs :: Expr -> Expr dropLocs = snd . splitWhile splitLoc splitAbs :: Expr -> Maybe ((Name,Type), Expr) splitAbs (dropLocs -> EAbs x t e) = Just ((x,t), e) splitAbs _ = Nothing splitApp :: Expr -> Maybe (Expr,Expr) splitApp (dropLocs -> EApp f a) = Just (a, f) splitApp _ = Nothing splitTAbs :: Expr -> Maybe (TParam, Expr) splitTAbs (dropLocs -> ETAbs t e) = Just (t, e) splitTAbs _ = Nothing splitProofAbs :: Expr -> Maybe (Prop, Expr) splitProofAbs (dropLocs -> EProofAbs p e) = Just (p,e) splitProofAbs _ = Nothing splitTApp :: Expr -> Maybe (Type,Expr) splitTApp (dropLocs -> ETApp e t) = Just (t, e) splitTApp _ = Nothing splitProofApp :: Expr -> Maybe ((), Expr) splitProofApp (dropLocs -> 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 HasLoc Expr where getLoc (ELocated r _) = Just r getLoc _ = Nothing 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) = vcat $ [ pp dName <+> text ":" <+> ppWithNames nm dSignature ] ++ (if null dPragmas then [] else [text "pragmas" <+> pp dName <+> sep (map pp dPragmas)]) ++ [ nest 2 (sep [pp dName <+> text "=", ppWithNames nm dDefinition]) ] instance PP (WithNames DeclDef) where ppPrec _ (WithNames DPrim _) = text "" ppPrec _ (WithNames (DForeign _) _) = text "" ppPrec _ (WithNames (DExpr e) nm) = ppWithNames nm e instance PP Decl where ppPrec = ppWithNamesPrec IntMap.empty instance PP n => PP (ModuleG n) where ppPrec = ppWithNamesPrec IntMap.empty instance PP n => PP (WithNames (ModuleG n)) where ppPrec _ (WithNames Module { .. } nm) = vcat [ text "module" <+> pp mName -- XXX: Print exports? , vcat (map pp' (Map.elems mTySyns)) -- XXX: Print abstarct types/functions , vcat (map pp' mDecls) , vcat (map pp (Map.elems mFunctors)) ] where mps = map mtpParam (Map.elems mParamTypes) pp' :: PP (WithNames a) => a -> Doc pp' = ppWithNames (addTNames mps nm) instance PP (WithNames TCTopEntity) where ppPrec _ (WithNames ent nm) = case ent of TCTopModule m -> ppWithNames nm m TCTopSignature n ps -> hang ("interface module" <+> pp n <+> "where") 2 (pp ps) cryptol-3.0.0/src/Cryptol/TypeCheck/Default.hs0000644000000000000000000002100107346545000017413 0ustar0000000000000000{-# LANGUAGE Safe #-} module Cryptol.TypeCheck.Default where import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe(mapMaybe, isJust) import Data.List((\\),nub) import Control.Monad(guard,mzero) import Cryptol.TypeCheck.Type import Cryptol.TypeCheck.SimpType(tMax) import Cryptol.TypeCheck.Error(Warning(..), Error(..)) import Cryptol.TypeCheck.Subst(Subst,apSubst,listSubst,substBinds,uncheckedSingleSubst) 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@ and @FLiteral m n r a@. -- -- For @Literal t a@ we examine the context of constraints on the type @a@ -- to decide how to default. If @Logic a@ is required, -- we cannot do any defaulting. Otherwise, we default -- to either @Integer@ or @Rational@. In particular, if -- we need to satisfy the @Field a@, constraint, we choose -- @Rational@ and otherwise we choose @Integer@. -- -- For @FLiteral t a@ we always default to @Rational@. 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 allProps = saturatedPropSet gSet has p a = Set.member (p (TVar a)) allProps isLiteralGoal a = isJust (Map.lookup a (literalGoals gSet)) || isJust (Map.lookup a (literalLessThanGoals gSet)) tryDefVar a = -- If there is an `FLiteral` constraint we use that for defaulting. case Map.lookup a (flitDefaultCandidates gSet) of Just m -> m -- Otherwise we try to use a `Literal` Nothing | isLiteralGoal a -> do defT <- if has pLogic a then mzero else if has pField a && not (has pIntegral a) then pure tRational else if not (has pField a) then pure tInteger else mzero let d = tvInfo a 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) | otherwise -> mzero flitDefaultCandidates :: Goals -> Map TVar (Maybe ((TVar,Type),Warning)) flitDefaultCandidates gs = Map.fromList (mapMaybe flitCandidate (Set.toList (goalSet gs))) where allProps = saturatedPropSet gs has p a = Set.member (p (TVar a)) allProps flitCandidate g = do (_,_,_,x) <- pIsFLiteral (goal g) a <- tIsVar x pure (a, do guard (not (has pLogic a) && not (has pIntegral a)) let defT = tRational let w = DefaultingTo (tvInfo a) defT pure ((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 , [Error] -- width defaulting errors ) 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 names = substBinds su mkErr (x,t) = case x of TVFree _ _ _ d | Just 0 <- tIsNum t -> AmbiguousSize d Nothing | otherwise -> AmbiguousSize d (Just t) TVBound {} -> panic "Crypto.TypeCheck.Infer" [ "tryDefault attempted to default a quantified variable." ] in ( [ a | a <- as, not (a `Set.member` names) ] , newOthers ++ others ++ nub (apSubst su fins) , su , map mkErr 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 = uncheckedSingleSubst 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-3.0.0/src/Cryptol/TypeCheck/Error.hs0000644000000000000000000007210707346545000017135 0ustar0000000000000000{-# Language FlexibleInstances, DeriveGeneric, DeriveAnyClass #-} {-# Language OverloadedStrings #-} {-# Language Safe #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 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,partition) import Data.Function(on) import Cryptol.Utils.Ident(Ident,Namespace(..)) import qualified Cryptol.Parser.AST as P import Cryptol.Parser.Position(Located(..), Range(..), rangeWithin) import Cryptol.TypeCheck.PP import Cryptol.TypeCheck.Type import Cryptol.TypeCheck.InferTypes import Cryptol.TypeCheck.Subst import Cryptol.TypeCheck.Unify(Path,isRootPath) import Cryptol.TypeCheck.FFI.Error import Cryptol.ModuleSystem.Name(Name) import Cryptol.Utils.RecordMap cleanupErrors :: [(Range,Error)] -> [(Range,Error)] cleanupErrors = dropErrorsFromSameLoc . sortBy (compare `on` (cmpR . fst)) -- order errors . dropSubsumed [] where -- pick shortest error from each location. dropErrorsFromSameLoc = concatMap chooseBestError . groupBy ((==) `on` fst) addErrorRating (r,e) = (errorImportance e, (r,e)) chooseBestError = map snd . head . groupBy ((==) `on` fst) . sortBy (flip compare `on` fst) . map addErrorRating cmpR r = ( source r -- First by file , from r -- Then starting position , to r -- Finally end position ) dropSubsumed survived xs = case xs of err : rest -> let keep e = not (subsumes err e) in dropSubsumed (err : filter keep survived) (filter keep rest) [] -> survived -- | Should the first error suppress the next one. subsumes :: (Range,Error) -> (Range,Error) -> Bool subsumes (_,NotForAll _ _ x _) (_,NotForAll _ _ y _) = x == y subsumes (r1,UnexpectedTypeWildCard) (r2,UnsupportedFFIType{}) = r1 `rangeWithin` r2 subsumes (r1,KindMismatch {}) (r2,err) = case err of KindMismatch {} -> r1 == r2 _ -> True subsumes _ _ = False data Warning = DefaultingKind (P.TParam Name) P.Kind | DefaultingWildType P.Kind | DefaultingTo !TVarInfo Type | NonExhaustivePropGuards Name deriving (Show, Generic, NFData) -- | Various errors that might happen during type checking/inference data Error = KindMismatch (Maybe TypeSource) 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 TypeSource Path Type Type -- ^ Expected type, inferred type | SchemaMismatch Ident Schema Schema -- ^ Name of module parameter, expected scehema, actual schema. -- This may happen when instantiating modules. | RecursiveType TypeSource Path Type Type -- ^ Unification results in a recursive type | UnsolvedGoals [Goal] -- ^ A constraint that we could not solve, usually because -- there are some left-over variables that we could not infer. | UnsolvableGoals [Goal] -- ^ A constraint that we could not solve and we know -- it is impossible to do it. | 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 TypeSource Path Type [TParam] -- ^ Unification variable depends on quantified variables -- that are not in scope. | NotForAll TypeSource Path 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 | BadParameterKind TParam Kind -- ^ Kind other than `*` or `#` given to parameter of -- type synonym, newtype, function signature, etc. | CannotMixPositionalAndNamedTypeParams | UndefinedTypeParameter (Located Ident) | RepeatedTypeParameter Ident [Range] | AmbiguousSize TVarInfo (Maybe Type) -- ^ Could not determine the value of a numeric type variable, -- but we know it must be at least as large as the given type -- (or unconstrained, if Nothing). | BareTypeApp -- ^ Bare expression of the form `{_} | UndefinedExistVar Name | TypeShadowing String Name String | MissingModTParam (Located Ident) | MissingModVParam (Located Ident) | MissingModParam Ident | FunctorInstanceMissingArgument Ident | FunctorInstanceBadArgument Ident | FunctorInstanceMissingName Namespace Ident | FunctorInstanceBadBacktick BadBacktickInstance | UnsupportedFFIKind TypeSource TParam Kind -- ^ Kind is not supported for FFI | UnsupportedFFIType TypeSource FFITypeError -- ^ Type is not supported for FFI | NestedConstraintGuard Ident -- ^ Constraint guards may only apper at the top-level | DeclarationRequiresSignatureCtrGrd Ident -- ^ All declarataions in a recursive group involving -- constraint guards should have signatures | InvalidConstraintGuard Prop -- ^ The given constraint may not be used as a constraint guard | TemporaryError Doc -- ^ This is for errors that don't fit other cateogories. -- We should not use it much, and is generally to be used -- for transient errors, which are due to incomplete -- implementation. deriving (Show, Generic, NFData) data BadBacktickInstance = BIPolymorphicArgument Ident Ident | BINested [(BIWhat, Name)] | BIMultipleParams Ident deriving (Show, Generic, NFData) data BIWhat = BIFunctor | BIInterface | BIPrimitive | BIForeign | BIAbstractType deriving (Show, Generic, NFData) -- | When we have multiple errors on the same location, we show only the -- ones with the has highest rating according to this function. errorImportance :: Error -> Int errorImportance err = case err of BareTypeApp -> 11 -- basically a parse error TemporaryError {} -> 11 -- show these as usually means the user used something that doesn't work FunctorInstanceMissingArgument {} -> 10 MissingModParam {} -> 10 FunctorInstanceBadArgument {} -> 10 FunctorInstanceMissingName {} -> 9 FunctorInstanceBadBacktick {} -> 9 KindMismatch {} -> 10 TyVarWithParams {} -> 9 TypeMismatch {} -> 8 SchemaMismatch {} -> 7 RecursiveType {} -> 7 NotForAll {} -> 6 TypeVariableEscaped {} -> 5 UndefinedExistVar {} -> 10 TypeShadowing {} -> 2 MissingModTParam {} -> 10 MissingModVParam {} -> 10 BadParameterKind{} -> 9 CannotMixPositionalAndNamedTypeParams {} -> 8 TooManyTypeParams {} -> 8 TooFewTyParams {} -> 8 TooManyPositionalTypeParams {} -> 8 UndefinedTypeParameter {} -> 8 RepeatedTypeParameter {} -> 8 TooManyTySynParams {} -> 8 UnexpectedTypeWildCard {} -> 8 RecursiveTypeDecls {} -> 9 UnsolvableGoals g | any tHasErrors (map goal g) -> 0 | otherwise -> 4 UnsolvedGoals g | any tHasErrors (map goal g) -> 0 | otherwise -> 4 UnsolvedDelayedCt dt | any tHasErrors (map goal (dctGoals dt)) -> 0 | otherwise -> 3 AmbiguousSize {} -> 2 UnsupportedFFIKind {} -> 10 UnsupportedFFIType {} -> 7 -- less than UnexpectedTypeWildCard NestedConstraintGuard {} -> 10 DeclarationRequiresSignatureCtrGrd {} -> 9 InvalidConstraintGuard {} -> 5 instance TVars Warning where apSubst su warn = case warn of DefaultingKind {} -> warn DefaultingWildType {} -> warn DefaultingTo d ty -> DefaultingTo d $! (apSubst su ty) NonExhaustivePropGuards {} -> warn instance FVS Warning where fvs warn = case warn of DefaultingKind {} -> Set.empty DefaultingWildType {} -> Set.empty DefaultingTo _ ty -> fvs ty NonExhaustivePropGuards {} -> Set.empty instance TVars Error where apSubst su err = case err of KindMismatch {} -> err TooManyTypeParams {} -> err TyVarWithParams -> err TooManyTySynParams {} -> err TooFewTyParams {} -> err RecursiveTypeDecls {} -> err SchemaMismatch i t1 t2 -> SchemaMismatch i !$ (apSubst su t1) !$ (apSubst su t2) TypeMismatch src pa t1 t2 -> TypeMismatch src pa !$ (apSubst su t1) !$ (apSubst su t2) RecursiveType src pa t1 t2 -> RecursiveType src pa !$ (apSubst su t1) !$ (apSubst su t2) UnsolvedGoals gs -> UnsolvedGoals !$ apSubst su gs UnsolvableGoals gs -> UnsolvableGoals !$ apSubst su gs UnsolvedDelayedCt g -> UnsolvedDelayedCt !$ (apSubst su g) UnexpectedTypeWildCard -> err TypeVariableEscaped src pa t xs -> TypeVariableEscaped src pa !$ (apSubst su t) .$ xs NotForAll src pa x t -> NotForAll src pa x !$ (apSubst su t) TooManyPositionalTypeParams -> err CannotMixPositionalAndNamedTypeParams -> err BadParameterKind{} -> err UndefinedTypeParameter {} -> err RepeatedTypeParameter {} -> err AmbiguousSize x t -> AmbiguousSize x !$ (apSubst su t) BareTypeApp -> err UndefinedExistVar {} -> err TypeShadowing {} -> err MissingModTParam {} -> err MissingModVParam {} -> err MissingModParam {} -> err FunctorInstanceMissingArgument {} -> err FunctorInstanceBadArgument {} -> err FunctorInstanceMissingName {} -> err FunctorInstanceBadBacktick {} -> err UnsupportedFFIKind {} -> err UnsupportedFFIType src e -> UnsupportedFFIType src !$ apSubst su e NestedConstraintGuard {} -> err DeclarationRequiresSignatureCtrGrd {} -> err InvalidConstraintGuard p -> InvalidConstraintGuard $! apSubst su p TemporaryError {} -> err instance FVS Error where fvs err = case err of KindMismatch {} -> Set.empty TooManyTypeParams {} -> Set.empty TyVarWithParams -> Set.empty TooManyTySynParams {} -> Set.empty TooFewTyParams {} -> Set.empty RecursiveTypeDecls {} -> Set.empty SchemaMismatch _ t1 t2 -> fvs (t1,t2) TypeMismatch _ _ t1 t2 -> fvs (t1,t2) RecursiveType _ _ t1 t2 -> fvs (t1,t2) UnsolvedGoals gs -> fvs gs UnsolvableGoals 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 AmbiguousSize _ t -> fvs t BadParameterKind tp _ -> Set.singleton (TVBound tp) BareTypeApp -> Set.empty UndefinedExistVar {} -> Set.empty TypeShadowing {} -> Set.empty MissingModTParam {} -> Set.empty MissingModVParam {} -> Set.empty MissingModParam {} -> Set.empty FunctorInstanceMissingArgument {} -> Set.empty FunctorInstanceBadArgument {} -> Set.empty FunctorInstanceMissingName {} -> Set.empty FunctorInstanceBadBacktick {} -> Set.empty UnsupportedFFIKind {} -> Set.empty UnsupportedFFIType _ t -> fvs t NestedConstraintGuard {} -> Set.empty DeclarationRequiresSignatureCtrGrd {} -> Set.empty InvalidConstraintGuard p -> fvs p TemporaryError {} -> 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 NonExhaustivePropGuards n -> text "Could not prove that the constraint guards used in defining" <+> pp n <+> text "were exhaustive." instance PP (WithNames Error) where ppPrec _ (WithNames err names) = case err of RecursiveType src pa t1 t2 -> addTVarsDescsAfter names err $ nested "Matching would result in an infinite type." $ vcat ( [ "The type: " <+> ppWithNames names t1 , "occurs in:" <+> ppWithNames names t2 ] ++ ppCtxt pa ++ [ "When checking" <+> pp src ] ) UnexpectedTypeWildCard -> addTVarsDescsAfter names err $ nested "Wild card types are not allowed in this context" $ vcat [ "They cannot be used in:" , bullets [ "type synonyms" , "FFI declarations" , "declarations with constraint guards" ] ] KindMismatch mbsrc k1 k2 -> addTVarsDescsAfter names err $ nested "Incorrect type form." $ vcat $ [ "Expected:" <+> cppKind k1 , "Inferred:" <+> cppKind k2 ] ++ kindMismatchHint k1 k2 ++ maybe [] (\src -> ["When checking" <+> pp src]) mbsrc 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:" (commaSep $ map nm ts) TypeMismatch src pa t1 t2 -> addTVarsDescsAfter names err $ nested "Type mismatch:" $ vcat $ [ "Expected type:" <+> ppWithNames names t1 , "Inferred type:" <+> ppWithNames names t2 ] ++ mismatchHint t1 t2 ++ ppCtxt pa ++ ["When checking" <+> pp src] SchemaMismatch i t1 t2 -> addTVarsDescsAfter names err $ nested ("Type mismatch in module parameter" <+> quotes (pp i)) $ vcat $ [ "Expected type:" <+> ppWithNames names t1 , "Actual type:" <+> ppWithNames names t2 ] UnsolvableGoals gs -> explainUnsolvable names gs UnsolvedGoals 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 src pa t xs -> addTVarsDescsAfter names err $ nested ("The type" <+> ppWithNames names t <+> "is not sufficiently polymorphic.") $ vcat ( [ "It cannot depend on quantified variables:" <+> (commaSep (map (ppWithNames names) xs)) ] ++ ppCtxt pa ++ [ "When checking" <+> pp src ] ) NotForAll src pa x t -> addTVarsDescsAfter names err $ nested "Inferred type is not sufficiently polymorphic." $ vcat ( [ "Quantified variable:" <+> ppWithNames names x , "cannot match type:" <+> ppWithNames names t ] ++ ppCtxt pa ++ [ "When checking" <+> pp src ] ) BadParameterKind tp k -> addTVarsDescsAfter names err $ vcat [ "Illegal kind assigned to type variable:" <+> ppWithNames names tp , "Unexpected:" <+> pp k ] 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 $ nest 2 $ "Multiple definitions for type parameter `" <.> pp x <.> "`:" $$ bullets (map pp rs) AmbiguousSize x t -> let sizeMsg = case t of Just t' -> ["Must be at least:" <+> ppWithNames names t'] Nothing -> [] in addTVarsDescsAfter names err (vcat (["Ambiguous numeric type:" <+> pp (tvarDesc x)] ++ sizeMsg)) BareTypeApp -> "Unexpected bare type application." $$ "Perhaps you meant `( ... ) instead." UndefinedExistVar x -> "Undefined type" <+> quotes (pp x) TypeShadowing this new that -> "Type" <+> text this <+> quotes (pp new) <+> "shadowing an existing" <+> text that <+> "with the same name." MissingModTParam x -> "Missing definition for type parameter" <+> quotes (pp (thing x)) MissingModVParam x -> "Missing definition for value parameter" <+> quotes (pp (thing x)) MissingModParam x -> "Missing module parameter" <+> quotes (pp x) FunctorInstanceMissingArgument i -> "Missing functor argument" <+> quotes (pp i) FunctorInstanceBadArgument i -> "Functor does not have parameter" <+> quotes (pp i) FunctorInstanceMissingName ns i -> "Functor argument does not define" <+> sayNS <+> "parameter" <+> quotes (pp i) where sayNS = case ns of NSValue -> "value" NSType -> "type" NSModule -> "module" FunctorInstanceBadBacktick bad -> case bad of BIPolymorphicArgument i x -> nested "Value parameter may not have a polymorphic type:" $ bullets [ "Module parameter:" <+> pp i , "Value parameter:" <+> pp x , "When instantiatiating a functor using parameterization," $$ "the value parameters need to have a simple type." ] BINested what -> nested "Invalid declarations in parameterized instantiation:" $ bullets $ [ it <+> pp n | (w,n) <- what , let it = case w of BIFunctor -> "functor" BIInterface -> "interface" BIPrimitive -> "primitive" BIAbstractType -> "abstract type" BIForeign -> "foreign import" ] ++ [ "A functor instantiated using parameterization," $$ "may not contain nested functors, interfaces, or primitives." ] BIMultipleParams x -> nested "Repeated parameter name in parameterized instantiation:" $ bullets [ "Parameter name:" <+> pp x , "Parameterized instantiation requires distinct parameter names" ] UnsupportedFFIKind src param k -> nested "Kind of type variable unsupported for FFI: " $ vcat [ pp param <+> colon <+> pp k , "Only type variables of kind" <+> pp KNum <+> "are supported" , "When checking" <+> pp src ] UnsupportedFFIType src t -> vcat [ ppWithNames names t , "When checking" <+> pp src ] NestedConstraintGuard d -> vcat [ "Local declaration" <+> backticks (pp d) <+> "may not use constraint guards." , "Constraint guards may only appear at the top-level of a module." ] DeclarationRequiresSignatureCtrGrd d -> vcat [ "The declaration of" <+> backticks (pp d) <+> "requires a full type signature," , "because it is part of a recursive group with constraint guards." ] InvalidConstraintGuard p -> let d = case tNoUser p of TCon tc _ -> pp tc _ -> ppWithNames names p in vcat [ backticks d <+> "may not be used in a constraint guard." , "Constraint guards support only numeric comparisons and `fin`." ] TemporaryError doc -> doc where bullets xs = vcat [ "•" <+> d | d <- xs ] nested x y = nest 2 (x $$ y) pl 1 x = text "1" <+> text x pl n x = text (show n) <+> text x <.> text "s" nm x = text "`" <.> pp x <.> text "`" kindMismatchHint k1 k2 = case (k1,k2) of (KType,KProp) -> [text "Possibly due to a missing `=>`"] _ -> [] mismatchHint (TRec fs1) (TRec fs2) = hint "Missing" missing ++ hint "Unexpected" extra where missing = displayOrder fs1 \\ displayOrder fs2 extra = displayOrder fs2 \\ displayOrder fs1 hint _ [] = [] hint s [x] = [text s <+> text "field" <+> pp x] hint s xs = [text s <+> text "fields" <+> commaSep (map pp xs)] mismatchHint _ _ = [] noUni = Set.null (Set.filter isFreeTV (fvs err)) ppCtxt pa = if isRootPath pa then [] else [ "Context:" <+> pp pa ] explainUnsolvable :: NameMap -> [Goal] -> Doc explainUnsolvable names gs = addTVarsDescsAfter names gs (bullets (map explain gs)) where bullets xs = vcat [ "•" <+> d | d <- xs ] explain g = let useCtr = hang "Unsolvable constraint:" 2 (ppWithNames names g) in case tNoUser (goal g) of TCon (PC pc) ts -> let tys = [ backticks (ppWithNames names t) | t <- ts ] doc1 = case tys of (doc1' : _) -> doc1' [] -> error "explainUnsolvable: Expected TCon to have at least one argument" custom msg = hang msg 2 (text "arising from" $$ pp (goalSource g) $$ text "at" <+> pp (goalRange g)) in case pc of PEqual -> useCtr PNeq -> useCtr PGeq -> useCtr PFin -> useCtr PPrime -> useCtr PHas sel -> custom ("Type" <+> doc1 "does not have field" <+> f <+> "of type" <+> (tys !! 1)) where f = case sel of P.TupleSel n _ -> int n P.RecordSel fl _ -> backticks (pp fl) P.ListSel n _ -> int n PZero -> custom ("Type" <+> doc1 "does not have `zero`") PLogic -> custom ("Type" <+> doc1 "does not support logical operations.") PRing -> custom ("Type" <+> doc1 "does not support ring operations.") PIntegral -> custom (doc1 "is not an integral type.") PField -> custom ("Type" <+> doc1 "does not support field operations.") PRound -> custom ("Type" <+> doc1 "does not support rounding operations.") PEq -> custom ("Type" <+> doc1 "does not support equality.") PCmp -> custom ("Type" <+> doc1 "does not support comparisons.") PSignedCmp -> custom ("Type" <+> doc1 "does not support signed comparisons.") PLiteral -> let doc2 = tys !! 1 in custom (doc1 "is not a valid literal of type" <+> doc2) PLiteralLessThan -> let doc2 = tys !! 1 in custom ("Type" <+> doc2 "does not contain all literals below" <+> (doc1 <> ".")) PFLiteral -> case ts of ~[m,n,_r,_a] -> let frac = backticks (ppWithNamesPrec names 4 m <> "/" <> ppWithNamesPrec names 4 n) ty = tys !! 3 in custom (frac "is not a valid literal of type" ty) PValidFloat -> case ts of ~[e,p] -> custom (hang "Unsupported floating point parameters:" 2 ("exponent =" <+> ppWithNames names e $$ "precision =" <+> ppWithNames names p)) PAnd -> useCtr PTrue -> useCtr _ -> useCtr -- | This picks the names to use when showing errors and warnings. computeFreeVarNames :: [(Range,Warning)] -> [(Range,Error)] -> NameMap computeFreeVarNames warns errs = mkMap numRoots numVaras `IntMap.union` mkMap otherRoots otherVars {- XXX: Currently we pick the names based on the unique of the variable: smaller uniques get an earlier name (e.g., 100 might get `a` and 200 `b`) This may still lead to changes in the names if the uniques got reordered for some reason. A more stable approach might be to order the variables on their location in the error/warning, but that's quite a bit more code so for now we just go with the simple approximation. -} where mkName x v = (tvUnique x, v) mkMap roots vs = IntMap.fromList (zipWith mkName vs (variants roots)) (numVaras,otherVars) = partition ((== KNum) . kindOf) $ Set.toList $ Set.filter isFreeTV $ fvs (map snd warns, map snd errs) otherRoots = [ "a", "b", "c", "d" ] numRoots = [ "m", "n", "u", "v" ] useUnicode = True suff n | n < 10 && useUnicode = [toEnum (0x2080 + n)] | otherwise = show n variant n x = if n == 0 then x else x ++ suff n variants roots = [ variant n r | n <- [ 0 .. ], r <- roots ] cryptol-3.0.0/src/Cryptol/TypeCheck/FFI.hs0000644000000000000000000001120407346545000016437 0ustar0000000000000000{-# LANGUAGE BlockArguments #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE Safe #-} -- | Checking and conversion of 'Type's to 'FFIType's. module Cryptol.TypeCheck.FFI ( toFFIFunType ) where import Data.Bifunctor import Data.Containers.ListUtils import Data.Either import Cryptol.TypeCheck.FFI.Error import Cryptol.TypeCheck.FFI.FFIType import Cryptol.TypeCheck.SimpType import Cryptol.TypeCheck.Type import Cryptol.Utils.RecordMap import Cryptol.Utils.Types -- | Convert a 'Schema' to a 'FFIFunType', along with any 'Prop's that must be -- satisfied for the 'FFIFunType' to be valid. toFFIFunType :: Schema -> Either FFITypeError ([Prop], FFIFunType) toFFIFunType (Forall params _ t) = -- Remove all type synonyms and simplify the type before processing it case go $ tRebuild' False t of Just (Right (props, fft)) -> Right -- Remove duplicate constraints (nubOrd $ map (fin . TVar . TVBound) params ++ props, fft) Just (Left errs) -> Left $ FFITypeError t $ FFIBadComponentTypes errs Nothing -> Left $ FFITypeError t FFINotFunction where go (TCon (TC TCFun) [argType, retType]) = Just case toFFIType argType of Right (ps, ffiArgType) -> case go retType of Just (Right (ps', ffiFunType)) -> Right ( ps ++ ps' , ffiFunType { ffiArgTypes = ffiArgType : ffiArgTypes ffiFunType } ) Just (Left errs) -> Left errs Nothing -> case toFFIType retType of Right (ps', ffiRetType) -> Right ( ps ++ ps' , FFIFunType { ffiTParams = params , ffiArgTypes = [ffiArgType], .. } ) Left err -> Left [err] Left err -> Left case go retType of Just (Right _) -> [err] Just (Left errs) -> err : errs Nothing -> case toFFIType retType of Right _ -> [err] Left err' -> [err, err'] go _ = Nothing -- | Convert a 'Type' to a 'FFIType', along with any 'Prop's that must be -- satisfied for the 'FFIType' to be valid. toFFIType :: Type -> Either FFITypeError ([Prop], FFIType) toFFIType t = case t of TCon (TC TCBit) [] -> Right ([], FFIBool) (toFFIBasicType -> Just r) -> (\fbt -> ([], FFIBasic fbt)) <$> r TCon (TC TCSeq) _ -> (\(szs, fbt) -> (map fin szs, FFIArray szs fbt)) <$> go t where go (toFFIBasicType -> Just r) = case r of Right fbt -> Right ([], fbt) Left err -> Left $ FFITypeError t $ FFIBadComponentTypes [err] go (TCon (TC TCSeq) [sz, ty]) = first (sz:) <$> go ty go _ = Left $ FFITypeError t FFIBadArrayType TCon (TC (TCTuple _)) ts -> case partitionEithers $ map toFFIType ts of ([], unzip -> (pss, fts)) -> Right (concat pss, FFITuple fts) (errs, _) -> Left $ FFITypeError t $ FFIBadComponentTypes errs TRec tMap -> case sequence resMap of Right resMap' -> Right $ FFIRecord <$> recordMapAccum (\ps (ps', ft) -> (ps' ++ ps, ft)) [] resMap' Left _ -> Left $ FFITypeError t $ FFIBadComponentTypes $ lefts $ displayElements resMap where resMap = fmap toFFIType tMap _ -> Left $ FFITypeError t FFIBadType -- | Convert a 'Type' to a 'FFIBasicType', returning 'Nothing' if it isn't a -- basic type and 'Left' if it is but there was some other issue with it. toFFIBasicType :: Type -> Maybe (Either FFITypeError FFIBasicType) toFFIBasicType t = case t of TCon (TC TCSeq) [TCon (TC (TCNum n)) [], TCon (TC TCBit) []] | n <= 8 -> word FFIWord8 | n <= 16 -> word FFIWord16 | n <= 32 -> word FFIWord32 | n <= 64 -> word FFIWord64 | otherwise -> Just $ Left $ FFITypeError t FFIBadWordSize where word = Just . Right . FFIBasicVal . FFIWord n TCon (TC TCFloat) [TCon (TC (TCNum e)) [], TCon (TC (TCNum p)) []] | (e, p) == float32ExpPrec -> float FFIFloat32 | (e, p) == float64ExpPrec -> float FFIFloat64 | otherwise -> Just $ Left $ FFITypeError t FFIBadFloatSize where float = Just . Right . FFIBasicVal . FFIFloat e p TCon (TC TCInteger) [] -> integer Nothing TCon (TC TCIntMod) [n] -> integer $ Just n TCon (TC TCRational) [] -> Just $ Right $ FFIBasicRef FFIRational _ -> Nothing where integer = Just . Right . FFIBasicRef . FFIInteger fin :: Type -> Prop fin t = TCon (PC PFin) [t] cryptol-3.0.0/src/Cryptol/TypeCheck/FFI/0000755000000000000000000000000007346545000016105 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/TypeCheck/FFI/Error.hs0000644000000000000000000000516207346545000017536 0ustar0000000000000000{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Safe #-} -- | Errors from typechecking foreign functions. module Cryptol.TypeCheck.FFI.Error where import Control.DeepSeq import GHC.Generics import Cryptol.TypeCheck.PP import Cryptol.TypeCheck.Subst import Cryptol.TypeCheck.Type data FFITypeError = FFITypeError Type FFITypeErrorReason deriving (Show, Generic, NFData) data FFITypeErrorReason = FFIBadWordSize | FFIBadFloatSize | FFIBadArrayType | FFIBadComponentTypes [FFITypeError] | FFIBadType | FFINotFunction deriving (Show, Generic, NFData) instance TVars FFITypeError where apSubst su (FFITypeError t r) = FFITypeError !$ apSubst su t !$ apSubst su r instance TVars FFITypeErrorReason where apSubst su r = case r of FFIBadWordSize -> r FFIBadFloatSize -> r FFIBadArrayType -> r FFIBadComponentTypes errs -> FFIBadComponentTypes !$ apSubst su errs FFIBadType -> r FFINotFunction -> r instance FVS FFITypeError where fvs (FFITypeError t r) = fvs (t, r) instance FVS FFITypeErrorReason where fvs r = case r of FFIBadWordSize -> mempty FFIBadFloatSize -> mempty FFIBadArrayType -> mempty FFIBadComponentTypes errs -> fvs errs FFIBadType -> mempty FFINotFunction -> mempty instance PP (WithNames FFITypeError) where ppPrec _ (WithNames (FFITypeError t r) names) = nest 2 $ "Type unsupported for FFI:" $$ vcat [ ppWithNames names t , "Due to:" , ppWithNames names r ] instance PP (WithNames FFITypeErrorReason) where ppPrec _ (WithNames r names) = case r of FFIBadWordSize -> vcat [ "Unsupported word size" , "Only words of up to 64 bits are supported" ] FFIBadFloatSize -> vcat [ "Unsupported Float format" , "Only Float32 and Float64 are supported" ] FFIBadArrayType -> vcat [ "Unsupported sequence element type" , "Only words or floats are supported as the element type of" , "(possibly multidimensional) sequences" ] FFIBadComponentTypes errs -> indent 2 $ vcat $ map (ppWithNames names) errs FFIBadType -> vcat [ "Only Bit, words, floats, Integer, Z, Rational, sequences, or structs" , "or tuples of the above are supported as FFI argument or return types" ] FFINotFunction -> "FFI binding must be a function" cryptol-3.0.0/src/Cryptol/TypeCheck/FFI/FFIType.hs0000644000000000000000000000412207346545000017706 0ustar0000000000000000{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Safe #-} -- | This module defines a nicer intermediate representation of Cryptol types -- allowed for the FFI, which the typechecker generates then stores in the AST. -- This way the FFI evaluation code does not have to examine the raw type -- signatures again. module Cryptol.TypeCheck.FFI.FFIType where import Control.DeepSeq import GHC.Generics import Cryptol.TypeCheck.Type import Cryptol.Utils.Ident import Cryptol.Utils.RecordMap -- | Type of a foreign function. data FFIFunType = FFIFunType { -- | Note: any type variables within this function type must be bound here. ffiTParams :: [TParam] , ffiArgTypes :: [FFIType] , ffiRetType :: FFIType } deriving (Show, Generic, NFData) -- | Type of a value that can be passed to or returned from a foreign function. data FFIType = FFIBool | FFIBasic FFIBasicType -- | [n][m][p]T --> FFIArray [n, m, p] T | FFIArray [Type] FFIBasicType | FFITuple [FFIType] | FFIRecord (RecordMap Ident FFIType) deriving (Show, Generic, NFData) -- | Types which can be elements of FFI arrays. data FFIBasicType = FFIBasicVal FFIBasicValType | FFIBasicRef FFIBasicRefType deriving (Show, Generic, NFData) -- | Basic type which is passed and returned directly by value. data FFIBasicValType = FFIWord Integer -- ^ The size of the Cryptol type FFIWordSize -- ^ The machine word size that it corresponds to | FFIFloat Integer -- ^ Exponent Integer -- ^ Precision FFIFloatSize -- ^ The machine float size that it corresponds to deriving (Show, Generic, NFData) data FFIWordSize = FFIWord8 | FFIWord16 | FFIWord32 | FFIWord64 deriving (Show, Generic, NFData) data FFIFloatSize = FFIFloat32 | FFIFloat64 deriving (Show, Generic, NFData) -- | Basic type which is passed and returned by reference through a parameter. data FFIBasicRefType = FFIInteger (Maybe Type) -- ^ Modulus (Just for Z, Nothing for Integer) | FFIRational deriving (Show, Generic, NFData) cryptol-3.0.0/src/Cryptol/TypeCheck/Infer.hs0000644000000000000000000014050107346545000017101 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 BlockArguments #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Redundant <$>" #-} {-# HLINT ignore "Redundant <&>" #-} module Cryptol.TypeCheck.Infer ( checkE , checkSigB , inferTopModule , inferBinds , checkTopDecls ) where import Data.Text(Text) import qualified Data.Text as Text import Cryptol.ModuleSystem.Name (lookupPrimDecl,nameLoc, nameIdent) 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, checkPropGuards) import Cryptol.TypeCheck.Instantiate import Cryptol.TypeCheck.Subst (listSubst,apSubst,(@@),isEmptySubst) import Cryptol.TypeCheck.Unify(rootPath) import Cryptol.TypeCheck.Module import Cryptol.TypeCheck.FFI import Cryptol.TypeCheck.FFI.FFIType import Cryptol.Utils.Ident import Cryptol.Utils.Panic(panic) import Cryptol.Utils.RecordMap import Cryptol.IR.TraverseNames(mapNames) import Cryptol.Utils.PP (pp) import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Set as Set import Data.List(foldl', sortBy, groupBy, partition) import Data.Either(partitionEithers) import Data.Maybe(isJust, fromMaybe, mapMaybe) import Data.Ratio(numerator,denominator) import Data.Traversable(forM) import Data.Function(on) import Control.Monad(zipWithM, unless, foldM, forM_, mplus, zipWithM, unless, foldM, forM_, mplus, when) -- import Debug.Trace -- import Cryptol.TypeCheck.PP inferTopModule :: P.Module Name -> InferM TCTopEntity inferTopModule m = case P.mDef m of P.NormalModule ds -> do newModuleScope (thing (P.mName m)) (P.exportedDecls ds) checkTopDecls ds proveModuleTopLevel endModule P.FunctorInstance f as inst -> do mb <- doFunctorInst (P.ImpTop <$> P.mName m) f as inst Nothing case mb of Just mo -> pure mo Nothing -> panic "inferModule" ["Didnt' get a module"] P.InterfaceModule sig -> do newTopSignatureScope (thing (P.mName m)) checkSignature sig endTopSignature -- | Construct a Prelude primitive in the parsed AST. mkPrim :: String -> InferM (P.Expr Name) mkPrim str = do nm <- mkPrim' str return (P.EVar nm) -- | Construct a Prelude primitive in the parsed AST. mkPrim' :: String -> InferM Name mkPrim' str = do prims <- getPrimMap return (lookupPrimDecl (prelPrim (Text.pack str)) prims) desugarLiteral :: P.Literal -> InferM (P.Expr Name) desugarLiteral lit = do l <- curRange numberPrim <- mkPrim "number" fracPrim <- mkPrim "fraction" 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.DecLit _ -> [ ] P.PolyLit _n -> [ ("rep", P.TSeq P.TWild P.TBit) ] P.ECFrac fr info -> let arg f = P.PosInst (P.TNum (f fr)) rnd = P.PosInst (P.TNum (case info of P.DecFrac _ -> 0 P.BinFrac _ -> 1 P.OctFrac _ -> 1 P.HexFrac _ -> 1)) in P.EAppT fracPrim [ arg numerator, arg denominator, rnd ] P.ECChar c -> number [ ("val", P.TNum (toInteger (fromEnum c))) , ("rep", tBits (8 :: Integer)) ] P.ECString s -> P.ETyped (P.EList [ P.ELit (P.ECChar c) | 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] -> TypeWithSource -> 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 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 -> do (e1,ds1) <- checkLocalDecls ds (appTys e ts tGoal) pure (EWhere e1 ds1) P.ELocated e r -> do e' <- inRange r (appTys e ts tGoal) cs <- getCallStacks if cs then pure (ELocated r e') else pure e' P.EGenerate {} -> mono P.ETuple {} -> mono P.ERecord {} -> mono P.EUpd {} -> mono P.ESel {} -> mono P.EList {} -> mono P.EFromTo {} -> mono P.EFromToBy {} -> mono P.EFromToDownBy {} -> mono P.EFromToLessThan {} -> 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.EPrefix {} -> 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 -> TypeWithSource -> 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.EGenerate e -> do prim <- mkPrim "generate" checkE (P.EApp prim e) tGoal P.ELit l@(P.ECNum _ (P.DecLit _)) -> do e <- desugarLiteral 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 (twsType tGoal) } appTys e [arg] tGoal P.ELit l -> (`checkE` tGoal) =<< desugarLiteral l P.ETuple es -> do etys <- expectTuple (length es) tGoal let mkTGoal n t e = WithSource t (TypeOfTupleField n) (getLoc e) es' <- zipWithM checkE es (zipWith3 mkTGoal [1..] etys es) return (ETuple es') P.ERecord fs -> do es <- expectRec fs tGoal let checkField f (e,t) = checkE e (WithSource t (TypeOfRecordField f) (getLoc e)) es' <- traverseRecordMap checkField es return (ERec es') P.EUpd x fs -> checkRecUpd x fs tGoal P.ESel e l -> do let src = selSrc l t <- newType src KType e' <- checkE e (WithSource t src (getLoc expr)) f <- newHasGoal l t (twsType tGoal) return (hasDoSelect f e') P.EList [] -> do (len,a) <- expectSeq tGoal expectFin 0 (WithSource len LenOfSeq (getLoc expr)) return (EList [] a) P.EList es -> do (len,a) <- expectSeq tGoal expectFin (length es) (WithSource len LenOfSeq (getLoc expr)) let checkElem e = checkE e (WithSource a TypeOfSeqElement (getLoc e)) es' <- mapM checkElem es return (EList es' a) P.EFromToBy isStrict t1 t2 t3 mety | isStrict -> do l <- curRange let fs = [("first",t1),("bound",t2),("stride",t3)] ++ case mety of Just ety -> [("a",ety)] Nothing -> [] prim <- mkPrim "fromToByLessThan" let e' = P.EAppT prim [ P.NamedInst P.Named{ name = Located l (packIdent x), value = y } | (x,y) <- fs ] checkE e' tGoal | otherwise -> do l <- curRange let fs = [("first",t1),("last",t2),("stride",t3)] ++ case mety of Just ety -> [("a",ety)] Nothing -> [] prim <- mkPrim "fromToBy" let e' = P.EAppT prim [ P.NamedInst P.Named{ name = Located l (packIdent x), value = y } | (x,y) <- fs ] checkE e' tGoal P.EFromToDownBy isStrict t1 t2 t3 mety | isStrict -> do l <- curRange let fs = [("first",t1),("bound",t2),("stride",t3)] ++ case mety of Just ety -> [("a",ety)] Nothing -> [] prim <- mkPrim "fromToDownByGreaterThan" let e' = P.EAppT prim [ P.NamedInst P.Named{ name = Located l (packIdent x), value = y } | (x,y) <- fs ] checkE e' tGoal | otherwise -> do l <- curRange let fs = [("first",t1),("last",t2),("stride",t3)] ++ case mety of Just ety -> [("a",ety)] Nothing -> [] prim <- mkPrim "fromToDownBy" let e' = P.EAppT prim [ P.NamedInst P.Named{ name = Located l (packIdent x), value = y } | (x,y) <- fs ] checkE e' tGoal P.EFromToLessThan t1 t2 mety -> do l <- curRange let fs0 = case mety of Just ety -> [("a", ety)] Nothing -> [] let fs = [("first", t1), ("bound", t2)] ++ fs0 prim <- mkPrim "fromToLessThan" let e' = P.EAppT prim [ P.NamedInst P.Named { name = Located l (packIdent x), value = y } | (x,y) <- fs ] checkE e' tGoal 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 inferred <- smallest ts ctrs <- unify (WithSource len LenOfSeq (getLoc expr)) inferred newGoals CtComprehension ctrs ds <- combineMaps dss e' <- withMonoTypes ds (checkE e (WithSource a TypeOfSeqElement (getLoc e))) return (EComp len a e' mss') where -- the renamer should have made these checks already? 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 ] duplicates = mapMaybe multiple . groupBy ((==) `on` thing) . sortBy (compare `on` thing) where multiple xs@(x : _ : _) = Just (thing x, map srcRange xs) multiple _ = Nothing P.EAppT e fs -> appTys e (map uncheckedTypeArg fs) tGoal P.EApp e1 e2 -> do let argSrc = TypeOfArg noArgDescr t1 <- newType argSrc KType e1' <- checkE e1 (WithSource (tFun t1 (twsType tGoal)) FunApp (getLoc e1)) e2' <- checkE e2 (WithSource t1 argSrc (getLoc e2)) return (EApp e1' e2') P.EIf e1 e2 e3 -> do e1' <- checkE e1 (WithSource tBit TypeOfIfCondExpr (getLoc e1)) e2' <- checkE e2 tGoal e3' <- checkE e3 tGoal return (EIf e1' e2' e3') P.EWhere e ds -> do (e1,ds1) <- checkLocalDecls ds (checkE e tGoal) pure (EWhere e1 ds1) P.ETyped e t -> do tSig <- checkTypeOfKind t KType e' <- checkE e (WithSource tSig TypeFromUserAnnotation (getLoc expr)) 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 desc ps e -> checkFun desc ps e tGoal P.ELocated e r -> do e' <- inRange r (checkE e tGoal) cs <- getCallStacks if cs then pure (ELocated r e') else pure e' 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.EPrefix op e -> do prim <- mkPrim case op of P.PrefixNeg -> "negate" P.PrefixComplement -> "complement" checkE (P.EApp prim e) tGoal P.EParens e -> checkE e tGoal checkRecUpd :: Maybe (P.Expr Name) -> [ P.UpdField Name ] -> TypeWithSource -> InferM Expr checkRecUpd mb fs tGoal = case mb of -- { _ | fs } ~~> \r -> { r | fs } Nothing -> do r <- newLocalName NSValue (packIdent "r") let p = P.PVar Located { srcRange = nameLoc r, thing = r } fe = P.EFun P.emptyFunDesc [p] (P.EUpd (Just (P.EVar r)) fs) checkE fe tGoal Just e -> do e1 <- checkE e tGoal fst <$> foldM doUpd (e1, getLoc e) fs where doUpd (e,eloc) (P.UpdField how sels v) = case sels of [l] -> case how of P.UpdSet -> do let src = selSrc s ft <- newType src KType v1 <- checkE v (WithSource ft src eloc) d <- newHasGoal s (twsType tGoal) ft pure (hasDoSet d e v1, eloc `rCombMaybe` getLoc v) P.UpdFun -> do let src = selSrc s ft <- newType src KType v1 <- checkE v (WithSource (tFun ft ft) src eloc) -- XXX: ^ may be used a different src? d <- newHasGoal s (twsType tGoal) ft tmp <- newLocalName NSValue (packIdent "rf") let e' = EVar tmp pure ( hasDoSet d e' (EApp v1 (hasDoSelect d e')) `EWhere` [ NonRecursive Decl { dName = tmp , dSignature = tMono (twsType tGoal) , dDefinition = DExpr e , dPragmas = [] , dInfix = False , dFixity = Nothing , dDoc = Nothing } ] , eloc `rCombMaybe` getLoc v ) where s = thing l _ -> panic "checkRecUpd/doUpd" [ "Expected exactly 1 field label" , "Got: " ++ show (length sels) ] expectSeq :: TypeWithSource -> InferM (Type,Type) expectSeq tGoal@(WithSource ty src rng) = case ty of TUser _ _ ty' -> expectSeq (WithSource ty' src rng) TCon (TC TCSeq) [a,b] -> return (a,b) TVar _ -> do tys@(a,b) <- genTys newGoals CtExactType =<< unify tGoal (tSeq a b) return tys _ -> do tys@(a,b) <- genTys recordErrorLoc rng (TypeMismatch src rootPath ty (tSeq a b)) return tys where genTys = do a <- newType LenOfSeq KNum b <- newType TypeOfSeqElement KType return (a,b) expectTuple :: Int -> TypeWithSource -> InferM [Type] expectTuple n tGoal@(WithSource ty src rng) = case ty of TUser _ _ ty' -> expectTuple n (WithSource ty' src rng) TCon (TC (TCTuple n')) tys | n == n' -> return tys TVar _ -> do tys <- genTys newGoals CtExactType =<< unify tGoal (tTuple tys) return tys _ -> do tys <- genTys recordErrorLoc rng (TypeMismatch src rootPath ty (tTuple tys)) return tys where genTys =forM [ 0 .. n - 1 ] $ \ i -> newType (TypeOfTupleField i) KType expectRec :: RecordMap Ident (Range, a) -> TypeWithSource -> InferM (RecordMap Ident (a, Type)) expectRec fs tGoal@(WithSource ty src rng) = case ty of TUser _ _ ty' -> expectRec fs (WithSource ty' src rng) TRec ls | Right r <- zipRecords (\_ (_rng,v) t -> (v,t)) fs ls -> pure r _ -> do res <- traverseRecordMap (\nm (_rng,v) -> do t <- newType (TypeOfRecordField nm) KType return (v, t)) fs let tys = fmap snd res case ty of TVar TVFree{} -> do ps <- unify tGoal (TRec tys) newGoals CtExactType ps _ -> recordErrorLoc rng (TypeMismatch src rootPath ty (TRec tys)) return res expectFin :: Int -> TypeWithSource -> InferM () expectFin n tGoal@(WithSource ty src rng) = case ty of TUser _ _ ty' -> expectFin n (WithSource ty' src rng) TCon (TC (TCNum n')) [] | toInteger n == n' -> return () _ -> newGoals CtExactType =<< unify tGoal (tNum n) expectFun :: Maybe Name -> Int -> TypeWithSource -> InferM ([Type],Type) expectFun mbN n (WithSource ty0 src rng) = go [] n ty0 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 (WithSource ty src rng) (foldr tFun res args) newGoals CtExactType ps _ -> recordErrorLoc rng (TypeMismatch src rootPath ty (foldr tFun res args)) return (reverse tys ++ args, res) | otherwise = return (reverse tys, ty) genArgs arity = forM [ 1 .. arity ] $ \ ix -> newType (TypeOfArg (ArgDescr mbN (Just ix))) KType checkHasType :: Type -> TypeWithSource -> InferM () checkHasType inferredType tGoal = do ps <- unify tGoal inferredType case ps of [] -> return () _ -> newGoals CtExactType ps checkFun :: P.FunDesc Name -> [P.Pattern Name] -> P.Expr Name -> TypeWithSource -> InferM Expr checkFun _ [] e tGoal = checkE e tGoal checkFun (P.FunDesc fun offset) ps e tGoal = inNewScope do let descs = [ TypeOfArg (ArgDescr fun (Just n)) | n <- [ 1 + offset .. ] ] (tys,tRes) <- expectFun fun (length ps) tGoal let srcs = zipWith3 WithSource tys descs (map getLoc ps) largs <- sequence (zipWith checkP ps srcs) let ds = Map.fromList [ (thing x, x { thing = t }) | (x,t) <- zip largs tys ] e1 <- withMonoTypes ds (checkE e (WithSource tRes TypeOfRes (twsRange tGoal))) 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 :: P.Pattern Name -> TypeWithSource -> InferM (Located Name) checkP p tGoal@(WithSource _ src rng0) = do (x, t) <- inferP p ps <- unify tGoal (thing t) let rngMb = getLoc p `mplus` rng0 rng = fromMaybe emptyRange rngMb let mkErr = recordErrorLoc rngMb . UnsolvedGoals . (:[]) . Goal (CtPattern src) 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 :: P.Pattern Name -> InferM (Name, Located Type) inferP 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 p (WithSource tSig TypeFromUserAnnotation (getLoc t)) 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 p n <- newType LenOfCompGen KNum e' <- checkE e (WithSource (tSeq n (thing t)) GeneratorOfListComp (getLoc e)) 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 generalization. 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) checkNumericConstraintGuardsOK isTopLevel sigs noSigs 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 {- Here we also check that: * Numeric constraint guards appear only at the top level * All definitions in a recursive groups with numberic constraint guards have signatures The reason is to avoid interference between local constraints coming from the guards and type inference. It might be possible to relex these requirements, but this requires some more careful thought on the interaction between the two, and the effects on pricniple types. -} checkNumericConstraintGuardsOK :: Bool -> [P.Bind Name] -> [P.Bind Name] -> InferM () checkNumericConstraintGuardsOK isTopLevel haveSig noSig = do unless isTopLevel (mapM_ (mkErr NestedConstraintGuard) withGuards) unless (null withGuards) (mapM_ (mkErr DeclarationRequiresSignatureCtrGrd) noSig) where mkErr f b = do let nm = P.bName b inRange (srcRange nm) (recordError (f (nameIdent (thing nm)))) withGuards = filter hasConstraintGuards haveSig -- When desugaring constraint guards we check that they have signatures, -- so no need to look at noSig hasConstraintGuards b = case thing (P.bDef b) of P.DPropGuards {} -> True _ -> False {- | 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 let wildOk = case thing bDef of P.DForeign {} -> NoWildCards P.DPrim -> NoWildCards P.DExpr {} -> AllowWildCards P.DPropGuards {} -> NoWildCards s1 <- checkSchema wildOk 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,errs) = defaultAndSimplify maybeAmbig here0 extendSubst defSu mapM_ recordWarning ws mapM_ recordError errs 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 = TPUnifyVar , 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 DForeign t -> DForeign t , 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.DForeign -> panic "checkMonoB" ["Foreign with no signature?"] P.DExpr e -> do let nm = thing (P.bName b) let tGoal = WithSource t (DefinitionOf nm) (getLoc b) e1 <- checkFun (P.FunDesc (Just nm) 0) (P.bParams b) e tGoal 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 } P.DPropGuards _ -> tcPanic "checkMonoB" [ "Used constraint guards without a signature at " , show . pp $ P.bName 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) = let name = thing (P.bName b) in case thing (P.bDef b) of -- XXX what should we do with validSchema in this case? P.DPrim -> return Decl { dName = name , dSignature = Forall as asmps0 t0 , dDefinition = DPrim , dPragmas = P.bPragmas b , dInfix = P.bInfix b , dFixity = P.bFixity b , dDoc = P.bDoc b } P.DForeign -> do let loc = getLoc b name' = thing $ P.bName b src = DefinitionOf name' inRangeMb loc do -- Ensure all type params are of kind # forM_ as \a -> when (tpKind a /= KNum) $ recordErrorLoc loc $ UnsupportedFFIKind src a $ tpKind a withTParams as do ffiFunType <- case toFFIFunType (Forall as asmps0 t0) of Right (props, ffiFunType) -> ffiFunType <$ do ffiGoals <- traverse (newGoal (CtFFI name')) props proveImplication True (Just name') as asmps0 $ validSchema ++ ffiGoals Left err -> do recordErrorLoc loc $ UnsupportedFFIType src err -- Just a placeholder type pure FFIFunType { ffiTParams = as, ffiArgTypes = [] , ffiRetType = FFITuple [] } pure Decl { dName = thing (P.bName b) , dSignature = Forall as asmps0 t0 , dDefinition = DForeign ffiFunType , 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 (t, asmps, e2) <- checkBindDefExpr [] asmps0 e0 return Decl { dName = name , 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 } P.DPropGuards cases0 -> inRangeMb (getLoc b) $ withTParams as $ do asmps1 <- applySubstPreds asmps0 t1 <- applySubst t0 cases1 <- mapM checkPropGuardCase cases0 exh <- checkExhaustive (P.bName b) as asmps1 (map fst cases1) unless exh $ -- didn't prove exhaustive i.e. none of the guarding props -- necessarily hold recordWarning (NonExhaustivePropGuards name) let schema = Forall as asmps1 t1 return Decl { dName = name , dSignature = schema , dDefinition = DExpr (foldr ETAbs (foldr EProofAbs (EPropGuards cases1 t1) asmps1) as) , dPragmas = P.bPragmas b , dInfix = P.bInfix b , dFixity = P.bFixity b , dDoc = P.bDoc b } where checkBindDefExpr :: [Prop] -> [Prop] -> P.Expr Name -> InferM (Type, [Prop], Expr) checkBindDefExpr asmpsSign asmps1 e0 = do (e1,cs0) <- collectGoals $ do let nm = thing (P.bName b) tGoal = WithSource t0 (DefinitionOf nm) (getLoc b) e1 <- checkFun (P.FunDesc (Just nm) 0) (P.bParams b) e0 tGoal addGoals validSchema () <- simplifyAllConstraints -- XXX: using `asmps` also? return e1 asmps2 <- applySubstPreds asmps1 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 -- if a goal mentions any of these variables, we'll commit to -- solving it now. stickyVars = Set.fromList (map tpVar as) `Set.union` fvs asmps2 (stay,leave) = findKeep stickyVars [] [ (c, fvs c) | c <- cs ] addGoals leave -- includes asmpsSign for the sake of implication, but doesn't actually -- include them in the resulting asmps su <- proveImplication True (Just (thing (P.bName b))) as (asmpsSign <> asmps2) stay extendSubst su let asmps = concatMap pSplitAnd (apSubst su asmps2) t <- applySubst t0 e2 <- applySubst e1 pure (t, asmps, e2) {- | Given a DPropGuards of the form @ f : {...} A f | (B1, B2) => ... | (C1, C2, C2) => ... @ we check that it is exhaustive by trying to prove the following implications: @ A /\ ~B1 => C1 /\ C2 /\ C3 A /\ ~B2 => C1 /\ C2 /\ C3 @ The implications were derive by the following general algorithm: - Find that @(C1, C2, C3)@ is the guard that has the most conjuncts, so we will keep it on the RHS of the generated implications in order to minimize the number of implications we need to check. - Negate @(B1, B2)@ which yields @(~B1) \/ (~B2)@. This is a disjunction, so we need to consider a branch for each disjunct --- one branch gets the assumption @~B1@ and another branch gets the assumption @~B2@. Each branch's implications need to be proven independently. -} checkExhaustive :: Located Name -> [TParam] -> [Prop] -> [[Prop]] -> InferM Bool checkExhaustive name as asmps guards = case sortBy cmpByLonger guards of [] -> pure False -- XXX: we should check the asmps are unsatisfiable longest : rest -> doGoals (theAlts rest) (map toGoal longest) where cmpByLonger props1 props2 = compare (length props2) (length props1) -- reversed, so that longets is first theAlts :: [[Prop]] -> [[Prop]] theAlts = map concat . sequence . map chooseNeg -- Choose one of the things to negate chooseNeg ps = case ps of [] -> [] p : qs -> (pNegNumeric p ++ qs) : [ p : alts | alts <- chooseNeg qs ] -- Try to validate all cases doGoals todo gs = case todo of [] -> pure True alt : more -> do ok <- canProve (asmps ++ alt) gs if ok then doGoals more gs else pure False toGoal :: Prop -> Goal toGoal prop = Goal { goalSource = CtPropGuardsExhaustive (thing name) , goalRange = srcRange name , goal = prop } canProve :: [Prop] -> [Goal] -> InferM Bool canProve asmps' goals = tryProveImplication (Just (thing name)) as asmps' goals {- | This function does not validate anything---it just translates into the type-checkd syntax. The actual validation of the guard will happen when the (automatically generated) function corresponding to the guard is checked, assuming 'ExpandpropGuards' did its job correctly. -} checkPropGuardCase :: P.PropGuardCase Name -> InferM ([Prop],Expr) checkPropGuardCase (P.PropGuardCase guards e0) = do ps <- checkPropGuards guards tys <- mapM (`checkType` Nothing) ts let rhsTs = foldl ETApp (getV eV) tys rhsPs = foldl (\e _p -> EProofApp e) rhsTs ps rhs = foldl EApp rhsPs (map getV es) pure (ps,rhs) where (e1,es) = P.asEApps e0 (eV,ts) = case e1 of P.EAppT ex1 tis -> (ex1, map getT tis) _ -> (e1, []) getV ex = case ex of P.EVar x -> EVar x _ -> bad "Expression is not a variable." getT ti = case ti of P.PosInst t -> t P.NamedInst {} -> bad "Unexpeceted NamedInst" bad msg = panic "checkPropGuardCase" [msg] -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- checkLocalDecls :: [P.Decl Name] -> InferM a -> InferM (a,[DeclGroup]) checkLocalDecls ds0 k = do newLocalScope forM_ ds0 \d -> checkDecl False d Nothing a <- k (ds,_tySyns) <- endLocalScope pure (a,ds) checkTopDecls :: [P.TopDecl Name] -> InferM () checkTopDecls = mapM_ checkTopDecl where checkTopDecl decl = case decl of P.Decl tl -> checkDecl True (P.tlValue tl) (thing <$> P.tlDoc tl) P.TDNewtype tl -> do t <- checkNewtype (P.tlValue tl) (thing <$> P.tlDoc tl) addNewtype t P.DPrimType tl -> do t <- checkPrimType (P.tlValue tl) (thing <$> P.tlDoc tl) addPrimType t P.DInterfaceConstraint _ cs -> inRange (srcRange cs) do cs1 <- checkParameterConstraints [ cs { thing = c } | c <- thing cs ] addParameterConstraints cs1 P.DModule tl -> selectorScope case P.mDef m of P.NormalModule ds -> do newSubmoduleScope (thing (P.mName m)) (thing <$> P.tlDoc tl) (P.exportedDecls ds) checkTopDecls ds proveModuleTopLevel endSubmodule P.FunctorInstance f as inst -> do let doc = thing <$> P.tlDoc tl _ <- doFunctorInst (P.ImpNested <$> P.mName m) f as inst doc pure () P.InterfaceModule sig -> do let doc = P.thing <$> P.tlDoc tl inRange (srcRange (P.mName m)) do newSignatureScope (thing (P.mName m)) doc checkSignature sig endSignature where P.NestedModule m = P.tlValue tl P.DModParam p -> inRange (srcRange (P.mpSignature p)) do let binds = P.mpRenaming p suMap = Map.fromList [ (y,x) | (x,y) <- Map.toList binds ] actualName x = Map.findWithDefault x x suMap ips <- lookupSignature (thing (P.mpSignature p)) let actualTys = [ mapNames actualName mp | mp <- Map.elems (mpnTypes ips) ] actualTS = [ mapNames actualName ts | ts <- Map.elems (mpnTySyn ips) ] actualCtrs = [ mapNames actualName prop | prop <- mpnConstraints ips ] actualVals = [ mapNames actualName vp | vp <- Map.elems (mpnFuns ips) ] param = ModParam { mpName = P.mpName p , mpIface = thing (P.mpSignature p) , mpQual = P.mpAs p , mpParameters = ModParamNames { mpnTypes = Map.fromList [ (mtpName tp, tp) | tp <- actualTys ] , mpnTySyn = Map.fromList [ (tsName ts, ts) | ts <- actualTS ] , mpnConstraints = actualCtrs , mpnFuns = Map.fromList [ (mvpName vp, vp) | vp <- actualVals ] , mpnDoc = thing <$> P.mpDoc p } } mapM_ addParamType actualTys addParameterConstraints actualCtrs mapM_ addParamFun actualVals mapM_ addTySyn actualTS addModParam param P.DImport {} -> pure () P.Include {} -> bad "Include" P.DParamDecl {} -> bad "DParamDecl" bad x = panic "checkTopDecl" [ x ] checkSignature :: P.Signature Name -> InferM () checkSignature sig = do forM_ (P.sigTypeParams sig) \pt -> addParamType =<< checkParameterType pt mapM_ checkSigDecl (P.sigDecls sig) addParameterConstraints =<< checkParameterConstraints (P.sigConstraints sig) forM_ (P.sigFunParams sig) \f -> addParamFun =<< checkParameterFun f proveModuleTopLevel checkSigDecl :: P.SigDecl Name -> InferM () checkSigDecl decl = case decl of P.SigTySyn ts mbD -> addTySyn =<< checkTySyn ts mbD P.SigPropSyn ps mbD -> addTySyn =<< checkPropSyn ps mbD checkDecl :: Bool -> P.Decl Name -> Maybe Text -> InferM () checkDecl isTopLevel d mbDoc = case d of P.DBind c -> do ~[b] <- inferBinds isTopLevel False [c] addDecls (NonRecursive b) P.DRec bs -> do bs1 <- inferBinds isTopLevel True bs addDecls (Recursive bs1) P.DType t -> do t1 <- checkTySyn t mbDoc addTySyn t1 P.DProp t -> do t1 <- checkPropSyn t mbDoc addTySyn t1 P.DLocated d' r -> inRange r (checkDecl isTopLevel d' mbDoc) P.DSignature {} -> bad "DSignature" P.DFixity {} -> bad "DFixity" P.DPragma {} -> bad "DPragma" P.DPatBind {} -> bad "DPatBind" where bad x = panic "checkDecl" [x] checkParameterFun :: P.ParameterFun Name -> InferM ModVParam checkParameterFun x = do (s,gs) <- checkSchema NoWildCards (P.pfSchema x) su <- proveImplication False (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 } tcPanic :: String -> [String] -> a tcPanic l msg = panic ("[TypeCheck] " ++ l) msg cryptol-3.0.0/src/Cryptol/TypeCheck/InferTypes.hs0000644000000000000000000003371007346545000020131 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 Control.Monad(guard) 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 (PrimIdent(..), preludeName) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Misc(anyJust) 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) -- | A default configuration for using Z3, where -- the solver prelude is expected to be found -- in the given search path. defaultSolverConfig :: [FilePath] -> SolverConfig defaultSolverConfig searchPath = SolverConfig { solverPath = "z3" , solverArgs = [ "-smt2", "-in" ] , solverVerbose = 0 , solverPreludePath = searchPath } -- | 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'. , saturatedPropSet :: Set Prop -- ^ The set of nonliteral goals, saturated by all superclass implications , literalGoals :: Map TVar LitGoal -- ^ An entry @(a,t)@ corresponds to @Literal t a@. , literalLessThanGoals :: Map TVar LitGoal -- ^ An entry @(a,t)@ corresponds to @LiteralLessThan 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 }) litLessThanGoalToGoal :: (TVar,LitGoal) -> Goal litLessThanGoalToGoal (a,g) = g { goal = pLiteralLessThan (goal g) (TVar a) } goalToLitLessThanGoal :: Goal -> Maybe (TVar,LitGoal) goalToLitLessThanGoal g = do (tn,a) <- matchMaybe $ do (tn,b) <- aLiteralLessThan (goal g) a <- aTVar b return (tn,a) return (a, g { goal = tn }) emptyGoals :: Goals emptyGoals = Goals { goalSet = Set.empty , saturatedPropSet = Set.empty , literalGoals = Map.empty , literalLessThanGoals = Map.empty } nullGoals :: Goals -> Bool nullGoals gs = Set.null (goalSet gs) && Map.null (literalGoals gs) && Map.null (literalLessThanGoals gs) fromGoals :: Goals -> [Goal] fromGoals gs = map litGoalToGoal (Map.toList (literalGoals gs)) ++ map litLessThanGoalToGoal (Map.toList (literalLessThanGoals gs)) ++ Set.toList (goalSet gs) goalsFromList :: [Goal] -> Goals goalsFromList = foldr insertGoal emptyGoals insertGoal :: Goal -> Goals -> Goals insertGoal g gls | Just (a,newG) <- goalToLitGoal g = -- XXX: here we are arbitrarily using the info of the first goal, -- which could lead to a confusing location for a constraint. let jn g1 g2 = g1 { goal = tMax (goal g1) (goal g2) } in gls { literalGoals = Map.insertWith jn a newG (literalGoals gls) , saturatedPropSet = Set.insert (pFin (TVar a)) (saturatedPropSet gls) } | Just (a,newG) <- goalToLitLessThanGoal g = let jn g1 g2 = g1 { goal = tMax (goal g1) (goal g2) } in gls { literalLessThanGoals = Map.insertWith jn a newG (literalLessThanGoals gls) } -- If the goal is already implied by some other goal, skip it | Set.member (goal g) (saturatedPropSet gls) = gls -- Otherwise, it is not already implied, add it and saturate | otherwise = gls { goalSet = gs', saturatedPropSet = sps' } where ips = superclassSet (goal g) igs = Set.map (\p -> g{ goal = p}) ips -- remove all the goals that are implied by ips gs' = Set.insert g (Set.difference (goalSet gls) igs) -- add the goal and all its implied toals to the saturated set sps' = Set.insert (goal g) (Set.union (saturatedPropSet gls) ips) -- | 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 -- ^ This is the "name" of the constraint, -- used to find the solution for ellaboration. , 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 TypeSource -- ^ Constraints arising from type-checking patterns | CtModuleInstance Range -- ^ Instantiating a parametrized module | CtPropGuardsExhaustive Name -- ^ Checking that a use of prop guards is exhastive | CtFFI Name -- ^ Constraints on a foreign declaration required -- by the FFI (e.g. sequences must be finite) deriving (Show, Generic, NFData) selSrc :: Selector -> TypeSource selSrc l = case l of RecordSel la _ -> TypeOfRecordField la TupleSel n _ -> TypeOfTupleField n ListSel _ _ -> TypeOfSeqElement 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 CtPropGuardsExhaustive _ -> src CtFFI _ -> 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 -- TODO? use `hang` here instead to indent things after "where" | 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 = vcat (frontMsg ++ [d] ++ backMsg) where (vs1,vs2) = Set.partition isFreeTV (fvs t) frontMsg | null vs1 = [] | otherwise = [hang "Failed to infer the following types:" 2 (vcat (map desc1 (Set.toList vs1)))] desc1 v = "•" <+> ppWithNames nm v <.> comma <+> pp (tvInfo v) backMsg | null vs2 = [] | otherwise = [hang "where" 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 ad -> "checking a pattern:" <+> pp ad CtModuleInstance r -> "module instantiation at" <+> pp r CtPropGuardsExhaustive n -> "exhaustion check for prop guards used in defining" <+> pp n CtFFI f -> "declaration of foreign function" <+> pp f ppUse :: Expr -> Doc ppUse expr = case expr of EVar (isPrelPrim -> Just prim) | prim == "number" -> "literal or demoted expression" | prim == "fraction" -> "fractional literal" | prim == "infFrom" -> "infinite enumeration" | prim == "infFromThen" -> "infinite enumeration (with step)" | prim == "fromTo" -> "finite enumeration" | prim == "fromThenTo" -> "finite enumeration" _ -> "expression" <+> pp expr where isPrelPrim x = do PrimIdent p i <- asPrim x guard (p == preludeName) pure i instance PP (WithNames Goal) where ppPrec _ (WithNames g names) = hang (ppWithNames names (goal g)) 2 (text "arising from" $$ pp (goalSource g) $$ text "at" <+> pp (goalRange g)) instance PP (WithNames DelayedCt) where ppPrec _ (WithNames d names) = sig $$ hang "we need to show that" 2 (vcat ( vars ++ asmps ++ [ hang "the following constraints hold:" 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 [] -> [] xs -> ["for any type" <+> commaSep (map (ppWithNames ns1) xs)] asmps = case dctAsmps d of [] -> [] xs -> [hang "assuming" 2 (vcat (bullets (map (ppWithNames ns1) xs)))] ns1 = addTNames (dctForall d) names cryptol-3.0.0/src/Cryptol/TypeCheck/Instantiate.hs0000644000000000000000000001567207346545000020333 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 :: TypeSource -> Kind -> MaybeCheckedType -> InferM Type checkTyParam src k mb = case mb of Checked t | k == k' -> pure t | otherwise -> do recordError (KindMismatch (Just src) 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 tpName p of 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 = let a = tpVar tp src = tvarDesc (tvInfo a) rng = Just (tvarSource (tvInfo a)) in unify (WithSource (TVar a) src rng) ty cryptol-3.0.0/src/Cryptol/TypeCheck/Interface.hs0000644000000000000000000000505407346545000017741 0ustar0000000000000000{-# LANGUAGE Safe #-} module Cryptol.TypeCheck.Interface where import qualified Data.Map as Map import Data.Set(Set) import qualified Data.Set as Set import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Exports(allExported) import Cryptol.TypeCheck.AST -- | Information about a declaration to be stored an in interface. mkIfaceDecl :: Decl -> IfaceDecl mkIfaceDecl d = IfaceDecl { ifDeclName = dName d , ifDeclSig = dSignature d , ifDeclIsPrim = case dDefinition d of DPrim {} -> True _ -> False , ifDeclPragmas = dPragmas d , ifDeclInfix = dInfix d , ifDeclFixity = dFixity d , ifDeclDoc = dDoc d } -- | Compute information about the names in a module. genIfaceNames :: ModuleG name -> IfaceNames name genIfaceNames m = IfaceNames { ifsName = mName m , ifsNested = mNested m , ifsDefines = genModDefines m , ifsPublic = allExported (mExports m) , ifsDoc = mDoc m } -- | Things defines by a module genModDefines :: ModuleG name -> Set Name genModDefines m = Set.unions [ Map.keysSet (mTySyns m) , Map.keysSet (mNewtypes m) , Set.fromList (map ntConName (Map.elems (mNewtypes m))) , Map.keysSet (mPrimTypes m) , Set.fromList (map dName (concatMap groupDecls (mDecls m))) , Map.keysSet (mSubmodules m) , Map.keysSet (mFunctors m) , Map.keysSet (mSignatures m) ] `Set.difference` nestedInSet (mNested m) where nestedInSet = Set.unions . map inNested . Set.toList inNested x = case Map.lookup x (mSubmodules m) of Just y -> ifsDefines y `Set.union` nestedInSet (ifsNested y) Nothing -> Set.empty -- must be signature or a functor genIface :: ModuleG name -> IfaceG name genIface m = genIfaceWithNames (genIfaceNames m) m -- | Generate an Iface from a typechecked module. genIfaceWithNames :: IfaceNames name -> ModuleG ignored -> IfaceG name genIfaceWithNames names m = Iface { ifNames = names , ifDefines = IfaceDecls { ifTySyns = mTySyns m , ifNewtypes = mNewtypes m , ifAbstractTypes = mPrimTypes m , ifDecls = Map.fromList [ (qn,mkIfaceDecl d) | dg <- mDecls m , d <- groupDecls dg , let qn = dName d ] , ifModules = mSubmodules m , ifSignatures = mSignatures m , ifFunctors = genIface <$> mFunctors m } , ifParams = mParams m } cryptol-3.0.0/src/Cryptol/TypeCheck/Kind.hs0000644000000000000000000003737707346545000016743 0ustar0000000000000000-- | -- Module : Cryptol.TypeCheck.Kind -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE BlockArguments #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Cryptol.TypeCheck.Kind ( checkType , checkSchema , checkNewtype , checkPrimType , checkTySyn , checkPropSyn , checkParameterType , checkParameterConstraints , checkPropGuards ) where import qualified Cryptol.Parser.AST as P 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 Cryptol.Utils.RecordMap import qualified Data.Map as Map import Data.List(sortBy,groupBy) import Data.Maybe(fromMaybe) import Data.Function(on) import Data.Text (Text) import Control.Monad(unless,when,mplus) -- | 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 mempty) $ 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 {- | Validate parsed propositions that appear in the guard of a PropGuard. * Note that we don't validate the well-formedness constraints here---instead, they'd be validated when the signature for the auto generated function corresponding guard is checked. * We also check that there are no wild-cards in the constraints. -} checkPropGuards :: [Located (P.Prop Name)] -> InferM [Prop] checkPropGuards props = do (newPs,_gs) <- collectGoals (mapM check props) pure newPs where check lp = inRange (srcRange lp) do let p = thing lp (_,ps) <- withTParams NoWildCards schemaParam [] (checkProp p) case tNoUser ps of TCon (PC x) _ | x `elem` [PEqual,PNeq,PGeq,PFin,PTrue] -> pure () _ -> recordError (InvalidConstraintGuard ps) pure ps -- | Check a module parameter declarations. Nothing much to check, -- we just translate from one syntax to another. checkParameterType :: P.ParameterType Name -> InferM ModTParam checkParameterType a = do let mbDoc = P.ptDoc a k = cvtK (P.ptKind a) n = thing (P.ptName a) return ModTParam { mtpKind = k, mtpName = n, mtpDoc = mbDoc } -- | Check a type-synonym declaration. checkTySyn :: P.TySyn Name -> Maybe Text -> 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 Text -> 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 Text -> InferM Newtype checkNewtype (P.Newtype x as con fs) mbD = do ((as1,fs1),gs) <- collectGoals $ inRange (srcRange x) $ do r <- withTParams NoWildCards newtypeParam as $ flip traverseRecordMap fs $ \_n (rng,f) -> kInRange rng $ doCheckType f (Just KType) simplifyAllConstraints return r return Newtype { ntName = thing x , ntParams = as1 , ntConstraints = map goal gs , ntConName = con , ntFields = fs1 , ntDoc = mbD } checkPrimType :: P.PrimType Name -> Maybe Text -> InferM AbstractType checkPrimType p mbD = do let (as,cs) = P.primTCts p (as',cs') <- withTParams NoWildCards TPPrimParam 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 (ts1,k1) <- appTy ts (kindOf nt) let as = ntParams nt ts2 <- checkParams as ts1 let su = zip as ts2 ps1 <- mapM (`kInstantiateT` su) (ntConstraints nt) kNewGoals (CtPartialTypeFun (ntName nt)) ps1 checkKind (TNewtype nt ts2) k k1 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 Nothing 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 <$> traverseRecordMap 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 mb -> do newK <- case (k, cvtK <$> mb) of (Just a, Just b) -> do unless (a == b) (kRecordError (KindMismatch Nothing a b)) pure (Just b) (a,b) -> pure (mplus a b) doCheckType t newK P.TInfix t x _ u-> doCheckType (P.TUser (thing x) [t, u]) k P.TTyApp _fs -> do kRecordError BareTypeApp kNewType TypeWildCard KNum where checkF _nm (rng,v) = kInRange rng $ doCheckType v (Just KType) -- | Validate a parsed proposition. checkProp :: P.Prop Name -- ^ Proposition that need to be checked -> KindM Prop -- ^ 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 Nothing k1 k2) kNewType TypeErrorPlaceHolder k1 checkKind t _ _ = return t cryptol-3.0.0/src/Cryptol/TypeCheck/Module.hs0000644000000000000000000003232407346545000017266 0ustar0000000000000000{-# Language BlockArguments, ImplicitParams #-} module Cryptol.TypeCheck.Module (doFunctorInst) where import Data.List(partition) import Data.Text(Text) import Data.Map(Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Control.Monad(unless,forM_) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Ident(Ident,Namespace(..),isInfixIdent) import Cryptol.Parser.Position (Range,Located(..), thing) import qualified Cryptol.Parser.AST as P import Cryptol.ModuleSystem.Name(nameIdent) import Cryptol.ModuleSystem.Interface ( IfaceG(..), IfaceDecls(..), IfaceNames(..), IfaceDecl(..) , filterIfaceDecls ) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Error import Cryptol.TypeCheck.Subst(Subst,listParamSubst,apSubst,mergeDistinctSubst) import Cryptol.TypeCheck.Solve(proveImplication) import Cryptol.TypeCheck.Monad import Cryptol.TypeCheck.Instantiate(instantiateWith) import Cryptol.TypeCheck.ModuleInstance import Cryptol.TypeCheck.ModuleBacktickInstance(MBQual, doBacktickInstance) doFunctorInst :: Located (P.ImpName Name) {- ^ Name for the new module -} -> Located (P.ImpName Name) {- ^ Functor being instantiated -} -> P.ModuleInstanceArgs Name {- ^ Instance arguments -} -> Map Name Name {- ^ Instantitation. These is the renaming for the functor that arises from generativity (i.e., it is something that will make the names "fresh"). -} -> Maybe Text {- ^ Documentation -} -> InferM (Maybe TCTopEntity) doFunctorInst m f as inst doc = inRange (srcRange m) do mf <- lookupFunctor (thing f) argIs <- checkArity (srcRange f) mf as m2 <- do as2 <- mapM checkArg argIs let (tySus,decls) = unzip [ (su,ds) | DefinedInst su ds <- as2 ] let ?tSu = mergeDistinctSubst tySus ?vSu = inst let m1 = moduleInstance mf m2 = m1 { mName = m , mDoc = Nothing , mParamTypes = mempty , mParamFuns = mempty , mParamConstraints = mempty , mParams = mempty , mDecls = map NonRecursive (concat decls) ++ mDecls m1 } let (tps,tcs,vps) = unzip3 [ (xs,cs,fs) | ParamInst xs cs fs <- as2 ] tpSet = Set.unions tps tpSet' = Set.map snd (Set.unions tps) emit p = Set.null (freeParams (thing p) `Set.intersection` tpSet') (emitPs,delayPs) = partition emit (mParamConstraints m1) forM_ emitPs \lp -> newGoals (CtModuleInstance (srcRange lp)) [thing lp] doBacktickInstance tpSet (map thing delayPs ++ concat tcs) (Map.unions vps) m2 case thing m of P.ImpTop mn -> newModuleScope mn (mExports m2) P.ImpNested mn -> newSubmoduleScope mn doc (mExports m2) mapM_ addTySyn (Map.elems (mTySyns m2)) mapM_ addNewtype (Map.elems (mNewtypes m2)) mapM_ addPrimType (Map.elems (mPrimTypes m2)) addSignatures (mSignatures m2) addSubmodules (mSubmodules m2) addFunctors (mFunctors m2) mapM_ addDecls (mDecls m2) case thing m of P.ImpTop {} -> Just <$> endModule P.ImpNested {} -> endSubmodule >> pure Nothing data ActualArg = UseParameter ModParam -- ^ Instantiate using this parameter | UseModule (IfaceG ()) -- ^ Instantiate using this module | AddDeclParams -- ^ Instantiate by adding parameters {- | Validate a functor application, just checking the argument names. The result associates a module parameter with the concrete way it should be instantiated, which could be: * `Left` instanciate using another parameter that is in scope * `Right` instanciate using a module, with the given interface -} checkArity :: Range {- ^ Location for reporting errors -} -> ModuleG () {- ^ The functor being instantiated -} -> P.ModuleInstanceArgs Name {- ^ The arguments -} -> InferM [(Range, ModParam, ActualArg)] {- ^ Associates functor parameters with the interfaces of the instantiating modules -} checkArity r mf args = case args of P.DefaultInstArg arg -> let i = Located { srcRange = srcRange arg , thing = head (Map.keys ps0) } in checkArgs [] ps0 [ P.ModuleInstanceNamedArg i arg ] P.NamedInstArgs as -> checkArgs [] ps0 as P.DefaultInstAnonArg {} -> panic "checkArity" [ "DefaultInstAnonArg" ] where ps0 = mParams mf checkArgs done ps as = case as of [] -> do forM_ (Map.keys ps) \p -> recordErrorLoc (Just r) (FunctorInstanceMissingArgument p) pure done P.ModuleInstanceNamedArg ll lm : more -> case Map.lookup (thing ll) ps of Just i -> do arg <- case thing lm of P.ModuleArg m -> Just . UseModule <$> lookupModule m P.ParameterArg p -> do mb <- lookupModParam p case mb of Nothing -> do inRange (srcRange lm) (recordError (MissingModParam p)) pure Nothing Just a -> pure (Just (UseParameter a)) P.AddParams -> pure (Just AddDeclParams) let next = case arg of Nothing -> done Just a -> (srcRange lm, i, a) : done checkArgs next (Map.delete (thing ll) ps) more Nothing -> do recordErrorLoc (Just (srcRange ll)) (FunctorInstanceBadArgument (thing ll)) checkArgs done ps more data ArgInst = DefinedInst Subst [Decl] -- ^ Argument that defines the params | ParamInst (Set (MBQual TParam)) [Prop] (Map (MBQual Name) Type) -- ^ Argument that add parameters -- The type parameters are in their module type parameter -- form (i.e., tpFlav is TPModParam) {- | Check the argument to a functor parameter. Returns: * A substitution which will replace the parameter types with the concrete types that were provided * Some declarations that define the parameters in terms of the provided values. * XXX: Extra parameters for instantiation by adding params -} checkArg :: (Range, ModParam, ActualArg) -> InferM ArgInst checkArg (r,expect,actual') = case actual' of AddDeclParams -> paramInst UseParameter {} -> definedInst UseModule {} -> definedInst where paramInst = do let as = Set.fromList (map (qual . mtpParam) (Map.elems (mpnTypes params))) cs = map thing (mpnConstraints params) check = checkSimpleParameterValue r (mpName expect) qual a = (mpQual expect, a) fs <- Map.mapMaybeWithKey (\_ v -> v) <$> mapM check (mpnFuns params) pure (ParamInst as cs (Map.mapKeys qual fs)) definedInst = do tRens <- mapM (checkParamType r tyMap) (Map.toList (mpnTypes params)) let renSu = listParamSubst (concat tRens) {- Note: the constraints from the signature are already added to the constraints for the functor and they are checked all at once in doFunctorInst -} vDecls <- concat <$> mapM (checkParamValue r vMap) [ s { mvpType = apSubst renSu (mvpType s) } | s <- Map.elems (mpnFuns params) ] pure (DefinedInst renSu vDecls) params = mpParameters expect -- Things provided by the argument module tyMap :: Map Ident (Kind, Type) vMap :: Map Ident (Name, Schema) (tyMap,vMap) = case actual' of UseParameter mp -> ( nameMapToIdentMap fromTP (mpnTypes ps) , nameMapToIdentMap fromVP (mpnFuns ps) ) where ps = mpParameters mp fromTP tp = (mtpKind tp, TVar (TVBound (mtpParam tp))) fromVP vp = (mvpName vp, mvpType vp) UseModule actual -> ( Map.unions [ nameMapToIdentMap fromTS (ifTySyns decls) , nameMapToIdentMap fromNewtype (ifNewtypes decls) , nameMapToIdentMap fromPrimT (ifAbstractTypes decls) ] , nameMapToIdentMap fromD (ifDecls decls) ) where localNames = ifsPublic (ifNames actual) isLocal x = x `Set.member` localNames -- Things defined by the argument module decls = filterIfaceDecls isLocal (ifDefines actual) fromD d = (ifDeclName d, ifDeclSig d) fromTS ts = (kindOf ts, tsDef ts) fromNewtype nt = (kindOf nt, TNewtype nt []) fromPrimT pt = (kindOf pt, TCon (abstractTypeTC pt) []) AddDeclParams -> panic "checkArg" ["AddDeclParams"] nameMapToIdentMap :: (a -> b) -> Map Name a -> Map Ident b nameMapToIdentMap f m = Map.fromList [ (nameIdent n, f v) | (n,v) <- Map.toList m ] -- | Check a type parameter to a module. checkParamType :: Range {- ^ Location for error reporting -} -> Map Ident (Kind,Type) {- ^ Actual types -} -> (Name,ModTParam) {- ^ Type parameter -} -> InferM [(TParam,Type)] {- ^ Mapping from parameter name to actual type -} checkParamType r tyMap (name,mp) = let i = nameIdent name expectK = mtpKind mp in case Map.lookup i tyMap of Nothing -> do recordErrorLoc (Just r) (FunctorInstanceMissingName NSType i) pure [] Just (actualK,actualT) -> do unless (expectK == actualK) (recordErrorLoc (Just r) (KindMismatch (Just (TVFromModParam name)) expectK actualK)) pure [(mtpParam mp, actualT)] -- | Check a value parameter to a module. checkParamValue :: Range {- ^ Location for error reporting -} -> Map Ident (Name,Schema) {- ^ Actual values -} -> ModVParam {- ^ The parameter we are checking -} -> InferM [Decl] {- ^ Mapping from parameter name to definition -} checkParamValue r vMap mp = let name = mvpName mp i = nameIdent name expectT = mvpType mp in case Map.lookup i vMap of Nothing -> do recordErrorLoc (Just r) (FunctorInstanceMissingName NSValue i) pure [] Just actual -> do e <- mkParamDef r (name,expectT) actual let d = Decl { dName = name , dSignature = expectT , dDefinition = DExpr e , dPragmas = [] , dInfix = isInfixIdent (nameIdent name) , dFixity = mvpFixity mp , dDoc = mvpDoc mp } pure [d] checkSimpleParameterValue :: Range {- ^ Location for error reporting -} -> Ident {- ^ Name of functor parameter -} -> ModVParam {- ^ Module parameter -} -> InferM (Maybe Type) {- ^ Type to add to things, `Nothing` on err -} checkSimpleParameterValue r i mp = case (sVars sch, sProps sch) of ([],[]) -> pure (Just (sType sch)) _ -> do recordErrorLoc (Just r) (FunctorInstanceBadBacktick (BIPolymorphicArgument i (nameIdent (mvpName mp)))) pure Nothing where sch = mvpType mp {- | Make an "adaptor" that instantiates the paramter into the form expected by the functor. If the actual type is: > {x} P => t and the provided type is: > f : {y} Q => s The result, if successful would be: /\x \{P}. f @a {Q} To do this we need to find types `a` to instantiate `y`, and prove that: {x} P => Q[a/y] /\ s = t -} mkParamDef :: Range {- ^ Location of instantiation for error reporting -} -> (Name,Schema) {- ^ Name and type of parameter -} -> (Name,Schema) {- ^ Name and type of actual argument -} -> InferM Expr mkParamDef r (pname,wantedS) (arg,actualS) = do (e,todo) <- collectGoals $ withTParams (sVars wantedS) do (e,t) <- instantiateWith pname(EVar arg) actualS [] props <- unify WithSource { twsType = sType wantedS , twsSource = TVFromModParam arg , twsRange = Just r } t newGoals (CtModuleInstance r) props pure e su <- proveImplication False (Just pname) (sVars wantedS) (sProps wantedS) todo let res = foldr ETAbs res1 (sVars wantedS) res1 = foldr EProofAbs (apSubst su e) (sProps wantedS) applySubst res cryptol-3.0.0/src/Cryptol/TypeCheck/ModuleBacktickInstance.hs0000644000000000000000000003005607346545000022407 0ustar0000000000000000{-# Language ImplicitParams #-} {-# Language FlexibleInstances #-} {-# Language RecursiveDo #-} {-# Language BlockArguments #-} {-# Language RankNTypes #-} {-# Language OverloadedStrings #-} module Cryptol.TypeCheck.ModuleBacktickInstance ( MBQual , doBacktickInstance ) where import Data.Set(Set) import qualified Data.Set as Set import Data.Map(Map) import qualified Data.Map as Map import MonadLib import Data.List(group,sort) import Data.Maybe(mapMaybe) import qualified Data.Text as Text import Cryptol.Utils.Ident(ModPath(..), modPathIsOrContains,Namespace(..) , Ident, mkIdent, identText , ModName, modNameChunksText ) import Cryptol.Utils.PP(pp) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.RecordMap(RecordMap,recordFromFields,recordFromFieldsErr) import Cryptol.Parser.Position import Cryptol.ModuleSystem.Name( nameModPath, nameModPathMaybe, nameIdent, mapNameIdent) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Error import qualified Cryptol.TypeCheck.Monad as TC type MBQual a = (Maybe ModName, a) {- | Rewrite declarations to add the given module parameters. Assumes the renaming due to the instantiation has already happened. The module being rewritten should not contain any nested functors (or module with only top-level constraints) because it is not clear how to parameterize the parameters. -} doBacktickInstance :: Set (MBQual TParam) -> [Prop] -> Map (MBQual Name) Type -> ModuleG (Located (ImpName Name)) -> TC.InferM (ModuleG (Located (ImpName Name))) doBacktickInstance as ps mp m | null as && null ps && Map.null mp = pure m | otherwise = runReaderT RO { isOurs = \x -> case nameModPathMaybe x of Nothing -> False Just y -> ourPath `modPathIsOrContains` y , tparams = Set.toList as , constraints = ps , vparams = mp , newNewtypes = Map.empty } do unless (null bad) (recordError (FunctorInstanceBadBacktick (BINested bad))) rec ts <- doAddParams nt mTySyns nt <- doAddParams nt mNewtypes ds <- doAddParams nt mDecls pure m { mTySyns = ts , mNewtypes = nt , mDecls = ds } where bad = mkBad mFunctors BIFunctor ++ mkBad mPrimTypes BIAbstractType ++ mkBad mSignatures BIInterface mkBad sel a = [ (a,k) | k <- Map.keys (sel m) ] ourPath = case thing (mName m) of ImpTop mo -> TopModule mo ImpNested mo -> Nested (nameModPath mo) (nameIdent mo) doAddParams nt sel = mapReader (\ro -> ro { newNewtypes = nt }) (addParams (sel m)) type RewM = ReaderT RO TC.InferM recordError :: Error -> RewM () recordError e = lift (TC.recordError e) data RO = RO { isOurs :: Name -> Bool , tparams :: [MBQual TParam] , constraints :: [Prop] , vparams :: Map (MBQual Name) Type , newNewtypes :: Map Name Newtype } class AddParams t where addParams :: t -> RewM t instance AddParams a => AddParams (Map Name a) where addParams = mapM addParams instance AddParams a => AddParams [a] where addParams = mapM addParams instance AddParams Newtype where addParams nt = do (tps,cs) <- newTypeParams TPNewtypeParam rProps <- rewTypeM tps (ntConstraints nt) rFields <- rewTypeM tps (ntFields nt) pure nt { ntParams = pDecl tps ++ ntParams nt , ntConstraints = cs ++ rProps , ntFields = rFields } instance AddParams TySyn where addParams ts = do (tps,cs) <- newTypeParams TPTySynParam rProps <- rewTypeM tps (tsConstraints ts) rDef <- rewTypeM tps (tsDef ts) pure ts { tsParams = pDecl tps ++ tsParams ts , tsConstraints = cs ++ rProps , tsDef = rDef } instance AddParams DeclGroup where addParams dg = case dg of Recursive ds -> Recursive <$> addParams ds NonRecursive d -> NonRecursive <$> addParams d instance AddParams Decl where addParams d = case dDefinition d of DPrim -> bad BIPrimitive DForeign {} -> bad BIForeign DExpr e -> do (tps,cs) <- newTypeParams TPSchemaParam (vps,bs) <- newValParams tps let s = dSignature d ty1 <- rewTypeM tps (sType s) ps1 <- rewTypeM tps (sProps s) let ty2 = foldr tFun ty1 (map snd bs) e1 <- rewValM tps (length cs) vps e let (das,e2) = splitWhile splitTAbs e1 (dcs,e3) = splitWhile splitProofAbs e2 e4 = foldr (uncurry EAbs) e3 bs e5 = foldr EProofAbs e4 (cs ++ dcs) e6 = foldr ETAbs e5 (pDecl tps ++ das) s1 = Forall { sVars = pDecl tps ++ sVars s , sProps = cs ++ ps1 , sType = ty2 } pure d { dDefinition = DExpr e6 , dSignature = s1 } where bad w = do recordError (FunctorInstanceBadBacktick (BINested [(w,dName d)])) pure d data Params decl use = Params { pDecl :: [decl] , pUse :: [use] , pSubst :: Map decl use } noParams :: Params decl use noParams = Params { pDecl = [] , pUse = [] , pSubst = Map.empty } qualLabel :: Maybe ModName -> Ident -> Ident qualLabel mb i = case mb of Nothing -> i Just mn -> let txt = Text.intercalate "'" (modNameChunksText mn ++ [identText i]) in mkIdent txt type TypeParams = Params TParam Type type ValParams = Params Name Expr newTypeParams :: (Name -> TPFlavor) -> RewM (TypeParams,[Prop]) newTypeParams flav = do ro <- ask let newFlaf q = flav . mapNameIdent (qualLabel q) as <- lift (forM (tparams ro) \(q,a) -> TC.freshTParam (newFlaf q) a) let bad = [ x | x : _ : _ <- group (sort (map nameIdent (mapMaybe tpName as))) ] forM_ bad \i -> recordError (FunctorInstanceBadBacktick (BIMultipleParams i)) let ts = map (TVar . TVBound) as su = Map.fromList (zip (map snd (tparams ro)) ts) ps = Params { pDecl = as, pUse = ts, pSubst = su } cs <- rewTypeM ps (constraints ro) pure (ps,cs) -- Note: we pass all value parameters as a record newValParams :: TypeParams -> RewM (ValParams, [(Name,Type)]) newValParams tps = do ro <- ask let vps = vparams ro if Map.null vps then pure (noParams, []) else do xts <- forM (Map.toList vps) \((q,x),t) -> do t1 <- rewTypeM tps t let l = qualLabel q (nameIdent x) pure (x, l, t1) let (xs,ls,ts) = unzip3 xts fs = zip ls ts sel l = RecordSel l (Just ls) t <- case recordFromFieldsErr fs of Right ok -> pure (TRec ok) Left (x,_) -> do recordError (FunctorInstanceBadBacktick (BIMultipleParams x)) pure (TRec (recordFromFields fs)) r <- lift (TC.newLocalName NSValue (mkIdent "params")) let e = EVar r pure ( Params { pDecl = [r] , pUse = [e] , pSubst = Map.fromList [ (x,ESel e (sel l)) | (x,l) <- zip xs ls ] } , [ (r,t) ] ) liftRew :: ((?isOurs :: Name -> Bool, ?newNewtypes :: Map Name Newtype) => a) -> RewM a liftRew x = do ro <- ask let ?isOurs = isOurs ro ?newNewtypes = newNewtypes ro pure x rewTypeM :: RewType t => TypeParams -> t -> RewM t rewTypeM ps x = do let ?tparams = ps liftRew rewType <*> pure x rewValM :: RewVal t => TypeParams -> Int -> ValParams -> t -> RewM t rewValM ts cs vs x = do let ?tparams = ts ?cparams = cs ?vparams = vs liftRew rew <*> pure x class RewType t where rewType :: ( ?isOurs :: Name -> Bool , ?newNewtypes :: Map Name Newtype -- Lazy , ?tparams :: TypeParams ) => t -> t instance RewType Type where rewType ty = case ty of TCon tc ts | TC (TCAbstract (UserTC x _)) <- tc , ?isOurs x -> TCon tc (pUse ?tparams ++ rewType ts) | otherwise -> TCon tc (rewType ts) TVar x -> case x of TVBound x' -> case Map.lookup x' (pSubst ?tparams) of Just t -> t Nothing -> ty TVFree {} -> panic "rawType" ["Free unification variable"] TUser f ts t | ?isOurs f -> TUser f (pUse ?tparams ++ rewType ts) (rewType t) | otherwise -> TUser f (rewType ts) (rewType t) TRec fs -> TRec (rewType fs) TNewtype tdef ts | ?isOurs nm -> TNewtype tdef' (pUse ?tparams ++ rewType ts) | otherwise -> TNewtype tdef (rewType ts) where nm = ntName tdef tdef' = case Map.lookup nm ?newNewtypes of Just yes -> yes Nothing -> panic "rewType" [ "Missing recursive newtype" , show (pp nm) ] instance RewType a => RewType [a] where rewType = fmap rewType instance RewType b => RewType (RecordMap a b) where rewType = fmap rewType instance RewType Schema where rewType sch = Forall { sVars = sVars sch , sProps = rewType (sProps sch) , sType = rewType (sType sch) } class RewVal t where rew :: ( ?isOurs :: Name -> Bool , ?newNewtypes :: Map Name Newtype -- Lazy , ?tparams :: TypeParams , ?cparams :: Int -- Number of constraitns , ?vparams :: ValParams ) => t -> t instance RewVal a => RewVal [a] where rew = fmap rew instance RewVal b => RewVal (RecordMap a b) where rew = fmap rew {- x as cs vs --> e (newAs ++ as) (newCS ++ cs) (newVS ++ vs) -} instance RewVal Expr where rew expr = case expr of EList es t -> EList (rew es) (rewType t) ETuple es -> ETuple (rew es) ERec fs -> ERec (rew fs) ESel e l -> ESel (rew e) l ESet t e1 s e2 -> ESet (rewType t) (rew e1) s (rew e2) EIf e1 e2 e3 -> EIf (rew e1) (rew e2) (rew e3) EComp t1 t2 e mss -> EComp (rewType t1) (rewType t2) (rew e) (rew mss) EVar x -> tryVarApp case Map.lookup x (pSubst ?vparams) of Just p -> p Nothing -> expr ETApp e t -> tryVarApp (ETApp (rew e) (rewType t)) EProofApp e -> tryVarApp (EProofApp (rew e)) EApp e1 e2 -> EApp (rew e1) (rew e2) ETAbs a e -> ETAbs a (rew e) EAbs x t e -> EAbs x (rewType t) (rew e) ELocated r e -> ELocated r (rew e) EProofAbs p e -> EProofAbs (rewType p) (rew e) EWhere e ds -> EWhere (rew e) (rew ds) EPropGuards gs t -> EPropGuards gs' (rewType t) where gs' = [ (rewType <$> p, rew e) | (p,e) <- gs ] where tryVarApp orElse = case splitExprInst expr of (EVar x, ts, cs) | ?isOurs x -> let ets = foldl ETApp (EVar x) (pUse ?tparams ++ rewType ts) eps = iterate EProofApp ets !! (?cparams + cs) evs = foldl EApp eps (pUse ?vparams) in evs _ -> orElse instance RewVal DeclGroup where rew dg = case dg of Recursive ds -> Recursive (rew ds) NonRecursive d -> NonRecursive (rew d) instance RewVal Decl where rew d = d { dDefinition = rew (dDefinition d) , dSignature = rewType (dSignature d) } instance RewVal DeclDef where rew def = case def of DPrim -> def DForeign {} -> def DExpr e -> DExpr (rew e) instance RewVal Match where rew ma = case ma of From x t1 t2 e -> From x (rewType t1) (rewType t2) (rew e) Let d -> Let (rew d) cryptol-3.0.0/src/Cryptol/TypeCheck/ModuleInstance.hs0000644000000000000000000001266607346545000020762 0ustar0000000000000000{-# Language ImplicitParams, ConstraintKinds #-} module Cryptol.TypeCheck.ModuleInstance where import Data.Map(Map) import qualified Data.Map as Map import Data.Set(Set) import qualified Data.Set as Set import Cryptol.Parser.Position(Located) import Cryptol.ModuleSystem.Interface(IfaceNames(..)) import Cryptol.IR.TraverseNames(TraverseNames,mapNames) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Subst(Subst,TVars,apSubst) {- | `?tSu` should be applied to all types. `?vSu` shoudl be applied to all values. -} type Su = (?tSu :: Subst, ?vSu :: Map Name Name) -- | Has value names but no types. doVInst :: (Su, TraverseNames a) => a -> a doVInst = mapNames (\x -> Map.findWithDefault x x ?vSu) -- | Has types but not values. doTInst :: (Su, TVars a) => a -> a doTInst = apSubst ?tSu -- | Has both value names and types. doTVInst :: (Su, TVars a, TraverseNames a) => a -> a doTVInst = apSubst ?tSu . doVInst doMap :: (Su, ModuleInstance a) => Map Name a -> Map Name a doMap mp = Map.fromList [ (moduleInstance x, moduleInstance d) | (x,d) <- Map.toList mp ] doSet :: Su => Set Name -> Set Name doSet = Set.fromList . map moduleInstance . Set.toList class ModuleInstance t where moduleInstance :: Su => t -> t instance ModuleInstance a => ModuleInstance [a] where moduleInstance = map moduleInstance instance ModuleInstance a => ModuleInstance (Located a) where moduleInstance l = moduleInstance <$> l instance ModuleInstance Name where moduleInstance = doVInst instance ModuleInstance name => ModuleInstance (ImpName name) where moduleInstance x = case x of ImpTop t -> ImpTop t ImpNested n -> ImpNested (moduleInstance n) instance ModuleInstance (ModuleG name) where moduleInstance m = Module { mName = mName m , mDoc = Nothing , mExports = doVInst (mExports m) , mParamTypes = doMap (mParamTypes m) , mParamFuns = doMap (mParamFuns m) , mParamConstraints = moduleInstance (mParamConstraints m) , mParams = moduleInstance <$> mParams m , mFunctors = doMap (mFunctors m) , mNested = doSet (mNested m) , mTySyns = doMap (mTySyns m) , mNewtypes = doMap (mNewtypes m) , mPrimTypes = doMap (mPrimTypes m) , mDecls = moduleInstance (mDecls m) , mSubmodules = doMap (mSubmodules m) , mSignatures = doMap (mSignatures m) } instance ModuleInstance Type where moduleInstance = doTInst instance ModuleInstance Schema where moduleInstance = doTInst instance ModuleInstance TySyn where moduleInstance ts = TySyn { tsName = moduleInstance (tsName ts) , tsParams = tsParams ts , tsConstraints = moduleInstance (tsConstraints ts) , tsDef = moduleInstance (tsDef ts) , tsDoc = tsDoc ts } instance ModuleInstance Newtype where moduleInstance nt = Newtype { ntName = moduleInstance (ntName nt) , ntParams = ntParams nt , ntConstraints = moduleInstance (ntConstraints nt) , ntConName = moduleInstance (ntConName nt) , ntFields = moduleInstance <$> ntFields nt , ntDoc = ntDoc nt } instance ModuleInstance AbstractType where moduleInstance at = AbstractType { atName = moduleInstance (atName at) , atKind = atKind at , atCtrs = let (ps,cs) = atCtrs at in (ps, moduleInstance cs) , atFixitiy = atFixitiy at , atDoc = atDoc at } instance ModuleInstance DeclGroup where moduleInstance dg = case dg of Recursive ds -> Recursive (moduleInstance ds) NonRecursive d -> NonRecursive (moduleInstance d) instance ModuleInstance Decl where moduleInstance = doTVInst instance ModuleInstance name => ModuleInstance (IfaceNames name) where moduleInstance ns = IfaceNames { ifsName = moduleInstance (ifsName ns) , ifsNested = doSet (ifsNested ns) , ifsDefines = doSet (ifsDefines ns) , ifsPublic = doSet (ifsPublic ns) , ifsDoc = ifsDoc ns } instance ModuleInstance ModParamNames where moduleInstance si = ModParamNames { mpnTypes = doMap (mpnTypes si) , mpnConstraints = moduleInstance (mpnConstraints si) , mpnFuns = doMap (mpnFuns si) , mpnTySyn = doMap (mpnTySyn si) , mpnDoc = mpnDoc si } instance ModuleInstance ModTParam where moduleInstance mp = ModTParam { mtpName = moduleInstance (mtpName mp) , mtpKind = mtpKind mp , mtpDoc = mtpDoc mp } instance ModuleInstance ModVParam where moduleInstance mp = ModVParam { mvpName = moduleInstance (mvpName mp) , mvpType = moduleInstance (mvpType mp) , mvpDoc = mvpDoc mp , mvpFixity = mvpFixity mp } instance ModuleInstance ModParam where moduleInstance p = ModParam { mpName = mpName p , mpIface = moduleInstance (mpIface p) , mpParameters = moduleInstance (mpParameters p) , mpQual = mpQual p } cryptol-3.0.0/src/Cryptol/TypeCheck/Monad.hs0000644000000000000000000014053007346545000017076 0ustar0000000000000000-- | -- Module : Cryptol.TypeCheck.Monad -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-} module Cryptol.TypeCheck.Monad ( module Cryptol.TypeCheck.Monad , module Cryptol.TypeCheck.InferTypes ) where import qualified Control.Applicative as A import qualified Control.Monad.Fail as Fail import Control.Monad.Fix(MonadFix(..)) import Data.Text(Text) 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.List.NonEmpty(NonEmpty((:|))) import Data.Semigroup(sconcat) import Data.Maybe(mapMaybe,fromMaybe) import Data.IORef import GHC.Generics (Generic) import Control.DeepSeq import MonadLib hiding (mapM) import Cryptol.ModuleSystem.Name (FreshM(..),Supply,mkLocal,asLocal , nameInfo, NameInfo(..),NameSource(..), nameTopModule) import qualified Cryptol.ModuleSystem.Interface as If import Cryptol.Parser.Position import qualified Cryptol.Parser.AST as P import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Subst import Cryptol.TypeCheck.Interface(genIfaceWithNames,genIfaceNames) import Cryptol.TypeCheck.Unify(doMGU, runResult, UnificationError(..) , Path, rootPath) import Cryptol.TypeCheck.InferTypes import Cryptol.TypeCheck.Error( Warning(..),Error(..) , cleanupErrors, computeFreeVarNames ) import qualified Cryptol.TypeCheck.SimpleSolver as Simple import qualified Cryptol.TypeCheck.Solver.SMT as SMT import Cryptol.TypeCheck.PP(NameMap) import Cryptol.Utils.PP(pp, (<+>), text,commaSep,brackets,debugShowUniques) import Cryptol.Utils.Ident(Ident,Namespace(..),ModName) import Cryptol.Utils.Panic(panic) -- | 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 , inpSignatures :: !(Map Name ModParamNames) -- ^ Signatures in scope , inpTopModules :: ModName -> Maybe (ModuleG (), If.IfaceG ()) , inpTopSignatures :: ModName -> Maybe ModParamNames -- When typechecking a module these start off empty. -- We need them when type-checking an expression at the command -- line, for example. , inpParams :: !ModParamNames , inpNameSeeds :: NameSeeds -- ^ Private state of type-checker , inpMonoBinds :: Bool -- ^ Should local bindings without -- signatures be monomorphized? , inpCallStacks :: Bool -- ^ Are we tracking call stacks? , 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 , inpSolver :: SMT.Solver -- ^ Solver connection for typechecking } -- | 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 NameMap [(Range,Warning)] [(Range,Error)] -- ^ We found some errors | InferOK NameMap [(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 m0 = do let IM m = selectorScope m0 counter <- newIORef 0 let allPs = inpParams info let env = Map.map ExtVar (inpVars info) <> Map.fromList [ (ntConName nt, ExtVar (newtypeConType nt)) | nt <- Map.elems (inpNewtypes info) ] <> Map.map (ExtVar . mvpType) (mpnFuns allPs) let ro = RO { iRange = inpRange info , iVars = env , iExtModules = inpTopModules info , iExtSignatures = inpTopSignatures info , iExtScope = (emptyModule ExternalScope) { mTySyns = inpTSyns info <> mpnTySyn allPs , mNewtypes = inpNewtypes info , mPrimTypes = inpAbstractTypes info , mParamTypes = mpnTypes allPs , mParamFuns = mpnFuns allPs , mParamConstraints = mpnConstraints allPs , mSignatures = inpSignatures info } , iTVars = [] , iSolvedHasLazy = Map.empty , iMonoBinds = inpMonoBinds info , iCallStacks = inpCallStacks info , iSolver = inpSolver info , iPrimNames = inpPrimNames info , iSolveCounter = counter } mb <- runExceptionT (runStateT rw (runReaderT ro m)) case mb of Left errs -> inferFailed [] errs Right (result, finalRW) -> do let theSu = iSubst finalRW defSu = defaultingSubst theSu warns = fmap' (fmap' (apSubst theSu)) (iWarnings finalRW) case iErrors finalRW of [] -> case iCts finalRW of cts | nullGoals cts -> inferOk warns (iNameSeeds finalRW) (iSupply finalRW) (apSubst defSu result) cts -> inferFailed warns [ ( goalRange g , UnsolvedGoals [apSubst theSu g] ) | g <- fromGoals cts ] errs -> inferFailed warns [(r,apSubst theSu e) | (r,e) <- errs] where inferOk ws a b c = pure (InferOK (computeFreeVarNames ws []) ws a b c) inferFailed ws es = let es1 = cleanupErrors es in pure (InferFailed (computeFreeVarNames ws es1) ws es1) rw = RW { iErrors = [] , iWarnings = [] , iSubst = emptySubst , iExistTVars = [] , iNameSeeds = inpNameSeeds info , iCts = emptyGoals , iHasCts = [] , iSolvedHas = Map.empty , iSupply = inpSupply info , iScope = [] , iBindTypes = mempty } {- | This introduces a new "selector scope" which is currently a module. I think that it might be possible to have selectors scopes be groups of recursive declarations instead, as we are not going to learn anything additional once we are done with the recursive group that generated the selectors constraints. We do it at the module level because this allows us to report more errors at once. A selector scope does the following: * Keep track of the Has constraints generated in this scope * Keep track of the solutions for discharged selector constraints: - this uses a laziness trick where we build up a map containing the solutions for the Has constraints in the state - the *final* value for this map (i.e., at the value the end of the scope) is passed in as thunk in the reader component of the moment - as we type check expressions when we need the solution for a Has constraint we look it up from the reader environment; note that since the map is not yet built up we just get back a thunk, so we have to be carefule to not force it until *after* we've solved the goals - all of this happens in the `rec` block below * At the end of a selector scope we make sure that all Has constraints were discharged. If not, we *abort* further type checking. The reason for aborting rather than just recording an error is that the expression which produce contains thunks that will lead to non-termination if forced, and some type-checking operations (e.g., instantiation a functor) require us to traverse the expressions. -} selectorScope :: InferM a -> InferM a selectorScope (IM m1) = IM do ro <- ask rw <- get mb <- inBase do rec let ro1 = ro { iSolvedHasLazy = solved } rw1 = rw { iHasCts = [] : iHasCts rw } mb <- runExceptionT (runStateT rw1 (runReaderT ro1 m1)) let solved = case mb of Left {} -> Map.empty Right (_,rw2) -> iSolvedHas rw2 pure mb case mb of Left err -> raise err Right (a,rw1) -> case iHasCts rw1 of us : cs -> do let errs = [ (goalRange g, UnsolvedGoals [g]) | g <- map hasGoal us ] set rw1 { iErrors = errs ++ iErrors rw1, iHasCts = cs } unIM (abortIfErrors) pure a [] -> panic "selectorScope" ["No selector scope"] newtype InferM a = IM { unIM :: ReaderT RO ( StateT RW ( ExceptionT [(Range,Error)] IO )) a } data ScopeName = ExternalScope | LocalScope | SubModule Name | SignatureScope Name (Maybe Text) -- ^ The Text is docs | TopSignatureScope P.ModName | MTopModule P.ModName -- | 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 -- These are only parameters vars that are in recursive component we -- are checking at the moment. If a var is not there, keep looking in -- the 'iScope' , iTVars :: [TParam] -- ^ Type variable that are in scope , iExtModules :: ModName -> Maybe (ModuleG (), If.IfaceG ()) -- ^ An exteral top-level module. -- We need the actual module when we instantiate functors, -- because currently the type-checker desugars such modules. , iExtSignatures :: ModName -> Maybe ModParamNames -- ^ External top-level signatures. , iExtScope :: ModuleG ScopeName -- ^ These are things we know about, but are not part of the -- modules we are currently constructing. -- XXX: this sould probably be an interface -- NOTE: External functors should be looked up in `iExtModules` -- and not here, as they may be top-level modules. , 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. , iCallStacks :: Bool -- ^ When this flag is true, retain source location information -- in typechecked terms , 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. These are separate from the other constraints because solving them results in actual elaboration of the term, indicating how to do the projection. The modification of the term is done using lazyness, by looking up a thunk ahead of time (@iSolvedHasLazy@ in RO), which is filled in when the constrait is solved (@iSolvedHas@). See also `selectorScope`. -} , iScope :: ![ModuleG ScopeName] -- ^ Nested scopes we are currently checking, most nested first. -- These are basically partially built modules. , iBindTypes :: !(Map Name Schema) -- ^ Types of variables that we know about. We don't worry about scoping -- here because we assume the bindings all have different names. , iSupply :: !Supply } instance Functor InferM where fmap f (IM m) = IM (fmap f m) instance A.Applicative InferM where pure x = IM (pure x) (<*>) = ap instance Monad InferM where return = pure IM m >>= f = IM (m >>= unIM . f) instance Fail.MonadFail InferM where fail x = IM (fail x) 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 = recordErrorLoc Nothing -- | Report an error. recordErrorLoc :: Maybe Range -> Error -> InferM () recordErrorLoc rng e = do r <- case rng of Just r -> pure r Nothing -> case e of AmbiguousSize d _ -> return (tvarSource d) _ -> curRange IM $ sets_ $ \s -> s { iErrors = (r,e) : iErrors s } -- | If there are any recoded errors than abort firther type-checking. abortIfErrors :: InferM () abortIfErrors = do rw <- IM get case iErrors rw of [] -> pure () es -> do es1 <- forM es \(l,e) -> do e1 <- applySubst e pure (l,e1) IM (raise es1) 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) , GlobalName 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 mempty (goal g) of p | Just t <- tIsError p -> do recordError $ UnsolvableGoals [g { goal = t }] 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 -> case iHasCts s of cs : more -> s { iHasCts = (HasGoal goalName g : cs) : more } [] -> panic "newHasGoal" ["no selector scope"] 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 generated @Has@ constraint addHasGoal :: HasGoal -> InferM () addHasGoal g = IM $ sets_ \s -> case iHasCts s of cs : more -> s { iHasCts = (g : cs) : more } [] -> panic "addHasGoal" ["No selector scope"] -- | 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 -> case iHasCts s of cs : more -> (cs, s { iHasCts = [] : more }) [] -> panic "getHasGoals" ["No selector scope"] 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. newLocalName :: Namespace -> Ident -> InferM Name newLocalName ns x = do r <- curRange liftSupply (mkLocal ns 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 :: TypeSource -> 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' :: TypeSource -> 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 }) -- | Check that the given "flavor" of parameter is allowed to -- have the given type, and raise an error if not checkParamKind :: TParam -> TPFlavor -> Kind -> InferM () checkParamKind tp flav k = case flav of TPModParam _ -> starOrHash TPPropSynParam _ -> starOrHashOrProp TPTySynParam _ -> starOrHash TPSchemaParam _ -> starOrHash TPNewtypeParam _ -> starOrHash TPPrimParam _ -> starOrHash TPUnifyVar -> starOrHash where starOrHashOrProp = case k of KNum -> return () KType -> return () KProp -> return () _ -> recordError (BadParameterKind tp k) starOrHash = case k of KNum -> return () KType -> return () _ -> recordError (BadParameterKind tp k) -- | Generate a new free type variable. newTParam :: P.TParam Name -> TPFlavor -> Kind -> InferM TParam newTParam nm flav k = do let desc = TVarInfo { tvarDesc = TVFromSignature (P.tpName nm) , tvarSource = fromMaybe emptyRange (P.tpRange nm) } tp <- newName $ \s -> let x = seedTVar s in (TParam { tpUnique = x , tpKind = k , tpFlav = flav , tpInfo = desc } , s { seedTVar = x + 1 }) checkParamKind tp flav k return tp -- | Generate a new version of a type parameter. We use this when -- instantiating module parameters (the "backtick" imports) freshTParam :: (Name -> TPFlavor) -> TParam -> InferM TParam freshTParam mkF tp = newName \s -> let u = seedTVar s in ( tp { tpUnique = u , tpFlav = case tpName tp of Just n -> mkF (asLocal NSType n) Nothing -> tpFlav tp -- shouldn't happen? } , s { seedTVar = u + 1 } ) -- | Generate an unknown type. The doc is a note about what is this type about. newType :: TypeSource -> Kind -> InferM Type newType src k = TVar `fmap` newTVar src k -------------------------------------------------------------------------------- -- | Record that the two types should be syntactically equal. unify :: TypeWithSource -> Type -> InferM [Prop] unify (WithSource t1 src rng) t2 = do t1' <- applySubst t1 t2' <- applySubst t2 let ((su1, ps), errs) = runResult (doMGU t1' t2') extendSubst su1 let toError :: (Path,UnificationError) -> Error toError (pa,err) = case err of UniTypeLenMismatch _ _ -> TypeMismatch src rootPath t1' t2' UniTypeMismatch s1 s2 -> TypeMismatch src pa s1 s2 UniKindMismatch k1 k2 -> KindMismatch (Just src) k1 k2 UniRecursive x t -> RecursiveType src pa (TVar x) t UniNonPolyDepends x vs -> TypeVariableEscaped src pa (TVar x) vs UniNonPoly x t -> NotForAll src pa x t case errs of [] -> return ps _ -> do mapM_ (recordErrorLoc rng . 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 escaped = Set.difference (freeParams ty) 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 hasCts <- IM (iHasCts <$> get) let sels = map (goal . hasGoal) (concat hasCts) 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 a -> pure a Nothing -> do mb1 <- Map.lookup x . iBindTypes <$> IM get case mb1 of Just a -> pure (ExtVar a) Nothing -> do mp <- IM $ asks iVars panic "lookupVar" $ [ "Undefined vairable" , show x , "IVARS" ] ++ map (show . debugShowUniques . pp) (Map.keys mp) -- | 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 = Map.lookup x <$> getTSyns -- | Lookup the definition of a newtype lookupNewtype :: Name -> InferM (Maybe Newtype) lookupNewtype x = Map.lookup x <$> getNewtypes lookupAbstractType :: Name -> InferM (Maybe AbstractType) lookupAbstractType x = Map.lookup x <$> getAbstractTypes -- | Lookup the kind of a parameter type lookupParamType :: Name -> InferM (Maybe ModTParam) lookupParamType x = Map.lookup x <$> getParamTypes lookupSignature :: P.ImpName Name -> InferM ModParamNames lookupSignature nx = case nx of -- XXX: top P.ImpNested x -> do sigs <- getSignatures case Map.lookup x sigs of Just ips -> pure ips Nothing -> panic "lookupSignature" [ "Missing signature", show x ] P.ImpTop t -> do loaded <- iExtSignatures <$> IM ask case loaded t of Just ps -> pure ps Nothing -> panic "lookupSignature" [ "Top level signature is not loaded", show (pp nx) ] -- | Lookup an external (i.e., previously loaded) top module. lookupTopModule :: ModName -> InferM (Maybe (ModuleG (), If.IfaceG ())) lookupTopModule m = do ms <- iExtModules <$> IM ask pure (ms m) lookupFunctor :: P.ImpName Name -> InferM (ModuleG ()) lookupFunctor iname = case iname of P.ImpTop m -> fst . fromMb <$> lookupTopModule m P.ImpNested m -> do localFuns <- getScope mFunctors case Map.lookup m localFuns of Just a -> pure a { mName = () } Nothing -> do mbTop <- lookupTopModule (nameTopModule m) pure (fromMb do a <- fst <$> mbTop b <- Map.lookup m (mFunctors a) pure b { mName = () }) where fromMb mb = case mb of Just a -> a Nothing -> panic "lookupFunctor" [ "Missing functor", show iname ] {- | Get information about the things defined in the module. Note that, in general, the interface may contain *more* than just the definitions in the module, however the `ifNames` should indicate which ones are part of the module. -} lookupModule :: P.ImpName Name -> InferM (If.IfaceG ()) lookupModule iname = case iname of P.ImpTop m -> snd . fromMb <$> lookupTopModule m P.ImpNested m -> do localMods <- getScope mSubmodules case Map.lookup m localMods of Just names -> do n <- genIfaceWithNames names <$> getCurDecls pure (If.ifaceForgetName n) Nothing -> do mb <- lookupTopModule (nameTopModule m) pure (fromMb do iface <- snd <$> mb names <- Map.lookup m (If.ifModules (If.ifDefines iface)) pure iface { If.ifNames = names { If.ifsName = () } }) where fromMb mb = case mb of Just a -> a Nothing -> panic "lookupModule" [ "Missing module", show iname ] lookupModParam :: P.Ident -> InferM (Maybe ModParam) lookupModParam p = do scope <- getScope mParams pure (Map.lookup p scope) -- | 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 (UndefinedExistVar 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 TySyn) getTSyns = getScope mTySyns -- | Returns the newtype declarations that are in scope. getNewtypes :: InferM (Map Name Newtype) getNewtypes = getScope mNewtypes -- | Returns the abstract type declarations that are in scope. getAbstractTypes :: InferM (Map Name AbstractType) getAbstractTypes = getScope mPrimTypes -- | Returns the abstract function declarations getParamTypes :: InferM (Map Name ModTParam) getParamTypes = getScope mParamTypes -- | Constraints on the module's parameters. getParamConstraints :: InferM [Located Prop] getParamConstraints = getScope mParamConstraints -- | 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 params <- Set.fromList . map mtpParam . Map.elems <$> getParamTypes let 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) getCallStacks :: InferM Bool getCallStacks = IM (asks iCallStacks) getSignatures :: InferM (Map Name ModParamNames) getSignatures = getScope mSignatures {- | 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. -} -- XXX: this should be done in renamer checkTShadowing :: String -> Name -> InferM () checkTShadowing this new = do tsyns <- getTSyns ro <- IM ask rw <- IM get let shadowed = do _ <- Map.lookup new tsyns 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 (TypeShadowing this new that) -- | 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 -- | Execute the given computation in a new top scope. -- The sub-computation would typically be validating a module. newScope :: ScopeName -> InferM () newScope nm = IM $ sets_ \rw -> rw { iScope = emptyModule nm : iScope rw } newLocalScope :: InferM () newLocalScope = newScope LocalScope newSignatureScope :: Name -> Maybe Text -> InferM () newSignatureScope x doc = do updScope \o -> o { mNested = Set.insert x (mNested o) } newScope (SignatureScope x doc) newTopSignatureScope :: ModName -> InferM () newTopSignatureScope x = newScope (TopSignatureScope x) {- | Start a new submodule scope. The imports and exports are just used to initialize an empty module. As we type check declarations they are added to this module's scope. -} newSubmoduleScope :: Name -> Maybe Text -> ExportSpec Name -> InferM () newSubmoduleScope x docs e = do updScope \o -> o { mNested = Set.insert x (mNested o) } newScope (SubModule x) updScope \m -> m { mDoc = docs, mExports = e } newModuleScope :: P.ModName -> ExportSpec Name -> InferM () newModuleScope x e = do newScope (MTopModule x) updScope \m -> m { mDoc = Nothing, mExports = e } -- | Update the current scope (first in the list). Assumes there is one. updScope :: (ModuleG ScopeName -> ModuleG ScopeName) -> InferM () updScope f = IM $ sets_ \rw -> rw { iScope = upd (iScope rw) } where upd r = case r of [] -> panic "updTopScope" [ "No top scope" ] s : more -> f s : more endLocalScope :: InferM ([DeclGroup], Map Name TySyn) endLocalScope = IM $ sets \rw -> case iScope rw of x : xs | LocalScope <- mName x -> ( (reverse (mDecls x), mTySyns x), rw { iScope = xs }) _ -> panic "endLocalScope" ["Missing local scope"] endSubmodule :: InferM () endSubmodule = IM $ sets_ \rw -> case iScope rw of x@Module { mName = SubModule m } : y : more -> rw { iScope = z : more } where x1 = x { mName = m, mDecls = reverse (mDecls x) } isFun = isParametrizedModule x1 add :: Monoid a => (ModuleG ScopeName -> a) -> a add f = if isFun then f y else f x <> f y z = Module { mName = mName y , mDoc = mDoc y , mExports = mExports y , mParamTypes = mParamTypes y , mParamFuns = mParamFuns y , mParamConstraints = mParamConstraints y , mParams = mParams y , mNested = mNested y , mTySyns = add mTySyns , mNewtypes = add mNewtypes , mPrimTypes = add mPrimTypes , mDecls = add mDecls , mSignatures = add mSignatures , mSubmodules = if isFun then mSubmodules y else Map.insert m (genIfaceNames x1) (mSubmodules x <> mSubmodules y) , mFunctors = if isFun then Map.insert m x1 (mFunctors y) else mFunctors x <> mFunctors y } _ -> panic "endSubmodule" [ "Not a submodule" ] endModule :: InferM TCTopEntity endModule = IM $ sets \rw -> case iScope rw of [ x ] | MTopModule m <- mName x -> ( TCTopModule x { mName = m, mDecls = reverse (mDecls x) } , rw { iScope = [] } ) _ -> panic "endModule" [ "Not a single top module" ] endSignature :: InferM () endSignature = IM $ sets_ \rw -> case iScope rw of x@Module { mName = SignatureScope m doc } : y : more -> rw { iScope = z : more } where z = y { mSignatures = Map.insert m sig (mSignatures y) } sig = ModParamNames { mpnTypes = mParamTypes x , mpnConstraints = mParamConstraints x , mpnFuns = mParamFuns x , mpnTySyn = mTySyns x , mpnDoc = doc } _ -> panic "endSignature" [ "Not a signature scope" ] endTopSignature :: InferM TCTopEntity endTopSignature = IM $ sets \rw -> case iScope rw of [ x ] | TopSignatureScope m <- mName x -> ( TCTopSignature m ModParamNames { mpnTypes = mParamTypes x , mpnConstraints = mParamConstraints x , mpnFuns = mParamFuns x , mpnTySyn = mTySyns x , mpnDoc = Nothing } , rw { iScope = [] } ) _ -> panic "endTopSignature" [ "Not a top-level signature" ] -- | Get an environment combining all nested scopes. getScope :: Semigroup a => (ModuleG ScopeName -> a) -> InferM a getScope f = do ro <- IM ask rw <- IM get pure (sconcat (f (iExtScope ro) :| map f (iScope rw))) getCurDecls :: InferM (ModuleG ()) getCurDecls = do ro <- IM ask rw <- IM get pure (foldr (\m1 m2 -> mergeDecls (forget m1) m2) (forget (iExtScope ro)) (iScope rw)) where forget m = m { mName = () } mergeDecls m1 m2 = Module { mName = () , mDoc = Nothing , mExports = mempty , mParams = mempty , mParamTypes = mempty , mParamConstraints = mempty , mParamFuns = mempty , mNested = mempty , mTySyns = uni mTySyns , mNewtypes = uni mNewtypes , mPrimTypes = uni mPrimTypes , mDecls = uni mDecls , mSubmodules = uni mSubmodules , mFunctors = uni mFunctors , mSignatures = uni mSignatures } where uni f = f m1 <> f m2 addDecls :: DeclGroup -> InferM () addDecls ds = do updScope \r -> r { mDecls = ds : mDecls r } IM $ sets_ \rw -> rw { iBindTypes = new rw } where add d = Map.insert (dName d) (dSignature d) new rw = foldr add (iBindTypes rw) (groupDecls ds) -- | The sub-computation is performed with the given type-synonym in scope. addTySyn :: TySyn -> InferM () addTySyn t = do let x = tsName t checkTShadowing "synonym" x updScope \r -> r { mTySyns = Map.insert x t (mTySyns r) } addNewtype :: Newtype -> InferM () addNewtype t = do updScope \r -> r { mNewtypes = Map.insert (ntName t) t (mNewtypes r) } IM $ sets_ \rw -> rw { iBindTypes = Map.insert (ntConName t) (newtypeConType t) (iBindTypes rw) } addPrimType :: AbstractType -> InferM () addPrimType t = updScope \r -> r { mPrimTypes = Map.insert (atName t) t (mPrimTypes r) } addParamType :: ModTParam -> InferM () addParamType a = updScope \r -> r { mParamTypes = Map.insert (mtpName a) a (mParamTypes r) } addSignatures :: Map Name ModParamNames -> InferM () addSignatures mp = updScope \r -> r { mSignatures = Map.union mp (mSignatures r) } addSubmodules :: Map Name (If.IfaceNames Name) -> InferM () addSubmodules mp = updScope \r -> r { mSubmodules = Map.union mp (mSubmodules r) } addFunctors :: Map Name (ModuleG Name) -> InferM () addFunctors mp = updScope \r -> r { mFunctors = Map.union mp (mFunctors r) } -- | The sub-computation is performed with the given abstract function in scope. addParamFun :: ModVParam -> InferM () addParamFun x = do updScope \r -> r { mParamFuns = Map.insert (mvpName x) x (mParamFuns r) } IM $ sets_ \rw -> rw { iBindTypes = Map.insert (mvpName x) (mvpType x) (iBindTypes rw) } -- | Add some assumptions for an entire module addParameterConstraints :: [Located Prop] -> InferM () addParameterConstraints ps = updScope \r -> r { mParamConstraints = ps ++ mParamConstraints r } addModParam :: ModParam -> InferM () addModParam p = updScope \r -> r { mParams = Map.insert (mpName p) p (mParams r) } -- | Perform the given computation in a new scope (i.e., the subcomputation -- may use existential type variables). This is a different kind of scope -- from the nested modules one. 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 -- | 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 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) -------------------------------------------------------------------------------- -- 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 x = KM (pure x) (<*>) = ap instance Monad KindM where return = pure KM m >>= k = KM (m >>= unKM . k) instance Fail.MonadFail KindM where fail x = KM (fail x) {- | 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 :: TypeSource -> 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-3.0.0/src/Cryptol/TypeCheck/PP.hs0000644000000000000000000000327307346545000016361 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-3.0.0/src/Cryptol/TypeCheck/Parseable.hs0000644000000000000000000001320007346545000017727 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 Data.Void import Prettyprinter import Cryptol.TypeCheck.AST import Cryptol.Utils.Ident (Ident,unpackIdent) import Cryptol.Utils.RecordMap (canonicalFields) import Cryptol.Parser.AST ( Located(..)) import Cryptol.ModuleSystem.Name infixl 5 $$ ($$) :: Doc a -> Doc a -> Doc a ($$) x y = sep [x, y] text :: String -> Doc a text = pretty int :: Int -> Doc a int = pretty -- 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 Void instance ShowParseable Expr where showParseable (ELocated _ e) = showParseable e -- TODO? emit range information showParseable (EList es _) = parens (text "EList" <+> showParseable es) showParseable (ETuple es) = parens (text "ETuple" <+> showParseable es) showParseable (ERec ides) = parens (text "ERec" <+> showParseable (canonicalFields ides)) showParseable (ESel e s) = parens (text "ESel" <+> showParseable e <+> showParseable s) showParseable (ESet _ty 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 ++ ")" showParseable (EPropGuards guards _) = parens (text "EPropGuards" $$ showParseable guards) instance (ShowParseable a, ShowParseable b) => ShowParseable (a,b) where showParseable (x,y) = parens (showParseable x <> comma <> 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 (canonicalFields 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 (DForeign t) = text (show $ DForeign t) 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)) <> comma <> maybeNameDoc (tpName tp)) maybeNameDoc :: Maybe Name -> Doc Void maybeNameDoc Nothing = dquotes mempty maybeNameDoc (Just n) = showParseable (nameIdent n) instance ShowParseable Name where showParseable n = parens (text (show (nameUnique n)) <> comma <> showParseable (nameIdent n)) cryptol-3.0.0/src/Cryptol/TypeCheck/Sanity.hs0000644000000000000000000005207007346545000017310 0ustar0000000000000000-- | -- Module : Cryptol.TypeCheck.Sanity -- Copyright : (c) 2015-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# Language OverloadedStrings #-} module Cryptol.TypeCheck.Sanity ( tcExpr , tcDecls , tcModule , ProofObligation , onlyNonTrivial , Error(..) , AreSame(..) , same ) where import Cryptol.Parser.Position(thing,Range,emptyRange) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Subst (apSubst, singleTParamSubst) import Cryptol.TypeCheck.Monad(InferInput(..)) import Cryptol.ModuleSystem.Name(nameLoc) import Cryptol.Utils.Ident import Cryptol.Utils.RecordMap import Cryptol.Utils.PP import Data.List (sort) import qualified Data.Set as Set import MonadLib import qualified Control.Applicative as A import Data.Map ( Map ) import qualified Data.Map as Map tcExpr :: InferInput -> Expr -> Either (Range, Error) (Schema, [ ProofObligation ]) tcExpr env e = runTcM env (exprSchema e) tcDecls :: InferInput -> [DeclGroup] -> Either (Range, Error) [ ProofObligation ] tcDecls env ds0 = case runTcM env (checkDecls ds0) of Left err -> Left err Right (_,ps) -> Right ps tcModule :: InferInput -> Module -> Either (Range, 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) onlyNonTrivial :: [ProofObligation] -> [ProofObligation] onlyNonTrivial = filter (not . trivialProofObligation) -- | Identify proof obligations that are obviously true. -- We can filter these to avoid clutter trivialProofObligation :: ProofObligation -> Bool trivialProofObligation oblig = pIsTrue goal || simpleEq || goal `elem` asmps where goal = sType oblig asmps = sProps oblig simpleEq = case pIsEqual goal of Just (t1,t2) -> t1 == t2 Nothing -> False -------------------------------------------------------------------------------- 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 TNewtype nt ts -> do ks <- mapM checkType ts checkKind (kindOf nt) 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 data AreSame = SameIf [Prop] | NotSame areSame :: AreSame areSame = SameIf [] sameAnd :: AreSame -> AreSame -> AreSame sameAnd x y = case (x,y) of (SameIf xs, SameIf ys) -> SameIf (xs ++ ys) _ -> NotSame sameBool :: Bool -> AreSame sameBool b = if b then areSame else NotSame sameTypes :: String -> Type -> Type -> TcM () sameTypes msg x y = sameSchemas msg (tMono x) (tMono y) sameSchemas :: String -> Schema -> Schema -> TcM () sameSchemas msg x y = case same x y of NotSame -> reportError (TypeMismatch msg x y) SameIf ps -> mapM_ proofObligation ps class Same a where same :: a -> a -> AreSame instance Same a => Same [a] where same [] [] = areSame same (x : xs) (y : ys) = same x y `sameAnd` same xs ys same _ _ = NotSame data Field a b = Field a b instance (Eq a, Same b) => Same (Field a b) where same (Field x a) (Field y b) = sameBool (x == y) `sameAnd` same a b instance Same Type where same t1 t2 | k1 /= k2 = NotSame | k1 == KNum = if t1 == t2 then SameIf [] else SameIf [ t1 =#= t2 ] | otherwise = case (tNoUser t1, tNoUser t2) of (TVar x, TVar y) -> sameBool (x == y) (TRec x, TRec y) -> same (mkRec x) (mkRec y) (TNewtype x xs, TNewtype y ys) -> same (Field x xs) (Field y ys) (TCon x xs, TCon y ys) -> same (Field x xs) (Field y ys) _ -> NotSame where k1 = kindOf t1 k2 = kindOf t2 mkRec r = [ Field x y | (x,y) <- canonicalFields r ] instance Same Schema where same (Forall xs ps s) (Forall ys qs t) = same xs ys `sameAnd` same ps qs `sameAnd` same s t instance Same TParam where same x y = sameBool (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 ELocated rng t -> withRange rng (exprSchema t) EList es t -> do checkTypeIs KType t forM_ es $ \e -> do t1 <- exprType e sameTypes "EList" t1 t return $ tMono $ tSeq (tNum (length es)) t ETuple es -> fmap (tMono . tTuple) (mapM exprType es) ERec fs -> do fs1 <- traverse exprType fs return $ tMono $ TRec fs1 ESet _ e x v -> do ty <- exprType e expe <- checkHas ty x has <- exprType v sameTypes "ESet" expe 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 sameTypes "EIf_condition" tBit ty t1 <- exprType e2 t2 <- exprType e3 sameTypes "EIf_arms" t1 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 = singleTParamSubst 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 ] | SameIf ps <- same a t2 -> do mapM_ proofObligation ps 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 EPropGuards _guards typ -> pure Forall {sVars = [], sProps = [], sType = typ} 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 = Set.toList (fieldSet fs) ns1 = sort fs1 unless (ns == ns1) $ reportError $ UnexpectedRecordShape ns1 ns case lookupField f fs of Nothing -> reportError $ MissingField f $ displayOrder 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 TNewtype nt1 ts1 -> case other of TNewtype nt2 ts2 | nt1 == nt2 -> goMany ts1 ts2 _ -> err TRec fs -> case other of TRec gs -> do unless (fieldSet fs == fieldSet gs) err goMany (recordElements fs) (recordElements gs) _ -> 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) DForeign _ -> 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 let nm = dName d loc = "definition of " ++ show (pp nm) ++ ", at " ++ show (pp (nameLoc nm)) sameSchemas loc 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 ] | SameIf ps <- same elt el -> do mapM_ proofObligation ps 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] , roRange :: Range , 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 (Range, Error) (StateT RW Id)) a) instance Functor TcM where fmap = liftM instance A.Applicative TcM where pure a = TcM (pure a) (<*>) = ap instance Monad TcM where return = pure TcM m >>= f = TcM (do a <- m let TcM m1 = f a m1) runTcM :: InferInput -> TcM a -> Either (Range, 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 allPs = inpParams env ro = RO { roTVars = Map.fromList [ (tpUnique x, x) | tp <- Map.elems (mpnTypes allPs) , let x = mtpParam tp ] , roAsmps = map thing (mpnConstraints allPs) , roRange = emptyRange , roVars = Map.union (fmap mvpType (mpnFuns allPs)) (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 $ do ro <- ask raise (roRange ro, 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 withRange :: Range -> TcM a -> TcM a withRange rng (TcM m) = TcM $ do ro <- ask local ro { roRange = rng } 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 instance PP Error where ppPrec _ err = case err of TypeMismatch what expected actual -> ppErr ("Type mismatch in" <+> text what) [ "Expected:" <+> pp expected , "Actual :" <+> pp actual ] ExpectedMono s -> ppErr "Not a monomorphic type" [ pp s ] TupleSelectorOutOfRange sel sz -> ppErr "Tuple selector out of range" [ "Selector:" <+> int sel , "Size :" <+> int sz ] MissingField f fs -> ppErr "Invalid record selector" [ "Field: " <+> pp f , "Fields:" <+> commaSep (map pp fs) ] UnexpectedTupleShape expected actual -> ppErr "Unexpected tuple shape" [ "Expected:" <+> int expected , "Actual :" <+> int actual ] UnexpectedRecordShape expected actual -> ppErr "Unexpected record shape" [ "Expected:" <+> commaSep (map pp expected) , "Actual :" <+> commaSep (map pp actual) ] UnexpectedSequenceShape n t -> ppErr "Unexpected sequence shape" [ "Expected:" <+> int n , "Actual :" <+> pp t ] BadSelector sel t -> ppErr "Bad selector" [ "Selector:" <+> pp sel , "Type :" <+> pp t ] BadInstantiation -> ppErr "Bad instantiation" [] Captured x -> ppErr "Captured type variable" [ "Variable:" <+> pp x ] BadProofNoAbs -> ppErr "Proof application without a proof abstraction" [] BadProofTyVars xs -> ppErr "Proof application with type abstraction" [ "Type parameter:" <+> pp x | x <- xs ] KindMismatch expected actual -> ppErr "Kind mismatch" [ "Expected:" <+> pp expected , "Actual :" <+> pp actual ] NotEnoughArgumentsInKind k -> ppErr "Not enough arguments in kind" [ pp k ] BadApplication t1 t2 -> ppErr "Bad application" [ "Function:" <+> pp t1 , "Argument:" <+> pp t2 ] FreeTypeVariable x -> ppErr "Free type variable" [ "Variable:" <+> pp x ] BadTypeApplication kf ka -> ppErr "Bad type application" [ "Function :" <+> pp kf , "Arguments:" <+> commaSep (map pp ka) ] RepeatedVariableInForall x -> ppErr "Repeated variable in forall" [ "Variable:" <+> pp x ] BadMatch t -> ppErr "Bad match" [ "Type:" <+> pp t ] EmptyArm -> ppErr "Empty comprehension arm" [] UndefinedTypeVaraible x -> ppErr "Undefined type variable" [ "Variable:" <+> pp x ] UndefinedVariable x -> ppErr "Undefined variable" [ "Variable:" <+> pp x ] where ppErr x ys = hang x 2 (vcat [ "•" <+> y | y <- ys ]) cryptol-3.0.0/src/Cryptol/TypeCheck/SimpType.hs0000644000000000000000000002321407346545000017611 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} {-# LANGUAGE Safe #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 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) 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 (fmap go xs) TNewtype nt xs -> TNewtype nt (map go 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 = tError (tf2 TCSub x y) | 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 = bad | Just 0 <- tIsNum y = bad | otherwise = tf2 TCDiv x y where bad = tError (tf2 TCDiv x y) tMod :: Type -> Type -> Type tMod x y | Just t <- tOp TCMod (op2 nMod) [x,y] = t | tIsInf x = bad | Just 0 <- tIsNum y = bad | otherwise = tf2 TCMod x y where bad = tError (tf2 TCMod x y) tCeilDiv :: Type -> Type -> Type tCeilDiv x y | Just t <- tOp TCCeilDiv (op2 nCeilDiv) [x,y] = t | tIsInf y = bad | Just 0 <- tIsNum y = bad | otherwise = tf2 TCCeilDiv x y where bad = tError (tf2 TCCeilDiv x y) tCeilMod :: Type -> Type -> Type tCeilMod x y | Just t <- tOp TCCeilMod (op2 nCeilMod) [x,y] = t | tIsInf y = bad | Just 0 <- tIsNum x = bad | otherwise = tf2 TCCeilMod x y where bad = tError (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 -- max 1 t ~> t, if t = a ^ b && a >= 1 | k == 1 , TCon (TF TCExp) [a,_] <- t' , Just base <- tIsNat' a , base >= Nat 1 = 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 -- width (2^n - 1) = n | TCon (TF TCSub) [a,b] <- tNoUser x , Just 1 <- tIsNum b , TCon (TF TCExp) [p,q] <- tNoUser a , Just 2 <- tIsNum p = q | 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. -- We assume that input kinds and the result kind are the same (i.e., Nat) tOp :: TFun -> ([Nat'] -> Maybe Nat') -> [Type] -> Maybe Type tOp tf f ts | Just t <- msum (map tIsError ts) = Just (tError t) -- assumes result kind the same as input kind | Just xs <- mapM tIsNat' ts = Just $ case f xs of Nothing -> tError (TCon (TF tf) (map tNat' xs)) Just n -> tNat' n | otherwise = Nothing cryptol-3.0.0/src/Cryptol/TypeCheck/SimpleSolver.hs0000644000000000000000000000527407346545000020471 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, cryIsPrime) import Cryptol.TypeCheck.Solver.Class ( solveZeroInst, solveLogicInst, solveRingInst , solveIntegralInst, solveFieldInst, solveRoundInst , solveEqInst, solveCmpInst, solveSignedCmpInst , solveLiteralInst , solveLiteralLessThanInst , solveValidFloat, solveFLiteralInst ) import Cryptol.Utils.Debug(ppTrace) import Cryptol.TypeCheck.PP simplify :: Ctxt -> Prop -> Prop simplify ctxt p = case simplifyStep ctxt p of Unsolvable -> case tIsError p of Nothing -> tError p _ -> p 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 "~~~>" <+> commaSep (map pp ps) where dbg msg x -- Change `False` to `True` below to enable extra tracing. Note that -- this is written with an extraneous `id` expression to suppress -- pattern-match coverage checking warnings in this one case. | id 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 PRing) [ty] -> solveRingInst ty TCon (PC PField) [ty] -> solveFieldInst ty TCon (PC PIntegral) [ty] -> solveIntegralInst ty TCon (PC PRound) [ty] -> solveRoundInst ty TCon (PC PEq) [ty] -> solveEqInst ty TCon (PC PCmp) [ty] -> solveCmpInst ty TCon (PC PSignedCmp) [ty] -> solveSignedCmpInst ty TCon (PC PLiteral) [t1,t2] -> solveLiteralInst t1 t2 TCon (PC PLiteralLessThan) [t1,t2] -> solveLiteralLessThanInst t1 t2 TCon (PC PFLiteral) [t1,t2,t3,t4] -> solveFLiteralInst t1 t2 t3 t4 TCon (PC PValidFloat) [t1,t2] -> solveValidFloat t1 t2 TCon (PC PPrime) [ty] -> cryIsPrime ctxt ty 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-3.0.0/src/Cryptol/TypeCheck/Solve.hs0000644000000000000000000003350707346545000017135 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 #-} module Cryptol.TypeCheck.Solve ( simplifyAllConstraints , proveImplication , tryProveImplication , 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.Patterns(matchMaybe) import Control.Applicative ((<|>)) import Control.Monad(mzero) import Data.Containers.ListUtils (nubOrd) import Data.Map (Map) import qualified Data.Map as Map import Data.Set ( Set ) import qualified Data.Set as Set import Data.List(partition) import Data.Maybe(listToMaybe,fromMaybe) quickSolverIO :: Ctxt -> [Goal] -> IO (Either Error (Subst,[Goal])) quickSolverIO _ [] = return (Right (emptySubst, [])) quickSolverIO ctxt gs = case quickSolver ctxt gs of Left 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 Error (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 noIncompatible unsolved) of Nothing -> Right (su,unsolved) Just imp -> case imp of Right (newSu, subs) -> go (newSu @@ su) [] (subs ++ apSubst newSu unsolved) Left err -> Left err go su unsolved (g : gs) | Set.member (goal g) (saturatedAsmps ctxt) = go su unsolved gs go su unsolved (g : gs) = case Simplify.simplifyStep ctxt (goal g) of Unsolvable -> Left (UnsolvableGoals [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 inc [] = do let bad = Map.intersectionWith (,) (integralTVars inc) (fracTVars inc) case Map.minView bad of Just ((g1,g2),_) -> pure $ Left $ UnsolvableGoals [g1,g2] Nothing -> mzero findImprovement inc (g : gs) = do (su,ps) <- improveProp False ctxt (goal g) return (Right (su, [ g { goal = p } | p <- ps ])) <|> findImprovement (addIncompatible g inc) gs -------------------------------------------------------------------------------- -- Look for type variable with incompatible constraints data Incompatible = Incompatible { integralTVars :: Map TVar Goal -- ^ Integral a , fracTVars :: Map TVar Goal -- ^ Field a or FLiteral } noIncompatible :: Incompatible noIncompatible = Incompatible { integralTVars = Map.empty , fracTVars = Map.empty } addIncompatible :: Goal -> Incompatible -> Incompatible addIncompatible g i = fromMaybe i $ do tv <- tIsVar =<< pIsIntegral (goal g) pure i { integralTVars = Map.insert tv g (integralTVars i) } <|> do tv <- tIsVar =<< pIsField (goal g) pure i { fracTVars = Map.insert tv g (fracTVars i) } <|> do (_,_,_,t) <- pIsFLiteral (goal g) tv <- tIsVar t pure i { fracTVars = Map.insert tv g (fracTVars i) } -------------------------------------------------------------------------------- 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 let optss = map 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 ] fLitGoals = flitDefaultCandidates gSet tryDefVar :: TParam -> [(TParam, Type)] tryDefVar a -- REPL defaulting for floating-point literals | Just m <- Map.lookup (TVBound a) fLitGoals = case m of Just ((_,t),_) -> [(a,t)] Nothing -> [] -- REPL defaulting for integer literals | Just gt <- Map.lookup (TVBound a) (literalGoals gSet) = let ok p = not (Set.member (TVBound a) (fvs p)) in [ (a,t) | t <- [ tInteger, tWord (tWidth (goal gt)) ] , ok t ] -- REPL defaulting for variables unconstrained by a literal constraint | otherwise = [ (a,t) | t <- [tInteger, tRational, tBit] ] appExpr tys = foldl (\e1 _ -> EProofApp e1) (foldl ETApp expr tys) (sProps sch) defaultAndSimplify :: [TVar] -> [Goal] -> ([TVar],[Goal],Subst,[Warning],[Error]) defaultAndSimplify as gs = let (as1, gs1, su1, ws) = defLit (as2, gs2, su2, errs) = improveByDefaultingWithPure as1 gs1 in (as2,gs2,su2 @@ su1, ws, errs) where defLit | isEmptySubst su = nope | otherwise = case quickSolver mempty (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 mempty gs of Left err -> recordError err 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,errs) = defaultAndSimplify vs gs extendSubst su1 mapM_ recordWarning ws mapM_ recordError errs cs <- getParamConstraints case cs of [] -> addGoals gs1 _ -> do su2 <- proveImplication False 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 :: Bool -> Maybe Name -> [TParam] -> [Prop] -> [Goal] -> InferM Subst proveImplication dedupErrs lnam as ps gs = do evars <- varsWithAsmps solver <- getSolver extraAs <- (map mtpParam . Map.elems) <$> getParamTypes extra <- map thing <$> getParamConstraints (mbErr,su) <- io (proveImplicationIO solver dedupErrs lnam evars (extraAs ++ as) (extra ++ ps) gs) case mbErr of Right ws -> mapM_ recordWarning ws Left errs -> mapM_ recordError errs return su -- | Tries to prove an implication. If proved, then returns `Right (m_su :: -- InferM Subst)` where `m_su` is an `InferM` computation that results in the -- solution substitution, and records any warning invoked during proving. If not -- proved, then returns `Left (m_err :: InferM ())`, which records all errors -- invoked during proving. tryProveImplication :: Maybe Name -> [TParam] -> [Prop] -> [Goal] -> InferM Bool tryProveImplication lnam as ps gs = do evars <- varsWithAsmps solver <- getSolver extraAs <- (map mtpParam . Map.elems) <$> getParamTypes extra <- map thing <$> getParamConstraints (mbErr,_su) <- io (proveImplicationIO solver False lnam evars (extraAs ++ as) (extra ++ ps) gs) case mbErr of Left {} -> pure False Right {} -> pure True proveImplicationIO :: Solver -> Bool -- ^ Whether to remove duplicate goals in errors -> 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 dedupErrs f varsInEnv ps asmps0 gs0 = do let ctxt = buildSolverCtxt asmps res <- quickSolverIO ctxt gs case res of Left erro -> return (Left [erro], 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,_,errs) | isEmptySubst newSu -> return (Left (err gs3:errs), su) -- XXX: Old? (_,newGs,newSu,ws,errs) -> do let su1 = newSu @@ su (res1,su2) <- proveImplicationIO s dedupErrs f varsInEnv ps (apSubst su1 asmps0) newGs let su3 = su2 @@ su1 case res1 of Left bad -> return (Left (bad ++ errs), su3) Right ws1 | null errs -> return (Right (ws++ws1),su3) | otherwise -> return (Left errs, su3) where err us = cleanupError $ UnsolvedDelayedCt $ DelayedCt { dctSource = f , dctForall = ps , dctAsmps = asmps0 , dctGoals = if dedupErrs then nubOrd us else 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 mempty 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 buildSolverCtxt :: [Prop] -> Ctxt buildSolverCtxt ps0 = let ps = saturateProps mempty ps0 ivals = assumptionIntervals mempty (Set.toList ps) in SolverCtxt { intervals = ivals , saturatedAsmps = ps } where saturateProps gs [] = gs saturateProps gs (p:ps) | Set.member p gs = saturateProps gs ps | Just (n,_) <- pIsLiteral p = let gs' = Set.fromList [p, pFin n] <> gs in saturateProps gs' ps | otherwise = let gs' = Set.singleton p <> superclassSet p <> gs in saturateProps gs' ps assumptionIntervals as ps = case computePropIntervals as ps of NoChange -> as InvalidInterval {} -> as -- XXX: say something NewIntervals bs -> Map.union bs as cryptol-3.0.0/src/Cryptol/TypeCheck/Solver/0000755000000000000000000000000007346545000016753 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/TypeCheck/Solver/Class.hs0000644000000000000000000003567207346545000020371 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. -- If you make changes to this file, please update the documenation in RefMan.md {-# LANGUAGE PatternGuards #-} module Cryptol.TypeCheck.Solver.Class ( solveZeroInst , solveLogicInst , solveRingInst , solveFieldInst , solveIntegralInst , solveRoundInst , solveEqInst , solveCmpInst , solveSignedCmpInst , solveLiteralInst , solveLiteralLessThanInst , solveFLiteralInst , solveValidFloat ) where import qualified LibBF as FP import Cryptol.TypeCheck.Type hiding (tSub) import Cryptol.TypeCheck.SimpType (tAdd,tSub,tWidth,tMax) import Cryptol.TypeCheck.Solver.Types import Cryptol.Utils.RecordMap {- | This places constraints on the floating point numbers that we can work with. This is a bit of an odd check, as it is really a limitiation of the backend, and not the language itself. On the other hand, it helps us give sane results if one accidentally types a polymorphic float at the REPL. Hopefully, most users will stick to particular FP sizes, so this should be quite transparent. -} solveValidFloat :: Type -> Type -> Solved solveValidFloat e p | Just _ <- knownSupportedFloat e p = SolvedIf [] | otherwise = Unsolved -- | Check that the type parameters correspond to a float that -- we support, and if so make the precision settings for the BigFloat library. knownSupportedFloat :: Type -> Type -> Maybe FP.BFOpts knownSupportedFloat et pt | Just e <- tIsNum et, Just p <- tIsNum pt , minExp <= e && e <= maxExp && minPrec <= p && p <= maxPrec = Just (FP.expBits (fromInteger e) <> FP.precBits (fromInteger p) <> FP.allowSubnormal) | otherwise = Nothing where minExp = max 2 (toInteger FP.expBitsMin) maxExp = toInteger FP.expBitsMax minPrec = max 2 (toInteger FP.precBitsMin) maxPrec = toInteger FP.precBitsMax -- | Solve a Zero constraint by instance, if possible. solveZeroInst :: Type -> Solved solveZeroInst ty = case tNoUser ty of -- Zero Error -> fails TCon (TError {}) _ -> Unsolvable -- 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 Real -- Zero Rational TCon (TC TCRational) [] -> SolvedIf [] -- ValidVloat e p => Zero (Float e p) TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ] -- 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 <- recordElements fs ] -- Zero -> fails TNewtype{} -> Unsolvable _ -> Unsolved -- | Solve a Logic constraint by instance, if possible. solveLogicInst :: Type -> Solved solveLogicInst ty = case tNoUser ty of -- Logic Error -> fails TCon (TError {}) _ -> Unsolvable -- Logic Bit TCon (TC TCBit) [] -> SolvedIf [] -- Logic Integer fails TCon (TC TCInteger) [] -> Unsolvable -- Logic (Z n) fails TCon (TC TCIntMod) [_] -> Unsolvable -- Logic Rational fails TCon (TC TCRational) [] -> Unsolvable -- Logic (Float e p) fails TCon (TC TCFloat) [_, _] -> Unsolvable -- 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 <- recordElements fs ] -- Logic -> fails TNewtype{} -> Unsolvable _ -> Unsolved -- | Solve a Ring constraint by instance, if possible. solveRingInst :: Type -> Solved solveRingInst ty = case tNoUser ty of -- Ring Error -> fails TCon (TError {}) _ -> Unsolvable -- Ring [n]e TCon (TC TCSeq) [n, e] -> solveRingSeq n e -- Ring b => Ring (a -> b) TCon (TC TCFun) [_,b] -> SolvedIf [ pRing b ] -- (Ring a, Ring b) => Arith (a,b) TCon (TC (TCTuple _)) es -> SolvedIf [ pRing e | e <- es ] -- Ring Bit fails TCon (TC TCBit) [] -> Unsolvable -- Ring Integer TCon (TC TCInteger) [] -> SolvedIf [] -- Ring (Z n) TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ] -- Ring Rational TCon (TC TCRational) [] -> SolvedIf [] -- ValidFloat e p => Ring (Float e p) TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ] -- (Ring a, Ring b) => Ring { x1 : a, x2 : b } TRec fs -> SolvedIf [ pRing ety | ety <- recordElements fs ] -- Ring -> fails TNewtype{} -> Unsolvable _ -> Unsolved -- | Solve a Ring constraint for a sequence. The type passed here is the -- element type of the sequence. solveRingSeq :: Type -> Type -> Solved solveRingSeq n ty = case tNoUser ty of -- fin n => Ring [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 [ pRing ty ] _ -> Unsolved -- Ring ty => Ring [n]ty _ -> SolvedIf [ pRing ty ] -- | Solve an Integral constraint by instance, if possible. solveIntegralInst :: Type -> Solved solveIntegralInst ty = case tNoUser ty of -- Integral Error -> fails TCon (TError {}) _ -> Unsolvable -- Integral Bit fails TCon (TC TCBit) [] -> Unsolvable -- Integral Integer TCon (TC TCInteger) [] -> SolvedIf [] -- fin n => Integral [n] TCon (TC TCSeq) [n, elTy] -> case tNoUser elTy of TCon (TC TCBit) [] -> SolvedIf [ pFin n ] TVar _ -> Unsolved _ -> Unsolvable TVar _ -> Unsolved _ -> Unsolvable -- | Solve a Field constraint by instance, if possible. solveFieldInst :: Type -> Solved solveFieldInst ty = case tNoUser ty of -- Field Error -> fails TCon (TError {}) _ -> Unsolvable -- Field Bit fails TCon (TC TCBit) [] -> Unsolvable -- Field Integer fails TCon (TC TCInteger) [] -> Unsolvable -- Field Rational TCon (TC TCRational) [] -> SolvedIf [] -- ValidFloat e p => Field (Float e p) TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ] -- Field Real -- Field (Z n) TCon (TC TCIntMod) [n] -> SolvedIf [ pPrime n ] -- Field ([n]a) fails TCon (TC TCSeq) [_, _] -> Unsolvable -- Field (a -> b) fails TCon (TC TCFun) [_, _] -> Unsolvable -- Field (a, b, ...) fails TCon (TC (TCTuple _)) _ -> Unsolvable -- Field {x : a, y : b, ...} fails TRec _ -> Unsolvable -- Field -> fails TNewtype{} -> Unsolvable _ -> Unsolved -- | Solve a Round constraint by instance, if possible. solveRoundInst :: Type -> Solved solveRoundInst ty = case tNoUser ty of -- Round Error -> fails TCon (TError {}) _ -> Unsolvable -- Round Bit fails TCon (TC TCBit) [] -> Unsolvable -- Round Integer fails TCon (TC TCInteger) [] -> Unsolvable -- Round (Z n) fails TCon (TC TCIntMod) [_] -> Unsolvable -- Round Rational TCon (TC TCRational) [] -> SolvedIf [] -- ValidFloat e p => Round (Float e p) TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ] -- Round Real -- Round ([n]a) fails TCon (TC TCSeq) [_, _] -> Unsolvable -- Round (a -> b) fails TCon (TC TCFun) [_, _] -> Unsolvable -- Round (a, b, ...) fails TCon (TC (TCTuple _)) _ -> Unsolvable -- Round {x : a, y : b, ...} fails TRec _ -> Unsolvable -- Round -> fails TNewtype{} -> Unsolvable _ -> Unsolved -- | Solve Eq constraints. solveEqInst :: Type -> Solved solveEqInst ty = case tNoUser ty of -- Eq Error -> fails TCon (TError {}) _ -> Unsolvable -- eq Bit TCon (TC TCBit) [] -> SolvedIf [] -- Eq Integer TCon (TC TCInteger) [] -> SolvedIf [] -- Eq Rational TCon (TC TCRational) [] -> SolvedIf [] -- ValidFloat e p => Eq (Float e p) TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ] -- Eq (Z n) TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ] -- (fin n, Eq a) => Eq [n]a TCon (TC TCSeq) [n,a] -> SolvedIf [ pFin n, pEq a ] -- (Eq a, Eq b) => Eq (a,b) TCon (TC (TCTuple _)) es -> SolvedIf (map pEq es) -- Eq (a -> b) fails TCon (TC TCFun) [_,_] -> Unsolvable -- (Eq a, Eq b) => Eq { x:a, y:b } TRec fs -> SolvedIf [ pEq e | e <- recordElements fs ] -- Eq -> fails TNewtype{} -> Unsolvable _ -> Unsolved -- | Solve Cmp constraints. solveCmpInst :: Type -> Solved solveCmpInst ty = case tNoUser ty of -- Cmp Error -> fails TCon (TError {}) _ -> Unsolvable -- Cmp Bit TCon (TC TCBit) [] -> SolvedIf [] -- Cmp Integer TCon (TC TCInteger) [] -> SolvedIf [] -- Cmp Rational TCon (TC TCRational) [] -> SolvedIf [] -- Cmp (Z n) fails TCon (TC TCIntMod) [_] -> Unsolvable -- ValidFloat e p => Cmp (Float e p) TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ] -- (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 -- (Cmp a, Cmp b) => Cmp { x:a, y:b } TRec fs -> SolvedIf [ pCmp e | e <- recordElements fs ] -- Cmp -> fails TNewtype{} -> Unsolvable _ -> 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 {}) _ -> Unsolvable -- SignedCmp Bit fails TCon (TC TCBit) [] -> Unsolvable -- SignedCmp Integer fails TCon (TC TCInteger) [] -> Unsolvable -- SignedCmp (Z n) fails TCon (TC TCIntMod) [_] -> Unsolvable -- SignedCmp Rational fails TCon (TC TCRational) [] -> Unsolvable -- SignedCmp (Float e p) fails TCon (TC TCFloat) [_, _] -> Unsolvable -- 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 -- (SignedCmp a, SignedCmp b) => SignedCmp { x:a, y:b } TRec fs -> SolvedIf [ pSignedCmp e | e <- recordElements fs ] -- SignedCmp -> fails TNewtype{} -> Unsolvable _ -> Unsolved -- | Solving fractional literal constraints. solveFLiteralInst :: Type -> Type -> Type -> Type -> Solved solveFLiteralInst numT denT rndT ty | TCon (TError {}) _ <- tNoUser numT = Unsolvable | TCon (TError {}) _ <- tNoUser denT = Unsolvable | tIsInf numT || tIsInf denT || tIsInf rndT = Unsolvable | Just 0 <- tIsNum denT = Unsolvable | otherwise = case tNoUser ty of TVar {} -> Unsolved TCon (TError {}) _ -> Unsolvable TCon (TC TCRational) [] -> SolvedIf [ pFin numT, pFin denT, denT >== tOne ] TCon (TC TCFloat) [e,p] | Just 0 <- tIsNum rndT -> SolvedIf [ pValidFloat e p , pFin numT, pFin denT, denT >== tOne ] | Just _ <- tIsNum rndT , Just opts <- knownSupportedFloat e p , Just n <- tIsNum numT , Just d <- tIsNum denT -> case FP.bfDiv opts (FP.bfFromInteger n) (FP.bfFromInteger d) of (_, FP.Ok) -> SolvedIf [] _ -> Unsolvable | otherwise -> Unsolved _ -> Unsolvable -- | Solve Literal constraints. solveLiteralInst :: Type -> Type -> Solved solveLiteralInst val ty | TCon (TError {}) _ <- tNoUser val = Unsolvable | otherwise = case tNoUser ty of -- Literal n Error -> fails TCon (TError {}) _ -> Unsolvable -- (1 >= val) => Literal val Bit TCon (TC TCBit) [] -> SolvedIf [ tOne >== val ] -- (fin val) => Literal val Integer TCon (TC TCInteger) [] -> SolvedIf [ pFin val ] -- (fin val) => Literal val Rational TCon (TC TCRational) [] -> SolvedIf [ pFin val ] -- ValidFloat e p => Literal val (Float e p) if `val` is representable TCon (TC TCFloat) [e,p] | Just n <- tIsNum val , Just opts <- knownSupportedFloat e p -> let bf = FP.bfFromInteger n in case FP.bfRoundFloat opts bf of (bf1,FP.Ok) | bf == bf1 -> SolvedIf [] _ -> Unsolvable | otherwise -> Unsolved -- (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 -- | Solve Literal constraints. solveLiteralLessThanInst :: Type -> Type -> Solved solveLiteralLessThanInst val ty | TCon (TError {}) _ <- tNoUser val = Unsolvable | otherwise = case tNoUser ty of -- Literal n Error -> fails TCon (TError {}) _ -> Unsolvable -- (2 >= val) => LiteralLessThan val Bit TCon (TC TCBit) [] -> SolvedIf [ tTwo >== val ] -- LiteralLessThan val Integer TCon (TC TCInteger) [] -> SolvedIf [ ] -- LiteralLessThan val Rational TCon (TC TCRational) [] -> SolvedIf [ ] -- ValidFloat e p => LiteralLessThan val (Float e p) if `val-1` is representable -- RWD Should we remove this instance for floats? TCon (TC TCFloat) [e, p] | Just n <- tIsNum val , n > 0 , Just opts <- knownSupportedFloat e p -> let bf = FP.bfFromInteger (n-1) in case FP.bfRoundFloat opts bf of (bf1,FP.Ok) | bf == bf1 -> SolvedIf [] _ -> Unsolvable | otherwise -> Unsolved -- (fin val, fin m, m >= val) => LiteralLessThan val (Z m) TCon (TC TCIntMod) [modulus] -> SolvedIf [ pFin val, pFin modulus, modulus >== val ] -- (fin bits, bits >= lg2 n) => LiteralLessThan 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 val' = tSub (tMax val tOne) tOne TVar _ -> Unsolved _ -> Unsolvable cryptol-3.0.0/src/Cryptol/TypeCheck/Solver/Improve.hs0000644000000000000000000001650107346545000020733 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | 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 -- Whenever we have `Literal n [m]a`, -- we can learn that `a = Bit` 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 = uncheckedSingleSubst 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) case singleSubst x other of Left _ -> mzero Right su -> return (su, []) <|> do (v,s) <- isSum this case singleSubst v (Mk.tSub other s) of Left _ -> mzero Right su -> return (su, [ 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 (intervals 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-3.0.0/src/Cryptol/TypeCheck/Solver/InfNat.hs0000644000000000000000000002012507346545000020466 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@, -- or when @blockSize = inf@. @inf@ divided by any positive -- finite value is @inf@. nCeilDiv :: Nat' -> Nat' -> Maybe Nat' nCeilDiv _ Inf = Nothing nCeilDiv _ (Nat 0) = Nothing nCeilDiv Inf (Nat _) = Just Inf 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@ -- or @blockSize = inf@. @inf@ modulus any positive finite value is @0@. nCeilMod :: Nat' -> Nat' -> Maybe Nat' nCeilMod _ Inf = Nothing nCeilMod _ (Nat 0) = Nothing nCeilMod Inf (Nat _) = Just (Nat 0) 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-3.0.0/src/Cryptol/TypeCheck/Solver/Numeric.hs0000644000000000000000000003307707346545000020723 0ustar0000000000000000{-# LANGUAGE PatternGuards, MagicHash, MultiWayIf, TypeOperators #-} module Cryptol.TypeCheck.Solver.Numeric ( cryIsEqual, cryIsNotEqual, cryIsGeq, cryIsPrime, primeTable ) where import Control.Applicative(Alternative(..)) import Control.Monad (guard,mzero) import qualified Control.Monad.Fail as Fail import Data.List (sortBy) import Data.MemoTrie import Math.NumberTheory.Primes.Testing (isPrime) import Cryptol.Utils.Patterns 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 (==) 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 (/=) t1 t2) -- | Try to solve @t1 >= t2@ cryIsGeq :: Ctxt -> Type -> Type -> Solved cryIsGeq i t1 t2 = matchDefault Unsolved $ (pBin (>=) 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 {-# NOINLINE primeTable #-} primeTable :: Integer :->: Bool primeTable = trie isPrime cryIsPrime :: Ctxt -> Type -> Solved cryIsPrime _varInfo ty = case tNoUser ty of TCon (TC tc) [] | TCNum n <- tc -> if untrie primeTable n then SolvedIf [] else Unsolvable | TCInf <- tc -> Unsolvable _ -> Unsolved -- | Try to solve something by evaluation. pBin :: (Nat' -> Nat' -> Bool) -> Type -> Type -> Match Solved pBin p t1 t2 | Just _ <- tIsError t1 = pure Unsolvable | Just _ <- tIsError t2 = pure Unsolvable | otherwise = do x <- aNat' t1 y <- aNat' t2 return $ if p x y then SolvedIf [] else Unsolvable -------------------------------------------------------------------------------- -- 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 (intervals ctxt) x iy = typeInterval (intervals 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 -------------------------------------------------------------------------------- -- | 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.fail "tryCancelVar" 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 (intervals 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 (intervals 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 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 (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 <|> -- 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 -- 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 (intervals ctxt) x1) let x2Fin = iIsFin (typeInterval (intervals 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 cryptol-3.0.0/src/Cryptol/TypeCheck/Solver/Numeric/0000755000000000000000000000000007346545000020355 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/TypeCheck/Solver/Numeric/Fin.hs0000644000000000000000000000541207346545000021427 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 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 :: Ctxt -> Prop -> Solved cryIsFin ctxt p = case pIsFin p of Just ty -> cryIsFinType ctxt ty Nothing -> Unsolved cryIsFinType :: Ctxt -> Type -> Solved cryIsFinType ctxt ty = let varInfo = intervals ctxt in case tNoUser ty of TVar x | Just i <- Map.lookup x varInfo , iIsFin i -> SolvedIf [] TCon (TC tc) [] | TCNum _ <- tc -> SolvedIf [] | TCInf <- tc -> Unsolvable 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, [_,_]) -> SolvedIf [] (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, [t1,_]) -> SolvedIf [ pFin t1 ] (TCCeilMod, [_,_]) -> SolvedIf [] (TCLenFromThenTo,[_,_,_]) -> SolvedIf [] _ -> Unsolved _ -> Unsolved cryptol-3.0.0/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs0000644000000000000000000003110107346545000022471 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 #-} {-# LANGUAGE Safe #-} module Cryptol.TypeCheck.Solver.Numeric.Interval where import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Solver.InfNat import Cryptol.TypeCheck.PP(NameMap,ppWithNames) 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) <- pIsEqual prop x <- tIsVar l return (x,typeInterval varInts r) , do (l,r) <- pIsEqual 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 }) , do (e,_) <- pIsValidFloat prop x <- tIsVar e pure (x, iAnyFin) , do (_,p) <- pIsValidFloat prop x <- tIsVar p pure (x, iAnyFin) ] -------------------------------------------------------------------------------- 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 ppIntervalsWithNames :: NameMap -> Map TVar Interval -> Doc ppIntervalsWithNames nms = vcat . map ppr . Map.toList where ppr :: (TVar,Interval) -> Doc ppr (var,i) = ppWithNames nms 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-3.0.0/src/Cryptol/TypeCheck/Solver/SMT.hs0000644000000000000000000003005007346545000017750 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 #-} module Cryptol.TypeCheck.Solver.SMT ( -- * Setup Solver , SolverConfig , withSolver , startSolver , stopSolver , isNumeric , resetSolver -- * Debugging , debugBlock , debugLog -- * Proving stuff , proveImp , checkUnsolvable , tryGetModel , shrinkModel -- * Lower level interactions , inNewFrame, TVars, declareVars, assume, unsolvable ) 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, pp ) -- | An SMT solver packed with a logger for debugging. data Solver = Solver { solver :: SMT.Solver -- ^ The actual solver , logger :: SMT.Logger -- ^ For debugging } setupSolver :: Solver -> SolverConfig -> IO () setupSolver s cfg = do _ <- SMT.setOptionMaybe (solver s) ":global-decls" "false" loadTcPrelude s (solverPreludePath cfg) -- | Start a fresh solver instance startSolver :: IO () -> SolverConfig -> IO Solver startSolver onExit sCfg = do logger <- if (solverVerbose sCfg) > 0 then SMT.newLogger 0 else return quietLogger let smtDbg = if (solverVerbose sCfg) > 1 then Just logger else Nothing solver <- SMT.newSolverNotify (solverPath sCfg) (solverArgs sCfg) smtDbg (Just (const onExit)) let sol = Solver solver logger setupSolver sol sCfg return sol where quietLogger = SMT.Logger { SMT.logMessage = \_ -> return () , SMT.logLevel = return 0 , SMT.logSetLevel= \_ -> return () , SMT.logTab = return () , SMT.logUntab = return () } -- | Shut down a solver instance stopSolver :: Solver -> IO () stopSolver s = void $ SMT.stop (solver s) resetSolver :: Solver -> SolverConfig -> IO () resetSolver s sCfg = do _ <- SMT.simpleCommand (solver s) ["reset"] setupSolver s sCfg -- | Execute a computation with a fresh solver instance. withSolver :: IO () -> SolverConfig -> (Solver -> IO a) -> IO a withSolver onExit cfg = bracket (startSolver onExit cfg) stopSolver -- | 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) inNewFrame :: Solver -> IO a -> IO a inNewFrame sol m = do push sol a <- m pop sol pure a 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) declareVars :: Solver -> [TVar] -> IO TVars declareVars sol vs = Map.fromList <$> zipWithM (declareVar sol) [ 0 .. ] [ v | v <- vs, kindOf v == KNum ] 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 (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-3.0.0/src/Cryptol/TypeCheck/Solver/Selector.hs0000644000000000000000000001543407346545000021076 0ustar0000000000000000-- | -- Module : Cryptol.TypeCheck.Solver.Selector -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE PatternGuards #-} module Cryptol.TypeCheck.Solver.Selector (tryHasGoal) where import Cryptol.Parser.Position(Range) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.InferTypes import Cryptol.TypeCheck.Monad( InferM, unify, newGoals , newType, applySubst, solveHasGoal , newLocalName ) import Cryptol.TypeCheck.Subst (listParamSubst, apSubst) import Cryptol.Utils.Ident (Ident, packIdent,Namespace(..)) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.RecordMap 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 (recordFromFields 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 :: Maybe Range -> Selector -> Type -> InferM Bool improveSelector rng 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 ps <- unify (WithSource outerT (selSrc sel) rng) ty newGoals CtExactType ps 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 (lookupField l fs) TNewtype nt ts -> case lookupField l (ntFields nt) of Nothing -> return Nothing Just t -> do let su = listParamSubst (zip (ntParams nt) ts) newGoals (CtPartialTypeFun (ntName nt)) $ apSubst su $ ntConstraints nt return $ Just $ apSubst su t TCon (TC TCSeq) [len,el] -> liftSeq len el TCon (TC TCFun) [t1,t2] -> liftFun t1 t2 _ -> 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 let rng = Just (goalRange (hasGoal has)) imped <- improveSelector rng sel th outerT <- tNoUser `fmap` applySubst th mbInnerT <- solveSelector sel outerT case mbInnerT of Nothing -> return (imped, False) Just innerT -> do newGoals CtExactType =<< unify (WithSource innerT (selSrc sel) rng) 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 outerT 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 <- newLocalName NSValue (packIdent "x") x2 <- newLocalName NSValue (packIdent "x") y2 <- newLocalName NSValue (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) (a -> t) -- f.s ~~> \x -> (f x).s -- { f | s = g } ~~> \x -> { f x | s = g x } liftFun t1 t2 = do x1 <- newLocalName NSValue (packIdent "x") x2 <- newLocalName NSValue (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-3.0.0/src/Cryptol/TypeCheck/Solver/Types.hs0000644000000000000000000000257307346545000020422 0ustar0000000000000000{-# Language OverloadedStrings, DeriveGeneric, DeriveAnyClass #-} {-# LANGUAGE Safe #-} module Cryptol.TypeCheck.Solver.Types where import Data.Map(Map) import Data.Set(Set) import Cryptol.TypeCheck.Type import Cryptol.TypeCheck.PP import Cryptol.TypeCheck.Solver.Numeric.Interval data Ctxt = SolverCtxt { intervals :: Map TVar Interval , saturatedAsmps :: Set Prop } instance Semigroup Ctxt where SolverCtxt is1 as1 <> SolverCtxt is2 as2 = SolverCtxt (is1 <> is2) (as1 <> as2) instance Monoid Ctxt where mempty = SolverCtxt mempty mempty data Solved = SolvedIf [Prop] -- ^ Solved, assuming the sub-goals. | Unsolved -- ^ We could not solve the goal. | Unsolvable -- ^ 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 -> text "unsolvable" cryptol-3.0.0/src/Cryptol/TypeCheck/Solver/Utils.hs0000644000000000000000000000500507346545000020407 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 {} -> [] TNewtype{} -> [] 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 TNewtype{} -> 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 TNewtype{} -> 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-3.0.0/src/Cryptol/TypeCheck/Subst.hs0000644000000000000000000003726307346545000017150 0ustar0000000000000000-- | -- Module : Cryptol.TypeCheck.Subst -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Safe #-} module Cryptol.TypeCheck.Subst ( Subst , emptySubst , SubstError(..) , singleSubst , singleTParamSubst , uncheckedSingleSubst , (@@) , defaultingSubst , listSubst , listParamSubst , isEmptySubst , FVS(..) , apSubstMaybe , TVars(..) , apSubstTypeMapKeys , substBinds , applySubstToVar , substToList , fmap', (!$), (.$) , mergeDistinctSubst ) 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, anyJust2) -- | A 'Subst' value represents a substitution that maps each 'TVar' -- to a 'Type'. -- -- Invariant 1: 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. -- -- Invariant 2: The substitution must be idempotent, in that applying -- a substitution to any 'Type' in the map should leave that 'Type' -- unchanged. In other words, 'Type' values in the range of a 'Subst' -- should not mention any 'TVar' in the domain of the 'Subst'. In -- particular, this implies that a substitution must not contain any -- recursive variable mappings. -- -- Invariant 3: The substitution must be kind correct: Each 'TVar' in -- the substitution must map to a 'Type' of the same kind. 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 } mergeDistinctSubst :: [Subst] -> Subst mergeDistinctSubst sus = case sus of [] -> emptySubst _ -> foldr1 merge sus where merge s1 s2 = S { suFreeMap = jn suFreeMap s1 s2 , suBoundMap = jn suBoundMap s1 s2 , suDefaulting = if suDefaulting s1 || suDefaulting s2 then err else False } err = panic "mergeDistinctSubst" [ "Not distinct" ] bad _ _ = err jn f x y = IntMap.unionWith bad (f x) (f y) -- | Reasons to reject a single-variable substitution. data SubstError = SubstRecursive -- ^ 'TVar' maps to a type containing the same variable. | SubstEscaped [TParam] -- ^ 'TVar' maps to a type containing one or more out-of-scope bound variables. | SubstKindMismatch Kind Kind -- ^ 'TVar' maps to a type with a different kind. singleSubst :: TVar -> Type -> Either SubstError Subst singleSubst x t | kindOf x /= kindOf t = Left (SubstKindMismatch (kindOf x) (kindOf t)) | x `Set.member` fvs t = Left SubstRecursive | not (Set.null escaped) = Left (SubstEscaped (Set.toList escaped)) | otherwise = Right (uncheckedSingleSubst x t) where escaped = case x of TVBound _ -> Set.empty TVFree _ _ scope _ -> freeParams t `Set.difference` scope uncheckedSingleSubst :: TVar -> Type -> Subst uncheckedSingleSubst v@(TVFree i _ _tps _) t = S { suFreeMap = IntMap.singleton i (v, t) , suBoundMap = IntMap.empty , suDefaulting = False } uncheckedSingleSubst v@(TVBound tp) t = S { suFreeMap = IntMap.empty , suBoundMap = IntMap.singleton (tpUnique tp) (v, t) , suDefaulting = False } singleTParamSubst :: TParam -> Type -> Subst singleTParamSubst tp t = uncheckedSingleSubst (TVBound tp) t (@@) :: 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 infixl 0 !$ infixl 0 .$ -- | Left-associative variant of the strict application operator '$!'. (!$) :: (a -> b) -> a -> b (!$) = ($!) -- | Left-associative variant of the application operator '$'. (.$) :: (a -> b) -> a -> b (.$) = ($) -- Only used internally to define fmap'. data Done a = Done a deriving (Functor, Foldable, Traversable) instance Applicative Done where pure x = Done x Done f <*> Done x = Done (f x) -- | Strict variant of 'fmap'. fmap' :: Traversable t => (a -> b) -> t a -> t b fmap' f xs = case traverse f' xs of Done y -> y where f' x = Done $! f x -- | 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 mempty (TCon t ss) _ -> Just (TCon t ss) TUser f ts t -> do (ts1, t1) <- anyJust2 (anyJust (apSubstMaybe su)) (apSubstMaybe su) (ts, t) Just (TUser f ts1 t1) TRec fs -> TRec `fmap` (anyJust (apSubstMaybe su) fs) {- We apply the substitution to the newtype as well, because it might contain module parameters, which need to be substituted when instantiating a functor. -} TNewtype nt ts -> uncurry TNewtype <$> anyJust2 (applySubstToNewtype su) (anyJust (apSubstMaybe su)) (nt,ts) 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 | suDefaulting su -> Just $! apSubst su t | otherwise -> Just t Nothing | suDefaulting su -> Just $! defaultFreeVar x | otherwise -> Nothing applySubstToNewtype :: Subst -> Newtype -> Maybe Newtype applySubstToNewtype su nt = do (cs,fs) <- anyJust2 (anyJust (apSubstMaybe su)) (anyJust (apSubstMaybe su)) (ntConstraints nt, ntFields nt) pure nt { ntConstraints = cs, ntFields = fs } class TVars t where apSubst :: Subst -> t -> t -- ^ Replaces free variables. To prevent space leaks when used with -- large 'Subst' values, every instance of 'apSubst' should satisfy -- a strictness property: Forcing evaluation of @'apSubst' s x@ -- should also force the evaluation of all recursive calls to -- @'apSubst' s@. This ensures that unevaluated thunks will not -- cause 'Subst' values to be retained on the heap. instance TVars t => TVars (Maybe t) where apSubst s = fmap' (apSubst s) instance TVars t => TVars [t] where apSubst s = fmap' (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 (Traversable 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 , tnewtype = fmap (lgo merge atNode) tnewtype } -- 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) } instance TVars a => TVars (Map.Map k a) where -- NB, strict map apSubst su m = Map.map (apSubst su) m instance TVars TySyn where apSubst su (TySyn nm params props t doc) = (\props' t' -> TySyn nm params props' t' doc) !$ apSubst su props !$ apSubst su t {- | 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 !$ (map doProp ps) !$ (apSubst su t) where doProp = pAnd . pSplitAnd . apSubst su {- NOTE: when applying a substitution to the predicates of a schema we preserve the number of predicate, even if some of them became "True" or and "And". This is to accomodate applying substitution to already type checked code (e.g., when instantiating a functor) where the predictes in the schema need to match the corresponding EProofAbs in the term. -} instance TVars Expr where apSubst su = go where go expr = case expr of ELocated r e -> ELocated r !$ (go e) 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 !$ p' !$ (go e) where p' = pAnd (pSplitAnd (apSubst su p)) {- NOTE: we used to panic if `pSplitAnd` didn't return a single result. It is useful to avoid the panic if applying the substitution to already type checked code (e.g., when we are instantitaing a functor). In that case, we don't have the option to modify the `EProofAbs` because we'd have to change all call sites, but things might simplify because of the extra info in the substitution. -} EProofApp e -> EProofApp !$ (go e) EVar {} -> expr ETuple es -> ETuple !$ (fmap' go es) ERec fs -> ERec !$ (fmap' go fs) ESet ty e x v -> ESet !$ (apSubst su ty) !$ (go e) .$ x !$ (go v) EList es t -> EList !$ (fmap' 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) EPropGuards guards ty -> EPropGuards !$ (\(props, e) -> (apSubst su `fmap'` props, apSubst su e)) `fmap'` guards .$ ty 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 = let !sig' = apSubst su (dSignature d) !def' = apSubst su (dDefinition d) in d { dSignature = sig', dDefinition = def' } instance TVars DeclDef where apSubst su (DExpr e) = DExpr !$ (apSubst su e) apSubst _ DPrim = DPrim apSubst _ (DForeign t) = DForeign t -- WARNING: This applies the substitution only to the declarations. instance TVars (ModuleG names) where apSubst su m = let !decls' = apSubst su (mDecls m) !funs' = apSubst su <$> mFunctors m in m { mDecls = decls', mFunctors = funs' } -- WARNING: This applies the substitution only to the declarations in modules. instance TVars TCTopEntity where apSubst su ent = case ent of TCTopModule m -> TCTopModule (apSubst su m) TCTopSignature {} -> ent cryptol-3.0.0/src/Cryptol/TypeCheck/TCon.hs0000644000000000000000000002663007346545000016707 0ustar0000000000000000{-# Language OverloadedStrings, DeriveGeneric, DeriveAnyClass, Safe #-} module Cryptol.TypeCheck.TCon where import qualified Data.Map as Map import GHC.Generics (Generic) import Control.DeepSeq import Cryptol.Parser.Selector import qualified Cryptol.ModuleSystem.Name as M import Cryptol.Utils.Fixity 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.GlobalName _ OrigName { ogModule = m } | m == M.TopModule preludeName -> Map.lookup (M.nameIdent nm) builtInTypes | m == M.TopModule floatName -> Map.lookup (M.nameIdent nm) builtInFloat | m == M.TopModule arrayName -> Map.lookup (M.nameIdent nm) builtInArray _ -> Nothing where x ~> y = (packIdent x, y) -- Built-in types from Float.cry builtInFloat = Map.fromList [ "Float" ~> TC TCFloat , "ValidFloat" ~> PC PValidFloat ] -- Built-in types from Cryptol.cry builtInTypes = Map.fromList [ -- Types "inf" ~> TC TCInf , "Bit" ~> TC TCBit , "Integer" ~> TC TCInteger , "Rational" ~> TC TCRational , "Z" ~> TC TCIntMod -- Predicate contstructors , "==" ~> PC PEqual , "!=" ~> PC PNeq , ">=" ~> PC PGeq , "fin" ~> PC PFin , "prime" ~> PC PPrime , "Zero" ~> PC PZero , "Logic" ~> PC PLogic , "Ring" ~> PC PRing , "Integral" ~> PC PIntegral , "Field" ~> PC PField , "Round" ~> PC PRound , "Eq" ~> PC PEq , "Cmp" ~> PC PCmp , "SignedCmp" ~> PC PSignedCmp , "Literal" ~> PC PLiteral , "LiteralLessThan" ~> PC PLiteralLessThan , "FLiteral" ~> PC PFLiteral -- 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 ] -- Built-in types from Array.cry builtInArray = Map.fromList [ "Array" ~> TC TCArray ] -------------------------------------------------------------------------------- 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 TCRational -> KType TCFloat -> KNum :-> KNum :-> KType TCIntMod -> KNum :-> KType TCArray -> KType :-> KType :-> KType TCSeq -> KNum :-> KType :-> KType TCFun -> KType :-> KType :-> KType TCTuple n -> foldr (:->) KType (replicate n KType) 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 PPrime -> KNum :-> KProp PHas _ -> KType :-> KType :-> KProp PZero -> KType :-> KProp PLogic -> KType :-> KProp PRing -> KType :-> KProp PIntegral -> KType :-> KProp PField -> KType :-> KProp PRound -> KType :-> KProp PEq -> KType :-> KProp PCmp -> KType :-> KProp PSignedCmp -> KType :-> KProp PLiteral -> KNum :-> KType :-> KProp PLiteralLessThan -> KNum :-> KType :-> KProp PFLiteral -> KNum :-> KNum :-> KNum :-> KType :-> KProp PValidFloat -> KNum :-> KNum :-> 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 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 _@ | PPrime -- ^ @prime _@ -- classes | PHas Selector -- ^ @Has sel type field@ does not appear in schemas | PZero -- ^ @Zero _@ | PLogic -- ^ @Logic _@ | PRing -- ^ @Ring _@ | PIntegral -- ^ @Integral _@ | PField -- ^ @Field _@ | PRound -- ^ @Round _@ | PEq -- ^ @Eq _@ | PCmp -- ^ @Cmp _@ | PSignedCmp -- ^ @SignedCmp _@ | PLiteral -- ^ @Literal _ _@ | PLiteralLessThan -- ^ @LiteralLessThan _ _@ | PFLiteral -- ^ @FLiteral _ _ _@ | PValidFloat -- ^ @ValidFloat _ _@ constraints on supported -- floating point representaitons | 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 | TCFloat -- ^ Float | TCIntMod -- ^ @Z _@ | TCRational -- ^ @Rational@ | TCArray -- ^ @Array _ _@ | TCSeq -- ^ @[_] _@ | TCFun -- ^ @_ -> _@ | TCTuple Int -- ^ @(_, _, _)@ | TCAbstract UserTC -- ^ An abstract type 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 -- | 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 _) = "Error" instance PP PC where ppPrec _ x = case x of PEqual -> text "(==)" PNeq -> text "(/=)" PGeq -> text "(>=)" PFin -> text "fin" PPrime -> text "prime" PHas sel -> parens (ppSelector sel) PZero -> text "Zero" PLogic -> text "Logic" PRing -> text "Ring" PIntegral -> text "Integral" PField -> text "Field" PRound -> text "Round" PEq -> text "Eq" PCmp -> text "Cmp" PSignedCmp -> text "SignedCmp" PLiteral -> text "Literal" PLiteralLessThan -> text "LiteralLessThan" PFLiteral -> text "FLiteral" PValidFloat -> text "ValidFloat" 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" TCRational -> text "Rational" TCArray -> text "Array" TCFloat -> text "Float" TCSeq -> text "[]" TCFun -> text "(->)" TCTuple 0 -> text "()" TCTuple 1 -> text "(one tuple?)" TCTuple n -> parens $ hcat $ replicate (n-1) comma 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-3.0.0/src/Cryptol/TypeCheck/Type.hs0000644000000000000000000011563207346545000016766 0ustar0000000000000000{-# Language Safe, DeriveGeneric, DeriveAnyClass, RecordWildCards #-} {-# Language FlexibleInstances, FlexibleContexts #-} {-# Language PatternGuards #-} {-# Language OverloadedStrings #-} {-| This module contains types related to typechecking and the output of the typechecker. In particular, it should contain the types needed by interface files (see 'Crytpol.ModuleSystem.Interface'), which are (kind of) the output of the typechker. -} module Cryptol.TypeCheck.Type ( module Cryptol.TypeCheck.Type , module Cryptol.TypeCheck.TCon ) where import GHC.Generics (Generic) import Control.DeepSeq import Data.Map(Map) import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import Cryptol.Parser.Selector import Cryptol.Parser.Position(Located,thing,Range,emptyRange) import Cryptol.Parser.AST(ImpName(..)) import Cryptol.ModuleSystem.Name import Cryptol.Utils.Ident (Ident, isInfixIdent, exprModName, ogModule, ModName) import Cryptol.TypeCheck.TCon import Cryptol.TypeCheck.PP import Cryptol.TypeCheck.Solver.InfNat import Cryptol.Utils.Fixity import Cryptol.Utils.Panic(panic) import Cryptol.Utils.RecordMap import Prelude infix 4 =#=, >== infixr 5 `tFun` -------------------------------------------------------------------------------- -- Module parameters type FunctorParams = Map Ident ModParam -- | Compute the names from all functor parameters allParamNames :: FunctorParams -> ModParamNames allParamNames mps = ModParamNames { mpnTypes = Map.unions (map mpnTypes ps) , mpnConstraints = concatMap mpnConstraints ps , mpnFuns = Map.unions (map mpnFuns ps) , mpnTySyn = Map.unions (map mpnTySyn ps) , mpnDoc = Nothing } where ps = map mpParameters (Map.elems mps) -- | A module parameter. Corresponds to a "signature import". -- A single module parameter can bring multiple things in scope. data ModParam = ModParam { mpName :: Ident -- ^ The name of a functor parameter. , mpQual :: !(Maybe ModName) -- ^ This is the qualifier for the parameter. We use it to -- derive parameter names when doing `_` imports. , mpIface :: ImpName Name -- ^ The interface corresponding to this parameter. -- This is thing in `import interface` , mpParameters :: ModParamNames {- ^ These are the actual parameters, not the ones in the interface For example if the same interface is used for multiple parameters the `ifmpParameters` would all be different. -} } deriving (Show, Generic, NFData) -- | Information about the names brought in through an "interface import". -- This is also used to keep information about. data ModParamNames = ModParamNames { mpnTypes :: Map Name ModTParam -- ^ Type parameters , mpnTySyn :: !(Map Name TySyn) -- ^ Type synonyms , mpnConstraints :: [Located Prop] -- ^ Constraints on param. types , mpnFuns :: Map.Map Name ModVParam -- ^ Value parameters , mpnDoc :: !(Maybe Text) -- ^ Documentation about the interface. } deriving (Show, Generic, NFData) -- | A type parameter of a module. data ModTParam = ModTParam { mtpName :: Name , mtpKind :: Kind , mtpDoc :: Maybe Text } deriving (Show,Generic,NFData) -- | This is how module parameters appear in actual types. 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 Text , mvpFixity :: Maybe Fixity -- XXX: This should be in the name? } deriving (Show,Generic,NFData) -------------------------------------------------------------------------------- -- | 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 | TPUnifyVar | TPSchemaParam Name | TPTySynParam Name | TPPropSynParam Name | TPNewtypeParam Name | TPPrimParam 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 = TPSchemaParam tySynParam :: Name -> TPFlavor tySynParam = TPTySynParam propSynParam :: Name -> TPFlavor propSynParam = TPPropSynParam newtypeParam :: Name -> TPFlavor newtypeParam = TPNewtypeParam modTyParam :: Name -> TPFlavor modTyParam = TPModParam tpfName :: TPFlavor -> Maybe Name tpfName f = case f of TPUnifyVar -> Nothing TPModParam x -> Just x TPSchemaParam x -> Just x TPTySynParam x -> Just x TPPropSynParam x -> Just x TPNewtypeParam x -> Just x TPPrimParam x -> Just 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 !(RecordMap Ident Type) -- ^ Record type | TNewtype !Newtype ![Type] -- ^ A newtype 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 info 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 tvUnique :: TVar -> Int tvUnique (TVFree u _ _ _) = u tvUnique (TVBound TParam { tpUnique = u }) = u data TVarInfo = TVarInfo { tvarSource :: !Range -- ^ Source code that gave rise , tvarDesc :: !TypeSource -- ^ Description } deriving (Show, Generic, NFData) -- | Explains how this type came to be, for better error messages. data TypeSource = 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 ArgDescr | TypeOfRes | FunApp | TypeOfIfCondExpr | TypeFromUserAnnotation | GeneratorOfListComp | TypeErrorPlaceHolder deriving (Show, Generic, NFData) data ArgDescr = ArgDescr { argDescrFun :: Maybe Name , argDescrNumber :: Maybe Int } deriving (Show,Generic,NFData) noArgDescr :: ArgDescr noArgDescr = ArgDescr { argDescrFun = Nothing, argDescrNumber = Nothing } -- | Get the names of something that is related to the tvar. tvSourceName :: TypeSource -> 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 TypeOfArg x -> argDescrFun x _ -> Nothing -- | A type annotated with information on how it came about. data TypeWithSource = WithSource { twsType :: Type , twsSource :: TypeSource , twsRange :: !(Maybe Range) } -- | 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 Text) -- ^ Documentation } deriving (Show, Generic, NFData) -- | Named records data Newtype = Newtype { ntName :: Name , ntParams :: [TParam] , ntConstraints :: [Prop] , ntConName :: !Name , ntFields :: RecordMap Ident Type , ntDoc :: Maybe Text } deriving (Show, Generic, NFData) instance Eq Newtype where x == y = ntName x == ntName y instance Ord Newtype where compare x y = compare (ntName x) (ntName y) -- | Information about an abstract type. data AbstractType = AbstractType { atName :: Name , atKind :: Kind , atCtrs :: ([TParam], [Prop]) , atFixitiy :: Maybe Fixity , atDoc :: Maybe Text } deriving (Show, Generic, NFData) -------------------------------------------------------------------------------- instance HasKind AbstractType where kindOf at = foldr (:->) (atKind at) (map kindOf (fst (atCtrs at))) 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 TNewtype{} -> 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 = xs == ys TNewtype ntx xs == TNewtype nty ys = ntx == nty && xs == ys _ == _ = 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 xs ys (TRec{}, _) -> LT (_, TRec{}) -> GT (TNewtype x xs, TNewtype y ys) -> compare (x,xs) (y,ys) 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 -------------------------------------------------------------------- -- Superclass -- | Compute the set of all @Prop@s that are implied by the -- given prop via superclass constraints. superclassSet :: Prop -> Set Prop superclassSet (TCon (PC PPrime) [n]) = Set.fromList [ pFin n, n >== tTwo ] superclassSet (TCon (PC p0) [t]) = go p0 where super p = Set.insert (TCon (PC p) [t]) (go p) go PRing = super PZero go PLogic = super PZero go PField = super PRing go PIntegral = super PRing go PRound = super PField <> super PCmp go PCmp = super PEq go PSignedCmp = super PEq go _ = mempty superclassSet _ = mempty newtypeConType :: Newtype -> Schema newtypeConType nt = Forall as (ntConstraints nt) $ TRec (ntFields nt) `tFun` TNewtype nt (map (TVar . tpVar) as) where as = ntParams nt abstractTypeTC :: AbstractType -> TCon abstractTypeTC at = case builtInType (atName at) of Just tcon | kindOf tcon == atKind at -> tcon | otherwise -> panic "abstractTypeTC" [ "Mismatch between built-in and declared type." , "Name: " ++ pretty (atName at) , "Declared: " ++ pretty (atKind at) , "Built-in: " ++ pretty (kindOf 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 Type tIsError ty = case tNoUser ty of TCon (TError _) [t] -> Just t TCon (TError _) _ -> panic "tIsError" ["Malformed error"] _ -> Nothing tHasErrors :: Type -> Bool tHasErrors ty = case tNoUser ty of TCon (TError _) _ -> True TCon _ ts -> any tHasErrors ts TRec mp -> any tHasErrors mp _ -> False 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 tIsRational :: Type -> Bool tIsRational ty = case tNoUser ty of TCon (TC TCRational) [] -> True _ -> False tIsFloat :: Type -> Maybe (Type, Type) tIsFloat ty = case tNoUser ty of TCon (TC TCFloat) [e, p] -> Just (e, p) _ -> Nothing tIsTuple :: Type -> Maybe [Type] tIsTuple ty = case tNoUser ty of TCon (TC (TCTuple _)) ts -> Just ts _ -> Nothing tIsRec :: Type -> Maybe (RecordMap 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 pIsPrime :: Prop -> Maybe Type pIsPrime ty = case tNoUser ty of TCon (PC PPrime) [t1] -> Just t1 _ -> Nothing pIsGeq :: Prop -> Maybe (Type,Type) pIsGeq ty = case tNoUser ty of TCon (PC PGeq) [t1,t2] -> Just (t1,t2) _ -> Nothing pIsEqual :: Prop -> Maybe (Type,Type) pIsEqual 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 pIsRing :: Prop -> Maybe Type pIsRing ty = case tNoUser ty of TCon (PC PRing) [t1] -> Just t1 _ -> Nothing pIsField :: Prop -> Maybe Type pIsField ty = case tNoUser ty of TCon (PC PField) [t1] -> Just t1 _ -> Nothing pIsIntegral :: Prop -> Maybe Type pIsIntegral ty = case tNoUser ty of TCon (PC PIntegral) [t1] -> Just t1 _ -> Nothing pIsRound :: Prop -> Maybe Type pIsRound ty = case tNoUser ty of TCon (PC PRound) [t1] -> Just t1 _ -> Nothing pIsEq :: Prop -> Maybe Type pIsEq ty = case tNoUser ty of TCon (PC PEq) [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 pIsLiteralLessThan :: Prop -> Maybe (Type, Type) pIsLiteralLessThan ty = case tNoUser ty of TCon (PC PLiteralLessThan) [t1, t2] -> Just (t1, t2) _ -> Nothing pIsFLiteral :: Prop -> Maybe (Type,Type,Type,Type) pIsFLiteral ty = case tNoUser ty of TCon (PC PFLiteral) [t1,t2,t3,t4] -> Just (t1,t2,t3,t4) _ -> 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 pIsValidFloat :: Prop -> Maybe (Type,Type) pIsValidFloat ty = case tNoUser ty of TCon (PC PValidFloat) [a,b] -> Just (a,b) _ -> 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 tNewtype :: Newtype -> [Type] -> Type tNewtype nt ts = TNewtype nt ts tBit :: Type tBit = TCon (TC TCBit) [] tInteger :: Type tInteger = TCon (TC TCInteger) [] tRational :: Type tRational = TCon (TC TCRational) [] tFloat :: Type -> Type -> Type tFloat e p = TCon (TC TCFloat) [ e, p ] tIntMod :: Type -> Type tIntMod n = TCon (TC TCIntMod) [n] tArray :: Type -> Type -> Type tArray a b = TCon (TC TCArray) [a, b] 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 :: RecordMap Ident Type -> Type tRec = TRec tTuple :: [Type] -> Type tTuple ts = TCon (TC (TCTuple (length ts))) ts -- | 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 an error value of the given type to replace -- the given malformed type (the argument to the error function) tError :: Type -> Type tError t = TCon (TError (k :-> k)) [t] where k = kindOf t 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] pRing :: Type -> Prop pRing t = TCon (PC PRing) [t] pIntegral :: Type -> Prop pIntegral t = TCon (PC PIntegral) [t] pField :: Type -> Prop pField t = TCon (PC PField) [t] pRound :: Type -> Prop pRound t = TCon (PC PRound) [t] pEq :: Type -> Prop pEq t = TCon (PC PEq) [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] pLiteralLessThan :: Type -> Type -> Prop pLiteralLessThan x y = TCon (PC PLiteralLessThan) [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) _ -> tError prop -- XXX: should we be doing this here?? _ -> prop where prop = TCon (PC PFin) [ty] pValidFloat :: Type -> Type -> Type pValidFloat e p = TCon (PC PValidFloat) [e,p] pPrime :: Type -> Prop pPrime ty = case tNoUser ty of TCon (TC TCInf) _ -> tError prop _ -> prop where prop = TCon (PC PPrime) [ty] -- Negation -------------------------------------------------------------------- {-| `pNegNumeric` negates a simple (i.e., not And, not prime, etc) prop over numeric type vars. The result is a conjunction of properties. -} pNegNumeric :: Prop -> [Prop] pNegNumeric prop = case tNoUser prop of TCon tcon tys -> case tcon of PC pc -> case pc of -- not (x == y) <=> x /= y PEqual -> [TCon (PC PNeq) tys] -- not (x /= y) <=> x == y PNeq -> [TCon (PC PEqual) tys] -- not (x >= y) <=> x /= y and y >= x PGeq -> [TCon (PC PNeq) tys, TCon (PC PGeq) (reverse tys)] -- not (fin x) <=> x == Inf PFin | [ty] <- tys -> [ty =#= tInf] | otherwise -> bad -- not True <=> 0 == 1 PTrue -> [TCon (PC PEqual) [tZero, tOne]] _ -> bad TError _ki -> [prop] -- propogates `TError` TC _tc -> bad TF _tf -> bad _ -> bad where bad = panic "pNegNumeric" [ "Unexpeceted numeric constraint:" , pretty prop ] -------------------------------------------------------------------------------- noFreeVariables :: FVS t => t -> Bool noFreeVariables = all (not . isFreeTV) . Set.toList . fvs freeParams :: FVS t => t -> Set TParam freeParams x = Set.unions (map params (Set.toList (fvs x))) where params (TVFree _ _ tps _) = tps params (TVBound tp) = Set.singleton tp 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 (recordElements fs) TNewtype _nt ts -> fvs ts -- | Find the abstract types mentioned in a type. class FreeAbstract t where freeAbstract :: t -> Set UserTC instance FreeAbstract a => FreeAbstract [a] where freeAbstract = Set.unions . map freeAbstract instance (FreeAbstract a, FreeAbstract b) => FreeAbstract (a,b) where freeAbstract (a,b) = Set.union (freeAbstract a) (freeAbstract b) instance FreeAbstract TCon where freeAbstract tc = case tc of TC (TCAbstract ut) -> Set.singleton ut _ -> Set.empty instance FreeAbstract Type where freeAbstract ty = case ty of TCon tc ts -> freeAbstract (tc,ts) TVar {} -> Set.empty TUser _ _ t -> freeAbstract t TRec fs -> freeAbstract (recordElements fs) TNewtype _nt ts -> freeAbstract ts 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 ppNewtypeFull :: Newtype -> Doc ppNewtypeFull nt = text "newtype" <+> pp (ntName nt) <+> hsep (map (ppWithNamesPrec nm 9) ps) $$ nest 2 (cs $$ ("=" <+> pp (ntConName nt) $$ nest 2 fs)) where ps = ntParams nt nm = addTNames ps emptyNameMap fs = vcat [ pp f <.> ":" <+> pp t | (f,t) <- canonicalFields (ntFields nt) ] cs = vcat (map pp (ntConstraints nt)) 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 = nest 2 (sep (vars ++ props ++ [body])) where body = ppWithNames ns1 (sType s) vars = case sVars s of [] -> [] vs -> [nest 1 (braces (commaSepFill (map (ppWithNames ns1) vs)))] props = case sProps s of [] -> [] ps -> [nest 1 (parens (commaSepFill (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) = nest 2 $ sep [ fsep ([text "type"] ++ ctr ++ lhs ++ [char '=']) , ppWithNames ns1 (tsDef ts) ] where ns1 = addTNames (tsParams ts) ns ctr = case kindResult (kindOf ts) of KProp -> [text "constraint"] _ -> [] 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] ++ 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? -- | The precedence levels used by this pretty-printing instance -- correspond with parser non-terminals as follows: -- -- * 0-1: @type@ -- -- * 2: @infix_type@ -- -- * 3: @app_type@ -- -- * 4: @dimensions atype@ -- -- * 5: @atype@ instance PP (WithNames Type) where ppPrec prec ty0@(WithNames ty nmMap) = case ty of TVar a -> ppWithNames nmMap a TNewtype nt ts -> optParens (prec > 3) $ fsep (pp (ntName nt) : map (go 5) ts) TRec fs -> ppRecord [ pp l <+> text ":" <+> go 0 t | (l,t) <- displayFields fs ] _ | Just tinf <- isTInfix ty0 -> optParens (prec > 2) $ ppInfix 2 isTInfix tinf TUser c ts t -> withNameDisp $ \disp -> case asOrigName c of Just og | NotInScope <- getNameFormat og disp -> go prec t -- unfold type synonym if not in scope _ -> case ts of [] -> pp c _ -> optParens (prec > 3) $ fsep (pp c : map (go 5) ts) TCon (TC tc) ts -> case (tc,ts) of (TCNum n, []) -> integer n (TCInf, []) -> text "inf" (TCBit, []) -> text "Bit" (TCInteger, []) -> text "Integer" (TCRational, []) -> text "Rational" (TCIntMod, [n]) -> optParens (prec > 3) $ text "Z" <+> go 5 n (TCSeq, [t1,TCon (TC TCBit) []]) -> brackets (go 0 t1) (TCSeq, [t1,t2]) -> optParens (prec > 4) $ brackets (go 0 t1) <.> go 4 t2 (TCFun, [t1,t2]) -> optParens (prec > 1) $ go 2 t1 <+> text "->" <+> go 1 t2 (TCTuple _, fs) -> ppTuple $ map (go 0) fs (_, _) -> optParens (prec > 3) $ fsep (pp tc : (map (go 5) 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]) -> optParens (prec > 3) $ text "fin" <+> (go 5 t1) (PPrime, [t1]) -> optParens (prec > 3) $ text "prime" <+> (go 5 t1) (PHas x, [t1,t2]) -> ppSelector x <+> text "of" <+> go 0 t1 <+> text "is" <+> go 0 t2 (PAnd, [t1,t2]) -> nest 1 (parens (commaSepFill (map (go 0) (t1 : pSplitAnd t2)))) (PRing, [t1]) -> pp pc <+> go 5 t1 (PField, [t1]) -> pp pc <+> go 5 t1 (PIntegral, [t1]) -> pp pc <+> go 5 t1 (PRound, [t1]) -> pp pc <+> go 5 t1 (PCmp, [t1]) -> pp pc <+> go 5 t1 (PSignedCmp, [t1]) -> pp pc <+> go 5 t1 (PLiteral, [t1,t2]) -> pp pc <+> go 5 t1 <+> go 5 t2 (PLiteralLessThan, [t1,t2]) -> pp pc <+> go 5 t1 <+> go 5 t2 (_, _) -> optParens (prec > 3) $ fsep (pp pc : map (go 5) ts) TCon f ts -> optParens (prec > 3) $ fsep (pp f : map (go 5) 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, ieFixity) <- infixPrimTy tc return Infix { .. } isTInfix (WithNames (TUser n [ieLeft',ieRight'] _) _) | isInfixIdent (nameIdent n) = do let ieLeft = WithNames ieLeft' nmMap ieRight = WithNames ieRight' nmMap ieFixity = fromMaybe defaultFixity (nameFixity n) ieOp = nameIdent n return Infix { .. } isTInfix _ = Nothing instance PP (WithNames TVar) where ppPrec _ (WithNames tv mp) = case tv of TVBound {} -> nmTxt TVFree {} -> "?" <.> nmTxt where nmTxt | Just a <- IntMap.lookup (tvUnique tv) mp = text a | otherwise = case tv of TVBound x -> let declNm n = pp n <.> "`" <.> int (tpUnique x) in case tpFlav x of TPModParam n -> ppPrefixName n TPUnifyVar -> pickTVarName (tpKind x) (tvarDesc (tpInfo x)) (tpUnique x) TPSchemaParam n -> declNm n TPTySynParam n -> declNm n TPPropSynParam n -> declNm n TPNewtypeParam n -> declNm n TPPrimParam n -> declNm n TVFree x k _ d -> pickTVarName k (tvarDesc d) x pickTVarName :: Kind -> TypeSource -> 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 -> case nameInfo x of GlobalName SystemName og | ogModule og == TopModule exprModName -> mk "it" _ -> using x LenOfCompGen -> mk "n" GeneratorOfListComp -> "seq" TypeOfIfCondExpr -> "b" TypeOfArg ad -> mk (case argDescrNumber ad of Nothing -> "arg" Just n -> "arg_" ++ show n) TypeOfRes -> "res" FunApp -> "fun" TypeFromUserAnnotation -> "user" 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 = hsep $ [pp (tvarDesc tvinfo)] ++ loc where loc = if rng == emptyRange then [] else ["at" <+> pp rng] rng = tvarSource tvinfo instance PP ArgDescr where ppPrec _ ad = hsep ([which, "argument"] ++ ofFun) where which = maybe "function" ordinal (argDescrNumber ad) ofFun = case argDescrFun ad of Nothing -> [] Just f -> ["of" <+> pp f] instance PP TypeSource 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 ad -> "type of" <+> pp ad TypeOfRes -> "type of function result" TypeOfIfCondExpr -> "type of `if` condition" TypeFromUserAnnotation -> "user annotation" GeneratorOfListComp -> "generator in a list comprehension" FunApp -> "function call" TypeErrorPlaceHolder -> "type error place-holder" instance PP ModParamNames where ppPrec _ ps = let tps = Map.elems (mpnTypes ps) in vcat $ map pp tps ++ if null (mpnConstraints ps) then [] else [ "type constraint" <+> parens (commaSep (map (pp . thing) (mpnConstraints ps))) ] ++ [ pp t | t <- Map.elems (mpnTySyn ps) ] ++ map pp (Map.elems (mpnFuns ps)) instance PP ModTParam where ppPrec _ p = "type" <+> pp (mtpName p) <+> ":" <+> pp (mtpKind p) instance PP ModVParam where ppPrec _ p = pp (mvpName p) <+> ":" <+> pp (mvpType p) cryptol-3.0.0/src/Cryptol/TypeCheck/TypeMap.hs0000644000000000000000000001503207346545000017415 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 #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} module Cryptol.TypeCheck.TypeMap ( TypeMap(..), TypesMap, TrieMap(..) , insertTM, insertWithTM , membersTM , mapTM, mapWithKeyTM, mapMaybeTM , List(..) ) where import Cryptol.TypeCheck.AST import Cryptol.Utils.Ident import Cryptol.Utils.RecordMap import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe(fromMaybe,maybeToList) import Control.Monad((<=<)) import Data.Maybe (isNothing) 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, Foldable, Traversable) 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) , tnewtype :: Map Newtype (List TypeMap a) } deriving (Functor, Foldable, Traversable) instance TrieMap TypeMap Type where emptyTM = TM { tvar = emptyTM, tcon = emptyTM, trec = emptyTM, tnewtype = emptyTM } nullTM ty = and [ nullTM (tvar ty) , nullTM (tcon ty) , nullTM (trec ty) , nullTM (tnewtype 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 $ canonicalFields fs in lookupTM ts <=< lookupTM xs . trec TNewtype nt ts -> lookupTM ts <=< lookupTM nt . tnewtype 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 $ canonicalFields fs in m { trec = alterTM xs (updSub ts f) (trec m) } TNewtype nt ts -> m { tnewtype = alterTM nt (updSub ts f) (tnewtype m) } toListTM m = [ (TVar x, v) | (x,v) <- toListTM (tvar m) ] ++ [ (TCon c ts, v) | (c,m1) <- toListTM (tcon m) , (ts,v) <- toListTM m1 ] ++ -- NB: this step loses 'displayOrder' information. -- It's not clear if we should try to fix this. [ (TRec (recordFromFields (zip fs ts)), v) | (fs,m1) <- toListTM (trec m) , (ts,v) <- toListTM m1 ] ++ [ (TNewtype nt ts, v) | (nt,m1) <- toListTM (tnewtype 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) , tnewtype = unionTM (unionTM f) (tnewtype m1) (tnewtype 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 (recordFromFields (zip fs ts))) a) l) (trec m) -- NB: this step loses 'displayOrder' information. -- It's not clear if we should try to fix this. , tnewtype = mapWithKeyTM (\nt l -> mapMaybeWithKeyTM (\ts a -> f (TNewtype nt ts) a) l) (tnewtype 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-3.0.0/src/Cryptol/TypeCheck/TypeOf.hs0000644000000000000000000001544107346545000017250 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 #-} {-# LANGUAGE NamedFieldPuns #-} module Cryptol.TypeCheck.TypeOf ( fastTypeOf , fastSchemaOf ) where import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Subst import Cryptol.Utils.Panic import Cryptol.Utils.PP import Cryptol.Utils.RecordMap 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 ELocated _ t -> fastTypeOf tyenv t EList es t -> tSeq (tNum (length es)) t ETuple es -> tTuple (map (fastTypeOf tyenv) es) ERec fields -> tRec (fmap (fastTypeOf tyenv) fields) ESel e sel -> typeSelect (fastTypeOf tyenv e) sel ESet ty _ _ _ -> ty 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" ] EPropGuards _guards sType -> sType -- Polymorphic fragment EVar {} -> polymorphic ETAbs {} -> polymorphic ETApp {} -> polymorphic EProofAbs {} -> polymorphic EProofApp {} -> polymorphic EWhere {} -> polymorphic where polymorphic = case fastSchemaOf tyenv expr of Forall [] [] ty -> ty s@Forall {} -> panic "Cryptol.TypeCheck.TypeOf.fastTypeOf" [ "unexpected polymorphic type in expression:" , pretty expr , "with schema:" , pretty s ] fastSchemaOf :: Map Name Schema -> Expr -> Schema fastSchemaOf tyenv expr = case expr of ELocated _ e -> fastSchemaOf tyenv e -- 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 = singleTParamSubst 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 -- PropGuards EPropGuards _ t -> Forall {sVars = [], sProps = [], sType = t} where monomorphic = Forall {sVars = [], sProps = [], sType = 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 (fmap (plainSubst s) fs) TNewtype nt ts -> TNewtype nt (map (plainSubst s) ts) TVar x -> apSubst s (TVar x) -- | Yields the return type of the selector on the given argument type. typeSelect :: Type -> Selector -> Type -- Selectors push inside the definition of type aliases typeSelect (TUser _ _ ty) sel = typeSelect ty sel -- Tuple selector applied to a tuple typeSelect (tIsTuple -> Just ts) (TupleSel i _) | i < length ts = ts !! i -- Record selector applied to a record typeSelect (TRec fields) (RecordSel n _) | Just ty <- lookupField n fields = ty -- Record selector applied to a newtype typeSelect (TNewtype nt args) (RecordSel n _) | Just ty <- lookupField n (ntFields nt) = plainSubst (listParamSubst (zip (ntParams nt) args)) ty -- List selector applied to a sequence typeSelect (tIsSeq -> Just (_, a)) ListSel{} = a -- Tuple selectors and record selectors lift pointwise over sequences typeSelect (tIsSeq -> Just (n, a)) sel@TupleSel{} = tSeq n (typeSelect a sel) typeSelect (tIsSeq -> Just (n, a)) sel@RecordSel{} = tSeq n (typeSelect a sel) -- Selectors lift pointwise over functions typeSelect (tIsFun -> Just (a, b)) sel = tFun a (typeSelect b sel) typeSelect ty _ = panic "Cryptol.TypeCheck.TypeOf.typeSelect" [ "cannot apply selector to value of type", show (pp ty) ] cryptol-3.0.0/src/Cryptol/TypeCheck/TypePat.hs0000644000000000000000000001307507346545000017431 0ustar0000000000000000-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE Safe #-} module Cryptol.TypeCheck.TypePat ( aInf, aNat, aNat' , anAdd, (|-|), aMul, (|^|), (|/|), (|%|) , aMin, aMax , aWidth , aCeilDiv, aCeilMod , aLenFromThenTo , aLiteral , aLiteralLessThan , aLogic , aTVar , aFreeTVar , anAbstractType , aBit , aSeq , aWord , aChar , aTuple , aRec , (|->|) , aFin, (|=|), (|/=|), (|>=|) , 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.Utils.RecordMap 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 anAbstractType :: Pat Type UserTC anAbstractType = \a -> case tNoUser a of TCon (TC (TCAbstract ut)) [] -> pure ut _ -> 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 (RecordMap 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 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 aLiteralLessThan :: Pat Prop (Type,Type) aLiteralLessThan = tp PLiteralLessThan ar2 aLogic :: Pat Prop Type aLogic = tp PLogic ar1 -------------------------------------------------------------------------------- anError :: Kind -> Pat Type () anError k = \a -> case tNoUser a of TCon (TError (_ :-> k1) ) _ | k == k1 -> return () _ -> mzero {- Note [-Wincomplete-uni-patterns and irrefutable patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Various parts of Cryptol use irrefutable patterns in functions that assume that their arguments have particular shapes. For example, the `ar1 ~[a] = a` function in this module uses an irrefutable pattern because it assumes the invariant that the argument list will have exactly one element. This lets ar1 be slightly lazier when evaluated. Unfortunately, this use of irrefutable patterns is at odds with the -Wincomplete-uni-patterns warning. At present, -Wincomplete-uni-patterns will produce a warning for any irrefutable pattern that does not cover all possible data constructors. While we could rewrite functions like `ar1` to explicitly provide a fall-through case, that would change its strictness properties. As a result, we simply disable -Wincomplete-uni-patterns warnings in each part of Cryptol that uses irrefutable patterns. Arguably, -Wincomplete-uni-patterns shouldn't be producing warnings for irrefutable patterns at all. GHC issue #14800 (https://gitlab.haskell.org/ghc/ghc/-/issues/14800) proposes this idea. If that issue is fixed in the future, we may want to reconsider whether we want to disable -Wincomplete-uni-patterns. -} cryptol-3.0.0/src/Cryptol/TypeCheck/Unify.hs0000644000000000000000000001426707346545000017141 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, DeriveGeneric, DeriveAnyClass #-} {-# LANGUAGE BlockArguments, OverloadedStrings #-} module Cryptol.TypeCheck.Unify where import Control.DeepSeq(NFData) import GHC.Generics(Generic) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Subst import Cryptol.Utils.RecordMap import Cryptol.Utils.Ident(Ident) import Cryptol.ModuleSystem.Name(nameIdent) import Cryptol.TypeCheck.PP import Control.Monad.Writer (Writer, writer, runWriter) 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 [(Path,UnificationError)] a runResult :: Result a -> (a, [(Path,UnificationError)]) runResult = runWriter data UnificationError = UniTypeMismatch Type Type | UniKindMismatch Kind Kind | UniTypeLenMismatch Int Int | UniRecursive TVar Type | UniNonPolyDepends TVar [TParam] | UniNonPoly TVar Type uniError :: Path -> UnificationError -> Result MGU uniError p e = writer (emptyMGU, [(p,e)]) newtype Path = Path [PathElement] deriving (Show,Generic,NFData) data PathElement = TConArg TC Int | TNewtypeArg Newtype Int | TRecArg Ident deriving (Show,Generic,NFData) rootPath :: Path rootPath = Path [] isRootPath :: Path -> Bool isRootPath (Path xs) = null xs extPath :: Path -> PathElement -> Path extPath (Path xs) x = Path (x : xs) emptyMGU :: MGU emptyMGU = (emptySubst, []) doMGU :: Type -> Type -> Result MGU doMGU t1 t2 = mgu rootPath t1 t2 mgu :: Path -> Type -> Type -> Result MGU mgu _ (TUser c1 ts1 _) (TUser c2 ts2 _) | c1 == c2 && ts1 == ts2 = return emptyMGU mgu p (TVar x) t = bindVar p x t mgu p t (TVar x) = bindVar p x t mgu p (TUser _ _ t1) t2 = mgu p t1 t2 mgu p t1 (TUser _ _ t2) = mgu p t1 t2 mgu p (TCon (TC tc1) ts1) (TCon (TC tc2) ts2) | tc1 == tc2 = let paths = [ extPath p (TConArg tc1 i) | i <- [ 0 .. ] ] in mguMany p paths ts1 ts2 mgu _ (TCon (TF f1) ts1) (TCon (TF f2) ts2) | f1 == f2 && ts1 == ts2 = return emptyMGU -- XXX: here we loose the information about where the constarint came from 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 p (TRec fs1) (TRec fs2) | fieldSet fs1 == fieldSet fs2 = let paths = [ extPath p (TRecArg i) | (i,_) <- canonicalFields fs1 ] in mguMany p paths (recordElements fs1) (recordElements fs2) mgu p (TNewtype ntx xs) (TNewtype nty ys) | ntx == nty = let paths = [ extPath p (TNewtypeArg ntx i) | i <- [ 0 .. ] ] in mguMany p paths xs ys mgu p t1 t2 | not (k1 == k2) = uniError p $ UniKindMismatch k1 k2 | otherwise = uniError p $ UniTypeMismatch t1 t2 where k1 = kindOf t1 k2 = kindOf t2 -- XXX: could pass the path to the lists themselvs mguMany :: Path -> [Path] -> [Type] -> [Type] -> Result MGU mguMany _ _ [] [] = return emptyMGU mguMany p (p1:ps) (t1 : ts1) (t2 : ts2) = do (su1,ps1) <- mgu p1 t1 t2 (su2,ps2) <- mguMany p ps (apSubst su1 ts1) (apSubst su1 ts2) return (su2 @@ su1, ps1 ++ ps2) mguMany p _ t1 t2 = uniError p $ UniTypeLenMismatch (length t1) (length t2) -- XXX: I think by this point the types should have been kind checked, -- so there should be no mismatches with the lengths... bindVar :: Path -> TVar -> Type -> Result MGU bindVar _ x (tNoUser -> TVar y) | x == y = return emptyMGU bindVar p v@(TVBound {}) (tNoUser -> TVar v1@(TVFree {})) = bindVar p v1 (TVar v) bindVar p v@(TVBound {}) t | k == kindOf t = if k == KNum then return (emptySubst, [TVar v =#= t]) else uniError p $ UniNonPoly v t | otherwise = uniError p $ UniKindMismatch k (kindOf t) where k = kindOf v bindVar _ x@(TVFree _ xk xscope _) (tNoUser -> TVar y@(TVFree _ yk yscope _)) | xscope `Set.isProperSubsetOf` yscope, xk == yk = return (uncheckedSingleSubst y (TVar x), []) -- In this case, we can add the reverse binding y ~> x to the -- substitution, but the instantiation x ~> y would be forbidden -- because it would allow y to escape from its scope. bindVar p x t = case singleSubst x t of Left SubstRecursive | kindOf x == KType -> uniError p $ UniRecursive x t | otherwise -> return (emptySubst, [TVar x =#= t]) Left (SubstEscaped tps) -> uniError p $ UniNonPolyDepends x tps Left (SubstKindMismatch k1 k2) -> uniError p $ UniKindMismatch k1 k2 Right su -> return (su, []) -------------------------------------------------------------------------------- ppPathEl :: PathElement -> Int -> (Int -> Doc) -> Doc ppPathEl el prec k = case el of TRecArg l -> braces (pp l <+> ":" <+> k 0 <.> comma <+> "…") TConArg tc n -> case tc of TCSeq -> optParens (prec > 4) if n == 0 then brackets (k 0) <+> "_" else brackets "_" <+> (k 4) TCFun -> optParens (prec > 1) if n == 0 then k 2 <+> "->" <+> "_" else "_" <+> "->" <+> k 1 TCTuple i -> parens (commaSep (before ++ [k 0] ++ after)) where before = replicate n "_" after = replicate (i - n - 1) "_" _ -> justPrefix (kindArity (kindOf tc)) (pp tc) n TNewtypeArg nt n -> justPrefix (length (ntParams nt)) (pp (nameIdent (ntName nt))) n where justPrefix arity fun n = optParens (prec > 3) (fun <+> hsep (before ++ [k 5] ++ after)) where before = replicate n "_" after = replicate (arity - n - 1) "_" kindArity ki = case ki of _ :-> k1 -> 1 + kindArity k1 _ -> 0 instance PP Path where ppPrec prec0 (Path ps0) = go (reverse ps0) prec0 where go ps prec = case ps of [] -> "ERROR" p : more -> ppPathEl p prec (go more) cryptol-3.0.0/src/Cryptol/Utils/0000755000000000000000000000000007346545000014722 5ustar0000000000000000cryptol-3.0.0/src/Cryptol/Utils/Benchmark.hs0000644000000000000000000000255307346545000017155 0ustar0000000000000000-- | Simple benchmarking of IO functions. module Cryptol.Utils.Benchmark ( BenchmarkStats (..) , benchmark , secs ) where import Criterion.Measurement (runBenchmark, secs, threshold) import Criterion.Measurement.Types import Data.Int import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U -- | Statistics returned by 'benchmark'. -- -- This is extremely crude compared to the full analysis that criterion can do, -- but is enough for now. data BenchmarkStats = BenchmarkStats { benchAvgTime :: !Double , benchAvgCpuTime :: !Double , benchAvgCycles :: !Int64 } deriving Show -- | Benchmark the application of the given function to the given input and the -- execution of the resulting IO action to WHNF, spending at least the given -- amount of time in seconds to collect measurements. benchmark :: Double -> (a -> IO b) -> a -> IO BenchmarkStats benchmark period f x = do (meas, _) <- runBenchmark (whnfAppIO f x) period let meas' = rescale <$> V.filter ((>= threshold) . measTime) meas len = length meas' sumMeasure sel = U.sum $ measure sel meas' pure BenchmarkStats { benchAvgTime = sumMeasure measTime / fromIntegral len , benchAvgCpuTime = sumMeasure measCpuTime / fromIntegral len , benchAvgCycles = sumMeasure measCycles `div` fromIntegral len } cryptol-3.0.0/src/Cryptol/Utils/Debug.hs0000644000000000000000000000061207346545000016303 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-3.0.0/src/Cryptol/Utils/Fixity.hs0000644000000000000000000000272307346545000016536 0ustar0000000000000000-- | -- Module : Cryptol.Utils.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.Utils.Fixity ( Assoc(..) , Fixity(..) , defaultFixity , FixityCmp(..) , compareFixity ) where import GHC.Generics (Generic) import Control.DeepSeq -- | Information about associativity. data Assoc = LeftAssoc | RightAssoc | NonAssoc deriving (Show, Eq, Ord, Generic, NFData) data Fixity = Fixity { fAssoc :: !Assoc, fLevel :: !Int } deriving (Eq, Ord, Generic, NFData, Show) data FixityCmp = FCError | FCLeft | FCRight deriving (Show, Eq) -- | Let @op1@ have fixity @f1@ and @op2@ have fixity @f2. Then -- @compareFixity f1 f2@ determines how to parse the infix expression -- @x op1 y op2 z@. -- -- * @FCLeft@: @(x op1 y) op2 z@ -- * @FCRight@: @x op1 (y op2 z)@ -- * @FCError@: no parse 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 cryptol-3.0.0/src/Cryptol/Utils/Ident.hs0000644000000000000000000002523707346545000016332 0ustar0000000000000000-- | -- Module : Cryptol.Utils.Ident -- Copyright : (c) 2015-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} module Cryptol.Utils.Ident ( -- * Module names ModPath(..) , apPathRoot , modPathCommon , modPathIsOrContains , topModuleFor , modPathSplit , modPathIsNormal , ModName , modNameToText , textToModName , modNameChunks , modNameChunksText , packModName , preludeName , preludeReferenceName , undefinedModName , floatName , suiteBName , arrayName , primeECName , interactiveName , noModuleName , exprModName , modNameArg , modNameIfaceMod , modNameToNormalModName , modNameIsNormal -- * Identifiers , Ident , packIdent , packInfix , unpackIdent , mkIdent , mkInfix , isInfixIdent , nullIdent , identText , modParamIdent , identAnonArg , identAnonIfaceMod , identIsNormal -- * Namespaces , Namespace(..) , allNamespaces -- * Original names , OrigName(..) , OrigSource(..) , ogFromModParam -- * Identifiers for primitives , PrimIdent(..) , prelPrim , floatPrim , arrayPrim , suiteBPrim , primeECPrim ) where import Control.DeepSeq (NFData) import Data.Char (isSpace) import Data.List (unfoldr) import Data.Text (Text) import qualified Data.Text as T import Data.String (IsString(..)) import GHC.Generics (Generic) import Cryptol.Utils.Panic(panic) -------------------------------------------------------------------------------- -- | Namespaces for names data Namespace = NSValue | NSType | NSModule deriving (Generic,Show,NFData,Eq,Ord,Enum,Bounded) allNamespaces :: [Namespace] allNamespaces = [ minBound .. maxBound ] -- | Idnetifies a possibly nested module data ModPath = TopModule ModName | Nested ModPath Ident deriving (Eq,Ord,Show,Generic,NFData) apPathRoot :: (ModName -> ModName) -> ModPath -> ModPath apPathRoot f path = case path of TopModule m -> TopModule (f m) Nested p q -> Nested (apPathRoot f p) q topModuleFor :: ModPath -> ModName topModuleFor m = case m of TopModule x -> x Nested p _ -> topModuleFor p -- | Compute a common prefix between two module paths, if any. -- This is basically "anti-unification" of the two paths, where we -- compute the longest common prefix, and the remaining differences for -- each module. modPathCommon :: ModPath -> ModPath -> Maybe (ModPath, [Ident], [Ident]) modPathCommon p1 p2 | top1 == top2 = Just (findCommon (TopModule top1) as bs) | otherwise = Nothing where (top1,as) = modPathSplit p1 (top2,bs) = modPathSplit p2 findCommon com xs ys = case (xs,ys) of (x:xs',y:ys') | x == y -> findCommon (Nested com x) xs' ys' _ -> (com, xs, ys) -- | Does the first module path contain the second? -- This returns true if the paths are the same. modPathIsOrContains :: ModPath -> ModPath -> Bool modPathIsOrContains p1 p2 = case modPathCommon p1 p2 of Just (_,[],_) -> True _ -> False modPathSplit :: ModPath -> (ModName, [Ident]) modPathSplit p0 = (top,reverse xs) where (top,xs) = go p0 go p = case p of TopModule a -> (a, []) Nested b i -> (a, i:bs) where (a,bs) = go b modPathIsNormal :: ModPath -> Bool modPathIsNormal p = modNameIsNormal m && all identIsNormal is where (m,is) = modPathSplit p -------------------------------------------------------------------------------- -- | Top-level Module names are just text. data ModName = ModName Text MaybeAnon deriving (Eq,Ord,Show,Generic) instance NFData ModName -- | Change a normal module name to a module name to be used for an -- anonnymous argument. modNameArg :: ModName -> ModName modNameArg (ModName m fl) = case fl of NormalName -> ModName m AnonModArgName AnonModArgName -> panic "modNameArg" ["Name is not normal"] AnonIfaceModName -> panic "modNameArg" ["Name is not normal"] -- | Change a normal module name to a module name to be used for an -- anonnymous interface. modNameIfaceMod :: ModName -> ModName modNameIfaceMod (ModName m fl) = case fl of NormalName -> ModName m AnonIfaceModName AnonModArgName -> panic "modNameIfaceMod" ["Name is not normal"] AnonIfaceModName -> panic "modNameIfaceMod" ["Name is not normal"] -- | This is used when we check that the name of a module matches the -- file where it is defined. modNameToNormalModName :: ModName -> ModName modNameToNormalModName (ModName t _) = ModName t NormalName modNameToText :: ModName -> Text modNameToText (ModName x fl) = maybeAnonText fl x -- | This is useful when we want to hide anonymous modules. modNameIsNormal :: ModName -> Bool modNameIsNormal (ModName _ fl) = isNormal fl -- | Make a normal module name out of text. textToModName :: T.Text -> ModName textToModName txt = ModName txt NormalName -- | Break up a module name on the separators, `Text` version. modNameChunksText :: ModName -> [T.Text] modNameChunksText (ModName x fl) = unfoldr step x where step str | T.null str = Nothing | otherwise = case T.breakOn modSep str of (a,b) | T.null b -> Just (maybeAnonText fl str, b) | otherwise -> Just (a,T.drop (T.length modSep) b) -- | Break up a module name on the separators, `String` version modNameChunks :: ModName -> [String] modNameChunks = map T.unpack . modNameChunksText 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 = "::" preludeName :: ModName preludeName = packModName ["Cryptol"] undefinedModName :: ModName undefinedModName = packModName ["Undefined module"] preludeReferenceName :: ModName preludeReferenceName = packModName ["Cryptol","Reference"] floatName :: ModName floatName = packModName ["Float"] arrayName :: ModName arrayName = packModName ["Array"] suiteBName :: ModName suiteBName = packModName ["SuiteB"] primeECName :: ModName primeECName = packModName ["PrimeEC"] interactiveName :: ModName interactiveName = packModName [""] noModuleName :: ModName noModuleName = packModName [""] exprModName :: ModName exprModName = packModName [""] -------------------------------------------------------------------------------- -- | Identifies an entitiy data OrigName = OrigName { ogNamespace :: Namespace , ogModule :: ModPath , ogSource :: OrigSource , ogName :: Ident } deriving (Eq,Ord,Show,Generic,NFData) -- | Describes where a top-level name came from data OrigSource = FromDefinition | FromFunctorInst | FromModParam Ident deriving (Eq,Ord,Show,Generic,NFData) -- | Returns true iff the 'ogSource' of the given 'OrigName' is 'FromModParam' ogFromModParam :: OrigName -> Bool ogFromModParam og = case ogSource og of FromModParam _ -> True _ -> False -------------------------------------------------------------------------------- {- | The type of identifiers. * The boolean flag indicates whether or not they're infix operators. The boolean is present just as cached information from the lexer, and never used during comparisons. * The MaybeAnon indicates if this is an anonymous name -} data Ident = Ident Bool MaybeAnon 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 _ mb1 i1) (Ident _ mb2 i2) = compare (mb1,i1) (mb2,i2) instance IsString Ident where fromString str = mkIdent (T.pack str) instance NFData Ident -- | Make a normal (i.e., not anonymous) identifier packIdent :: String -> Ident packIdent = mkIdent . T.pack -- | Make a normal (i.e., not anonymous) identifier packInfix :: String -> Ident packInfix = mkInfix . T.pack unpackIdent :: Ident -> String unpackIdent = T.unpack . identText -- | Make a normal (i.e., not anonymous) identifier mkIdent :: T.Text -> Ident mkIdent = Ident False NormalName mkInfix :: T.Text -> Ident mkInfix = Ident True NormalName isInfixIdent :: Ident -> Bool isInfixIdent (Ident b _ _) = b nullIdent :: Ident -> Bool nullIdent = T.null . identText identText :: Ident -> T.Text identText (Ident _ mb t) = maybeAnonText mb t modParamIdent :: Ident -> Ident modParamIdent (Ident x a t) = Ident x a (T.append (T.pack "module parameter ") t) -- | Make an anonymous identifier for the module corresponding to -- a `where` block in a functor instantiation. identAnonArg :: Ident -> Ident identAnonArg (Ident b _ txt) = Ident b AnonModArgName txt -- | Make an anonymous identifier for the interface corresponding to -- a `parameter` declaration. identAnonIfaceMod :: Ident -> Ident identAnonIfaceMod (Ident b _ txt) = Ident b AnonIfaceModName txt identIsNormal :: Ident -> Bool identIsNormal (Ident _ mb _) = isNormal mb -------------------------------------------------------------------------------- -- | Information about anonymous names. data MaybeAnon = NormalName -- ^ Not an anonymous name. | AnonModArgName -- ^ Anonymous module (from `where`) | AnonIfaceModName -- ^ Anonymous interface (from `parameter`) deriving (Eq,Ord,Show,Generic) instance NFData MaybeAnon -- | Modify a name, if it is a nonymous maybeAnonText :: MaybeAnon -> Text -> Text maybeAnonText mb txt = case mb of NormalName -> txt AnonModArgName -> "`where` argument of " <> txt AnonIfaceModName -> "`parameter` interface of " <> txt isNormal :: MaybeAnon -> Bool isNormal mb = case mb of NormalName -> True _ -> False -------------------------------------------------------------------------------- {- | A way to identify primitives: we used to use just 'Ident', but this isn't good anymore as now we have primitives in multiple modules. This is used as a key when we need to lookup details about a specific primitive. Also, this is intended to mostly be used internally, so we don't store the fixity flag of the `Ident` -} data PrimIdent = PrimIdent ModName T.Text deriving (Eq,Ord,Show,Generic) -- | A shortcut to make (non-infix) primitives in the prelude. prelPrim :: T.Text -> PrimIdent prelPrim = PrimIdent preludeName floatPrim :: T.Text -> PrimIdent floatPrim = PrimIdent floatName suiteBPrim :: T.Text -> PrimIdent suiteBPrim = PrimIdent suiteBName primeECPrim :: T.Text -> PrimIdent primeECPrim = PrimIdent primeECName arrayPrim :: T.Text -> PrimIdent arrayPrim = PrimIdent arrayName instance NFData PrimIdent cryptol-3.0.0/src/Cryptol/Utils/Logger.hs0000644000000000000000000000254707346545000016505 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-3.0.0/src/Cryptol/Utils/Misc.hs0000644000000000000000000000215107346545000016150 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 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 $ runLift $ 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 (Just x , Nothing) -> Just (x, b) (Nothing, Just y ) -> Just (a, y) (Just x , Just y ) -> Just (x, y) cryptol-3.0.0/src/Cryptol/Utils/PP.hs0000644000000000000000000002713207346545000015602 0ustar0000000000000000-- | -- Module : Cryptol.Utils.PP -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE Safe #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Cryptol.Utils.PP where import Cryptol.Utils.Fixity import Cryptol.Utils.Ident import Control.DeepSeq import Control.Monad (mplus) import Data.Maybe (fromMaybe) import Data.String (IsString(..)) import qualified Data.Text as T import Data.Void (Void) import GHC.Generics (Generic) import qualified Prettyprinter as PP import qualified Prettyprinter.Util as PP import qualified Prettyprinter.Render.String as PP -- | How to pretty print things when evaluating data PPOpts = PPOpts { useAscii :: Bool , useBase :: Int , useInfLength :: Int , useFPBase :: Int , useFPFormat :: PPFloatFormat , useFieldOrder :: FieldOrder } deriving Show asciiMode :: PPOpts -> Integer -> Bool asciiMode opts width = useAscii opts && (width == 7 || width == 8) data PPFloatFormat = FloatFixed Int PPFloatExp -- ^ Use this many significant digis | FloatFrac Int -- ^ Show this many digits after floating point | FloatFree PPFloatExp -- ^ Use the correct number of digits deriving Show data PPFloatExp = ForceExponent -- ^ Always show an exponent | AutoExponent -- ^ Only show exponent when needed deriving Show data FieldOrder = DisplayOrder | CanonicalOrder deriving (Bounded, Enum, Eq, Ord, Read, Show) defaultPPOpts :: PPOpts defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5 , useFPBase = 16 , useFPFormat = FloatFree AutoExponent , useFieldOrder = DisplayOrder } -- 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 (OrigName -> Maybe NameFormat) deriving (Generic, NFData) instance Show NameDisp where show _ = "" instance Semigroup NameDisp where NameDisp f <> NameDisp g = NameDisp (\n -> f n `mplus` g n) EmptyNameDisp <> EmptyNameDisp = EmptyNameDisp EmptyNameDisp <> x = x x <> _ = x instance Monoid NameDisp where mempty = EmptyNameDisp mappend = (<>) data NameFormat = UnQualified | Qualified !ModName | NotInScope deriving (Show) -- | Never qualify names from this module. neverQualifyMod :: ModPath -> NameDisp neverQualifyMod mn = NameDisp $ \n -> case ogSource n of FromDefinition | ogModule n == mn -> Just UnQualified _ -> Nothing neverQualify :: NameDisp neverQualify = NameDisp $ \ _ -> Just UnQualified -- | Compose two naming environments, preferring names from the left -- environment. extend :: NameDisp -> NameDisp -> NameDisp extend = mappend -- | Get the format for a name. getNameFormat :: OrigName -> NameDisp -> NameFormat getNameFormat m (NameDisp f) = fromMaybe NotInScope (f m) getNameFormat _ EmptyNameDisp = NotInScope -- | Produce a document in the context of the current 'NameDisp'. withNameDisp :: (NameDisp -> Doc) -> Doc withNameDisp k = withPPCfg (k . ppcfgNameDisp) -- | Produce a document in the context of the current configuration. withPPCfg :: (PPCfg -> Doc) -> Doc withPPCfg k = Doc (\cfg -> runDocWith cfg (k cfg)) -- | Fix the way that names are displayed inside of a doc. fixNameDisp :: NameDisp -> Doc -> Doc fixNameDisp disp d = withPPCfg (\cfg -> fixPPCfg cfg { ppcfgNameDisp = disp } d) -- | Fix the way that names are displayed inside of a doc. fixPPCfg :: PPCfg -> Doc -> Doc fixPPCfg cfg (Doc f) = Doc (\_ -> f cfg) updPPCfg :: (PPCfg -> PPCfg) -> Doc -> Doc updPPCfg f d = withPPCfg (\cfg -> fixPPCfg (f cfg) d) debugShowUniques :: Doc -> Doc debugShowUniques = updPPCfg \cfg -> cfg { ppcfgShowNameUniques = True } -- Documents ------------------------------------------------------------------- data PPCfg = PPCfg { ppcfgNameDisp :: NameDisp , ppcfgShowNameUniques :: Bool } defaultPPCfg :: PPCfg defaultPPCfg = PPCfg { ppcfgNameDisp = mempty , ppcfgShowNameUniques = False } newtype Doc = Doc (PPCfg -> PP.Doc Void) deriving (Generic, NFData) instance Semigroup Doc where (<>) = liftPP2 (<>) instance Monoid Doc where mempty = liftPP mempty mappend = (<>) runDocWith :: PPCfg -> Doc -> PP.Doc Void runDocWith names (Doc f) = f names runDoc :: NameDisp -> Doc -> PP.Doc Void runDoc disp = runDocWith defaultPPCfg { ppcfgNameDisp = disp } instance Show Doc where show d = PP.renderString (PP.layoutPretty opts (runDocWith defaultPPCfg d)) where opts = PP.defaultLayoutOptions { PP.layoutPageWidth = PP.AvailablePerLine 100 0.666 } instance IsString Doc where fromString = text renderOneLine :: Doc -> String renderOneLine d = PP.renderString (PP.layoutCompact (runDocWith defaultPPCfg d)) class PP a where ppPrec :: Int -> a -> Doc class PP a => PPName a where -- | Fixity information for infix operators ppNameFixity :: a -> Maybe Fixity -- | 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 instance PPName ModName where ppNameFixity _ = Nothing ppPrefixName = pp ppInfixName = pp pp :: PP a => a -> Doc pp = ppPrec 0 pretty :: PP a => a -> String pretty = show . pp optParens :: Bool -> Doc -> Doc optParens b body | b = nest 1 (parens body) | otherwise = body -- | Information about an infix expression of some sort. data Infix op thing = Infix { ieOp :: op -- ^ operator , ieLeft :: thing -- ^ left argument , ieRight :: thing -- ^ right argument , ieFixity :: Fixity -- ^ operator fixity } -- | 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 wrapL (ieLeft expr) <+> pp (ieOp expr) , ppSub wrapR (ieRight expr) ] where wrapL f = compareFixity f (ieFixity expr) /= FCLeft wrapR f = compareFixity (ieFixity expr) f /= FCRight ppSub w e | Just e1 <- isInfix e = optParens (w (ieFixity 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 --------------------------------------------------------- liftPP :: PP.Doc Void -> Doc liftPP d = Doc (const d) liftPP1 :: (PP.Doc Void -> PP.Doc Void) -> Doc -> Doc liftPP1 f (Doc d) = Doc (\env -> f (d env)) liftPP2 :: (PP.Doc Void -> PP.Doc Void -> PP.Doc Void) -> (Doc -> Doc -> Doc) liftPP2 f (Doc a) (Doc b) = Doc (\e -> f (a e) (b e)) liftSep :: ([PP.Doc Void] -> PP.Doc Void) -> ([Doc] -> Doc) liftSep f ds = Doc (\e -> f [ d e | Doc d <- ds ]) reflow :: T.Text -> Doc reflow x = liftPP (PP.reflow x) infixl 6 <.>, <+>, (<.>) :: Doc -> Doc -> Doc (<.>) = liftPP2 (PP.<>) (<+>) :: Doc -> Doc -> Doc (<+>) = liftPP2 (PP.<+>) () :: Doc -> Doc -> Doc Doc x Doc y = Doc (\e -> x e <> PP.softline <> y e) infixl 5 $$ ($$) :: Doc -> Doc -> Doc ($$) x y = vsep [x,y] sep :: [Doc] -> Doc sep = liftSep PP.sep fsep :: [Doc] -> Doc fsep = liftSep PP.fillSep hsep :: [Doc] -> Doc hsep = liftSep PP.hsep hcat :: [Doc] -> Doc hcat = liftSep PP.hcat vcat :: [Doc] -> Doc vcat = liftSep PP.vcat vsep :: [Doc] -> Doc vsep = liftSep PP.vsep group :: Doc -> Doc group = liftPP1 PP.group -- NB, this is the semantics of "hang" as defined -- by the HugesPJ printer, not the "hang" from prettyprinter, -- which is subtly different. hang :: Doc -> Int -> Doc -> Doc hang (Doc p) i (Doc q) = Doc (\e -> PP.hang i (PP.vsep [p e, q e])) nest :: Int -> Doc -> Doc nest n = liftPP1 (PP.nest n) indent :: Int -> Doc -> Doc indent n = liftPP1 (PP.indent n) align :: Doc -> Doc align = liftPP1 PP.align parens :: Doc -> Doc parens = liftPP1 PP.parens braces :: Doc -> Doc braces = liftPP1 PP.braces brackets :: Doc -> Doc brackets = liftPP1 PP.brackets quotes :: Doc -> Doc quotes = liftPP1 PP.squotes commaSep :: [Doc] -> Doc commaSep xs = Doc (\e -> PP.sep (PP.punctuate PP.comma [ d e | Doc d <- xs ])) -- | Print a comma-separated list. Lay out each item on a single line -- if it will fit. If an item requires multiple lines, then start it -- on its own line. commaSepFill :: [Doc] -> Doc commaSepFill xs = Doc (\e -> fillSep (PP.punctuate PP.comma [ d e | Doc d <- xs ])) where fillSep [] = mempty fillSep (d0 : ds) = foldl (\a d -> a <> PP.group (PP.line <> d)) d0 ds ppList :: [Doc] -> Doc ppList xs = group (nest 1 (brackets (commaSepFill xs))) ppTuple :: [Doc] -> Doc ppTuple xs = group (nest 1 (parens (commaSep xs))) ppRecord :: [Doc] -> Doc ppRecord xs = group (nest 1 (braces (commaSep xs))) backticks :: Doc -> Doc backticks d = hcat [ "`", d, "`" ] text :: String -> Doc text s = liftPP (PP.pretty s) char :: Char -> Doc char c = liftPP (PP.pretty c) integer :: Integer -> Doc integer i = liftPP (PP.pretty i) int :: Int -> Doc int i = liftPP (PP.pretty i) comma :: Doc comma = liftPP PP.comma colon :: Doc colon = liftPP PP.colon pipe :: Doc pipe = liftPP PP.pipe 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" instance PP Fixity where ppPrec _ (Fixity assoc level) = text "precedence" <+> int level <.> comma <+> pp assoc instance PP ModPath where ppPrec _ p = case p of TopModule m -> pp m Nested q t -> pp q <.> "::" <.> pp t instance PP OrigName where ppPrec _ og = withNameDisp $ \disp -> case getNameFormat og disp of UnQualified -> pp (ogName og) Qualified m -> ppQual (TopModule m) (pp (ogName og)) NotInScope -> ppQual (ogModule og) case ogSource og of FromModParam x -> pp x <.> "::" <.> pp (ogName og) _ -> pp (ogName og) where ppQual mo x = case mo of TopModule m | m == exprModName -> x | otherwise -> pp m <.> "::" <.> x Nested m y -> ppQual m (pp y <.> "::" <.> x) instance PP Namespace where ppPrec _ ns = case ns of NSValue -> "/*value*/" NSType -> "/*type*/" NSModule -> "/*module*/" instance PP PrimIdent where ppPrec _ (PrimIdent m t) = pp m <.> text (T.unpack t) cryptol-3.0.0/src/Cryptol/Utils/Panic.hs0000644000000000000000000000152207346545000016310 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, xxxTODO) 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 xxxTODO :: HasCallStack => String -> a xxxTODO x = panic "TODO" [x] instance PanicComponent Cryptol where panicComponentName _ = "Cryptol" panicComponentIssues _ = "https://github.com/GaloisInc/cryptol/issues" {-# Noinline panicComponentRevision #-} panicComponentRevision = $useGitRevision cryptol-3.0.0/src/Cryptol/Utils/Patterns.hs0000644000000000000000000000704507346545000017064 0ustar0000000000000000{-# Language Safe, RankNTypes, MultiParamTypeClasses #-} {-# Language FunctionalDependencies #-} {-# Language FlexibleInstances #-} {-# Language TypeFamilies, UndecidableInstances #-} {-# Language TypeOperators #-} module Cryptol.Utils.Patterns where import Control.Monad(liftM,liftM2,ap,MonadPlus(..),guard) import qualified Control.Monad.Fail as Fail 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 Match m >>= f = Match $ \no yes -> m no $ \a -> let Match n = f a in n no yes instance Fail.MonadFail Match where fail _ = empty 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-3.0.0/src/Cryptol/Utils/RecordMap.hs0000644000000000000000000001673607346545000017147 0ustar0000000000000000-- | -- Module : Cryptol.Utils.RecordMap -- Copyright : (c) 2020 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable -- -- This module implements an "order insensitive" datastructure for -- record types and values. For most purposes, we want to deal with -- record fields in a canonical order; but for user interaction -- purposes, we generally want to display the fields in the order they -- were specified by the user (in source files, at the REPL, etc.). {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Safe #-} module Cryptol.Utils.RecordMap ( RecordMap , displayOrder , canonicalFields , displayFields , recordElements , displayElements , fieldSet , recordFromFields , recordFromFieldsErr , recordFromFieldsWithDisplay , lookupField , adjustField , traverseRecordMap , mapWithFieldName , zipRecordsM , zipRecords , recordMapAccum ) where import Control.DeepSeq import Control.Monad.Except import Data.Functor.Identity import Data.Set (Set) import Data.Map (Map) import qualified Data.Map.Strict as Map import qualified Data.Map.Merge.Strict as Map import Cryptol.Utils.Panic -- | An "order insensitive" datastructure. -- The fields can be accessed either according -- to a "canonical" order, or based on a -- "display" order, which matches the order -- in which the fields were originally specified. data RecordMap a b = RecordMap { recordMap :: !(Map a b) , _displayOrder :: [a] } -- RecordMap Invariant: -- The `displayOrder` field should contain exactly the -- same set of field names as the keys of `recordMap`. -- Moreover, each field name should occur at most once. instance (Ord a, Eq b) => Eq (RecordMap a b) where a == b = recordMap a == recordMap b instance (Ord a, Ord b) => Ord (RecordMap a b) where compare a b = compare (recordMap a) (recordMap b) instance (Show a, Ord a, Show b) => Show (RecordMap a b) where show = show . displayFields instance (NFData a, NFData b) => NFData (RecordMap a b) where rnf = rnf . canonicalFields -- | Return the fields in this record as a set. fieldSet :: Ord a => RecordMap a b -> Set a fieldSet r = Map.keysSet (recordMap r) -- | The order in which the fields originally appeared. displayOrder :: RecordMap a b -> [a] displayOrder r = _displayOrder r -- | Retrieve the elements of the record in canonical order -- of the field names recordElements :: RecordMap a b -> [b] recordElements = map snd . canonicalFields -- | Return a list of field/value pairs in canonical order. canonicalFields :: RecordMap a b -> [(a,b)] canonicalFields = Map.toList . recordMap -- | Retrieve the elements of the record in display order -- of the field names. displayElements :: (Show a, Ord a) => RecordMap a b -> [b] displayElements = map snd . displayFields -- | Return a list of field/value pairs in display order. displayFields :: (Show a, Ord a) => RecordMap a b -> [(a,b)] displayFields r = map find (displayOrder r) where find x = case Map.lookup x (recordMap r) of Just v -> (x, v) Nothing -> panic "displayFields" ["Could not find field in recordMap " ++ show x , "Display order: " ++ show (displayOrder r) , "Canonical order:" ++ show (map fst (canonicalFields r)) ] -- | Generate a record from a list of field/value pairs. -- Precondition: each field identifier appears at most -- once in the given list. recordFromFields :: (Show a, Ord a) => [(a,b)] -> RecordMap a b recordFromFields xs = case recordFromFieldsErr xs of Left (x,_) -> panic "recordFromFields" ["Repeated field value: " ++ show x] Right r -> r -- | Generate a record from a list of field/value pairs. -- If any field name is repeated, the first repeated name/value -- pair is returned. Otherwise the constructed record is returned. recordFromFieldsErr :: (Show a, Ord a) => [(a,b)] -> Either (a,b) (RecordMap a b) recordFromFieldsErr xs0 = loop mempty xs0 where loop m [] = Right (RecordMap m (map fst xs0)) loop m ((x,v):xs) | Just _ <- Map.lookup x m = Left (x,v) | otherwise = loop (Map.insert x v m) xs -- | Generate a record from a list of field/value pairs, -- and also provide the "display" order for the fields directly. -- Precondition: each field identifier appears at most once in each -- list, and a field name appears in the display order iff it appears -- in the field list. recordFromFieldsWithDisplay :: (Show a, Ord a) => [a] -> [(a,b)] -> RecordMap a b recordFromFieldsWithDisplay dOrd fs = r { _displayOrder = dOrd } where r = recordFromFields fs -- | Lookup the value of a field lookupField :: Ord a => a -> RecordMap a b -> Maybe b lookupField x m = Map.lookup x (recordMap m) -- | Update the value of a field by applying the given function. -- If the field is not present in the record, return Nothing. adjustField :: forall a b. Ord a => a -> (b -> b) -> RecordMap a b -> Maybe (RecordMap a b) adjustField x f r = mkRec <$> Map.alterF f' x (recordMap r) where mkRec m = r{ recordMap = m } f' :: Maybe b -> Maybe (Maybe b) f' Nothing = Nothing f' (Just v) = Just (Just (f v)) -- | Traverse the elements of the given record map in canonical -- order, applying the given action. traverseRecordMap :: Applicative t => (a -> b -> t c) -> RecordMap a b -> t (RecordMap a c) traverseRecordMap f r = (\m -> RecordMap m (displayOrder r)) <$> Map.traverseWithKey f (recordMap r) -- | Apply the given function to each element of a record. mapWithFieldName :: (a -> b -> c) -> RecordMap a b -> RecordMap a c mapWithFieldName f = runIdentity . traverseRecordMap (\a b -> Identity (f a b)) instance Functor (RecordMap a) where fmap f = mapWithFieldName (\_ -> f) instance Foldable (RecordMap a) where foldMap f = foldMap (f . snd) . canonicalFields instance Traversable (RecordMap a) where traverse f = traverseRecordMap (\_ -> f) -- | The function recordMapAccum threads an accumulating argument through -- the map in canonical order of fields. recordMapAccum :: (a -> b -> (a,c)) -> a -> RecordMap k b -> (a, RecordMap k c) recordMapAccum f z r = (a, r{ recordMap = m' }) where (a, m') = Map.mapAccum f z (recordMap r) -- | Zip together the fields of two records using the provided action. -- If some field is present in one record, but not the other, -- an @Either a a@ will be returned, indicating which record is missing -- the field, and returning the name of the missing field. -- -- The @displayOrder@ of the resulting record will be taken from the first -- argument (rather arbitrarily). zipRecordsM :: forall t a b c d. (Ord a, Monad t) => (a -> b -> c -> t d) -> RecordMap a b -> RecordMap a c -> t (Either (Either a a) (RecordMap a d)) zipRecordsM f r1 r2 = runExceptT (mkRec <$> zipMap (recordMap r1) (recordMap r2)) where mkRec m = RecordMap m (displayOrder r1) zipMap :: Map a b -> Map a c -> ExceptT (Either a a) t (Map a d) zipMap = Map.mergeA missingLeft missingRight matched missingLeft = Map.traverseMissing (\a _b -> throwError (Left a)) missingRight = Map.traverseMissing (\a _c -> throwError (Right a)) matched = Map.zipWithAMatched (\a b c -> lift (f a b c)) -- | Pure version of `zipRecordsM` zipRecords :: forall a b c d. Ord a => (a -> b -> c -> d) -> RecordMap a b -> RecordMap a c -> Either (Either a a) (RecordMap a d) zipRecords f r1 r2 = runIdentity (zipRecordsM (\a b c -> Identity (f a b c)) r1 r2) cryptol-3.0.0/src/Cryptol/Utils/Types.hs0000644000000000000000000000051307346545000016361 0ustar0000000000000000-- | Useful information about various types. module Cryptol.Utils.Types where -- | Exponent and precision of 32-bit IEEE-754 floating point. float32ExpPrec :: (Integer, Integer) float32ExpPrec = (8, 24) -- | Exponent and precision of 64-bit IEEE-754 floating point. float64ExpPrec :: (Integer, Integer) float64ExpPrec = (11, 53) cryptol-3.0.0/src/Cryptol/Version.hs0000644000000000000000000000204707346545000015606 0ustar0000000000000000-- | -- Module : Cryptol.Version -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE CPP #-} module Cryptol.Version ( commitHash , commitShortHash , commitBranch , commitDirty , version , displayVersion ) where import Paths_cryptol import qualified GitRev import Data.Version (showVersion) commitHash :: String commitHash = GitRev.hash commitShortHash :: String commitShortHash = take 7 GitRev.hash commitBranch :: String commitBranch = GitRev.branch commitDirty :: Bool commitDirty = GitRev.dirty displayVersion :: Monad m => (String -> m ()) -> m () displayVersion putLn = do let ver = showVersion version putLn ("Cryptol " ++ ver) putLn ("Git commit " ++ commitHash) putLn (" branch " ++ commitBranch ++ dirtyLab) #ifdef FFI_ENABLED putLn "FFI enabled" #endif where dirtyLab | commitDirty = " (non-committed files present during build)" | otherwise = "" cryptol-3.0.0/src/GHC/Num/0000755000000000000000000000000007346545000013326 5ustar0000000000000000cryptol-3.0.0/src/GHC/Num/Compat.hs0000644000000000000000000001044407346545000015110 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnboxedSums #-} {-# LANGUAGE UnboxedTuples #-} -- | -- Module : GHC.Num.Compat -- Description : Defines numeric compatibility shims that work with both -- ghc-bignum (GHC 9.0+) and integer-gmp (older GHCs). -- Copyright : (c) 2021 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable module GHC.Num.Compat ( -- * BigNat# BigNat# , bigNatAdd , bigNatIsOne , bigNatIsZero , bigNatMul , bigNatRem , bigNatSqr , bigNatSub , bigNatSubUnsafe , oneBigNat , recipModBigNat , shiftLBigNat , shiftRBigNat , testBitBigNat , zeroBigNat -- * Integer , Integer(IS, IP, IN) , integerRecipMod -- * Conversions , bigNatToInteger , integerToBigNat ) where #if defined(MIN_VERSION_ghc_bignum) import GHC.Num.BigNat (BigNat#, bigNatAdd, bigNatIsOne, bigNatIsZero, bigNatMul, bigNatRem, bigNatSqr, bigNatSub, bigNatSubUnsafe) import qualified GHC.Num.Backend as BN import qualified GHC.Num.BigNat as BN import GHC.Num.Integer (Integer(IS, IP, IN)) import qualified GHC.Num.Integer as Integer import GHC.Exts -- | Coerce a @BigNat#@ to an integer value. bigNatToInteger :: BigNat# -> Integer bigNatToInteger = Integer.integerFromBigNat# -- | @'integerRecipMod' x m@ computes the modular inverse of @x@ mod @m@. -- -- PRECONDITION: @m@ must be strictly positive. integerRecipMod :: Integer -> Integer -> Maybe Integer integerRecipMod x y = case Integer.integerRecipMod# x (Integer.integerToNaturalClamp y) of (# r | #) -> Just (toInteger r) (# | () #) -> Nothing -- | Coerce an integer value to a @BigNat#@. This operation only really makes -- sense for nonnegative values, but this condition is not checked. integerToBigNat :: Integer -> BigNat# integerToBigNat = Integer.integerToBigNatClamp# -- Top-level unlifted bindings aren't allowed, so we fake one with a thunk. oneBigNat :: (# #) -> BigNat# oneBigNat _ = BN.bigNatFromWord# 1## recipModBigNat :: BigNat# -> BigNat# -> BigNat# recipModBigNat = BN.sbignat_recip_mod 0# shiftLBigNat :: BigNat# -> Int# -> BigNat# shiftLBigNat bn i = BN.bigNatShiftL# bn (int2Word# i) shiftRBigNat :: BigNat# -> Int# -> BigNat# shiftRBigNat bn i = BN.bigNatShiftR# bn (int2Word# i) testBitBigNat :: BigNat# -> Int# -> Bool testBitBigNat bn i = isTrue# (BN.bigNatTestBit# bn (int2Word# i)) -- Top-level unlifted bindings aren't allowed, so we fake one with a thunk. zeroBigNat :: (# #) -> BigNat# zeroBigNat _ = BN.bigNatFromWord# 0## #else import GHC.Integer.GMP.Internals (bigNatToInteger, recipModBigNat, shiftLBigNat, shiftRBigNat, testBitBigNat) import qualified GHC.Integer.GMP.Internals as GMP import GHC.Exts type BigNat# = GMP.BigNat {-# COMPLETE IS, IP, IN #-} pattern IS :: Int# -> Integer pattern IS i = GMP.S# i pattern IP :: ByteArray# -> Integer pattern IP ba = GMP.Jp# (GMP.BN# ba) pattern IN :: ByteArray# -> Integer pattern IN ba = GMP.Jn# (GMP.BN# ba) bigNatAdd :: BigNat# -> BigNat# -> BigNat# bigNatAdd = GMP.plusBigNat bigNatIsOne :: BigNat# -> Bool bigNatIsOne bn = GMP.eqBigNat bn GMP.oneBigNat bigNatIsZero :: BigNat# -> Bool bigNatIsZero = GMP.isZeroBigNat bigNatMul :: BigNat# -> BigNat# -> BigNat# bigNatMul = GMP.timesBigNat bigNatRem :: BigNat# -> BigNat# -> BigNat# bigNatRem = GMP.remBigNat bigNatSqr :: BigNat# -> BigNat# bigNatSqr = GMP.sqrBigNat bigNatSub :: BigNat# -> BigNat# -> (# (# #) | BigNat# #) bigNatSub x y = case GMP.isNullBigNat# res of 0# -> (# | res #) _ -> (# (# #) | #) where res = GMP.minusBigNat x y bigNatSubUnsafe :: BigNat# -> BigNat# -> BigNat# bigNatSubUnsafe = GMP.minusBigNat integerToBigNat :: Integer -> BigNat# integerToBigNat (GMP.S# i) = GMP.wordToBigNat (int2Word# i) integerToBigNat (GMP.Jp# b) = b integerToBigNat (GMP.Jn# b) = b -- | @'integerRecipMod' x m@ computes the modular inverse of @x@ mod @m@. -- -- PRECONDITION: @m@ must be strictly positive. integerRecipMod :: Integer -> Integer -> Maybe Integer integerRecipMod x y | res == 0 = Nothing | otherwise = Just res where res = GMP.recipModInteger x y oneBigNat :: (##) -> BigNat# oneBigNat _ = GMP.oneBigNat zeroBigNat :: (##) -> BigNat# zeroBigNat _ = GMP.zeroBigNat #endif cryptol-3.0.0/src/0000755000000000000000000000000007346545000012166 5ustar0000000000000000cryptol-3.0.0/src/GitRev.hs0000644000000000000000000000103607346545000013722 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-3.0.0/utils/0000755000000000000000000000000007346545000012537 5ustar0000000000000000cryptol-3.0.0/utils/CryHtml.hs0000644000000000000000000000461407346545000014462 0ustar0000000000000000#!/usr/bin/env runhaskell {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module : Main -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable import Cryptol.Parser.Lexer import Cryptol.Parser.Position import Cryptol.Utils.PP import qualified Data.Text.IO as Text import Text.Blaze.Html (Html, AttributeValue, toHtml, (!), toValue) 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.String (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 (Located _ (tokenType -> EOF)) = mempty toBlaze tok = H.span ! (A.class_ $ cl $ tokenType $ thing tok) ! (A.id $ toValue $ show $ pp $ from $ srcRange tok) $ H.toHtml $ tokenText $ thing tok cl :: TokenT -> AttributeValue cl tok = case tok of Num {} -> "number" Frac {} -> "number" Ident {} -> "identifier" Selector {} -> "selector" 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; white-space: pre; }" , ".number { color: #cc00cc }" , ".identifier { }" , ".selector { color: #33033 }" , ".keyword { color: blue; }" , ".operator { color: #cc00cc }" , ".symbol { color: blue }" , ".white { }" , ".virtual { background-color: red }" , ".comment { color: green }" , ".error { color: red }" , ".text { color: #cc00cc }" ]