cryptol 3.5.0 → 3.6.0
raw patch · 75 files changed
+5169/−3890 lines, 75 filesdep ~basedep ~sbvdep ~simple-smtPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, sbv, simple-smt, what4
API changes (from Hackage documentation)
+ REPL.Haskeline: DefBlock :: [String] -> NextLine
- REPL.Haskeline: getInputLines :: String -> InputT REPL NextLine
+ REPL.Haskeline: getInputLines :: Int -> String -> InputT REPL NextLine
Files
- CHANGES.md +141/−3
- cryptol-repl-internal/REPL/Haskeline.hs +75/−14
- cryptol.cabal +11/−8
- lib/Array.cry +5/−5
- lib/Cryptol.cry +20/−4
- lib/Cryptol/Reference.cry +32/−2
- lib/CryptolTC.smt2 +5/−0
- lib/Float.cry +14/−3
- lib/PrimeEC.cry +4/−4
- lib/SuiteB.cry +5/−5
- src/Cryptol/Backend/Concrete.hs +4/−3
- src/Cryptol/Backend/FloatHelpers.hs +7/−3
- src/Cryptol/Backend/What4.hs +4/−4
- src/Cryptol/Eval.hs +26/−12
- src/Cryptol/Eval/Concrete.hs +1/−1
- src/Cryptol/Eval/FFI.hs +22/−26
- src/Cryptol/Eval/FFI/Abstract/Call.hsc +3/−3
- src/Cryptol/Eval/FFI/Abstract/Export.hs +1/−1
- src/Cryptol/Eval/FFI/Abstract/Import.hs +1/−1
- src/Cryptol/Eval/Generic.hs +49/−11
- src/Cryptol/Eval/Reference.lhs +89/−20
- src/Cryptol/Eval/Type.hs +10/−2
- src/Cryptol/Eval/Value.hs +53/−14
- src/Cryptol/IR/TraverseExprs.hs +115/−0
- src/Cryptol/ModuleSystem.hs +2/−2
- src/Cryptol/ModuleSystem/Base.hs +88/−23
- src/Cryptol/ModuleSystem/Binds.hs +125/−244
- src/Cryptol/ModuleSystem/Env.hs +91/−44
- src/Cryptol/ModuleSystem/Interface.hs +44/−2
- src/Cryptol/ModuleSystem/Monad.hs +13/−0
- src/Cryptol/ModuleSystem/Name.hs +31/−16
- src/Cryptol/ModuleSystem/NamingEnv.hs +31/−18
- src/Cryptol/ModuleSystem/NamingEnv/Types.hs +25/−3
- src/Cryptol/ModuleSystem/Renamer.hs +1457/−1472
- src/Cryptol/ModuleSystem/Renamer/Error.hs +70/−36
- src/Cryptol/ModuleSystem/Renamer/ImplicitImports.hs +0/−124
- src/Cryptol/ModuleSystem/Renamer/Imports.hs +0/−579
- src/Cryptol/ModuleSystem/Renamer/Monad.hs +818/−531
- src/Cryptol/Parser.y +68/−64
- src/Cryptol/Parser/AST.hs +130/−40
- src/Cryptol/Parser/ExpandPropGuards.hs +10/−1
- src/Cryptol/Parser/LexerUtils.hs +47/−7
- src/Cryptol/Parser/Name.hs +7/−1
- src/Cryptol/Parser/NoInclude.hs +2/−1
- src/Cryptol/Parser/NoPat.hs +3/−2
- src/Cryptol/Parser/ParserUtils.hs +289/−84
- src/Cryptol/REPL/Command.hs +93/−25
- src/Cryptol/REPL/Help.hs +6/−0
- src/Cryptol/REPL/Monad.hs +69/−5
- src/Cryptol/Symbolic.hs +15/−11
- src/Cryptol/Symbolic/SBV.hs +59/−19
- src/Cryptol/Symbolic/What4.hs +40/−19
- src/Cryptol/Testing/Random.hs +20/−16
- src/Cryptol/TypeCheck/AST.hs +60/−22
- src/Cryptol/TypeCheck/Docstrings.hs +12/−4
- src/Cryptol/TypeCheck/Error.hs +15/−5
- src/Cryptol/TypeCheck/Infer.hs +88/−56
- src/Cryptol/TypeCheck/InferTypes.hs +2/−0
- src/Cryptol/TypeCheck/Interface.hs +7/−3
- src/Cryptol/TypeCheck/Kind.hs +15/−4
- src/Cryptol/TypeCheck/Module.hs +160/−104
- src/Cryptol/TypeCheck/ModuleBacktickInstance.hs +5/−1
- src/Cryptol/TypeCheck/ModuleInstance.hs +18/−6
- src/Cryptol/TypeCheck/Monad.hs +121/−67
- src/Cryptol/TypeCheck/Sanity.hs +37/−27
- src/Cryptol/TypeCheck/SimpType.hs +1/−0
- src/Cryptol/TypeCheck/SimpleSolver.hs +3/−1
- src/Cryptol/TypeCheck/Solver/InfNat.hs +6/−6
- src/Cryptol/TypeCheck/Solver/Numeric.hs +126/−12
- src/Cryptol/TypeCheck/Solver/SMT.hs +43/−5
- src/Cryptol/TypeCheck/TCon.hs +4/−0
- src/Cryptol/TypeCheck/Type.hs +77/−25
- src/Cryptol/TypeCheck/TypePat.hs +4/−1
- src/Cryptol/Utils/Ident.hs +1/−1
- src/Cryptol/Utils/PP.hs +14/−2
CHANGES.md view
@@ -1,3 +1,141 @@+# 3.6.0 -- 2026-09-08++## Language changes++* Allow arbitrary expressions in the head of a record update, previously+ we were restricted to atomic expressions.+ ([#2127](https://github.com/GaloisInc/cryptol/issues/2127))++* Primitives `arrayCopy`, `arraySet`, and `arrayRangeEqual` from the+ built-in `Array` module now have types with `fin` constraints.+ ([#2037](https://github.com/GaloisInc/cryptol/issues/2037))++* Add typechecker simplification rule: `max(a,a) == a`+ ([#1923](https://github.com/GaloisInc/cryptol/issues/1923))++* Allow comma separate parameters in functor `parameter` blocks+ ([#556](https://github.com/GaloisInc/cryptol/issues/556))++* Nested modules and imports of sub-modules may only be used in the+ declarations that follow them. We now add implicit imports for all submodules+ uniformly (previously we did not add implicit imports for functor+ instantiations).+ ([#1992](https://github.com/GaloisInc/cryptol/issues/1992))++* Defining two or more `parameter` blocks within the same module will now raise+ an error. To migrate an existing module that uses multiple `parameter`+ blocks, put all of the parameters under a single `parameter` block before+ they are used.+ ([#1992](https://github.com/GaloisInc/cryptol/issues/1992))++* The REPL now contains some debug flags for dumping the results of+ intermediate Cryptol passes.+ ([#2000](https://github.com/GaloisInc/cryptol/issues/2000))++* The REPL now supports multi-line definition blocks, delimited by `:{`+ and `:}`. Everything between the delimiters is+ processed as a group of top-level declarations, without needing `\`+ continuations or a leading `let`, which makes pasting definitions+ easier.+ ([#2105](https://github.com/GaloisInc/cryptol/issues/2105))++* Add a timeout for individual typechecker SMT queries, configurable with the+ `tcTimeout` REPL option. Timed-out solver processes are killed and replaced.+ ([#2117](https://github.com/GaloisInc/cryptol/issues/2117))++* Support `prime` constraints in numeric constraint guards.+ ([#1658](https://github.com/GaloisInc/cryptol/issues/1658))++* Parameter values of a functor instance are now accessible through a+ virtual submodule named after the parameter (e.g., `M::I::x`).+ ([#1699](https://github.com/GaloisInc/cryptol/issues/1699))++* Interfaces may now be parameterized by other interfaces (interface functors).+ ([#1582](https://github.com/GaloisInc/cryptol/issues/1582))++* Add module aliases for giving short names to+ existing modules, functors, or interfaces.+ ([#1591](https://github.com/GaloisInc/cryptol/issues/1591))++* Add new `foldWhile` primitive, which can optionally break early while+ folding. ([#2028](https://github.com/GaloisInc/cryptol/issues/2028))++* Add a `notPrime` constraint.+ ([#2089](https://github.com/GaloisInc/cryptol/issues/2089))++* Add the following typechecker simplification rules:+ * `K1 != K2 ^^ t ~~> t != logBase K2 K1`+ * `K1 ^^ t >= K2 ~~> t >= logBase K2 K1`+ * `K1 ^^ t > K2 ~~> t > logBase K2 K1`+ * `K1 >= K2 ^^ t ~~> logBase K2 K1 >= t`+ * `K1 > K2 ^^ t ~~> logBase K2 K1 > t`++## Bug fixes++* Fix a panic in the reference evaluator (`:eval`) when evaluating a+ numeric literal at type `Bit`, e.g. `:eval 1 : Bool`. The reference+ evaluator now agrees with the concrete evaluator, treating a nonzero+ literal as `True` and zero as `False`.++* Fix pretty printing of types in errors messages+ ([#2019](https://github.com/GaloisInc/cryptol/issues/2019))++* Fix interface constraint scoping. Interface constraints are kept in+ the order they were declared, but will be floated as early as possible.+ ([#1690](https://github.com/GaloisInc/cryptol/issues/1690))++* Fix incorrect module context computation for nested functors.+ ([#1872](https://github.com/GaloisInc/cryptol/issues/1872))+ ([#1898](https://github.com/GaloisInc/cryptol/issues/1898))++* Don't consider schemas with trivial `True` constraints to be polymorphic.+ ([#1576](https://github.com/GaloisInc/cryptol/issues/1576))++* Don't panic when evaluating parameterized definitions at the REPL after a+ type error.+ ([#2011](https://github.com/GaloisInc/cryptol/issues/2011))++* Fix a bug in `coreLint` that would trigger a panic when checking record+ updates on newtype values.+ ([#2025](https://github.com/GaloisInc/cryptol/issues/2025))++* Fix a bug that would cause Bitwuzla-based provers to fail when reasoning+ about enums.+ ([#2027](https://github.com/GaloisInc/cryptol/issues/2027))++* Fix a bug where calling `roundAway` on floating-point values would return+ incorrect results on concrete values.+ ([#2044](https://github.com/GaloisInc/cryptol/issues/2044))++* Fix the reference evaluator panicking on primitives whose reference+ implementation is written in Cryptol.+ ([#2070](https://github.com/GaloisInc/cryptol/issues/2070))++* Fix a bug in which numeric constraint guards that include "trivial"+ constraints (e.g., `n == n`) could generate ill-typed code.+ ([#2093](https://github.com/GaloisInc/cryptol/issues/2093))++* Fix a bug in which evaluating `fpToBits (fromInteger i : Float e p)` could+ crash if the float size was smaller than a double-precision float.+ ([#2108](https://github.com/GaloisInc/cryptol/issues/2108))++* Change how `:load` adjusts the module search path; see `:help :load`.+ ([#2115](https://github.com/GaloisInc/cryptol/issues/2115))++## API changes++* Add `isValidIdent` to `Cryptol.Parser.LexerUtils`, which checks if a name is+ a valid Cryptol identifier.+ ([#2036](https://github.com/GaloisInc/cryptol/issues/2036))++* Add `pIsNeq` to `Cryptol.TypeCheck.Type`, which recognizes if a Cryptol+ constraint is headed by a not-equal (`!=`) operator.+ ([#2038](https://github.com/GaloisInc/cryptol/issues/2038))++* `Cryptol.TypeCheck.Solver.InfNat.genLog` now takes the log base as the first+ argument instead of the second argument. This better reflects the intuition+ that `genLog base x` mirrors the mathematical notation `log_{base}(x)`.+ # 3.5.0 -- 2026-01-27 ## Administrative changes@@ -31,7 +169,7 @@ and make saving the cache atomic on file systems where renaming a file to an existing file is atomic. This is useful because we get partial results if the validation process is interrupted.- + * Change the default behavior of `-p`/`--project`. The new behavior is that it will check all files that have changed, and also files that have not been previously verified. The old behavior would only validate files that@@ -57,7 +195,7 @@ is only noticeable when working with nested modules. The new behavior works better when these commands are used from docstrings (e.g., with the new behavior, writing `:check` on a submodule, will only check the properties- in that submodule, as expected). + in that submodule, as expected). * When running the `:check-docstrings` command, `Bit` properties (e.g. `property p = True`) will be checked with `:exhaust`, unless their docstrings contain@@ -90,7 +228,7 @@ * Fix #1696, which corrected an incorrect simplification rule, leading to panics.- + * Allow changing the `tcSolver` setting to non-Z3 solvers (e.g., CVC5) without crashing. ([#1874](https://github.com/GaloisInc/cryptol/issues/1874))
cryptol-repl-internal/REPL/Haskeline.hs view
@@ -68,7 +68,8 @@ loop :: Bool -> Int -> InputT REPL CommandResult loop !success !lineNum =- do ln <- getInputLines =<< MTL.lift getPrompt+ do prompt <- MTL.lift getPrompt+ ln <- getInputLines lineNum prompt case ln of NoMoreLines -> return emptyCommandResult { crSuccess = success } Interrupted@@ -77,6 +78,7 @@ NextLine ls | all (all isSpace) ls -> loop success (lineNum + length ls) | otherwise -> doCommand success lineNum ls+ DefBlock ls -> doDeclBlock success lineNum ls run lineNum cmd = case replMode of@@ -84,31 +86,90 @@ InteractiveBatch _ -> runCommand lineNum Nothing cmd Batch path -> runCommand lineNum (Just path) cmd + runBlock lineNum ls =+ case replMode of+ InteractiveRepl -> evalDeclBlock (lineNum + 1) ls Nothing+ InteractiveBatch _ -> evalDeclBlock (lineNum + 1) ls Nothing+ Batch path -> evalDeclBlock (lineNum + 1) ls (Just path)+ doCommand success lineNum txt = case parseCommand findCommandExact (unlines txt) of Nothing | isBatch && stopOnError -> return emptyCommandResult { crSuccess = False } | otherwise -> loop False (lineNum + length txt) -- say somtething? Just cmd -> join $ MTL.lift $ do status <- handleInterrupt (handleCtrlC emptyCommandResult { crSuccess = False }) (run lineNum cmd)- case crSuccess status of- False | isBatch && stopOnError -> return (return status)- _ -> do goOn <- shouldContinue- return (if goOn then loop (crSuccess status && success) (lineNum + length txt) else return status)+ continueAfter success (length txt) lineNum status + doDeclBlock success lineNum ls = join $ MTL.lift $+ do status <- handleInterrupt (handleCtrlC emptyCommandResult { crSuccess = False }) (runBlock lineNum ls)+ -- account for the block body plus the `:{` and `:}` delimiter lines+ continueAfter success (length ls + 2) lineNum status -data NextLine = NextLine [String] | NoMoreLines | Interrupted+ continueAfter success consumed lineNum status =+ case crSuccess status of+ False | isBatch && stopOnError -> pure (pure status)+ _ ->+ do+ goOn <- shouldContinue+ pure $+ if goOn+ then loop (crSuccess status && success) (lineNum + consumed)+ else return status -getInputLines :: String -> InputT REPL NextLine-getInputLines = handleInterrupt (MTL.lift (handleCtrlC Interrupted)) . loop []++-- | The result of reading a chunk of input from the user.+data NextLine+ = NextLine [String]+ -- ^ A single logical command, possibly assembled from multiple physical+ -- lines joined with @\\@ continuation.+ | DefBlock [String]+ -- ^ The body of a @:{@ ... @:}@ definition block, excluding the+ -- delimiter lines. It is parsed as a group of top-level declarations.+ | NoMoreLines+ | Interrupted++-- | Read one chunk of input, tracking multi-line continuations.+getInputLines :: Int -> String -> InputT REPL NextLine+getInputLines lineNum =+ handleInterrupt (MTL.lift (handleCtrlC Interrupted)) . start where- loop ls prompt =- do mb <- fmap (filter (/= '\r')) <$> getInputLine prompt- let newPropmpt = map (\_ -> ' ') prompt+ start prompt =+ do mb <- readLine 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+ Just l -> case trim l of+ ":{" -> block [] (lineNum + 1) (not (null prompt))+ _ -> continuation [] l prompt++ continuation ls l prompt+ | not (null l) && last l == '\\' =+ do mb <- readLine (blanked prompt)+ case mb of+ Nothing -> return NoMoreLines+ Just l' -> continuation (init l : ls) l' (blanked prompt)+ | otherwise = return $ NextLine $ reverse (l : ls)++ block ls n showPrompt =+ do let prompt = if showPrompt then blockPrompt n else ""+ mb <- readLine prompt+ case mb of+ Nothing ->+ do MTL.lift (rPutStrLn "[error] unterminated :{ block")+ return NoMoreLines+ Just l -> case trim l of+ ":}" -> return (DefBlock (reverse ls))+ _ -> block (l : ls) (n + 1) showPrompt++ readLine prompt = fmap (filter (/= '\r')) <$> getInputLine prompt++ blanked = map (const ' ')++ blockPrompt n = replicate (max 0 (blockPromptWidth - length s)) ' ' ++ s ++ "| "+ where s = show n++ blockPromptWidth = 5++ trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse loadCryRC :: Cryptolrc -> REPL CommandResult loadCryRC cryrc =
cryptol.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 2.4 Name: cryptol-Version: 3.5.0+Version: 3.6.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 <http://www.cryptol.net/>. License: BSD-3-Clause@@ -29,7 +29,7 @@ type: git location: https://github.com/GaloisInc/cryptol.git -- add a tag on release branches- tag: 3.5.0+ tag: 3.6.0 flag static@@ -47,7 +47,7 @@ library Default-language: Haskell2010- Build-depends: base >= 4.9 && < 5,+ Build-depends: base >= 4.9 && < 4.22, aeson >= 2.0 && < 2.3, arithmoi >= 0.12, async >= 2.2 && < 2.3,@@ -80,8 +80,12 @@ primitive, process >= 1.2, rme-what4 ^>= 0.1,- sbv >= 9.1 && < 10.11,- simple-smt >= 0.9.8,+ -- See #2054 before changing the sbv pattern.+ -- sbv 11.[1-5] do not build with ghc 9.8, and+ -- 11.6+ do not work with the old z3 we have in+ -- what4-solvers and use in CI.+ sbv >= 9.1 && < 11.1,+ simple-smt >= 1.0.1, stm >= 2.4, strict, text >= 1.1,@@ -92,7 +96,7 @@ mtl >= 2.2.1, time >= 1.6.0.1, panic >= 0.3,- what4 >= 1.6 && < 1.8+ what4 >= 1.6 && < 1.9 if impl(ghc >= 9.0) build-depends: ghc-bignum >= 1.0 && < 1.4@@ -154,8 +158,6 @@ 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, @@ -207,6 +209,7 @@ Cryptol.Transform.Specialize, Cryptol.IR.FreeVars,+ Cryptol.IR.TraverseExprs, Cryptol.IR.TraverseNames, Cryptol.IR.Builder, Cryptol.IR.Prove,
lib/Array.cry view
@@ -22,7 +22,7 @@ * 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)+primitive arrayCopy : {n, a} (fin n) => (Array [n] a) -> [n] -> (Array [n] a) -> [n] -> [n] -> (Array [n] a) /** * Set elements of the given array. *@@ -31,12 +31,12 @@ * * The result is undefined if 'idx + len' wraps around. */-primitive arraySet : {n, a} (Array [n] a) -> [n] -> a -> [n] -> (Array [n] a)+primitive arraySet : {n, a} (fin n) => (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+ * 'arrayRangeEqual 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.@@ -44,7 +44,7 @@ * 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+primitive arrayRangeEqual : {n, a} (fin n) => (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@@ -52,7 +52,7 @@ 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+arrayRangeUpdate arr idx vals = last arrs where arrs = [arr] # [ arrayUpdate acc (idx + i) val | acc <- arrs | i <- [0 ..< n] | val <- vals ]
lib/Cryptol.cry view
@@ -86,6 +86,9 @@ /** Assert that a numeric type is a prime number. */ primitive type prime : # -> Prop +/** Assert that a numeric type is not a prime number. */+primitive type notPrime : # -> Prop+ /** Add numeric types. */ primitive type (+) : # -> # -> # @@ -850,13 +853,13 @@ * Return the first (left-most) element of a sequence. */ head : {n, a} [1 + n]a -> a-head xs = xs @ (0 : Integer)+head xs = xs @ (0 : [8]) /** * Return the right-most element of a sequence. */ last : {n, a} (fin n) => [1 + n]a -> a-last xs = xs ! (0 : Integer)+last xs = xs ! (0 : [8]) /** * Same as 'split', but with a different type argument order.@@ -1154,7 +1157,7 @@ /** * Functional right fold. *- * foldr (-) 0 [1,2,3] = 0 - (1 - (2 - 3))+ * foldr (-) 0 [1,2,3] = 1 - (2 - (3 - 0)) */ foldr : {n, a, b} (fin n) => (a -> b -> b) -> b -> [n]a -> b foldr f acc xs = foldl g acc (reverse xs)@@ -1164,11 +1167,24 @@ * 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' (-) 0 [1,2,3] = 1 - (2 - (3 - 0)) */ 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++/**+ * Functional left fold that can conditionally stop early.+ *+ * Returns the accumulator when the array has been fully traversed+ * or when the function returns `False`.+ *+ * let f = \a b -> (b < 10, max a b)+ * foldWhile f 0 [1, 2, 3] == 3+ * foldWhile f 0 [1, 2, 10, 8] == 10+ * foldWhile f 0 [10, 8, 6] == 10+ */+primitive foldWhile : {n, a, b} (fin n) => (a -> b -> (Bool, a)) -> a -> [n]b -> a /** * Compute the sum of the values in the sequence.
lib/Cryptol/Reference.cry view
@@ -7,7 +7,7 @@ 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 ]+ zs = [0] # [ (z << (1 : [8])) ^ (if yi then 0 # x else 0) | yi <- y | z <- zs ] /** * Performs division of polynomials over GF(2).@@ -41,7 +41,7 @@ reduce u = if u ! degree then u ^ y else u powers : [inf][1 + v]- powers = [reduce 1] # [ reduce (p << 1) | p <- powers ]+ powers = [reduce 1] # [ reduce (p << (1 : [8])) | p <- powers ] zs = [0] # [ z ^ (if xi then tail p else 0) | xi <- reverse x | p <- powers | z <- zs ] @@ -54,6 +54,36 @@ */ foldl : {n, a, b} (fin n) => (a -> b -> a) -> a -> [n]b -> a foldl f z bs = last (scanl f z bs)++/**+ * Functional left fold, with strict evaluation of the accumulator value.+ *+ * The reference evaluator does not model evaluation strategy, so for the+ * purpose of giving semantics this is identical to `foldl`.+ *+ * Reference implementation.+ */+foldl' : {n, a, b} (fin n, Eq a) => (a -> b -> a) -> a -> [n]b -> a+foldl' f z bs = foldl f z bs++/**+ * Functional left fold that can conditionally stop early.+ *+ * Returns the accumulator when the array has been fully traversed+ * or when the function returns `False`.+ *+ * let f = \a b -> (b < 10, max a b)+ * foldWhile f 0 [1, 2, 3] == 3+ * foldWhile f 0 [1, 2, 10, 8] == 10+ * foldWhile f 0 [10, 8, 6] == 10+ */+foldWhile : {n, a, b} (fin n) => (a -> b -> (Bool, a)) -> a -> [n]b -> a+foldWhile f z bs+ | n == 0 => z+ | n > 0 => if c then foldWhile f z' ys else z'+ where+ [y] # ys = bs+ (c, z') = f z y /** * Scan left is like a foldl that also emits the intermediate values.
lib/CryptolTC.smt2 view
@@ -83,6 +83,11 @@ (cryBool (and (isFin x) (cryPrimeUnknown (value x))))) ) +(define-fun cryNotPrime ((x InfNat)) MaybeBool+ (ite (isErr x) cryErrProp+ (cryBool (or (not (isFin x)) (not (cryPrimeUnknown (value x))))))+)+ ; ------------------------------------------------------------------------------ ; Basic Cryptol assume/assert
lib/Float.cry view
@@ -98,6 +98,12 @@ in IEEE interchange format with layout: (sign : [1]) # (biased_exponent : [e]) # (significand : [p-1])++Note that there are multiple bit patterns which correspond to NaN. If+'biased_exponent' has all bits set and 'significand' has at least one bit set,+then 'fpToBits' will return a NaN. On the other hand, calling 'fpFromBits' on+NaN will always return one particular bit pattern (see the documentation for+'fpFromBits' for more details). */ primitive fpFromBits : {e,p} ValidFloat e p => [e + p] -> Float e p@@ -106,9 +112,14 @@ (sign : [1]) # (biased_exponent : [e]) # (significand : [p-1]) -NaN is represented as:- * positive: sign == 0- * quiet with no info: significand == 0b1 # 0+NaN is represented using:+ * an unset sign bit: sign == 0+ * all exponent bits set: biased_exponent == repeat 1+ * quiet with no info: significand == 0b1 # 0++Note that although NaN uses a 'sign' bit 0, it should not be considered a+positive number. The IEEE-754 standard does not interpret the sign of a NaN, so+the sign bit has no mathematical meaning. */ primitive fpToBits : {e,p} ValidFloat e p => Float e p -> [e + p]
lib/PrimeEC.cry view
@@ -4,7 +4,7 @@ * 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', + * 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". */@@ -45,7 +45,7 @@ * 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_point_affine b S = S.y^^(2 : [8]) == S.x^^(3 : [8]) - (3*S.x) + b /**@@ -56,7 +56,7 @@ * 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+ec_is_nonsingular b = (fromInteger 4) * a^^(3 : [8]) + (fromInteger 27) * b^^(2 : [8]) != 0 where a = -3 : Z p /**@@ -91,7 +91,7 @@ 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 }+ R = {x = lambda^^(2 : [8]) * S.x, y = lambda^^(3 : [8]) * S.y } lambda = recip S.z /**
lib/SuiteB.cry view
@@ -117,7 +117,7 @@ aesEncryptBlock : {k} (fin k) => AESEncryptKeySchedule k -> [128] -> [128] aesEncryptBlock schedule plaintext = rnf (join final) where- final = (AESEncFinalRound (rds!0)) ^ schedule.aesEncFinalKey+ final = (AESEncFinalRound (last rds)) ^ schedule.aesEncFinalKey rds = [ schedule.aesEncInitialKey ^ split plaintext ] # [ AESEncRound r ^ rdk@@ -132,7 +132,7 @@ aesDecryptBlock : {k} (fin k) => AESDecryptKeySchedule k -> [128] -> [128] aesDecryptBlock schedule cyphertext = rnf (join final) where- final = (AESDecFinalRound (rds!0)) ^ schedule.aesDecFinalKey+ final = (AESDecFinalRound (last rds)) ^ schedule.aesDecFinalKey rds = [ split cyphertext ^ schedule.aesDecInitialKey ] # [ AESDecRound r ^ rdk@@ -143,9 +143,9 @@ 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)+ { aesEncInitialKey = ks @ (0 : [8])+ , aesEncRoundKeys = ks @@ ([ 1 .. k+5 ] : [_][8])+ , aesEncFinalKey = ks @ (`(k+6) : [8]) } where ks : [k+7]AESRoundKey
src/Cryptol/Backend/Concrete.hs view
@@ -89,7 +89,7 @@ integerToChar = toEnum . fromInteger lg2 :: Integer -> Integer-lg2 i = case genLog i 2 of+lg2 i = case genLog 2 i of Just (i',isExact) | isExact -> i' | otherwise -> i' + 1 Nothing -> 0@@ -146,7 +146,7 @@ wordLen' _ (BV w _) = w {-# INLINE wordLen' #-}- + wordAsChar _ (BV _ x) = Just $! integerToChar x wordBit _ (BV w x) idx = pure $! testBit x (fromInteger (w - 1 - idx))@@ -399,10 +399,11 @@ fpFromInteger sym e p r x = do r' <- fpRoundMode sym r+ let opts = FP.fpOpts e p r' pure FP.BF { FP.bfExpWidth = e , FP.bfPrecWidth = p , FP.bfValue = FP.fpCheckStatus $- FP.bfRoundInt r' (FP.bfFromInteger x)+ FP.bfRoundFloat opts (FP.bfFromInteger x) } fpToInteger = fpCvtToInteger
src/Cryptol/Backend/FloatHelpers.hs view
@@ -155,20 +155,24 @@ do rat <- floatToRational fun fp pure case r of NearEven -> round rat- NearAway -> if rat > 0 then ceiling rat else floor rat+ NearAway -> roundAway rat ToPosInf -> ceiling rat ToNegInf -> floor rat ToZero -> truncate rat _ -> panic "fpCvtToInteger" ["Unexpected rounding mode", show r]+ where+ -- | Evaluate a rational to an integer with rounding away from zero.+ roundAway :: Rational -> Integer+ roundAway r = truncate (r + signum r * 0.5) -floatFromBits :: +floatFromBits :: Integer {- ^ Exponent width -} -> Integer {- ^ Precision widht -} -> Integer {- ^ Raw bits -} -> BF-floatFromBits e p bv = BF { bfValue = bfFromBits (fpOpts e p NearEven) bv +floatFromBits e p bv = BF { bfValue = bfFromBits (fpOpts e p NearEven) bv , bfExpWidth = e, bfPrecWidth = p }
src/Cryptol/Backend/What4.hs view
@@ -175,9 +175,9 @@ -- | 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 :: W4.IsSymExprBuilder sym => What4 sym -> W4.Pred sym -> IO () addDefEqn sym p =- liftIO (modifyMVar_ (w4defs sym) (W4.andPred (w4 sym) p))+ modifyMVar_ (w4defs sym) (W4.andPred (w4 sym) p) -- | Add s safety condition. addSafety :: W4.IsSymExprBuilder sym => W4.Pred sym -> W4Eval sym ()@@ -645,7 +645,7 @@ 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)+ liftIO (addDefEqn sym =<< W4.impliesPred (w4 sym) grd rel) ratio sym x y fpCvtFromRational ::@@ -686,6 +686,6 @@ 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)+ liftIO (addDefEqn sym =<< W4.orPred (w4 sym) divZero rel) return z
src/Cryptol/Eval.hs view
@@ -53,7 +53,7 @@ import Cryptol.Parser.Position import Cryptol.Parser.Selector(ppSelector) import Cryptol.TypeCheck.AST-import Cryptol.TypeCheck.Solver.InfNat(Nat'(..),nMul)+import Cryptol.TypeCheck.Solver.InfNat(Nat'(..),nMul,widthInteger) import Cryptol.Utils.Ident import Cryptol.Utils.Panic (panic) import Cryptol.Utils.PP@@ -69,6 +69,8 @@ import Data.Semigroup import Control.Applicative +import Math.NumberTheory.Primes.Testing (isPrime)+ import Prelude () import Prelude.Compat @@ -259,8 +261,14 @@ 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 PPrime | [n] <- ns ->+ case n of+ Nat n' -> isPrime n'+ Inf -> False+ PC PNotPrime | [n] <- ns ->+ case n of+ Nat n' -> not (isPrime n')+ Inf -> True PC PTrue -> True TError {} -> False _ -> evalPanic "evalProp" ["cannot use this as a guarding constraint: ", show . pp $ TCon tcon ts ]@@ -340,14 +348,14 @@ evalNominalDecl sym nt env0 = case ntDef nt of Struct c -> pure (bindVarDirect (ntConName c) (mkCon structCon) env0)- Enum cs -> foldM enumCon env0 cs+ Enum cs -> foldM (enumCon (length cs)) env0 cs Abstract -> pure env0 where structCon = PFun PPrim mkCon c = foldr tabs c (ntParams nt) - enumCon env c =- do con <- evalEnumCon sym (nameIdent (ecName c)) (ecNumber c)+ enumCon numCons env c =+ do con <- evalEnumCon sym (nameIdent (ecName c)) (ecNumber c) numCons let done = PVal . con . Vector.fromList . reverse fu _t f xs = PFun (\v -> f (v:xs)) pure (bindVarDirect (ecName c)@@ -364,14 +372,20 @@ {-# INLINE evalNominalDecl #-} --- | Make the function for a known constructor+-- | Make the function for a known constructor in an enum. evalEnumCon :: Backend sym =>- sym -> Ident -> Int ->+ sym ->+ -- | The constructor's name.+ Ident ->+ -- | The constructor's tag (zero-indexed).+ Int ->+ -- | The total number of constructors in the enum.+ Int -> SEval sym (Vector (SEval sym (GenValue sym)) -> GenValue sym)-evalEnumCon sym i n =- do tag <- integerLit sym (toInteger n)- pure (VEnum tag . IntMap.singleton n . ConInfo i)+evalEnumCon sym i conIdx numCons =+ do tag <- wordLit sym (widthInteger (toInteger numCons)) (toInteger conIdx)+ pure (VEnum tag . IntMap.singleton conIdx . ConInfo i) @@ -641,7 +655,7 @@ setList n = case e of- VSeq i mp | TVSeq _ elty <- tyv -> + VSeq i mp | TVSeq _ elty <- tyv -> mkSeq sym (Nat i) elty $ updateSeqMap mp n v VStream mp -> pure $ VStream $ updateSeqMap mp n v VWord m -> VWord <$> updateWordValue sym m n asBit
src/Cryptol/Eval/Concrete.hs view
@@ -91,7 +91,7 @@ Abstract -> panic "toExp" ["Asbtract vs Record"] f = foldl (\x t -> ETApp x (tNumValTy t)) (EVar c) ts in pure (EApp f (ERec efs))- (TVNominal nt ts (TVEnum tfss), VEnum i' vf_map) ->+ (TVNominal nt ts (TVEnum tfss), VEnum (BV _ i') vf_map) -> let i = fromInteger i' in case tfss Vector.!? i of
src/Cryptol/Eval/FFI.hs view
@@ -9,35 +9,31 @@ , evalForeignDecls ) where -import Cryptol.Eval.FFI.ForeignSrc- ( ForeignSrc)-#ifdef FFI_ENABLED-import Cryptol.Eval.FFI.ForeignSrc- (ForeignImpl, loadForeignImpl )-#else-import Cryptol.Parser.AST (ForeignMode)-#endif-import Cryptol.Eval.FFI.Error ( FFILoadError )-import Cryptol.Eval (Eval, EvalEnv )-import Cryptol.TypeCheck.AST- ( FFI(..), TVar(TVBound), findForeignDecls )-import Cryptol.TypeCheck.FFI.FFIType ( FFIFunType(..) )+import Cryptol.Eval.FFI.ForeignSrc (ForeignSrc)+import Cryptol.Eval.FFI.Error (FFILoadError)+import Cryptol.Eval (Eval, EvalEnv)+import Cryptol.ModuleSystem.Name (Name)+import Cryptol.TypeCheck.AST (FFI(..), findForeignDecls) #ifdef FFI_ENABLED -import Data.Either(partitionEithers)-import Data.Traversable(for)-import Cryptol.Backend.Concrete-import Cryptol.Backend.Monad-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.Eval.FFI.C(callForeignC)-import Cryptol.Eval.FFI.Abstract(callForeignAbstract)+import Data.Either (partitionEithers)+import Data.Traversable (for) +import Cryptol.Backend.Concrete (Concrete)+import Cryptol.Backend.Monad (io)+import Cryptol.Eval.Env (bindVarDirect)+import Cryptol.Eval.FFI.Abstract (callForeignAbstract)+import Cryptol.Eval.FFI.C (callForeignC)+import Cryptol.Eval.FFI.ForeignSrc (ForeignImpl, loadForeignImpl)+import Cryptol.Eval.Prims (Prim(..))+import Cryptol.Eval.Type (TypeEnv, bindTypeVar)+import Cryptol.Eval.Value (GenValue, Backend(SEval))+import Cryptol.ModuleSystem.Name (nameIdent)+import Cryptol.TypeCheck.AST (TVar(TVBound))+import Cryptol.TypeCheck.FFI.FFIType (FFIFunType(..))+import Cryptol.Utils.Ident (unpackIdent)+ #endif #ifdef FFI_ENABLED@@ -70,7 +66,7 @@ foreignPrim :: FFIFunType t -> (TypeEnv -> [(t,GenValue s)] -> SEval s (GenValue s)) ->- Prim s + Prim s foreignPrim ft k = buildNumPoly (ffiTParams ft) mempty where buildNumPoly (tp:tps) tenv = PNumPoly \n ->
src/Cryptol/Eval/FFI/Abstract/Call.hsc view
@@ -57,14 +57,14 @@ runFFI args ty k = allocaBytes #{size struct CryValImporter} $ \robj -> allocaBytes #{size struct CryValExporter} $ \aobj ->- + do expS <- cryStartExport args #{poke struct CryValExporter, self} aobj expS #{poke struct CryValExporter, recv_u8} aobj cry_recv_u8_addr #{poke struct CryValExporter, recv_u64} aobj cry_recv_u64_addr #{poke struct CryValExporter, recv_double} aobj cry_recv_double_addr #{poke struct CryValExporter, recv_u64_digits} aobj cry_recv_u64_digits_addr- impS <- cryStartImport ty + impS <- cryStartImport ty #{poke struct CryValImporter, self} robj impS #{poke struct CryValImporter, send_bool} robj cry_bool_addr #{poke struct CryValImporter, send_small_uint} robj cry_small_uint_addr@@ -74,7 +74,7 @@ #{poke struct CryValImporter, send_new_large_int} robj cry_large_int_addr #{poke struct CryValImporter, send_sign} robj cry_sign_addr callForeignImpl k [SomeFFIArg aobj, SomeFFIArg robj] :: IO ()- + -- callFFI k retVoid [argPtr aobj, argPtr robj] cryEndExport expS cryFinishImport impS
src/Cryptol/Eval/FFI/Abstract/Export.hs view
@@ -60,7 +60,7 @@ VSeq n sm -> exportValues (enumerateSeqMap n sm) -- 1. tag, 2. constructor values- VEnum tag mp+ VEnum (BV _ tag) mp | 0 <= tag && tag <= toInteger (maxBound :: Int) , let n = fromInteger tag , Just con <- IntMap.lookup n mp ->
src/Cryptol/Eval/FFI/Abstract/Import.hs view
@@ -127,7 +127,7 @@ mkV :: [Value] -> Value mkV vs = pure (VEnum- (toInteger n)+ (BV (enumTagWidth opts) (toInteger n)) (IntMap.singleton n ci { conFields = Vector.fromList vs }))
src/Cryptol/Eval/Generic.hs view
@@ -756,7 +756,7 @@ (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) ->- (SInteger Concrete -> SInteger Concrete -> SEval Concrete a -> SEval Concrete a) ->+ (SWord Concrete -> SWord Concrete -> SEval Concrete a -> SEval Concrete a) -> (TValue -> GenValue Concrete -> GenValue Concrete -> SEval Concrete a -> SEval Concrete a) #-} @@ -770,7 +770,7 @@ (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) ->- (SInteger sym -> SInteger sym -> SEval sym a -> SEval sym a) -> -- ^ how to compare enum tags+ (SWord sym -> SWord sym -> SEval sym a -> SEval sym a) -> -- ^ how to compare enum tags (TValue -> GenValue sym -> GenValue sym -> SEval sym a -> SEval sym a) cmpValue sym merge fb fw fi fz fq ff ftag = cmp where@@ -818,8 +818,8 @@ -- first compare based on tag... ftag tag1 tag2 -- if both tags are concrete...- case (integerAsLit sym tag1, integerAsLit sym tag2) of- (Just i, Just j)+ case (wordAsLit sym tag1, wordAsLit sym tag2) of+ (Just (_, i), Just (_, j)) -- ...then because the comparisons are lazy, this part should -- only be evaluated if tag1 == tag2 | i == j -> do@@ -837,7 +837,7 @@ _ -> do -- in the symbolic case, here tag1 may or may not equal tag2, so -- we need to explicitly check this- sameTag <- intEq sym tag1 tag2+ sameTag <- wordEq sym tag1 tag2 -- if tag1 == tag2, then compare by field, otherwise we are done -- comparing mergeEval sym merge sameTag doFields k@@ -852,9 +852,9 @@ IMap.intersectionWith (,) cons1 cons2 doFieldsForTag i (con1, con2) doRest = do -- if the tag is i, then compare fields for constructor i- i' <- integerLit sym (toInteger i)+ i' <- wordLit sym (wordLen sym tag1) (toInteger i) -- we know tag1 == tag2, so we arbitrarily use tag1 here- isThisTag <- intEq sym tag1 i'+ isThisTag <- wordEq sym tag1 i' mergeEval sym merge isThisTag (cmpFields i con1 con2) doRest@@ -894,7 +894,7 @@ 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- ftag = fi+ ftag = fw {-# INLINE valLt #-} valLt :: Backend sym =>@@ -907,7 +907,7 @@ 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- ftag = fi+ ftag = fw {-# INLINE valGt #-} valGt :: Backend sym =>@@ -920,7 +920,7 @@ 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- ftag = fi+ ftag = fw {-# INLINE eqCombine #-} eqCombine :: Backend sym =>@@ -989,7 +989,10 @@ 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"]- ftag x y k = lexCombine sym (intLessThan sym x y) (intEq sym x y) k+ ftag x y k = lexCombine sym (wordLessThan sym x y) (wordEq sym x y) k+ -- NB: Use `wordLessThan` to compare enum constructor tags,+ -- not `wordSignedLessThan`. We only used signed comparisons+ -- on the constructors' fields, not on the tags. @@ -1939,7 +1942,39 @@ forceValue =<< a' go1 f a' bs +foldWhileV :: Backend sym => sym -> Prim sym+foldWhileV sym =+ PNumPoly \_n ->+ PTyPoly \_a ->+ PTyPoly \_b ->+ PFun \f ->+ PFun \z ->+ PStrict \v ->+ PPrim+ case v of+ VSeq n m -> unwrapF f z (enumerateSeqMap n m)+ VWord wv -> unwrapF f z . map (pure . VBit) =<< enumerateWordValue sym wv+ _ -> panic "Cryptol.Eval.Generic.foldWhileV" ["Expected finite sequence"]+ where+ unwrapF _f a [] = a+ unwrapF f a bs =+ do+ f' <- fromVFun sym <$> f+ go f' a bs + go _f a [] = a+ go f a (b:bs) =+ do+ f' <- fromVFun sym <$> f a+ tup <- fromVTuple <$> f' b+ case tup of+ [condition, a'] ->+ do+ bit <- fromVBit <$> condition+ iteValue sym bit (go f a' bs) a'+ _ -> panic "Cryptol.Eval.Generic.foldWhileV" ["function returned tuple with wrong number of elements"]++ -- scanl : {n, a, b} (a -> b -> a) -> a -> [n]b -> [1+n]a scanlV :: forall sym. Backend sym => sym -> Prim sym scanlV sym =@@ -2362,6 +2397,9 @@ , ("foldl'" , {-# SCC "Prelude::foldl'" #-} foldl'V sym)++ , ("foldWhile" , {-# SCC "Prelude::foldWhile'" #-}+ foldWhileV sym) , ("scanl" , {-# SCC "Prelude::scanl" #-} scanlV sym)
src/Cryptol/Eval/Reference.lhs view
@@ -48,7 +48,9 @@ > (TValue(..), TNominalTypeValue(..), ConInfo(..), > isTBit, evalValType, evalNumType, TypeEnv, bindTypeVar) > import Cryptol.Eval.Concrete (mkBv, ppBV, lg2)-> import Cryptol.Utils.Ident (Ident,PrimIdent, prelPrim, floatPrim, unpackIdent)+> import Cryptol.Utils.Ident+> ( Ident, PrimIdent, prelPrim, floatPrim, unpackIdent, identText+> , preludeReferenceName) > import Cryptol.Utils.Panic (panic) > import Cryptol.Utils.PP > import Cryptol.Utils.RecordMap@@ -56,7 +58,10 @@ > import Cryptol.Eval.Type (evalType, lookupTypeVar, tNumTy, tValTy) > > import qualified Cryptol.ModuleSystem as M+> import qualified Cryptol.ModuleSystem.Base as M (loadModuleFrom) > import qualified Cryptol.ModuleSystem.Env as M (loadedModules,loadedNominalTypes)+> import qualified Cryptol.ModuleSystem.Monad as M+> (ModuleM, runModuleM, getModuleEnv, ImportSource(..)) Overview ========@@ -276,23 +281,32 @@ ------------ An evaluation environment keeps track of the values of term variables-and type variables that are in scope at any point.+and type variables that are in scope at any point. It additionally+carries a table of "redirects" for primitives whose reference+implementation is provided in Cryptol (see `loadReferencePrimImpls`). > data Env = Env-> { envVars :: !(Map Name (E Value))-> , envTypes :: !TypeEnv+> { envVars :: !(Map Name (E Value))+> , envTypes :: !TypeEnv+> , envPrimRedirect :: Map PrimIdent (E Value)+> -- ^ Intentionally lazy: this field is built via a recursive knot+> -- in `evaluate`, where its value depends on the final env that+> -- contains it. Making it strict would tie the knot too tight and+> -- send env construction into a loop. > } > > instance Semigroup Env where > l <> r = Env-> { envVars = envVars l <> envVars r-> , envTypes = envTypes l <> envTypes r+> { envVars = envVars l <> envVars r+> , envTypes = envTypes l <> envTypes r+> , envPrimRedirect = envPrimRedirect l <> envPrimRedirect r > } > > instance Monoid Env where > mempty = Env-> { envVars = mempty-> , envTypes = mempty+> { envVars = mempty+> , envTypes = mempty+> , envPrimRedirect = mempty > } > mappend = (<>) >@@ -577,7 +591,7 @@ > evalDecl :: Env -> Decl -> (Name, E Value) > evalDecl env d = > case dDefinition d of-> DPrim -> (dName d, pure (evalPrim (dName d)))+> DPrim -> (dName d, evalPrim env (dName d)) > DForeign _ me -> (dName d, val) > where > val =@@ -626,11 +640,16 @@ Primitives ========== -To evaluate a primitive, we look up its implementation by name in a table.+To evaluate a primitive, we first look up its implementation by name in+the built-in `primTable`. If the primitive is not there, we fall back to+the environment's redirect table, which may provide a Cryptol-level+reference implementation loaded from `Cryptol::Reference` (see+`loadReferencePrimImpls`). -> evalPrim :: Name -> Value-> evalPrim n-> | Just i <- asPrim n, Just v <- Map.lookup i primTable = v+> evalPrim :: Env -> Name -> E Value+> evalPrim env n+> | Just i <- asPrim n, Just v <- Map.lookup i primTable = pure v+> | Just i <- asPrim n, Just v <- Map.lookup i (envPrimRedirect env) = v > | otherwise = evalPanic "evalPrim" ["Unimplemented primitive", show (pp n)] Cryptol primitives fall into several groups, mostly delineated@@ -1108,6 +1127,7 @@ > literal :: Integer -> TValue -> E Value > literal i = go > where+> go TVBit = pure (VBit (i > 0)) > go TVInteger = pure (VInteger i) > go TVRational = pure (VRational (fromInteger i)) > go (TVFloat e p) = pure (VFloat (fpToBF e p (FP.bfFromInteger i)))@@ -1996,6 +2016,43 @@ > VPoly _ -> text "<polymorphic value>" > VNumPoly _ -> text "<polymorphic value>" +Loading Reference Primitive Implementations+-------------------------------------------++Force-load `Cryptol::Reference` and build a redirect table from primitive+identifiers to the Cryptol-level definitions that live in that module.++This is unusual: normally the reference evaluator just walks whatever+modules the user has loaded. We special-case `Cryptol::Reference` because+a handful of primitives declared in `lib/Cryptol.cry` (e.g. `pmult`,+`pdiv`, `pmod`, `foldl`, `scanl`, `iterate`, ...) have no Haskell+implementation in `primTable`; their reference semantics is given in+Cryptol itself in `lib/Cryptol/Reference.cry`.++The result is a function that, when given the final evaluation+environment, produces a map suitable for `envPrimRedirect`: each entry+maps a primitive's `PrimIdent` to the `E Value` that the same name is+bound to in the env. The caller ties the knot between this map and the+env it eventually builds.++> loadReferencePrimImpls :: M.ModuleM (Env -> Map PrimIdent (E Value))+> loadReferencePrimImpls =+> do _ <- M.loadModuleFrom True (M.FromModule preludeReferenceName)+> modEnv <- M.getModuleEnv+> let refNames =+> [ dName d+> | m <- M.loadedModules modEnv+> , mName m == preludeReferenceName+> , dg <- mDecls m+> , d <- groupDecls dg+> ]+> pure \env ->+> Map.fromList+> [ (prelPrim (identText (nameIdent n)), v)+> | n <- refNames+> , Just v <- [Map.lookup n (envVars env)]+> ]+ Module Command -------------- @@ -2003,11 +2060,23 @@ <expression>` command for the Cryptol REPL, which prints the result of running the reference evaluator on an expression. +Before evaluating, we force-load `Cryptol::Reference` and install its+Cryptol-level definitions as fallback implementations for primitives that+lack a Haskell implementation in `primTable`. Note the recursive knot:+`overrides` looks up names in `envVars env`, while `env` itself is built+on top of an initial environment that contains those very `overrides`.+This is safe because the redirect is consulted lazily, only when a+`DPrim` declaration is forced during evaluation.+ > 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.loadedNominalTypes modEnv)-> env = foldl evalDeclGroup (foldl evalNominalDecl mempty nts) extDgs-> val = evalExpr env expr+> evaluate expr minp = M.runModuleM minp $+> do mkOverrides <- loadReferencePrimImpls+> modEnv <- M.getModuleEnv+> let extDgs = concatMap mDecls (M.loadedModules modEnv)+> ++ M.deDecls (M.meDynEnv modEnv)+> nts = Map.elems (M.loadedNominalTypes modEnv)+> env0 = mempty { envPrimRedirect = mkOverrides env }+> env = foldl evalDeclGroup+> (foldl evalNominalDecl env0 nts)+> extDgs+> pure (evalExpr env expr)
src/Cryptol/Eval/Type.hs view
@@ -34,7 +34,7 @@ -- | An evaluated type of kind *. -- These types do not contain type variables, type synonyms, or type functions. data TValue- = TVBit -- ^ @ Bit @ + = TVBit -- ^ @ Bit @ | TVInteger -- ^ @ Integer @ | TVFloat Integer Integer -- ^ @ Float e p @ | TVIntMod Integer -- ^ @ Z n @@@ -127,6 +127,14 @@ Nat x -> x Inf -> panic "Cryptol.Eval.Value.finNat'" [ "Unexpected `inf`" ] +-- | Compute the mininum number of bits needed to represent an enum tag with+-- the given constructors. See @Note [Represent enum tags as words]@ in+-- "Cryptol.Eval.Value".+enumTagWidth :: Vector (ConInfo a) -> Integer+enumTagWidth cons = widthInteger $ toInteger $ Vector.length cons - 1+ -- Note the use of `- 1` above, which assumes that `cons` is non-empty. This+ -- should always be the case because Cryptol requires enums to have at least+ -- one constructor. -- Type Evaluation ------------------------------------------------------------- @@ -256,7 +264,7 @@ TVFloat e p -> wrapAfter 1 ("Float" <+> integer e <+> integer p) TVIntMod m -> wrapAfter 1 ("Z" <+> integer m) TVRational -> "Rational"- TVArray a b -> wrapAfter 1 ("Array" <+> pp2 0 a <+> pp2 1 b) + TVArray a b -> wrapAfter 1 ("Array" <+> pp2 0 a <+> pp2 1 b) TVSeq m v -> case v of TVBit -> brackets (integer m)
src/Cryptol/Eval/Value.hs view
@@ -26,7 +26,7 @@ module Cryptol.Eval.Value ( -- * GenericValue- GenValue + GenValue (VRecord, VTuple , VEnum, VBit , VInteger, VRational@@ -127,11 +127,13 @@ data GenValue sym = VRecord !(RecordMap Ident (SEval sym (GenValue sym))) -- ^ @ { .. } @ | VTuple ![SEval sym (GenValue sym)] -- ^ @ ( .. ) @- | VEnum !(SInteger sym) !(IntMap (ConValue sym))- -- ^ As an example, consider the enum value @Just ()@. The 'SInteger' is the+ | VEnum !(SWord sym) !(IntMap (ConValue sym))+ -- ^ As an example, consider the enum value @Just ()@. The 'SWord' is the -- tag (e.g., 'Just' would have the tag @0@), and the 'IntMap' contains the -- fields (e.g., @{ 0 -> ("Just",()) }@. The 'IntMap' is only really needed -- to represent symbolic values.+ --+ -- See also @Note [Represent enum tags as words]@. | VBit !(SBit sym) -- ^ @ Bit @ | VInteger !(SInteger sym) -- ^ @ Integer @ or @ Z n @ | VRational !(SRational sym) -- ^ @ Rational @@@ -159,6 +161,43 @@ VRational, VFloat, VWord, VStream, VFun, VPoly, VNumPoly, VSeq #-} +{-+Note [Represent enum tags as words]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When translating enum values to Cryptol's various backends, we encode an enum+constructor by its tag, i.e., an index (starting at zero) representing the+constructor's position in the overall enum. For instance, given:++ enum Option a = None | Some a++Cryptol would give `None` the tag 0, and it would give `Some` the tag 1.++There is a design question of how best to represent these tags when translating+to symbolic backends. Two reasonable options that come to mind are:++1. Represent the tag as an integer (i.e., SMT-Lib's `Int` type).+2. Represent the tag as a word (i.e., SMT-Lib's `BitVec` type).++Option (1) comes with a severe downside that not all solvers support SMT-LIB's+`Int` type (notably, Bitwuzla does not). Moreover, solvers tend to be slightly+faster on purely bitvector-oriented queries than they do with integer-oriented+queries. As such, Cryptol picks option (2).++There is a catch to option (2), however: in addition to knowing what the value+of the tag will be as a word, one must also know the word size in bits.+Different enums will require different word sizes. For instance, `Option` only+has two constructors, so a word size with 1 bit suffices to encode all of its+constructors. On the other hand, it would not suffice to encode all of the+constructors in an an enum like this one:++ enum Grade = A | B | C | D | E | F++Since `Grade` has 6 constructors, we'd need a minimum of three bits to encode+all of its constructors. As such, several parts of the enum implementation in+Cryptol must keep track of the total number of constructors for the sake of+computing the tag's bit width.+-}+ type ConValue sym = ConInfo (SEval sym (GenValue sym)) -- | Force the evaluation of a value@@ -243,8 +282,8 @@ CanonicalOrder -> canonicalFields ppEnumVal prec i mp =- case integerAsLit x i of- Just c ->+ case wordAsLit x i of+ Just (_, c) -> case IMap.lookup (fromInteger c) mp of Just con | isNullaryCon con -> pure (pp (conIdent con))@@ -435,14 +474,14 @@ Inf -> pure $ VStream vals -- | Construct a finite sequence of word values.-wordSeq :: - Backend sym => +wordSeq ::+ Backend sym => sym -> -- | The length of the sequence. Integer -> -- | The word size of the element type. Integer ->- SeqMap sym (GenValue sym) -> + SeqMap sym (GenValue sym) -> SEval sym (GenValue sym) wordSeq sym n w vals = mkSeq sym (Nat n) (TVSeq w TVBit) vals @@ -544,7 +583,7 @@ VRecord fs -> fs _ -> evalPanic "fromVRecord" ["not a record", show val] -fromVEnum :: Backend sym => GenValue sym -> (SInteger sym, IntMap (ConValue sym))+fromVEnum :: Backend sym => GenValue sym -> (SWord sym, IntMap (ConValue sym)) fromVEnum val = case val of VEnum c xs -> (c,xs)@@ -585,20 +624,20 @@ caseValue :: Backend sym => sym ->- SInteger sym ->+ SWord sym -> IntMap (ConValue sym) -> CaseCont sym -> SEval sym (GenValue sym) caseValue sym tag alts k- | Just c <- integerAsLit sym tag =+ | Just (_, c) <- wordAsLit sym tag = case IMap.lookup (fromInteger c) alts of Just conV -> doCase conV Nothing -> panic "caseValue" ["Missing constructor for tag", show c] | otherwise = foldr doSymCase (doDefault Nothing) (IMap.toList alts) where doSymCase (n,con) otherOpts =- do expect <- integerLit sym (toInteger n)- yes <- intEq sym tag expect+ do expect <- wordLit sym (wordLen sym tag) (toInteger n)+ yes <- wordEq sym tag expect iteValue sym yes (doCase con) otherOpts doDefault mb =@@ -639,7 +678,7 @@ Right r -> pure (VRecord r) (VEnum c1 fs1, VEnum c2 fs2) ->- VEnum <$> iteInteger sym c c1 c2+ VEnum <$> iteWord sym c c1 c2 <*> pure (IMap.unionWith (mergeConValue sym c) fs1 fs2) (VTuple vs1 , VTuple vs2 ) | length vs1 == length vs2 ->
+ src/Cryptol/IR/TraverseExprs.hs view
@@ -0,0 +1,115 @@+{-# Language ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Cryptol.IR.TraverseExprs + ( TraverseExprs(..)+ , traverseSubExprs+ , traverseImmSubExprs+ , mapSubExprs+ , mapExprs+ , foldMapSubExprs+ , foldMapExprs+ ) where++import Control.Monad.Writer++import Data.Functor.Identity+import Data.Set(Set)+import qualified Data.Set as Set++import Cryptol.TypeCheck.AST+import Cryptol.Parser.Position(Located(..))++class TraverseExprs t where+ -- | Traverse over constituent expressions, without recursing into sub-expressions.+ traverseExprs :: Applicative f => (Expr -> f Expr) -> t -> f t++-- | Traverse over constituent expressions, first recursing into sub-expressions.+traverseSubExprs ::+ forall t m. (TraverseExprs t, Monad m) => (Expr -> m Expr) -> (t -> m t)+traverseSubExprs f = traverseExprs go+ where+ go :: Expr -> m Expr+ go e = traverseImmSubExprs go e >>= f++mapSubExprs :: TraverseExprs t => (Expr -> Expr) -> t -> t+mapSubExprs f x = runIdentity (traverseSubExprs (Identity . f) x)++mapExprs :: TraverseExprs t => (Expr -> Expr) -> t -> t+mapExprs f x = runIdentity (traverseExprs (Identity . f) x)++foldMapSubExprs :: (TraverseExprs t, Monoid m) => (Expr -> m) -> t -> m+foldMapSubExprs f t = execWriter $ traverseSubExprs (\e -> tell (f e) >> return e) t++foldMapExprs :: (TraverseExprs t, Monoid m) => (Expr -> m) -> t -> m+foldMapExprs f t = execWriter $ traverseExprs (\e -> tell (f e) >> return e) t++-- | Traverse over immediate sub-expressions.+traverseImmSubExprs :: forall f. Applicative f => (Expr -> f Expr) -> Expr -> f Expr+traverseImmSubExprs f se = case se of+ EList es t -> EList <$> go es <*> pure t+ ETuple es -> ETuple <$> go es+ ERec mp -> ERec <$> traverse go mp+ ESel e sel -> ESel <$> go e <*> pure sel+ ESet t e1 sel e2 -> ESet <$> pure t <*> go e1 <*> pure sel <*> go e2+ EIf eP eT eF -> EIf <$> go eP <*> go eT <*> go eF+ ECase e alts malt -> ECase+ <$> go e <*> traverse go alts <*> go malt+ EComp t1 t2 e matches -> EComp+ <$> pure t1 <*> pure t2 <*> go e <*> go matches+ EVar n -> EVar <$> pure n+ ETAbs tps e -> ETAbs <$> pure tps <*> go e+ ETApp e t -> ETApp <$> go e <*> pure t+ EApp e1 e2 -> EApp <$> go e1 <*> go e2+ EAbs n t e -> EAbs <$> pure n <*> pure t <*> go e+ ELocated r e -> ELocated <$> pure r <*> go e+ EProofAbs p e -> EProofAbs <$> pure p <*> go e+ EProofApp e -> EProofApp <$> go e+ EWhere e decls -> EWhere <$> go e <*> traverse go decls+ EPropGuards gs t -> EPropGuards <$> traverse doG gs <*> pure t+ where doG (xs, e) = (,) <$> pure xs <*> go e+ where+ go :: forall t. TraverseExprs t => t -> f t+ go = traverseExprs f++instance TraverseExprs a => TraverseExprs [a] where+ traverseExprs f = traverse (traverseExprs f)++instance TraverseExprs a => TraverseExprs (Maybe a) where+ traverseExprs f = traverse (traverseExprs f)++instance (Ord a, TraverseExprs a) => TraverseExprs (Set a) where+ traverseExprs f = fmap Set.fromList . traverseExprs f . Set.toList++instance TraverseExprs a => TraverseExprs (Located a) where+ traverseExprs f (Located r a) = Located r <$> traverseExprs f a++instance TraverseExprs Expr where+ traverseExprs f = f++instance TraverseExprs CaseAlt where+ traverseExprs f (CaseAlt xs e) =+ CaseAlt <$> pure xs <*> traverseExprs f e++instance TraverseExprs Match where+ traverseExprs f = \case+ From x t1 t2 e -> From <$> pure x <*> pure t1 <*> pure t2 <*> traverseExprs f e+ Let d -> Let <$> traverseExprs f d++instance TraverseExprs DeclDef where+ traverseExprs f = \case+ DPrim -> pure DPrim+ DForeign ffi me -> DForeign <$> pure ffi <*> traverseExprs f me+ DExpr e -> DExpr <$> traverseExprs f e++instance TraverseExprs DeclGroup where+ traverseExprs f = \case+ Recursive ds -> Recursive <$> traverseExprs f ds+ NonRecursive d -> NonRecursive <$> traverseExprs f d++instance TraverseExprs Decl where+ traverseExprs f Decl{..} = Decl+ <$> pure dName <*> pure dSignature <*> traverseExprs f dDefinition <*> pure dPragmas + <*> pure dInfix <*> pure dFixity <*> pure dDoc+
src/Cryptol/ModuleSystem.hs view
@@ -136,13 +136,13 @@ -- 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)+ Base.rename M.interactiveName names (R.resolveNameUse M.NSValue 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)+ Base.rename M.interactiveName names (R.resolveNameUse M.NSType n) -------------------------------------------------------------------------------- -- Dependencies
src/Cryptol/ModuleSystem/Base.hs view
@@ -19,10 +19,10 @@ module Cryptol.ModuleSystem.Base where import qualified Control.Exception as X-import Control.Monad (unless,forM)+import Control.Monad (unless,when,forM) import Data.Set(Set) import qualified Data.Set as Set-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, maybeToList) import Data.List(sortBy) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..))@@ -30,13 +30,15 @@ import Data.Monoid ((<>),Endo(..), Any(..)) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8')-import System.Directory (doesFileExist, canonicalizePath)+import System.Directory+ (doesFileExist, canonicalizePath, makeRelativeToCurrentDirectory) import System.FilePath ( addExtension+ , dropExtension , isAbsolute , joinPath+ , splitDirectories , (</>) , normalise- , takeDirectory , takeFileName ) import qualified System.IO.Error as IOE@@ -59,7 +61,8 @@ , meCoreLint, CoreLint(..) , ModContext(..), ModContextParams(..) , ModulePath(..), modulePathLabel- , EvalForeignPolicy (..))+ , EvalForeignPolicy (..)+ , PassName(..), DebugOpts(..)) import Cryptol.Eval.FFI.ForeignSrc import qualified Cryptol.Eval as E import qualified Cryptol.Eval.Concrete as Concrete@@ -72,7 +75,7 @@ import Cryptol.Parser.AST as P import Cryptol.Parser.NoPat (RemovePatterns(removePatterns)) import qualified Cryptol.Parser.ExpandPropGuards as ExpandPropGuards- ( expandPropGuards, runExpandPropGuardsM )+ ( expandPropGuards, expandTopDecl, runExpandPropGuardsM ) import Cryptol.Parser.NoInclude (removeIncludesModule) import Cryptol.Parser.Position (HasLoc(..), Range, emptyRange) import qualified Cryptol.TypeCheck as T@@ -83,6 +86,7 @@ import Cryptol.Utils.Ident ( preludeName, floatName, arrayName, suiteBName, primeECName , preludeReferenceName, interactiveName, modNameChunks+ , modNameIsNormal , modNamesMatch, Namespace(NSModule) ) import Cryptol.Utils.PP (pretty, pp, hang, vcat, ($$), (<+>), (<.>), colon) import Cryptol.Utils.Panic (panic)@@ -154,6 +158,14 @@ Left err -> expandPropGuardsError err Right a' -> pure a' +-- | Run the expandPropGuards pass on a group of top-level declarations.+expandPropGuardsDecls :: [P.TopDecl PName] -> ModuleM [P.TopDecl PName]+expandPropGuardsDecls ds =+ case ExpandPropGuards.runExpandPropGuardsM $+ concat <$> mapM ExpandPropGuards.expandTopDecl ds of+ Left err -> expandPropGuardsError err+ Right ds' -> pure ds'+ -- Parsing --------------------------------------------------------------------- -- | Parse a module and expand includes@@ -233,11 +245,15 @@ 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+loadModuleByPath eval path = do+ foundPath <- findFile path (fp, deps, pms) <- parseModule (InFile foundPath)- last <$>+ extras <- case [ thing (P.mName pm) | pm <- pms+ , modNameIsNormal (thing (P.mName pm)) ] of+ n : _ -> checkPathLayout foundPath n+ [] -> pure Nothing+ withPrependedSearchPath (maybeToList extras) $+ last <$> forM pms \pm -> do let n = thing (P.mName pm) @@ -258,7 +274,38 @@ | otherwise -> duplicateModuleName n path' loaded where loaded = lmModuleId lm +{- | Check whether the file's parent directories match the parent chunks of+the module's hierarchical name. If they do, return the directory prefix+that should be prepended to the search path so that imports from a sibling+can be resolved. If they do not, emit a warning and return 'Nothing',+leaving the search path alone. -}+checkPathLayout :: FilePath -> ModName -> ModuleM (Maybe FilePath)+checkPathLayout fp mname =+ case stripParentSuffix (modNameChunks mname)+ (splitDirectories (dropExtension (normalise fp))) of+ Just root -> pure (Just (if null root then "." else root))+ Nothing ->+ do relFp <- io (makeRelativeToCurrentDirectory fp)+ withLogger logPutStrLn $+ "[warning] " ++ show relFp ++ " does not match module name " +++ pretty mname+ pure Nothing+ where+ stripParentSuffix chunks p =+ case (reverse chunks, reverse p) of+ -- We just check parent directories, not file name.+ (_ : rcs, _ : rds) -> go rds rcs+ _ -> Nothing+ where+ go rest cs =+ case cs of+ [] -> Just (joinPath (reverse rest))+ c : cs' ->+ case rest of+ d : ds | d == c -> go ds cs'+ _ -> Nothing + -- | Load a module, unless it was previously loaded. loadModuleFrom :: Bool {- ^ quiet mode -} -> ImportSource -> ModuleM (ModulePath,T.TCTopEntity)@@ -453,9 +500,10 @@ 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+ FunctorInstance f as ins k -> FunctorInstance f as ins k+ InterfaceModule s -> InterfaceModule s { sigImports = P.SigImport prel : sigImports s }+ ModuleAlias t -> ModuleAlias t importedMods = map (P.thing . P.iModule . P.thing) (P.mImports m) prel = P.Located@@ -533,14 +581,15 @@ findDeps' m = case mDef m of NormalModule ds -> mconcat (map depsOfDecl ds)- FunctorInstance f as _ ->+ FunctorInstance f as _ _k -> 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))+ InterfaceModule s -> mconcat (map loadSigImp (sigImports s))+ ModuleAlias t -> loadImpName FromModuleAlias t where loadI i = (mempty, Endo (i:)) @@ -552,6 +601,13 @@ loadImpD li = loadImpName (FromImport . new) (thing . iModule <$> li) where new i = i { thing = (thing li) { iModule = i } } + loadIfaceParam mp = loadImpName FromSigImport (mpSignature mp)++ loadSigImp si =+ case si of+ P.SigImport li -> loadImpD li+ P.SigIfaceImport mp -> loadIfaceParam mp+ loadNamedInstArg (ModuleInstanceNamedArg _ f) = loadInstArg f loadInstArg f = case thing f of@@ -621,8 +677,10 @@ decls = mctxDecls fe names = mctxNames fe + epgds <- expandPropGuardsDecls ds+ (declsEnv,rds) <- rename interactiveName names- $ R.renameTopDecls interactiveName ds+ $ R.renameTopDecls epgds prims <- getPrimMap let act = TCAction { tcAction = T.tcDecls, tcLinter = declsLinter , tcPrims = prims }@@ -655,6 +713,15 @@ ModuleM (R.NamingEnv,T.TCTopEntity, Module Name) checkModule isrc m = do + dbgOpts <- getDebugOpts+ let prelOk = dbgIncludePrelude dbgOpts || thing (mName m) /= preludeName+ setting = if dbgIncludePrelude dbgOpts then id else T.debugHidePreludeNames+ dump nm dbg =+ when (prelOk && (nm `Set.member` dbgDumpAfter dbgOpts))+ (io (print (setting (T.debugShowUniques dbg))))++ dump PassParser (pp m) + -- check that the name of the module matches expectations let nm = importedModule isrc unless (modNamesMatch nm (thing (P.mName m)))@@ -662,20 +729,15 @@ -- remove pattern bindings npm <- noPat m+ dump PassNoPat (pp npm) -- run expandPropGuards epgm <- expandPropGuards npm+ dump PassPropGuards (pp epgm) -- rename everything renMod <- renameModule epgm--- {- dump renamed- unless (thing (mName (R.rmModule renMod)) == preludeName)- do (io $ print (T.pp renMod))- -- io $ exitSuccess- --}-+ dump PassRename (pp renMod) -- 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@@ -691,10 +753,13 @@ tcm <- typecheck act (R.rmModule renMod) NoParams (R.rmImported renMod)+ dump PassTC (pp tcm) rewMod <- case tcm of T.TCTopModule mo -> T.TCTopModule <$> liftSupply (`rewModule` mo) T.TCTopSignature {} -> pure tcm+ dump PassREW (pp tcm)+ let nameEnv = case tcm of T.TCTopModule mo -> T.mInScope mo -- Name env for signatures does not change after typechecking
src/Cryptol/ModuleSystem/Binds.hs view
@@ -2,240 +2,44 @@ {-# Language RecordWildCards #-} {-# Language FlexibleInstances #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE PatternSynonyms #-} module Cryptol.ModuleSystem.Binds ( BindsNames- , TopDef(..)- , Mod(..) , ModKind(..)- , modNested , modBuilder- , topModuleDefs- , topDeclsDefs , newModParam , newFunctorInst , InModule(..)- , ifaceToMod- , ifaceSigToMod- , modToMap , defsOf+ , defsOfSig+ , defsOfPats ) 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,forM)+import Control.Monad(forM) import qualified MonadLib as M import Cryptol.Utils.Panic (panic)-import Cryptol.Utils.Ident(allNamespaces)+import Cryptol.Utils.RecordMap(displayElements) import Cryptol.Parser.Position-import Cryptol.Parser.Name(isSystemName)+import Cryptol.Parser.Name(isSystemName, pattern UnQual) 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 = modParamNamesNamingEnv 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.+-- names to instantiate when the signature is used. signatureDefs :: ModPath -> Signature PName -> BuildNamingEnv signatureDefs m sig = mconcat [ namingEnv (InModule loc p) | p <- sigTypeParams sig ]@@ -243,6 +47,9 @@ <> mconcat [ namingEnv (InModule loc p) | p <- sigDecls sig ] where loc = Just m++defsOfSig :: ModPath -> Signature PName -> Supply -> (NamingEnv,Supply)+defsOfSig m sig = buildNamingEnv (signatureDefs m sig) -------------------------------------------------------------------------------- @@ -324,49 +131,65 @@ DPrimType d -> namingEnv (InModule ns (tlValue d)) TDNewtype d -> namingEnv (InModule ns (tlValue d)) TDEnum d -> namingEnv (InModule ns (tlValue d))- DParamDecl {} -> mempty+ DParamDecl {} -> mempty -- shouldn't happen Include {} -> mempty- DImport {} -> mempty -- see 'openLoop' in the renamer+ DImport {} -> mempty -- Handled in renamer DModule m -> namingEnv (InModule ns (tlValue m))- DModParam {} -> mempty -- shouldn't happen+ DModParam {} -> mempty -- Handled in renamer 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)+ namingEnv (InModule mb (NestedModule mdef)) =+ case mb of+ Just m -> BuildNamingEnv $+ do+ let pnmame = mName mdef+ nm <- newTop NSModule m (thing pnmame) Nothing (srcRange pnmame)+ pure (singletonNS NSModule (thing pnmame) nm)+ Nothing -> panic "BindsNames (InModule (NestedModule PName))" ["Nothing"] 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)+ namingEnv (InModule mb PrimType { .. }) =+ case mb of+ Just m ->+ BuildNamingEnv $+ do let Located { .. } = primTName+ nm <- newTop NSType m thing primTFixity srcRange+ pure (singletonNS NSType thing nm)+ Nothing -> panic "BindsNames (InModule (PrimType PName))" ["Nothing"] 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)+ namingEnv (InModule mb ParameterFun { .. }) =+ case mb of+ Just ns -> BuildNamingEnv $+ do+ let Located { .. } = pfName+ ntName <- newTop NSValue ns thing pfFixity srcRange+ return (singletonNS NSValue thing ntName)+ Nothing -> panic "BindsNames (InModule (ParameterFun PName))" ["Nothing"] 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)+ namingEnv (InModule mb ParameterType { .. }) =+ case mb of+ Just ns -> 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)+ Nothing -> panic "BindsNames (InModule (ParameterType PName))" ["Nothing"] 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 NSConstructor ns thing Nothing srcRange- return (singletonNS NSType thing ntName `mappend`- singletonNS NSConstructor thing ntConName)+ namingEnv (InModule mb Newtype { .. }) =+ case mb of+ Just ns -> BuildNamingEnv $+ do let Located { .. } = nName+ ntName <- newTop NSType ns thing Nothing srcRange+ ntConName <- newTop NSConstructor ns thing Nothing srcRange+ return (singletonNS NSType thing ntName `mappend`+ singletonNS NSConstructor thing ntConName)+ Nothing -> panic "BindsNames (InModule (Newtype PName))" ["Nothing"] instance BindsNames (InModule (EnumDecl PName)) where namingEnv (InModule (Just ns) EnumDecl { .. }) = BuildNamingEnv $@@ -413,17 +236,75 @@ SigTySyn ts _ -> namingEnv (InModule m (DType ts)) SigPropSyn ps _ -> namingEnv (InModule m (DProp ps)) -instance BindsNames (Pattern PName) where- namingEnv pat =- case pat of- PVar x -> BuildNamingEnv (- do y <- newLocal NSValue (thing x) (srcRange x)- pure (singletonNS NSValue (thing x) y)- )- PCon _ xs -> mconcat (map namingEnv xs)- PLocated p _r -> namingEnv p- PTyped p _t -> namingEnv p- _ -> panic "namingEnv" ["Unexpected pattern"]++type PatsM = M.StateT (Set Ident) (SupplyT M.Id)++-- | We have a special case for this, because of the existential types+-- that we might encounter in the types of patterns. In particular, if+-- we see `p : T` and `T` mentions a name `a` which is not otherwise defined,+-- we treat it as a new existential variable, and it is now considered defined+-- (i.e., other references to `a` should use the same name).+defsOfPats ::+ Set Ident {- ^ Unqalified type level names that are in scope -} ->+ [Pattern PName] {- ^ We want to know what names are introduced by these -} ->+ Supply -> (NamingEnv,Supply)+defsOfPats bound ps s =+ M.runId (runSupplyT s (fst <$> M.runStateT bound (defsOfPats' ps)))++defsOfPats' :: [Pattern PName] -> PatsM NamingEnv+defsOfPats' ps =+ case ps of+ [] -> pure mempty+ p : more -> (<>) <$> defsOfPat p <*> defsOfPats' more++defsOfPat :: Pattern PName -> PatsM NamingEnv+defsOfPat pat =+ case pat of++ PVar x ->+ do+ y <- newLocal NSValue (thing x) (srcRange x)+ pure (singletonNS NSValue (thing x) y) ++ PCon _ xs -> defsOfPats' xs+ PLocated p _r -> defsOfPat p+ PTyped p t -> (<>) <$> defsOfTy t <*> defsOfPat p+ _ -> panic "namingEnv" ["Unexpected pattern"]++-- | Look for "naming" type variables in the type.+defsOfTy :: Type PName -> PatsM NamingEnv+defsOfTy ty =+ case ty of+ TFun a b -> defsOfTys [a,b]+ TSeq n t -> defsOfTys [n,t]+ TBit -> pure mempty+ TNum {} -> pure mempty+ TChar {} -> pure mempty++ TUser Located { thing = nm@(UnQual i), srcRange = rng } [] ->+ do+ bound <- M.get+ if i `Set.member` bound+ then pure mempty+ else+ do+ y <- newLocal NSType nm rng+ M.sets (\b -> (singletonNS NSType nm y, Set.insert i b))++ TUser _ ts -> defsOfTys ts+ TTyApp {} -> panic "defsOfTy" ["TTyApp"]+ TRecord r -> defsOfTys (map snd (displayElements r))+ TTuple ts -> defsOfTys ts+ TWild -> pure mempty+ TLocated t _ -> defsOfTy t+ TParens t _ -> defsOfTy t+ TInfix t1 _ _ t2 -> defsOfTys [t1,t2]+ +defsOfTys :: [Type PName] -> PatsM NamingEnv+defsOfTys tys =+ case tys of+ t : more -> (<>) <$> defsOfTy t <*> defsOfTys more+ [] -> pure mempty
src/Cryptol/ModuleSystem/Env.hs view
@@ -26,7 +26,7 @@ import qualified Cryptol.IR.FreeVars as T import Cryptol.ModuleSystem.Fingerprint import Cryptol.ModuleSystem.Interface-import Cryptol.ModuleSystem.Name (Name,NameInfo(..),Supply,emptySupply,nameInfo,nameTopModuleMaybe)+import Cryptol.ModuleSystem.Name (Name,Supply,emptySupply,nameTopModuleMaybe,nameIdent,asOrigName) import qualified Cryptol.ModuleSystem.NamingEnv as R import Cryptol.Parser.AST import qualified Cryptol.TypeCheck as T@@ -99,7 +99,8 @@ , meEvalForeignPolicy :: EvalForeignPolicy -- ^ How to evaluate @foreign@ bindings.-+ + , meDebugOpts :: !DebugOpts } deriving Generic instance NFData ModuleEnv where@@ -110,6 +111,22 @@ | CoreLint -- ^ Run core lint deriving (Generic, NFData) +data PassName =+ PassParser | PassNoPat | PassPropGuards | PassRename | PassTC | PassREW+ deriving (Eq,Ord,Enum,Bounded,Show)++data DebugOpts = DebugOpts {+ dbgIncludePrelude :: Bool, -- ^ Should we dump `Cryptol.cry`+ dbgDumpAfter :: Set PassName+}++noDebugOpts :: DebugOpts+noDebugOpts = DebugOpts {+ dbgIncludePrelude = False,+ dbgDumpAfter = mempty+}++ -- | How to evaluate @foreign@ bindings. data EvalForeignPolicy -- | Use foreign implementation and report an error at module load time if it@@ -189,6 +206,7 @@ , meCoreLint = NoCoreLint , meSupply = emptySupply , meEvalForeignPolicy = defaultEvalForeignPolicy+ , meDebugOpts = noDebugOpts } -- | Try to focus a loaded module in the module environment.@@ -277,33 +295,51 @@ , mctxNameDisp = R.toNameDisp mempty } -findEnv :: Name -> Iface -> T.ModuleG a -> Maybe (R.NamingEnv, Set Name)-findEnv n iface m+-- | 'IfaceDecls` should contain enough information so that we can check+-- and evalute everything in scope. At the moment we just pass all loaded+-- things here. See 'modContextOf'.+findEnv ::+ ModuleEnv -> IfaceDecls -> Name -> Iface -> T.ModuleG a -> Maybe ModContext+findEnv me loaded n iface m | Just sm <- Map.lookup n (T.mSubmodules m) =- Just (T.smInScope sm, ifsPublic (T.smIface sm))+ let localNames = T.smInScope sm in+ Just+ ModContext+ { mctxParams = NoParams+ , mctxExported = ifsPublic (T.smIface sm)+ , mctxDecls = loaded+ , mctxNames = localNames+ , mctxNameDisp = R.toNameDisp localNames+ }+ | Just fn <- Map.lookup n (T.mFunctors m) = case Map.lookup n (ifFunctors (ifDefines iface)) of Nothing -> panic "findEnv" ["Submodule functor not present in interface"]- Just d -> Just (T.mInScope fn, ifsPublic (ifNames d))- | otherwise = asum (fmap (findEnv n iface) (Map.elems (T.mFunctors m)))+ Just d ->+ let localNames = T.mInScope fn in+ Just+ ModContext+ { mctxParams = FunctorParams (ifParams d)+ , mctxExported = ifsPublic (ifNames d)+ , mctxDecls = ifDefines d <> loaded+ , mctxNames = localNames+ , mctxNameDisp = R.toNameDisp localNames+ } + | Just target <- Map.lookup n (T.mModAliases m) = modContextOf target me++ | otherwise = asum (fmap (findEnv me loaded n iface) (Map.elems (T.mFunctors m)))+ modContextOf :: ImpName Name -> ModuleEnv -> Maybe ModContext modContextOf (ImpNested name) me = do -- find the top module:- mname <- nameTopModuleMaybe name- lm <- lookupModule mname me+ mname <- nameTopModuleMaybe name+ lm <- lookupModule mname me+ let loadedDecls = map (ifDefines . lmInterface)+ $ getLoadedModules (meLoadedModules me)+ loaded = mconcat (ifDefines (lmInterface lm) : loadedDecls)+ findEnv me loaded name (lmInterface lm) (lmModule lm) - (localNames, exported) <- findEnv name (lmInterface lm) (lmModule lm)- let -- XXX: do we want only public ones here?- loadedDecls = map (ifDefines . lmInterface)- $ getLoadedModules (meLoadedModules me)- pure ModContext- { mctxParams = NoParams- , mctxExported = exported- , mctxDecls = mconcat (ifDefines (lmInterface lm) : loadedDecls)- , mctxNames = localNames- , mctxNameDisp = R.toNameDisp localNames- } -- TODO: support focusing inside a submodule signature to support browsing? modContextOf (ImpTop mname) me = do lm <- lookupModule mname me@@ -568,25 +604,39 @@ isLoadedStrict mn modId lm = isLoaded mn lm && modId `Set.member` getLoadedIds lm --- | Is this a loaded parameterized module.-isLoadedParamMod :: ImpName Name -> LoadedModules -> Bool-isLoadedParamMod (ImpTop mn) lm = any ((mn ==) . lmName) (lmLoadedParamModules lm)-isLoadedParamMod (ImpNested n) lm =- any (check1 . lmModule) (lmLoadedModules lm) ||- any (check2 . lmModule) (lmLoadedParamModules lm)+-- | Does the given module path refer something with parameters.+-- Note that it is possible that the thing itself is not parameterized+-- explicitly, but it resides within a parameterized entity.+isLoadedParamModPath :: I.ModPath -> LoadedModules -> Bool+isLoadedParamModPath pa lms = isParam pa where- -- We haven't crossed into a parameterized functor yet- check1 m = Map.member n (T.mFunctors m)- || any check2 (T.mFunctors m)-- -- We're inside a parameterized module and are finished as soon as we have containment- check2 :: T.ModuleG a -> Bool- check2 m =- Map.member n (T.mSubmodules m) ||- Map.member n (T.mSignatures m) ||- Map.member n (T.mFunctors m) ||- any check2 (T.mFunctors m)+ roots = Set.fromList (topParam ++ topNonParam)+ topParam = map (I.TopModule . T.mName . lmModule) (lmLoadedParamModules lms)+ topNonParam =+ [ I.Nested top (nameIdent f)+ | m <- lmLoadedModules lms,+ let mo = lmModule m+ top = I.TopModule (T.mName mo)+ , f <- Map.keys (T.mFunctors mo)+ ]+ isParam x =+ (x `Set.member` roots) ||+ case x of+ I.Nested mo _ -> isParam mo+ I.TopModule _ -> False +-- | Is this a loaded parameterized module.+-- Assumes that the name was referring to a module to start with.+isLoadedParamMod :: ImpName Name -> LoadedModules -> Bool+isLoadedParamMod nm =+ isLoadedParamModPath $+ case nm of+ ImpTop x -> I.TopModule x+ ImpNested n ->+ case asOrigName n of+ Just yes -> I.Nested (I.ogModule yes) (I.ogName yes)+ Nothing -> panic "isLoadedParamMod" ["Missing OG name"]+ -- | Is this a loaded interface module. isLoadedInterface :: ImpName Name -> LoadedModules -> Bool isLoadedInterface (ImpTop mn) ln = any ((mn ==) . lmName) (lmLoadedSignatures ln)@@ -613,13 +663,8 @@ badTs = T.tyParams ds badName nm bs =- case nameInfo nm of-- -- XXX: Changes if focusing on nested modules- GlobalName _ I.OrigName { ogModule = I.TopModule m }- | isLoadedParamMod (ImpTop m) lm -> Set.insert nm bs- | isLoadedInterface (ImpTop m) lm -> Set.insert nm bs-+ case asOrigName nm of+ Just og | isLoadedParamModPath (I.ogModule og) lm -> Set.insert nm bs _ -> bs @@ -793,6 +838,8 @@ , ifModules = Map.empty , ifFunctors = Map.empty , ifSignatures = Map.empty+ , ifModuleAliases = Map.empty+ , ifSigOwnParams = Nothing } where decls = mconcat
src/Cryptol/ModuleSystem/Interface.hs view
@@ -16,11 +16,14 @@ Iface , IfaceG(..) , IfaceDecls(..)+ , IfaceParamDecls+ , ParamDecls(..) , IfaceDecl(..) , IfaceNames(..) , ifModName , emptyIface+ , ifIsSignature , ifacePrimMap , ifaceForgetName , ifaceIsFunctor@@ -38,7 +41,9 @@ import Data.Text (Text) import GHC.Generics (Generic)+import Control.Applicative((<|>)) import Control.DeepSeq+import Data.Maybe(isJust, maybeToList) import Prelude () import Prelude.Compat@@ -49,7 +54,6 @@ import Cryptol.Utils.Fixity(Fixity) import Cryptol.Parser.AST(Pragma, ImpName(..)) import Cryptol.TypeCheck.Type-import Data.Maybe (maybeToList) type Iface = IfaceG ModName @@ -61,6 +65,10 @@ -- (includes nested definitions) } deriving (Show, Generic, NFData, Functor) +-- | Is this an interface functor (parameterized interface)?+ifIsSignature :: IfaceG name -> Bool+ifIsSignature = isJust . ifSigOwnParams . ifDefines+ -- | 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 ()@@ -112,10 +120,26 @@ 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. -}+ compilation. + This map contains both regular functors and interface functors+ (parameterized interfaces). Interface functors have a 'Just' value+ in 'ifSigOwnParams'. -}++ , ifModuleAliases :: !(Map.Map Name (ImpName Name))++ , ifSigOwnParams :: !(Maybe IfaceParamDecls)+ {- ^ For interface functors only. Contains the interface's own type+ and value parameter declarations that are not part of the imported+ interface parameters in 'ifParams'. These are the declarations that+ get passed through when the interface functor is instantiated.+ 'Nothing' for non-interface-functor modules.+ Note: type synonyms defined in the interface are in 'ifTySyns'. -} } deriving (Show, Generic, NFData) +-- | The type and value parameters declared directly by an interface functor.+type IfaceParamDecls = ParamDecls+ filterIfaceDecls :: (Name -> Bool) -> IfaceDecls -> IfaceDecls filterIfaceDecls p ifs = IfaceDecls { ifTySyns = filterMap (ifTySyns ifs)@@ -124,10 +148,17 @@ , ifModules = filterMap (ifModules ifs) , ifFunctors = filterMap (ifFunctors ifs) , ifSignatures = filterMap (ifSignatures ifs)+ , ifModuleAliases = filterMap (ifModuleAliases ifs)+ , ifSigOwnParams = filterSigParams <$> ifSigOwnParams ifs } where filterMap :: Map.Map Name a -> Map.Map Name a filterMap = Map.filterWithKey (\k _ -> p k)+ filterSigParams ps = ParamDecls+ { pdTypes = filterMap (pdTypes ps)+ , pdFuns = filterMap (pdFuns ps)+ , pdConstraints = pdConstraints ps+ } ifaceDeclsNames :: IfaceDecls -> Set Name ifaceDeclsNames i = Set.unions [ Map.keysSet (ifTySyns i)@@ -136,7 +167,12 @@ , Map.keysSet (ifModules i) , Map.keysSet (ifFunctors i) , Map.keysSet (ifSignatures i)+ , sigParamNames (ifSigOwnParams i) ]+ where+ sigParamNames Nothing = Set.empty+ sigParamNames (Just ps) = Map.keysSet (pdTypes ps) `Set.union`+ Map.keysSet (pdFuns ps) instance Semigroup IfaceDecls where@@ -147,6 +183,8 @@ , ifModules = Map.union (ifModules l) (ifModules r) , ifFunctors = Map.union (ifFunctors l) (ifFunctors r) , ifSignatures = ifSignatures l <> ifSignatures r+ , ifModuleAliases = Map.union (ifModuleAliases l) (ifModuleAliases r)+ , ifSigOwnParams = ifSigOwnParams l <|> ifSigOwnParams r } instance Monoid IfaceDecls where@@ -157,6 +195,8 @@ , ifModules = mempty , ifFunctors = mempty , ifSignatures = mempty+ , ifModuleAliases = mempty+ , ifSigOwnParams = Nothing } mappend = (<>) mconcat ds = IfaceDecls@@ -166,6 +206,8 @@ , ifModules = Map.unions (map ifModules ds) , ifFunctors = Map.unions (map ifFunctors ds) , ifSignatures = Map.unions (map ifSignatures ds)+ , ifModuleAliases = Map.unions (map ifModuleAliases ds)+ , ifSigOwnParams = foldr ((<|>) . ifSigOwnParams) Nothing ds } data IfaceDecl = IfaceDecl
src/Cryptol/ModuleSystem/Monad.hs view
@@ -69,6 +69,7 @@ | FromImport (Located P.Import) | FromSigImport (Located P.ModName) | FromModuleInstance (Located P.ModName)+ | FromModuleAlias (Located P.ModName) deriving (Show, Generic, NFData) instance Eq ImportSource where@@ -81,6 +82,8 @@ FromSigImport l -> text "import of interface" <+> pp (P.thing l) FromModuleInstance l -> text "instantiation of module" <+> pp (P.thing l)+ FromModuleAlias l ->+ text "module alias for" <+> pp (P.thing l) importedModule :: ImportSource -> P.ModName importedModule is =@@ -89,6 +92,7 @@ FromImport li -> P.thing (P.iModule (P.thing li)) FromModuleInstance l -> P.thing l FromSigImport l -> P.thing l+ FromModuleAlias l -> P.thing l data ModuleError@@ -649,6 +653,12 @@ getSearchPath :: ModuleM [FilePath] getSearchPath = ModuleT (meSearchPath `fmap` get) +-- | Replace the search path.+setSearchPath :: [FilePath] -> ModuleM ()+setSearchPath fps = ModuleT $ do+ env <- get+ set $! env { meSearchPath = fps }+ -- | Run a 'ModuleM' action in a context with a prepended search -- path. Useful for temporarily looking in other places while -- resolving imports, for example.@@ -677,3 +687,6 @@ withLogger :: (Logger -> a -> IO b) -> a -> ModuleM b withLogger f a = do l <- getEvalOpts io (f (evalLogger l) a)++getDebugOpts :: ModuleM DebugOpts+getDebugOpts = ModuleT (meDebugOpts <$> get)
src/Cryptol/ModuleSystem/Name.hs view
@@ -33,6 +33,7 @@ , nameToPNameWithQualifiers , asPrim , asOrigName+ , nameModParam , nameModPath , nameModPathMaybe , nameTopModule@@ -62,17 +63,17 @@ ) where import Control.DeepSeq+import Data.Char(isAlpha,toUpper)+import Data.Functor.Identity(runIdentity) import qualified Data.Map as Map+import Data.Maybe import qualified Data.Monoid as M-import Data.Functor.Identity(runIdentity)+import qualified Data.Text as Text 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.Name (PName, NameSource(..)) import qualified Cryptol.Parser.Name as PName import Cryptol.Parser.Position (Range,Located(..))@@ -239,27 +240,35 @@ nameToDefPName :: Name -> PName nameToDefPName n = case nInfo n of- GlobalName ns og -> PName.origNameToDefPName og ns+ GlobalName ns og -> PName.origNameToDefPName og ns LocalName ns _ txt -> PName.UnQual' txt ns --- | Compute a `PName` from `Name`, this preserves all qualifiers in the name,--- whereas `nameToDefPName` does not.+-- | Compute a `PName` from `Name`.+--+-- This function preserves module qualifiers in the name, as compared+-- to `nameToDefPName` which does *not* preserve module qualifiers.+--+-- FIXME: this should qualify names that come from module+-- parameters (as `nameToDefPName` does).+-- nameToPNameWithQualifiers :: Name -> PName nameToPNameWithQualifiers n = case nameInfo n of- GlobalName ns og -> origNameToPName og ns LocalName ns _ txt -> PName.UnQual' txt ns+ GlobalName ns og -> case quals of+ [] -> PName.UnQual' ident ns+ ms -> PName.Qual (packModName ms) ident - where- origNameToPName :: OrigName -> NameSource -> PName- origNameToPName og vis =- case modPathSplit (ogModule og) of- (_top,[] ) -> PName.UnQual' ident vis- (_top,ids) -> PName.Qual (packModName (map identText ids)) ident+ where+ ident = ogName og - where- ident = ogName og+ -- add the rest of needed qualifiers to `quals`:+ quals = case modPathSplit (ogModule og) of+ (_top,[] ) -> param+ (_top,ids) -> map identText ids ++ param + -- if name from a Parameter, we start with qualifier for that:+ param = maybeToList (identText <$> ogFromParam og) -- | Primtives must be in a top level module, at least for now. asPrim :: Name -> Maybe PrimIdent@@ -276,6 +285,12 @@ case nInfo n of GlobalName _ og -> Just og LocalName {} -> Nothing++-- | Check if this name is from a module parameter, and if so get the+-- name of the module paramter.+nameModParam :: Name -> Maybe Ident+nameModParam x = ogFromParam =<< asOrigName x+ -- | Get the module path for the given name. nameModPathMaybe :: Name -> Maybe ModPath
src/Cryptol/ModuleSystem/NamingEnv.hs view
@@ -214,7 +214,7 @@ NamingEnv ns = consToValues env -- | Get the subset of the first environment that shadows something--- in the second one. We only consider UserNames in the second enviornment.+-- in the second one. We only consider UserNames in the second environment. findShadowing :: NamingEnv -> NamingEnv -> [(PName, Name, [Name])] findShadowing (NamingEnv lhs) rhs = res where@@ -230,7 +230,7 @@ isUser z = nameSrc z == UserName -- | Do an arbitrary choice for ambiguous names.--- We do this to continue checking afetr we've reported an ambiguity error.+-- We do this to continue checking after we've reported an ambiguity error. forceUnambig :: NamingEnv -> NamingEnv forceUnambig (NamingEnv mp) = NamingEnv (fmap (One . anyOne) <$> mp) @@ -254,11 +254,11 @@ -- | Compute an unqualified naming environment, containing the various module -- parameters. modParamNamesNamingEnv :: T.ModParamNames -> NamingEnv-modParamNamesNamingEnv T.ModParamNames { .. } =+modParamNamesNamingEnv nms = NamingEnv $ Map.fromList- [ (NSValue, Map.fromList $ map fromFu $ Map.keys mpnFuns)- , (NSType, Map.fromList $ map fromTS (Map.elems mpnTySyn) ++- map fromTy (Map.elems mpnTypes))+ [ (NSValue, Map.fromList $ map fromFu $ Map.keys (T.mpnFuns nms))+ , (NSType, Map.fromList $ map fromTS (Map.elems (T.mpnTySyn nms)) +++ map fromTy (Map.elems (T.mpnTypes nms))) ] where toPName n = UnQual' (nameIdent n) (nameSrc n)@@ -280,7 +280,7 @@ -- the names are qualified. unqualifiedEnv :: IfaceDecls -> NamingEnv unqualifiedEnv IfaceDecls { .. } =- mconcat [ exprs, tySyns, ntTypes, ntExprs, mods, sigs ]+ mconcat [ exprs, tySyns, ntTypes, ntExprs, mods, sigs, funs, aliases ] where toPName n = UnQual' (nameIdent n) (nameSrc n) @@ -308,32 +308,45 @@ sigs = mconcat [ singletonNS NSModule (toPName n) n | n <- Map.keys ifSignatures ] + funs = mconcat [ singletonNS NSModule (toPName n) n+ | n <- Map.keys ifFunctors ] + aliases = mconcat [ singletonNS NSModule (toPName n) n+ | n <- Map.keys ifModuleAliases ]++ -- | Adapt the things exported by a module to the specific import/open. interpImportEnv :: ImportG name {- ^ The import declaration -} ->- NamingEnv {- ^ All public things coming in -} ->+ Set Name {- ^ All public things coming in -} -> NamingEnv-interpImportEnv imp = interpImportEnv' (iAs imp) (iSpec imp)+interpImportEnv imp =+ interpImportEnv'+ nameToDefPName+ (iAs imp)+ (iSpec imp) --- | A more general version of `interpImportEnv`-interpImportEnv' :: Maybe ModName {- ^ prefix with this qualifier -} ->+-- | A more general version of `interpImportEnv`.+interpImportEnv' :: (Name -> PName) {- ^ used to create the naming env -} ->+ Maybe ModName {- ^ prefix with this qualifier -} -> Maybe ImportSpec {- ^ restrict per ImportSpec -} ->- NamingEnv {- ^ All public things coming in -} ->+ Set Name {- ^ All public things coming in -} -> NamingEnv-interpImportEnv' iAs' iSpec' public = qualified+interpImportEnv' nameToPName iAs' iSpec' public = qualified where-+ -- optionally qualify names in NamingEnv if the import is "qualified", -- i.e., if `isJust iAs'`- qualified | Just pfx <- iAs' = qualify pfx restricted- | otherwise = restricted+ qualified | Just pfx <- iAs' = qualify pfx names+ | otherwise = names + names = namingEnvFromNames' nameToPName restricted+ -- restrict or hide imported symbols restricted | Just (Hiding ns) <- iSpec' =- filterPNames (\qn -> not (getIdent qn `elem` ns)) public+ Set.filter (\n -> not (nameIdent n `elem` ns)) public | Just (Only ns) <- iSpec' =- filterPNames (\qn -> getIdent qn `elem` ns) public+ Set.filter (\n -> nameIdent n `elem` ns) public | otherwise = public
src/Cryptol/ModuleSystem/NamingEnv/Types.hs view
@@ -4,12 +4,15 @@ module Cryptol.ModuleSystem.NamingEnv.Types where +import Data.List(partition) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map+import qualified Data.Set as Set import Control.DeepSeq (NFData) import GHC.Generics (Generic) +import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.Names import Cryptol.Parser.Name import Cryptol.Utils.Ident@@ -29,9 +32,28 @@ 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))+ ppPrec _ (NamingEnv mps) = vcat $ map ppNS $ Map.toList mps+ where+ isPrel x =+ case nameModPathMaybe x of+ Nothing -> False+ Just p -> topModuleFor p == preludeName+ + skip (x,as) (count, defs) =+ let (ps,qs) = partition isPrel (namesToList as)+ in ( count + length ps+ , if null qs then defs else (x,namesFromSet (Set.fromList qs)) : defs+ )++ ppNS (ns,xs) =+ withPPCfg (\cfg ->+ let (skipped,shown)+ | not (ppcfgHidePreludeNames cfg) = (0,Map.toList xs)+ | otherwise = foldr skip (0,[]) (Map.toList xs)+ skippedDoc = if skipped > 0 then "Skipped" <+> int skipped <+> "names from `Cryptol" else mempty+ in nest 2 (vcat (pp ns : skippedDoc : map ppNm shown))+ )+ ppNm (x,as) = pp x <+> "->" <+> commaSep (map pp (namesToList as)) -- | Move names in the constructor namespace to the value namespace. -- This is handy when checking for ambiguities.
src/Cryptol/ModuleSystem/Renamer.hs view
@@ -1,1472 +1,1457 @@--- |--- 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- , 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,m1) <- collectIfaceDeps (renameModule' mname m)- env <- rmodDefines <$> lookupResolved mname- pure RenamedModule- { rmModule = m1- , rmDefines = env- , 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 (ModuleG mname Name)-renameModule' mname m =- setCurMod (impNameModPath mname)-- 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 m { mDef = NormalModule ds1, mInScope = inScope }-- -- 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-- -- This inScope is incomplete; it only contains names from the- -- enclosing scope, but we also want the names in scope from the- -- functor, for ease of testing at the command line. We will fix- -- this up in doFunctorInst in the typechecker, because right now- -- we don't have access yet to the inScope of the functor.- inScope <- getNamingEnv-- pure m { mDef = FunctorInstance f' as' imap, mInScope = inScope }-- InterfaceModule s ->- shadowNames' CheckNone (rmodDefines resolved)- do d <- InterfaceModule <$> renameIfaceModule mname s- inScope <- getNamingEnv- pure m { mDef = d, mInScope = inScope }---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- TDEnum {} -> 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) ]- TDEnum d -> hasName' (thing (eName (tlValue d)))- (map (thing . ecName . tlValue)- (eCons (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- [] -> panic "doModParams" ["[]"]- [_] -> 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- TDEnum n -> TDEnum <$> 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 let mo = iModule i- m <- withLoc (srcRange mo) (rename (thing mo))- unless (isFakeName m) (recordImport (srcRange li) m)- pure li { thing = i { iModule = mo { thing = 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 let m' = m { mName = ImpNested <$> mName m }- 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 <- renameCon 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)- deriving' <- traverse (rnLocated (renameType NameUse)) (nDeriving n)- return Newtype { nName = nameT- , nConName = nameC- , nParams = ps'- , nBody = body'- , nDeriving = deriving' }--instance Rename EnumDecl where- rename n =- shadowNames (eParams n) $- do nameT <- rnLocated (renameType NameBind) (eName n)- nameCs <- forM (eCons n) \tlEc ->- do let con = tlValue tlEc- nameC <- rnLocated (renameCon NameBind) (ecName con)- depsOf (NamedThing (thing nameC)) (addDep (thing nameT))- pure (nameC,tlEc)- depsOf (NamedThing (thing nameT)) $- do ps' <- traverse rename (eParams n)- cons <- forM nameCs \(c,tlEc) ->- do ts' <- traverse rename (ecFields (tlValue tlEc))- let con = EnumCon { ecName = c, ecFields = ts' }- pure tlEc { tlValue = con }- deriving' <- traverse (rnLocated (renameType NameUse)) (eDeriving n)- pure EnumDecl { eName = nameT- , eParams = ps'- , eCons = cons- , eDeriving = deriving'- }---- | Try to resolve a name.--- SPECIAL CASE: if we have a NameUse for NSValue, we also look in NSConstructor-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 ())- checkCon = case (nt,expected) of- (NameUse, NSValue) -> lkpIn NSConstructor- _ -> Nothing- found = case (lkpIn expected, checkCon) of- (Just a, Just b) -> Just (a <> b)- (Nothing, y) -> y- (x, Nothing) -> x- case found 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- headSym =- case syms of- sym:_ -> sym- [] -> panic "resolveNameMaybe" ["Ambig with no names"]- mapM_ use syms -- mark as used to avoid unused warnings- n <- located qn- recordError (MultipleSyms n syms)- return (Just headSym)-- 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---- | 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--renameCon :: NameType -> PName -> RenameM Name-renameCon nt = resolveName nt NSConstructor--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 <$> withLoc (srcRange qn) (traverse (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 (traverse renameSchema) (bSignature b)- shadowNames ((fst . thing) `fmap` mbSig) $- do (patEnv,bParams') <- renameBindParams (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 = bParams'- , bDef = e'- , bSignature = fmap snd `fmap` mbSig- , bPragmas = bPragmas b- }--instance Rename BindDef where- rename DPrim = return DPrim- rename (DForeign cc i) = DForeign cc <$> traverse rename i- rename (DImpl i) = DImpl <$> rename i--instance Rename BindImpl where- 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)--instance Rename Pattern where- rename p = case p of- PVar lv -> PVar <$> rnLocated (renameVar NameBind) lv- PCon c ps -> PCon <$> rnLocated (renameCon NameUse) c- <*> traverse rename ps- 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 = mkUnqual . 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- ECase e as -> ECase <$> rename e <*> traverse rename as- 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- x'' <- located x'- mkEInfix (Just (srcRange x'')) 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-- -- The input comes from UpdField, and as such, it is expected to be a- -- non-empty list.- reLoc xs = x { thing = map thing xs }- where- x = case xs of- x':_ -> x'- [] -> panic "checkLabels" ["UpdFields with no labels"]--mkEInfix :: Maybe Range -- ^ Location of left expression- -> Expr Name -- ^ May contain infix expressions- -> (Located Name,Fixity) -- ^ The operator to use- -> Expr Name -- ^ Will not contain infix expressions- -> RenameM (Expr Name)--mkEInfix mbR 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 Nothing y op z- return (EInfix x o1 f1 r)-- FCError -> do recordError (FixityError o1 f1 o2 f2)- return (EInfix (maybeLoc mbR e) o2 f2 z)--mkEInfix mbR 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 Nothing x op y- return (EPrefix o1 r)-- -- Even if the fixities conflict, we make the prefix operator take- -- precedence.- _ -> return (EInfix (maybeLoc mbR 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' r) op z =- mkEInfix (Just r) e' op z--mkEInfix mbR e (o,f) z =- return (EInfix (maybeLoc mbR e) o f z)- --maybeLoc :: Maybe Range -> Expr name -> Expr name-maybeLoc mb e =- case mb of- Nothing -> e- Just r -> ELocated e r--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, [])---- | Rename patterns used as bind parameters, and collect the new environment that they introduce.-renameBindParams :: BindParams PName -> RenameM (NamingEnv, BindParams Name)-renameBindParams (PatternParams pats) =- (\(env,pats') -> (env, PatternParams pats')) <$> renamePats pats-renameBindParams (DroppedParams rng i) = return (mempty, DroppedParams rng i)--patternEnv :: Pattern PName -> RenameM NamingEnv-patternEnv = go- where- go (PVar Located { .. }) =- do let src = case thing of- NewName {} -> SystemName- _ -> UserName- n <- liftSupply (mkLocal src NSValue (getIdent thing) srcRange)- -- XXX: for deps, we should record a use- return (singletonNS NSValue thing n)- go (PCon _ ps) = bindVars ps- 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 let pn = thing pn'- mb <- withLoc (srcRange pn') (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 (mkLocalPName NSType 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 (mkLocalPName NSType 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 CaseAlt where- rename (CaseAlt p e) = shadowNames p (CaseAlt <$> rename p <*> rename e)--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)- , "// -- Module -------------------------------"- , pp (rmModule rn)- , "// -----------------------------------------"- ]--+{-# Language BlockArguments, BangPatterns, ImportQualifiedPost, OverloadedStrings #-}+module Cryptol.ModuleSystem.Renamer (+ NamingEnv(), shadowing+ , BindsNames, InModule(..)+ -- , shadowNames+ , Rename(..), runRenamer, RenameM()+ , RenamerError(..)+ , RenamerWarning(..)+ , resolveNameUse+ , renameModule+ , renameSchema+ , renameTopDecls+ , RenamerInfo(..)+ , RenamedModule(..)+ ) where++-- import Debug.Trace++import Data.List(foldl',find)+import Data.Maybe(mapMaybe)+import Data.Either(partitionEithers)+import Data.Set(Set)+import Data.Set qualified as Set+import Data.Map qualified as Map+import Control.Monad(forM,mapAndUnzipM,foldM_,unless)+import Data.Graph(SCC(..), graphFromEdges', flattenSCC)+import Data.Graph.SCC(sccGraph, stronglyConnComp)++import Cryptol.Utils.Panic(panic)+import Cryptol.Utils.Ident+import Cryptol.Utils.PP+import Cryptol.Parser.Name+import Cryptol.Parser.Position+import Cryptol.Parser.Selector+import Cryptol.Parser.AST+import Cryptol.ModuleSystem.Name+import Cryptol.ModuleSystem.NamingEnv+import Cryptol.ModuleSystem.Interface+import Cryptol.ModuleSystem.Binds(defsOf, defsOfSig, defsOfPats, InModule(..), newFunctorInst, newModParam, BindsNames)+import Cryptol.ModuleSystem.Names+import Cryptol.ModuleSystem.Renamer.Error+import Cryptol.ModuleSystem.Renamer.Monad++-- | The result of renaming a module+data RenamedModule = RenamedModule+ { rmModule :: Module Name -- ^ The renamed module+ , rmDefines :: NamingEnv -- ^ What this module defines+ , rmImported :: IfaceDecls+ -- ^ Imported declarations. This provides the types for external+ -- names (used by the type-checker).+ }++instance PP RenamedModule where+ ppPrec _ rn = updPPCfg (\cfg -> cfg { ppcfgShowNameUniques = True }) doc+ where+ doc =+ vcat [ "// --- Defines -----------------------------"+ , pp (rmDefines rn)+ , "// -- Module -------------------------------"+ , pp (rmModule rn)+ -- , "// -- DEPS -------------------------------------"+ -- , vcat [ pp x | + -- (x,y) <- Map.toList (ifDecls (rmImported rn))+ -- ]+ , "// -----------------------------------------"+ ]++-- | Entry point. This is used for renaming a top-level module.+renameModule :: Module PName -> RenameM RenamedModule+renameModule m =+ do+ let lnm = mName m+ (names, newM) <- withLoc (srcRange lnm) (renameModuleDef m)+ ids <- getExternalDeps+ pure RenamedModule {+ rmModule = newM,+ rmDefines = nameDefsToNamingEnv names,+ rmImported = ids+ }++-- | Get the definitions of a module as a naming environment.+-- Top level things get unqualified names and they shadow module parameters,+-- which are available both as qualified and unqualified.+nameDefsToNamingEnv :: Set Name -> NamingEnv+nameDefsToNamingEnv names = mconcat nonMps `shadowing` mconcat mps+ where+ (mps,nonMps) = partitionEithers (map isMP (Set.toList names))+ isMP x =+ let + mk p = singletonNS (nameNamespace x) p x+ u = mk (UnQual' (nameIdent x) (nameSrc x))+ in + case nameModParam x of+ Just i -> Left (mk (Qual (identToModName i) (nameIdent x)) <> u)+ Nothing -> Right u+ +++instance Rename NestedModule where+ rename (NestedModule mo) =+ do+ lnm <- traverse (resolveNameDef NSModule) (mName mo)+ let nm = thing lnm+ case mDef mo of+ ModuleAlias target -> renameModuleAlias nm lnm target+ _ ->+ do+ (names, newMo1) <-+ withLoc (srcRange lnm) (inSubmodule (nameIdent nm) (renameModuleDef mo))+ let newMo = newMo1 { mName = lnm }+ addResolvedMod names newMo+ pure (NestedModule newMo)++renameModuleAlias :: Name -> Located Name -> Located (ImpName PName) ->+ RenameM (NestedModule Name)+renameModuleAlias nm lnm target =+ do+ (newTarget, ok) <-+ withLoc (srcRange target) (resolveAliasTarget (thing target))+ resolved <- resolveModAlias newTarget+ -- mInScope is not used for aliases; the typechecker just records+ -- the alias mapping without opening a new scope.+ let newMo = Module { mName = lnm, mInScope = mempty+ , mDef = ModuleAlias (target { thing = resolved })+ , mDocTop = Nothing }+ if ok then addModAlias nm newTarget+ else addFakeMod nm+ pure (NestedModule newMo)++-- | Rename the definition of a module.+renameModuleDef :: ModuleG name PName -> RenameM (Set Name, ModuleG name Name)+renameModuleDef mo =+ case mDef mo of+ NormalModule decls ->+ do+ def <- NormalModule <$> renameModTopDecls decls+ names <- getCurDefNames+ scope <- getCurScope+ pure (names, mo { mInScope = scope, mDef = def })+ FunctorInstance fun args _ k ->+ do+ (names,_scope,def) <- makeFunctorInstance fun args k+ scope <- getCurScope+ -- XXX: For the time being we just store the outer scope of the+ -- module here, and the type-checker modifies it. We really should+ -- update to do all name stuff here.+ pure (names, mo { mInScope = scope, mDef = def })+ InterfaceModule sig ->+ do+ def <- InterfaceModule <$> rename sig+ names <- getCurDefNames+ scope <- getCurScope+ pure (names, mo { mInScope = scope, mDef = def })+ ModuleAlias {} ->+ panic "renameModuleDef" ["ModuleAlias handled in renameModuleAlias"]+++--------------------------------------------------------------------------------+-- Processing Functor Instantiation+--------------------------------------------------------------------------------++makeFunctorInstance ::+ Located (ImpName PName) -> ModuleInstanceArgs PName -> FunctorInstKind ->+ RenameM (Set Name, NamingEnv, ModuleDefinition Name)+makeFunctorInstance f args k =+ do+ let expectedKind = case k of+ ModuleInst -> AFunctor+ SignatureInst -> AnIfaceFunctor+ (newF,moF) <- withLoc (srcRange f) (resolveModName expectedKind (thing f))+ newArgs <- rename args+ -- Note: currently the validation that the arguments match what the+ -- functor expects is done in the type checker. We may want to do it+ -- here instead.+ (defs,scope,inst) <- generateFunctorInstance (backtickParams newArgs) k moF+ pure (defs, scope, FunctorInstance f { thing = newF } newArgs inst k)++-- | Determine which parameters are instantiated with @_@ (backtick).+-- @Nothing@ means all parameters use @_@; @Just s@ lists specific ones.+backtickParams :: ModuleInstanceArgs Name -> Maybe (Set Ident)+backtickParams args =+ case args of+ DefaultInstArg l+ | AddParams <- thing l -> Nothing+ | otherwise -> Just Set.empty+ DefaultInstAnonArg {} -> Just Set.empty+ NamedInstArgs as -> Just $ Set.fromList+ [ thing nm | ModuleInstanceNamedArg nm l <- as, AddParams <- [thing l] ]++++generateFunctorInstance ::+ Maybe (Set Ident) -> FunctorInstKind -> Mod ->+ RenameM (Set Name, NamingEnv, ModuleInstance Name)+generateFunctorInstance btParams instKind moF =+ do+ mpath <- getCurModPath++ case instKind of++ -- For SignatureInst, the result is a signature---no nested submodules+ -- or virtual parameter modules are needed.+ SignatureInst ->+ do+ (inst, newDefs) <- mkModInst mpath moF+ let scope = nameDefsToNamingEnv newDefs+ pure (newDefs, scope, ModuleInstance+ { modInstMap = inst+ , modInstVirtParamMods = []+ })++ ModuleInst ->+ do+ let (virtNames, instNames) = Set.partition isVirtParam (modDefines moF)+ (inst, newDefs) <- mkModInst mpath (moF { modDefines = instNames })+ subI <- doSubs mpath inst+ (vparamMods, paramInst) <- makeVirtParamModules mpath virtNames++ let fullInst = inst `Map.union` paramInst `Map.union` subI+ vparamModDefs = Set.fromList (map vpmName vparamMods)+ allDefs = newDefs `Set.union` vparamModDefs+ `Set.union` Set.fromList (Map.elems paramInst)+ scope = nameDefsToNamingEnv newDefs+ pure (allDefs, scope, ModuleInstance+ { modInstMap = fullInst+ , modInstVirtParamMods = vparamMods+ })+ where+ isVirtParam n =+ case nameModParam n of+ Just i -> case btParams of+ Nothing -> False+ Just s -> not (i `Set.member` s)+ Nothing -> False++ -- Generate fresh instantiations for the modules contained in the+ -- module at this path+ doSubs mpath inst =+ Map.unions <$>+ mapM (doSub mpath)+ [ def | def <- Map.toList inst, nameNamespace (fst def) == NSModule ]++ -- Generate a fresh instantiation for the module at the given path.+ -- This module may be of any kind (normal, functor, interface).+ mkModInst mpath someMo =+ do+ inst <-+ forM (Set.toList (modDefines someMo)) \old ->+ do+ new <- newFunctorInst mpath old+ pure (old,new)+ pure (Map.fromList inst, Set.fromList (map snd inst))++ -- Instantiate a module contained in the given module path+ doSub mpath (old,new) =+ do+ ogMod <- lookupMod (ImpNested old) Nothing+ let newMPath = Nested mpath (nameIdent new)+ (newI,newE) <- mkModInst newMPath ogMod+ let ren x =+ case Map.lookup x newI of+ Just y -> y+ Nothing -> panic "generateFunctorInstance" ["Missing name"]+ addInstMod new+ Mod {+ modKind = modKind ogMod,+ modDefines = newE,+ modPublic = Set.map ren (modPublic ogMod)+ }+ subMap <- doSubs newMPath newI+ pure (Map.union newI subMap)++-- | Create virtual submodules for the parameter definitions of a functor+-- instance. For each parameter (e.g., @import interface I@), we generate a+-- nested module (e.g., @M::I@) whose names are the definition sites for the+-- parameter values. Returns the virtual submodules and a mapping from the+-- original parameter names to the virtual submodule definition names (to be+-- merged into the instMap).+makeVirtParamModules ::+ ModPath -> Set Name -> RenameM ([VirtParamMod Name], Map.Map Name Name)+makeVirtParamModules mpath paramNames =+ do+ loc <- getCurLoc+ let paramGroups = Map.fromListWith (<>)+ [ (paramId, [old])+ | old <- Set.toList paramNames+ , Just paramId <- [nameModParam old]+ ]+ (vpmods, instMaps) <- mapAndUnzipM (mkVirtMod loc) (Map.toList paramGroups)+ pure (vpmods, Map.unions instMaps)+ where+ mkVirtMod loc (paramId, paramEntries) =+ do+ let vsubId = if isAnonIfaceModIdnet paramId+ then packIdent "Parameter"+ else paramId+ vsubPath = Nested mpath vsubId+ vsubName <- liftSupply+ (mkDeclared NSModule mpath UserName vsubId Nothing loc)++ -- Create names inside the virtual submodule; these become the+ -- definition sites for the parameter values.+ results <- forM paramEntries \old ->+ do+ defName <- liftSupply+ (mkDeclared (nameNamespace old) vsubPath UserName+ (nameIdent old) (nameFixity old) loc)+ pure (defName, old)++ let defs = Map.fromList results+ instMap = Map.fromList [ (old, defName) | (defName, old) <- results ]+ defNames = Map.keysSet defs+ addInstMod vsubName+ Mod { modKind = AModule+ , modDefines = defNames+ , modPublic = defNames+ }+ pure ( VirtParamMod+ { vpmIdent = vsubId+ , vpmName = vsubName+ , vpmDefs = defs+ }+ , instMap+ )++instance Rename ModuleInstanceArgs where+ rename args =+ case args of+ DefaultInstAnonArg {} ->+ panic "Rename ModuleInstanceArgs" ["Nested DefaultInstAnonArg"]+ DefaultInstArg l -> DefaultInstArg <$> rnLocated rename l+ NamedInstArgs as -> NamedInstArgs <$> mapM rename as++instance Rename ModuleInstanceNamedArg where+ rename (ModuleInstanceNamedArg nm l) =+ ModuleInstanceNamedArg nm <$> rnLocated rename l++instance Rename ModuleInstanceArg where+ rename arg =+ case arg of+ ModuleArg m ->+ do + (nm,_) <- resolveModName AModule m+ pure (ModuleArg nm)+ ParameterArg i -> pure (ParameterArg i)+ AddParams -> pure AddParams++--------------------------------------------------------------------------------+-- Processing Interface Modules+--------------------------------------------------------------------------------++instance Rename Signature where+ rename sig =+ do+ mo <- getCurModPath+ env <- doDefGroup (defsOfSig mo sig)+ setThisModuleDefs env+ newTopImps <- mapM (fmap fst . doImport) topImps+ newImps <- mapM renameSigImport rest++ funPs <- mapM rename (sigFunParams sig)+ tyPs <- mapM rename (sigTypeParams sig)+ ctrs <- mapM (rnLocated rename) (sigConstraints sig)+ decls <- renameSigDecls (sigDecls sig)++ pure Signature {+ sigImports = map SigImport newTopImps ++ newImps,+ sigTypeParams = tyPs,+ sigConstraints = ctrs,+ sigDecls = decls,+ sigFunParams = funPs+ }+ where+ (topImps,rest) = go [] [] (sigImports sig)+ where+ go tops others [] = (reverse tops, reverse others)+ go tops others (si : more) =+ case si of+ SigImport li | ImpTop {} <- thing (iModule (thing li))+ -> go (li : tops) others more+ _ -> go tops (si : others) more++ renameSigImport si =+ case si of+ SigImport li -> SigImport . fst <$> doImport li+ SigIfaceImport p -> SigIfaceImport . fst <$> doModParam p++instance Rename ParameterType where+ rename a =+ do+ n <- rnLocated (resolveNameDef NSType) (ptName a)+ return a { ptName = n }++instance Rename ParameterFun where+ rename a =+ do+ n <- rnLocated (resolveNameDef NSValue) (pfName a)+ renameSchema (pfSchema a) \sig ->+ pure a { pfName = n, pfSchema = sig }++renameSigDecls :: [SigDecl PName] -> RenameM [SigDecl Name]+renameSigDecls decls =+ do+ gr <- forM decls \d ->+ do+ (d1,xs) <- getDeps (rename d)+ pure (d1, sigDeclName d1, Set.toList xs)+ concat <$> mapM validateRecSigDep (stronglyConnComp gr)+ +sigDeclName :: SigDecl a -> a +sigDeclName d =+ thing+ case d of+ SigTySyn ts _ -> tsName ts+ SigPropSyn ps _ -> psName ps++validateRecSigDep :: SCC (SigDecl Name) -> RenameM [SigDecl Name]+validateRecSigDep sc =+ case sc of+ AcyclicSCC x -> pure [x]+ CyclicSCC xs ->+ do+ recordError (InvalidDependency (map (NamedThing . sigDeclName) xs))+ pure xs++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+++++--------------------------------------------------------------------------------+-- Processing Top-level Declarations+--------------------------------------------------------------------------------++{- | Entry point. Rename a list of top-level declarations.+This is used for declarations that don't live in a module+(e.g., defined on the command line).++NOTE: We used to check that the top-decls are not nested modules, but I can't+see anything that goes wrong if we allow modules, so I lifted the restriction+for now (ISD).+-}+renameTopDecls :: [TopDecl PName] -> RenameM (NamingEnv,[TopDecl Name])+renameTopDecls ds0 =+ do+ mo <- renameModTopDecls ds0+ env <- getCurScope+ pure (env,mo)+++-- | Rename the top-level declarations of a module.+renameModTopDecls :: [TopDecl PName] -> RenameM [TopDecl Name]+renameModTopDecls decls =+ do+ mp <- getCurModPath+ mapM_ doImport topImps+ (env,defs) <- doDefOrdGroup (map (InModule (Just mp)) otherDecls)+ setThisModuleDefs env+ renameAndReorderTopDecls (zip otherDecls defs)+ where+ (topImps,otherDecls) = partitionEithers (map isTopImp decls)+ isTopImp d =+ case d of+ DImport limp ->+ case thing (iModule (thing limp)) of+ ImpTop {} -> Left limp+ _ -> Right d+ _ -> Right d+++-- | Rename declarations and order them in dependency order. Also, we preserve+-- the order of interface constraints as it they were written in the file,+-- but we move them as early as possible (i.e., immediately after all of+-- their dependencies.+renameAndReorderTopDecls :: [(TopDecl PName,Set Name)] -> RenameM [TopDecl Name]+renameAndReorderTopDecls xs =+ do+ gr0 <- go (0 :: Int) [] xs+ let nodeMap = Map.fromList [ (k,d) | (k,d,_,_) <- gr0 ]+ declFromKey k =+ case Map.lookup k nodeMap of+ Just d -> d+ Nothing -> panic "renameAndReorderTopDecls" ["missing node"]+ defMap = Map.fromList+ [ (x,k) | (k,_,defs,_) <- gr0, x <- Set.toList defs ]+ edges = [ (d, k, mapMaybe (`Map.lookup` defMap) (Set.toList deps))+ | (k,d,_,deps) <- gr0 ]+ compG = sccGraph (fst (graphFromEdges' edges))+ ifaceCtrKeys = [ k | (k,d,_,_) <- gr0, isIfaceCtr d ]+ ordered = reorderTopDecls ifaceCtrKeys compG+ result = map (fmap declFromKey) ordered+ -- traceM ("DEPS:\n" ++ unlines (map (_dbgShowEdge gr0) edges))+ concat <$> mapM validateTopRecDep result+ where+ -- XXX: report unused top-level module declarations.+ -- An SCC is used if:+ -- * it is a module level constraint, or+ -- * it is public, or+ -- * it is private, and it is a dependency of some other used SCC++ _dbgShowEdge gr (d', k, ds) =+ let d = case d' of+ DModule tl -> DModule (upd <$> tl)+ where upd (NestedModule nm) = NestedModule nm { mInScope = mempty }+ _ -> d'+ in+ let me = [ (prov,uses) | (k',_,prov,uses) <- gr, k == k' ] in+ let+ prov = [ p | (ps,_) <- me, p <- Set.toList ps ]+ uses = [ u | (_,us) <- me, u <- Set.toList us ]+ in+ " " ++ show k ++ ": " ++ show ds ++ ", provides " +++ unwords (map (show . pp) prov) ++ ", uses " ++ unwords (map (show . pp) uses) +++ "\n" ++ unlines (map (" " ++) (lines (show (pp d))))++ isIfaceCtr d =+ case d of+ DInterfaceConstraint {} -> True+ _ -> False++ -- This does the actual renaming, and assigns each declaration a unique id.+ -- Things earlier in the file order get small ids, which is used when+ -- ordering module level constraints (see `ifaceCtrKeys`)+ go !curId gr ds =+ case ds of+ [] -> pure gr+ (d,bdefs) : more ->+ -- traceM ("RENAMING: " ++ show (pp d)) >>+ case d of+ DImport imp ->+ do+ ((newI,defs),deps) <- getDeps (doImport imp)+ go (curId + 1) ((curId,DImport newI,defs,deps) : gr) more+ DModParam p ->+ do+ ((par,defs),deps) <- getDeps (doModParam p) + go (curId + 1) ((curId,DModParam par,defs,deps) : gr) more+ DModule {} ->+ do+ (d',deps) <- getDeps (rename d)+ -- We add implicit imports of all modules nested in this,+ -- as long as the following declaration is not a user specified+ -- import of this module.+ implicit <- implicitImports (getDModName d')+ -- traceM ("ADDING IMPLICIT:\n" ++ unlines [ " " ++ show (pp i) | (i,_) <- implicit ])+ go (curId + 1) ((curId,d',bdefs,deps) : gr) (implicit ++ more)+ _ ->+ do+ (d',deps) <- getDeps (rename d)+ go (curId + 1) ((curId,d',bdefs,deps) : gr) more+ + getDModName td =+ case td of+ DModule md+ | NestedModule mo <- tlValue md -> mName mo+ _ -> panic "renameAndReorderTopDecls" ["Not a module decl"]+++-- | This computes a topological sort of the SCCs. We do it manually to+-- enforce some additional constraints: we'd like the top-level module+-- constraints to go as early in the file as possible, and stay in the order+-- they were written in the file.+reorderTopDecls ::+ [Int] {- ^ Keys for top-level constraint declarations.+ Note that the these are the keys *in* the SCC, not the key *of*+ the SCC (i.e., the keys in the graph before its has been quotient-ed) -}->+ [(SCC Int, Int, [Int])] {- ^ Quotient graph -} ->+ [SCC Int]+reorderTopDecls priority grlist = reverse (go Set.empty [] allTodo)+ where+ allTodo = map getUnq priority ++ Map.keys qgraph+ -- The priority elements are in the list twice, but the extra copies will+ -- be skipped by the "visited" check.++ go visited res todo =+ case todo of+ [] -> res+ x : more ->+ case postOrder (visited,res) x of+ (visited1,res1) -> go visited1 res1 more++ postOrder s@(visited,res) k+ | k `Set.member` visited = s+ | otherwise =+ let (v,deps) = getQ k + visited1 = Set.insert k visited+ -- There should be no cycles so it doesn't matter if we do this now+ -- or later but we do it sooner to avoid looping if there's a bug.+ (visited2,res1) = foldl' postOrder (visited1,res) deps+ in (visited2, v : res1)++ -- Map nodes in the quotient graph to their declaration and+ -- dependencies (in the quotient graph)+ qgraph = Map.fromList [ (k,(v,deps)) | (v,k,deps) <- grlist ]+ getQ x =+ case Map.lookup x qgraph of+ Just v -> v+ Nothing -> panic "reorderTopDecls" ["missing Q"]++ -- Maps nodes in the original graph to nodes in the quotient graph+ unq = Map.fromList [ (v,k) | (c,k,_) <- grlist, v <- flattenSCC c ]+ getUnq x =+ case Map.lookup x unq of+ Just v -> v+ Nothing -> panic "reorderTopDecls" ["missing unQ"]+++--------------------------------------------------------------------------------+-- Validate Recursive Dependencies+--------------------------------------------------------------------------------++-- | Report errors for invalid recursive dependencies.+validateTopRecDep :: SCC (TopDecl Name) -> RenameM [TopDecl Name]+validateTopRecDep sc =+ case sc of+ AcyclicSCC x -> pure [x]+ CyclicSCC tds ->+ case mapM isDecl tds of+ Nothing ->+ do+ recordError (InvalidDependency (map topDeclName tds))+ pure tds+ Just ds ->+ do+ newDs <- validateRecDep (CyclicSCC (map tlValue ds))+ pure [Decl TopLevel {+ tlValue = d',+ tlDoc = Nothing,+ tlExport =+ if all ((== Private) . tlExport) ds then Private else Public+ -- XXX: This is wrong: it should be possible to have + -- recursive declarations where one of the things is public+ -- and the rest are private. We have no way to represent this+ -- at the moment. Old renamer set this to `Public` always.+ } | d' <- newDs ]+ where+ -- Only decls may be recursive at present. This would have to change,+ -- if, for example, we allowed recursive `enum`.+ isDecl d =+ case d of+ Decl tl -> Just tl+ _ -> Nothing+ +validateRecDep :: SCC (Decl Name) -> RenameM [Decl Name]+validateRecDep sc =+ case sc of+ AcyclicSCC d -> pure [d]+ CyclicSCC ds ->+ case mapM recOk ds of+ Just bs -> pure [DRec bs]+ Nothing ->+ do+ recordError (InvalidDependency (map (NamedThing . declName) ds))+ pure ds+ where+ recOk d =+ case d of+ DLocated d' _ -> recOk d'+ DBind b -> pure b+ _ -> Nothing+++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 -> DepName+topDeclName topDecl =+ case topDecl of+ Decl d -> NamedThing (declName (tlValue d))+ DPrimType d -> NamedThing (thing (primTName (tlValue d)))+ TDNewtype d -> NamedThing (thing (nName (tlValue d)))+ TDEnum d -> NamedThing (thing (eName (tlValue d)))+ DModule d -> NamedThing (thing (mName m))+ where NestedModule m = tlValue d++ DInterfaceConstraint _ ds -> ConstratintAt (srcRange ds)+ DImport i -> ImportAt (srcRange i)+ DModParam m -> ModParamName (srcRange (mpSignature m)) (mpName m)++ Include {} -> bad "Include"+ DParamDecl {} -> bad "DParamDecl"+ where+ bad x = panic "topDeclName" [x]+++++--------------------------------------------------------------------------------+-- Resolve names+--------------------------------------------------------------------------------++-- | Resolve a name that refers to something defined.+resolveNameUse :: Namespace -> PName -> RenameM Name+resolveNameUse ns p =+ do+ scope <- getCurScope+ case lookupNS ns p scope of+ Just names -> found names+ Nothing+ -- SPECIAL CASE: if we have a NameUse for NSValue, we also look in NSConstructor+ | ns == NSValue,+ Just names <- lookupNS NSConstructor p scope -> found names+ _ -> reportUnboundName ns p scope+ where+ found names =+ do+ (x,xs) <-+ case names of+ One x -> pure (x, Set.singleton x)+ Ambig xs ->+ do+ p' <- located p+ recordError (MultipleSyms p' (Set.toList xs))+ pure (anyOne names, xs)+ recordNameUses xs+ pure x+++-- | Resolve the name for a top-level definition.+resolveNameDef :: Namespace -> PName -> RenameM Name+resolveNameDef ns p =+ do+ defs <- getCurBinds+ case lookupNS ns p defs of+ Just names -> pure (anyOne names) -- there should be only one+ Nothing ->+ getCurLoc >>= \l ->+ panic "resolveNameDef"+ [ "Missing def"+ , "Location: " ++ show (pp l)+ , "Namespace: " ++ show ns+ , "Name: " ++ show (pp p)+ , "Defs: "+ , show (pp defs)+ ]++resolveModName :: ModKind -> ImpName PName -> RenameM (ImpName Name, Mod)+resolveModName k x =+ do+ nm <-+ case x of+ ImpTop m -> pure (ImpTop m)+ ImpNested y -> ImpNested <$> resolveNameUse NSModule y+ mo <- lookupMod nm (Just k)+ pure (nm, mo)++resolveAliasTarget :: ImpName PName -> RenameM (ImpName Name, Bool)+resolveAliasTarget x =+ do+ nm <-+ case x of+ ImpTop m -> pure (ImpTop m)+ ImpNested y -> ImpNested <$> resolveNameUse NSModule y+ ok <- isResolvableMod nm+ unless ok $+ case nm of+ ImpNested n ->+ do loc <- getCurLoc+ recordError (ImportTooSoon loc (nameIdent n))+ ImpTop {} -> pure ()+ pure (nm, ok)+++--------------------------------------------------------------------------------+-- Importing Stuff+--------------------------------------------------------------------------------++++-- | The declaration should be an import. Add the names coming through+-- the import the current scope.+doImport ::+ Located (ImportG (ImpName PName)) ->+ RenameM (Located (ImportG (ImpName Name)), Set Name)+doImport limp =+ withLoc (srcRange limp)+ do+ let imp = thing limp+ let lname = iModule imp+ (resMo,mo) <- withLoc (srcRange limp) (resolveModName AModule (thing lname))+ let isSys x = case nameSrc x of+ SystemName -> True+ UserName -> False+ isPub x = not (isSys x) && (x `Set.member` modPublic mo)+ newNames = interpImportEnv imp (Set.filter isPub (modDefines mo))+ case thing lname of+ ImpTop x -> recordTopImport x+ _ -> pure ()+ addImported (srcRange limp) newNames+ pure ( limp { thing = imp { iModule = (iModule imp) { thing = resMo } } },+ namingEnvNames newNames+ )++-- | Add the names from module parameters to the current scope+doModParam :: ModParam PName -> RenameM (ModParam Name, Set Name)+doModParam mp =+ do+ let nm = mpName mp++ -- Check that the virtual submodule name won't conflict with an+ -- existing submodule definition. We do this before resolving the+ -- signature so that fake names from failed resolution don't interfere.+ let vsubId = if isAnonIfaceModIdnet nm then packIdent "Parameter" else nm+ defs <- getCurTopDefs+ case lookupNS NSModule (mkUnqual vsubId) defs of+ Just ns -> recordError (ConflictingModParam vsubId (anyOne ns))+ Nothing -> pure ()++ x <- rnLocated (resolveModName ASignature) (mpSignature mp)+ let mo = snd (thing x)+ rng = srcRange x+ mpath <- getCurModPath++ ren <- forM (Set.toList (modDefines mo)) \old ->+ do+ new <- newModParam mpath nm rng old+ pure (new,old)+ let names = Set.fromList (fst <$> ren)+ let impNam a =+ case mpAs mp of+ Nothing -> UnQual' (nameIdent a) (nameSrc a)+ Just q -> Qual q (nameIdent a)+ let env = namingEnvFromNames' impNam names+ addModParams (mpSignature mp) { thing = nm } env+ pure (mp { mpSignature = fst <$> x,+ mpRenaming = Map.fromList ren,+ mpInst = Nothing+ },+ names)+++--------------------------------------------------------------------------------+-- Implicit Imports+--------------------------------------------------------------------------------++-- | Compute what implicit imports we should add for the given name.+-- Note that the second argument in the pair is just there to make the types+-- fit---we place an empty set there, which will be replaced when the imports+-- are resolved.+implicitImports :: Located Name -> RenameM [(TopDecl PName, Set Name)]+implicitImports lname =+ do+ nts <- nestedModNames (thing lname)+ let imps = concatMap (nameTreeToImports (srcRange lname) []) nts+ pure [ (DImport lname { thing = i },Set.empty) | i <- imps ]++data NameTree = NameTree Name [NameTree]++nestedModNames :: Name -> RenameM [NameTree]+nestedModNames mo+ | identIsNormal (nameIdent mo) =+ do+ info <- lookupMod (ImpNested mo) Nothing+ case modKind info of+ AModule ->+ pure . NameTree mo . concat <$>+ mapM nestedModNames+ [x | x <- Set.toList (modPublic info), nameNamespace x == NSModule ]+ _ -> pure []+ | otherwise = pure []++nameTreeToImports :: Range -> [Ident] -> NameTree -> [ ImportG (ImpName PName) ]+nameTreeToImports rng qs (NameTree x subs) =+ Import {+ iModule = Located { srcRange = rng, thing = ImpNested nm },+ iAs = Just (isToQual (reverse (i : qs))),+ iSpec = Nothing,+ iInst = Nothing,+ iDoc = Nothing+ } : concatMap (nameTreeToImports rng (i : qs)) subs+ where+ i = nameIdent x+ isToQual is = packModName (map identText is)+ nm =+ case reverse qs of+ [] -> mkUnqual i -- we don't import system names so this is OK here+ qs' -> mkQual (isToQual qs') i+++--------------------------------------------------------------------------------+-- Renaming+--------------------------------------------------------------------------------++class Rename f where+ rename :: f PName -> RenameM (f Name)++-- | Rename a located thing using the given function.+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+ TDEnum n -> TDEnum <$> traverse rename n+ Include n -> return (Include n)+ DModule m -> DModule <$> traverse rename m+ DInterfaceConstraint d ds ->+ DInterfaceConstraint d <$> rnLocated (mapM rename) ds+ DParamDecl {} -> panic "rename" ["DParamDecl"]+ DImport {} -> panic "rename" ["DImport"]+ DModParam {} -> panic "rename" ["DModParam"]++++-- | Rename local declarations (e.g., from `where`), adds them to the local scope.+renameDecls :: [Decl PName] -> ([Decl Name] -> RenameM a) -> RenameM a+renameDecls decls k =+ do+ env <- doDefGroup (defsOf (map (InModule Nothing) decls))+ do+ ds <- inLocalBindScope False env+ do+ gr <- forM decls \d ->+ do+ (d1,xs) <- getDeps (rename d)+ pure (d1, declName d1, Set.toList xs)+ concat <$> mapM validateRecDep (stronglyConnComp gr)++ inLocalScope env (k ds)+ ++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 PrimType where+ rename pt =+ do+ x <- rnLocated (resolveNameDef NSType) (primTName pt)+ let (as,ps) = primTCts pt+ cts <- renameQual as ps \as' ps' ->+ do+ recordNameUses (Set.fromList (map tpName as'))+ pure (as',ps')+ pure pt { primTCts = cts, primTName = x }+++instance Rename Newtype where+ rename n =+ do+ nameT <- rnLocated (resolveNameDef NSType) (nName n)+ nameC <- resolveNameDef NSConstructor (nConName n)+ withTParams (nParams n) \ps' ->+ do+ body' <- traverse (traverse rename) (nBody n)+ deriving' <- traverse (rnLocated (resolveNameUse NSType)) (nDeriving n)+ pure Newtype {+ nName = nameT,+ nConName = nameC,+ nParams = ps',+ nBody = body',+ nDeriving = deriving'+ }+++instance Rename EnumDecl where+ rename n =+ do+ nameT <- rnLocated (resolveNameDef NSType) (eName n)++ nameCs <- forM (eCons n) \tlEc ->+ do+ let con = tlValue tlEc+ nameC <- rnLocated (resolveNameDef NSConstructor) (ecName con) + pure (nameC,tlEc)++ withTParams (eParams n) \ps' ->+ do+ cons <- forM nameCs \(c,tlEc) ->+ do+ ts' <- traverse rename (ecFields (tlValue tlEc))+ let con = EnumCon { ecName = c, ecFields = ts' }+ pure tlEc { tlValue = con }+ deriving' <- traverse (rnLocated (resolveNameUse NSType)) (eDeriving n)+ pure EnumDecl {+ eName = nameT,+ eParams = ps',+ eCons = cons,+ eDeriving = deriving'+ }++instance Rename TySyn where+ rename (TySyn n f ps ty) =+ do+ n' <- rnLocated (resolveNameDef NSType) n+ withTParams ps \ps' ->+ TySyn n' f ps' <$> rename ty++instance Rename PropSyn where+ rename (PropSyn n f ps cs) =+ do+ n' <- rnLocated (resolveNameDef NSType) n + withTParams ps \ps' ->+ PropSyn n' f ps' <$> mapM rename cs++++++--------------------------------------------------------------------------------+-- Renaming of Types+--------------------------------------------------------------------------------+++-- | Rename something with local type parameters.+withTParams ::+ [TParam PName] ->+ ([TParam Name] -> RenameM a) ->+ RenameM a+withTParams as k =+ do+ env <- doDefGroup (defsOf as)+ inLocalBindScope True env+ do+ as' <- traverse (renameTP env) as+ k as'++ where+ renameTP env tp =+ case lookupNS NSType (tpName tp) env of+ Just (One n) -> pure tp { tpName = n }+ _ -> panic "withTParams" ["Missing/ambiguous name"]+ ++-- | Rename a qualified thing.+renameQual :: [TParam PName] -> [Prop PName] ->+ ([TParam Name] -> [Prop Name] -> RenameM a) ->+ RenameM a+renameQual as ps k =+ withTParams as \as' ->+ do+ ps' <- traverse rename ps+ k as' ps'++renameSchema :: Schema PName -> (Schema Name -> RenameM a) -> RenameM a+renameSchema (Forall ps p ty loc) k =+ renameQual ps p \ps' p' ->+ do+ ty' <- rename ty+ k (Forall ps' p' ty' loc)++++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 <$> withLoc (srcRange qn)+ (traverse (resolveNameUse NSType) 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'++instance Rename TypeInst where+ rename ti = case ti of+ NamedInst nty -> NamedInst <$> traverse rename nty+ PosInst ty -> PosInst <$> rename ty+++--------------------------------------------------------------------------------+-- Fixity Resolution+--------------------------------------------------------------------------------++renameOp :: Located PName -> RenameM (Located Name, Fixity)+renameOp ln =+ withLoc ln $+ do n <- resolveNameUse NSValue (thing ln)+ fixity <- lookupFixity n+ return (ln { thing = n }, fixity)++renameTypeOp :: Located PName -> RenameM (Located Name, Fixity)+renameTypeOp ln =+ withLoc ln $+ do n <- resolveNameUse NSType (thing ln)+ fixity <- lookupFixity n+ return (ln { thing = n }, fixity)++lookupFixity :: Name -> RenameM Fixity+lookupFixity n =+ case nameFixity n of+ Just fixity -> pure fixity+ Nothing -> pure defaultFixity -- FIXME: should we raise an error instead?++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)++mkEInfix :: Maybe Range -- ^ Location of left expression+ -> Expr Name -- ^ May contain infix expressions+ -> (Located Name,Fixity) -- ^ The operator to use+ -> Expr Name -- ^ Will not contain infix expressions+ -> RenameM (Expr Name)++mkEInfix mbR 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 Nothing y op z+ return (EInfix x o1 f1 r)++ FCError -> do recordError (FixityError o1 f1 o2 f2)+ return (EInfix (maybeLoc mbR e) o2 f2 z)++mkEInfix mbR e@(EPrefix o1 x) op@(o2, f2) y =+ case compareFixity (prefixFixity o1) f2 of+ FCRight -> do+ addWarning (PrefixAssocChanged o1 x o2 f2 y)+ r <- mkEInfix Nothing x op y+ return (EPrefix o1 r)++ -- Even if the fixities conflict, we make the prefix operator take+ -- precedence.+ _ -> return (EInfix (maybeLoc mbR 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' r) op z =+ mkEInfix (Just r) e' op z++mkEInfix mbR e (o,f) z =+ return (EInfix (maybeLoc mbR e) o f z)+ +maybeLoc :: Maybe Range -> Expr name -> Expr name+maybeLoc mb e =+ case mb of+ Nothing -> e+ Just r -> ELocated e r+++--------------------------------------------------------------------------------+-- Bindings and Expressions+--------------------------------------------------------------------------------++-- | Rename a binding.+instance Rename Bind where+ rename b =+ do+ n' <- rnLocated (resolveNameDef NSValue) (bName b)+ let checkSig k =+ case bSignature b of+ Nothing -> k Nothing+ Just ls -> renameSchema (thing ls) \s' -> k (Just ls { thing = s' }) + checkSig \mbSig ->+ renameBindParams (bParams b) \ps ->+ do+ e' <- setCurBind (bName b) (thing n') (rnLocated rename (bDef b))+ pure b {+ bName = n',+ bParams = ps,+ bDef = e',+ bSignature = mbSig,+ bPragmas = bPragmas b+ }++instance Rename BindDef where+ rename DPrim = return DPrim+ rename (DForeign cc i) = DForeign cc <$> traverse rename i+ rename (DImpl i) = DImpl <$> rename i++instance Rename BindImpl where+ rename (DExpr e) = DExpr <$> rename e+ rename (DPropGuards gs) = DPropGuards <$> mapM rename gs++instance Rename PropGuardCase where+ rename pg =+ do+ props <- mapM (rnLocated rename) (pgcProps pg)+ rhs <- rename (pgcExpr pg)+ pure PropGuardCase { pgcProps = props, pgcExpr = rhs }+++instance Rename Expr where+ rename expr =+ case expr of+ EVar n -> EVar <$> resolveNameUse NSValue n+ ELit l -> pure (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+ (envs,newArms) <- mapAndUnzipM renameArm bs+ inLocalScope (mconcat envs)+ do+ newE <- rename e'+ pure (EComp newE newArms)++ 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+ ECase e as -> ECase <$> rename e <*> traverse rename as++ EWhere e' ds ->+ renameDecls ds \ds' ->+ do+ newE <- rename e'+ pure (EWhere newE ds')++ ETyped e' ty -> ETyped <$> rename e' <*> rename ty+ ETypeVal ty -> ETypeVal<$> rename ty+ EFun desc ps e' ->+ do+ desc' <- rename desc+ -- We disable warnings for arguments of this came from a+ -- a system name. This is to avoid spurious warnings arising+ -- from the additional definitions we get from prop guard desugaring.+ let checkUsed = not (funDescrFromPropGuard desc')+ renamePats checkUsed ps \newPs -> EFun desc' newPs <$> 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+ x'' <- located x'+ mkEInfix (Just (srcRange x'')) x' op z'+ EPrefix op e -> EPrefix op <$> rename e++instance Rename FunDesc where+ rename (FunDesc nm offset fromP) =+ do+ nm' <- traverse (resolveCurBind fromP) nm+ pure (FunDesc nm' offset fromP)++--------------------------------------------------------------------------------+-- Records+--------------------------------------------------------------------------------++-- | 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 = mkUnqual . selName <$> last ls + _ -> UpdField UpdFun [l] <$> rename (EUpd Nothing [ UpdField h more e])+ [] -> panic "rename@UpdField" [ "Empty label list." ]+++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++ -- The input comes from UpdField, and as such, it is expected to be a+ -- non-empty list.+ reLoc xs = x { thing = map thing xs }+ where+ x = case xs of+ x':_ -> x'+ [] -> panic "checkLabels" ["UpdFields with no labels"]+++++--------------------------------------------------------------------------------+-- List Comprehensions+--------------------------------------------------------------------------------++-- | Rename matches and compute environment.+-- Does not affect the locals.+renameArm :: [Match PName] -> RenameM (NamingEnv,[Match Name])+renameArm ms =+ case ms of+ m : more ->+ renameMatch m \env m' ->+ do+ (env',moreMs) <- renameArm more+ pure (env' `shadowing` env, m' : moreMs)+ [] -> pure (mempty, [])++-- | The name environment generated by a single match.+-- The env is also added to the local environment, but we return it+-- so that we can compute the scope in the head of the comprehension.+renameMatch :: Match PName -> (NamingEnv -> Match Name -> RenameM a) -> RenameM a+renameMatch ma k =+ case ma of+ Match p e ->+ do+ e' <- rename e+ bound <- getCurUnqualTypes+ env <- liftSupply (defsOfPats bound [p])+ inLocalBindScope False env+ do p' <- rename p+ k env (Match p' e')++ MatchLet b ->+ do+ env <- liftSupply (defsOf (InModule Nothing b))+ inLocalBindScope False env+ do+ b' <- rename b+ k env (MatchLet b')+++--------------------------------------------------------------------------------+-- Patterns+--------------------------------------------------------------------------------++renameBindParams :: BindParams PName -> (BindParams Name -> RenameM a) -> RenameM a+renameBindParams bps k =+ case bps of+ DroppedParams x y -> k (DroppedParams x y)+ PatternParams ps -> renamePats True ps \ps' -> k (PatternParams ps')++instance Rename CaseAlt where+ rename (CaseAlt p e) =+ do+ bound <- getCurUnqualTypes+ env <- liftSupply (defsOfPats bound [p])+ inLocalBindScope True env (CaseAlt <$> rename p <*> rename e)++-- | Rename a group of patterns from the same place and add their names+-- to the local environment.+renamePats :: Bool -> [Pattern PName] -> ([Pattern Name] -> RenameM a) -> RenameM a+renamePats checkUsed ps k =+ do+ bound <- getCurUnqualTypes+ env <- doDefGroup (defsOfPats bound ps)+ inLocalBindScope checkUsed env (k =<< mapM rename ps)+ +instance Rename Pattern where+ rename pat =+ case pat of+ PVar x -> PVar <$> rnLocated (resolveNameDef NSValue) x+ PCon c xs ->+ PCon+ <$> rnLocated (resolveNameUse NSConstructor) c+ <*> mapM rename xs+ PLocated p r -> withLoc r (rename p)+ PTyped p t -> PTyped <$> rename p <*> rename t+ _ -> panic "renamePat" ["Unexpected pattern"]
src/Cryptol/ModuleSystem/Renamer/Error.hs view
@@ -29,11 +29,14 @@ data RenamerError = MultipleSyms (Located PName) [Name]- -- ^ Multiple imported symbols contain this name+ -- ^ This name is ambiguous. | UnboundName Namespace (Located PName) -- ^ Some name not bound to any definition + | ImportTooSoon Range Ident+ -- ^ Import is before the definition of a module.+ | OverlappingSyms [Name] -- ^ An environment has produced multiple overlapping symbols @@ -53,21 +56,16 @@ | 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)+ -- ^ Expected one kind (first one) but found the other (second one) + | ConflictingModParam Ident Name+ -- ^ A functor parameter's name conflicts with a submodule definition.+ 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 -}+{- | This is used to make nicer error messages for certain kinds of dependnecies. -} data DepName = NamedThing Name -- ^ Something with a name @@ -75,11 +73,14 @@ -- ^ 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) -}+ -- ^ A module parameter+ | ConstratintAt Range- -- ^ Identifed by location in source+ -- ^ A top-level constraint. Shouldn't really appear in+ -- recursive groups as nothing can refer to it.++ | ImportAt Range+ -- ^ Identifies an import deriving (Eq,Ord,Show,Generic,NFData) depNameLoc :: DepName -> Maybe Range@@ -89,17 +90,19 @@ ConstratintAt r -> Just r ModParamName r _ -> Just r ModPath {} -> Nothing+ ImportAt r -> Just r -data ModKind = AFunctor | ASignature | AModule+data ModKind = AFunctor | ASignature | AModule | AnIfaceFunctor deriving (Show, Generic, NFData, Eq, Ord) instance PP ModKind where ppPrec _ e = case e of- AFunctor -> "a functor"- ASignature -> "an interface"- AModule -> "a module"+ AFunctor -> "a functor"+ ASignature -> "an interface"+ AModule -> "a module"+ AnIfaceFunctor -> "a parameterized interface" @@ -108,8 +111,8 @@ MultipleSyms lqn qns -> hang (text "[error] at" <+> pp (srcRange lqn))- 4 $ (text "Multiple definitions for symbol:" <+> pp (thing lqn))- $$ vcat (map ppLocName qns)+ 4 $ (text "The name" <+> backticks (pp (thing lqn)) <+> "is ambiguous. See:")+ $$ indent 2 (vcat (map (pp . nameLoc) qns)) UnboundName ns lqn -> hang (text "[error] at" <+> pp (srcRange lqn))@@ -121,6 +124,10 @@ NSModule -> "Module" NSConstructor -> "Constructor" + ImportTooSoon rng x ->+ hang (text "[error] at" <+> pp rng)+ 4 ("Module" <+> backticks (pp x) <+> "is not yet defined.")+ OverlappingSyms qns -> hang (text "[error]") 4 $ text "Overlapping symbols defined:"@@ -178,21 +185,19 @@ 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 ]) + ConflictingModParam i n ->+ hang ("[error] at" <+> pp (nameLoc n))+ 4 (vcat [ "Submodule" <+> backticks (pp n) <+>+ "conflicts with functor parameter" <+> backticks (pp i)+ ]) + instance PP DepName where ppPrec _ d = case d of@@ -208,17 +213,41 @@ case modPathSplit mp of (m,[]) -> "module" <+> pp m (_,is) -> "submodule" <+> hcat (intersperse "::" (map pp is))+ ImportAt r -> "import at" <+> pp r -- Warnings -------------------------------------------------------------------- data RenamerWarning- = SymbolShadowed PName Name [Name]+ = SymbolShadowed Shadower [Name] | UnusedName Name | PrefixAssocChanged PrefixOp (Expr Name) (Located Name) Fixity (Expr Name) deriving (Show, Generic, NFData) +data Shadower = ImportShadower Range | DefShadower PName Name+ deriving (Show, Generic, NFData)++shadowerLoc :: Shadower -> Range+shadowerLoc x =+ case x of+ ImportShadower a -> a+ DefShadower _ a -> nameLoc a++shadowerName :: Shadower -> Maybe Name+shadowerName x =+ case x of+ ImportShadower {} -> Nothing+ DefShadower _ a -> Just a++instance Eq Shadower where+ x == y = compare x y == EQ++-- used to determine in what order to show things+instance Ord Shadower where+ compare x y = compare (cmp x) (cmp y)+ where cmp z = (from (shadowerLoc z), shadowerName z)+ instance Eq RenamerWarning where x == y = compare x y == EQ @@ -226,8 +255,7 @@ instance Ord RenamerWarning where compare w1 w2 = case (w1, w2) of- (SymbolShadowed x y _, SymbolShadowed x' y' _) ->- compare (byStart y, x) (byStart y', x')+ (SymbolShadowed x _, SymbolShadowed x' _) -> compare x x' (UnusedName x, UnusedName x') -> compare (byStart x) (byStart x') (PrefixAssocChanged _ _ op _ _, PrefixAssocChanged _ _ op' _ _) ->@@ -241,18 +269,22 @@ priority PrefixAssocChanged {} = 2 instance PP RenamerWarning where- ppPrec _ (SymbolShadowed k x os) =+ ppPrec _ (SymbolShadowed sh os) = hang (text "[warning] at" <+> loc)- 4 $ fsep [ "This binding for" <+> backticks (pp k)- , "shadows the existing binding" <.> plural+ 4 $ fsep [ who, "shadows the existing binding" <.> plural , text "at" ] $$ vcat (map (pp . nameLoc) os) where+ who =+ case sh of+ ImportShadower _ -> "The import"+ DefShadower k _ -> "This binding for" <+> backticks (pp k)+ plural | length os > 1 = char 's' | otherwise = mempty - loc = pp (nameLoc x)+ loc = pp (shadowerLoc sh) ppPrec _ (UnusedName x) = hang (text "[warning] at" <+> pp (nameLoc x))@@ -263,6 +295,8 @@ 4 $ fsep [ backticks (pp old) , "is now parsed as" , backticks (pp new) ]++ where old = EInfix (EPrefix prefixOp x) infixOp infixFixity y
− src/Cryptol/ModuleSystem/Renamer/ImplicitImports.hs
@@ -1,124 +0,0 @@-{- |-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.Utils.Ident(identIsNormal, packModName)-import Cryptol.Utils.Panic(panic)-import Cryptol.Parser.Position(Range)-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 =- case dcl of- DModule m ->- let NestedModule m1 = tlValue m- mname = getIdent (thing (mName m1))- loc = srcRange (mName m1)- in- case mDef m1 of- _ | not (identIsNormal mname) -> ([dcl],[])- NormalModule ds ->- let (childExs, ds1) = addImplicitNestedImports' ds- imps = map (mname :) ([] : childExs) -- this & nested- in ( DModule m { tlValue = NestedModule m1 { mDef = NormalModule ds1 } }- : map (mkImp loc) imps- , case tlExport m of- Public -> imps- Private -> []- )-- FunctorInstance {} ->- let imps = [[mname]]- in ( dcl : map (mkImp loc) imps- , case tlExport m of- Public -> imps- Private -> []- )- InterfaceModule {} -> ([dcl], [])- _ -> panic "processModule" ["Not a module"]----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 = Located loc (ImpNested (isToName xs))- , iAs = Just (isToQual xs)- , iSpec = Nothing- , iInst = Nothing- , iDoc = Nothing- }- }--
− src/Cryptol/ModuleSystem/Renamer/Imports.hs
@@ -1,579 +0,0 @@-{- |--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.Position(Located(..))-import Cryptol.Parser.AST- ( ImportG(..),PName, ModuleInstanceArgs(..), ImpName(..) )-import Cryptol.ModuleSystem.Binds- ( Mod(..), TopDef(..), modNested, ModKind(..), newFunctorInst )-import Cryptol.ModuleSystem.Name- ( Name, Supply, SupplyT, runSupplyT, 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 (thing 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 <- newFunctorInst 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--
src/Cryptol/ModuleSystem/Renamer/Monad.hs view
@@ -1,531 +1,818 @@--- |--- 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 #-}-{-# Language MultiParamTypeClasses #-}-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(..),- undefinedModName)-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- }---- The ExceptionT here is for bailing when a fake value like mkFakeName is--- encountered. These values have already had an error recorded and are being--- processed for best-effort error reporting so we do not need a value.-newtype RenameM a = RenameM { unRenameM :: ReaderT RO (ExceptionT () (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')--instance ExceptionM RenameM () where- {-# INLINE raise #-}- raise = RenameM . raise--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) = case a of- Left _ -> panic "runRenamer" ["No renaming errors, but no output"]- Right r -> Right (r,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)- case Map.lookup nm mp of- Just r -> pure r- Nothing | isFakeName nm -> raise ()- 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. This warning is only emited--- for UserNames-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)- ]- )--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+{-# Language BlockArguments, BangPatterns, ImportQualifiedPost, LambdaCase #-}+{-# Language GeneralisedNewtypeDeriving #-}+module Cryptol.ModuleSystem.Renamer.Monad+ ( + -- * Renamer monad+ RenameM+ , runRenamer+ , RenamerInfo(..)++ -- * Modules+ , lookupMod+ , addResolvedMod+ , addInstMod+ , addModAlias+ , addFakeMod+ , isResolvableMod+ , resolveModAlias+ , recordTopImport+ , getExternalDeps+ , Mod(..)++ -- * The current module+ , getCurModPath+ , getCurTopDefs+ , getCurDefNames+ , getCurBinds+ , getCurScope+ , getCurUnqualTypes+ , setThisModuleDefs+ , addModParams+ , addImported++ -- * Scopes+ , inSubmodule+ , inLocalScope+ , inLocalBindScope++ , setCurBind+ , resolveCurBind++ -- * Name generation+ , doDefGroup+ , doDefOrdGroup++ -- * Error reporting+ , recordError+ , addWarning+ , reportUnused+ , quit+ , getCurLoc+ , located+ , withLoc+ , reportUnboundName+ , noWarningsFor++ -- * Dependency tracking+ , recordNameUses+ , getDeps+ ) where++-- import Debug.Trace+-- import Cryptol.Utils.PP++import MonadLib+import Data.Maybe(fromMaybe,maybeToList)+import Data.Set(Set)+import Data.Set qualified as Set+import Data.Map(Map)+import Data.Map qualified as Map+import Data.Text qualified as Text++import Cryptol.Utils.Panic+import Cryptol.Utils.Ident+import Cryptol.Utils.PP(pp,(<+>))+import Cryptol.Parser.Name+import Cryptol.Parser.Position+import Cryptol.Parser.AST+import Cryptol.ModuleSystem.Name+import Cryptol.ModuleSystem.NamingEnv+import Cryptol.ModuleSystem.Interface+import Cryptol.ModuleSystem.Binds+import Cryptol.ModuleSystem.Renamer.Error+import Cryptol.ModuleSystem.Exports+import Cryptol.TypeCheck.Type(ModParamNames)+import Cryptol.TypeCheck.Type qualified as T++newtype RenameM a = R (ReaderT RO (ExceptionT () (StateT RW Lift)) a)+ deriving (Functor,Applicative,Monad)+++-- | 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. These include normal modules, and functors+ -- (on the Right), as well as interfaces (on the Left)+ }+++-- | Do some renaming.+runRenamer ::+ RenamerInfo ->+ RenameM a ->+ (Either [RenamerError] (a,Supply), [RenamerWarning])+runRenamer info (R m) = (res, reverse (renWarnings rwFin))+ where+ (mres, rwFin) = runLift (runStateT rw0 (runExceptionT (runReaderT ro0 m)))+ res =+ case renErrors rwFin of+ [] | Right a <- mres -> Right (a, newNames rwFin)+ es -> Left (reverse es)++ ro0 = RO {+ curBind = Nothing,+ localsEnv = mempty,+ localBindEnv = mempty,+ outEnv = renEnv info,+ outDefs = renEnv info,+ curModPath = renContext info,+ curLoc = emptyRange,+ don'tWarn = mempty,+ loadedIfaces =+ let hasIf x =+ case x of+ Left {} -> Nothing+ Right i -> Just i+ in Map.mapMaybe hasIf (renIfaces info)+ }++ rw0 = RW {+ defEnv = mempty,+ impEnv = mempty,+ modParams = mempty,+ externalDeps = mempty,+ newNames = renSupply info,+ renErrors = [],+ renWarnings = [],+ usedNames = Set.empty,+ knownMods =+ Map.unions [ + case ent of+ Left ps -> Map.singleton (ImpTop t) (ModKnown (ifaceSigToMod ps))+ Right i -> ifaceToMod (ImpTop t) i+ | (t,ent) <- Map.toList (renIfaces info)+ ]++ }+++data RO = RO {+ curModPath :: ModPath,+ -- ^ Current module that we are working on++ curLoc :: Range,+ -- ^ The source location where we are doing something++ loadedIfaces :: Map ModName Iface,+ -- ^ Interfaces for external loaded modules.+ -- We keep this so then if one of the modules is imported, we can+ -- collect its definitions in `externalDeps` to give the typechecker.++ curBind :: Maybe (Located PName, Name),+ -- ^ The current binding we are working on. During NoPat we do+ -- a transformation like this:+ -- f x y = e ~> f = \/*f*/ x -> \/*f*/ y -> e+ -- We use `curBind` to resolve the `f` in the lambdas. Specifically,+ -- we want to avoid getting confused in a situation like this:+ -- f f y = ~> f = \/*f*/ f -> \/*f*/ y -> e + -- If we are not careful the (f) in the second lambda could refer to the+ -- argument instead of the original binding.+ -- The /*f*/ is the 'FunDesc' in the 'EFun'++ localBindEnv :: NamingEnv,+ -- ^ Local names that are in scope, for resolving definition names++ localsEnv :: NamingEnv,+ -- ^ Local names that are in scope, for resolving name uses++ outEnv :: NamingEnv,+ -- ^ Things in an enclosing scope (for nested modules). This is used+ -- for resolving names, and it includes definitions and imports in the+ -- outer scope of a module appropriately shadowed.++ outDefs :: NamingEnv,+ -- ^ Things defined in outer scopes. This is not used for resolving names,+ -- but to report shadowing warnings.++ don'tWarn :: Set Name+ -- ^ Don't emit warnings for these names+}++data RW = RW {++ knownMods :: ModMap,+ -- ^ Information about previously processed modules++ externalDeps :: IfaceDecls,+ -- ^ Interface declarations for imported external modules.+ -- We track this so we can give it to the type checker.+ + defEnv :: NamingEnv,+ -- ^ Things defined in the current module++ modParams :: !(Map Ident (Range, NamingEnv)),+ -- ^ Information about the module parameters of the current module++ impEnv :: NamingEnv,+ -- ^ Things imported in the current scope++ newNames :: !Supply,+ -- ^ Used to generate unique names when renaming++ renErrors :: [RenamerError],+ -- ^ Errors we found++ renWarnings :: [RenamerWarning],+ -- ^ Warnings we'd like to emit.++ usedNames :: Set Name+ -- ^ Every time we resove a name use we record it here.+ -- In this way we can determine the dependencies of things.+}+++modParamEnv :: Map Ident (Range, NamingEnv) -> NamingEnv+modParamEnv = mconcat . map snd . Map.elems++--------------------------------------------------------------------------------+-- Module Manipulation+--------------------------------------------------------------------------------+++-- | Information about a processed module.+data Mod = Mod+ { modKind :: ModKind -- ^ What sort of thing are we+ , modDefines :: Set Name -- ^ Things defined by this module.+ , modPublic :: !(Set Name) -- ^ These are the exported names+ }++-- | A dummy module to use as placeholder for error situations+emptyMod :: ModKind -> Mod+emptyMod k = Mod {+ modKind = k,+ modDefines = mempty,+ modPublic = mempty+}+++-- | Lookup a known module+lookupMod :: ImpName Name -> Maybe ModKind -> RenameM Mod+lookupMod = lookupMod' Set.empty++lookupMod' :: Set (ImpName Name) -> ImpName Name -> Maybe ModKind -> RenameM Mod+lookupMod' visited nm mbExpected+ | nm `Set.member` visited =+ do loc <- getCurLoc+ case nm of+ ImpNested x ->+ recordError (ImportTooSoon loc (nameIdent x))+ ImpTop {} -> panic "lookupMod" ["cycle with top-level module"]+ pure (emptyMod (fromMaybe AModule mbExpected))+ | otherwise =+ do+ rw <- R get+ case Map.lookup nm (knownMods rw) of+ Just (ModKnown mo) ->+ case mbExpected of+ Nothing -> pure mo+ Just expected+ | expected == actual -> pure mo+ | otherwise ->+ do+ loc <- getCurLoc+ recordError (ModuleKindMismatch loc nm expected actual)+ pure (emptyMod expected)+ where actual = modKind mo+ Just (ModAlias target) -> lookupMod' (Set.insert nm visited) target mbExpected+ Just ModTodo ->+ do+ loc <- getCurLoc+ case nm of+ ImpNested x ->+ recordError (ImportTooSoon loc (nameIdent x))+ ImpTop {} -> panic "lookupMod" ["ModTodo"]+ pure (emptyMod (fromMaybe AModule mbExpected))+ Just ModFake ->+ pure (emptyMod (fromMaybe AModule mbExpected))++ Nothing ->+ panic "lookupMod" ["Resolved name, but unknown module"]++recordTopImport :: ModName -> RenameM ()+recordTopImport = go Set.empty+ where+ go visited m+ | m `Set.member` visited = pure ()+ | otherwise =+ do+ ro <- R ask+ case Map.lookup m (loadedIfaces ro) of+ Just ifa ->+ do+ R (sets_ \rw ->+ rw { externalDeps = ifDefines ifa <> externalDeps rw })+ {- The interface may contain submodule aliases whose targets+ live in a different top-level module. We need to also+ bring the decls of those modules into scope so that the+ type checker can find the types of names accessed through+ the alias. -}+ let visited' = Set.insert m visited+ forM_ (Map.elems (ifModuleAliases (ifDefines ifa))) \case+ ImpTop t -> go visited' t+ ImpNested n ->+ case nameTopModuleMaybe n of+ Just t -> go visited' t+ Nothing -> pure ()++ -- This can happen if the module is of the wrong kind (e.g.,+ -- importing an interface as a module). The error is already+ -- reported by lookupMod.+ Nothing -> pure ()++getExternalDeps :: RenameM IfaceDecls+getExternalDeps = R (externalDeps <$> get)++data ModStatus = ModKnown Mod | ModAlias (ImpName Name) | ModFake | ModTodo++type ModMap = Map (ImpName Name) ModStatus++-- | Make a `Mod` from the public declarations in a top-level module's interface.+-- This is used to handle imports.+ifaceToMod :: ImpName Name -> IfaceG name -> ModMap+ifaceToMod nm iface =+ ifaceNamesToMod iface (ifParams iface) nm (ifNames iface)++-- | Like 'ifaceToMod' but checks 'ifIsSignature' to determine the kind.+ifaceToFunctorMod :: ImpName Name -> IfaceG Name -> ModMap+ifaceToFunctorMod nm iface+ | ifIsSignature iface =+ ifaceNamesToMod iface (ifParams iface) nm (ifNames iface)+ | otherwise = ifaceToMod nm iface++-- | Generate a module or functor from the given names.+ifaceNamesToMod ::+ IfaceG topname -> Map Ident T.ModParam -> ImpName Name -> IfaceNames name -> ModMap+ifaceNamesToMod iface params nm names =+ Map.unions (Map.fromList ((nm,ModKnown mo) : sigs ++ aliases) : funs ++ nest)+ where+ sigs =+ [ (ImpNested k, ModKnown (ifaceSigToMod v)) | (k,v) <- Map.toList (ifSignatures decls) ]+ funs =+ [ ifaceToFunctorMod (ImpNested k) v | (k,v) <- Map.toList (ifFunctors decls) ]+ nest =+ [ ifaceNamesToMod iface mempty (ImpNested k) v+ | (k,v) <- Map.toList (ifModules decls) ]+ aliases =+ [ (ImpNested k, ModAlias v) | (k,v) <- Map.toList (ifModuleAliases decls) ]+ mo = Mod+ { modKind = if ifIsSignature iface then AnIfaceFunctor+ else if null params then AModule+ else AFunctor+ , modDefines = Set.fromList namesFromPs `Set.union` defs+ , modPublic = ifsPublic names+ }+ defs = ifsDefines names `Set.union` namesFromSigParams+ isLocal x = x `Set.member` ifsDefines names+ decls = filterIfaceDecls isLocal (ifDefines iface)+ namesFromPs =+ [ pnm+ | mp <- Map.elems params+ , let nms = T.mpParameters mp+ , pnm <- Map.keys (T.mpnTypes nms) +++ Map.keys (T.mpnFuns nms) +++ Map.keys (T.mpnTySyn nms)+ ]+ namesFromSigParams =+ case ifSigOwnParams (ifDefines iface) of+ Nothing -> Set.empty+ Just nms -> Map.keysSet (pdTypes nms) `Set.union`+ Map.keysSet (pdFuns nms)++-- | Generate a module corresponding to an interface module.+ifaceSigToMod :: ModParamNames -> Mod+ifaceSigToMod ps = Mod+ { modKind = ASignature+ , modDefines = env+ , modPublic = env+ }+ where+ env = namingEnvNames (modParamNamesNamingEnv ps)++-- | Add a module that was generated when instantiating a functor+addInstMod :: Name -> Mod -> RenameM ()+addInstMod x y =+ R (sets_ \rw -> rw { knownMods = Map.insert (ImpNested x) (ModKnown y) (knownMods rw) })++-- | Add a module alias: the name refers to another module.+addModAlias :: Name -> ImpName Name -> RenameM ()+addModAlias x target =+ R (sets_ \rw -> rw { knownMods = Map.insert (ImpNested x) (ModAlias target) (knownMods rw) })++-- | Register a module name as fake (for error recovery).+addFakeMod :: Name -> RenameM ()+addFakeMod x =+ R (sets_ \rw -> rw { knownMods = Map.insert (ImpNested x) ModFake (knownMods rw) })++-- | Check if a module can be resolved (is defined and not in a cycle).+isResolvableMod :: ImpName Name -> RenameM Bool+isResolvableMod nm =+ do rw <- R get+ pure (go Set.empty (knownMods rw) nm)+ where+ go visited mp x+ | x `Set.member` visited = False+ | otherwise =+ case Map.lookup x mp of+ Just (ModKnown {}) -> True+ Just (ModAlias tgt) -> go (Set.insert x visited) mp tgt+ _ -> False++-- | Follow alias chains to get the fully-resolved target.+-- Returns the input unchanged if it is not an alias or if there is a cycle.+resolveModAlias :: ImpName Name -> RenameM (ImpName Name)+resolveModAlias nm =+ do rw <- R get+ pure (go Set.empty (knownMods rw) nm)+ where+ go visited mp x+ | x `Set.member` visited = x+ | otherwise =+ case Map.lookup x mp of+ Just (ModAlias tgt) -> go (Set.insert x visited) mp tgt+ _ -> x++addResolvedMod :: Set Name -> ModuleG Name Name -> RenameM ()+addResolvedMod names mo =+ do+ let nm = ImpNested (thing (mName mo))+ summary <-+ case mDef mo of+ NormalModule ds ->+ pure Mod {+ modKind = if any isParamDecl ds+ then AFunctor else AModule,+ modDefines = names,+ modPublic = Set.unions (map (`exported` expSpec) allNamespaces)+ }+ where expSpec = exportedDecls ds+ + FunctorInstance f _ modInst kind ->+ do+ -- Here we don't validate the functor again, to avoid duplicated+ -- error.+ fmo <- withLoc (srcRange f) (lookupMod (thing f) Nothing)+ -- If there was an error, and the thing we are instantiating+ -- is *not* a functor `inst` would be empty. We just leave+ -- the name as is in this case, which shouldn't matter as we'll+ -- stop after the renamer due to errors.+ let inst = modInstMap modInst+ remap x = Map.findWithDefault x x inst+ -- Virtual submodules created for parameters are not in the+ -- original functor, so they won't be reached by remapping.+ vpNames = Set.fromList+ [ vpmName s | s <- modInstVirtParamMods modInst ]+ k = case kind of+ ModuleInst -> AModule+ SignatureInst -> ASignature++ pure Mod {+ modKind = k,+ modDefines = names,+ modPublic = Set.map remap (modPublic fmo)+ `Set.union` vpNames+ }++ InterfaceModule sig ->+ pure Mod {+ modKind = if any isSigIfaceImport (sigImports sig)+ then AnIfaceFunctor+ else ASignature,+ modDefines = names,+ modPublic = names+ }+ ModuleAlias {} ->+ panic "addResolvedMod" ["ModuleAlias handled in renameModuleAlias"]+ R (sets_ \rw -> rw { knownMods = Map.insert nm (ModKnown summary) (knownMods rw) })++++--------------------------------------------------------------------------------+-- The current module+--------------------------------------------------------------------------------++-- | What module we are currently processing.+getCurModPath :: RenameM ModPath+getCurModPath = R (curModPath <$> ask)++-- | Get just the things defined in the current module+getCurTopDefs :: RenameM NamingEnv+getCurTopDefs = R (defEnv <$> get)++-- | Get names that should be defined in a module.+-- Note that for functors we include names that come from parameters,+-- because when making an instantiation we may generate specialized versions+-- of the original module's name.+getCurDefNames :: RenameM (Set Name)+getCurDefNames =+ do+ rw <- R get+ pure (Set.union (namingEnvNames (defEnv rw)) (namingEnvNames (modParamEnv (modParams rw))))++-- | Get things defined in the current module, and any local bindings in scope.+-- Used for resolving name definitions.+-- Note that this does not include module parameters as these don't have+-- an explicit binding site that needs renaming.+getCurBinds :: RenameM NamingEnv+getCurBinds = R+ do+ ro <- ask+ rw <- get+ pure (localBindEnv ro `shadowing` defEnv rw)+++-- | Compute the current scope, for resolving name uses.+getCurScope :: RenameM NamingEnv+getCurScope = R+ do+ ro <- ask+ rw <- get+ pure $+ localsEnv ro `shadowing`+ defEnv rw `shadowing`+ modParamEnv (modParams rw) `shadowing`+ impEnv rw `shadowing`+ outEnv ro++getCurUnqualTypes :: RenameM (Set Ident)+getCurUnqualTypes =+ do+ scope <- getCurScope+ pure (Set.fromList [ i | UnQual i <- Map.keys (namespaceMap NSType scope) ])++-- | Set the definition for the current module.+setThisModuleDefs :: NamingEnv -> RenameM ()+setThisModuleDefs env =+ R (sets_ \rw -> rw { defEnv = env,+ knownMods = todoMods `Map.union` knownMods rw+ })+ where+ todoMods =+ Map.fromList + [ (ImpNested x,ModTodo)+ | x <- Set.toList (namingEnvNames env), nameNamespace x == NSModule+ ]++-- | Add names from module parameters to the current scope.+-- It is an error if the module parameters conflict with the+-- definitions in a module.+addModParams :: Located Ident -> NamingEnv -> RenameM ()+addModParams nm env =+ do+ errs <- R (sets upd)+ mapM_ recordError errs+ unless (null errs) quit+ where+ upd rw =+ let nms = modParams rw+ newEnv = env <> modParamEnv nms+ errs =+ [ MultipleModParams (thing nm) [r,srcRange nm]+ | (r,_) <- maybeToList (Map.lookup (thing nm) nms) ] +++ map OverlappingSyms (findAmbig newEnv)+ in (errs, rw { modParams = Map.insert (thing nm) (srcRange nm, newEnv) nms })++-- | Add some names that came from an import.+addImported :: Range -> NamingEnv -> RenameM ()+addImported rng env =+ do+ R (sets_ \rw -> rw { impEnv = env <> impEnv rw })+ outDs <- R (outDefs <$> ask)+ forM_ (findShadowing env outDs) \(_,_,xs) ->+ addWarning (SymbolShadowed (ImportShadower rng) xs)++setCurBind :: Located PName -> Name -> RenameM a -> RenameM a+setCurBind p n (R m) = R (mapReader upd m)+ where upd r = r { curBind = Just (p,n) }++resolveCurBind :: Bool -> PName -> RenameM Name+resolveCurBind fromP p =+ do+ mb <- R (curBind <$> ask)+ case mb of+ Just (p',n)+ | thing p' == p -> pure n+ | fromP,+ let i = identText (getIdent (thing p')),+ let j = identText (getIdent p),+ j `Text.isPrefixOf` i -> pure n+ | otherwise ->+ panic "resolveCurBind"+ [ "Unexpected current binding"+ , "Expected: " ++ show (pp (thing p') <+> pp (srcRange p'))+ , "Actual: " ++ show (pp p)+ ]+ Nothing ->+ panic "resolveCurBind" ["No current binding", "Actual: " ++ show (pp p) ]++-- | Set the names of bindings for the duration of a computation.+inLocalBindScope :: Bool -> NamingEnv -> RenameM a -> RenameM a+inLocalBindScope checkUsed env (R m) =+ do+ a <- R (mapReader upd m)+ used <- R (usedNames <$> get)+ let unused = namingEnvNames env `Set.difference` used+ when checkUsed (mapM_ reportUnused unused)+ scope <- getCurScope -- XXX: is this too much, we'll get warning for shadowing imported things too...+ mapM_ reportShadowed (findShadowing env scope)+ pure a+ where+ upd ro = ro {+ localBindEnv = env,+ localsEnv = env `shadowing` localsEnv ro+ }++-- | Do something that will only modify the local scope, and restore+-- it after the computation. Usually we use `inLocalBindScope`, but+-- we use this for list comprehensions, because the binders in the arms+-- need to be combined when processing the "head" of the comprehension.+inLocalScope :: NamingEnv -> RenameM a -> RenameM a+inLocalScope env (R m) =+ do+ a <- R (mapReader upd m)+ used <- R (usedNames <$> get)+ let unused = namingEnvNames env `Set.difference` used+ mapM_ reportUnused (Set.toList unused)+ pure a+ where+ upd ro = ro {+ localsEnv = env `shadowing` localsEnv ro+ }++-- | Do some renaming in the context of a nested module.+inSubmodule :: Ident -> RenameM a -> RenameM a+inSubmodule x (R m) = R+ do+ rw <- get+ let defs = defEnv rw+ pars = modParams rw+ imps = impEnv rw+ + let upd ro =+ let ds = defs `shadowing` modParamEnv pars+ in+ ro {+ curModPath = Nested (curModPath ro) x,+ outEnv = ds `shadowing` imps `shadowing` outEnv ro,+ outDefs = ds `shadowing` outDefs ro+ }++ set rw {+ defEnv = mempty,+ impEnv = mempty,+ modParams = mempty+ }+ a <- mapReader upd m+ sets \rw1 -> + let bound = Set.unions+ (map namingEnvNames+ [ defEnv rw1, impEnv rw1, modParamEnv (modParams rw1) ])+ in+ (a,+ rw1 { defEnv = defs,+ modParams = pars,+ impEnv = imps,+ usedNames = usedNames rw1 `Set.difference` bound+ } )+++--------------------------------------------------------------------------------+-- Error reporting+--------------------------------------------------------------------------------++recordError :: RenamerError -> RenameM ()+recordError e = R (sets_ \rw -> rw { renErrors = e : renErrors rw })++noWarningsFor :: Set Name -> RenameM a -> RenameM a+noWarningsFor xs (R m) = R (mapReader upd m)+ where upd ro = ro { don'tWarn = Set.union xs (don'tWarn ro) }++addWarning :: RenamerWarning -> RenameM ()+addWarning e = R (sets_ \rw -> rw { renWarnings = e : renWarnings rw })++reportUnused :: Name -> RenameM ()+reportUnused n+ | nameSrc n == UserName =+ case Text.uncons (identText (nameIdent n)) of+ Just ('_',_) -> pure ()+ _ ->+ do+ ws <- R (don'tWarn <$> ask)+ unless (n `Set.member` ws) (addWarning (UnusedName n))+ | otherwise = pure ()++reportShadowed :: (PName, Name, [Name]) -> RenameM ()+reportShadowed (x,y,z) = addWarning (SymbolShadowed (DefShadower x y) z)++quit :: RenameM a+quit = R (raise ())++getCurLoc :: RenameM Range+getCurLoc = R (curLoc <$> ask)++-- | Annotate something with the current range.+located :: a -> RenameM (Located a)+located a =+ do loc <- getCurLoc+ return Located { thing = a, srcRange = loc }++withLoc :: HasLoc loc => loc -> RenameM a -> RenameM a+withLoc th (R m) = R+ case getLoc th of+ Nothing -> m+ Just r -> mapReader (\ro -> ro { curLoc = r }) m++-- | Generate an error for a name that we cannot resolve.+-- We try to give a hint, if the name appears in a different name space.+reportUnboundName :: Namespace -> PName -> NamingEnv -> RenameM Name+reportUnboundName expected qn scope =+ do + let others = [ ns | ns <- allNamespaces+ , ns /= expected+ , Just _ <- [lookupNS ns qn scope] ]+ 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)++ -- traceM ("UNDEFINED NAME IN " ++ show (pp expected) ++ ": " ++ show (pp qn) ++ "\n" ++ show (debugHidePreludeNames (pp scope)))++ mkFakeName expected qn+++--------------------------------------------------------------------------------+-- Name generation+--------------------------------------------------------------------------------++instance FreshM RenameM where+ liftSupply f =+ R (sets \rw ->+ case f (newNames rw) of+ (a,s1) -> (a, rw1)+ where !rw1 = rw { newNames = s1 })++-- | Make names for a bunch of things defined together.+-- Check that they all have distinct names.+-- We also return the names defined by each entry.+-- This is useful for when we need to rearrange the entries in dependency+-- order.+doDefOrdGroup :: BindsNames a => [a] -> RenameM (NamingEnv,[Set Name])+doDefOrdGroup as =+ do+ envs <- mapM (liftSupply . defsOf) as+ let env = mconcat envs+ errs = findAmbig env+ mapM_ (recordError . OverlappingSyms) errs+ when (not (null errs)) quit+ pure (env, map namingEnvNames envs)+++-- | Make names for a bunch of things defined together.+-- Check that they all have distinct names.+doDefGroup :: (Supply -> (NamingEnv, Supply)) -> RenameM NamingEnv+doDefGroup m =+ do+ env <- liftSupply m+ let errs = findAmbig env+ mapM_ (recordError . OverlappingSyms) (findAmbig env)+ when (not (null errs)) quit+ pure env++-- | 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+ loc <- getCurLoc+ nm <-+ liftSupply (mkDeclared ns (TopModule undefinedModName)+ SystemName (getIdent pn) Nothing loc)+ R (sets_ \rw -> rw { defEnv = singletonNS ns pn nm `shadowing` defEnv rw,+ knownMods =+ case ns of+ NSModule -> Map.insert (ImpNested nm) ModFake (knownMods rw)+ _ -> knownMods rw })+ pure nm +++--------------------------------------------------------------------------------+-- Dependency Tracking+--------------------------------------------------------------------------------++-- | Collect all names used while running the given computation.+-- Note that the names of the sub-computation are *NOT* added to the dependencies.+getDeps :: RenameM a -> RenameM (a, Set Name)+getDeps (R m) = R+ do+ curUses <- sets \rw -> (usedNames rw, rw { usedNames = Set.empty })+ a <- m+ sets \rw -> ((a,usedNames rw), rw { usedNames = usedNames rw <> curUses })++-- | Add some dependencies for the current thing we are working on.+recordNameUses :: Set Name -> RenameM ()+recordNameUses xs =+ R (sets_ \rw -> rw { usedNames = Set.union xs (usedNames rw) })
src/Cryptol/Parser.y view
@@ -170,6 +170,11 @@ | 'v{' vmod_body 'v}' {% mkAnonymousModule $2 } | mbDoc 'interface' 'module' modName 'where' 'v{' sig_body 'v}' { mkTopSig $1 $4 $7 }+ | mbDoc 'interface' 'module' modName '=' impName 'where'+ 'v{' vmod_body 'v}'+ { [mkIfaceInst $1 $4 $6 (DefaultInstAnonArg $9)] }+ | mbDoc 'interface' 'module' modName '=' impName '{' modInstParams '}'+ { [mkIfaceInst $1 $4 $6 $8] } module_def :: { Module PName } @@ -181,7 +186,9 @@ | modName '=' impName '{' modInstParams '}' { mkModuleInstance $1 $3 $5 } + | modName '=' impName { mkModuleAlias $1 $3 } + modInstParams :: { ModuleInstanceArgs PName } : modInstParam { DefaultInstArg $1 } | namedModInstParams { NamedInstArgs $1 }@@ -200,18 +207,11 @@ , srcRange = $1 } } vmod_body :: { [TopDecl PName] }- : vtop_decls { reverse $1 }+ : vtop_decls { concat (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)) } : mbDoc 'import' impName optInst mbAs mbImportSpec optImportWhere {% mkImport $2 $3 $4 $5 $6 $7 $1 }@@ -241,40 +241,35 @@ : 'as' modName { Just $2 } | {- empty -} { Nothing } -mbImportSpec :: { Maybe (Located ImportSpec) }- : mbHiding '(' name_list ')'{ Just Located+mbImportSpec :: { Maybe (Located ImportSpec) }+ : mbHiding '(' vars_comma ')'{ Just Located { srcRange = case $3 of { [] -> emptyRange ; xs -> rCombs (map srcRange xs) }- , thing = $1 (reverse (map thing $3))+ , thing = $1 (reverse (map (getIdent . 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) }+ : top_decls { Program (concat (reverse $1)) } | {- empty -} { Program [] } program_layout :: { Program PName }- : 'v{' vtop_decls 'v}' { Program (reverse $2) }+ : 'v{' vtop_decls 'v}' { Program (concat (reverse $2)) } | 'v{''v}' { Program [] } -top_decls :: { [TopDecl PName] }- : top_decl ';' { $1 }- | top_decls top_decl ';' { $2 ++ $1 }+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_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] }@@ -294,29 +289,37 @@ | mbDoc 'submodule' module_def {% ((:[]) . exportModule $1) `fmap` mkNested $3 } - | mbDoc sig_def { [mkSigDecl $1 $2] }- | mod_param_decl { [DModParam $1] }+ | mbDoc 'interface' 'submodule' name 'where' 'v{' sig_body 'v}'+ { [mkSigDecl $1 ($4, $7)] }+ | mbDoc 'interface' 'submodule' name '=' impName 'where'+ 'v{' vmod_body 'v}'+ {% mkNestedIfaceInst $1 $4 $6 (DefaultInstAnonArg $9) }+ | mbDoc 'interface' 'submodule' name '=' impName '{' modInstParams '}'+ {% mkNestedIfaceInst $1 $4 $6 $8 }+ | mbDoc 'interface' 'submodule' name '=' impName+ {% mkNestedIfaceAlias $1 $4 $6 }+ | iface_import { [DModParam $1] } | import { [DImport $1] } --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 }+ | sig_imports 'v;' par_decls {% mkInterface $1 $3 }+ | sig_imports ';' par_decls {% mkInterface $1 $3 } +sig_import :: { SigImport PName }+ : import { SigImport $1 }+ | iface_import { SigIfaceImport $1 } -mod_param_decl :: { ModParam PName }+sig_imports :: { [SigImport PName] }+ : sig_imports 'v;' sig_import { $3 : $1 }+ | sig_imports ';' sig_import { $3 : $1 }+ | sig_import { [$1] }++iface_import :: { ModParam PName } : mbDoc 'import' 'interface'- impName mbAs { ModParam { mpSignature = $4- , mpAs = fmap thing $5- , mpName = mkModParamName $4 $5- , mpDoc = $1- , mpRenaming = mempty } }+ impName optInst mbAs+ optImportWhere {% mkIfaceImport $1 $4 $5 $6 $7 } top_decl :: { [TopDecl PName] }@@ -326,9 +329,9 @@ private_decls :: { [TopDecl PName] } : 'private' 'v{' vtop_decls 'v}'- { changeExport Private (reverse $3) }+ { changeExport Private (concat (reverse $3)) } | doc 'private' 'v{' vtop_decls 'v}'- {% privateDocedDecl $1 $4 }+ {% privateDocedDecl $1 (concat (reverse $4)) } prim_bind :: { [TopDecl PName] } : mbDoc 'primitive' name ':' schema { mkPrimDecl $1 $3 $5 }@@ -341,21 +344,32 @@ parameter_decls :: { TopDecl PName }- : 'parameter' 'v{' par_decls 'v}' { mkParDecls (reverse $3) }+ : 'parameter' 'v{' par_decls 'v}' { mkParDecls $3 } ++par_decls :: { [ParamDecl PName] }+ : par_decls_rev { concat (reverse $1) }+ -- Reversed-par_decls :: { [ParamDecl PName] }- : par_decl { [$1] }- | par_decls ';' par_decl { $3 : $1 }- | par_decls 'v;' par_decl { $3 : $1 }+par_decls_rev :: { [[ParamDecl PName]] }+ : par_decl { [$1] }+ | par_decls_rev ';' par_decl { $3 : $1 }+ | par_decls_rev '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 (ParameterConstraint (distrLoc $2) $1) }+par_decl :: { [ParamDecl PName] }+ : mbDoc vars_comma ':' schema { map (\x -> mkParFun $1 x $4) $2 }+ | mbDoc 'type' type_vars_comma ':' kind {% mapM (\x -> mkParType $1 x $5) $3 }+ | mbDoc typeOrPropSyn { [mkIfacePropSyn (thing `fmap` $1) $2] }+ | mbDoc topTypeConstraint { [DParameterConstraint (ParameterConstraint (distrLoc $2) $1)] } +-- We only expect names here, but to avoid reduce/reduce conflicts+-- due to 1 look-ahead we parse a whole type, and then check that it was+-- indeed just a nme.+type_vars_comma :: { [ LPName ] }+ : type {% fmap (: []) (getTypeName $1) }+ | type_vars_comma ',' type {% fmap (: $1) (getTypeName $3) } + doc :: { Located Text } : DOC { mkDoc (fmap tokenText $1) } @@ -660,7 +674,7 @@ rec_expr :: { Either (Expr PName) [Named (Expr PName)] }- : aexpr '|' field_exprs { Left (EUpd (recExprWildcardCase $1) (reverse $3)) }+ : expr '|' field_exprs { Left (EUpd (recExprWildcardCase $1) (reverse $3)) } | field_exprs {% Right `fmap` mapM ufToNamed $1 } field_exprs :: { [UpdField PName] }@@ -668,11 +682,7 @@ | field_exprs ',' field_expr { $3 : $1 } field_expr :: { UpdField PName }- : field_path opt_iapats_indices field_how expr- { UpdField $3 $1 (mkIndexedExpr $2 $4) }--field_path :: { [Located Selector] }- : aexpr {% exprToFieldPath $1 }+ : simpleExpr field_how expr {% mkRecField $1 $2 $3 } field_how :: { UpdHow } : '=' { UpdSet }@@ -787,12 +797,6 @@ iapats_indices :: { ([Pattern PName], [Pattern PName]) } : iapats indices { ($1, $2) } | '@' indices1 { ([], $2) }--opt_iapats_indices :: { ([Pattern PName], [Pattern PName]) }- : {- empty -} { ([],[]) }- | iapats_indices { $1 }-- --------------------------------------------------------------------------------
src/Cryptol/Parser/AST.hs view
@@ -49,10 +49,12 @@ , isParamDecl , ModuleDefinition(..)+ , FunctorInstKind(..) , ModuleInstanceArgs(..) , ModuleInstanceNamedArg(..) , ModuleInstanceArg(..)- , ModuleInstance+ , ModuleInstance(..)+ , VirtParamMod(..) , emptyModuleInstance , Program(..)@@ -78,6 +80,7 @@ , ParameterConstraint(..) , NestedModule(..) , Signature(..)+ , SigImport(..), isSigIfaceImport , SigDecl(..) , ModParam(..) , ParamDecl(..)@@ -170,12 +173,16 @@ -- ^ Names in scope inside this module, filled in by the renamer. -- Also, for the 'FunctorInstance' case this is not the final result of -- the names in scope. The typechecker adds in the names in scope in the- -- functor, so this will just contain the names in the enclosing scope.+ -- functor, so after renaming, this will contain only the names in the enclosing scope. , mDocTop :: Maybe (Located Text) -- ^ only used for top-level modules } deriving (Show, Generic, NFData) +-- | Whether a functor instantiation produces a module or a signature.+data FunctorInstKind = ModuleInst | SignatureInst+ deriving (Eq, Show, Generic, NFData)+ -- | Different flavours of modules we have. data ModuleDefinition name = NormalModule [TopDecl name]@@ -183,19 +190,50 @@ | FunctorInstance (Located (ImpName name)) (ModuleInstanceArgs name) (ModuleInstance name)- -- ^ The instance is filled in by the renamer+ FunctorInstKind+ -- ^ The 'ModuleInstance' field is filled in by the renamer and+ -- it is used by the type-checker when generating the module instantiation.+ -- The 'FunctorInstKind' indicates whether the result of instantiation+ -- is a module ('ModuleInst') or a signature ('SignatureInst'). | InterfaceModule (Signature name)++ | ModuleAlias (Located (ImpName name))+ -- ^ An alias for another module. The name of the alias is+ -- an ordinary definition which refers to the target module. 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 entries for all the name in the instantiated functor,-including names in modules nested inside the functor. -}-type ModuleInstance name = Map name name+{- | Information about a functor instance, filled in by the renamer. -}+data ModuleInstance name = ModuleInstance+ { modInstMap :: Map name name+ -- ^ Maps names in the original functor to names in the instance.+ -- For non-parameter definitions, maps to fresh instance names.+ -- For parameter definitions, maps to names in the virtual submodules.+ -- Backtick parameter names are treated as non-parameter definitions.+ -- This includes entries for all names in the instantiated functor,+ -- including names in modules nested inside the functor.+ , modInstVirtParamMods :: [VirtParamMod name]+ -- ^ Virtual submodules that are the definition sites for functor+ -- parameter values.+ } deriving (Show, Generic, NFData) +-- | A virtual submodule that defines the values from a functor parameter.+data VirtParamMod name = VirtParamMod+ { vpmIdent :: Ident+ -- ^ The parameter identifier (or "Parameter" for inline params).+ , vpmName :: name+ -- ^ The module name for the virtual submodule.+ , vpmDefs :: Map name name+ -- ^ Maps names defined in the virtual submodule to the original+ -- parameter names in the functor. The @modInstMap@ maps the original+ -- parameter names to these virtual submodule definition names.+ } deriving (Show, Generic, NFData)+ emptyModuleInstance :: Ord name => ModuleInstance name-emptyModuleInstance = mempty+emptyModuleInstance = ModuleInstance+ { modInstMap = mempty+ , modInstVirtParamMods = mempty+ } -- XXX: Review all places this is used, that it actually makes sense@@ -204,8 +242,9 @@ mDecls m = case mDef m of NormalModule ds -> ds- FunctorInstance _ _ _ -> []+ FunctorInstance {} -> [] InterfaceModule {} -> []+ ModuleAlias {} -> [] -- | Imports of top-level (i.e. "file" based) modules. mImports :: ModuleG mname name -> [ Located Import ]@@ -213,7 +252,8 @@ case mDef m of NormalModule ds -> mapMaybe topImp [ li | DImport li <- ds ] FunctorInstance {} -> []- InterfaceModule sig -> mapMaybe topImp (sigImports sig)+ InterfaceModule sig -> mapMaybe topImp [ li | SigImport li <- sigImports sig ]+ ModuleAlias {} -> [] where topImp li = case thing mo of ImpTop n -> Just li { thing = i { iModule = Located (srcRange mo) n } }@@ -291,10 +331,10 @@ -- | All arguments in a functor instantiation data ModuleInstanceArgs name = DefaultInstArg (Located (ModuleInstanceArg name))- -- ^ Single parameter instantitaion+ -- ^ Single parameter instantiations | DefaultInstAnonArg [TopDecl name]- -- ^ Single parameter instantitaion using this anonymous module.+ -- ^ Single parameter instantiations using this anonymous module. -- (parser only) | NamedInstArgs [ModuleInstanceNamedArg name]@@ -393,8 +433,8 @@ 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+ { sigImports :: [SigImport name]+ -- ^ Imports and interface parameters, in source order , sigTypeParams :: [ParameterType name] -- ^ Type parameters , sigConstraints :: [Located (Prop name)] -- ^ Constraints on the type parameters and type synonyms.@@ -403,6 +443,16 @@ , sigFunParams :: [ParameterFun name] -- ^ Value parameters } deriving (Show,Generic,NFData) +-- | An import in the preamble of an interface (signature).+data SigImport name =+ SigImport (Located (ImportG (ImpName name)))+ | SigIfaceImport (ModParam name)+ deriving (Show,Generic,NFData)++isSigIfaceImport :: SigImport name -> Bool+isSigIfaceImport (SigIfaceImport {}) = True+isSigIfaceImport _ = False+ -- | A constraint or type synonym declared in an interface. data SigDecl name = SigTySyn (TySyn name) (Maybe Text)@@ -433,7 +483,11 @@ {- ^ Filled in by the renamer. Maps the actual (value/type) parameter names to the names in the interface module. -}- } deriving (Eq,Show,Generic,NFData)+ , mpInst :: Maybe (ModuleInstanceArgs name)+ {- ^ Optional instantiation arguments (parser only).+ Used when importing a parameterized interface with inline arguments,+ e.g., @import interface J { M }@ or @import interface J where ...@ -}+ } deriving (Show,Generic,NFData) -- | An import declaration.@@ -707,11 +761,13 @@ { 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)+ , funDescrFromPropGuard :: Bool+ -- ^ This came from a prop guard alternative. Used in Renamer } deriving (Eq, Show, Generic, NFData, Functor) emptyFunDesc :: FunDesc n-emptyFunDesc = FunDesc Nothing 0+emptyFunDesc = FunDesc Nothing 0 False data UpdField n = UpdField UpdHow [Located Selector] (Expr n) -- ^ non-empty list @ x.y = e@@@ -963,10 +1019,10 @@ ppL = pp . thing ppNamed :: PP a => String -> Named a -> Doc-ppNamed s x = ppL (name x) <+> text s <+> pp (value x)+ppNamed s x = nest 1 (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+ppNamed' s (i,(_,v)) = nest 1 (pp i <+> text s </> pp v) @@ -982,27 +1038,35 @@ $$ indent 2 (vcat ["/* In scope:", indent 2 (pp (mInScope m)), " */"]) where kw' = case mDef m of- InterfaceModule {} -> "interface" <+> kw- _ -> kw+ InterfaceModule {} -> "interface" <+> kw+ FunctorInstance _ _ _ SignatureInst -> "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 ]+ FunctorInstance f as inst _kind ->+ vcat [ "=" <+> pp (thing f) <+> pp as+ , indent 2 (pp inst)+ ] InterfaceModule s -> ppInterface "where" s+ ModuleAlias t -> "=" <+> pp (thing t) +instance (Show name, PPName name) => PP (ModuleInstance name) where+ ppPrec _ inst+ | null imap && null psubs = mempty+ | otherwise = vcat ("/* Instance:" : instLines ++ psubLines ++ [" */"])+ where+ imap = modInstMap inst+ psubs = modInstVirtParamMods inst+ instLines = [ " *" <+> pp k <+> "->" <+> pp v+ | (k,v) <- Map.toList imap ]+ psubLines = [ " * param" <+> pp (vpmIdent s) <+> "->" <+> pp (vpmName s)+ | s <- psubs ]+ instance (Show name, PPName name) => PP (ModuleInstanceArgs name) where ppPrec _ arg = case arg of@@ -1019,7 +1083,7 @@ case arg of ModuleArg x -> pp x ParameterArg i -> "parameter" <+> pp i- AddParams -> "{}"+ AddParams -> "_" instance (Show name, PPName name) => PP (Program name) where@@ -1065,6 +1129,12 @@ ++ cs ++ map pp (sigFunParams sig) +instance (Show name, PPName name) => PP (SigImport name) where+ ppPrec p si =+ case si of+ SigImport li -> ppPrec p (thing li)+ SigIfaceImport mp -> ppPrec p mp+ instance (Show name, PPName name) => PP (SigDecl name) where ppPrec p decl = case decl of@@ -1143,7 +1213,7 @@ ppPrec _ c = pp (ecName c) <+> hsep (map (ppPrec 1) (ecFields c)) instance (PP mname) => PP (ImportG mname) where- ppPrec _ d = vcat [ text "import" <+> sep ([pp (iModule d)] ++ mbInst +++ ppPrec _ d = vcat [ text "import" <+> sep ([pp (thing (iModule d))] ++ mbInst ++ mbAs ++ mbSpec) , indent 2 mbWhere ]@@ -1221,7 +1291,13 @@ instance (Show name, PPName name) => PP (BindImpl name) where ppPrec p (DExpr e) = ppPrec p e- ppPrec _p (DPropGuards _guards) = text "propguards"+ ppPrec _p (DPropGuards guards) =+ text "propguards" $$ indent 2 (vcat (map pp guards))+ +instance (Show name, PPName name) => PP (PropGuardCase name) where+ ppPrec _ pg =+ parens (commaSep (map (pp . thing) (pgcProps pg))) <+>+ "=>" <+> pp (pgcExpr pg) instance PPName name => PP (TySyn name) where@@ -1355,8 +1431,11 @@ ESel e l -> ppPrec 4 e <.> text "." <.> pp l -- low prec- EFun _ xs e -> wrap n 0 ((text "\\" <.> hsep (map (ppPrec 3) xs)) <+>+ EFun d xs e -> wrap n 0 ((text "\\" <.> des <.> hsep (map (ppPrec 3) xs)) <+> text "->" </> pp e)+ where+ des = maybe mempty ppNm (funDescrName d)+ ppNm x = "/*" <.> pp x <.> (if funDescrFromPropGuard d then " prop-guard " else mempty) <.> "*/" EIf e1 e2 e3 -> wrap n 0 $ sep [ text "if" <+> pp e1 , text "then" <+> pp e2@@ -1366,7 +1445,7 @@ , nest 2 (vcat (map pp as)) ] - ETyped e t -> wrap n 0 (ppPrec 2 e <+> text ":" <+> pp t)+ ETyped e t -> wrap n 0 (ppPrec 2 e <+> text ":" </> pp t) EWhere e ds -> wrap n 0 $ align $ vsep [ pp e@@ -1401,6 +1480,9 @@ prefixText PrefixNeg = "-" prefixText PrefixComplement = "~" +instance (Show name, PP name) => PP (FunDesc name) where+ ppPrec _ fd = maybe mempty pp (funDescrName fd)+ instance (Show name, PPName name) => PP (CaseAlt name) where ppPrec _ (CaseAlt p e) = vcat [ pp p <+> "->", nest 2 (pp e) ] @@ -1467,9 +1549,9 @@ ppPrec n ty = case ty of TWild -> text "_"- TTuple ts -> parens $ commaSep $ map pp ts+ TTuple ts -> ppTuple $ map pp ts TTyApp fs -> braces $ commaSep $ map (ppNamed " = ") fs- TRecord fs -> braces $ commaSep $ map (ppNamed' ":") (displayFields fs)+ TRecord fs -> ppRecord $ map (ppNamed' ":") (displayFields fs) TBit -> text "Bit" TNum x -> integer x TChar x -> text (show x)@@ -1538,8 +1620,9 @@ noPos m = case m of NormalModule ds -> NormalModule (noPos ds)- FunctorInstance f as ds -> FunctorInstance (noPos f) (noPos as) ds+ FunctorInstance f as ds k -> FunctorInstance (noPos f) (noPos as) ds k InterfaceModule s -> InterfaceModule (noPos s)+ ModuleAlias t -> ModuleAlias (noPos t) instance NoPos (ModuleInstanceArgs name) where noPos as =@@ -1579,13 +1662,19 @@ DParameterConstraint d -> DParameterConstraint (noPos d) instance NoPos (Signature name) where- noPos sig = Signature { sigImports = sigImports sig+ noPos sig = Signature { sigImports = map noPos (sigImports sig) , sigTypeParams = map noPos (sigTypeParams sig) , sigDecls = map noPos (sigDecls sig) , sigConstraints = map noPos (sigConstraints sig) , sigFunParams = map noPos (sigFunParams sig) } +instance NoPos (SigImport name) where+ noPos si =+ case si of+ SigImport li -> SigImport li+ SigIfaceImport p -> SigIfaceImport (noPos p)+ instance NoPos (SigDecl name) where noPos decl = case decl of@@ -1598,6 +1687,7 @@ , mpName = mpName mp , mpDoc = mpDoc mp , mpRenaming = mpRenaming mp+ , mpInst = noPos (mpInst mp) } instance NoPos (PrimType name) where
src/Cryptol/Parser/ExpandPropGuards.hs view
@@ -76,6 +76,7 @@ NormalModule ds -> NormalModule . concat <$> mapM expandTopDecl ds FunctorInstance {} -> pure m InterfaceModule {} -> pure m+ ModuleAlias {} -> pure m expandTopDecl :: TopDecl PName -> ExpandPropGuardsM [TopDecl PName] expandTopDecl topDecl =@@ -133,6 +134,14 @@ Right (PosInst (TUser (Located loc (tpName tp)) []))) `traverse` tParams let e' = foldl EApp (EAppT (EVar $ thing bName') typeInsts) (patternToExpr <$> bindParams bind)+ let updatedDef x =+ case x of+ ELocated e1 l -> ELocated (updatedDef e1) l+ EWhere e'' ds -> EWhere (updatedDef e'') ds+ EFun desc xs y+ | Just {} <- funDescrName desc ->+ EFun desc { funDescrFromPropGuard = True } xs (updatedDef y)+ _ -> x pure ( PropGuardCase props' e', bind@@ -145,7 +154,7 @@ t rng }, -- keeps same location at original bind -- i.e. "on top of" original bind- bDef = (bDef bind) {thing = exprDef e}+ bDef = (bDef bind) {thing = exprDef (updatedDef e) } } ) (guards', binds') <- unzip <$> mapM goGuard guards
src/Cryptol/Parser/LexerUtils.hs view
@@ -6,7 +6,40 @@ -- Stability : provisional -- Portability : portable {-# LANGUAGE OverloadedStrings #-}-module Cryptol.Parser.LexerUtils where+module Cryptol.Parser.LexerUtils+ ( Config(..)+ , defaultConfig+ , Action+ , LexS(..)+ , startComment+ , endComment+ , addToComment+ , startEndComment+ , startString+ , endString+ , addToString+ , startChar+ , endChar+ , addToChar+ , mkIdent+ , mkQualIdent+ , mkQualOp+ , emit+ , emitS+ , emitFancy+ , splitQual+ , numToken+ , fromDigit+ , fnumTokens+ , isValidIdent+ , selectorToken+ , readDecimal+ , AlexInput(..)+ , alexGetByte+ , Layout(..)+ , dropWhite+ , byteForChar+ ) where import Control.Monad(guard) import Data.Char(toLower,generalCategory,isAscii,ord,isSpace,@@ -309,19 +342,26 @@ eBase = if rad == 10 then 10 else 2 :: Rational +++-- | Check if a name is a valid Cryptol identifier.+isValidIdent :: Text -> Bool+isValidIdent body =+ case T.uncons body of+ Just (x, xs) -> id_first x && T.all id_next xs+ Nothing -> False+ where+ id_first x = isAlpha x || x == '_'+ id_next x = isAlphaNum x || x == '_' || x == '\''+ -- 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)+ | isValidIdent body = 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
src/Cryptol/Parser/Name.hs view
@@ -121,8 +121,14 @@ where i = getIdent n - ppPrefixName n = optParens (isInfixIdent i) (pfx <.> pp i)+ ppPrefixName n =+ withPPCfg (\cfg ->+ let base = optParens (isInfixIdent i) (pfx <.> pp i)+ in if ppcfgShowNameUniques cfg then base <.> text sys else base) where+ sys = case n of+ UnQual' _ SystemName -> "/*sys*/"+ _ -> "" i = getIdent n pfx = case getModName n of Just ns -> pp ns <.> text "::"
src/Cryptol/Parser/NoInclude.hs view
@@ -195,8 +195,9 @@ noIncludeModule m = do newDef <- case mDef m of NormalModule ds -> NormalModule <$> doDecls ds- FunctorInstance f as is -> pure (FunctorInstance f as is)+ FunctorInstance f as is k -> pure (FunctorInstance f as is k) InterfaceModule s -> pure (InterfaceModule s)+ ModuleAlias t -> pure (ModuleAlias t) pure m { mDef = newDef } where doDecls = fmap concat . collectErrors noIncTopDecl
src/Cryptol/Parser/NoPat.hs view
@@ -221,7 +221,7 @@ -- 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+ let desc = FunDesc mnm offset False return (EFun desc [p'] body) noPatArm :: [Match PName] -> NoPatM [Match PName]@@ -386,8 +386,9 @@ do def <- case mDef m of NormalModule ds -> NormalModule <$> noPatTopDs ds- FunctorInstance f as i -> pure (FunctorInstance f as i)+ FunctorInstance f as i k -> pure (FunctorInstance f as i k) InterfaceModule s -> pure (InterfaceModule s)+ ModuleAlias t -> pure (ModuleAlias t) pure m { mDef = def } --------------------------------------------------------------------------------
src/Cryptol/Parser/ParserUtils.hs view
@@ -225,6 +225,18 @@ mkSchema :: [TParam PName] -> [Prop PName] -> Type PName -> Schema PName mkSchema xs ps t = Forall xs ps t Nothing +getTypeName :: Type PName -> ParseM LPName+getTypeName = check Nothing+ where+ check loc ty =+ case ty of+ TUser x [] | UnQual {} <- thing x -> pure x+ TLocated t r -> check (Just r) t+ _ ->+ case loc of+ Just r -> errorMessage r ["Expected a type name"]+ Nothing -> panic "getTypeName" ["Type without location"]+ getName :: Located Token -> PName getName l = case thing l of Token (Ident [] x) _ -> mkUnqual (mkIdent x)@@ -851,6 +863,77 @@ | null ps = mkGenerate (reverse ixs) body | otherwise = EFun emptyFunDesc (reverse ps) (mkGenerate (reverse ixs) body) +-- | Construct a record field by decomposing its expression-shaped left-hand+-- side into a field path, parameters, and indices. Parsing the left-hand side+-- as an expression lets the parser postpone deciding whether it is+--+-- { f x | ... } -- the head of a record update+-- { f x @ i = ... } -- the left-hand side of a record field+--+-- until it sees the delimiter.+mkRecField ::+ Expr PName ->+ UpdHow ->+ Expr PName ->+ ParseM (UpdField PName)+mkRecField lhs how body =+ do let (app, ixs0) = splitFieldIndices lhs+ (path, ps0) = splitFieldApp app+ sels <- exprToFieldPath path+ ps <- traverse exprAtomToIPat ps0+ ixs <- traverse exprAtomToIPat ixs0+ pure (UpdField how sels+ (mkIndexedExpr (reverse ps, reverse ixs) body))++-- | Split a left-associated chain of uses of the infix-at operator. The parser+-- represents operators as located 'EInfix' nodes until fixity resolution.+splitFieldIndices :: Expr PName -> (Expr PName, [Expr PName])+splitFieldIndices = go Nothing []+ where+ go mbLoc ixs expr =+ case expr of+ ELocated e r -> go (Just r) ixs e+ EInfix lhs op _ rhs+ | UnQual "@" <- thing op ->+ go mbLoc (rhs : ixs) lhs+ _ -> (at mbLoc expr, ixs)++-- | Split a left-associated expression application into its head and+-- arguments.+splitFieldApp :: Expr PName -> (Expr PName, [Expr PName])+splitFieldApp = go Nothing []+ where+ go mbLoc args expr =+ case expr of+ ELocated e r -> go (Just r) args e+ EApp f x -> go mbLoc (x : args) f+ _ -> (at mbLoc expr, args)++-- | Convert an expression atom back to the irrefutable pattern with the same+-- concrete syntax.+exprAtomToIPat :: Expr PName -> ParseM (Pattern PName)+exprAtomToIPat = go emptyRange+ where+ go :: Range -> Expr PName -> ParseM (Pattern PName)+ go loc expr =+ case expr of+ ELocated e r -> PLocated <$> go r e <*> pure r+ EParens e -> go loc e++ EVar n+ | UnQual "_" <- n -> pure PWild+ | otherwise -> pure (mkPVar (Located loc n))++ ETuple es -> PTuple <$> traverse (go loc) es+ ERecord fs -> PRecord <$> traverseRecordMap cvt fs+ where cvt _ (r,e) = (,) r <$> go r e+ EList es -> PList <$> traverse (go loc) es+ ETyped e t -> (`PTyped` t) <$> go loc e+ EInfix e1 op _ e2+ | UnQual "#" <- thing op -> PSplit <$> go loc e1 <*> go loc e2++ _ -> errorMessage loc ["Invalid parameter in record field."]+ mkGenerate :: [Pattern PName] -> Expr PName -> Expr PName mkGenerate pats body = foldr (\pat e -> EGenerate (EFun emptyFunDesc [pat] e)) body pats@@ -1179,7 +1262,7 @@ , "A workaround would be to do the instantion in the outer context." ] -mkInterface' :: [Located (ImportG (ImpName PName))] ->+mkInterface' :: [SigImport PName] -> [ParamDecl PName] -> Signature PName mkInterface' is = foldl' add@@ -1189,6 +1272,7 @@ , sigConstraints = [] , sigFunParams = [] }+ . reverse where add s d = case d of@@ -1199,11 +1283,13 @@ -mkInterface :: [Located (ImportG (ImpName PName))] ->+-- | The imports are in reverse order from the parser.+mkInterface :: [SigImport PName] -> [ParamDecl PName] -> ParseM (Signature PName) mkInterface is ps =- do onlySimpleImports is- pure (mkInterface' is ps)+ do let is' = reverse is+ onlySimpleImports [ li | SigImport li <- is' ]+ pure (mkInterface' is' ps) mkIfacePropSyn :: Maybe Text -> Decl PName -> ParamDecl PName mkIfacePropSyn mbDoc d =@@ -1240,7 +1326,7 @@ Module PName mkModuleInstanceAnon nm fun ds = Module { mName = nm- , mDef = FunctorInstance fun (DefaultInstAnonArg ds) mempty+ , mDef = FunctorInstance fun (DefaultInstAnonArg ds) emptyModuleInstance ModuleInst , mInScope = mempty , mDocTop = Nothing }@@ -1252,12 +1338,62 @@ Module PName mkModuleInstance m f as = Module { mName = m- , mDef = FunctorInstance f as emptyModuleInstance+ , mDef = FunctorInstance f as emptyModuleInstance ModuleInst , mInScope = mempty , mDocTop = Nothing } +mkModuleAlias :: Located ModName -> Located (ImpName PName) -> Module PName+mkModuleAlias nm target =+ Module { mName = nm+ , mDef = ModuleAlias target+ , mInScope = mempty+ , mDocTop = Nothing+ } +mkNestedIfaceAlias ::+ Maybe (Located Text) ->+ Located PName ->+ Located (ImpName PName) ->+ ParseM [TopDecl PName]+mkNestedIfaceAlias doc nm target =+ do nested <- mkNested (mkModuleAlias (fmap toModName nm) target)+ pure [exportModule doc nested]+ where+ toModName n = case n of+ UnQual i -> mkModName [identText i]+ _ -> panic "mkNestedIfaceAlias" ["Unexpected qualified name"]++-- | Nested interface functor instantiation+mkNestedIfaceInst ::+ Maybe (Located Text) ->+ Located PName ->+ Located (ImpName PName) ->+ ModuleInstanceArgs PName ->+ ParseM [TopDecl PName]+mkNestedIfaceInst doc nm fun as =+ do nested <- mkNested (mkIfaceInst Nothing (fmap toModName nm) fun as)+ pure [exportModule doc nested]+ where+ toModName n = case n of+ UnQual i -> mkModName [identText i]+ _ -> panic "mkNestedIfaceInst" ["Unexpected qualified name"]++-- | Interface functor instantiation+mkIfaceInst ::+ Maybe (Located Text) ->+ Located ModName ->+ Located (ImpName PName) ->+ ModuleInstanceArgs PName ->+ Module PName+mkIfaceInst doc nm fun as =+ Module { mName = nm+ , mDef = FunctorInstance fun as emptyModuleInstance SignatureInst+ , mInScope = mempty+ , mDocTop = doc+ }++ ufToNamed :: UpdField PName -> ParseM (Named (Expr PName)) ufToNamed (UpdField h ls e) = case (h,ls) of@@ -1381,12 +1517,53 @@ (Nothing, Nothing) -> pure Nothing +mkIfaceImport ::+ Maybe (Located Text) ->+ Located (ImpName PName) ->+ Maybe (ModuleInstanceArgs PName) ->+ Maybe (Located ModName) ->+ Maybe (Located [Decl PName]) ->+ ParseM (ModParam PName)+mkIfaceImport doc impName optInst mbAs optImportWhere =+ do inst <- getInst+ pure ModParam { mpSignature = impName+ , mpAs = thing <$> mbAs+ , mpName = mkModParamName impName mbAs+ , mpDoc = doc+ , mpRenaming = mempty+ , mpInst = inst+ }+ where+ getInst =+ case (optInst, optImportWhere) of+ (Just _, Just _) ->+ errorMessage (srcRange impName)+ [ "Invalid interface import instantiation."+ , "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 :: Maybe (Located Text) -> Module PName -> ParseM [Module PName] mkTopMods doc m =- do (m', ms) <- desugarMod m { mDocTop = doc }+ do case mDef m of+ ModuleAlias {} ->+ errorMessage (srcRange (mName m))+ ["Module aliases are only allowed inside other modules."]+ _ -> pure ()+ (m', ms) <- desugarMod m { mDocTop = doc } pure (ms ++ [m']) mkTopSig :: Maybe (Located Text) -> Located ModName -> Signature PName -> [Module PName]@@ -1430,7 +1607,7 @@ desugarMod mo = case mDef mo of - FunctorInstance f as _ | DefaultInstAnonArg lds <- as ->+ FunctorInstance f as _ k | DefaultInstAnonArg lds <- as -> do (ms,lds') <- desugarTopDs (mName mo) lds case ms of m : _ | InterfaceModule si <- mDef m@@ -1445,7 +1622,7 @@ pos = from (srcRange nm) nm = Located { srcRange = srcRange (mName mo), thing = i } as' = DefaultInstArg (ModuleArg . toImpName <$> nm)- pure ( mo { mDef = FunctorInstance f as' mempty }+ pure ( mo { mDef = FunctorInstance f as' emptyModuleInstance k } , [ Module { mName = nm , mDef = NormalModule lds'@@ -1461,80 +1638,77 @@ _ -> pure (mo, []) +data AnonParamBlock name =+ NoAnonParamBlock [Located (ImportG (ImpName name))]+ | HaveAnonParamBlock Range++ desugarTopDs :: MkAnon name => Located name -> [TopDecl PName] -> ParseM ([ModuleG name PName], [TopDecl PName])-desugarTopDs ownerName = go emptySig+desugarTopDs ownerName = go (NoAnonParamBlock []) 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 }+ addI i s =+ case s of+ NoAnonParamBlock is -> NoAnonParamBlock (i : is)+ HaveAnonParamBlock {} -> s - go sig ds =+ go anonPs ds = case ds of - []- | isEmpty sig -> pure ([],[])- | otherwise ->- do let nm = mkAnon AnonIfaceMod <$> ownerName- pure ( [ Module { mName = nm- , mDef = InterfaceModule sig- , mInScope = mempty- , mDocTop = Nothing- }- ]- , [ DModParam- ModParam- { mpSignature = toImpName <$> nm- , mpAs = Nothing- , mpName = mkModParamName (toImpName <$> nm)- Nothing- , mpDoc = Nothing- , mpRenaming = mempty- }- ]- )+ [] -> pure ([],[]) d : more -> let cont emit sig' = do (ms,ds') <- go sig' more pure (ms, emit ++ ds')+ contMods extraMs emit sig' =+ do (ms,ds') <- go sig' more+ pure (extraMs ++ ms, emit ++ ds') in case d of DImport i | ImpTop _ <- thing (iModule (thing i)) , Nothing <- iInst (thing i) ->- cont [d] (addI i sig)+ cont [d] (addI i anonPs) DImport i | Just inst <- iInst (thing i) -> do newDs <- desugarInstImport i inst- cont newDs sig+ cont newDs anonPs - DParamDecl _ ds' -> cont [] (jnSig ds' sig)+ DParamDecl rng ds' ->+ case anonPs of+ NoAnonParamBlock is ->+ let nm = mkAnon AnonIfaceMod <$> ownerName+ mo =+ Module { mName = nm+ , mDef = InterfaceModule ds' { sigImports = map SigImport (reverse is) }+ , mInScope = mempty+ , mDocTop = Nothing+ }+ imp =+ DModParam+ ModParam+ { mpSignature = toImpName <$> nm+ , mpAs = Nothing+ , mpName = mkModParamName (toImpName <$> nm) Nothing+ , mpDoc = Nothing+ , mpRenaming = mempty+ , mpInst = Nothing+ } + in contMods [mo] [imp] (HaveAnonParamBlock rng)+ HaveAnonParamBlock otherBlock ->+ errorMessage rng+ [ "Multiple `parameter` blocks.",+ " The other block is here: " ++ show (pp otherBlock)++ ]+ DModule tl | NestedModule mo <- tlValue tl -> do (mo', ms) <- desugarMod mo cont ([ DModule TopLevel@@ -1543,43 +1717,74 @@ , tlDoc = Nothing -- generated modules have no docstrings } | m <- ms] ++ [DModule tl { tlValue = NestedModule mo' }])- sig+ anonPs - _ -> cont [d] sig+ DModParam p+ | Just inst <- mpInst p ->+ do (newMs, newParam) <- desugarIfaceInst ownerName p inst+ contMods newMs [newParam] anonPs + _ -> cont [d] anonPs++desugarIfaceInst ::+ MkAnon name =>+ Located name ->+ ModParam PName ->+ ModuleInstanceArgs PName ->+ ParseM ([ModuleG name PName], TopDecl PName)+desugarIfaceInst ownerName p inst =+ do (iname, ms) <- desugarFunctorInst anonName (mpSignature p) inst SignatureInst+ let newParam = DModParam p+ { mpSignature = toImpName <$> iname+ , mpName = mkModParamName (toImpName <$> iname) Nothing+ , mpInst = Nothing+ }+ pure (ms, newParam)+ where+ pos = from (srcRange (mpSignature p))+ anonName = mkAnon (AnonArg (line pos) (col pos)) <$> ownerName+ desugarInstImport :: Located (ImportG (ImpName PName)) {- ^ The import -} ->- ModuleInstanceArgs PName {- ^ The insantiation -} ->+ ModuleInstanceArgs PName {- ^ The instantiation -} -> ParseM [TopDecl PName] desugarInstImport i inst =- do (m, ms) <- desugarMod- Module { mName = iname- , mDef = FunctorInstance- origMod inst emptyModuleInstance- , mInScope = mempty- , mDocTop = Nothing- }- pure (DImport (newImp <$> i) : map modTop (ms ++ [m]))-+ do (iname, ms) <- desugarFunctorInst anonName origMod inst ModuleInst+ pure (map modTop ms ++ [DImport (newImp iname <$> i)]) where origMod = iModule (thing i) - iname = Located {- thing = mkUnqualSystem- $ let pos = from (srcRange i)- in identAnonInstImport (line pos) (col pos),- srcRange = srcRange origMod- }- + anonName = Located+ { thing = mkUnqualSystem+ $ let pos = from (srcRange i)+ in identAnonInstImport (line pos) (col pos)+ , srcRange = srcRange origMod+ } - newImp d = d { iModule = ImpNested <$> iname- , iInst = Nothing- }+ newImp nm d = d { iModule = ImpNested <$> nm+ , iInst = Nothing+ } modTop m = DModule TopLevel- { tlExport = Private- , tlDoc = Nothing- , tlValue = NestedModule m- }-+ { tlExport = Private+ , tlDoc = Nothing+ , tlValue = NestedModule m+ } +-- | Create an anonymous functor instantiation module, desugar it,+-- and return the generated name and all resulting modules.+desugarFunctorInst ::+ MkAnon name =>+ Located name {- ^ Anonymous module name -} ->+ Located (ImpName PName) {- ^ The functor to instantiate -} ->+ ModuleInstanceArgs PName {- ^ The instantiation arguments -} ->+ FunctorInstKind {- ^ Module or signature instantiation -} ->+ ParseM (Located name, [ModuleG name PName])+desugarFunctorInst iname functor inst kind =+ do (mo, ms) <- desugarMod+ Module { mName = iname+ , mDef = FunctorInstance functor inst emptyModuleInstance kind+ , mInScope = mempty+ , mDocTop = Nothing+ }+ pure (iname, ms ++ [mo])
src/Cryptol/REPL/Command.hs view
@@ -29,6 +29,7 @@ , emptyCommandResult , moduleCmd, loadCmd, loadPrelude, setOptionCmd+ , evalDeclBlock -- Parsing , interactiveConfig@@ -97,7 +98,8 @@ import Cryptol.Testing.Random import qualified Cryptol.Testing.Random as TestR import Cryptol.Parser- (parseExprWith,parseReplWith,ParseError(),Config(..),defaultConfig+ (parseExprWith,parseReplWith,parseDeclsWith,ParseError()+ ,Config(..),defaultConfig ,parseModName,parseHelpName,parseImpName) import Cryptol.Parser.Position (replPosition,startOfLine,Range(..),HasLoc(..)) import qualified Cryptol.TypeCheck.AST as T@@ -342,7 +344,16 @@ "" , CommandDescr [ ":l", ":load" ] ["FILE"] (FilenameArg loadCmd) "Load a module by filename."- ""+ (unlines+ [ "When FILE's path ends in directories that match the hierarchical"+ , "module name (e.g., some/where/A/B/M.cry for module A::B::M),"+ , "Cryptol temporarily prepends the containing directory to the"+ , "module search path while loading, so imports resolve to sibling"+ , "modules. When the path does not match the module name, Cryptol"+ , "prints a warning and leaves the search path unchanged; imports"+ , "may then fail unless the search path already covers them (see"+ , ":set path or the CRYPTOLPATH environment variable)."+ ]) , CommandDescr [ ":r", ":reload" ] [] (NoArg reloadCmd) "Reload the currently loaded module." ""@@ -392,6 +403,16 @@ (ModNameArg (moduleInfoCmd False)) "Show information about the dependencies of a module" ""++ , CommandDescr [ ":{" ] [] (NoArg openDefBlockCmd)+ "Begin a multi-line definition block."+ (unlines [+ "The following lines may declare functions in standard Cryptol notation",+ "The block is terminated with `:}` on its own line." ])++ , CommandDescr [ ":}" ] [] (NoArg closeDefBlockCmd)+ "End a multi-line definition block started with `:{`."+ "This command is only meaningful as the terminator of a `:{` block." ] genHelp :: [CommandDescr] -> [String]@@ -410,7 +431,9 @@ runCommand :: Int -> Maybe FilePath -> Command -> REPL CommandResult runCommand lineNum mbBatch c = case c of - Command cmd -> cmd lineNum mbBatch `Cryptol.REPL.Monad.catch` handler+ Command cmd ->+ rethrowTCSolverTimeout (cmd lineNum mbBatch)+ `Cryptol.REPL.Monad.catch` handler where handler re = do rPutStrLn ""@@ -463,6 +486,47 @@ rPrint (pp e) pure emptyCommandResult { crSuccess = False } ++{- | Reachable only if a @:{@ line is not intercepted by the input+reader (e.g. @:help :{@ dispatch, or non-standard input paths).+Explain the intended usage. -}+openDefBlockCmd :: REPL CommandResult+openDefBlockCmd =+ do rPutStrLn "[error] `:{` must appear alone on its line; see `:help :{`."+ pure emptyCommandResult { crSuccess = False }++{- | Reachable when @:}@ appears outside of a @:{@ block. Report the+error and continue. -}+closeDefBlockCmd :: REPL CommandResult+closeDefBlockCmd =+ do rPutStrLn "[error] `:}` outside of a `:{` block; see `:help :{`."+ pure emptyCommandResult { crSuccess = False }+++{- | Process the body of a @:{@ ... @:}@ definition block. The block+consists of the lines strictly between the delimiters (which are not+included). The @startLine@ argument is the REPL/file line number of the+first body line, so that parse errors carry the correct source position. -}+evalDeclBlock :: Int -> [String] -> Maybe FilePath -> REPL CommandResult+evalDeclBlock startLine ls mbBatch =+ do let str = unlines ls+ cfg = case mbBatch of+ Nothing -> interactiveConfig { cfgStart = startOfLine startLine }+ Just f -> defaultConfig+ { cfgSource = f+ , cfgStart = startOfLine startLine+ }+ ds <- replParse (parseDeclsWith cfg . T.pack) str+ case ds of+ [] -> pure emptyCommandResult+ _ -> do replEvalDecls ds+ pure emptyCommandResult+ `catch` \e -> do+ rPutStrLn ""+ rPrint (pp e)+ pure emptyCommandResult { crSuccess = False }++ printCounterexample :: CounterExampleType -> Doc -> [Concrete.Value] -> REPL () printCounterexample cexTy exprDoc vs = do ppOpts <- getPPValOpts@@ -781,7 +845,7 @@ -- | Attempts to prove the given term is safe for all inputs safeCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL CommandResult --- Throw error when no argument is passed to a command expecting one-safeCmd "" _pos _fnm = +safeCmd "" _pos _fnm = do rPutStrLn $ invalidCommandArgument ":safe" return emptyCommandResult {crSuccess = False} @@ -1112,7 +1176,7 @@ specializeCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL CommandResult --- Throw error when no argument is passed to a command expecting one-specializeCmd "" _pos _fnm = +specializeCmd "" _pos _fnm = do rPutStrLn $ invalidCommandArgument ":debug_specialize" return emptyCommandResult {crSuccess = False} @@ -1131,7 +1195,7 @@ refEvalCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL CommandResult --- Throw error when no argument is passed to a command expecting one-refEvalCmd "" _pos _fnm = +refEvalCmd "" _pos _fnm = do rPutStrLn $ invalidCommandArgument ":eval" return emptyCommandResult {crSuccess = False} @@ -1148,7 +1212,7 @@ astOfCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL CommandResult --- Throw error when no argument is passed to a command expecting one-astOfCmd "" _pos _fnm = +astOfCmd "" _pos _fnm = do rPutStrLn $ invalidCommandArgument ":ast" return emptyCommandResult {crSuccess = False} @@ -1167,7 +1231,7 @@ typeOfCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL CommandResult --- Throw error when no argument is passed to a command expecting one-typeOfCmd "" _pos _fnm = +typeOfCmd "" _pos _fnm = do rPutStrLn $ invalidCommandArgument ":type" return emptyCommandResult {crSuccess = False} @@ -1180,7 +1244,7 @@ whenDebug (rPutStrLn (dump def)) --- Get module context parameters- modCtxtParams <- M.mctxParams <$> getFocusedEnv + modCtxtParams <- M.mctxParams <$> getFocusedEnv --- Get the map that maps variable names to module type parameters let modParamMap = T.mpnTypes (M.modContextParamNames modCtxtParams) --- Get a list of type parameters from all module type parameterss in the Map@@ -1189,7 +1253,7 @@ cfg = defaultPPCfg --- Load module type param into a new empty NameMap ns = T.addTNames cfg modTParams emptyNameMap- --- Create a pretty printed string + --- Create a pretty printed string ppAll = ppWithNames ns sig fDisp <- M.mctxNameDisp <$> getFocusedEnv@@ -1202,7 +1266,7 @@ timeCmd :: String -> (Int, Int) -> Maybe FilePath -> REPL CommandResult --- Throw error when no argument is passed to a command expecting one-timeCmd "" _pos _fnm = +timeCmd "" _pos _fnm = do rPutStrLn $ invalidCommandArgument ":time" return emptyCommandResult {crSuccess = False} @@ -1612,7 +1676,7 @@ -- XXX this should probably do something a bit more specific. handleCtrlC :: a -> REPL a handleCtrlC a = do rPutStrLn "Ctrl-C"- resetTCSolver+ killTCSolver return a -- Utilities -------------------------------------------------------------------@@ -1737,6 +1801,11 @@ , P.tlValue = d } (names,ds',tyMap) <- liftModuleCmd (M.checkDecls (map mkTop npds)) + -- Check if the declarations depend on definitions from a parameterized+ -- module. If they do, make sure to error out here *before* adding the+ -- declarations' names to the environments (as is done immediately below).+ validEvalContext ds'+ -- extend the naming env and type synonym maps denv <- getDynEnv setDynEnv denv { M.deNames = names `M.shadowing` M.deNames denv@@ -1877,7 +1946,6 @@ 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) @@ -1979,9 +2047,9 @@ -- | Construct a helpful error message for commad parse errors where -- a cryptol command is not given expression arg when its expecting one. invalidCommandArgument :: String -> String-invalidCommandArgument cmd = concat ["ERROR: Command `", cmd - , "` needs an EXPR argument. See `:help " - , cmd, "` for more details."] +invalidCommandArgument cmd = concat ["ERROR: Command `", cmd+ , "` needs an EXPR argument. See `:help "+ , cmd, "` for more details."] -- | Parse a line as a command. parseCommand :: (String -> [CommandDescr]) -> String -> Maybe Command@@ -2072,11 +2140,11 @@ } printBlock :: [T.Text] -> REPL ()-printBlock block = +printBlock block = mapM_ printLine (continuedLines block) printLine :: T.Text -> REPL ()-printLine line +printLine line | T.all isSpace line = pure () | otherwise = case parseCommand (findNbCommand True) (T.unpack line) of@@ -2103,7 +2171,7 @@ do let tab n = replicate n ' ' rPutStrLn (tab 4 ++ T.unpack line) let doErr msg =- do rPutStrLn (tab 6 ++ msg) + do rPutStrLn (tab 6 ++ msg) pure [SubcommandResult { srInput = line , srLog = msg@@ -2174,8 +2242,8 @@ ['\n'] -> "\n" '\n' : more -> '\n' : tab ++ postTab more c : more -> c : postTab more- + -- | Apply control character semantics to the result of the logger interpretControls :: String -> String interpretControls = f []@@ -2307,7 +2375,7 @@ Nothing -> case M.lookupSignature mn env of Nothing ->- do rPutStrLn (tab ++ "Module " ++ show mn ++ " is not loaded")+ do rPutStrLn (tab ++ "Module " ++ show (pp mn) ++ " is not loaded") kNo emptyCommandResult { crSuccess = False } Just{} -> do rPutStrLn (tab ++ "Skipping docstrings on interface module")@@ -2409,11 +2477,11 @@ let fpAcc' = Map.adjust (\e -> e{ Proj.cacheDocstringResult = Nothing }) (Proj.CacheInFile path) fpAcc pure (fpAcc', (path, m) : needCheck, success) _ ->- do + do rPrint ("Checking module" <+> hcat [pp name, ": FAIL (cached)"]) let fpAcc' = Map.adjust (\e -> e{ Proj.cacheDocstringResult = Just False }) (Proj.CacheInFile path) fpAcc pure (fpAcc', needCheck, False) -- preserve fail- + Nothing -> pure (fpAcc', newNeedCheck, success) where fpAcc' = Map.adjust (\e -> e{ Proj.cacheDocstringResult = Nothing }) (Proj.CacheInFile path) fpAcc@@ -2421,10 +2489,10 @@ case mode of Proj.ModifiedMode -> needCheck _ -> (path, m) : needCheck- + Proj.Scanned Proj.Changed _ ms -> pure (fpAcc', reverse pms ++ needCheck_, success_) where pms = [ (path, m) | (m, _) <- ms ]- fpAcc' = Map.adjust (\e -> e{ Proj.cacheDocstringResult = Nothing }) (Proj.CacheInFile path) fpAcc_ + fpAcc' = Map.adjust (\e -> e{ Proj.cacheDocstringResult = Nothing }) (Proj.CacheInFile path) fpAcc_ -- | Get the path to the SAW command. -- Search options, in order:
src/Cryptol/REPL/Help.hs view
@@ -190,6 +190,12 @@ , " ", "and exports:" , indent 2 $ vcat [ ppTPs, ppFPs ] ]+ M.AnIfaceFunctor ->+ vcat [ "Parameterized interface" <+> pp name <+> "requires:"+ , indent 2 $ ppPs+ , " ", "and exports:"+ , indent 2 $ vcat [ ppTPs, ppCtrs, ppFPs ]+ ] doShowDocString doc
src/Cryptol/REPL/Monad.hs view
@@ -34,6 +34,7 @@ -- ** Errors , REPLException(..) , rethrowEvalError+ , rethrowTCSolverTimeout -- ** Environment , getFocusedEnv@@ -42,6 +43,7 @@ , getCallStacks , getTCSolver , resetTCSolver+ , killTCSolver , uniqify, freshName , whenDebug , getEvalOptsAction@@ -371,6 +373,7 @@ | SBVException SBVException | SBVPortfolioException SBVPortfolioException | W4Exception W4Exception+ | TCSolverTimedOut Int deriving (Show,Typeable) instance X.Exception REPLException@@ -406,6 +409,9 @@ SBVException e -> text "SBV exception:" $$ text (show e) SBVPortfolioException e -> text "SBV exception:" $$ text (show e) W4Exception e -> text "What4 exception:" $$ text (show e)+ TCSolverTimedOut seconds ->+ "Typechecking timed out after" <+> int seconds <+>+ if seconds == 1 then "second." else "seconds." -- | Raise an exception. raise :: REPLException -> REPL a@@ -441,7 +447,13 @@ rethrowUnsupported :: Unsupported -> IO a rethrowUnsupported exn = X.throwIO (Unsupported exn) +rethrowTCSolverTimeout :: REPL a -> REPL a+rethrowTCSolverTimeout m =+ REPL $ \ref ->+ unREPL m ref `X.catch` \(SMT.SolverTimeout seconds) ->+ unREPL (raise (TCSolverTimedOut seconds)) ref + -- Primitives ------------------------------------------------------------------ @@ -493,6 +505,15 @@ do io (SMT.stopSolver s) modifyRW_ (\rw -> rw{ eTCSolver = Nothing }) +killTCSolver :: REPL ()+killTCSolver =+ do mtc <- eTCSolver <$> getRW+ case mtc of+ Nothing -> return ()+ Just s ->+ do io (SMT.killSolver s)+ modifyRW_ (\rw -> rw{ eTCSolver = Nothing })+ -- Get the setting we should use for displaying values. getPPValOpts :: REPL PPOpts getPPValOpts =@@ -994,7 +1015,7 @@ insert m d = foldl (\m' n -> insertTrie n d m') m (optAliases d) userOptions :: OptionMap-userOptions = mkOptionMap+userOptions = mkOptionMap $ [ simpleOpt "base" [] (EnvNum 16) checkBase "The base to display words at (2, 8, 10, or 16)." , simpleOpt "debug" [] (EnvBool False) noCheck@@ -1056,6 +1077,17 @@ resetTCSolver _ -> return () + , OptionDescr "tcTimeout" ["tc-timeout"] (EnvNum 5)+ (checkTimeout "tc-timeout")+ "Specify timeout in seconds for typechecker SMT queries." $+ \case EnvNum n -> do changed <- modifyRW (\rw -> ( rw{ eTCConfig = (eTCConfig rw)+ { T.solverTimeout = n+ }}+ , n /= T.solverTimeout (eTCConfig rw)+ ))+ when changed resetTCSolver+ _ -> return ()+ , OptionDescr "tcDebug" ["tc-debug"] (EnvNum 0) noCheck (unlines@@ -1103,7 +1135,8 @@ , simpleOpt "proverStats" ["prover-stats"] (EnvBool True) noCheck "Enable prover timing statistics." - , simpleOpt "proverTimeout" ["prover-timeout"] (EnvNum 0) checkTimeout+ , simpleOpt "proverTimeout" ["prover-timeout"] (EnvNum 0)+ (checkTimeout "prover-timeout") "Specify timeout in seconds for online prover processes." , simpleOpt "proverValidate" ["prover-validate"] (EnvBool False) noCheck@@ -1149,7 +1182,38 @@ , simpleOpt "sawFlags" ["saw-flags"] (EnvString "-v 0") noCheck "Flags for all calls to SAW."+ ] ++ debugDumpOpts++debugDumpOpts :: [OptionDescr]+debugDumpOpts =+ opt "debugDumpPrelude"+ "Indicates if we should `dbg-dump-` for `Cryptol.cry`"+ (\b o -> o { M.dbgIncludePrelude = b })+ :+ [ opt ("debugDump_" ++ show n ++ "_" ++ nm)+ (passHelp pass)+ (\b o -> o { M.dbgDumpAfter = upd b pass (M.dbgDumpAfter o) })+ | (n,pass) <- [1 :: Int ..] `zip` [ minBound .. maxBound ]+ , let nm = drop 4 (show pass) ]+ where+ opt x msg k = OptionDescr x [] (EnvBool False) noCheck msg $+ \case+ EnvBool b -> setIt (k b)+ _ -> pure ()+ upd b = if b then Set.insert else Set.delete+ setIt f =+ do + me <- getModuleEnv+ setModuleEnv me { M.meDebugOpts = f (M.meDebugOpts me) }+ passHelp p =+ case p of+ M.PassParser -> "The AST produced by the parser"+ M.PassNoPat -> "The AST after some desugaring (e.g., eliminate patterns)"+ M.PassPropGuards -> "AST with simplified prop. guards"+ M.PassRename -> "The AST with resolve names"+ M.PassTC -> "Typechecked AST (this is different to the parsed one)"+ M.PassREW -> "Typechecked AST with some simplifying rewrites" parsePPFloatFormat :: String -> Maybe PPFloatFormat@@ -1178,13 +1242,13 @@ parseFieldOrder "display" = Just DisplayOrder parseFieldOrder _ = Nothing -checkTimeout :: Checker-checkTimeout val =+checkTimeout :: String -> Checker+checkTimeout option val = case val of EnvNum n | n < 0 -> noWarns (Just "timeout should be non-negative") | otherwise -> noWarns Nothing- _ -> noWarns (Just "Failed to parse `prover-timeout`")+ _ -> noWarns (Just ("Failed to parse `" ++ option ++ "`")) checkFieldOrder :: Checker checkFieldOrder val =
src/Cryptol/Symbolic.hs view
@@ -66,7 +66,8 @@ import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Solver.InfNat import Cryptol.Eval.Type- (TValue(..), TNominalTypeValue(..), evalType,tValTy,tNumValTy,ConInfo(..))+ ( ConInfo(..), TValue(..), TNominalTypeValue(..)+ , enumTagWidth, evalType, tValTy, tNumValTy ) import Cryptol.Utils.Ident (Ident,prelPrim,floatPrim) import Cryptol.Utils.RecordMap import Cryptol.Utils.Panic@@ -127,7 +128,7 @@ predArgTypes :: QueryType -> Schema -> Either Doc [FinType] predArgTypes qtype schema@(Forall ts ps ty)- | null ts && null ps =+ | null ts && all pIsTrue ps = -- We could have `True` constraints due to module instantiations (see #1576) case evalType mempty ty of Left _ -> Left "Predicate needs to be of kind *" Right tval ->@@ -182,7 +183,7 @@ TVSeq n t -> FTSeq n <$> doSub 0 (finType t) TVTuple ts -> FTTuple <$> zipWithM doSub [ 0 .. ] (map finType ts) TVRec fields -> FTRecord <$> doFields fields- where + where TVNominal u ts nv -> setHere $ FTNominal u ts <$> case nv of TVStruct body -> FStruct <$> traverse finType body@@ -248,7 +249,8 @@ | VarFinSeq Integer [VarShape sym] | VarTuple [VarShape sym] | VarRecord (RecordMap Ident (VarShape sym))- | VarEnum (SInteger sym) (Vector (ConInfo (VarShape sym)))+ | VarEnum (SWord sym) (Vector (ConInfo (VarShape sym)))+ -- See Note [Represent enum tags as words] in Cryptol.Eval.Value ppVarShape :: Backend sym => sym -> VarShape sym -> Doc ppVarShape _sym (VarBit _b) = text "<bit>"@@ -309,7 +311,9 @@ data FreshVarFns sym = FreshVarFns { freshBitVar :: IO (SBit sym)- , freshWordVar :: Integer -> IO (SWord sym)+ -- | The @Maybe Integer@ field is an optional upper bound.+ , freshWordVar :: Integer -> Maybe Integer -> IO (SWord sym)+ -- | The @Maybe Integer@ fields are optional lower and upper bounds. , freshIntegerVar :: Maybe Integer -> Maybe Integer -> IO (SInteger sym) , freshFloatVar :: Integer -> Integer -> IO (SFloat sym) }@@ -325,7 +329,7 @@ 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 FTBit -> VarWord <$> freshWordVar fns (toInteger n) Nothing 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@@ -334,7 +338,7 @@ FStruct fs -> VarRecord <$> traverse (freshVar fns) fs FEnum conTs -> do let maxCon = toInteger (Vector.length conTs - 1)- tag <- freshIntegerVar fns (Just 0) (Just maxCon)+ tag <- freshWordVar fns (enumTagWidth conTs) (Just maxCon) cons <- traverse (traverse (freshVar fns)) conTs pure (VarEnum tag cons) @@ -392,9 +396,9 @@ (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)- (VarEnum vi vcons, VarEnum i cons) ->- do tag <- integerLit sym i- sameTag <- intEq sym tag vi+ (VarEnum vi vcons, VarEnum (Concrete.BV w i) cons) ->+ do tag <- wordLit sym w i+ sameTag <- wordEq sym tag vi let i' = fromInteger i flds = Vector.toList . conFields sameFs <- case (vcons Vector.!? i', cons Vector.!? i') of@@ -428,7 +432,7 @@ f = foldl (\x t -> ETApp x (tNumValTy t)) (EVar con) ts in EApp f (ERec efs) - (FTNominal nt ts (FEnum cons), VarEnum tag conVs) ->+ (FTNominal nt ts (FEnum cons), VarEnum (Concrete.BV _ tag) conVs) -> foldl EApp conName args where tag' = fromInteger tag
src/Cryptol/Symbolic/SBV.hs view
@@ -16,6 +16,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeApplications #-} module Cryptol.Symbolic.SBV ( SBVProverConfig@@ -44,7 +45,7 @@ import LibBF(bfNaN) import qualified Data.SBV as SBV (sObserve, symbolicEnv, SMTReasonUnknown (..))-import qualified Data.SBV.Internals as SBV (SBV(..))+import qualified Data.SBV.Internals as SBV (SBV(..), SMTModel(..)) import qualified Data.SBV.Dynamic as SBV import qualified Data.SBV.Trans.Control as SBV (SMTOption(..)) import Data.SBV (Timing(SaveTiming))@@ -451,13 +452,17 @@ -- "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)+ SBV.sObserve safetyObservableName (SBV.SBV safety' :: SBV.SBV Bool) -- read any definitional relations that were asserted defRels <- liftIO (readMVar defRelsVar) return (addAsm defRels (SBV.svAnd safety' b))) +-- | A distinguished name to use when observing the safety predicate.+safetyObservableName :: String+safetyObservableName = "safety"+ -- | 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 ::@@ -476,13 +481,13 @@ 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+ (SBV.Satisfiable {} : _) | isSat, Just ms <- allSatResults -> do+ tevss <- map snd <$> mapM (mkTevs prims) ms return $ AllSatResult tevss -- prove should only have one counterexample- [r@SBV.Satisfiable{}] -> do- (safety, res) <- mkTevs prims r+ [SBV.Satisfiable _ m] -> do+ (safety, res) <- mkTevs prims m let cexType = if safety then PredicateFalsified else SafetyViolation return $ CounterExample cexType res @@ -506,14 +511,41 @@ | otherwise = show $ SBV.ThmResult resultsHead 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+ -- | If all of the 'SBV.SMTResult's are 'SBV.Satisfiable', return the+ -- underlying 'SBV.SMTModel's. Otherwise, return 'Nothing'.+ allSatResults :: Maybe [SBV.SMTModel]+ allSatResults =+ traverse+ (\case SBV.Satisfiable _ m -> Just m+ _ -> Nothing)+ results++ mkTevs ::+ PrimMap ->+ SBV.SMTModel ->+ M.ModuleT IO (Bool, [(TValue, Expr, Concrete.Value)])+ mkTevs prims m = do+ -- Look for a CV in the SMTModel's modelAssocs with a name matching the+ -- safety predicate. Note that it is not safe to assume that the safety+ -- predicate will appear in a particular order in this list. Not only is+ -- this considered an implementation detail, different SBV versions use+ -- different conventions+ -- (see https://github.com/LeventErkok/sbv/issues/779), so it is important+ -- to be able to handle any convention.+ let mAssocs = SBV.modelAssocs m+ let (nonSafetyAssocs1, otherAssocs) =+ break (\(name, _) -> name == safetyObservableName) mAssocs+ (safetyCV, cvs) <-+ case otherAssocs of+ (_, safetyCV):nonSafetyAssocs2 ->+ pure (safetyCV, map snd (nonSafetyAssocs1 ++ nonSafetyAssocs2))+ [] ->+ panic+ "processResults"+ [ "Model did not contain safety predicate:"+ , show mAssocs+ ]+ let safety = SBV.cvToBool safetyCV (vs, _) = parseValues ts cvs mdl = computeModel prims ts vs return (safety, mdl)@@ -622,12 +654,14 @@ FStruct r -> parseValue (FTRecord r) cvs FEnum cons -> fromMaybe (panic "Cryptol.Symbolic.parseValue" ["no enum"]) $- do (tag, cvs') <- SBV.genParse SBV.KUnbounded cvs+ do let tagWidth = enumTagWidth cons+ (tag, cvs') <-+ SBV.genParse (SBV.KBounded False (fromInteger @Int tagWidth)) cvs let doCon input con = case parseValues (Vector.toList (conFields con)) input of (vs,input') -> (input', con { conFields = Vector.fromList vs }) (input3, conVs) = mapAccumL doCon cvs' cons- pure (VarEnum tag conVs, input3)+ pure (VarEnum (Concrete.BV tagWidth tag) conVs, input3) parseValue (FTFloat e p) cvs = (VarFloat FH.BF { FH.bfValue = bfNaN@@ -650,10 +684,16 @@ Nothing -> pure () return x -freshBitvector :: SBV -> Integer -> IO SBV.SVal-freshBitvector sym w+freshBitvector :: SBV -> Integer -> Maybe Integer -> IO SBV.SVal+freshBitvector sym w hi | w == 0 = pure (SBV.svInteger (SBV.KBounded False 0) 0)- | otherwise = freshBV_ sym (fromInteger w)+ | otherwise =+ do let w' = fromInteger @Int w+ x <- freshBV_ sym w'+ case hi of+ Just h -> addDefEqn sym (SBV.svLessEq x (SBV.svInteger (SBV.KBounded False w') h))+ Nothing -> pure ()+ pure x sbvFreshFns :: SBV -> FreshVarFns SBV sbvFreshFns sym =
src/Cryptol/Symbolic/What4.hs view
@@ -150,8 +150,8 @@ -- | Wraps a 'W4.ConfigOption' to provide a consistent interface for setting -- solver goal timeouts (see 'configTimeoutMilliSeconds', 'configTimeoutSeconds', 'setConfigTimeout').-data ConfigTimeout = - ConfigTimeout +data ConfigTimeout =+ ConfigTimeout (W4.ConfigOption W4.BaseIntegerType) -- | Translate a 'W4.SolverGoalTimeout' into the integer backing this config option. (W4.SolverGoalTimeout -> Integer)@@ -162,19 +162,19 @@ configTimeoutMilliSeconds opt = ConfigTimeout opt W4.getGoalTimeoutInMilliSeconds -- | Construct a 'ConfigTimeout' from a 'W4.ConfigOption', where the given--- option configures a solver-specific timeout measured in seconds. --- Rounds up to at least 1 second when setting a non-zero timeout +-- option configures a solver-specific timeout measured in seconds.+-- Rounds up to at least 1 second when setting a non-zero timeout -- (see 'W4.getGoalTimeoutInSeconds'). configTimeoutSeconds :: W4.ConfigOption W4.BaseIntegerType -> ConfigTimeout configTimeoutSeconds opt = ConfigTimeout opt W4.getGoalTimeoutInSeconds -setConfigTimeout :: +setConfigTimeout :: W4.IsExprBuilder sym => ConfigTimeout -> W4.SolverGoalTimeout -> sym -> IO ()-setConfigTimeout (ConfigTimeout opt toOpt) t sym = +setConfigTimeout (ConfigTimeout opt toOpt) t sym = do optSetting <- W4.getOptionSetting opt (W4.getConfiguration sym) _ <- W4.trySetOpt optSetting (toOpt t) pure ()@@ -340,13 +340,29 @@ setupAnAdapter (AnOnlineAdapter _n _fs opts _ _p) = W4.extendConfig opts (W4.getConfiguration sym) -what4FreshFns :: W4.IsSymExprBuilder sym => sym -> FreshVarFns (What4 sym)+freshBV ::+ W4.IsSymExprBuilder sym =>+ What4 sym ->+ Integer ->+ Maybe Integer ->+ IO (SW.SWord sym)+freshBV sym w hi =+ do x <- SW.freshBV (w4 sym) W4.emptySymbol w+ case hi of+ Just h ->+ do sh <- SW.bvLit (w4 sym) w h+ p <- SW.bvule (w4 sym) x sh+ addDefEqn sym p+ Nothing -> pure ()+ pure x++what4FreshFns :: W4.IsSymExprBuilder sym => What4 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+ { freshBitVar = W4.freshConstant (w4 sym) W4.emptySymbol W4.BaseBoolRepr+ , freshWordVar = freshBV sym+ , freshIntegerVar = W4.freshBoundedInt (w4 sym) W4.emptySymbol+ , freshFloatVar = W4.fpFresh (w4 sym) } -- | Simulate and manipulate query into a form suitable to be sent@@ -363,7 +379,7 @@ case predArgTypes pcQueryType pcSchema of Left msg -> pure (Left msg) Right ts ->- do args <- liftIO (mapM (freshVar (what4FreshFns (w4 sym))) ts)+ do args <- liftIO (mapM (freshVar (what4FreshFns sym)) ts) (safety,b) <- simulate ntEnv args liftIO do -- Ignore the safety condition if the flag is set@@ -782,18 +798,17 @@ snd <$> doW4Eval (w4 sym) (varModelPred sym (v, c)) varShapeToConcrete ::+ forall sym t fm.+ sym ~ W4.ExprBuilder t CryptolState fm => W4.GroundEvalFn t ->- VarShape (What4 (W4.ExprBuilder t CryptolState fm)) ->+ VarShape (What4 sym) -> 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+ VarWord w -> VarWord <$> sWordToConcrete w VarFloat fv@(W4.SFloat f) -> let (e,p) = W4.fpSize fv in VarFloat . FH.BF e p <$> W4.groundEval evalFn f@@ -804,10 +819,16 @@ VarRecord fs -> VarRecord <$> traverse (varShapeToConcrete evalFn) fs VarEnum tag cons ->- VarEnum <$> W4.groundEval evalFn tag+ VarEnum <$> sWordToConcrete tag <*> traverse (traverse (varShapeToConcrete evalFn)) cons+ where+ sWordToConcrete :: SW.SWord sym -> IO Concrete.BV+ sWordToConcrete SW.ZBV = pure (Concrete.mkBv 0 0)+ sWordToConcrete (SW.DBV x) =+ let w = W4.intValue (W4.bvWidth x)+ in Concrete.mkBv w . BV.asUnsigned <$> W4.groundEval evalFn x -setAdapterTimeout :: +setAdapterTimeout :: W4.IsExprBuilder sym => AnAdapter -> W4.SolverGoalTimeout ->
src/Cryptol/Testing/Random.hs view
@@ -52,9 +52,9 @@ import Cryptol.Eval(evalEnumCon) import Cryptol.Eval.Type ( TValue(..), TNominalTypeValue(..), ConInfo(..)- , isNullaryCon )+ , enumTagWidth, isNullaryCon ) import Cryptol.Eval.Value ( GenValue(..), ppValue, defaultPPOpts, fromVFun, mkSeq, unsafeToFinSeq, finSeq)-import Cryptol.TypeCheck.Solver.InfNat (widthInteger, Nat' (..))+import Cryptol.TypeCheck.Solver.InfNat (Nat' (..)) import Cryptol.Utils.Ident (Ident) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.RecordMap@@ -343,7 +343,7 @@ let (v, g') = gen sz g in seq v (g', v)) g1 (conFields con) in- (($ flds') <$> evalEnumCon sym (conIdent con) num, g2)+ (($ flds') <$> evalEnumCon sym (conIdent con) num (length cons), g2) randomFloat :: (Backend sym, RandomGen g) =>@@ -361,14 +361,14 @@ | 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%+ | otherwise -> genNormal g' -- remaining ~50% where- emax = bit (fromInteger e) - 1- smax = bit (fromInteger p) - 1- -- generates floats uniformly chosen from among all bitpatterns genBinary g =+ -- NB: Use the size (e+p) below: 1 bit for the sign bit, e bits for the+ -- exponent, and (p - 1) bits for the mantissa for a total of+ -- (1 + e + (p - 1)) = (e+p) bits. let (v, g1) = randomR (0, bit (fromInteger (e+p)) - 1) g in (VFloat <$> (fpFromBits sym e p =<< wordLit sym (e+p) v), g1) @@ -376,17 +376,20 @@ -- values with 0 biased exponent and nonzero mantissa. genSubnormal g = let (sgn, g1) = random g- (v, g2) = randomR (1, bit (fromInteger p) - 1) g1+ -- NB: Use size (p - 1) bits below. `p` includes the implicit leading+ -- bit of the mantissa, which isn't explicitly included in the+ -- overall bit pattern.+ (v, g2) = randomR (1, bit (fromInteger p - 1) - 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 =+ -- generates floats corresponding to normal values. These are values where+ -- the exponent bits are not all zeros and not all ones.+ genNormal 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)+ (ex, g2) = randomR (1, bit (fromInteger e) - 2) g1+ (si, g3) = randomR (0, bit (fromInteger p - 1) - 1) g2+ v = (ex `shiftL` (fromInteger p - 1)) .|. si+ in (VFloat <$> ((if sgn then fpNeg sym else pure) =<< fpFromBits sym e p =<< wordLit sym (e+p) v), g3) -- | A test result is either a pass, a failure due to evaluating to@@ -513,10 +516,11 @@ case nv of TVStruct tbody -> typeValues (TVRec tbody) TVEnum cons ->- [ VEnum (toInteger tag) (IntMap.singleton tag con')+ [ VEnum tag' (IntMap.singleton tag con') | (tag,con) <- zip [0..] (Vector.toList cons) , vs <- mapM typeValues (conFields con) , let con' = con { conFields = pure <$> vs }+ , let tag' = BV (enumTagWidth cons) (toInteger tag) ] TVAbstract -> []
src/Cryptol/TypeCheck/AST.hs view
@@ -85,19 +85,35 @@ Module { mName :: !mname , mDoc :: ![Text] , mExports :: ExportSpec Name+ , mIsIfaceFunctor :: !Bool+ -- ^ True when this is an interface functor+ -- (parameterized interface) rather than a+ -- normal functor. -- Functors:- , mParamTypes :: Map Name ModTParam- , mParamFuns :: Map Name ModVParam- , mParamConstraints :: [Located Prop]-+ , mParamDecls :: ParamDecls+ -- ^ Input parameters: type/value parameters and+ -- constraints from interface imports. These are+ -- resolved when the functor is instantiated.+ -- Use by normal and interface functors.+ , mParams :: FunctorParams -- ^ Parameters grouped by "import". + -- Interfaces+ , mOutputParamDecls :: ParamDecls+ -- ^ Output parameters: declared by interfaces+ -- (both ordinary and functor interfaces).+ -- These specify what an interface provides.++ , mFunctors :: Map Name (ModuleG Name)- -- ^ Functors directly nested in this module.- -- Things further nested are in the modules in the- -- elements of the map.+ -- ^ Functors in this module, and from nested non+ -- functor module. Things nested in functors are in the+ -- modules in the elements of the map.+ -- This includes both regular functors and interface+ -- functors; use 'mIsIfaceFunctor' on each entry to+ -- distinguish. , mNested :: !(Set Name)@@ -110,6 +126,7 @@ , mDecls :: [DeclGroup] , mSubmodules :: Map Name Submodule , mSignatures :: !(Map Name ModParamNames)+ , mModAliases :: !(Map Name (ImpName Name)) , mInScope :: NamingEnv -- ^ Things in scope at the top level.@@ -119,19 +136,30 @@ data Submodule = Submodule { smIface :: IfaceNames Name , smInScope :: NamingEnv+ , smVirtual :: Bool+ -- ^ Generated by the system (e.g., to expose functor parameters). } deriving (Show, Generic, NFData) +mParamTypes :: ModuleG mname -> Map Name ModTParam+mParamTypes = pdTypes . mParamDecls++mParamFuns :: ModuleG mname -> Map Name ModVParam+mParamFuns = pdFuns . mParamDecls++mParamConstraints :: ModuleG mname -> [Located Prop]+mParamConstraints = pdConstraints . mParamDecls+ emptyModule :: mname -> ModuleG mname emptyModule nm = Module { mName = nm , mDoc = mempty , mExports = mempty+ , mIsIfaceFunctor = False , mParams = mempty- , mParamTypes = mempty- , mParamConstraints = mempty- , mParamFuns = mempty+ , mParamDecls = mempty+ , mOutputParamDecls = mempty , mNested = mempty @@ -141,6 +169,7 @@ , mFunctors = mempty , mSubmodules = mempty , mSignatures = mempty+ , mModAliases = mempty , mInScope = mempty }@@ -539,26 +568,35 @@ ppPrec _ (WithNames Module { .. } nm) = withPPCfg $ \cfg -> let- mps = map mtpParam (Map.elems mParamTypes)+ mps = map mtpParam (Map.elems (pdTypes mParamDecls) +++ Map.elems (pdTypes mOutputParamDecls)) pp' :: PP (WithNames a) => a -> Doc pp' = ppWithNames (addTNames cfg mps nm) ppSig (x,y) = "interface module" <+> pp x <+> "where" $$ indent 2 (pp y) vcat' xs = if null xs then Nothing else Just (vcat xs) in- vcat $- catMaybes- [ Just (text "module" <+> pp mName)- , Just ""- -- XXX: Print exports?- , vcat' (map pp' (Map.elems mTySyns))- -- XXX: Print abstarct types/functions- , vcat' (map pp' mDecls)+ vcat [+ text "module" <+> pp mName,+ "",+ indent 2 $ vcat $+ catMaybes+ -- XXX: Print exports?+ [ vcat' [ "-- Input parameters:" $$ indent 2 (pp mParamDecls)+ | not (null (pdTypes mParamDecls))+ || not (null (pdFuns mParamDecls)) ]+ , vcat' [ "-- Output parameters:" $$ indent 2 (pp mOutputParamDecls)+ | not (null (pdTypes mOutputParamDecls))+ || not (null (pdFuns mOutputParamDecls)) ]+ , Just ""+ , vcat' (map pp' (Map.elems mTySyns))+ , vcat' (map pp' mDecls) - , vcat' (map pp (Map.elems mFunctors))+ , vcat' (map pp (Map.elems mFunctors)) - , vcat' (map ppSig (Map.toList mSignatures))- ]+ , vcat' (map ppSig (Map.toList mSignatures))+ ]+ ] instance PP (WithNames TCTopEntity) where
src/Cryptol/TypeCheck/Docstrings.hs view
@@ -24,6 +24,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, maybeToList)+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T @@ -62,28 +63,35 @@ { docModContext = lookupModuleName n , docFor = DocForDef n , docText = maybeToList (tsDoc t)- } | (n, t) <- Map.assocs (mTySyns m)] +++ } | (n, t) <- Map.assocs (mTySyns m), not (inVirtual n)] ++ [DocItem { docModContext = lookupModuleName n , docFor = DocForDef n , docText = maybeToList (ntDoc t)- } | (n, t) <- Map.assocs (mNominalTypes m)] +++ } | (n, t) <- Map.assocs (mNominalTypes m), not (inVirtual n)] ++ [DocItem { docModContext = lookupModuleName (dName d) , docFor = DocForDef (dName d) , docText = maybeToList (dDoc d <> exhaustBoolProp d)- } | g <- mDecls m, d <- groupDecls g] +++ } | g <- mDecls m, d <- groupDecls g, not (inVirtual (dName d))] ++ [DocItem { docModContext = ImpNested n , docFor = DocForMod (ImpNested n) , docText = ifsDoc (smIface s)- } | (n, s) <- Map.assocs (mSubmodules m)] +++ } | (n, s) <- Map.assocs (mSubmodules m), not (smVirtual s)] ++ [DocItem { docModContext = ImpTop (mName m) , docFor = DocForMod (ImpNested n) , docText = maybeToList (mpnDoc s) } | (n, s) <- Map.assocs (mSignatures m)] where+ virtModNames = Map.keysSet (Map.filter smVirtual (mSubmodules m))++ inVirtual n =+ case Map.lookup n nameToModule of+ Just (ImpNested owner) -> owner `Set.member` virtModNames+ _ -> False+ lookupModuleName n = case Map.lookup n nameToModule of Just x -> x
src/Cryptol/TypeCheck/Error.hs view
@@ -64,7 +64,7 @@ -- | Clean up warning messages by sorting them by source location -- (they are accumulated in reverse order by 'recordWarning'). cleanupWarnings :: [(Range,Warning)] -> [(Range,Warning)]-cleanupWarnings = +cleanupWarnings = sortBy (compare `on` (cmpR . fst)) -- order warnings where cmpR r = ( source r -- First by file@@ -224,6 +224,9 @@ | OverlappingPat (Maybe Ident) [Range] -- ^ Overlapping patterns in a case + | TCSolverTimeout Int+ -- ^ The typechecker SMT solver exceeded its timeout+ | TemporaryError Doc -- ^ This is for errors that don't fit other cateogories. -- We should not use it much, and is generally to be used@@ -246,6 +249,7 @@ errorImportance err = case err of BareTypeApp -> 11 -- basically a parse error+ TCSolverTimeout {} -> 11 TemporaryError {} -> 11 -- show these as usually means the user used something that doesn't work @@ -381,6 +385,7 @@ InvalidConstraintGuard p -> InvalidConstraintGuard $! apSubst su p + TCSolverTimeout {} -> err TemporaryError {} -> err @@ -435,6 +440,7 @@ InvalidConstraintGuard p -> fvs p + TCSolverTimeout {} -> Set.empty TemporaryError {} -> Set.empty instance PP Warning where@@ -522,7 +528,7 @@ addTVarsDescsAfter names err $ nested "Recursive type declarations:" (commaSep $ map nm ts)- + TooManyParams n t i j -> addTVarsDescsAfter names err $ nested "Type signature mismatch." $@@ -755,6 +761,10 @@ , "Constraint guards support only numeric comparisons and `fin`." ] + TCSolverTimeout seconds ->+ "Typechecking timed out after" <+> int seconds <+>+ if seconds == 1 then "second." else "seconds."+ TemporaryError doc -> doc where bullets xs = vcat [ "•" <+> d | d <- xs ]@@ -818,6 +828,7 @@ PGeq -> useCtr PFin -> useCtr PPrime -> useCtr+ PNotPrime -> useCtr PHas sel -> custom ("Type" <+> doc1 </> "does not have field" <+> f@@ -906,13 +917,12 @@ (uvars,non_uvars) = partition isFreeTV $ Set.toList $ fvs (map snd warns, map snd errs)- + mpNames = computeModParamNames cfg [ tp | TVBound tp <- non_uvars ] mempty- + (numVaras,otherVars) = partition ((== KNum) . kindOf) uvars otherRoots = [ "a", "b", "c", "d" ] numRoots = [ "m", "n", "u", "v" ] variants roots = [ nameVariant n r | n <- [ 0 .. ], r <- roots ]-
src/Cryptol/TypeCheck/Infer.hs view
@@ -82,21 +82,30 @@ proveModuleTopLevel endModule - P.FunctorInstance f as inst ->+ P.FunctorInstance f as inst kind -> do mb <- doFunctorInst- (P.ImpTop <$> P.mName m) f as inst (P.mInScope m) (thing <$> P.mDocTop m)+ (P.ImpTop <$> P.mName m) f as inst kind (P.mInScope m) (thing <$> P.mDocTop m) 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+ P.InterfaceModule sig+ | not (any P.isSigIfaceImport (P.sigImports sig)) ->+ do newTopSignatureScope (thing (P.mName m))+ checkSignature sig+ endTopSignature + | otherwise ->+ do newModuleScope [] (thing (P.mName m)) mempty mempty+ checkSignature sig+ updScope \s -> s { mIsIfaceFunctor = True }+ endModule + P.ModuleAlias {} ->+ panic "inferTopModule" ["Module alias at top level"] + -- | Construct a Prelude primitive in the parsed AST. mkPrim :: String -> InferM (P.Expr Name) mkPrim str =@@ -823,7 +832,7 @@ 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 =+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@@ -1147,7 +1156,7 @@ do let nm = thing (P.bName b) let tGoal = WithSource t (DefinitionOf nm) (getLoc b) checkBindParams b tGoal- e1 <- checkFun (P.FunDesc (Just nm) 0) (P.bindParams b) e tGoal+ e1 <- checkFun (P.FunDesc (Just nm) 0 False) (P.bindParams b) e tGoal let f = thing (P.bName b) return Decl { dName = f , dSignature = Forall [] [] t@@ -1279,7 +1288,7 @@ let nm = thing (P.bName b) tGoal = WithSource t0 (DefinitionOf nm) (getLoc b) checkBindParams b tGoal- e1 <- checkFun (P.FunDesc (Just nm) 0) (P.bindParams b) e0 tGoal+ e1 <- checkFun (P.FunDesc (Just nm) 0 False) (P.bindParams b) e0 tGoal addGoals validSchema () <- simplifyAllConstraints -- XXX: using `asmps` also? return e1@@ -1557,62 +1566,38 @@ proveModuleTopLevel endSubmodule - P.FunctorInstance f as inst ->+ P.FunctorInstance f as inst kind -> do let doc = thing <$> P.tlDoc tl _ <- doFunctorInst- (P.ImpNested <$> P.mName m) f as inst (P.mInScope m) doc+ (P.ImpNested <$> P.mName m) f as inst kind (P.mInScope m) doc pure () - P.InterfaceModule sig ->+ P.InterfaceModule sig+ | not (any P.isSigIfaceImport (P.sigImports sig)) -> do let doc = 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+ | otherwise ->+ do inRange (srcRange (P.mName m))+ do let nm = thing (P.mName m)+ newSubmoduleScope nm [] mempty mempty+ checkSignature sig+ updScope \s -> s { mIsIfaceFunctor = True }+ endSubmodule - 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) ]+ P.ModuleAlias target ->+ do let nm = thing (P.mName m)+ updScope \s ->+ s { mNested = Set.insert nm (mNested s)+ , mModAliases = Map.insert nm (thing target) (mModAliases s)+ } - 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- }- }+ where P.NestedModule m = P.tlValue tl - mapM_ addParamType actualTys- addParameterConstraints actualCtrs- mapM_ addParamFun actualVals- mapM_ addTySyn actualTS- addModParam param+ P.DModParam p -> checkModParam p P.DImport {} -> pure () P.Include {} -> bad "Include"@@ -1622,18 +1607,65 @@ bad x = panic "checkTopDecl" [ x ] +checkModParam :: P.ModParam Name -> InferM ()+checkModParam 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+ { mpnParams = ParamDecls+ { pdTypes = Map.fromList [ (mtpName tp, tp)+ | tp <- actualTys ]+ , pdFuns = Map.fromList [ (mvpName vp, vp)+ | vp <- actualVals ]+ , pdConstraints = actualCtrs+ }+ , mpnTySyn = Map.fromList [ (tsName ts, ts)+ | ts <- actualTS ]+ , mpnDoc = thing <$> P.mpDoc p+ }+ }++ mapM_ addParamType actualTys+ addParameterConstraints actualCtrs+ mapM_ addParamFun actualVals+ mapM_ addTySyn actualTS+ addModParam param++ checkSignature :: P.Signature Name -> InferM () checkSignature sig =- do forM_ (P.sigTypeParams sig) \pt ->- addParamType =<< checkParameterType pt+ do forM_ [ p | P.SigIfaceImport p <- P.sigImports sig ] checkModParam + forM_ (P.sigTypeParams sig) \pt ->+ addOutputParamType =<< checkParameterType pt+ mapM_ checkSigDecl (P.sigDecls sig) - addParameterConstraints =<<+ addOutputParameterConstraints =<< checkParameterConstraints (P.sigConstraints sig) forM_ (P.sigFunParams sig) \f ->- addParamFun =<< checkParameterFun f+ addOutputParamFun =<< checkParameterFun f proveModuleTopLevel
src/Cryptol/TypeCheck/InferTypes.hs view
@@ -46,6 +46,7 @@ { 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+ , solverTimeout :: Int -- ^ Timeout for solver queries, in seconds , solverPreludePath :: [FilePath] -- ^ Look for the solver prelude in these locations. , solverSmtFile :: Maybe FilePath@@ -63,6 +64,7 @@ { solverPath = "z3" , solverArgs = [ "-smt2", "-in" ] , solverVerbose = 0+ , solverTimeout = 5 , solverPreludePath = searchPath , solverSmtFile = Nothing }
src/Cryptol/TypeCheck/Interface.hs view
@@ -35,7 +35,7 @@ , ifsDoc = mDoc m } --- | Things defines by a module+-- | Things defined by a module genModDefines :: ModuleG name -> Set Name genModDefines m = Set.unions@@ -47,6 +47,7 @@ , Map.keysSet (mSubmodules m) , Map.keysSet (mFunctors m) , Map.keysSet (mSignatures m)+ , Map.keysSet (mModAliases m) ] `Set.difference` nestedInSet (mNested m) where nestedInSet = Set.unions . map inNested . Set.toList@@ -75,9 +76,12 @@ , ifModules = smIface <$> mSubmodules m , ifSignatures = mSignatures m , ifFunctors = genIface <$> mFunctors m+ , ifModuleAliases = mModAliases m+ , ifSigOwnParams = if mIsIfaceFunctor m+ then Just (mOutputParamDecls m)+ else Nothing } , ifParams = mParams m }--+
src/Cryptol/TypeCheck/Kind.hs view
@@ -63,8 +63,7 @@ -- 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+ let newPs = simplifyConstraintProps ps1 return ( Forall xs1 newPs (tRebuild t1) , [ g { goal = tRebuild (goal g) } | g <- gs ] )@@ -81,18 +80,24 @@ function corresponding guard is checked. * We also check that there are no wild-cards in the constraints.++ * If any constraints are trivial (e.g., `n == n`), then simplify them away.+ This ensures that when we apply each auto-generated guard function to proof+ arguments, we pick the correct number of 'EProofApp's. -} checkPropGuards :: [Located (P.Prop Name)] -> InferM [Prop] checkPropGuards props = do (newPs,_gs) <- collectGoals (mapM check props)- pure newPs+ -- Use `simplifyConstraintProps` here for symmetry with `checkSchema`,+ -- which also simplifies away trivial constraints in type signatures.+ pure $ simplifyConstraintProps 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 ()+ TCon (PC x) _ | x `elem` [PEqual,PNeq,PGeq,PFin,PPrime,PNotPrime,PTrue] -> pure () _ -> recordError (InvalidConstraintGuard ps) pure ps @@ -649,3 +654,9 @@ | k1 /= k2 = do kRecordError (KindMismatch Nothing k1 k2) kNewType TypeErrorPlaceHolder k1 checkKind t _ _ = return t++-- | Simplify constraints arising from a user-written type signature (see+-- 'checkSchema') or numeric constraint guards (see 'checkPropGuards').+simplifyConstraintProps :: [Prop] -> [Prop]+simplifyConstraintProps =+ concatMap pSplitAnd . map (simplify mempty) . map tRebuild
src/Cryptol/TypeCheck/Module.hs view
@@ -1,25 +1,23 @@ {-# Language BlockArguments, ImplicitParams #-} module Cryptol.TypeCheck.Module (doFunctorInst) where -import Data.List(partition,unzip4)+import Data.List(partition) import Data.Text(Text) import Data.Map(Map) import Data.Maybe (maybeToList) import qualified Data.Map as Map-import qualified Data.Map.Merge.Strict as Map import Data.Set (Set) import qualified Data.Set as Set import Control.Monad(unless,forM_,mapAndUnzipM) import Cryptol.Utils.Panic(panic)-import Cryptol.Utils.Ident(Ident,Namespace(..),ModPath,isInfixIdent)+import Cryptol.Utils.Ident(Ident,Namespace(..),isInfixIdent) import Cryptol.Parser.Position (Range,Located(..), thing) import qualified Cryptol.Parser.AST as P-import Cryptol.ModuleSystem.Binds(newFunctorInst) import Cryptol.ModuleSystem.Name(nameIdent) import Cryptol.ModuleSystem.NamingEnv- (NamingEnv(..), modParamNamingEnv, shadowing, without)+ (NamingEnv(..), modParamNamesNamingEnv, shadowing, without, mapNamingEnv) import Cryptol.ModuleSystem.Interface ( IfaceG(..), IfaceDecls(..), IfaceNames(..), IfaceDecl(..) , filterIfaceDecls@@ -37,43 +35,45 @@ 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").+ P.ModuleInstance Name+ {- ^ Instantiation. Filled in by the renamer.+ Contains the renaming for the functor that arises from+ generativity (i.e., it is something that will make the names "fresh"),+ and virtual submodule names for functor parameters. -} ->+ P.FunctorInstKind {- ^ Module or signature instantiation -} -> NamingEnv {- ^ Names in the enclosing scope of the instantiated module -} -> Maybe Text {- ^ Documentation for the module being generated -} -> InferM (Maybe TCTopEntity)-doFunctorInst m f as instMap0 enclosingInScope doc =+doFunctorInst m f as modInst instKind enclosingInScope doc = inRange (srcRange m)- do mf <- lookupFunctor (thing f)+ do let instMap = P.modInstMap modInst+ mf <- lookupFunctor (thing f) argIs <- checkArity (srcRange f) mf as- m2 <- do let mpath = P.impNameModPath (thing m)- as2 <- mapM (checkArg mpath) argIs- let (tySus,paramTySyns,decls,paramInstMaps) =- unzip4 [ (su,ts,ds,im) | DefinedInst su ts ds im <- as2 ]- instMap <- addMissingTySyns mpath mf instMap0+ m2 <- do+ as2 <- mapM (checkArg instMap) argIs+ let (tySus,paramTySyns,decls) =+ unzip3 [ (su,ts,ds) | DefinedInst su ts ds <- as2 ] let ?tVarSu = mergeDistinctSubst tySus- ?nameSu = instMap <> mconcat paramInstMaps+ ?nameSu = instMap let m1 = moduleInstance mf m2 = m1 { mName = m , mDoc = mempty- , mParamTypes = mempty- , mParamFuns = mempty- , mParamConstraints = mempty+ , mParamDecls = mempty+ , mOutputParamDecls = mOutputParamDecls m1 , mParams = mempty , mTySyns = mconcat paramTySyns <> mTySyns m1 , 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 ->@@ -94,9 +94,17 @@ -- and focused. -- -- The exception is when instantiating with _, in which case we must delete- -- the module parameters from the naming environment.- let inScope0 = mInScope m2 `without`- mconcat [ modParamNamingEnv mp | (_, mp, AddDeclParams) <- argIs ]+ -- the module parameters from the naming environment, but we should+ -- still add type synonyms.+ let ren x = case Map.lookup x instMap of+ Just x' -> x'+ Nothing -> panic "doFunctorInst" ["Missing module parameter"]+ inScope0 = mInScope m2 `without`+ mapNamingEnv ren (+ mconcat [ modParamNamesNamingEnv nms+ | (_, mp, AddDeclParams) <- argIs + , let nms = (mpParameters mp) { mpnTySyn = mempty }+ ]) inScope = inScope0 `shadowing` enclosingInScope -- Combine the docstrings of:@@ -104,23 +112,77 @@ -- * The module being generated let newDoc = maybeToList doc <> mDoc mf - case thing m of- P.ImpTop mn -> newModuleScope newDoc mn (mExports m2) inScope- P.ImpNested mn -> newSubmoduleScope mn newDoc (mExports m2) inScope+ case instKind of+ P.ModuleInst ->+ do case thing m of+ P.ImpTop mn -> newModuleScope newDoc mn (mExports m2) inScope+ P.ImpNested mn -> newSubmoduleScope mn newDoc (mExports m2) inScope - mapM_ addTySyn (Map.elems (mTySyns m2))- mapM_ addNominal (Map.elems (mNominalTypes m2))- addSignatures (mSignatures m2)- addSubmodules (mSubmodules m2)- setNested (mNested m2)- addFunctors (mFunctors m2)- mapM_ addDecls (mDecls m2)+ mapM_ addTySyn (Map.elems (mTySyns m2))+ mapM_ addNominal (Map.elems (mNominalTypes m2))+ addSignatures (mSignatures m2)+ addFunctors (mFunctors m2)+ addModAliases (mModAliases m2)+ mapM_ addDecls (mDecls m2) - case thing m of- P.ImpTop {} -> Just <$> endModule- P.ImpNested {} -> endSubmodule >> pure Nothing+ (vpmSubs, vpmNested) <-+ makeVirtParamModDefs (P.modInstVirtParamMods modInst)+ addSubmodules (mSubmodules m2 `Map.union` vpmSubs)+ setNested (mNested m2 `Set.union` vpmNested) + case thing m of+ P.ImpTop {} -> Just <$> endModule+ P.ImpNested {} -> endSubmodule >> pure Nothing + -- Interface functor instantiation: the result is a signature.+ -- The signature's output parameters come from the interface+ -- functor's own declarations (mOutputParamDecls), which were+ -- preserved through instantiation.+ P.SignatureInst ->+ do let addSigDecls =+ do let sigPd = mOutputParamDecls m2+ mapM_ addOutputParamType (Map.elems (pdTypes sigPd))+ addOutputParameterConstraints (pdConstraints sigPd)+ mapM_ addOutputParamFun (Map.elems (pdFuns sigPd))+ mapM_ addTySyn (Map.elems (mTySyns m2))+ case thing m of+ P.ImpTop mn ->+ do newTopSignatureScope mn+ addSigDecls+ Just <$> endTopSignature+ P.ImpNested mn ->+ do newSignatureScope mn doc+ addSigDecls+ endSignature+ pure Nothing++++-- | Register virtual parameter submodules. The actual definitions for the+-- parameter values are created by checkParamType/checkParamValue (using the+-- instMap which now maps directly to virtual submodule names). This function+-- just registers the submodule metadata.+makeVirtParamModDefs ::+ [P.VirtParamMod Name] -> InferM (Map Name Submodule, Set Name)+makeVirtParamModDefs vpmods =+ do let submodules = Map.fromList+ [ (P.vpmName ps, Submodule+ { smIface = IfaceNames+ { ifsName = P.vpmName ps+ , ifsNested = mempty+ , ifsDefines = Map.keysSet (P.vpmDefs ps)+ , ifsPublic = Map.keysSet (P.vpmDefs ps)+ , ifsDoc = mempty+ }+ , smInScope = mempty+ , smVirtual = True+ })+ | ps <- vpmods+ ]+ nested = Set.fromList [ P.vpmName ps | ps <- vpmods ]+ pure (submodules, nested)++ data ActualArg = UseParameter ModParam -- ^ Instantiate using this parameter | UseModule (IfaceG ()) -- ^ Instantiate using this module@@ -196,9 +258,6 @@ -- ^ Type synonyms created from the functor's type parameters [Decl] -- ^ Bindings for value parameters- (Map Name Name)- -- ^ Map from the functor's parameter names to the new names- -- created for the instantiation | ParamInst (Set (MBQual TParam)) [Prop] (Map (MBQual Name) Type) -- ^ Argument that add parameters@@ -207,20 +266,9 @@ -{- | 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 ::- ModPath -> (Range, ModParam, ActualArg) -> InferM ArgInst-checkArg mpath (r,expect,actual') =+{- | Check the argument to a functor parameter. -}+checkArg :: Map Name Name -> (Range, ModParam, ActualArg) -> InferM ArgInst+checkArg instMap (r,expect,actual') = case actual' of AddDeclParams -> paramInst UseParameter {} -> definedInst@@ -228,17 +276,17 @@ where paramInst =- do let as = Set.fromList- (map (qual . mtpParam) (Map.elems (mpnTypes params)))- cs = map thing (mpnConstraints params)- check = checkSimpleParameterValue r (mpName expect)+ do let (as,su) = prepParamTypeBacktick instMap (Map.elems (mpnTypes params))+ cs = map (apSubst su . thing) (mpnConstraints params)+ check = checkParamValueBacktick instMap su 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))+ fs <- concat <$> mapM check (Map.elems (mpnFuns params))+ let funs = Map.fromList [ (qual f, t) | (f,t) <- fs ]+ pure (ParamInst (Set.fromList (map qual as)) cs funs) definedInst =- do (tRens, tSyns, tInstMaps) <- unzip3 <$>- mapM (checkParamType mpath r tyMap) (Map.toList (mpnTypes params))+ do (tRens, tSyns) <-+ mapAndUnzipM (checkParamType instMap r tyMap) (Map.toList (mpnTypes params)) let renSu = listParamSubst (concat tRens) {- Note: the constraints from the signature are already added to the@@ -246,13 +294,12 @@ doFunctorInst -} - (vDecls, vInstMaps) <-- mapAndUnzipM (checkParamValue mpath r vMap)+ vDecls <-+ mapM (checkParamValue instMap r vMap) [ s { mvpType = apSubst renSu (mvpType s) } | s <- Map.elems (mpnFuns params) ] - pure $ DefinedInst renSu (mconcat tSyns)- (concat vDecls) (mconcat tInstMaps <> mconcat vInstMaps)+ pure $ DefinedInst renSu (mconcat tSyns) (concat vDecls) params = mpParameters expect@@ -303,31 +350,33 @@ -- | Check a type parameter to a module. checkParamType ::- ModPath {- ^ The new module we are creating -} ->+ Map Name Name {- ^ Renaming -} -> Range {- ^ Location for error reporting -} -> Map Ident (Kind,Type) {- ^ Actual types -} -> (Name,ModTParam) {- ^ Type parameter -} ->- InferM ([(TParam,Type)], Map Name TySyn, Map Name Name)+ InferM ([(TParam,Type)], Map Name TySyn) {- ^ Mapping from parameter name to actual type (for type substitution), type synonym map from a fresh type name to the actual type (only so that the type can be referred to in the REPL; type synonyms are fully inlined into types at this point), and a map from the old type name to the fresh type name (for instantiation) -}-checkParamType mpath r tyMap (name,mp) =+checkParamType instMap 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 ([], Map.empty, Map.empty)+ pure ([], Map.empty) Just (actualK,actualT) -> do unless (expectK == actualK) (recordErrorLoc (Just r) (KindMismatch (Just (TVFromModParam name)) expectK actualK))- name' <- newFunctorInst mpath name+ let name' = case Map.lookup name instMap of+ Just nm -> nm+ Nothing -> panic "checkParamType" [ "missing name" ] let tySyn = TySyn { tsName = name' , tsParams = [] , tsConstraints = []@@ -335,30 +384,31 @@ , tsDoc = mtpDoc mp } pure ( [(mtpParam mp, actualT)] , Map.singleton name' tySyn- , Map.singleton name name' ) -- | Check a value parameter to a module. checkParamValue ::- ModPath {- ^ The new module we are creating -} ->+ Map Name Name {- ^ Name instance map -} -> Range {- ^ Location for error reporting -} -> Map Ident (Name,Schema) {- ^ Actual values -} -> ModVParam {- ^ The parameter we are checking -} ->- InferM ([Decl], Map Name Name)+ InferM [Decl] {- ^ Decl mapping a new name to the actual value, and a map from the value param name in the functor to the new name (for instantiation) -}-checkParamValue mpath r vMap mp =+checkParamValue instMap 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 ([], Map.empty)+ pure [] Just actual -> do e <- mkParamDef r (name,expectT) actual- name' <- newFunctorInst mpath name+ let name' = case Map.lookup name instMap of+ Just nm -> nm+ Nothing -> panic "checkParamValue" ["Missing name"] let d = Decl { dName = name' , dSignature = expectT , dDefinition = DExpr e@@ -368,28 +418,54 @@ , dDoc = mvpDoc mp } - pure ([d], Map.singleton name name')+ pure [d] +--------------------------------------------------------------------------------+-- "Backtick" instantiation+-------------------------------------------------------------------------------- -checkSimpleParameterValue ::+-- | Compute the names of the type parameters for a backtick import.+-- The `ModTParam` arguments are those from the functor, so we need to+-- apply the instantiation renaming to them, so that it can be consistently+-- used when instantiation+prepParamTypeBacktick :: Map Name Name -> [ModTParam] -> ([TParam], Subst)+prepParamTypeBacktick nameInst mps = (newTPs, su)+ where+ su = listParamSubst (oldTPs `zip` map (TVar . TVBound) newTPs)+ newTPs = map renP mps+ oldTPs = map mtpParam mps+ renP p =+ case Map.lookup (mtpName p) nameInst of+ Just nm -> mtpParam p { mtpName = nm }+ Nothing -> panic "prepParamTypeBacktick" ["Missing parameter"]+++-- | Check that the type o+checkParamValueBacktick ::+ Map Name Name {- ^ Instantiation map -} ->+ Subst {- ^ Renaming subsitution -} -> 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 =+ InferM [(Name, Type)] {- ^ Name to use, and it's type. [] on error -}+checkParamValueBacktick instMap su r i mp = case (sVars sch, sProps sch) of- ([],[]) -> pure (Just (sType sch))+ ([],ps) | all pIsTrue ps -> pure [(newNm,apSubst su (sType sch))] _ -> do recordErrorLoc (Just r) (FunctorInstanceBadBacktick (BIPolymorphicArgument i (nameIdent (mvpName mp))))- pure Nothing+ pure [] where sch = mvpType mp-+ newNm =+ case Map.lookup (mvpName mp) instMap of+ Just nm -> nm+ Nothing -> panic "checkParamValueBacktick" ["Missing value parameter"]+-------------------------------------------------------------------------------- -{- | Make an "adaptor" that instantiates the paramter into the form expected+{- | Make an "adaptor" that instantiates the parameter into the form expected by the functor. If the actual type is: > {x} P => t@@ -431,23 +507,3 @@ res1 = foldr EProofAbs (apSubst su e) (sProps wantedS) applySubst res----- | The instMap we get from the renamer will not contain the fresh names for--- certain things in the functor generated in the typechecking stage, if we are--- instantiating a functor that is in the same file, since renaming and--- typechecking happens together with the instantiation. In particular, if the--- functor's interface has type synonyms, they will only get copied over into--- the functor in the typechecker, so the renamer will not see them. Here we--- make the fresh names for those missing type synonyms and add them to the--- instMap.-addMissingTySyns ::- ModPath {- ^ The new module we are creating -} ->- ModuleG () {- ^ The functor -} ->- Map Name Name {- ^ instMap we get from renamer -} ->- InferM (Map Name Name) {- ^ the complete instMap -}-addMissingTySyns mpath f = Map.mergeA- (Map.traverseMissing \name _ -> newFunctorInst mpath name)- Map.preserveMissing- (Map.zipWithMatched \_ _ name' -> name')- (mTySyns f)
src/Cryptol/TypeCheck/ModuleBacktickInstance.hs view
@@ -382,7 +382,11 @@ where tryVarApp orElse = case splitExprInst expr of- (EVar x, ts, cs) | ?isOurs x ->+ (EVar x, ts, cs)+ -- We operate on the instantiated module (including module params),+ -- and module parameters look like they are defined in the module,+ -- so we have to explicitly check that we have no binding.+ | ?isOurs x, not (x `Map.member` pSubst ?vparams) -> let ets = foldl ETApp (EVar x) (pUse ?tparams ++ rewType ts) eps = iterate EProofApp ets !! (?cparams + cs) evs = foldl EApp eps (pUse ?vparams)
src/Cryptol/TypeCheck/ModuleInstance.hs view
@@ -67,6 +67,7 @@ moduleInstance x = Submodule { smInScope = moduleInstance (smInScope x) , smIface = moduleInstance (smIface x)+ , smVirtual = smVirtual x } instance ModuleInstance (ModuleG name) where@@ -74,9 +75,17 @@ Module { mName = mName m , mDoc = mempty , mExports = doNameInst (mExports m)- , mParamTypes = doMap (mParamTypes m)- , mParamFuns = doMap (mParamFuns m)- , mParamConstraints = moduleInstance (mParamConstraints m)+ , mIsIfaceFunctor = mIsIfaceFunctor m+ , mParamDecls = ParamDecls+ { pdTypes = doMap (mParamTypes m)+ , pdFuns = doMap (mParamFuns m)+ , pdConstraints = moduleInstance (mParamConstraints m)+ }+ , mOutputParamDecls = ParamDecls+ { pdTypes = doMap (pdTypes (mOutputParamDecls m))+ , pdFuns = doMap (pdFuns (mOutputParamDecls m))+ , pdConstraints = moduleInstance (pdConstraints (mOutputParamDecls m))+ } , mParams = moduleInstance <$> mParams m , mFunctors = doMap (mFunctors m) , mNested = doSet (mNested m)@@ -85,6 +94,7 @@ , mDecls = moduleInstance (mDecls m) , mSubmodules = doMap (mSubmodules m) , mSignatures = doMap (mSignatures m)+ , mModAliases = doMap (mModAliases m) , mInScope = moduleInstance (mInScope m) } @@ -161,9 +171,11 @@ instance ModuleInstance ModParamNames where moduleInstance si =- ModParamNames { mpnTypes = doMap (mpnTypes si)- , mpnConstraints = moduleInstance (mpnConstraints si)- , mpnFuns = doMap (mpnFuns si)+ ModParamNames { mpnParams = ParamDecls+ { pdTypes = doMap (mpnTypes si)+ , pdFuns = doMap (mpnFuns si)+ , pdConstraints = moduleInstance (mpnConstraints si)+ } , mpnTySyn = doMap (mpnTySyn si) , mpnDoc = mpnDoc si }
src/Cryptol/TypeCheck/Monad.hs view
@@ -31,6 +31,7 @@ import Data.Semigroup(sconcat) import Data.Maybe(mapMaybe,fromMaybe) import Data.IORef+import qualified Control.Exception as X import GHC.Generics (Generic) import Control.DeepSeq@@ -143,9 +144,7 @@ { mTySyns = inpTSyns info <> mpnTySyn allPs , mNominalTypes = inpNominalTypes info- , mParamTypes = mpnTypes allPs- , mParamFuns = mpnFuns allPs- , mParamConstraints = mpnConstraints allPs+ , mParamDecls = mpnParams allPs , mSignatures = inpSignatures info } @@ -158,30 +157,34 @@ , 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)+ mbTimeout <- X.try (runExceptionT (runStateT rw (runReaderT ro m)))+ case mbTimeout of+ Left (SMT.SolverTimeout seconds) ->+ inferFailed [] [(inpRange info, TCSolverTimeout seconds)]+ Right mb ->+ 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- ]+ 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]+ errs -> inferFailed warns [(r,apSubst theSu e) | (r,e) <- errs] where ppcfg = defaultPPCfg@@ -775,19 +778,27 @@ -- | Lookup the type of a variable. lookupVar :: Name -> InferM VarType lookupVar x =- do mb <- IM $ asks $ Map.lookup x . iVars+ do mb <- tryLookupVar x case mb of Just a -> pure a Nothing ->+ do mp <- IM $ asks iVars+ panic "lookupVar" $ [ "Undefined variable"+ , show x+ , "IVARS"+ ] ++ map (show . debugShowUniques . pp) (Map.keys mp)++-- | Like 'lookupVar' but returns 'Nothing' instead of panicking.+-- Used by 'makeVirtParamModDefs' where a parameter variable may not exist+-- because the functor argument was invalid (error already reported).+tryLookupVar :: Name -> InferM (Maybe VarType)+tryLookupVar x =+ do mb <- IM $ asks $ Map.lookup x . iVars+ case mb of+ Just a -> pure (Just 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 variable"- , show x- , "IVARS"- ] ++ map (show . debugShowUniques . pp) (Map.keys mp)+ pure (ExtVar <$> mb1) -- | 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.@@ -815,8 +826,12 @@ do sigs <- getSignatures case Map.lookup x sigs of Just ips -> pure ips- Nothing -> panic "lookupSignature"- [ "Missing signature", show x ]+ Nothing ->+ do aliases <- getScope mModAliases+ case Map.lookup x aliases of+ Just target -> lookupSignature target+ Nothing -> panic "lookupSignature"+ [ "Missing signature", show x ] P.ImpTop t -> do loaded <- iExtSignatures <$> IM ask@@ -840,10 +855,14 @@ 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 = () })+ do aliases <- getScope mModAliases+ case Map.lookup m aliases of+ Just target -> lookupFunctor target+ 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@@ -868,13 +887,17 @@ 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 = () } })+ do aliases <- getScope mModAliases+ case Map.lookup m aliases of+ Just target -> lookupModule target+ 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@@ -919,13 +942,15 @@ getNominalTypes :: InferM (Map Name NominalType) getNominalTypes = getScope mNominalTypes --- | Returns the abstract function declarations+-- | All abstract type parameters in scope (both input and output). getParamTypes :: InferM (Map Name ModTParam)-getParamTypes = getScope mParamTypes+getParamTypes =+ Map.union <$> getScope mParamTypes <*> getScope (pdTypes . mOutputParamDecls) --- | Constraints on the module's parameters.+-- | All parameter constraints in scope (both input and output). getParamConstraints :: InferM [Located Prop]-getParamConstraints = getScope mParamConstraints+getParamConstraints =+ (++) <$> getScope mParamConstraints <*> getScope (pdConstraints . mOutputParamDecls) -- | Get the set of bound type variables that are in scope. getTVars :: InferM (Set Name)@@ -1056,9 +1081,9 @@ { mName = mName y , mDoc = mDoc y , mExports = mExports y- , mParamTypes = mParamTypes y- , mParamFuns = mParamFuns y- , mParamConstraints = mParamConstraints y+ , mIsIfaceFunctor = mIsIfaceFunctor y+ , mParamDecls = mParamDecls y+ , mOutputParamDecls = mOutputParamDecls y , mParams = mParams y , mNested = mNested y , mInScope = mInScope y@@ -1071,12 +1096,14 @@ then mSubmodules y else let sm = Submodule { smIface = genIfaceNames x1- , smInScope = mInScope x }+ , smInScope = mInScope x+ , smVirtual = False } in Map.insert m sm (mSubmodules x <> mSubmodules y) , mFunctors = if isFun then Map.insert m x1 (mFunctors y) else mFunctors x <> mFunctors y+ , mModAliases = add mModAliases } _ -> panic "endSubmodule" [ "Not a submodule" ]@@ -1101,9 +1128,7 @@ where z = y { mSignatures = Map.insert m sig (mSignatures y) } sig = ModParamNames- { mpnTypes = mParamTypes x- , mpnConstraints = mParamConstraints x- , mpnFuns = mParamFuns x+ { mpnParams = mOutputParamDecls x , mpnTySyn = mTySyns x , mpnDoc = doc }@@ -1115,9 +1140,7 @@ case iScope rw of [ x ] | TopSignatureScope m <- mName x -> ( TCTopSignature m ModParamNames- { mpnTypes = mParamTypes x- , mpnConstraints = mParamConstraints x- , mpnFuns = mParamFuns x+ { mpnParams = mOutputParamDecls x , mpnTySyn = mTySyns x , mpnDoc = Nothing }@@ -1149,10 +1172,10 @@ { mName = () , mDoc = mempty , mExports = mempty+ , mIsIfaceFunctor = False , mParams = mempty- , mParamTypes = mempty- , mParamConstraints = mempty- , mParamFuns = mempty+ , mParamDecls = mempty+ , mOutputParamDecls = mempty , mNested = mempty , mTySyns = uni mTySyns@@ -1161,6 +1184,7 @@ , mSubmodules = uni mSubmodules , mFunctors = uni mFunctors , mSignatures = uni mSignatures+ , mModAliases = uni mModAliases , mInScope = uni mInScope }@@ -1192,7 +1216,9 @@ addParamType :: ModTParam -> InferM () addParamType a =- updScope \r -> r { mParamTypes = Map.insert (mtpName a) a (mParamTypes r) }+ updScope \r ->+ let pd = mParamDecls r+ in r { mParamDecls = pd { pdTypes = Map.insert (mtpName a) a (pdTypes pd) } } addSignatures :: Map Name ModParamNames -> InferM () addSignatures mp =@@ -1206,6 +1232,10 @@ addFunctors mp = updScope \r -> r { mFunctors = Map.union mp (mFunctors r) } +addModAliases :: Map Name (P.ImpName Name) -> InferM ()+addModAliases mp =+ updScope \r -> r { mModAliases = Map.union mp (mModAliases r) }+ setNested :: Set Name -> InferM () setNested names = updScope \r -> r { mNested = names }@@ -1214,14 +1244,38 @@ -- | 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) }+ do updScope \r ->+ let pd = mParamDecls r+ in r { mParamDecls = pd { pdFuns = Map.insert (mvpName x) x (pdFuns pd) } } 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 }+ updScope \r ->+ let pd = mParamDecls r+ in r { mParamDecls = pd { pdConstraints = ps ++ pdConstraints pd } }++addOutputParamType :: ModTParam -> InferM ()+addOutputParamType a =+ updScope \r ->+ let pd = mOutputParamDecls r+ in r { mOutputParamDecls = pd { pdTypes = Map.insert (mtpName a) a (pdTypes pd) } }++addOutputParamFun :: ModVParam -> InferM ()+addOutputParamFun x =+ do updScope \r ->+ let pd = mOutputParamDecls r+ in r { mOutputParamDecls = pd { pdFuns = Map.insert (mvpName x) x (pdFuns pd) } }+ IM $ sets_ \rw -> rw { iBindTypes = Map.insert (mvpName x) (mvpType x)+ (iBindTypes rw) }++addOutputParameterConstraints :: [Located Prop] -> InferM ()+addOutputParameterConstraints ps =+ updScope \r ->+ let pd = mOutputParamDecls r+ in r { mOutputParamDecls = pd { pdConstraints = ps ++ pdConstraints pd } } addModParam :: ModParam -> InferM () addModParam p =
src/Cryptol/TypeCheck/Sanity.hs view
@@ -394,39 +394,19 @@ 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])+ checkRecordSel UnexpectedRecordShape f mb fs + TNominal nt _ ->+ case ntDef nt of+ Struct con ->+ checkRecordSel UnexpectedNewtypeShape f mb (ntFields con)+ _ -> reportError $ BadSelector sel t _ -> reportError $ BadSelector sel t @@ -448,8 +428,31 @@ _ -> reportError $ BadSelector sel t -+-- | Check that a record selection or update expression is well-formed. This is+-- written to work for both record values and newtype values.+checkRecordSel ::+ -- | What error to raise if the record or newtype value is malformed.+ ([Ident] -> [Ident] -> Error) ->+ -- | The field name being selected.+ Ident ->+ -- | The expected field names for the record or newtype.+ Maybe [Ident] ->+ -- | The actual field names for the record or newtype.+ RecordMap Ident Type ->+ -- | The type of the field being selected.+ TcM Type+checkRecordSel unexpectedShape f mb fs =+ do case mb of+ Nothing -> return ()+ Just fs1 ->+ do let ns = Set.toList (fieldSet fs)+ ns1 = sort fs1+ unless (ns == ns1) $+ reportError $ unexpectedShape ns1 ns + case lookupField f fs of+ Nothing -> reportError $ MissingField f $ displayOrder fs+ Just ft -> return ft -- | Check if the one type is convertible to the other. convertible :: Type -> Type -> TcM ()@@ -638,6 +641,7 @@ | MissingField Ident [Ident] | UnexpectedTupleShape Int Int | UnexpectedRecordShape [Ident] [Ident]+ | UnexpectedNewtypeShape [Ident] [Ident] | UnexpectedSequenceShape Int Type | BadSelector Selector Type | BadInstantiation@@ -749,6 +753,12 @@ UnexpectedRecordShape expected actual -> ppErr "Unexpected record shape"+ [ "Expected:" <+> commaSep (map pp expected)+ , "Actual :" <+> commaSep (map pp actual)+ ]++ UnexpectedNewtypeShape expected actual ->+ ppErr "Unexpected newtype shape" [ "Expected:" <+> commaSep (map pp expected) , "Actual :" <+> commaSep (map pp actual) ]
src/Cryptol/TypeCheck/SimpType.hs view
@@ -300,6 +300,7 @@ | Just t <- tOp TCMax (total (op2 nMax)) [x,y] = t | Just n <- tIsNat' x = maxK n y | Just n <- tIsNat' y = maxK n x+ | x == y = x | otherwise = tf2 TCMax x y where maxK Inf _ = tInf
src/Cryptol/TypeCheck/SimpleSolver.hs view
@@ -5,7 +5,8 @@ ( 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.Numeric+ ( cryIsEqual, cryIsNotEqual, cryIsGeq, cryIsPrime, cryIsNotPrime ) import Cryptol.TypeCheck.Solver.Class ( solveDerivedInst , solveZeroInst, solveLogicInst, solveRingInst@@ -67,6 +68,7 @@ TCon (PC PValidFloat) [t1,t2] -> solveValidFloat t1 t2 TCon (PC PPrime) [ty] -> cryIsPrime ctxt ty+ TCon (PC PNotPrime) [ty] -> cryIsNotPrime ctxt ty TCon (PC PFin) [ty] -> cryIsFinType ctxt ty TCon (PC PEqual) [t1,t2] -> cryIsEqual ctxt t1 t2
src/Cryptol/TypeCheck/Solver/InfNat.hs view
@@ -145,7 +145,7 @@ nLg2 :: Nat' -> Nat' nLg2 Inf = Inf nLg2 (Nat 0) = Nat 0-nLg2 (Nat n) = case genLog n 2 of+nLg2 (Nat n) = case genLog 2 n of Just (x,exact) | exact -> Nat x | otherwise -> Nat (x + 1) Nothing -> panic "Cryptol.TypeCheck.Solver.InfNat.nLg2"@@ -225,12 +225,12 @@ -- | 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.+-- The logarithm base is the first 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)+genLog 0 x = if x == 1 then Just (0, True) else Nothing+genLog 1 _ = Nothing+genLog _ 0 = Nothing+genLog base x = Just (exactLoop 0 x) where exactLoop s i | i == 1 = (s,True)
src/Cryptol/TypeCheck/Solver/Numeric.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards, MagicHash, MultiWayIf, TypeOperators #-} module Cryptol.TypeCheck.Solver.Numeric- ( cryIsEqual, cryIsNotEqual, cryIsGeq, cryIsPrime, primeTable+ ( cryIsEqual, cryIsNotEqual, cryIsGeq, cryIsPrime, cryIsNotPrime, primeTable ) where import Control.Applicative(Alternative(..))@@ -52,7 +52,11 @@ -- | Try to solve @t1 /= t2@ cryIsNotEqual :: Ctxt -> Type -> Type -> Solved-cryIsNotEqual _i t1 t2 = matchDefault Unsolved (pBin (/=) t1 t2)+cryIsNotEqual i t1 t2 =+ matchDefault Unsolved $+ (pBin (/=) t1 t2)+ <|> (aNat' t1 >>= tryNeqK i t2)+ <|> (aNat' t2 >>= tryNeqK i t1) -- | Try to solve @t1 >= t2@ cryIsGeq :: Ctxt -> Type -> Type -> Solved@@ -95,7 +99,22 @@ _ -> Unsolved +cryIsNotPrime :: Ctxt -> Type -> Solved+cryIsNotPrime _varInfo ty =+ case tNoUser ty of + TCon (TC tc) []+ | TCNum n <- tc ->+ if untrie primeTable n then+ Unsolvable+ else+ SolvedIf []++ | TCInf <- tc -> SolvedIf []++ _ -> Unsolved++ -- | Try to solve something by evaluation. pBin :: (Nat' -> Nat' -> Bool) -> Type -> Type -> Match Solved pBin p t1 t2@@ -124,6 +143,28 @@ Inf -> [ b =#= tZero ] Nat 0 -> [] Nat k -> [ tNum (div n k) >== b ]+ <|>+ -- K1 >= K2 ^^ t ~~> logBase K2 K1 >= t+ do let k1 = n+ (k2, t) <- matches ty ((|^|), aNat, __)+ case genLog k2 k1 of+ Just (logBaseK2K1,True) -> pure $ SolvedIf [ tNum logBaseK2K1 >== t ]+ _ -> pure Unsolved+ <|>+ -- K1 >= 1 + (K2 ^^ t) ~~> logBase K2 K1 >= 1 + t+ --+ -- Or, equivalently,+ --+ -- K1 > K2 ^^ t ~~> logBase K2 K1 > t+ do let k1 = n+ (oneTy,ty') <- anAdd ty+ oneK <- aNat oneTy+ guard (oneK == 1)+ (k2, t) <- matches ty' ((|^|), aNat, __)+ case genLog k2 k1 of+ Just (logBaseK2K1,True) ->+ pure $ SolvedIf [ tNum logBaseK2K1 >== tf2 TCAdd (tNum oneK) t ]+ _ -> pure Unsolved -- | Try to solve @t >= K@ tryGeqThanK :: Ctxt -> Type -> Nat' -> Match Solved@@ -136,12 +177,72 @@ return $ SolvedIf $ if n >= k then [] else [ b >== tNum (k - n) ]- -- XXX: K1 ^^ n >= K2+ <|>+ -- K1 ^^ t >= K2 ~~> t >= logBase K1 K2+ do (k1, t') <- matches t ((|^|), aNat, __)+ let k2 = k+ case genLog k1 k2 of+ -- Only apply the rewrite if logBase returns an exact result.+ -- See Note [Don't weaken inequalities involving logBase].+ Just (logBaseK1K2,True) -> pure $ SolvedIf [ t' >== tNum logBaseK1K2 ]+ _ ->+ -- K1 ^^ t >= 1 + K2 ~~> t >= 1 + logBase K1 K2+ --+ -- Or, equivalently,+ --+ -- K1 ^^ t > K2 ~~> t > logBase K2 K1+ do let k2Plus1 = k+ guard (k2Plus1 > 0)+ case genLog k1 (k2Plus1-1) of+ -- Only apply the rewrite if logBase returns an exact result.+ -- See Note [Don't weaken inequalities involving logBase].+ Just (logBaseK1K2,True) ->+ pure $ SolvedIf [ t' >== tNum (1+logBaseK1K2) ]+ _ -> pure Unsolved +{-+Note [Don't weaken inequalities involving logBase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the logBase(base, x) function, which returns the number y such that+`x = base^^y`. In most math settings, logBase works over real numbers, but in+Cryptol, all type-level numeric operators are restricted to natural numbers, so+Cryptol defines logBase to round down to the nearest natural number if the+result is inexact (i.e., if logBase would have otherwise returned a real+number). For instance, this means that: + logBase 2 2 == 1 (exact result)+ logBase 2 3 == 1 (inexact result)++Now consider the following rewrites in tryGetThanK:++ K1 ^^ t >= K2 ~~> t >= logBase K1 K2+ K1 ^^ t > K2 ~~> t > logBase K1 K2++Cryptol will only apply these rewrites if `logBase K1 K2` return exact results.+Note that the left-hand sides of the `~~>` rewrites would still imply the+right-hand sides even if the `logBase` results were inexact, but the resulting+inequalities would be weaker than before. To see why this can be a problem,+consider the following function:++ f : {n} (2^^(2^^n) >= 3) => [n]+ f = [False] # zero++The body of `f` will only typecheck if `n > 0`. Critically, we do /not/ want to+apply the `K1 ^^ t >= K2 ~~> t >= logBase K1 K2` rewrite above. If we did,+the following chain of rewrites would occur:++ 2^^(2^^n) >= 3 ~~> 2^^n >= 1 (since `logBase 2 3 == 1` with an inexact result)+ 2^^n >= 1 ~~> n >= 0 (since `logBase 2 1 == 0` with an exact result)++But now Cryptol is left with `n >= 0`, which does not imply `n > 0`! As a+result, Cryptol cannot typecheck `f`, which is terrible. Moral of the story:+only apply the rewrites above if `logBase` returns exact results, which+prevents this sort of constraint weakening.+-}+ -- (K >= 2 && K^a >= K^b) => a >= b tryGeqExp :: Ctxt -> Type -> Type -> Match Solved-tryGeqExp _ x y = +tryGeqExp _ x y = do (k_1, a) <- (|^|) x n <- aNat k_1 guard (n >= 2)@@ -248,16 +349,16 @@ -- if (K >= 2) && K^a = K^b => a = b tryEqExp :: Type -> Type -> Match Solved tryEqExp x y = check x y <|> check y x- where + where check i j =- do + do (k_1, a) <- (|^|) i n <- aNat k_1 guard (n >= 2) (k_2, b) <- (|^|) j guard (k_1 == k_2) return $ SolvedIf [ a =#= b ]- + -- min t1 t2 = t1 ~> t1 <= t2 tryEqMin :: Type -> Type -> Match Solved tryEqMin x y =@@ -333,7 +434,7 @@ --- e.g., 10 = t+-- (K = t) (e.g., 10 = t) tryEqK :: Ctxt -> Type -> Nat' -> Match Solved tryEqK ctxt ty lk = @@ -386,10 +487,11 @@ <|> -- K1 == K2 ^^ t ~~> t = logBase K2 K1- do (rk, b) <- matches ty ((|^|), aNat, __)+ do (k2, t) <- 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]+ Inf | k2 > 1 -> SolvedIf [ t =#= tInf ]+ Nat k1 | Just (logBaseK2K1,True) <- genLog k2 k1 ->+ SolvedIf [ t =#= tNum logBaseK2K1] _ -> Unsolvable -- XXX: Min, Max, etx@@ -398,6 +500,18 @@ -- 10 = min (2,y) --> impossible +-- K != t (e.g., 10 = t)+tryNeqK :: Ctxt -> Type -> Nat' -> Match Solved+tryNeqK _ ty lk =++ -- K1 != K2 ^^ t ~~> t != logBase K2 K1+ do (k2, t) <- matches ty ((|^|), aNat, __)+ return $ case lk of+ Inf | k2 > 1 -> SolvedIf [ t =/= tInf ]+ Nat k1 | Just (logBaseK2K1,True) <- genLog k2 k1 ->+ SolvedIf [ t =/= tNum logBaseK2K1]+ _ -> SolvedIf []+ -- | K1 * t1 + K2 * t2 + ... = K3 * t3 + K4 * t4 + ... tryEqMulConst :: Type -> Type -> Match Solved tryEqMulConst l r =@@ -462,7 +576,7 @@ tryLinearSolution :: Ctxt -> Type -> Type -> Match Solved tryLinearSolution ctxt s1 t = do (a,xs) <- matchLinearUnifier t- guard (noFreeVariables s1) + guard (noFreeVariables s1) -- NB: matchLinearUnifier only matches if xs is nonempty let s2 = foldr1 Simp.tAdd xs
src/Cryptol/TypeCheck/Solver/SMT.hs view
@@ -19,6 +19,7 @@ , startSolver , stopSolver , killSolver+ , SolverTimeout(..) , isNumeric , resetSolver @@ -44,6 +45,8 @@ import qualified Data.Set as Set import Data.Maybe(catMaybes,isJust) import Data.List(partition)+import Control.Concurrent(forkIO,killThread,threadDelay)+import Control.Concurrent.MVar(newEmptyMVar,putMVar,takeMVar) import Control.Exception import Control.Monad(msum,zipWithM,void) import Data.Char(isSpace)@@ -72,8 +75,16 @@ , logger :: SMT.Logger -- ^ For debugging++ , timeoutSeconds :: Int+ -- ^ Timeout for individual solver queries } +newtype SolverTimeout = SolverTimeout Int+ deriving Show++instance Exception SolverTimeout+ setupSolver :: Solver -> SolverConfig -> IO () setupSolver s cfg = do _ <- SMT.setOptionMaybe (solver s) ":global-decls" "false"@@ -115,7 +126,11 @@ , SMT.solverLogger = maybe SMT.noSolverLogger SMT.smtSolverLogger smtDbg }- let sol = Solver solver logger+ let sol = Solver+ { solver = solver+ , logger = logger+ , timeoutSeconds = solverTimeout sCfg+ } setupSolver sol sCfg return sol @@ -144,6 +159,28 @@ withSolver :: IO () -> SolverConfig -> (Solver -> IO a) -> IO a withSolver onExit cfg = bracket (startSolver onExit cfg) stopSolver +check :: Solver -> IO SMT.Result+check s+ | timeoutSeconds s <= 0 = SMT.check (solver s)+ | otherwise =+ do resultVar <- newEmptyMVar+ _ <- forkIO $+ do result <- try (SMT.check (solver s))+ putMVar resultVar (Just result)+ timerThread <- forkIO $+ do threadDelay (timeoutSeconds s * 1000000)+ putMVar resultVar Nothing+ result <- takeMVar resultVar+ case result of+ Nothing ->+ do killSolver s+ throwIO (SolverTimeout (timeoutSeconds s))+ Just checkResult ->+ do killThread timerThread+ case checkResult of+ Left ex -> throwIO (ex :: SomeException)+ Right a -> pure a+ -- | Load the definitions used for type checking. loadTcPrelude :: Solver -> [FilePath] {- ^ Search in this paths -} -> IO () loadTcPrelude s [] = loadString s cryptolTcContents@@ -261,7 +298,7 @@ do push sol tvs <- Map.fromList <$> zipWithM (declareVar sol) [ 0 .. ] as mapM_ (assume sol tvs) ps- sat <- SMT.check (solver sol)+ sat <- check sol su <- case sat of SMT.Sat -> case as of@@ -351,7 +388,7 @@ do let s = solver sol push sol SMT.assert s (SMT.fun "cryProve" [ toSMT tvs (goal g) ])- res <- SMT.check s+ res <- check sol pop sol case res of SMT.Unsat -> return Nothing@@ -364,7 +401,7 @@ debugBlock sol "UNSOLVABLE" $ do SMT.push (solver sol) mapM_ (assume sol tvs) ps- res <- SMT.check (solver sol)+ res <- check sol SMT.pop (solver sol) case res of SMT.Unsat -> return True@@ -382,7 +419,7 @@ -- | Assumes no 'And' isNumeric :: Prop -> Bool isNumeric ty = matchDefault False $ msum [ is (|=|), is (|/=|), is (|>=|)- , is aFin, is aPrime ]+ , is aFin, is aPrime, is aNotPrime ] where is f = f ty >> return True @@ -403,6 +440,7 @@ , aFin ~> "cryFin" , aPrime ~> "cryPrime"+ , aNotPrime ~> "cryNotPrime" , (|=|) ~> "cryEq" , (|/=|) ~> "cryNeq" , (|>=|) ~> "cryGeq"
src/Cryptol/TypeCheck/TCon.hs view
@@ -70,6 +70,7 @@ , ">=" ~> PC PGeq , "fin" ~> PC PFin , "prime" ~> PC PPrime+ , "notPrime" ~> PC PNotPrime , "Zero" ~> PC PZero , "Logic" ~> PC PLogic , "Ring" ~> PC PRing@@ -149,6 +150,7 @@ PGeq -> KNum :-> KNum :-> KProp PFin -> KNum :-> KProp PPrime -> KNum :-> KProp+ PNotPrime -> KNum :-> KProp PHas _ -> KType :-> KType :-> KProp PZero -> KType :-> KProp PLogic -> KType :-> KProp@@ -198,6 +200,7 @@ | PGeq -- ^ @_ >= _@ | PFin -- ^ @fin _@ | PPrime -- ^ @prime _@+ | PNotPrime -- ^ @notPrime _@ -- classes | PHas Selector -- ^ @Has sel type field@ does not appear in schemas@@ -289,6 +292,7 @@ PGeq -> text "(>=)" PFin -> text "fin" PPrime -> text "prime"+ PNotPrime -> text "notPrime" PHas sel -> parens (ppSelector sel) PZero -> text "Zero" PLogic -> text "Logic"
src/Cryptol/TypeCheck/Type.hs view
@@ -50,9 +50,11 @@ allParamNames :: FunctorParams -> ModParamNames allParamNames mps = ModParamNames- { mpnTypes = Map.unions (map mpnTypes ps)- , mpnConstraints = concatMap mpnConstraints ps- , mpnFuns = Map.unions (map mpnFuns ps)+ { mpnParams = ParamDecls+ { pdTypes = Map.unions (map mpnTypes ps)+ , pdFuns = Map.unions (map mpnFuns ps)+ , pdConstraints = concatMap mpnConstraints ps+ } , mpnTySyn = Map.unions (map mpnTySyn ps) , mpnDoc = Nothing }@@ -81,25 +83,26 @@ } 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+ { mpnParams :: ParamDecls+ -- ^ Type parameters, value parameters, and constraints , 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) +mpnTypes :: ModParamNames -> Map Name ModTParam+mpnTypes = pdTypes . mpnParams++mpnFuns :: ModParamNames -> Map.Map Name ModVParam+mpnFuns = pdFuns . mpnParams++mpnConstraints :: ModParamNames -> [Located Prop]+mpnConstraints = pdConstraints . mpnParams+ -- | A type parameter of a module. data ModTParam = ModTParam { mtpName :: Name@@ -126,6 +129,28 @@ , mvpDoc :: Maybe Text , mvpFixity :: Maybe Fixity -- XXX: This should be in the name? } deriving (Show,Generic,NFData)++-- | Type and value parameters declared directly by a module or interface.+data ParamDecls = ParamDecls+ { pdTypes :: Map Name ModTParam+ , pdFuns :: Map Name ModVParam+ , pdConstraints :: [Located Prop]+ } deriving (Show, Generic, NFData)++instance Semigroup ParamDecls where+ x <> y = ParamDecls+ { pdTypes = pdTypes x <> pdTypes y+ , pdFuns = pdFuns x <> pdFuns y+ , pdConstraints = pdConstraints x <> pdConstraints y+ }++instance Monoid ParamDecls where+ mempty = ParamDecls+ { pdTypes = mempty+ , pdFuns = mempty+ , pdConstraints = mempty+ }+ -------------------------------------------------------------------------------- @@ -643,6 +668,11 @@ TCon (PC PPrime) [t1] -> Just t1 _ -> Nothing +pIsNotPrime :: Prop -> Maybe Type+pIsNotPrime ty = case tNoUser ty of+ TCon (PC PNotPrime) [t1] -> Just t1+ _ -> Nothing+ pIsGeq :: Prop -> Maybe (Type,Type) pIsGeq ty = case tNoUser ty of TCon (PC PGeq) [t1,t2] -> Just (t1,t2)@@ -653,6 +683,11 @@ TCon (PC PEqual) [t1,t2] -> Just (t1,t2) _ -> Nothing +pIsNeq :: Prop -> Maybe (Type,Type)+pIsNeq ty = case tNoUser ty of+ TCon (PC PNeq) [t1,t2] -> Just (t1,t2)+ _ -> Nothing+ pIsZero :: Prop -> Maybe Type pIsZero ty = case tNoUser ty of TCon (PC PZero) [t1] -> Just t1@@ -975,6 +1010,14 @@ -- not True <=> 0 == 1 PTrue -> [TCon (PC PEqual) [tZero, tOne]] + -- not (prime p) <=> notPrime p+ PPrime | [ty] <- tys -> [TCon (PC PNotPrime) [ty]]+ | otherwise -> bad++ -- not (notPrime p) <=> prime p+ PNotPrime | [ty] <- tys -> [TCon (PC PPrime) [ty]]+ | otherwise -> bad+ _ -> bad TError _ki -> [prop] -- propogates `TError`@@ -1107,9 +1150,9 @@ ctrs = case ntConstraints nt of [] -> mempty _ -> parens (commaSep (map ppC (ntConstraints nt))) <+> "=>"- + instance PP Schema where ppPrec = ppWithNamesPrec IntMap.empty @@ -1118,15 +1161,15 @@ withPPCfg $ \cfg -> let 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 cfg (sVars s) ns in if null (sVars s) && null (sProps s) then body@@ -1179,18 +1222,18 @@ -- * 5: @atype@ instance PP (WithNames Type) where ppPrec prec ty0@(WithNames ty nmMap) =+ withNameDisp $ \disp -> case ty of TVar a -> ppWithNames nmMap a TNominal 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 ]+ [ nest 1 (pp l <+> text ":" </> go 0 t) | (l,t) <- displayFields fs ] - _ | Just tinf <- isTInfix ty0 -> optParens (prec > 2)- $ ppInfix 2 isTInfix tinf+ _ | Just tinf <- isTInfix disp ty0 ->+ optParens (prec > 2) $ ppInfix 2 (isTInfix disp) 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@@ -1227,6 +1270,7 @@ (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)+ (PNotPrime, [t1]) -> optParens (prec > 3) $ text "notPrime" <+> (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))))@@ -1248,13 +1292,15 @@ where go p t = ppWithNamesPrec nmMap p t - isTInfix (WithNames (TCon tc [ieLeft',ieRight']) _) =+ 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'] _) _)+ isTInfix disp (WithNames (TUser n [ieLeft',ieRight'] n') env)+ | Just og <- asOrigName n, NotInScope <- getNameFormat og disp =+ isTInfix disp (WithNames n' env) | isInfixIdent (nameIdent n) = do let ieLeft = WithNames ieLeft' nmMap ieRight = WithNames ieRight' nmMap@@ -1262,7 +1308,7 @@ ieOp = nameIdent n return Infix { .. } - isTInfix _ = Nothing+ isTInfix _ _ = Nothing @@ -1387,7 +1433,7 @@ | not (null (mpnConstraints ps)) ] ++ [ pp t | t <- Map.elems (mpnTySyn ps) ] ++- map pp (Map.elems (mpnFuns ps)) + map pp (Map.elems (mpnFuns ps)) instance PP ModTParam where ppPrec _ p =@@ -1395,5 +1441,11 @@ instance PP ModVParam where ppPrec _ p = pp (mvpName p) <+> ":" <+> pp (mvpType p)++instance PP ParamDecls where+ ppPrec _ pd =+ vcat (map pp (Map.elems (pdTypes pd)) +++ [ pp (thing c) | c <- pdConstraints pd ] +++ map pp (Map.elems (pdFuns pd)))
src/Cryptol/TypeCheck/TypePat.hs view
@@ -25,7 +25,7 @@ , aRec , (|->|) - , aFin, aPrime, (|=|), (|/=|), (|>=|)+ , aFin, aPrime, aNotPrime, (|=|), (|/=|), (|>=|) , aAnd , aTrue @@ -168,6 +168,9 @@ aPrime :: Pat Prop Type aPrime = tp PPrime ar1++aNotPrime :: Pat Prop Type+aNotPrime = tp PNotPrime ar1 (|=|) :: Pat Prop (Type,Type) (|=|) = tp PEqual ar2
src/Cryptol/Utils/Ident.hs view
@@ -402,7 +402,7 @@ instance NFData MaybeAnon --- | Modify a name, if it is a nonymous.+-- | Modify a name, if it is anonymous. -- If we change this, please update the reference manual as well, so that -- folks know how to refer to these in external tools. maybeAnonText :: MaybeAnon -> Text -> Text
src/Cryptol/Utils/PP.hs view
@@ -134,6 +134,9 @@ debugShowUniques :: Doc -> Doc debugShowUniques = updPPCfg \cfg -> cfg { ppcfgShowNameUniques = True } +debugHidePreludeNames :: Doc -> Doc+debugHidePreludeNames = updPPCfg \cfg -> cfg { ppcfgHidePreludeNames = True }+ setAnnotStyle :: AnnotStyle -> Doc -> Doc setAnnotStyle s = updPPCfg \cfg -> cfg { ppcfgAnnotStyle = s } @@ -144,6 +147,7 @@ data PPCfg = PPCfg { ppcfgNameDisp :: NameDisp , ppcfgShowNameUniques :: Bool+ , ppcfgHidePreludeNames :: Bool , ppcfgAnnotStyle :: AnnotStyle } @@ -151,6 +155,7 @@ defaultPPCfg = PPCfg { ppcfgNameDisp = mempty , ppcfgShowNameUniques = False+ , ppcfgHidePreludeNames = False , ppcfgAnnotStyle = AnsiAnnot } @@ -160,7 +165,7 @@ -- | How to render annotations data AnnotStyle = NoAnnot | AnsiAnnot | MarkdownAnnot --- The underlyng `Doc` type we (i.e., without the additional configuration)+-- The underlying `Doc` type we (i.e., without the additional configuration) type PPDoc = PP.Doc (AnnotStyle, PPAnnot) @@ -441,7 +446,14 @@ ppPrec _ str = text (T.unpack str) instance PP Ident where- ppPrec _ i = text (T.unpack (identText i))+ ppPrec _ i =+ withPPCfg (\cfg ->+ let base = text (T.unpack (identText i))+ in+ if ppcfgShowNameUniques cfg && not (identIsNormal i)+ then base <.> "/*sys*/"+ else base)+ instance PP ModName where ppPrec _ = text . T.unpack . modNameToText