diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,103 @@ +# 3.0.0 -- 2023-06-26 + +## Language changes + +* Cryptol now includes a redesigned module system that is significantly more + expressive than in previous releases. The new module system includes the + following features: + + * Nested modules: Modules may now be defined within other modules. + + * Named interfaces: An interface specifies the parameters to a module. + Separating the interface from the parameter declarations makes it possible + to have different parameters that use the same interface. + + * Top-level module constraints: These are useful to specify constraints + between different module parameters (i.e., ones that come from different + interfaces or multiple copies of the same interface). + + See the + [manual section](https://galoisinc.github.io/cryptol/master/Modules.html#instantiation-by-parametrizing-declarations) + for more information. + +* Declarations may now use *numeric constraint guards*. This is a feature + that allows a function to behave differently depending on its numeric + type parameters. See the [manual section](https://galoisinc.github.io/cryptol/master/BasicSyntax.html#numeric-constraint-guards)) + for more information. + +* The foreign function interface (FFI) has been added, which allows Cryptol to + call functions written in C. See the [manual section](https://galoisinc.github.io/cryptol/master/FFI.html) + for more information. + +* The unary `-` operator now has the same precedence as binary `-`, meaning + expressions like `-x^^2` will now parse as `-(x^^2)` instead of `(-x)^^2`. + **This is a breaking change.** A warning has been added in cases where the + behavior has changed, and can be disabled with `:set warnPrefixAssoc=off`. + +* Infix operators are now allowed in import lists: `import M ((<+>))` will + import only the operator `<+>` from module `M`. + +* `lib/Array.cry` now contains an `arrayEq` primitive. Like the other + array-related primitives, this has no computational interpretation (and + therefore cannot be used in the Cryptol interpreter), but it is useful for + stating specifications that are used in SAW. + +## New features + +* Add a `:time` command to benchmark the evaluation time of expressions. + +* Add support for literate Cryptol using reStructuredText. Cryptol code + is extracted from `.. code-block:: cryptol` and `.. sourcecode:: cryptol` + directives. + +* Add a syntax highlight file for Vim, + available in `syntax-highlight/cryptol.vim` + +* Add `:new-seed` and `:set-seed` commands to the REPL. + These affect random test generation, + and help write reproducable Cryptol scripts. + +* Add support for the CVC5 solver, which can be selected with + `:set prover=cvc5`. If you want to specify a What4 or SBV backend, you can + use `:set prover=w4-cvc5` or `:set prover=sbv-cvc5`, respectively. (Note that + `sbv-cvc5` is non-functional on Windows at this time due to a downstream issue + with CVC5 1.0.4 and earlier.) + +* Add `:file-deps` commands to the REPL and Python API. + It shows information about the source files and dependencies of + modules or Cryptol files. + +## Bug fixes + +* Fix a bug in the What4 backend that could cause applications of `(@)` with + symbolic `Integer` indices to become out of bounds (#1359). + +* Fix a bug that caused finite bitvector enumerations to panic when used in + combination with `(#)` (e.g., `[0..1] # 0`). + +* Cryptol's markdown parser is slightly more permissive and will now parse code + blocks with whitespace in between the backticks and `cryptol`. This sort of + whitespace is often inserted by markdown generation tools such as `pandoc`. + +* Improve documentation for `fromInteger` (#1465) + +* Closed issues #812, #977, #1090, #1140, #1147, #1253, #1322, #1324, #1329, + #1344, #1347, #1351, #1354, #1355, #1359, #1366, #1368, #1370, #1371, #1372, + #1373, #1378, #1383, #1385, #1386, #1391, #1394, #1395, #1396, #1398, #1399, + #1404, #1415, #1423, #1435, #1439, #1440, #1441, #1442, #1444, #1445, #1448, + #1449, #1450, #1451, #1452, #1456, #1457, #1458, #1462, #1465, #1466, #1470, + #1475, #1480, #1483, #1484, #1485, #1487, #1488, #1491, #1496, #1497, #1501, + #1503, #1510, #1511, #1513, and #1514. + +* Merged pull requests #1184, #1205, #1279, #1356, #1357, #1358, #1361, #1363, + #1365, #1367, #1376, #1379, #1380, #1384, #1387, #1388, #1393, #1401, #1402, + #1403, #1406, #1408, #1409, #1410, #1411, #1412, #1413, #1414, #1416, #1417, + #1418, #1419, #1420, #1422, #1424, #1429, #1430, #1431, #1432, #1436, #1438, + #1443, #1447, #1453, #1454, #1459, #1460, #1461, #1463, #1464, #1467, #1468, + #1472, #1473, #1474, #1476, #1477, #1478, #1481, #1493, #1499, #1502, #1504, + #1506, #1509, #1512, #1516, #1518, #1519, #1520, #1521, #1523, #1527, and + #1528. + # 2.13.0 ## Language changes diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -26,7 +26,6 @@ import qualified Cryptol.ModuleSystem.Env as M import qualified Cryptol.ModuleSystem.Monad as M import qualified Cryptol.ModuleSystem.NamingEnv as M -import Cryptol.ModuleSystem.Interface (noIfaceParams) import qualified Cryptol.Parser as P import qualified Cryptol.Parser.AST as P @@ -130,7 +129,7 @@ , M.tcLinter = M.moduleLinter (P.thing (P.mName scm)) , M.tcPrims = prims } - M.typecheck act scm noIfaceParams tcEnv + M.typecheck act scm mempty tcEnv ceval :: String -> String -> FilePath -> T.Text -> Benchmark ceval cd name path expr = diff --git a/cryptol.cabal b/cryptol.cabal --- a/cryptol.cabal +++ b/cryptol.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.4 Name: cryptol -Version: 2.13.0 +Version: 3.0.0 Synopsis: Cryptol: The Language of Cryptography Description: Cryptol is a domain-specific language for specifying cryptographic algorithms. A Cryptol implementation of an algorithm resembles its mathematical specification more closely than an implementation in a general purpose language. For more, see . License: BSD-3-Clause @@ -9,11 +9,12 @@ Maintainer: cryptol@galois.com Homepage: http://www.cryptol.net/ Bug-reports: https://github.com/GaloisInc/cryptol/issues -Copyright: 2013-2021 Galois Inc. +Copyright: 2013-2022 Galois Inc. Category: Language Build-type: Simple extra-source-files: bench/data/*.cry CHANGES.md + lib/*.cry lib/*.z3 data-files: **/*.cry **/*.z3 data-dir: lib @@ -26,7 +27,7 @@ type: git location: https://github.com/GaloisInc/cryptol.git -- add a tag on release branches - tag: 2.13.0 + tag: 3.0.0 flag static @@ -37,6 +38,10 @@ default: True description: Don't use the Cabal-provided data directory for looking up Cryptol libraries. This is useful when the data directory can't be known ahead of time, like for a relocatable distribution. +flag ffi + default: True + description: Enable the foreign function interface + library Default-language: Haskell2010 @@ -48,6 +53,7 @@ bytestring >= 0.10, array >= 0.4, containers >= 0.5, + criterion-measurement, cryptohash-sha1 >= 0.11 && < 0.12, deepseq >= 1.3, directory >= 1.2.2.0, @@ -57,30 +63,44 @@ ghc-prim, GraphSCC >= 1.0.4, heredoc >= 0.2, + language-c99, + language-c99-simple, libBF >= 0.6 && < 0.7, MemoTrie >= 0.6 && < 0.7, monad-control >= 1.0, monadLib >= 3.7.2, parameterized-utils >= 2.0.2, + pretty, prettyprinter >= 1.7.0, + pretty-show, process >= 1.2, - sbv >= 8.10 && < 9.1, + sbv >= 9.1 && < 10.2, simple-smt >= 0.9.7, stm >= 2.4, strict, text >= 1.1, tf-random >= 0.5, transformers-base >= 0.4, + vector, mtl >= 2.2.1, time >= 1.6.0.1, panic >= 0.3, - what4 >= 1.3 && < 1.4 + what4 >= 1.4 && < 1.5 if impl(ghc >= 9.0) - build-depends: ghc-bignum >= 1.0 && < 1.3 + build-depends: ghc-bignum >= 1.0 && < 1.4 else build-depends: integer-gmp >= 1.0 && < 1.1 + if flag(ffi) + build-depends: hgmp, + libffi >= 0.2 + if os(windows) + build-depends: Win32 + else + build-depends: unix + cpp-options: -DFFI_ENABLED + Build-tool-depends: alex:alex, happy:happy hs-source-dirs: src @@ -93,6 +113,7 @@ Cryptol.Parser.Names, Cryptol.Parser.Name, Cryptol.Parser.NoPat, + Cryptol.Parser.ExpandPropGuards, Cryptol.Parser.NoInclude, Cryptol.Parser.Selector, Cryptol.Parser.Utils, @@ -107,6 +128,8 @@ Cryptol.Utils.Misc, Cryptol.Utils.Patterns, Cryptol.Utils.Logger, + Cryptol.Utils.Benchmark, + Cryptol.Utils.Types, Cryptol.Version, Cryptol.ModuleSystem, @@ -116,10 +139,13 @@ Cryptol.ModuleSystem.Interface, Cryptol.ModuleSystem.Monad, Cryptol.ModuleSystem.Name, + Cryptol.ModuleSystem.Names, Cryptol.ModuleSystem.NamingEnv, + Cryptol.ModuleSystem.Binds Cryptol.ModuleSystem.Exports, - Cryptol.ModuleSystem.InstantiateModule, Cryptol.ModuleSystem.Renamer, + Cryptol.ModuleSystem.Renamer.Imports, + Cryptol.ModuleSystem.Renamer.ImplicitImports, Cryptol.ModuleSystem.Renamer.Monad, Cryptol.ModuleSystem.Renamer.Error, @@ -132,7 +158,6 @@ Cryptol.TypeCheck.Parseable, Cryptol.TypeCheck.Monad, Cryptol.TypeCheck.Infer, - Cryptol.TypeCheck.CheckModuleInstance, Cryptol.TypeCheck.InferTypes, Cryptol.TypeCheck.Interface, Cryptol.TypeCheck.Error, @@ -147,6 +172,12 @@ Cryptol.TypeCheck.TypeMap, Cryptol.TypeCheck.TypeOf, Cryptol.TypeCheck.Sanity, + Cryptol.TypeCheck.FFI, + Cryptol.TypeCheck.FFI.Error, + Cryptol.TypeCheck.FFI.FFIType, + Cryptol.TypeCheck.Module, + Cryptol.TypeCheck.ModuleInstance, + Cryptol.TypeCheck.ModuleBacktickInstance, Cryptol.TypeCheck.Solver.Types, Cryptol.TypeCheck.Solver.SMT, @@ -162,13 +193,15 @@ Cryptol.Transform.MonoValues, Cryptol.Transform.Specialize, - Cryptol.Transform.AddModParams, Cryptol.IR.FreeVars, + Cryptol.IR.TraverseNames, Cryptol.Backend, Cryptol.Backend.Arch, Cryptol.Backend.Concrete, + Cryptol.Backend.FFI, + Cryptol.Backend.FFI.Error, Cryptol.Backend.FloatHelpers, Cryptol.Backend.Monad, Cryptol.Backend.SeqMap, @@ -179,6 +212,8 @@ Cryptol.Eval, Cryptol.Eval.Concrete, Cryptol.Eval.Env, + Cryptol.Eval.FFI, + Cryptol.Eval.FFI.GenHeader, Cryptol.Eval.Generic, Cryptol.Eval.Prims, Cryptol.Eval.Reference, @@ -199,6 +234,7 @@ Cryptol.Symbolic.What4, Cryptol.REPL.Command, + Cryptol.REPL.Help, Cryptol.REPL.Browse, Cryptol.REPL.Monad, Cryptol.REPL.Trie diff --git a/cryptol/CheckExercises.hs b/cryptol/CheckExercises.hs --- a/cryptol/CheckExercises.hs +++ b/cryptol/CheckExercises.hs @@ -291,7 +291,7 @@ if Seq.null (rdReplout rd) then do let cryCmd = (P.shell (exe ++ " --interactive-batch " ++ inFile ++ " -e")) - (cryEC, cryOut, _) <- P.readCreateProcessWithExitCode cryCmd "" + (cryEC, cryOut, cryErr) <- P.readCreateProcessWithExitCode cryCmd "" Line lnReplinStart _ Seq.:<| _ <- return $ rdReplin rd @@ -301,6 +301,7 @@ putStrLn $ "REPL error (replin lines " ++ show lnReplinStart ++ "-" ++ show lnReplinEnd ++ ")." putStr cryOut + putStr cryErr exitFailure ExitSuccess -> do -- remove temporary input file diff --git a/cryptol/Main.hs b/cryptol/Main.hs --- a/cryptol/Main.hs +++ b/cryptol/Main.hs @@ -200,7 +200,7 @@ , "via the `:edit` command" ] ) - , ( "SBV_{ABC,BOOLECTOR,CVC4,MATHSAT,YICES,Z3}_OPTIONS" + , ( "SBV_{ABC,BOOLECTOR,CVC4,CVC5,MATHSAT,YICES,Z3}_OPTIONS" , [ "A string of command-line arguments to be passed to the" , "corresponding solver invoked for `:sat` and `:prove`" , "when using a prover via SBV" diff --git a/lib/Array.cry b/lib/Array.cry --- a/lib/Array.cry +++ b/lib/Array.cry @@ -10,6 +10,7 @@ primitive arrayConstant : {a, b} b -> (Array a b) primitive arrayLookup : {a, b} (Array a b) -> a -> b primitive arrayUpdate : {a, b} (Array a b) -> a -> b -> (Array a b) +primitive arrayEq : {n, a} (Array [n] a) -> (Array [n] a) -> Bool /** * Copy elements from the source array to the destination array. diff --git a/lib/Cryptol.cry b/lib/Cryptol.cry --- a/lib/Cryptol.cry +++ b/lib/Cryptol.cry @@ -339,11 +339,21 @@ primitive type Ring : * -> Prop /** - * Converts an unbounded integer to a value in a Ring. When converting - * to the bitvector type [n], the value is reduced modulo 2^^n. Likewise, - * when converting to Z n, the value is reduced modulo n. When converting - * to a floating-point value, the value is rounded to the nearest - * representable value. + * Converts an unbounded integer to a value in a Ring using the following rules: + * * to bitvector type [n]: + * the value is reduced modulo 2^^n, + * * to Z n: + * the value is reduced modulo n, + * * floating point types: + * the value is rounded to the nearest representable value, + * * sequences other than bitvectors: + * elements are computed by using `fromInteger` pointwise + * Example: (fromInteger 2 : [3][8]) === [ 0x02, 0x02, 0x02 ] + * * tuples and records: + * elements are computed by using `fromInteger` pointwise + * Example: (fromInteger 2 : (Integer,[3][8])) === (2, [ 0x2, 0x2, 0x2 ]) + * * functions: + * a constant function returning `fromInteger` on the result type */ primitive fromInteger : {a} (Ring a) => Integer -> a diff --git a/src/Cryptol/Backend/FFI.hs b/src/Cryptol/Backend/FFI.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Backend/FFI.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | The implementation of loading and calling external functions from shared +-- libraries. +module Cryptol.Backend.FFI + ( ForeignSrc + , getForeignSrcPath + , loadForeignSrc + , unloadForeignSrc + , foreignLibPath +#ifdef FFI_ENABLED + , ForeignImpl + , loadForeignImpl + , FFIArg + , FFIRet + , SomeFFIArg (..) + , callForeignImpl +#endif + ) + where + +import Control.DeepSeq + +import Cryptol.Backend.FFI.Error + +#ifdef FFI_ENABLED + +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad +import Data.Bifunctor +import Data.Word +import Foreign hiding (newForeignPtr) +import Foreign.C.Types +import Foreign.Concurrent +import Foreign.LibFFI +import System.FilePath ((-<.>)) +import System.Directory(doesFileExist) +import System.IO.Error +import System.Info(os) + +#if defined(mingw32_HOST_OS) +import System.Win32.DLL +#else +import System.Posix.DynamicLinker +#endif + +import Cryptol.Utils.Panic + +#else + +import GHC.Generics + +#endif + +#ifdef FFI_ENABLED + +-- | A source from which we can retrieve implementations of foreign functions. +data ForeignSrc = ForeignSrc + { -- | The file path of the 'ForeignSrc'. + foreignSrcPath :: FilePath + -- | The 'ForeignPtr' wraps the pointer returned by 'dlopen', where the + -- finalizer calls 'dlclose' when the library is no longer needed. We keep + -- references to the 'ForeignPtr' in each foreign function that is in the + -- evaluation environment, so that the shared library will stay open as long + -- as there are references to it. + , foreignSrcFPtr :: ForeignPtr () + -- | We support explicit unloading of the shared library so we keep track of + -- if it has already been unloaded, and if so the finalizer does nothing. + -- This is updated atomically when the library is unloaded. + , foreignSrcLoaded :: MVar Bool } + +instance Show ForeignSrc where + show = show . foreignSrcFPtr + +instance NFData ForeignSrc where + rnf ForeignSrc {..} = foreignSrcFPtr `seq` foreignSrcLoaded `deepseq` () + +-- | Get the file path of the 'ForeignSrc'. +getForeignSrcPath :: ForeignSrc -> Maybe FilePath +getForeignSrcPath = Just . foreignSrcPath + +-- | Load a 'ForeignSrc' for the given __Cryptol__ file path. The file path of +-- the shared library that we try to load is the same as the Cryptol file path +-- except with a platform specific extension. +loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc) +loadForeignSrc = loadForeignLib >=> traverse \(foreignSrcPath, ptr) -> do + foreignSrcLoaded <- newMVar True + foreignSrcFPtr <- newForeignPtr ptr (unloadForeignSrc' foreignSrcLoaded ptr) + pure ForeignSrc {..} + + +-- | Given the path to a Cryptol module, compute the location of +-- the shared library we'd like to load. +foreignLibPath :: FilePath -> IO (Maybe FilePath) +foreignLibPath path = + search + case os of + "mingw32" -> ["dll"] + "darwin" -> ["dylib","so"] + _ -> ["so"] + + where + search es = + case es of + [] -> pure Nothing + e : more -> + do let p = path -<.> e + yes <- doesFileExist p + if yes then pure (Just p) else search more + + +loadForeignLib :: FilePath -> IO (Either FFILoadError (FilePath, Ptr ())) +loadForeignLib path = + do mb <- foreignLibPath path + case mb of + Nothing -> pure (Left (CantLoadFFISrc path "File not found")) + Just libPath -> tryLoad (CantLoadFFISrc path) (open libPath) + + where open libPath = do +#if defined(mingw32_HOST_OS) + ptr <- loadLibrary libPath +#else + -- RTLD_NOW so we can make sure that the symbols actually exist at + -- module loading time + ptr <- undl <$> dlopen libPath [RTLD_NOW] +#endif + pure (libPath, ptr) + +-- | Explicitly unload a 'ForeignSrc' immediately instead of waiting for the +-- garbage collector to do it. This can be useful if you want to immediately +-- load the same library again to pick up new changes. +-- +-- The 'ForeignSrc' __must not__ be used in any way after this is called, +-- including calling 'ForeignImpl's loaded from it. +unloadForeignSrc :: ForeignSrc -> IO () +unloadForeignSrc ForeignSrc {..} = withForeignPtr foreignSrcFPtr $ + unloadForeignSrc' foreignSrcLoaded + +unloadForeignSrc' :: MVar Bool -> Ptr () -> IO () +unloadForeignSrc' loaded lib = modifyMVar_ loaded \l -> do + when l $ unloadForeignLib lib + pure False + +unloadForeignLib :: Ptr () -> IO () +#if defined(mingw32_HOST_OS) +unloadForeignLib = freeLibrary +#else +unloadForeignLib = dlclose . DLHandle +#endif + +withForeignSrc :: ForeignSrc -> (Ptr () -> IO a) -> IO a +withForeignSrc ForeignSrc {..} f = withMVar foreignSrcLoaded + \case + True -> withForeignPtr foreignSrcFPtr f + False -> + panic "[FFI] withForeignSrc" ["Use of foreign library after unload"] + +-- | An implementation of a foreign function. +data ForeignImpl = ForeignImpl + { foreignImplFun :: FunPtr () + -- | We don't need this to call the function but we want to keep the library + -- around as long as we still have a function from it so that it isn't + -- unloaded too early. + , foreignImplSrc :: ForeignSrc + } + +-- | Load a 'ForeignImpl' with the given name from the given 'ForeignSrc'. +loadForeignImpl :: ForeignSrc -> String -> IO (Either FFILoadError ForeignImpl) +loadForeignImpl foreignImplSrc name = + withForeignSrc foreignImplSrc \lib -> + tryLoad (CantLoadFFIImpl name) do + foreignImplFun <- loadForeignFunPtr lib name + pure ForeignImpl {..} + +loadForeignFunPtr :: Ptr () -> String -> IO (FunPtr ()) +#if defined(mingw32_HOST_OS) +loadForeignFunPtr source symbol = do + addr <- getProcAddress source symbol + pure $ castPtrToFunPtr addr +#else +loadForeignFunPtr = dlsym . DLHandle +#endif + +tryLoad :: (String -> FFILoadError) -> IO a -> IO (Either FFILoadError a) +tryLoad err = fmap (first $ err . displayException) . tryIOError + +-- | Types which can be converted into libffi arguments. +-- +-- The Storable constraint is so that we can put them in arrays. +class Storable a => FFIArg a where + ffiArg :: a -> Arg + +instance FFIArg Word8 where + ffiArg = argWord8 + +instance FFIArg Word16 where + ffiArg = argWord16 + +instance FFIArg Word32 where + ffiArg = argWord32 + +instance FFIArg Word64 where + ffiArg = argWord64 + +instance FFIArg CFloat where + ffiArg = argCFloat + +instance FFIArg CDouble where + ffiArg = argCDouble + +instance FFIArg (Ptr a) where + ffiArg = argPtr + +instance FFIArg CSize where + ffiArg = argCSize + +-- | Types which can be returned from libffi. +-- +-- The Storable constraint is so that we can put them in arrays. +class Storable a => FFIRet a where + ffiRet :: RetType a + +instance FFIRet Word8 where + ffiRet = retWord8 + +instance FFIRet Word16 where + ffiRet = retWord16 + +instance FFIRet Word32 where + ffiRet = retWord32 + +instance FFIRet Word64 where + ffiRet = retWord64 + +instance FFIRet CFloat where + ffiRet = retCFloat + +instance FFIRet CDouble where + ffiRet = retCDouble + +instance FFIRet () where + ffiRet = retVoid + +-- | Existential wrapper around a 'FFIArg'. +data SomeFFIArg = forall a. FFIArg a => SomeFFIArg a + +-- | Call a 'ForeignImpl' with the given arguments. The type parameter decides +-- how the return value should be converted into a Haskell value. +callForeignImpl :: forall a. FFIRet a => ForeignImpl -> [SomeFFIArg] -> IO a +callForeignImpl ForeignImpl {..} xs = withForeignSrc foreignImplSrc \_ -> + callFFI foreignImplFun (ffiRet @a) $ map toArg xs + where toArg (SomeFFIArg x) = ffiArg x + +#else + +data ForeignSrc = ForeignSrc deriving (Show, Generic, NFData) + +getForeignSrcPath :: ForeignSrc -> Maybe FilePath +getForeignSrcPath _ = Nothing + +loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc) +loadForeignSrc _ = pure $ Right ForeignSrc + +unloadForeignSrc :: ForeignSrc -> IO () +unloadForeignSrc _ = pure () + +#endif diff --git a/src/Cryptol/Backend/FFI/Error.hs b/src/Cryptol/Backend/FFI/Error.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Backend/FFI/Error.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} + +-- | Errors from dynamic loading of shared libraries for FFI. +module Cryptol.Backend.FFI.Error where + +import Control.DeepSeq +import GHC.Generics + +import Cryptol.Utils.PP +import Cryptol.ModuleSystem.Name + +data FFILoadError + = CantLoadFFISrc + FilePath -- ^ Path to cryptol module + String -- ^ Error message + | CantLoadFFIImpl + String -- ^ Function name + String -- ^ Error message + | FFIDuplicates [Name] + | FFIInFunctor Name + deriving (Show, Generic, NFData) + +instance PP FFILoadError where + ppPrec _ e = + case e of + CantLoadFFISrc path msg -> + hang ("Could not load foreign source for module located at" + <+> text path <.> colon) + 4 (text msg) + CantLoadFFIImpl name msg -> + hang ("Could not load foreign implementation for binding" + <+> text name <.> colon) + 4 (text msg) + FFIDuplicates xs -> + hang "Multiple foreign declarations with the same name:" + 4 (backticks (pp (nameIdent (head xs))) <+> + "defined at" <+> align (vcat (map (pp . nameLoc) xs))) + FFIInFunctor x -> + hang (pp (nameLoc x) <.> ":") + 4 "Foreign declaration" <+> backticks (pp (nameIdent x)) <+> + "may not appear in a parameterized module." diff --git a/src/Cryptol/Backend/FloatHelpers.hs b/src/Cryptol/Backend/FloatHelpers.hs --- a/src/Cryptol/Backend/FloatHelpers.hs +++ b/src/Cryptol/Backend/FloatHelpers.hs @@ -8,6 +8,7 @@ import Cryptol.Utils.PP import Cryptol.Utils.Panic(panic) +import Cryptol.Utils.Types import Cryptol.Backend.Monad( EvalError(..) ) @@ -176,3 +177,8 @@ -- (most significant bit in the significand is set, the rest of it is 0) floatToBits :: Integer -> Integer -> BigFloat -> Integer floatToBits e p bf = bfToBits (fpOpts e p NearEven) bf + + +-- | Create a 64-bit IEEE-754 float. +floatFromDouble :: Double -> BF +floatFromDouble = uncurry BF float64ExpPrec . bfFromDouble diff --git a/src/Cryptol/Backend/Monad.hs b/src/Cryptol/Backend/Monad.hs --- a/src/Cryptol/Backend/Monad.hs +++ b/src/Cryptol/Backend/Monad.hs @@ -54,7 +54,7 @@ import Cryptol.Parser.Position import Cryptol.Utils.Panic import Cryptol.Utils.PP -import Cryptol.TypeCheck.AST(Name) +import Cryptol.TypeCheck.AST(Name, TParam) -- | A computation that returns an already-evaluated value. ready :: a -> Eval a @@ -412,16 +412,20 @@ -- | Data type describing errors that can occur during evaluation. data EvalError - = InvalidIndex (Maybe Integer) -- ^ Out-of-bounds index - | DivideByZero -- ^ Division or modulus by 0 - | NegativeExponent -- ^ Exponentiation by negative integer - | LogNegative -- ^ Logarithm of a negative integer - | UserError String -- ^ Call to the Cryptol @error@ primitive - | LoopError String -- ^ Detectable nontermination - | NoPrim Name -- ^ Primitive with no implementation - | BadRoundingMode Integer -- ^ Invalid rounding mode - | BadValue String -- ^ Value outside the domain of a partial function. - deriving Typeable + = InvalidIndex (Maybe Integer) -- ^ Out-of-bounds index + | DivideByZero -- ^ Division or modulus by 0 + | NegativeExponent -- ^ Exponentiation by negative integer + | LogNegative -- ^ Logarithm of a negative integer + | UserError String -- ^ Call to the Cryptol @error@ primitive + | LoopError String -- ^ Detectable nontermination + | NoPrim Name -- ^ Primitive with no implementation + | BadRoundingMode Integer -- ^ Invalid rounding mode + | BadValue String -- ^ Value outside the domain of a partial function. + | NoMatchingPropGuardCase String -- ^ No prop guard holds for the given type variables. + | FFINotSupported Name -- ^ Foreign function cannot be called + | FFITypeNumTooBig Name TParam Integer -- ^ Number passed to foreign function + -- as a type argument is too large + deriving Typeable instance PP EvalError where ppPrec _ e = case e of @@ -440,6 +444,18 @@ BadRoundingMode r -> "invalid rounding mode" <+> integer r BadValue x -> "invalid input for" <+> backticks (text x) NoPrim x -> text "unimplemented primitive:" <+> pp x + NoMatchingPropGuardCase msg -> text $ "No matching constraint guard; " ++ msg + FFINotSupported x -> vcat + [ text "cannot call foreign function" <+> pp x + , text "FFI calls are not supported in this context" + , text "If you are trying to evaluate an expression, try rebuilding" + , text " Cryptol with FFI support enabled." + ] + FFITypeNumTooBig f p n -> vcat + [ text "numeric type argument to foreign function is too large:" + <+> integer n + , text "in type parameter" <+> pp p <+> "of function" <+> pp f + , text "type arguments must fit in a C `size_t`" ] instance Show EvalError where show = show . pp diff --git a/src/Cryptol/Backend/What4.hs b/src/Cryptol/Backend/What4.hs --- a/src/Cryptol/Backend/What4.hs +++ b/src/Cryptol/Backend/What4.hs @@ -11,6 +11,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} module Cryptol.Backend.What4 where diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -15,6 +15,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} module Cryptol.Eval ( moduleEnv @@ -35,6 +36,7 @@ , Unsupported(..) , WordTooWide(..) , forceValue + , checkProp ) where import Cryptol.Backend @@ -63,6 +65,7 @@ import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map import Data.Semigroup +import Control.Applicative import Prelude () import Prelude.Compat @@ -171,8 +174,9 @@ Just (Right val) | ?callStacks -> case nameInfo n of - Declared{} -> sPushFrame sym n ?range (cacheCallStack sym =<< val) - Parameter -> cacheCallStack sym =<< val + GlobalName {} -> + sPushFrame sym n ?range (cacheCallStack sym =<< val) + LocalName {} -> cacheCallStack sym =<< val | otherwise -> val Nothing -> do envdoc <- ppEnv sym defaultPPOpts env @@ -215,13 +219,59 @@ env' <- evalDecls sym ds env evalExpr sym env' e + EPropGuards guards _ -> {-# SCC "evalExpr->EPropGuards" #-} do + let checkedGuards = [ e | (ps,e) <- guards, all (checkProp . evalProp env) ps ] + case checkedGuards of + (e:_) -> eval e + [] -> raiseError sym (NoMatchingPropGuardCase $ "Among constraint guards: " ++ show (fmap pp . fst <$> guards)) + where {-# INLINE eval #-} eval = evalExpr sym env ppV = ppValue sym defaultPPOpts +-- | Checks whether an evaluated `Prop` holds +checkProp :: Prop -> Bool +checkProp = \case + TCon tcon ts -> + let ns = toNat' <$> ts in + case tcon of + PC PEqual | [n1, n2] <- ns -> n1 == n2 + PC PNeq | [n1, n2] <- ns -> n1 /= n2 + PC PGeq | [n1, n2] <- ns -> n1 >= n2 + PC PFin | [n] <- ns -> n /= Inf + -- TODO: instantiate UniqueFactorization for Nat'? + -- PC PPrime | [n] <- ns -> isJust (isPrime n) + PC PTrue -> True + TError {} -> False + _ -> evalPanic "evalProp" ["cannot use this as a guarding constraint: ", show . pp $ TCon tcon ts ] + prop -> evalPanic "evalProp" ["cannot use this as a guarding constraint: ", show . pp $ prop ] + where + toNat' :: Type -> Nat' + toNat' = \case + TCon (TC (TCNum n)) [] -> Nat n + TCon (TC TCInf) [] -> Inf + prop -> panic "checkProp" ["Expected `" ++ pretty prop ++ "` to be an evaluated numeric type"] + +-- | Evaluates a `Prop` in an `EvalEnv` by substituting all variables according +-- to `envTypes` and expanding all type synonyms via `tNoUser`. +evalProp :: GenEvalEnv sym -> Prop -> Prop +evalProp env@EvalEnv { envTypes } = \case + TCon tc tys + | TError KProp <- tc, [p] <- tys -> + case evalProp env p of + x@(TCon (TError KProp) _) -> x + _ -> TCon (TError KProp) [evalProp env p] + | otherwise -> TCon tc (toType . evalType envTypes <$> tys) + TVar tv | Just (toType -> ty) <- lookupTypeVar tv envTypes -> ty + prop@TUser {} -> evalProp env (tNoUser prop) + TVar tv | Nothing <- lookupTypeVar tv envTypes -> panic "evalProp" ["Could not find type variable `" ++ pretty tv ++ "` in the type evaluation environment"] + prop -> panic "evalProp" ["Cannot use the following as a type constraint: `" ++ pretty prop ++ "`"] + where + toType = either tNumTy tValTy + -- | Capure the current call stack from the evaluation monad and -- annotate function values. When arguments are later applied -- to the function, the call stacks will be combined together. @@ -269,7 +319,7 @@ Newtype -> GenEvalEnv sym -> SEval sym (GenEvalEnv sym) -evalNewtypeDecl _sym nt = pure . bindVarDirect (ntName nt) (foldr tabs con (ntParams nt)) +evalNewtypeDecl _sym nt = pure . bindVarDirect (ntConName nt) (foldr tabs con (ntParams nt)) where con = PFun PPrim @@ -382,9 +432,11 @@ sym -> Decl -> SEval sym (Name, Schema, SEval sym (GenValue sym), SEval sym (GenValue sym) -> SEval sym ()) declHole sym d = case dDefinition d of - DPrim -> evalPanic "Unexpected primitive declaration in recursive group" - [show (ppLocName nm)] - DExpr _ -> do + DPrim -> evalPanic "Unexpected primitive declaration in recursive group" + [show (ppLocName nm)] + DForeign _ -> evalPanic "Unexpected foreign declaration in recursive group" + [show (ppLocName nm)] + DExpr _ -> do (hole, fill) <- sDeclareHole sym msg return (nm, sch, hole, fill) where @@ -407,8 +459,10 @@ GenEvalEnv sym {- ^ An evaluation environment to extend with the given declaration -} -> Decl {- ^ The declaration to evaluate -} -> SEval sym (GenEvalEnv sym) -evalDecl sym renv env d = - let ?range = nameLoc (dName d) in +-- evalDecl sym renv env d = +-- let ?range = nameLoc (dName d) in +evalDecl sym renv env d = do + let ?range = nameLoc (dName d) case dDefinition d of DPrim -> case ?evalPrim =<< asPrim (dName d) of @@ -416,6 +470,18 @@ Just (Left ex) -> bindVar sym (dName d) (evalExpr sym renv ex) env Nothing -> bindVar sym (dName d) (cryNoPrimError sym (dName d)) env + DForeign _ -> do + -- Foreign declarations should have been handled by the previous + -- Cryptol.Eval.FFI.evalForeignDecls pass already, so they should already + -- be in the environment. If not, then either Cryptol was not compiled + -- with FFI support enabled, or we are in a non-Concrete backend. In that + -- case, we just bind the name to an error computation which will raise an + -- error if we try to evaluate it. + case lookupVar (dName d) env of + Just _ -> pure env + Nothing -> bindVar sym (dName d) + (raiseError sym $ FFINotSupported $ dName d) env + DExpr e -> bindVar sym (dName d) (evalExpr sym renv e) env @@ -689,5 +755,6 @@ where f env = case dDefinition d of - DPrim -> evalPanic "evalMatch" ["Unexpected local primitive"] - DExpr e -> evalExpr sym env e + DPrim -> evalPanic "evalMatch" ["Unexpected local primitive"] + DForeign _ -> evalPanic "evalMatch" ["Unexpected local foreign"] + DExpr e -> evalExpr sym env e diff --git a/src/Cryptol/Eval/Concrete.hs b/src/Cryptol/Eval/Concrete.hs --- a/src/Cryptol/Eval/Concrete.hs +++ b/src/Cryptol/Eval/Concrete.hs @@ -8,16 +8,10 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} module Cryptol.Eval.Concrete ( module Cryptol.Backend.Concrete , Value @@ -87,7 +81,7 @@ case res of Left _ -> mismatch -- different fields Right efs -> - let f = foldl (\x t -> ETApp x (tNumValTy t)) (EVar (ntName nt)) ts + let f = foldl (\x t -> ETApp x (tNumValTy t)) (EVar (ntConName nt)) ts in pure (EApp f (ERec efs)) (TVTuple ts, VTuple tvs) -> diff --git a/src/Cryptol/Eval/FFI.hs b/src/Cryptol/Eval/FFI.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Eval/FFI.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Evaluation of foreign functions. +module Cryptol.Eval.FFI + ( findForeignDecls + , evalForeignDecls + ) where + +import Cryptol.Backend.FFI +import Cryptol.Backend.FFI.Error +import Cryptol.Eval +import Cryptol.TypeCheck.AST +import Cryptol.TypeCheck.FFI.FFIType + +#ifdef FFI_ENABLED + +import Control.Exception(bracket_) +import Data.Either +import Data.Foldable +import Data.IORef +import Data.Proxy +import Data.Ratio +import Data.Traversable +import Data.Word +import Foreign +import Foreign.C.Types +import GHC.Float +import LibBF (bfFromDouble, bfToDouble, + pattern NearEven) +import Numeric.GMP.Raw.Unsafe +import Numeric.GMP.Utils + +import Cryptol.Backend +import Cryptol.Backend.Concrete +import Cryptol.Backend.FloatHelpers +import Cryptol.Backend.Monad +import Cryptol.Backend.SeqMap +import Cryptol.Eval.Env +import Cryptol.Eval.Prims +import Cryptol.Eval.Type +import Cryptol.Eval.Value +import Cryptol.ModuleSystem.Name +import Cryptol.Utils.Ident +import Cryptol.Utils.RecordMap + +#endif + +#ifdef FFI_ENABLED + +-- | Add the given foreign declarations to the environment, loading their +-- implementations from the given 'ForeignSrc'. This is a separate pass from the +-- main evaluation functions in "Cryptol.Eval" since it only works for the +-- Concrete backend. +evalForeignDecls :: ForeignSrc -> [(Name, FFIFunType)] -> EvalEnv -> + Eval (Either [FFILoadError] EvalEnv) +evalForeignDecls fsrc decls env = io do + ePrims <- for decls \(name, ffiFunType) -> + fmap ((name,) . foreignPrimPoly name ffiFunType) <$> + loadForeignImpl fsrc (unpackIdent $ nameIdent name) + pure case partitionEithers ePrims of + ([], prims) -> Right $ foldr (uncurry bindVarDirect) env prims + (errs, _) -> Left errs + +-- | Generate a 'Prim' value representing the given foreign function, containing +-- all the code necessary to marshal arguments and return values and do the +-- actual FFI call. +foreignPrimPoly :: Name -> FFIFunType -> ForeignImpl -> Prim Concrete +foreignPrimPoly name fft impl = buildNumPoly (ffiTParams fft) mempty + where -- Add type lambdas for the type parameters and build a type environment + -- that we can look up later to compute e.g. array sizes. + -- + -- Given [p1, p2, ..., pk] {}, returns + -- PNumPoly \n1 -> PNumPoly \n2 -> ... PNumPoly \nk -> + -- foreignPrim name fft impl {p1 = n1, p2 = n2, ..., pk = nk} + buildNumPoly (tp:tps) tenv = PNumPoly \n -> + buildNumPoly tps $ bindTypeVar (TVBound tp) (Left n) tenv + buildNumPoly [] tenv = foreignPrim name fft impl tenv + +-- | Methods for obtaining a return value. The producer of this type must supply +-- both 1) a polymorphic IO object directly containing a return value that the +-- consumer can instantiate at any 'FFIRet' type, and 2) an effectful function +-- that takes some output arguments and modifies what they are pointing at to +-- store a return value. The consumer can choose which one to use. +data GetRet = GetRet + { getRetAsValue :: forall a. FFIRet a => IO a + , getRetAsOutArgs :: [SomeFFIArg] -> IO () } + +-- | Operations needed for returning a basic reference type. +data BasicRefRet a = BasicRefRet + { -- | Initialize the object before passing to foreign function. + initBasicRefRet :: Ptr a -> IO () + -- | Free the object after returning from foreign function and obtaining + -- return value. + , clearBasicRefRet :: Ptr a -> IO () + -- | Convert the object to a Cryptol value. + , marshalBasicRefRet :: a -> Eval (GenValue Concrete) } + +-- | Generate the monomorphic part of the foreign 'Prim', given a 'TypeEnv' +-- containing all the type arguments we have already received. +foreignPrim :: Name -> FFIFunType -> ForeignImpl -> TypeEnv -> Prim Concrete +foreignPrim name FFIFunType {..} impl tenv = buildFun ffiArgTypes [] + where + + -- Build up the 'Prim' function for the FFI call. + -- + -- Given [t1, t2 ... tm] we return + -- PStrict \v1 -> PStrict \v2 -> ... PStrict \vm -> PPrim $ + -- marshalArg t1 v1 \a1 -> + -- marshalArg t2 v2 \a2 -> ... marshalArg tm vm \am -> + -- marshalRet ffiRetType GetRet + -- { getRetAsValue = callForeignImpl impl [n1, ..., nk, a1, ..., am] + -- , getRetAsOutArgs = \[o1, ..., ol] -> + -- callForeignImpl impl [n1, ..., nk, a1, ..., am, o1, ..., ol] } + buildFun :: [FFIType] -> [(FFIType, GenValue Concrete)] -> Prim Concrete + buildFun (argType:argTypes) typesAndVals = PStrict \val -> + buildFun argTypes $ typesAndVals ++ [(argType, val)] + buildFun [] typesAndVals = PPrim $ + marshalArgs typesAndVals \inArgs -> do + tyArgs <- traverse marshalTyArg ffiTParams + let tyInArgs = tyArgs ++ inArgs + marshalRet ffiRetType GetRet + { getRetAsValue = callForeignImpl impl tyInArgs + , getRetAsOutArgs = callForeignImpl impl . (tyInArgs ++) } + + -- Look up the value of a type parameter in the type environment and marshal + -- it. + marshalTyArg :: TParam -> Eval SomeFFIArg + marshalTyArg tp + | n <= toInteger (maxBound :: CSize) = + pure $ SomeFFIArg @CSize $ fromInteger n + | otherwise = raiseError Concrete $ FFITypeNumTooBig name tp n + where n = evalFinType $ TVar $ TVBound tp + + -- Marshal the given value as the given FFIType and call the given function + -- with the results. A single Cryptol argument may correspond to any number of + -- C arguments, so the callback takes a list. + -- + -- NOTE: the result must be used only in the callback since it may have a + -- limited lifetime (e.g. pointer returned by alloca). + marshalArg :: + FFIType -> + GenValue Concrete -> + ([SomeFFIArg] -> Eval a) -> + Eval a + + marshalArg FFIBool val f = f [SomeFFIArg @Word8 (fromBool (fromVBit val))] + + marshalArg (FFIBasic (FFIBasicVal t)) val f = + getMarshalBasicValArg t \doExport -> + do arg <- doExport val + f [SomeFFIArg arg] + + marshalArg (FFIBasic (FFIBasicRef t)) val f = + getMarshalBasicRefArg t \doExport -> + -- Since we need to do Eval actions in an IO callback, we need to manually + -- unwrap and wrap the Eval datatype + Eval \stk -> + doExport val \arg -> + with arg \ptr -> + runEval stk (f [SomeFFIArg ptr]) + + marshalArg (FFIArray (map evalFinType -> sizes) bt) val f = + case bt of + + FFIBasicVal t -> + getMarshalBasicValArg t \doExport -> + -- Since we need to do Eval actions in an IO callback, + -- we need to manually unwrap and wrap the Eval datatype + Eval \stk -> + marshalArrayArg stk \v k -> + k =<< runEval stk (doExport v) + + FFIBasicRef t -> Eval \stk -> + getMarshalBasicRefArg t \doExport -> + marshalArrayArg stk doExport + + where marshalArrayArg stk doExport = + allocaArray (fromInteger (product sizes)) \ptr -> do + -- Traverse the nested sequences and write the elements to the + -- array in order. + -- ns is the dimensions of the values we are currently + -- processing. + -- vs is the values we are currently processing. + -- nvss is the stack of previous ns and vs that we keep track of + -- that we push onto when we start processing a nested sequence + -- and pop off when we finish processing the current ones. + -- i is the index into the array. + + let + -- write next element of multi-dimensional array + write (n:ns) (v:vs) nvss !i = + do vs' <- traverse (runEval stk) + (enumerateSeqMap n (fromVSeq v)) + write ns vs' ((n, vs):nvss) i + + -- write next element in flat array + write [] (v:vs) nvss !i = + doExport v \rep -> + do pokeElemOff ptr i rep + write [] vs nvss (i + 1) + + -- finished with flat array, do next element of multi-d array + write ns [] ((n, vs):nvss) !i = write (n:ns) vs nvss i + + -- done + write _ _ [] _ = pure () + + + write sizes [val] [] 0 + runEval stk $ f [SomeFFIArg ptr] + + marshalArg (FFITuple types) val f = + do vals <- sequence (fromVTuple val) + marshalArgs (types `zip` vals) f + + marshalArg (FFIRecord typeMap) val f = + do vals <- traverse (`lookupRecord` val) (displayOrder typeMap) + marshalArgs (displayElements typeMap `zip` vals) f + + -- Call marshalArg on a bunch of arguments and collect the results together + -- (in the order of the arguments). + marshalArgs :: + [(FFIType, GenValue Concrete)] -> + ([SomeFFIArg] -> Eval a) -> + Eval a + marshalArgs typesAndVals f = go typesAndVals [] + where + go [] args = f (concat (reverse args)) + go ((t, v):tvs) prevArgs = + marshalArg t v \currArgs -> + go tvs (currArgs : prevArgs) + + -- Given an FFIType and a GetRet, obtain a return value and convert it to a + -- Cryptol value. The return value is obtained differently depending on the + -- FFIType. + marshalRet :: FFIType -> GetRet -> Eval (GenValue Concrete) + marshalRet FFIBool gr = + do rep <- io (getRetAsValue gr @Word8) + pure (VBit (toBool rep)) + + marshalRet (FFIBasic (FFIBasicVal t)) gr = + getMarshalBasicValRet t \doImport -> + do rep <- io (getRetAsValue gr) + doImport rep + + marshalRet (FFIBasic (FFIBasicRef t)) gr = + getBasicRefRet t \how -> + Eval \stk -> + alloca \ptr -> + bracket_ (initBasicRefRet how ptr) (clearBasicRefRet how ptr) + do getRetAsOutArgs gr [SomeFFIArg ptr] + rep <- peek ptr + runEval stk (marshalBasicRefRet how rep) + + marshalRet (FFIArray (map evalFinType -> sizes) bt) gr = + Eval \stk -> do + let totalSize = fromInteger (product sizes) + getResult marshal ptr = do + getRetAsOutArgs gr [SomeFFIArg ptr] + + let build (n:ns) !i = do + -- We need to be careful to actually run this here and not just + -- stick the IO action into the sequence with io, or else we + -- will read from the array after it is deallocated. + vs <- for [0 .. fromInteger n - 1] \j -> + build ns (i * fromInteger n + j) + pure (VSeq n (finiteSeqMap Concrete (map pure vs))) + build [] !i = peekElemOff ptr i >>= runEval stk . marshal + + build sizes 0 + + case bt of + + FFIBasicVal t -> + getMarshalBasicValRet t \doImport -> + allocaArray totalSize (getResult doImport) + + FFIBasicRef t -> + getBasicRefRet t \how -> + allocaArray totalSize \ptr -> + do let forEach f = for_ [0 .. totalSize - 1] (f . advancePtr ptr) + bracket_ (forEach (initBasicRefRet how)) + (forEach (clearBasicRefRet how)) + (getResult (marshalBasicRefRet how) ptr) + + marshalRet (FFITuple types) gr = VTuple <$> marshalMultiRet types gr + + marshalRet (FFIRecord typeMap) gr = + VRecord . recordFromFields . zip (displayOrder typeMap) <$> + marshalMultiRet (displayElements typeMap) gr + + -- Obtain multiple return values as output arguments for a composite return + -- type. Each return value is fully evaluated but put back in an Eval since + -- VTuple and VRecord expect it. + marshalMultiRet :: [FFIType] -> GetRet -> Eval [Eval (GenValue Concrete)] + -- Since IO callbacks are involved we just do the whole thing in IO and wrap + -- it in an Eval at the end. This should be fine since we are not changing + -- the (Cryptol) call stack. + marshalMultiRet types gr = Eval \stk -> do + -- We use this IORef hack here since we are calling marshalRet recursively + -- but marshalRet doesn't let us return any extra information from the + -- callback through to the result of the function. So we remember the result + -- as a side effect. + vals <- newIORef [] + let go [] args = getRetAsOutArgs gr args + go (t:ts) prevArgs = do + val <- runEval stk $ marshalRet t $ getRetFromAsOutArgs \currArgs -> + go ts (prevArgs ++ currArgs) + modifyIORef' vals (val :) + go types [] + map pure <$> readIORef vals + + -- | Call the callback with a 'BasicRefRet' for the given type. + getBasicRefRet :: FFIBasicRefType -> + (forall a. Storable a => BasicRefRet a -> b) -> b + getBasicRefRet (FFIInteger mbMod) f = f BasicRefRet + { initBasicRefRet = mpz_init + , clearBasicRefRet = mpz_clear + , marshalBasicRefRet = \mpz -> do + n <- io $ peekInteger' mpz + VInteger <$> + case mbMod of + Nothing -> pure n + Just m -> intToZn Concrete (evalFinType m) n } + getBasicRefRet FFIRational f = f BasicRefRet + { initBasicRefRet = mpq_init + , clearBasicRefRet = mpq_clear + , marshalBasicRefRet = \mpq -> do + r <- io $ peekRational' mpq + pure $ VRational $ SRational (numerator r) (denominator r) } + + -- Evaluate a finite numeric type expression. + evalFinType :: Type -> Integer + evalFinType = finNat' . evalNumType tenv + +-- | Given a way to 'getRetAsOutArgs', create a 'GetRet', where the +-- 'getRetAsValue' simply allocates a temporary space to call 'getRetAsOutArgs' +-- on. This is useful for return types that we know how to obtain directly as a +-- value but need to obtain as an output argument when multiple return values +-- are involved. +getRetFromAsOutArgs :: ([SomeFFIArg] -> IO ()) -> GetRet +getRetFromAsOutArgs f = GetRet + { getRetAsValue = alloca \ptr -> do + f [SomeFFIArg ptr] + peek ptr + , getRetAsOutArgs = f } + +-- | Given a 'FFIBasicValType', call the callback with a marshalling function +-- that marshals values to the 'FFIArg' type corresponding to the +-- 'FFIBasicValType'. The callback must be able to handle marshalling functions +-- that marshal to any 'FFIArg' type. +getMarshalBasicValArg :: + FFIBasicValType -> + (forall rep. + FFIArg rep => + (GenValue Concrete -> Eval rep) -> + result) -> + result + +getMarshalBasicValArg (FFIWord _ s) f = withWordType s \(_ :: p t) -> + f @t $ fmap (fromInteger . bvVal) . fromVWord Concrete "getMarshalBasicValArg" + +getMarshalBasicValArg (FFIFloat _ _ s) f = + case s of + -- LibBF can only convert to 'Double' directly, so we do that first then + -- convert to 'Float', which should not result in any loss of precision if + -- the original data was 32-bit anyways. + FFIFloat32 -> f $ pure . CFloat . double2Float . toDouble + FFIFloat64 -> f $ pure . CDouble . toDouble + where + toDouble = fst . bfToDouble NearEven . bfValue . fromVFloat + +-- | Given a 'FFIBasicValType', call the callback with an unmarshalling function +-- from the 'FFIRet' type corresponding to the 'FFIBasicValType' to Cryptol +-- values. The callback must be able to handle unmarshalling functions from any +-- 'FFIRet' type. +getMarshalBasicValRet :: FFIBasicValType -> + (forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b) -> b +getMarshalBasicValRet (FFIWord n s) f = withWordType s \(_ :: p t) -> + f @t $ word Concrete n . toInteger +getMarshalBasicValRet (FFIFloat e p s) f = + case s of + FFIFloat32 -> f $ toValue . \case CFloat x -> float2Double x + FFIFloat64 -> f $ toValue . \case CDouble x -> x + where toValue = pure . VFloat . BF e p . bfFromDouble + +-- | Call the callback with the Word type corresponding to the given +-- 'FFIWordSize'. +withWordType :: FFIWordSize -> + (forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b) -> b +withWordType FFIWord8 f = f $ Proxy @Word8 +withWordType FFIWord16 f = f $ Proxy @Word16 +withWordType FFIWord32 f = f $ Proxy @Word32 +withWordType FFIWord64 f = f $ Proxy @Word64 + +-- | Given a 'FFIBasicRefType', call the callback with a marshalling function +-- that takes a Cryptol value and calls its callback with the 'Storable' type +-- corresponding to the 'FFIBasicRefType'. +getMarshalBasicRefArg :: FFIBasicRefType -> + (forall rep. + Storable rep => + (GenValue Concrete -> (rep -> IO val) -> IO val) -> + result) -> + result +getMarshalBasicRefArg (FFIInteger _) f = f \val g -> + withInInteger' (fromVInteger val) g +getMarshalBasicRefArg FFIRational f = f \val g -> do + let SRational {..} = fromVRational val + withInRational' (sNum % sDenom) g + +#else + +-- | Dummy implementation for when FFI is disabled. Does not add anything to +-- the environment. +evalForeignDecls :: ForeignSrc -> [(Name, FFIFunType)] -> EvalEnv -> + Eval (Either [FFILoadError] EvalEnv) +evalForeignDecls _ _ env = pure $ Right env + +#endif diff --git a/src/Cryptol/Eval/FFI/GenHeader.hs b/src/Cryptol/Eval/FFI/GenHeader.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Eval/FFI/GenHeader.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +-- | Generate C header files from foreign declarations. +module Cryptol.Eval.FFI.GenHeader + ( generateForeignHeader + ) where + +import Control.Monad.Writer.Strict +import Data.Functor +import Data.Char(isAlphaNum) +import Data.List +import Data.Set (Set) +import qualified Data.Set as Set +import Language.C99.Pretty as C +import qualified Language.C99.Simple as C +import qualified Text.PrettyPrint as Pretty + +import Cryptol.ModuleSystem.Name +import Cryptol.TypeCheck.FFI.FFIType +import Cryptol.TypeCheck.Type +import Cryptol.Utils.Ident +import Cryptol.Utils.RecordMap + +-- | @Include foo@ represents an include statement @#include @ +newtype Include = Include String deriving (Eq, Ord) + +-- | The monad for generating headers. We keep track of which headers we need to +-- include and add them to the output at the end. +type GenHeaderM = Writer (Set Include) + +-- | Generate a C header file from the given foreign declarations. +generateForeignHeader :: [(Name, FFIFunType)] -> String +generateForeignHeader decls = + unlines (map renderInclude $ Set.toAscList incs) + ++ Pretty.render (C.pretty $ C.translate (C.TransUnit cdecls [])) + where (cdecls, incs) = runWriter $ traverse convertFun decls + +renderInclude :: Include -> String +renderInclude (Include inc) = "#include <" ++ inc ++ ">" + +-- | The "direction" of a parameter (input or output). +data ParamDir = In | Out + +-- | The result of converting a Cryptol type into its C representation. +data ConvertResult + = Direct C.Type -- ^ A type that can be directly returned if it is a return + -- type and passed as a single parameter if it is a Cryptol + -- parameter type. + | Params [C.Param] -- ^ A type that is turned into a number of parameters, + -- for both Cryptol parameter and return type cases. + +-- | Convert a Cryptol foreign declaration into a C function declaration. +convertFun :: (Name, FFIFunType) -> GenHeaderM C.Decln +convertFun (fName, FFIFunType {..}) = do + let tpIdent = fmap nameIdent . tpName + typeParams <- traverse convertTypeParam (pickNames (map tpIdent ffiTParams)) + -- Name the input args in0, in1, etc + let inPrefixes = + case ffiArgTypes of + [_] -> ["in"] + _ -> ["in" ++ show @Integer i | i <- [0..]] + inParams <- convertMultiType In $ zip inPrefixes ffiArgTypes + (retType, outParams) <- convertType Out ffiRetType + <&> \case + Direct u -> (u, []) + -- Name the output arg out + Params ps -> (C.TypeSpec C.Void, map (prefixParam "out") ps) + -- Avoid possible name collisions + let params = snd $ mapAccumL renameParam Set.empty $ + typeParams ++ inParams ++ outParams + renameParam names (C.Param u name) = + (Set.insert name' names, C.Param u name') + where name' = until (`Set.notMember` names) (++ "_") name + pure $ C.FunDecln Nothing retType (unpackIdent $ nameIdent fName) params + + +-- | Convert a Cryptol type parameter to a C value parameter. +convertTypeParam :: String -> GenHeaderM C.Param +convertTypeParam name = (`C.Param` name) <$> sizeT + +-- | Convert a Cryptol parameter or return type to C. +convertType :: ParamDir -> FFIType -> GenHeaderM ConvertResult +convertType _ FFIBool = Direct <$> uint8T +convertType _ (FFIBasic t) = convertBasicType t +convertType _ (FFIArray _ t) = do + u <- convertBasicTypeInArray t + pure $ Params [C.Param (C.Ptr u) ""] +convertType dir (FFITuple ts) = Params <$> convertMultiType dir + -- We name the tuple components using their indices + (zip (map (componentSuffix . show @Integer) [0..]) ts) +convertType dir (FFIRecord tMap) = + Params <$> convertMultiType dir (zip names ts) + where + (fs,ts) = unzip (displayFields tMap) + names = map componentSuffix (pickNames (map Just fs)) + +-- | Convert many Cryptol types, each associated with a prefix, to C parameters +-- named with their prefixes. +convertMultiType :: ParamDir -> [(C.Ident, FFIType)] -> GenHeaderM [C.Param] +convertMultiType dir = fmap concat . traverse \(prefix, t) -> + convertType dir t + <&> \case + Direct u -> [C.Param u' prefix] + where u' = case dir of + In -> u + -- Turn direct return types into pointer out parameters + Out -> C.Ptr u + Params ps -> map (prefixParam prefix) ps + +{- | Convert a basic Cryptol FFI type to a C type with its corresponding +calling convention. At present all value types use the same calling +convention no matter if they are inputs or outputs, so we don't +need the 'ParamDir'. -} +convertBasicType :: FFIBasicType -> GenHeaderM ConvertResult +convertBasicType bt = + case bt of + FFIBasicVal bvt -> Direct <$> convertBasicValType bvt + FFIBasicRef brt -> do t <- convertBasicRefType brt + pure (Params [C.Param t ""]) + +-- | Convert a basic Cryptol FFI type to a C type. +-- This is used when the type is stored in array. +convertBasicTypeInArray :: FFIBasicType -> GenHeaderM C.Type +convertBasicTypeInArray bt = + case bt of + FFIBasicVal bvt -> convertBasicValType bvt + FFIBasicRef brt -> convertBasicRefType brt + +-- | Convert a basic Cryptol FFI type to a value C type. +convertBasicValType :: FFIBasicValType -> GenHeaderM C.Type +convertBasicValType (FFIWord _ s) = + case s of + FFIWord8 -> uint8T + FFIWord16 -> uint16T + FFIWord32 -> uint32T + FFIWord64 -> uint64T +convertBasicValType (FFIFloat _ _ s) = + case s of + FFIFloat32 -> pure $ C.TypeSpec C.Float + FFIFloat64 -> pure $ C.TypeSpec C.Double + +-- | Convert a basic Cryptol FFI type to a reference C type. +convertBasicRefType :: FFIBasicRefType -> GenHeaderM C.Type +convertBasicRefType brt = + case brt of + FFIInteger {} -> mpzT + FFIRational -> mpqT + +prefixParam :: C.Ident -> C.Param -> C.Param +prefixParam pre (C.Param u name) = C.Param u (pre ++ name) + +-- | Create a suffix corresponding to some component name of some larger type. +componentSuffix :: String -> C.Ident +componentSuffix = ('_' :) + +sizeT, uint8T, uint16T, uint32T, uint64T, mpzT, mpqT :: GenHeaderM C.Type +sizeT = typedefFromInclude stddefH "size_t" +uint8T = typedefFromInclude stdintH "uint8_t" +uint16T = typedefFromInclude stdintH "uint16_t" +uint32T = typedefFromInclude stdintH "uint32_t" +uint64T = typedefFromInclude stdintH "uint64_t" +mpzT = typedefFromInclude gmpH "mpz_t" +mpqT = typedefFromInclude gmpH "mpq_t" + +stddefH, stdintH, gmpH :: Include +stddefH = Include "stddef.h" +stdintH = Include "stdint.h" +gmpH = Include "gmp.h" + + +-- | Return a type with the given name, included from some header file. +typedefFromInclude :: Include -> C.Ident -> GenHeaderM C.Type +typedefFromInclude inc u = do + tell $ Set.singleton inc + pure $ C.TypeSpec $ C.TypedefName u + +-- | Given some Cryptol identifiers (normal ones, not operators) +-- pick suitable unique C names for them +pickNames :: [Maybe Ident] -> [String] +pickNames xs = snd (mapAccumL add Set.empty xs) + where + add known x = + let y = simplify x + ys = y : [ y ++ show i | i <- [ 0 :: Int .. ] ] + y' : _ = dropWhile (`Set.member` known) ys + in (Set.insert y' known, y') + + simplify x = case x of + Just i | let y = filter ok (unpackIdent i), not (null y) -> y + _ -> "zz" + + ok x = x == '_' || isAlphaNum x + diff --git a/src/Cryptol/Eval/Generic.hs b/src/Cryptol/Eval/Generic.hs --- a/src/Cryptol/Eval/Generic.hs +++ b/src/Cryptol/Eval/Generic.hs @@ -1452,12 +1452,12 @@ PNumPoly \first -> PNumPoly \lst -> PTyPoly \ty -> - PVal + PPrim let !f = mkLit sym ty in case (first, lst) of (Nat first', Nat lst') -> let len = 1 + (lst' - first') - in VSeq len $ indexSeqMap $ \i -> f (first' + i) + in mkSeq sym (Nat len) ty $ indexSeqMap $ \i -> f (first' + i) _ -> evalPanic "fromToV" ["invalid arguments"] {-# INLINE fromThenToV #-} @@ -1469,12 +1469,12 @@ PNumPoly \lst -> PTyPoly \ty -> PNumPoly \len -> - PVal + PPrim let !f = mkLit sym ty in case (first, next, lst, len) of (Nat first', Nat next', Nat _lst', Nat len') -> let diff = next' - first' - in VSeq len' $ indexSeqMap $ \i -> f (first' + i*diff) + in mkSeq sym (Nat len') ty $ indexSeqMap $ \i -> f (first' + i*diff) _ -> evalPanic "fromThenToV" ["invalid arguments"] {-# INLINE fromToLessThanV #-} @@ -1484,12 +1484,12 @@ PFinPoly \first -> PNumPoly \bound -> PTyPoly \ty -> - PVal + PPrim let !f = mkLit sym ty ss = indexSeqMap $ \i -> f (first + i) in case bound of - Inf -> VStream ss - Nat bound' -> VSeq (bound' - first) ss + Inf -> return $ VStream ss + Nat bound' -> mkSeq sym (Nat (bound' - first)) ty ss {-# INLINE fromToByV #-} -- @[ 0 .. 10 by 2 ]@ @@ -1499,10 +1499,10 @@ PFinPoly \lst -> PFinPoly \stride -> PTyPoly \ty -> - PVal + PPrim let !f = mkLit sym ty ss = indexSeqMap $ \i -> f (first + i*stride) - in VSeq (1 + ((lst - first) `div` stride)) ss + in mkSeq sym (Nat (1 + ((lst - first) `div` stride))) ty ss {-# INLINE fromToByLessThanV #-} -- @[ 0 .. <10 by 2 ]@ @@ -1512,12 +1512,12 @@ PNumPoly \bound -> PFinPoly \stride -> PTyPoly \ty -> - PVal + PPrim let !f = mkLit sym ty ss = indexSeqMap $ \i -> f (first + i*stride) in case bound of - Inf -> VStream ss - Nat bound' -> VSeq ((bound' - first + stride - 1) `div` stride) ss + Inf -> return $ VStream ss + Nat bound' -> mkSeq sym (Nat ((bound' - first + stride - 1) `div` stride)) ty ss {-# INLINE fromToDownByV #-} @@ -1528,10 +1528,10 @@ PFinPoly \lst -> PFinPoly \stride -> PTyPoly \ty -> - PVal + PPrim let !f = mkLit sym ty ss = indexSeqMap $ \i -> f (first - i*stride) - in VSeq (1 + ((first - lst) `div` stride)) ss + in mkSeq sym (Nat (1 + ((first - lst) `div` stride))) ty ss {-# INLINE fromToDownByGreaterThanV #-} -- @[ 10 .. >0 down by 2 ]@ @@ -1541,10 +1541,10 @@ PFinPoly \bound -> PFinPoly \stride -> PTyPoly \ty -> - PVal + PPrim let !f = mkLit sym ty ss = indexSeqMap $ \i -> f (first - i*stride) - in VSeq ((first - bound + stride - 1) `div` stride) ss + in mkSeq sym (Nat ((first - bound + stride - 1) `div` stride)) ty ss {-# INLINE infFromV #-} infFromV :: Backend sym => sym -> Prim sym diff --git a/src/Cryptol/Eval/Reference.lhs b/src/Cryptol/Eval/Reference.lhs --- a/src/Cryptol/Eval/Reference.lhs +++ b/src/Cryptol/Eval/Reference.lhs @@ -10,6 +10,8 @@ > {-# LANGUAGE BlockArguments #-} > {-# LANGUAGE PatternGuards #-} > {-# LANGUAGE LambdaCase #-} +> {-# LANGUAGE NamedFieldPuns #-} +> {-# LANGUAGE ViewPatterns #-} > > module Cryptol.Eval.Reference > ( Value(..) @@ -32,6 +34,7 @@ > import LibBF (BigFloat) > import qualified LibBF as FP > import qualified GHC.Num.Compat as Integer +> import qualified Data.List as List > > import Cryptol.ModuleSystem.Name (asPrim) > import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), nAdd, nMin, nMul) @@ -46,6 +49,8 @@ > import Cryptol.Utils.Panic (panic) > import Cryptol.Utils.PP > import Cryptol.Utils.RecordMap +> import Cryptol.Eval (checkProp) +> import Cryptol.Eval.Type (evalType, lookupTypeVar, tNumTy, tValTy) > > import qualified Cryptol.ModuleSystem as M > import qualified Cryptol.ModuleSystem.Env as M (loadedModules,loadedNewtypes) @@ -332,12 +337,28 @@ > EProofAbs _ e -> evalExpr env e > EProofApp e -> evalExpr env e > EWhere e dgs -> evalExpr (foldl evalDeclGroup env dgs) e - +> +> EPropGuards guards _ty -> +> case List.find (all (checkProp . evalProp env) . fst) guards of +> Just (_, e) -> evalExpr env e +> Nothing -> evalPanic "fromVBit" ["No guard constraint was satisfied"] > appFun :: E Value -> E Value -> E Value > appFun f v = f >>= \f' -> fromVFun f' v +> -- | Evaluates a `Prop` in an `EvalEnv` by substituting all variables +> -- according to `envTypes` and expanding all type synonyms via `tNoUser`. +> evalProp :: Env -> Prop -> Prop +> evalProp env@Env { envTypes } = \case +> TCon tc tys -> TCon tc (toType . evalType envTypes <$> tys) +> TVar tv | Just (toType -> ty) <- lookupTypeVar tv envTypes -> ty +> prop@TUser {} -> evalProp env (tNoUser prop) +> TVar tv | Nothing <- lookupTypeVar tv envTypes -> panic "evalProp" ["Could not find type variable `" ++ pretty tv ++ "` in the type evaluation environment"] +> prop -> panic "evalProp" ["Cannot use the following as a type constraint: `" ++ pretty prop ++ "`"] +> where +> toType = either tNumTy tValTy + Selectors --------- @@ -510,8 +531,9 @@ > evalDecl :: Env -> Decl -> (Name, E Value) > evalDecl env d = > case dDefinition d of -> DPrim -> (dName d, pure (evalPrim (dName d))) -> DExpr e -> (dName d, evalExpr env e) +> DPrim -> (dName d, pure (evalPrim (dName d))) +> DForeign _ -> (dName d, cryError $ FFINotSupported $ dName d) +> DExpr e -> (dName d, evalExpr env e) > Newtypes @@ -523,7 +545,7 @@ that consumes and ignores its type arguments. > evalNewtypeDecl :: Env -> Newtype -> Env -> evalNewtypeDecl env nt = bindVar (ntName nt, pure val) env +> evalNewtypeDecl env nt = bindVar (ntConName nt, pure val) env > where > val = foldr tabs con (ntParams nt) > con = VFun (\x -> x) diff --git a/src/Cryptol/Eval/SBV.hs b/src/Cryptol/Eval/SBV.hs --- a/src/Cryptol/Eval/SBV.hs +++ b/src/Cryptol/Eval/SBV.hs @@ -8,6 +8,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} diff --git a/src/Cryptol/Eval/Type.hs b/src/Cryptol/Eval/Type.hs --- a/src/Cryptol/Eval/Type.hs +++ b/src/Cryptol/Eval/Type.hs @@ -18,6 +18,7 @@ import Cryptol.Utils.Panic (panic) import Cryptol.Utils.Ident (Ident) import Cryptol.Utils.RecordMap +import Cryptol.Utils.Types import Data.Maybe(fromMaybe) import qualified Data.IntMap.Strict as IntMap @@ -27,7 +28,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 @ @@ -86,6 +87,10 @@ tvSeq (Nat n) t = TVSeq n t tvSeq Inf t = TVStream t +-- | The Cryptol @Float64@ type. +tvFloat64 :: TValue +tvFloat64 = uncurry TVFloat float64ExpPrec + -- | Coerce an extended natural into an integer, -- for values known to be finite finNat' :: Nat' -> Integer @@ -100,6 +105,7 @@ newtype TypeEnv = TypeEnv { envTypeMap :: IntMap.IntMap (Either Nat' TValue) } + deriving (Show) instance Monoid TypeEnv where mempty = TypeEnv mempty diff --git a/src/Cryptol/Eval/What4.hs b/src/Cryptol/Eval/What4.hs --- a/src/Cryptol/Eval/What4.hs +++ b/src/Cryptol/Eval/What4.hs @@ -6,6 +6,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} @@ -505,7 +506,7 @@ TValue -> SInteger (What4 sym) -> SEval (What4 sym) (Value sym) -indexFront_int sym mblen _a xs ix idx +indexFront_int sym mblen _a xs _ix idx | Just i <- W4.asInteger idx = lookupSeqMap xs i @@ -535,16 +536,13 @@ _ -> Nothing ) - -- Maximum possible in-bounds index given `Z m` - -- type information and the length - -- of the sequence. If the sequences is infinite and the - -- integer is unbounded, there isn't much we can do. + -- Maximum possible in-bounds index given the length + -- of the sequence. If the sequence is infinite, there + -- isn't much we can do. maxIdx = - case (mblen, ix) of - (Nat n, TVIntMod m) -> Just (min (toInteger n) (toInteger m)) - (Nat n, _) -> Just n - (_ , TVIntMod m) -> Just m - _ -> Nothing + case mblen of + Nat n -> Just (n - 1) + Inf -> Nothing indexFront_segs :: W4.IsSymExprBuilder sym => What4 sym -> diff --git a/src/Cryptol/IR/FreeVars.hs b/src/Cryptol/IR/FreeVars.hs --- a/src/Cryptol/IR/FreeVars.hs +++ b/src/Cryptol/IR/FreeVars.hs @@ -93,6 +93,7 @@ instance FreeVars DeclDef where freeVars d = case d of DPrim -> mempty + DForeign _ -> mempty DExpr e -> freeVars e @@ -116,6 +117,7 @@ EProofAbs p e -> freeVars p <> freeVars e EProofApp e -> freeVars e EWhere e ds -> foldFree ds <> rmVals (defs ds) (freeVars e) + EPropGuards guards _ -> mconcat [ freeVars e | (_, e) <- guards ] where foldFree :: (FreeVars a, Defs a) => [a] -> Deps foldFree = foldr updateFree mempty diff --git a/src/Cryptol/IR/TraverseNames.hs b/src/Cryptol/IR/TraverseNames.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/IR/TraverseNames.hs @@ -0,0 +1,267 @@ +{-# Language ImplicitParams #-} +module Cryptol.IR.TraverseNames where + +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Functor.Identity + +import Cryptol.ModuleSystem.Name(nameUnique) +import Cryptol.Utils.RecordMap(traverseRecordMap) +import Cryptol.Parser.Position(Located(..)) +import Cryptol.TypeCheck.AST +import Cryptol.TypeCheck.FFI.FFIType + +traverseNames :: + (TraverseNames t, Applicative f) => (Name -> f Name) -> (t -> f t) +traverseNames f = let ?name = f in traverseNamesIP + +mapNames :: (TraverseNames t) => (Name -> Name) -> t -> t +mapNames f x = result + where + Identity result = let ?name = pure . f + in traverseNamesIP x + +class TraverseNames t where + traverseNamesIP :: (Applicative f, ?name :: Name -> f Name) => t -> f t + +instance TraverseNames a => TraverseNames [a] where + traverseNamesIP = traverse traverseNamesIP + +instance TraverseNames a => TraverseNames (Maybe a) where + traverseNamesIP = traverse traverseNamesIP + +instance (Ord a, TraverseNames a) => TraverseNames (Set a) where + traverseNamesIP = fmap Set.fromList . traverseNamesIP . Set.toList + +instance TraverseNames a => TraverseNames (Located a) where + traverseNamesIP (Located r a) = Located r <$> traverseNamesIP a + +instance TraverseNames Name where + traverseNamesIP = ?name + +instance (Ord a, TraverseNames a) => TraverseNames (ExportSpec a) where + traverseNamesIP (ExportSpec mp) = ExportSpec <$> traverse traverseNamesIP mp + +instance TraverseNames Expr where + traverseNamesIP expr = + case expr of + EList es t -> EList <$> traverseNamesIP es <*> traverseNamesIP t + + ETuple es -> ETuple <$> traverseNamesIP es + + ERec mp -> ERec <$> traverseRecordMap (\_ -> traverseNamesIP) mp + + ESel e l -> (`ESel` l) <$> traverseNamesIP e + + ESet t e1 l e2 -> ESet <$> traverseNamesIP t + <*> traverseNamesIP e1 + <*> pure l + <*> traverseNamesIP e2 + + EIf e1 e2 e3 -> EIf <$> traverseNamesIP e1 + <*> traverseNamesIP e2 + <*> traverseNamesIP e3 + + EComp t1 t2 e mss -> EComp <$> traverseNamesIP t1 + <*> traverseNamesIP t2 + <*> traverseNamesIP e + <*> traverseNamesIP mss + + EVar x -> EVar <$> traverseNamesIP x + ETAbs tp e -> ETAbs <$> traverseNamesIP tp <*> traverseNamesIP e + ETApp e t -> ETApp <$> traverseNamesIP e <*> traverseNamesIP t + EApp e1 e2 -> EApp <$> traverseNamesIP e1 <*> traverseNamesIP e2 + EAbs x t e -> EAbs <$> traverseNamesIP x + <*> traverseNamesIP t + <*> traverseNamesIP e + ELocated r e -> ELocated r <$> traverseNamesIP e + EProofAbs p e -> EProofAbs <$> traverseNamesIP p <*> traverseNamesIP e + EProofApp e -> EProofApp <$> traverseNamesIP e + EWhere e ds -> EWhere <$> traverseNamesIP e <*> traverseNamesIP ds + + EPropGuards gs t -> EPropGuards <$> traverse doG gs <*> traverseNamesIP t + where doG (xs, e) = (,) <$> traverseNamesIP xs <*> traverseNamesIP e + +instance TraverseNames Match where + traverseNamesIP mat = + case mat of + From x t1 t2 e -> From <$> traverseNamesIP x + <*> traverseNamesIP t1 + <*> traverseNamesIP t2 + <*> traverseNamesIP e + Let d -> Let <$> traverseNamesIP d + +instance TraverseNames DeclGroup where + traverseNamesIP dg = + case dg of + NonRecursive d -> NonRecursive <$> traverseNamesIP d + Recursive ds -> Recursive <$> traverseNamesIP ds + +instance TraverseNames Decl where + traverseNamesIP decl = mk <$> traverseNamesIP (dName decl) + <*> traverseNamesIP (dSignature decl) + <*> traverseNamesIP (dDefinition decl) + where mk nm sig def = decl { dName = nm + , dSignature = sig + , dDefinition = def + } + +instance TraverseNames DeclDef where + traverseNamesIP d = + case d of + DPrim -> pure d + DForeign t -> DForeign <$> traverseNamesIP t + DExpr e -> DExpr <$> traverseNamesIP e + +instance TraverseNames Schema where + traverseNamesIP (Forall as ps t) = + Forall <$> traverseNamesIP as + <*> traverseNamesIP ps + <*> traverseNamesIP t + +instance TraverseNames TParam where + traverseNamesIP tp = mk <$> traverseNamesIP (tpFlav tp) + <*> traverseNamesIP (tpInfo tp) + -- XXX: module parameters should probably be represented directly + -- as (abstract) user-defined types, rather than type variables. + where mk f i = case f of + TPModParam x -> + tp { tpUnique = nameUnique x, tpFlav = f, tpInfo = i } + _ -> tp { tpFlav = f, tpInfo = i } + + +instance TraverseNames TPFlavor where + traverseNamesIP tpf = + case tpf of + TPModParam x -> TPModParam <$> traverseNamesIP x + TPUnifyVar -> pure tpf + TPSchemaParam x -> TPSchemaParam <$> traverseNamesIP x + TPTySynParam x -> TPTySynParam <$> traverseNamesIP x + TPPropSynParam x -> TPPropSynParam <$> traverseNamesIP x + TPNewtypeParam x -> TPNewtypeParam <$> traverseNamesIP x + TPPrimParam x -> TPPrimParam <$> traverseNamesIP x + +instance TraverseNames TVarInfo where + traverseNamesIP (TVarInfo r s) = TVarInfo r <$> traverseNamesIP s + +instance TraverseNames TypeSource where + traverseNamesIP src = + case src of + TVFromModParam x -> TVFromModParam <$> traverseNamesIP x + TVFromSignature x -> TVFromSignature <$> traverseNamesIP x + TypeWildCard -> pure src + TypeOfRecordField {} -> pure src + TypeOfTupleField {} -> pure src + TypeOfSeqElement -> pure src + LenOfSeq -> pure src + TypeParamInstNamed x i -> TypeParamInstNamed <$> traverseNamesIP x + <*> pure i + TypeParamInstPos x i -> TypeParamInstPos <$> traverseNamesIP x + <*> pure i + DefinitionOf x -> DefinitionOf <$> traverseNamesIP x + LenOfCompGen -> pure src + TypeOfArg arg -> TypeOfArg <$> traverseNamesIP arg + TypeOfRes -> pure src + FunApp -> pure src + TypeOfIfCondExpr -> pure src + TypeFromUserAnnotation -> pure src + GeneratorOfListComp -> pure src + TypeErrorPlaceHolder -> pure src + +instance TraverseNames ArgDescr where + traverseNamesIP arg = mk <$> traverseNamesIP (argDescrFun arg) + where mk n = arg { argDescrFun = n } + +instance TraverseNames Type where + traverseNamesIP ty = + case ty of + TCon tc ts -> TCon <$> traverseNamesIP tc <*> traverseNamesIP ts + TVar x -> TVar <$> traverseNamesIP x + TUser x ts t -> TUser <$> traverseNamesIP x + <*> traverseNamesIP ts + <*> traverseNamesIP t + TRec rm -> TRec <$> traverseRecordMap (\_ -> traverseNamesIP) rm + TNewtype nt ts -> TNewtype <$> traverseNamesIP nt <*> traverseNamesIP ts + + +instance TraverseNames TCon where + traverseNamesIP tcon = + case tcon of + TC tc -> TC <$> traverseNamesIP tc + _ -> pure tcon + +instance TraverseNames TC where + traverseNamesIP tc = + case tc of + TCAbstract ut -> TCAbstract <$> traverseNamesIP ut + _ -> pure tc + +instance TraverseNames UserTC where + traverseNamesIP (UserTC x k) = UserTC <$> traverseNamesIP x <*> pure k + +instance TraverseNames TVar where + traverseNamesIP tvar = + case tvar of + TVFree x k ys i -> TVFree x k <$> traverseNamesIP ys <*> traverseNamesIP i + TVBound x -> TVBound <$> traverseNamesIP x + +instance TraverseNames Newtype where + traverseNamesIP nt = mk <$> traverseNamesIP (ntName nt) + <*> traverseNamesIP (ntParams nt) + <*> traverseNamesIP (ntConstraints nt) + <*> traverseNamesIP (ntConName nt) + <*> traverseRecordMap (\_ -> traverseNamesIP) + (ntFields nt) + where + mk a b c d e = nt { ntName = a + , ntParams = b + , ntConstraints = c + , ntConName = d + , ntFields = e + } + +instance TraverseNames ModTParam where + traverseNamesIP nt = mk <$> traverseNamesIP (mtpName nt) + where + mk x = nt { mtpName = x } + +instance TraverseNames ModVParam where + traverseNamesIP nt = mk <$> traverseNamesIP (mvpName nt) + <*> traverseNamesIP (mvpType nt) + where + mk x t = nt { mvpName = x, mvpType = t } + +instance TraverseNames FFIFunType where + traverseNamesIP fi = mk <$> traverseNamesIP (ffiArgTypes fi) + <*> traverseNamesIP (ffiRetType fi) + where + mk as b = + FFIFunType + { ffiTParams = ffiTParams fi + , ffiArgTypes = as + , ffiRetType = b + } + +instance TraverseNames FFIType where + traverseNamesIP ft = + case ft of + FFIBool -> pure ft + FFIBasic _ -> pure ft -- assumes no names here + FFIArray sz t -> (`FFIArray` t) <$> traverseNamesIP sz + FFITuple ts -> FFITuple <$> traverseNamesIP ts + FFIRecord mp -> FFIRecord <$> traverseRecordMap + (\_ -> traverseNamesIP) mp +instance TraverseNames TySyn where + traverseNamesIP ts = mk <$> traverseNamesIP (tsName ts) + <*> traverseNamesIP (tsParams ts) + <*> traverseNamesIP (tsConstraints ts) + <*> traverseNamesIP (tsDef ts) + where mk n ps cs t = + TySyn { tsName = n + , tsParams = ps + , tsConstraints = cs + , tsDef = t + , tsDoc = tsDoc ts + } + + diff --git a/src/Cryptol/ModuleSystem.hs b/src/Cryptol/ModuleSystem.hs --- a/src/Cryptol/ModuleSystem.hs +++ b/src/Cryptol/ModuleSystem.hs @@ -7,6 +7,7 @@ -- Portability : portable {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BlockArguments #-} module Cryptol.ModuleSystem ( -- * Module System @@ -18,8 +19,10 @@ , findModule , loadModuleByPath , loadModuleByName + , checkModuleByPath , checkExpr , evalExpr + , benchmarkExpr , checkDecls , evalDecls , noPat @@ -29,8 +32,11 @@ , renameType -- * Interfaces - , Iface, IfaceG(..), IfaceParams(..), IfaceDecls(..), T.genIface - , IfaceTySyn, IfaceDecl(..) + , Iface, IfaceG(..), IfaceDecls(..), T.genIface, IfaceDecl(..) + + -- * Dependencies + , getFileDependencies + , getModuleDependencies ) where import Data.Map (Map) @@ -47,6 +53,7 @@ import Cryptol.Parser.NoPat (RemovePatterns) import qualified Cryptol.TypeCheck.AST as T import qualified Cryptol.TypeCheck.Interface as T +import Cryptol.Utils.Benchmark (BenchmarkStats) import qualified Cryptol.Utils.Ident as M -- Public Interface ------------------------------------------------------------ @@ -63,23 +70,34 @@ findModule n env = runModuleM env (Base.findModule n) -- | Load the module contained in the given file. -loadModuleByPath :: FilePath -> ModuleCmd (ModulePath,T.Module) -loadModuleByPath path minp = - runModuleM minp{ minpModuleEnv = resetModuleEnv (minpModuleEnv minp) } $ do +loadModuleByPath :: FilePath -> ModuleCmd (ModulePath,T.TCTopEntity) +loadModuleByPath path minp = do + moduleEnv' <- resetModuleEnv $ minpModuleEnv minp + runModuleM minp{ minpModuleEnv = moduleEnv' } $ do unloadModule ((InFile path ==) . lmFilePath) - m <- Base.loadModuleByPath path - setFocusedModule (T.mName m) + m <- Base.loadModuleByPath True path + setFocusedModule (T.tcTopEntitytName m) return (InFile path,m) -- | Load the given parsed module. -loadModuleByName :: P.ModName -> ModuleCmd (ModulePath,T.Module) -loadModuleByName n minp = - runModuleM minp{ minpModuleEnv = resetModuleEnv (minpModuleEnv minp) } $ do +loadModuleByName :: P.ModName -> ModuleCmd (ModulePath,T.TCTopEntity) +loadModuleByName n minp = do + moduleEnv' <- resetModuleEnv $ minpModuleEnv minp + runModuleM minp{ minpModuleEnv = moduleEnv' } $ do unloadModule ((n ==) . lmName) (path,m') <- Base.loadModuleFrom False (FromModule n) - setFocusedModule (T.mName m') + setFocusedModule (T.tcTopEntitytName m') return (path,m') +-- | Parse and typecheck a module, but don't evaluate or change the environment. +checkModuleByPath :: FilePath -> ModuleCmd (ModulePath, T.TCTopEntity) +checkModuleByPath path minp = do + (res, warns) <- runModuleM minp $ Base.loadModuleByPath False path + -- restore the old environment + let res1 = do (x,_newEnv) <- res + pure ((InFile path, x), minpModuleEnv minp) + pure (res1, warns) + -- Extended Environments ------------------------------------------------------- -- These functions are particularly useful for interactive modes, as @@ -95,6 +113,11 @@ evalExpr :: T.Expr -> ModuleCmd Concrete.Value evalExpr e env = runModuleM env (interactive (Base.evalExpr e)) +-- | Benchmark an expression. +benchmarkExpr :: Double -> T.Expr -> ModuleCmd BenchmarkStats +benchmarkExpr period e env = + runModuleM env (interactive (Base.benchmarkExpr period e)) + -- | Typecheck top-level declarations. checkDecls :: [P.TopDecl PName] -> ModuleCmd (R.NamingEnv,[T.DeclGroup], Map Name T.TySyn) checkDecls ds env = runModuleM env @@ -119,3 +142,16 @@ renameType :: R.NamingEnv -> PName -> ModuleCmd Name renameType names n env = runModuleM env $ interactive $ Base.rename M.interactiveName names (R.renameType R.NameUse n) + +-------------------------------------------------------------------------------- +-- Dependencies + + +-- | Get information about the dependencies of a file. +getFileDependencies :: FilePath -> ModuleCmd (ModulePath, FileInfo) +getFileDependencies f env = runModuleM env (Base.findDepsOf (InFile f)) + +-- | Get information about the dependencies of a module. +getModuleDependencies :: M.ModName -> ModuleCmd (ModulePath, FileInfo) +getModuleDependencies m env = runModuleM env (Base.findDepsOfModule m) + diff --git a/src/Cryptol/ModuleSystem/Base.hs b/src/Cryptol/ModuleSystem/Base.hs --- a/src/Cryptol/ModuleSystem/Base.hs +++ b/src/Cryptol/ModuleSystem/Base.hs @@ -11,17 +11,22 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} module Cryptol.ModuleSystem.Base where import qualified Control.Exception as X -import Control.Monad (unless,when) +import Control.Monad (unless,forM) +import Data.Set(Set) +import qualified Data.Set as Set import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) +import Data.List(sortBy,groupBy) +import Data.Function(on) +import Data.Monoid ((<>),Endo(..), Any(..)) import Data.Text.Encoding (decodeUtf8') -import Data.IORef(newIORef,readIORef) import System.Directory (doesFileExist, canonicalizePath) import System.FilePath ( addExtension , isAbsolute @@ -39,39 +44,45 @@ -import Cryptol.ModuleSystem.Env (DynamicEnv(..)) import Cryptol.ModuleSystem.Fingerprint import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Monad -import Cryptol.ModuleSystem.Name (Name,liftSupply,PrimMap,ModPath(..)) -import Cryptol.ModuleSystem.Env (lookupModule - , LoadedModule(..) +import Cryptol.ModuleSystem.Name (Name,liftSupply,PrimMap,ModPath(..),nameIdent) +import Cryptol.ModuleSystem.Env ( DynamicEnv(..),FileInfo(..),fileInfo + , lookupModule + , lookupTCEntity + , LoadedModuleG(..), lmInterface , meCoreLint, CoreLint(..) - , ModContext(..) + , ModContext(..), ModContextParams(..) , ModulePath(..), modulePathLabel) +import Cryptol.Backend.FFI import qualified Cryptol.Eval as E import qualified Cryptol.Eval.Concrete as Concrete import Cryptol.Eval.Concrete (Concrete(..)) +import Cryptol.Eval.FFI import qualified Cryptol.ModuleSystem.NamingEnv as R import qualified Cryptol.ModuleSystem.Renamer as R import qualified Cryptol.Parser as P import qualified Cryptol.Parser.Unlit as P import Cryptol.Parser.AST as P import Cryptol.Parser.NoPat (RemovePatterns(removePatterns)) +import qualified Cryptol.Parser.ExpandPropGuards as ExpandPropGuards + ( expandPropGuards, runExpandPropGuardsM ) import Cryptol.Parser.NoInclude (removeIncludesModule) import Cryptol.Parser.Position (HasLoc(..), Range, emptyRange) import qualified Cryptol.TypeCheck as T import qualified Cryptol.TypeCheck.AST as T import qualified Cryptol.TypeCheck.PP as T import qualified Cryptol.TypeCheck.Sanity as TcSanity +import qualified Cryptol.Backend.FFI.Error as FFI -import Cryptol.Transform.AddModParams (addModParams) import Cryptol.Utils.Ident ( preludeName, floatName, arrayName, suiteBName, primeECName , preludeReferenceName, interactiveName, modNameChunks - , notParamInstModName, isParamInstModName ) + , modNameToNormalModName ) import Cryptol.Utils.PP (pretty) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.Logger(logPutStrLn, logPrint) +import Cryptol.Utils.Benchmark import Cryptol.Prelude ( preludeContents, floatContents, arrayContents , suiteBContents, primeECContents, preludeReferenceContents ) @@ -114,11 +125,22 @@ unless (null errs) (noPatErrors errs) return a' +-- ExpandPropGuards ------------------------------------------------------------ +-- | Run the expandPropGuards pass. +expandPropGuards :: Module PName -> ModuleM (Module PName) +expandPropGuards a = + case ExpandPropGuards.runExpandPropGuardsM $ ExpandPropGuards.expandPropGuards a of + Left err -> expandPropGuardsError err + Right a' -> pure a' + -- Parsing --------------------------------------------------------------------- -- | Parse a module and expand includes -parseModule :: ModulePath -> ModuleM (Fingerprint, P.Module PName) +-- Returns a fingerprint of the module, and a set of dependencies due +-- to `include` directives. +parseModule :: + ModulePath -> ModuleM (Fingerprint, Set FilePath, [P.Module PName]) parseModule path = do getBytes <- getByteReader @@ -150,111 +172,167 @@ } case P.parseModule cfg txt of - Right pm -> + Right pms -> do let fp = fingerprint bytes - pm1 <- case path of - InFile p -> - do r <- getByteReader - mb <- io (removeIncludesModule r p pm) + (pm1,deps) <- + case path of + InFile p -> + do r <- getByteReader + (mo,d) <- unzip <$> + forM pms \pm -> + do mb <- io (removeIncludesModule r p pm) case mb of Right ok -> pure ok Left err -> noIncludeErrors err + pure (mo, Set.unions d) - {- We don't do "include" resolution for in-memory files - because at the moment the include resolution pass requires - the path to the file to be known---this is used when - looking for other inlcude files. This could be - generalized, but we can do it once we have a concrete use - case as it would help guide the design. -} - InMem {} -> pure pm + {- We don't do "include" resolution for in-memory files + because at the moment the include resolution pass requires + the path to the file to be known---this is used when + looking for other inlcude files. This could be + generalized, but we can do it once we have a concrete use + case as it would help guide the design. -} + InMem {} -> pure (pms, Set.empty) - fp `seq` return (fp, pm1) +{- + case path of + InFile {} -> io $ print (T.vcat (map T.pp pm1)) + InMem {} -> pure () +--} + fp `seq` return (fp, deps, pm1) Left err -> moduleParseError path err --- Modules --------------------------------------------------------------------- +-- Top Level Modules and Signatures -------------------------------------------- + -- | Load a module by its path. -loadModuleByPath :: FilePath -> ModuleM T.Module -loadModuleByPath path = withPrependedSearchPath [ takeDirectory path ] $ do +loadModuleByPath :: + Bool {- ^ evaluate declarations in the module -} -> + FilePath -> ModuleM T.TCTopEntity +loadModuleByPath eval path = withPrependedSearchPath [ takeDirectory path ] $ do let fileName = takeFileName path foundPath <- findFile fileName - (fp, pm) <- parseModule (InFile foundPath) - let n = thing (P.mName pm) + (fp, deps, pms) <- parseModule (InFile foundPath) + last <$> + forM pms \pm -> + do let n = thing (P.mName pm) - -- Check whether this module name has already been loaded from a different file - env <- getModuleEnv - -- path' is the resolved, absolute path, used only for checking - -- whether it's already been loaded - path' <- io (canonicalizePath foundPath) + -- Check whether this module name has already been loaded from a + -- different file + env <- getModuleEnv + -- path' is the resolved, absolute path, used only for checking + -- whether it's already been loaded + path' <- io (canonicalizePath foundPath) - case lookupModule n env of - -- loadModule will calculate the canonical path again - Nothing -> doLoadModule False (FromModule n) (InFile foundPath) fp pm - Just lm - | path' == loaded -> return (lmModule lm) - | otherwise -> duplicateModuleName n path' loaded - where loaded = lmModuleId lm + case lookupTCEntity n env of + -- loadModule will calculate the canonical path again + Nothing -> + doLoadModule eval False (FromModule n) (InFile foundPath) fp deps pm + Just lm + | path' == loaded -> return (lmData lm) + | otherwise -> duplicateModuleName n path' loaded + where loaded = lmModuleId lm -- | Load a module, unless it was previously loaded. -loadModuleFrom :: Bool {- ^ quiet mode -} -> ImportSource -> ModuleM (ModulePath,T.Module) +loadModuleFrom :: + Bool {- ^ quiet mode -} -> ImportSource -> ModuleM (ModulePath,T.TCTopEntity) loadModuleFrom quiet isrc = do let n = importedModule isrc mb <- getLoadedMaybe n case mb of - Just m -> return (lmFilePath m, lmModule m) + Just m -> return (lmFilePath m, lmData m) Nothing -> do path <- findModule n errorInFile path $ - do (fp, pm) <- parseModule path - m <- doLoadModule quiet isrc path fp pm - return (path,m) + do (fp, deps, pms) <- parseModule path + ms <- mapM (doLoadModule True quiet isrc path fp deps) pms + return (path,last ms) -- | Load dependencies, typecheck, and add to the eval environment. doLoadModule :: + Bool {- ^ evaluate declarations in the module -} -> Bool {- ^ quiet mode: true suppresses the "loading module" message -} -> ImportSource -> ModulePath -> Fingerprint -> + Set FilePath {- ^ `include` dependencies -} -> P.Module PName -> - ModuleM T.Module -doLoadModule quiet isrc path fp pm0 = + ModuleM T.TCTopEntity +doLoadModule eval quiet isrc path fp incDeps pm0 = loading isrc $ do let pm = addPrelude pm0 - loadDeps pm + impDeps <- loadDeps pm + let what = case P.mDef pm of + P.InterfaceModule {} -> "interface module" + _ -> "module" + unless quiet $ withLogger logPutStrLn - ("Loading module " ++ pretty (P.thing (P.mName pm))) + ("Loading " ++ what ++ " " ++ pretty (P.thing (P.mName pm))) - (nameEnv,tcmod) <- checkModule isrc pm - tcm <- optionalInstantiate tcmod + (nameEnv,tcm) <- checkModule isrc pm -- extend the eval env, unless a functor. tbl <- Concrete.primTable <$> getEvalOptsAction let ?evalPrim = \i -> Right <$> Map.lookup i tbl callStacks <- getCallStacks let ?callStacks = callStacks - unless (T.isParametrizedModule tcm) $ modifyEvalEnv (E.moduleEnv Concrete tcm) - loadedModule path fp nameEnv tcm + let shouldEval = + case tcm of + T.TCTopModule m | eval && not (T.isParametrizedModule m) -> Just m + _ -> Nothing + foreignSrc <- case shouldEval of + Just m -> + do fsrc <- evalForeign m + modifyEvalEnv (E.moduleEnv Concrete m) + pure fsrc + Nothing -> pure Nothing + + let fi = fileInfo fp incDeps impDeps foreignSrc + loadedModule path fi nameEnv foreignSrc tcm + return tcm + where - optionalInstantiate tcm - | isParamInstModName (importedModule isrc) = - if T.isParametrizedModule tcm then - case addModParams tcm of - Right tcm1 -> return tcm1 - Left xs -> failedToParameterizeModDefs (T.mName tcm) xs - else notAParameterizedModule (T.mName tcm) - | otherwise = return tcm + evalForeign tcm + | not (null foreignFs) = + ffiLoadErrors (T.mName tcm) (map FFI.FFIInFunctor foreignFs) + | not (null dups) = + ffiLoadErrors (T.mName tcm) (map FFI.FFIDuplicates dups) + | null foreigns = pure Nothing + | otherwise = + case path of + InFile p -> io (canonicalizePath p >>= loadForeignSrc) >>= + \case + Right fsrc -> do + unless quiet $ + case getForeignSrcPath fsrc of + Just fpath -> withLogger logPutStrLn $ + "Loading dynamic library " ++ takeFileName fpath + Nothing -> pure () + modifyEvalEnvM (evalForeignDecls fsrc foreigns) >>= + \case + Right () -> pure $ Just fsrc + Left errs -> ffiLoadErrors (T.mName tcm) errs + Left err -> ffiLoadErrors (T.mName tcm) [err] + InMem m _ -> panic "doLoadModule" + ["Can't find foreign source of in-memory module", m] + where foreigns = findForeignDecls tcm + foreignFs = T.findForeignDeclsInFunctors tcm + dups = [ d | d@(_ : _ : _) <- groupBy ((==) `on` nameIdent) + $ sortBy (compare `on` nameIdent) + $ map fst foreigns ] + -- | Rewrite an import declaration to be of the form: -- -- > import foo as foo [ [hiding] (a,b,c) ] @@ -298,51 +376,149 @@ -- | Discover a file. This is distinct from 'findModule' in that we -- assume we've already been given a particular file name. findFile :: FilePath -> ModuleM FilePath -findFile path | isAbsolute path = do - -- No search path checking for absolute paths - b <- io (doesFileExist path) - if b then return path else cantFindFile path -findFile path = do - paths <- getSearchPath - loop (possibleFiles paths) - where - loop paths = case paths of - path':rest -> do - b <- io (doesFileExist path') - if b then return (normalise path') else loop rest - [] -> cantFindFile path - possibleFiles paths = map ( path) paths +findFile path + | isAbsolute path = + do -- No search path checking for absolute paths + b <- io (doesFileExist path) + if b then return path else cantFindFile path + | otherwise = + do paths <- getSearchPath + loop (possibleFiles paths) + where + loop paths = case paths of + path' : rest -> + do b <- io (doesFileExist path') + if b then return (normalise path') else loop rest + [] -> cantFindFile path + possibleFiles paths = map ( path) paths -- | Add the prelude to the import list if it's not already mentioned. addPrelude :: P.Module PName -> P.Module PName addPrelude m | preludeName == P.thing (P.mName m) = m | preludeName `elem` importedMods = m - | otherwise = m { mDecls = importPrelude : mDecls m } + | otherwise = m { mDef = newDef } where + newDef = + case mDef m of + NormalModule ds -> NormalModule (P.DImport prel : ds) + FunctorInstance f as ins -> FunctorInstance f as ins + InterfaceModule s -> InterfaceModule s { sigImports = prel + : sigImports s } + importedMods = map (P.iModule . P.thing) (P.mImports m) - importPrelude = P.DImport P.Located + prel = P.Located { P.srcRange = emptyRange , P.thing = P.Import - { iModule = P.ImpTop preludeName - , iAs = Nothing - , iSpec = Nothing + { iModule = P.ImpTop preludeName + , iAs = Nothing + , iSpec = Nothing + , iInst = Nothing } } -- | Load the dependencies of a module into the environment. -loadDeps :: P.Module name -> ModuleM () +loadDeps :: P.ModuleG mname name -> ModuleM (Set ModName) loadDeps m = - do mapM_ loadI (P.mImports m) - mapM_ loadF (P.mInstance m) + do let ds = findDeps m + mapM_ (loadModuleFrom False) ds + pure (Set.fromList (map importedModule ds)) + +-- | Find all imports in a module. +findDeps :: P.ModuleG mname name -> [ImportSource] +findDeps m = appEndo (snd (findDeps' m)) [] + +findDepsOfModule :: ModName -> ModuleM (ModulePath, FileInfo) +findDepsOfModule m = + do mpath <- findModule m + findDepsOf mpath + +findDepsOf :: ModulePath -> ModuleM (ModulePath, FileInfo) +findDepsOf mpath' = + do mpath <- case mpath' of + InFile file -> InFile <$> io (canonicalizePath file) + InMem {} -> pure mpath' + (fp, incs, ms) <- parseModule mpath + let (anyF,imps) = mconcat (map (findDeps' . addPrelude) ms) + fpath <- if getAny anyF + then do mb <- io case mpath of + InFile can -> foreignLibPath can + InMem {} -> pure Nothing + pure case mb of + Nothing -> Set.empty + Just f -> Set.singleton f + else pure Set.empty + pure + ( mpath + , FileInfo + { fiFingerprint = fp + , fiIncludeDeps = incs + , fiImportDeps = Set.fromList (map importedModule (appEndo imps [])) + , fiForeignDeps = fpath + } + ) + +-- | Find the set of top-level modules imported by a module. +findModuleDeps :: P.ModuleG mname name -> Set P.ModName +findModuleDeps = Set.fromList . map importedModule . findDeps + +-- | A helper `findDeps` and `findModuleDeps` that actually does the searching. +findDeps' :: P.ModuleG mname name -> (Any, Endo [ImportSource]) +findDeps' m = + case mDef m of + NormalModule ds -> mconcat (map depsOfDecl ds) + FunctorInstance f as _ -> + let fds = loadImpName FromModuleInstance f + ads = case as of + DefaultInstArg a -> loadInstArg a + DefaultInstAnonArg ds -> mconcat (map depsOfDecl ds) + NamedInstArgs args -> mconcat (map loadNamedInstArg args) + in fds <> ads + InterfaceModule s -> mconcat (map loadImpD (sigImports s)) where - loadI i = do (_,m1) <- loadModuleFrom False (FromImport i) - when (T.isParametrizedModule m1) $ importParamModule $ T.mName m1 - loadF f = do _ <- loadModuleFrom False (FromModuleInstance f) - return () + loadI i = (mempty, Endo (i:)) + loadImpName src l = + case thing l of + ImpTop f -> loadI (src l { thing = f }) + _ -> mempty + loadImpD li = loadImpName (FromImport . new) (iModule <$> li) + where new i = i { thing = (thing li) { iModule = thing i } } + loadNamedInstArg (ModuleInstanceNamedArg _ f) = loadInstArg f + loadInstArg f = + case thing f of + ModuleArg mo -> loadImpName FromModuleInstance f { thing = mo } + _ -> mempty + + depsOfDecl d = + case d of + DImport li -> loadImpD li + + DModule TopLevel { tlValue = NestedModule nm } -> findDeps' nm + + DModParam mo -> loadImpName FromSigImport s + where s = mpSignature mo + + Decl dd -> depsOfDecl' (tlValue dd) + + _ -> mempty + + depsOfDecl' d = + case d of + DLocated d' _ -> depsOfDecl' d' + DBind b -> + case thing (bDef b) of + DForeign {} -> (Any True, mempty) + _ -> mempty + _ -> mempty + + + + + + -- Type Checking --------------------------------------------------------------- -- | Typecheck a single expression, yielding a renamed parsed expression, @@ -405,46 +581,38 @@ Nothing -> panic "Cryptol.ModuleSystem.Base.getPrimMap" [ "Unable to find the prelude" ] --- | Load a module, be it a normal module or a functor instantiation. -checkModule :: ImportSource -> P.Module PName -> ModuleM (R.NamingEnv, T.Module) -checkModule isrc m = - case P.mInstance m of - Nothing -> checkSingleModule T.tcModule isrc m - Just fmName -> - do mbtf <- getLoadedMaybe (thing fmName) - case mbtf of - Just tf -> - do renThis <- io $ newIORef (lmNamingEnv tf) - let how = T.tcModuleInst renThis (lmModule tf) - (_,m') <- checkSingleModule how isrc m - newEnv <- io $ readIORef renThis - pure (newEnv,m') - Nothing -> panic "checkModule" - [ "Functor of module instantiation not loaded" ] - - --- | Typecheck a single module. If the module is an instantiation --- of a functor, then this just type-checks the instantiating parameters. --- See 'checkModule' +-- | Typecheck a single module. -- Note: we assume that @include@s have already been processed -checkSingleModule :: - Act (P.Module Name) T.Module {- ^ how to check -} -> - ImportSource {- ^ why are we loading this -} -> - P.Module PName {- ^ module to check -} -> - ModuleM (R.NamingEnv,T.Module) -checkSingleModule how isrc m = do +checkModule :: + ImportSource {- ^ why are we loading this -} -> + P.Module PName {- ^ module to check -} -> + ModuleM (R.NamingEnv,T.TCTopEntity) +checkModule isrc m = do -- check that the name of the module matches expectations let nm = importedModule isrc - unless (notParamInstModName nm == thing (P.mName m)) + unless (modNameToNormalModName nm == + modNameToNormalModName (thing (P.mName m))) (moduleNameMismatch nm (mName m)) -- remove pattern bindings npm <- noPat m + -- run expandPropGuards + epgm <- expandPropGuards npm + -- rename everything - renMod <- renameModule npm + renMod <- renameModule epgm + +{- + -- dump renamed + unless (thing (mName (R.rmModule renMod)) == preludeName) + do (io $ print (T.pp renMod)) + -- io $ exitSuccess +--} + + -- when generating the prim map for the typechecker, if we're checking the -- prelude, we have to generate the map from the renaming environment, as we -- don't have the interface yet. @@ -453,21 +621,22 @@ else getPrimMap -- typecheck - let act = TCAction { tcAction = how - , tcLinter = moduleLinter (P.thing (P.mName m)) + let act = TCAction { tcAction = T.tcModule + , tcLinter = tcTopEntitytLinter (P.thing (P.mName m)) , tcPrims = prims } - tcm0 <- typecheck act (R.rmModule renMod) noIfaceParams (R.rmImported renMod) - - let tcm = tcm0 -- fromMaybe tcm0 (addModParams tcm0) + tcm <- typecheck act (R.rmModule renMod) NoParams (R.rmImported renMod) - rewMod <- liftSupply (`rewModule` tcm) + rewMod <- case tcm of + T.TCTopModule mo -> T.TCTopModule <$> liftSupply (`rewModule` mo) + T.TCTopSignature {} -> pure tcm pure (R.rmInScope renMod,rewMod) data TCLinter o = TCLinter { lintCheck :: - o -> T.InferInput -> Either (Range, TcSanity.Error) [TcSanity.ProofObligation] + o -> T.InferInput -> + Either (Range, TcSanity.Error) [TcSanity.ProofObligation] , lintModule :: Maybe P.ModName } @@ -478,7 +647,8 @@ case TcSanity.tcExpr i e' of Left err -> Left err Right (s1,os) - | TcSanity.same s s1 -> Right os + | TcSanity.SameIf os' <- TcSanity.same s s1 -> + Right (map T.tMono os' ++ os) | otherwise -> Left ( fromMaybe emptyRange (getLoc e') , TcSanity.TypeMismatch "exprLinter" s s1 ) @@ -502,6 +672,17 @@ , lintModule = Just m } +tcTopEntitytLinter :: P.ModName -> TCLinter T.TCTopEntity +tcTopEntitytLinter m = TCLinter + { lintCheck = \m' i -> case m' of + T.TCTopModule mo -> + lintCheck (moduleLinter m) mo i + T.TCTopSignature {} -> Right [] + -- XXX: what can we lint about module interfaces + , lintModule = Just m + } + + type Act i o = i -> T.InferInput -> IO (T.InferOutput o) data TCAction i o = TCAction @@ -511,8 +692,8 @@ } typecheck :: - (Show i, Show o, HasLoc i) => TCAction i o -> i -> - IfaceParams -> IfaceDecls -> ModuleM o + (Show i, Show o, HasLoc i) => + TCAction i o -> i -> ModContextParams -> IfaceDecls -> ModuleM o typecheck act i params env = do let range = fromMaybe emptyRange (getLoc i) @@ -531,8 +712,12 @@ CoreLint -> case lintCheck (tcLinter act) o input of Right as -> let ppIt l = mapM_ (logPrint l . T.pp) - in withLogger ppIt as - Left err -> panic "Core lint failed:" [show err] + in withLogger ppIt (TcSanity.onlyNonTrivial as) + Left (loc,err) -> + panic "Core lint failed:" + [ "Location: " ++ show (T.pp loc) + , show (T.pp err) + ] return o T.InferFailed nameMap warns errs -> @@ -540,8 +725,9 @@ typeCheckingFailed nameMap errs -- | Generate input for the typechecker. -genInferInput :: Range -> PrimMap -> IfaceParams -> IfaceDecls -> ModuleM T.InferInput -genInferInput r prims params env' = do +genInferInput :: Range -> PrimMap -> ModContextParams -> IfaceDecls -> + ModuleM T.InferInput +genInferInput r prims params env = do seeds <- getNameSeeds monoBinds <- getMonoBinds solver <- getTCSolver @@ -549,25 +735,29 @@ searchPath <- getSearchPath callStacks <- getCallStacks - -- TODO: include the environment needed by the module - let env = flatPublicDecls env' - -- XXX: we should really just pass this directly + topMods <- getAllLoaded + topSigs <- getAllLoadedSignatures + return T.InferInput - { T.inpRange = r - , T.inpVars = Map.map ifDeclSig (ifDecls env) - , T.inpTSyns = ifTySyns env - , T.inpNewtypes = ifNewtypes env - , T.inpAbstractTypes = ifAbstractTypes env - , T.inpNameSeeds = seeds - , T.inpMonoBinds = monoBinds - , T.inpCallStacks = callStacks - , T.inpSearchPath = searchPath - , T.inpSupply = supply - , T.inpPrimNames = prims - , T.inpParamTypes = ifParamTypes params - , T.inpParamConstraints = ifParamConstraints params - , T.inpParamFuns = ifParamFuns params + { T.inpRange = r + , T.inpVars = Map.map ifDeclSig (ifDecls env) + , T.inpTSyns = ifTySyns env + , T.inpNewtypes = ifNewtypes env + , T.inpAbstractTypes = ifAbstractTypes env + , T.inpSignatures = ifSignatures env + , T.inpNameSeeds = seeds + , T.inpMonoBinds = monoBinds + , T.inpCallStacks = callStacks + , T.inpSearchPath = searchPath + , T.inpSupply = supply + , T.inpParams = case params of + NoParams -> T.allParamNames mempty + FunctorParams ps -> T.allParamNames ps + InterfaceParams ps -> ps + , T.inpPrimNames = prims , T.inpSolver = solver + , T.inpTopModules = topMods + , T.inpTopSignatures = topSigs } @@ -585,6 +775,22 @@ let ?callStacks = callStacks io $ E.runEval mempty (E.evalExpr Concrete (env <> deEnv denv) e) + +benchmarkExpr :: Double -> T.Expr -> ModuleM BenchmarkStats +benchmarkExpr period e = do + env <- getEvalEnv + denv <- getDynEnv + evopts <- getEvalOptsAction + let env' = env <> deEnv denv + let tbl = Concrete.primTable evopts + let ?evalPrim = \i -> Right <$> Map.lookup i tbl + let ?range = emptyRange + callStacks <- getCallStacks + let ?callStacks = callStacks + + let eval expr = E.runEval mempty $ + E.evalExpr Concrete env' expr >>= E.forceValue + io $ benchmark period eval e evalDecls :: [T.DeclGroup] -> ModuleM () evalDecls dgs = do diff --git a/src/Cryptol/ModuleSystem/Binds.hs b/src/Cryptol/ModuleSystem/Binds.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/ModuleSystem/Binds.hs @@ -0,0 +1,434 @@ +{-# Language BlockArguments #-} +{-# Language RecordWildCards #-} +{-# Language FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +module Cryptol.ModuleSystem.Binds + ( BindsNames + , TopDef(..) + , Mod(..) + , ModKind(..) + , modNested + , modBuilder + , topModuleDefs + , topDeclsDefs + , newModParam + , InModule(..) + , ifaceToMod + , ifaceSigToMod + , modToMap + , defsOf + ) where + +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Maybe(fromMaybe) +import Control.Monad(foldM) +import qualified MonadLib as M + +import Cryptol.Utils.Panic (panic) +import Cryptol.Utils.Ident(allNamespaces) +import Cryptol.Parser.Position +import Cryptol.Parser.Name(isGeneratedName) +import Cryptol.Parser.AST +import Cryptol.ModuleSystem.Exports(exportedDecls,exported) +import Cryptol.ModuleSystem.Renamer.Error +import Cryptol.ModuleSystem.Name +import Cryptol.ModuleSystem.Names +import Cryptol.ModuleSystem.NamingEnv +import Cryptol.ModuleSystem.Interface +import Cryptol.TypeCheck.Type(ModParamNames(..)) + + + +data TopDef = TopMod ModName (Mod ()) + | TopInst ModName (ImpName PName) (ModuleInstanceArgs PName) + +-- | Things defined by a module +data Mod a = Mod + { modImports :: [ ImportG (ImpName PName) ] + , modKind :: ModKind + , modInstances :: Map Name (ImpName PName, ModuleInstanceArgs PName) + , modMods :: Map Name (Mod a) -- ^ this includes signatures + + , modDefines :: NamingEnv + {- ^ Things defined by this module. Note the for normal modules we + really just need the public names, however for things within + functors we need all defined names, so that we can generate fresh + names in instantiations -} + + , modPublic :: !(Set Name) + -- ^ These are the exported names + + , modState :: a + {- ^ Used in the import loop to track the current state of processing. + The reason this is here, rather than just having a pair in the + other algorithm is because this type is recursive (for nested modules) + and it is conveninet to keep track for all modules at once -} + } + +modNested :: Mod a -> Set Name +modNested m = Set.unions [ Map.keysSet (modInstances m) + , Map.keysSet (modMods m) + ] + +instance Functor Mod where + fmap f m = m { modState = f (modState m) + , modMods = fmap f <$> modMods m + } + +-- | Generate a map from this module and all modules nested in it. +modToMap :: + ImpName Name -> Mod () -> + Map (ImpName Name) (Mod ()) -> Map (ImpName Name) (Mod ()) +modToMap x m mp = Map.insert x m (Map.foldrWithKey add mp (modMods m)) + where + add n = modToMap (ImpNested n) + +-- | Make a `Mod` from the public declarations in an interface. +-- This is used to handle imports. +ifaceToMod :: IfaceG name -> Mod () +ifaceToMod iface = ifaceNamesToMod iface (ifaceIsFunctor iface) (ifNames iface) + +ifaceNamesToMod :: IfaceG topname -> Bool -> IfaceNames name -> Mod () +ifaceNamesToMod iface params names = + Mod + { modKind = if params then AFunctor else AModule + , modMods = (ifaceNamesToMod iface False <$> ifModules decls) + `Map.union` + (ifaceToMod <$> ifFunctors decls) + `Map.union` + (ifaceSigToMod <$> ifSignatures decls) + , modDefines = namingEnvFromNames defs + , modPublic = ifsPublic names + + , modImports = [] + , modInstances = mempty + , modState = () + } + where + defs = ifsDefines names + isLocal x = x `Set.member` defs + decls = filterIfaceDecls isLocal (ifDefines iface) + + +ifaceSigToMod :: ModParamNames -> Mod () +ifaceSigToMod ps = Mod + { modImports = [] + , modKind = ASignature + , modInstances = mempty + , modMods = mempty + , modDefines = env + , modPublic = namingEnvNames env + , modState = () + } + where + env = modParamsNamingEnv ps + + + + + + +type ModBuilder = SupplyT (M.StateT [RenamerError] M.Id) + +modBuilder :: ModBuilder a -> Supply -> ((a, [RenamerError]),Supply) +modBuilder m s = ((a,errs),s1) + where ((a,s1),errs) = M.runId (M.runStateT [] (runSupplyT s m)) + +defErr :: RenamerError -> ModBuilder () +defErr a = M.lift (M.sets_ (a:)) + +defNames :: BuildNamingEnv -> ModBuilder NamingEnv +defNames b = liftSupply \s -> M.runId (runSupplyT s (runBuild b)) + + +topModuleDefs :: Module PName -> ModBuilder TopDef +topModuleDefs m = + case mDef m of + NormalModule ds -> TopMod mname <$> declsToMod (Just (TopModule mname)) ds + FunctorInstance f as _ -> pure (TopInst mname (thing f) as) + InterfaceModule s -> TopMod mname <$> sigToMod (TopModule mname) s + where + mname = thing (mName m) + +topDeclsDefs :: ModPath -> [TopDecl PName] -> ModBuilder (Mod ()) +topDeclsDefs = declsToMod . Just + +sigToMod :: ModPath -> Signature PName -> ModBuilder (Mod ()) +sigToMod mp sig = + do env <- defNames (signatureDefs mp sig) + pure Mod { modImports = map thing (sigImports sig) + , modKind = ASignature + , modInstances = mempty + , modMods = mempty + , modDefines = env + , modPublic = namingEnvNames env + , modState = () + } + + + +declsToMod :: Maybe ModPath -> [TopDecl PName] -> ModBuilder (Mod ()) +declsToMod mbPath ds = + do defs <- defNames (foldMap (namingEnv . InModule mbPath) ds) + let expSpec = exportedDecls ds + let pub = Set.fromList + [ name + | ns <- allNamespaces + , pname <- Set.toList (exported ns expSpec) + , name <- lookupListNS ns pname defs + ] + + case findAmbig defs of + bad@(_ : _) : _ -> + -- defErr (MultipleDefinitions mbPath (nameIdent f) (map nameLoc bad)) + defErr (OverlappingSyms bad) + _ -> pure () + + let mo = Mod { modImports = [ thing i | DImport i <- ds ] + , modKind = if any isParamDecl ds + then AFunctor else AModule + , modInstances = mempty + , modMods = mempty + , modDefines = defs + , modPublic = pub + , modState = () + } + + foldM (checkNest defs) mo ds + + where + checkNest defs mo d = + case d of + DModule tl -> + do let NestedModule nmod = tlValue tl + pname = thing (mName nmod) + name = case lookupNS NSModule pname defs of + Just xs -> anyOne xs + _ -> panic "declsToMod" ["undefined name", show pname] + case mbPath of + Nothing -> + do defErr (UnexpectedNest (srcRange (mName nmod)) pname) + pure mo + Just path -> + case mDef nmod of + + NormalModule xs -> + do m <- declsToMod (Just (Nested path (nameIdent name))) xs + pure mo { modMods = Map.insert name m (modMods mo) } + + FunctorInstance f args _ -> + pure mo { modInstances = Map.insert name (thing f, args) + (modInstances mo) } + + InterfaceModule sig -> + do m <- sigToMod (Nested path (nameIdent name)) sig + pure mo { modMods = Map.insert name m (modMods mo) } + + + _ -> pure mo + + + +-- | These are the names "owned" by the signature. These names are +-- used when resolving the signature. They are also used to figure out what +-- names to instantuate when the signature is used. +signatureDefs :: ModPath -> Signature PName -> BuildNamingEnv +signatureDefs m sig = + mconcat [ namingEnv (InModule loc p) | p <- sigTypeParams sig ] + <> mconcat [ namingEnv (InModule loc p) | p <- sigFunParams sig ] + <> mconcat [ namingEnv (InModule loc p) | p <- sigDecls sig ] + where + loc = Just m +-------------------------------------------------------------------------------- + + + + +-------------------------------------------------------------------------------- +-- Computes the names introduced by various declarations. + +-- | Things that define exported names. +class BindsNames a where + namingEnv :: a -> BuildNamingEnv + +newtype BuildNamingEnv = BuildNamingEnv { runBuild :: SupplyT M.Id NamingEnv } + +buildNamingEnv :: BuildNamingEnv -> Supply -> (NamingEnv,Supply) +buildNamingEnv b supply = M.runId $ runSupplyT supply $ runBuild b + +-- | Generate a 'NamingEnv' using an explicit supply. +defsOf :: BindsNames a => a -> Supply -> (NamingEnv,Supply) +defsOf = buildNamingEnv . namingEnv + +instance Semigroup BuildNamingEnv where + BuildNamingEnv a <> BuildNamingEnv b = BuildNamingEnv $ + do x <- a + y <- b + return (mappend x y) + +instance Monoid BuildNamingEnv where + mempty = BuildNamingEnv (pure mempty) + + mappend = (<>) + + mconcat bs = BuildNamingEnv $ + do ns <- sequence (map runBuild bs) + return (mconcat ns) + +instance BindsNames NamingEnv where + namingEnv env = BuildNamingEnv (return env) + {-# INLINE namingEnv #-} + +instance BindsNames a => BindsNames (Maybe a) where + namingEnv = foldMap namingEnv + {-# INLINE namingEnv #-} + +instance BindsNames a => BindsNames [a] where + namingEnv = foldMap namingEnv + {-# INLINE namingEnv #-} + +-- | Generate a type renaming environment from the parameters that are bound by +-- this schema. +instance BindsNames (Schema PName) where + namingEnv (Forall ps _ _ _) = foldMap namingEnv ps + {-# INLINE namingEnv #-} + + + +-- | Introduce the name +instance BindsNames (InModule (Bind PName)) where + namingEnv (InModule mb b) = BuildNamingEnv $ + do let Located { .. } = bName b + n <- case mb of + Just m -> newTop NSValue m thing (bFixity b) srcRange + Nothing -> newLocal NSValue thing srcRange -- local fixitiies? + + return (singletonNS NSValue thing n) + +-- | Generate the naming environment for a type parameter. +instance BindsNames (TParam PName) where + namingEnv TParam { .. } = BuildNamingEnv $ + do let range = fromMaybe emptyRange tpRange + n <- newLocal NSType tpName range + return (singletonNS NSType tpName n) + + +instance BindsNames (InModule (TopDecl PName)) where + namingEnv (InModule ns td) = + case td of + Decl d -> namingEnv (InModule ns (tlValue d)) + DPrimType d -> namingEnv (InModule ns (tlValue d)) + TDNewtype d -> namingEnv (InModule ns (tlValue d)) + DParamDecl {} -> mempty + Include _ -> mempty + DImport {} -> mempty -- see 'openLoop' in the renamer + DModule m -> namingEnv (InModule ns (tlValue m)) + DModParam {} -> mempty -- shouldn't happen + DInterfaceConstraint {} -> mempty + -- handled in the renamer as we need to resolve + -- the signature name first (similar to import) + + +instance BindsNames (InModule (NestedModule PName)) where + namingEnv (InModule ~(Just m) (NestedModule mdef)) = BuildNamingEnv $ + do let pnmame = mName mdef + nm <- newTop NSModule m (thing pnmame) Nothing (srcRange pnmame) + pure (singletonNS NSModule (thing pnmame) nm) + +instance BindsNames (InModule (PrimType PName)) where + namingEnv (InModule ~(Just m) PrimType { .. }) = + BuildNamingEnv $ + do let Located { .. } = primTName + nm <- newTop NSType m thing primTFixity srcRange + pure (singletonNS NSType thing nm) + +instance BindsNames (InModule (ParameterFun PName)) where + namingEnv (InModule ~(Just ns) ParameterFun { .. }) = BuildNamingEnv $ + do let Located { .. } = pfName + ntName <- newTop NSValue ns thing pfFixity srcRange + return (singletonNS NSValue thing ntName) + +instance BindsNames (InModule (ParameterType PName)) where + namingEnv (InModule ~(Just ns) ParameterType { .. }) = BuildNamingEnv $ + -- XXX: we don't seem to have a fixity environment at the type level + do let Located { .. } = ptName + ntName <- newTop NSType ns thing Nothing srcRange + return (singletonNS NSType thing ntName) + +instance BindsNames (InModule (Newtype PName)) where + namingEnv (InModule ~(Just ns) Newtype { .. }) = BuildNamingEnv $ + do let Located { .. } = nName + ntName <- newTop NSType ns thing Nothing srcRange + ntConName <- newTop NSValue ns thing Nothing srcRange + return (singletonNS NSType thing ntName `mappend` + singletonNS NSValue thing ntConName) + +-- | The naming environment for a single declaration. +instance BindsNames (InModule (Decl PName)) where + namingEnv (InModule pfx d) = case d of + DBind b -> namingEnv (InModule pfx b) + DSignature ns _sig -> foldMap qualBind ns + DPragma ns _p -> foldMap qualBind ns + DType syn -> qualType (tsName syn) (tsFixity syn) + DProp syn -> qualType (psName syn) (psFixity syn) + DLocated d' _ -> namingEnv (InModule pfx d') + DRec {} -> panic "namingEnv" [ "DRec" ] + DPatBind _pat _e -> panic "namingEnv" ["Unexpected pattern binding"] + DFixity{} -> panic "namingEnv" ["Unexpected fixity declaration"] + + where + + mkName ns ln fx = case pfx of + Just m -> newTop ns m (thing ln) fx (srcRange ln) + Nothing -> newLocal ns (thing ln) (srcRange ln) + + qualBind ln = BuildNamingEnv $ + do n <- mkName NSValue ln Nothing + return (singletonNS NSValue (thing ln) n) + + qualType ln f = BuildNamingEnv $ + do n <- mkName NSType ln f + return (singletonNS NSType (thing ln) n) + +instance BindsNames (InModule (SigDecl PName)) where + namingEnv (InModule m d) = + case d of + SigTySyn ts _ -> namingEnv (InModule m (DType ts)) + SigPropSyn ps _ -> namingEnv (InModule m (DProp ps)) + + + + +-------------------------------------------------------------------------------- +-- Helpers + +newTop :: + FreshM m => Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name +newTop ns m thing fx rng = + liftSupply (mkDeclared ns m src (getIdent thing) fx rng) + where src = if isGeneratedName thing then SystemName else UserName + +newLocal :: FreshM m => Namespace -> PName -> Range -> m Name +newLocal ns thing rng = liftSupply (mkLocal ns (getIdent thing) rng) + +-- | Given a name in a signature, make a name for the parameter corresponding +-- to the signature. +newModParam :: FreshM m => ModPath -> Ident -> Range -> Name -> m Name +newModParam m i rng n = liftSupply (mkModParam m i rng n) + + +{- | Do something in the context of a module. +If `Nothing` than we are working with a local declaration. +Otherwise we are at the top-level of the given module. + +By wrapping types with this, we can pass the module path +to methods that need the extra information. -} +data InModule a = InModule (Maybe ModPath) a + deriving (Functor,Traversable,Foldable,Show) + + + diff --git a/src/Cryptol/ModuleSystem/Env.hs b/src/Cryptol/ModuleSystem/Env.hs --- a/src/Cryptol/ModuleSystem/Env.hs +++ b/src/Cryptol/ModuleSystem/Env.hs @@ -7,17 +7,20 @@ -- Portability : portable {-# LANGUAGE CPP #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Cryptol.ModuleSystem.Env where #ifndef RELOCATABLE import Paths_cryptol (getDataDir) #endif +import Cryptol.Backend.FFI (ForeignSrc, unloadForeignSrc, getForeignSrcPath) import Cryptol.Eval (EvalEnv) import Cryptol.ModuleSystem.Fingerprint import Cryptol.ModuleSystem.Interface @@ -34,13 +37,16 @@ import qualified Control.Exception as X import Data.Function (on) import Data.Set(Set) +import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map import Data.Semigroup +import Data.Maybe(fromMaybe) import System.Directory (getAppUserDataDirectory, getCurrentDirectory) import System.Environment(getExecutablePath) import System.FilePath ((), normalise, joinPath, splitPath, takeDirectory) import qualified Data.List as List +import Data.Foldable import GHC.Generics (Generic) import Control.DeepSeq @@ -99,14 +105,19 @@ | CoreLint -- ^ Run core lint deriving (Generic, NFData) -resetModuleEnv :: ModuleEnv -> ModuleEnv -resetModuleEnv env = env - { meLoadedModules = mempty - , meNameSeeds = T.nameSeeds - , meEvalEnv = mempty - , meFocusedModule = Nothing - , meDynEnv = mempty - } +resetModuleEnv :: ModuleEnv -> IO ModuleEnv +resetModuleEnv env = do + for_ (getLoadedModules $ meLoadedModules env) $ \lm -> + case lmForeignSrc (lmData lm) of + Just fsrc -> unloadForeignSrc fsrc + _ -> pure () + pure env + { meLoadedModules = mempty + , meNameSeeds = T.nameSeeds + , meEvalEnv = mempty + , meFocusedModule = Nothing + , meDynEnv = mempty + } initialModuleEnv :: IO ModuleEnv initialModuleEnv = do @@ -171,9 +182,9 @@ loadedNonParamModules :: ModuleEnv -> [T.Module] loadedNonParamModules = map lmModule . lmLoadedModules . meLoadedModules -loadedNewtypes :: ModuleEnv -> Map Name IfaceNewtype +loadedNewtypes :: ModuleEnv -> Map Name T.Newtype loadedNewtypes menv = Map.unions - [ ifNewtypes (ifPublic i) <> ifNewtypes (ifPrivate i) + [ ifNewtypes (ifDefines i) <> ifNewtypes (ifDefines i) | i <- map lmInterface (getLoadedModules (meLoadedModules menv)) ] @@ -184,10 +195,22 @@ allDeclGroups :: ModuleEnv -> [T.DeclGroup] allDeclGroups = concatMap T.mDecls . loadedNonParamModules +data ModContextParams = + InterfaceParams T.ModParamNames + | FunctorParams T.FunctorParams + | NoParams + +modContextParamNames :: ModContextParams -> T.ModParamNames +modContextParamNames mp = + case mp of + InterfaceParams ps -> ps + FunctorParams ps -> T.allParamNames ps + NoParams -> T.allParamNames mempty + -- | Contains enough information to browse what's in scope, -- or type check new expressions. data ModContext = ModContext - { mctxParams :: IfaceParams + { mctxParams :: ModContextParams -- T.FunctorParams , mctxExported :: Set Name , mctxDecls :: IfaceDecls -- ^ Should contain at least names in NamingEnv, but may have more @@ -199,7 +222,7 @@ -- This instance is a bit bogus. It is mostly used to add the dynamic -- environemnt to an existing module, and it makes sense for that use case. instance Semigroup ModContext where - x <> y = ModContext { mctxParams = jnParams (mctxParams x) (mctxParams y) + x <> y = ModContext { mctxParams = jnPs (mctxParams x) (mctxParams y) , mctxExported = mctxExported x <> mctxExported y , mctxDecls = mctxDecls x <> mctxDecls y , mctxNames = names @@ -208,14 +231,15 @@ where names = mctxNames x `R.shadowing` mctxNames y - jnParams a b - | isEmptyIfaceParams a = b - | isEmptyIfaceParams b = a - | otherwise = - panic "ModContext" [ "Cannot combined 2 parameterized contexts" ] + jnPs as bs = + case (as,bs) of + (NoParams,_) -> bs + (_,NoParams) -> as + (FunctorParams xs, FunctorParams ys) -> FunctorParams (xs <> ys) + _ -> panic "(<>) @ ModContext" ["Can't combine parameters"] instance Monoid ModContext where - mempty = ModContext { mctxParams = noIfaceParams + mempty = ModContext { mctxParams = NoParams , mctxDecls = mempty , mctxExported = mempty , mctxNames = mempty @@ -229,16 +253,36 @@ do lm <- lookupModule mname me let localIface = lmInterface lm localNames = lmNamingEnv lm - loadedDecls = map (ifPublic . lmInterface) + + -- XXX: do we want only public ones here? + loadedDecls = map (ifDefines . lmInterface) $ getLoadedModules (meLoadedModules me) + + params = ifParams localIface pure ModContext - { mctxParams = ifParams localIface - , mctxExported = ifaceDeclsNames (ifPublic localIface) - , mctxDecls = mconcat (ifPrivate localIface : loadedDecls) + { mctxParams = if Map.null params then NoParams + else FunctorParams params + , mctxExported = ifsPublic (ifNames localIface) + , mctxDecls = mconcat (ifDefines localIface : loadedDecls) , mctxNames = localNames , mctxNameDisp = R.toNameDisp localNames } + `mplus` + do lm <- lookupSignature mname me + let localNames = lmNamingEnv lm + -- XXX: do we want only public ones here? + loadedDecls = map (ifDefines . lmInterface) + $ getLoadedModules (meLoadedModules me) + pure ModContext + { mctxParams = InterfaceParams (lmData lm) + , mctxExported = Set.empty + , mctxDecls = mconcat loadedDecls + , mctxNames = localNames + , mctxNameDisp = R.toNameDisp localNames + } + + dynModContext :: ModuleEnv -> ModContext dynModContext me = mempty { mctxNames = dynNames , mctxNameDisp = R.toNameDisp dynNames @@ -277,6 +321,17 @@ (InMem a _, InMem b _) -> a == b _ -> False +-- | In-memory things are compared by label. +instance Ord ModulePath where + compare p1 p2 = + case (p1,p2) of + (InFile x, InFile y) -> compare x y + (InMem a _, InMem b _) -> compare a b + (InMem {}, InFile {}) -> LT + (InFile {}, InMem {}) -> GT + + + instance PP ModulePath where ppPrec _ e = case e of @@ -303,24 +358,49 @@ , lmLoadedParamModules :: [LoadedModule] -- ^ Loaded parameterized modules. + , lmLoadedSignatures :: ![LoadedSignature] + } deriving (Show, Generic, NFData) +data LoadedEntity = + ALoadedModule LoadedModule + | ALoadedFunctor LoadedModule + | ALoadedInterface LoadedSignature + +getLoadedEntities :: + LoadedModules -> Map ModName LoadedEntity +getLoadedEntities lm = + Map.fromList $ [ (lmName x, ALoadedModule x) | x <- lmLoadedModules lm ] ++ + [ (lmName x, ALoadedFunctor x) | x <- lmLoadedParamModules lm ] ++ + [ (lmName x, ALoadedInterface x) | x <- lmLoadedSignatures lm ] + getLoadedModules :: LoadedModules -> [LoadedModule] getLoadedModules x = lmLoadedParamModules x ++ lmLoadedModules x +getLoadedNames :: LoadedModules -> Set ModName +getLoadedNames lm = Set.fromList + $ map lmName (lmLoadedModules lm) + ++ map lmName (lmLoadedParamModules lm) + ++ map lmName (lmLoadedSignatures lm) + instance Semigroup LoadedModules where l <> r = LoadedModules { lmLoadedModules = List.unionBy ((==) `on` lmName) (lmLoadedModules l) (lmLoadedModules r) - , lmLoadedParamModules = lmLoadedParamModules l ++ lmLoadedParamModules r } + , lmLoadedParamModules = lmLoadedParamModules l ++ lmLoadedParamModules r + , lmLoadedSignatures = lmLoadedSignatures l ++ lmLoadedSignatures r + } instance Monoid LoadedModules where mempty = LoadedModules { lmLoadedModules = [] , lmLoadedParamModules = [] + , lmLoadedSignatures = [] } mappend = (<>) -data LoadedModule = LoadedModule +-- | A generic type for loaded things. +-- The things can be either modules or signatures. +data LoadedModuleG a = LoadedModule { lmName :: ModName -- ^ The name of this module. Should match what's in 'lmModule' @@ -335,36 +415,94 @@ , lmNamingEnv :: !R.NamingEnv -- ^ What's in scope in this module - , lmInterface :: Iface + , lmFileInfo :: !FileInfo + + , lmData :: a + } deriving (Show, Generic, NFData) + +type LoadedModule = LoadedModuleG LoadedModuleData + +lmModule :: LoadedModule -> T.Module +lmModule = lmdModule . lmData + +lmInterface :: LoadedModule -> Iface +lmInterface = lmdInterface . lmData + +data LoadedModuleData = LoadedModuleData + { lmdInterface :: Iface -- ^ The module's interface. - , lmModule :: T.Module + , lmdModule :: T.Module -- ^ The actual type-checked module - , lmFingerprint :: Fingerprint + , lmForeignSrc :: Maybe ForeignSrc + -- ^ The dynamically loaded source for any foreign functions in the module } deriving (Show, Generic, NFData) +type LoadedSignature = LoadedModuleG T.ModParamNames + + -- | Has this module been loaded already. isLoaded :: ModName -> LoadedModules -> Bool -isLoaded mn lm = any ((mn ==) . lmName) (getLoadedModules lm) +isLoaded mn lm = mn `Set.member` getLoadedNames lm -- | Is this a loaded parameterized module. isLoadedParamMod :: ModName -> LoadedModules -> Bool isLoadedParamMod mn ln = any ((mn ==) . lmName) (lmLoadedParamModules ln) +-- | Is this a loaded interface module. +isLoadedInterface :: ModName -> LoadedModules -> Bool +isLoadedInterface mn ln = any ((mn ==) . lmName) (lmLoadedSignatures ln) + + + +lookupTCEntity :: ModName -> ModuleEnv -> Maybe (LoadedModuleG T.TCTopEntity) +lookupTCEntity m env = + case lookupModule m env of + Just lm -> pure lm { lmData = T.TCTopModule (lmModule lm) } + Nothing -> + do lm <- lookupSignature m env + pure lm { lmData = T.TCTopSignature m (lmData lm) } + -- | Try to find a previously loaded module lookupModule :: ModName -> ModuleEnv -> Maybe LoadedModule lookupModule mn me = search lmLoadedModules `mplus` search lmLoadedParamModules where search how = List.find ((mn ==) . lmName) (how (meLoadedModules me)) +lookupSignature :: ModName -> ModuleEnv -> Maybe LoadedSignature +lookupSignature mn me = + List.find ((mn ==) . lmName) (lmLoadedSignatures (meLoadedModules me)) +addLoadedSignature :: + ModulePath -> String -> + FileInfo -> + R.NamingEnv -> + ModName -> T.ModParamNames -> + LoadedModules -> LoadedModules +addLoadedSignature path ident fi nameEnv nm si lm + | isLoaded nm lm = lm + | otherwise = lm { lmLoadedSignatures = loaded : lmLoadedSignatures lm } + where + loaded = LoadedModule + { lmName = nm + , lmFilePath = path + , lmModuleId = ident + , lmNamingEnv = nameEnv + , lmData = si + , lmFileInfo = fi + } + -- | Add a freshly loaded module. If it was previously loaded, then -- the new version is ignored. addLoadedModule :: - ModulePath -> String -> Fingerprint -> R.NamingEnv -> T.Module -> - LoadedModules -> LoadedModules -addLoadedModule path ident fp nameEnv tm lm + ModulePath -> + String -> + FileInfo -> + R.NamingEnv -> + Maybe ForeignSrc -> + T.Module -> LoadedModules -> LoadedModules +addLoadedModule path ident fi nameEnv fsrc tm lm | isLoaded (T.mName tm) lm = lm | T.isParametrizedModule tm = lm { lmLoadedParamModules = loaded : lmLoadedParamModules lm } @@ -376,21 +514,53 @@ , lmFilePath = path , lmModuleId = ident , lmNamingEnv = nameEnv - , lmInterface = T.genIface tm - , lmModule = tm - , lmFingerprint = fp + , lmData = LoadedModuleData + { lmdInterface = T.genIface tm + , lmdModule = tm + , lmForeignSrc = fsrc + } + , lmFileInfo = fi } -- | Remove a previously loaded module. -- Note that this removes exactly the modules specified by the predicate. -- One should be carfule to preserve the invariant on 'LoadedModules'. -removeLoadedModule :: (LoadedModule -> Bool) -> LoadedModules -> LoadedModules +removeLoadedModule :: + (forall a. LoadedModuleG a -> Bool) -> LoadedModules -> LoadedModules removeLoadedModule rm lm = LoadedModules - { lmLoadedModules = filter (not . rm) (lmLoadedModules lm) - , lmLoadedParamModules = filter (not . rm) (lmLoadedParamModules lm) + { lmLoadedModules = filter (not . rm) (lmLoadedModules lm) + , lmLoadedParamModules = filter (not . rm) (lmLoadedParamModules lm) + , lmLoadedSignatures = filter (not . rm) (lmLoadedSignatures lm) } +-- FileInfo -------------------------------------------------------------------- + +data FileInfo = FileInfo + { fiFingerprint :: Fingerprint + , fiIncludeDeps :: Set FilePath + , fiImportDeps :: Set ModName + , fiForeignDeps :: Set FilePath + } deriving (Show,Generic,NFData) + + +fileInfo :: + Fingerprint -> + Set FilePath -> + Set ModName -> + Maybe ForeignSrc -> + FileInfo +fileInfo fp incDeps impDeps fsrc = + FileInfo + { fiFingerprint = fp + , fiIncludeDeps = incDeps + , fiImportDeps = impDeps + , fiForeignDeps = fromMaybe Set.empty + do src <- fsrc + Set.singleton <$> getForeignSrcPath src + } + + -- Dynamic Environments -------------------------------------------------------- -- | Extra information we need to carry around to dynamically extend @@ -433,6 +603,8 @@ , ifAbstractTypes = Map.empty , ifDecls = decls , ifModules = Map.empty + , ifFunctors = Map.empty + , ifSignatures = Map.empty } where decls = mconcat diff --git a/src/Cryptol/ModuleSystem/Exports.hs b/src/Cryptol/ModuleSystem/Exports.hs --- a/src/Cryptol/ModuleSystem/Exports.hs +++ b/src/Cryptol/ModuleSystem/Exports.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} module Cryptol.ModuleSystem.Exports where import Data.Set(Set) @@ -10,30 +11,32 @@ import GHC.Generics (Generic) import Cryptol.Parser.AST -import Cryptol.Parser.Names(namesD,tnamesD,tnamesNT) +import Cryptol.Parser.Names(namesD,tnamesD,namesNT,tnamesNT) import Cryptol.ModuleSystem.Name -modExports :: Ord name => ModuleG mname name -> ExportSpec name -modExports m = fold (concat [ exportedNames d | d <- mDecls m ]) - +exportedDecls :: Ord name => [TopDecl name] -> ExportSpec name +exportedDecls ds = fold (concat [ exportedNames d | d <- ds ]) exportedNames :: Ord name => TopDecl name -> [ExportSpec name] -exportedNames (Decl td) = map exportBind (names namesD td) - ++ map exportType (names tnamesD td) -exportedNames (DPrimType t) = [ exportType (thing . primTName <$> t) ] -exportedNames (TDNewtype nt) = map exportType (names tnamesNT nt) -exportedNames (Include {}) = [] -exportedNames (DImport {}) = [] -exportedNames (DParameterFun {}) = [] -exportedNames (DParameterType {}) = [] -exportedNames (DParameterConstraint {}) = [] -exportedNames (DModule nested) = - case tlValue nested of - NestedModule x -> - [exportName NSModule nested { tlValue = thing (mName x) }] +exportedNames decl = + case decl of + Decl td -> map exportBind (names namesD td) + ++ map exportType (names tnamesD td) + DPrimType t -> [ exportType (thing . primTName <$> t) ] + TDNewtype nt -> map exportType (names tnamesNT nt) ++ + map exportBind (names namesNT nt) + Include {} -> [] + DImport {} -> [] + DParamDecl {} -> [] + DInterfaceConstraint {} -> [] + DModule nested -> + case tlValue nested of + NestedModule x -> + [exportName NSModule nested { tlValue = thing (mName x) }] + DModParam {} -> [] + where + names by td = [ td { tlValue = thing n } | n <- fst (by (tlValue td)) ] -names :: (a -> ([Located a'], b)) -> TopLevel a -> [TopLevel a'] -names by td = [ td { tlValue = thing n } | n <- fst (by (tlValue td)) ] newtype ExportSpec name = ExportSpec (Map Namespace (Set name)) @@ -53,6 +56,9 @@ $ Map.singleton ns $ Set.singleton (tlValue n) | otherwise = mempty + +allExported :: Ord name => ExportSpec name -> Set name +allExported (ExportSpec mp) = Set.unions (Map.elems mp) exported :: Namespace -> ExportSpec name -> Set name exported ns (ExportSpec mp) = Map.findWithDefault Set.empty ns mp diff --git a/src/Cryptol/ModuleSystem/Fingerprint.hs b/src/Cryptol/ModuleSystem/Fingerprint.hs --- a/src/Cryptol/ModuleSystem/Fingerprint.hs +++ b/src/Cryptol/ModuleSystem/Fingerprint.hs @@ -10,6 +10,7 @@ ( Fingerprint , fingerprint , fingerprintFile + , fingerprintHexString ) where import Control.DeepSeq (NFData (rnf)) @@ -17,6 +18,7 @@ import Data.ByteString (ByteString) import Control.Exception (try) import qualified Data.ByteString as B +import qualified Data.Vector as Vector newtype Fingerprint = Fingerprint ByteString deriving (Eq, Show) @@ -37,3 +39,13 @@ case res :: Either IOError ByteString of Left{} -> Nothing Right b -> Just $! fingerprint b + +fingerprintHexString :: Fingerprint -> String +fingerprintHexString (Fingerprint bs) = B.foldr hex "" bs + where + digits = Vector.fromList "0123456789ABCDEF" + digit x = digits Vector.! fromIntegral x + hex b cs = let (x,y) = divMod b 16 + in digit x : digit y : cs + + diff --git a/src/Cryptol/ModuleSystem/InstantiateModule.hs b/src/Cryptol/ModuleSystem/InstantiateModule.hs deleted file mode 100644 --- a/src/Cryptol/ModuleSystem/InstantiateModule.hs +++ /dev/null @@ -1,325 +0,0 @@ -{-# Language FlexibleInstances, PatternGuards #-} -{-# Language BlockArguments #-} --- | Assumes that local names do not shadow top level names. -module Cryptol.ModuleSystem.InstantiateModule - ( instantiateModule - ) where - -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import MonadLib(ReaderT,runReaderT,ask) - -import Cryptol.Utils.Panic(panic) -import Cryptol.Utils.Ident(ModName,modParamIdent) -import Cryptol.Parser.Position(Located(..)) -import Cryptol.ModuleSystem.Name -import Cryptol.TypeCheck.AST -import Cryptol.TypeCheck.Subst(listParamSubst, apSubst) -import Cryptol.TypeCheck.SimpType(tRebuild) - -{- -XXX: Should we simplify constraints in the instantiated modules? - -If so, we also need to adjust the constraint parameters on terms appropriately, -especially when working with dictionaries. --} - - --- | Convert a module instantiation into a partial module. --- The resulting module is incomplete because it is missing the definitions --- from the instantiation. -instantiateModule :: FreshM m => - Module {- ^ Parametrized module -} -> - ModName {- ^ Name of the new module -} -> - Map TParam Type {- ^ Type params -} -> - Map Name Expr {- ^ Value parameters -} -> - m (Name -> Name, [Located Prop], Module) - -- ^ Renaming, instantiated constraints, fresh module, new supply -instantiateModule func newName tpMap vpMap - | not (null (mSubModules func)) = - panic "instantiateModule" - [ "XXX: we don't support functors with nested moduels yet." ] - | otherwise = - runReaderT (TopModule newName) $ - do let oldVpNames = Map.keys vpMap - newVpNames <- mapM freshParamName (Map.keys vpMap) - let vpNames = Map.fromList (zip oldVpNames newVpNames) - - env <- computeEnv func tpMap vpNames - let ren x = case nameNamespace x of - NSValue -> Map.findWithDefault x x (funNameMap env) - NSType -> Map.findWithDefault x x (tyNameMap env) - NSModule -> x - - let rnMp :: Inst a => (a -> Name) -> Map Name a -> Map Name a - rnMp f m = Map.fromList [ (f x, x) | a <- Map.elems m - , let x = inst env a ] - - renamedExports = inst env (mExports func) - renamedTySyns = rnMp tsName (mTySyns func) - renamedNewtypes = rnMp ntName (mNewtypes func) - renamedPrimTys = rnMp atName (mPrimTypes func) - - su = listParamSubst (Map.toList (tyParamMap env)) - - goals = map (fmap (apSubst su)) (mParamConstraints func) - -- Constraints to discharge about the type instances - - let renamedDecls = inst env (mDecls func) - paramDecls = map (mkParamDecl su vpNames) (Map.toList vpMap) - - return ( ren - , goals - , Module - { mName = newName - , mExports = renamedExports - , mImports = mImports func - , mTySyns = renamedTySyns - , mNewtypes = renamedNewtypes - , mPrimTypes = renamedPrimTys - , mParamTypes = Map.empty - , mParamConstraints = [] - , mParamFuns = Map.empty - , mDecls = paramDecls ++ renamedDecls - - , mSubModules = mempty - , mFunctors = mempty - } ) - - where - mkParamDecl su vpNames (x,e) = - NonRecursive Decl - { dName = Map.findWithDefault (error "OOPS") x vpNames - , dSignature = apSubst su - $ mvpType - $ Map.findWithDefault (error "UUPS") x (mParamFuns func) - , dDefinition = DExpr e - , dPragmas = [] -- XXX: which if any pragmas? - , dInfix = False -- XXX: get from parameter? - , dFixity = Nothing -- XXX: get from parameter - , dDoc = Nothing -- XXX: get from parametr(or instance?) - } - - --------------------------------------------------------------------------------- --- Things that need to be renamed - -class Defines t where - defines :: t -> Set Name - -instance Defines t => Defines [t] where - defines = Set.unions . map defines - -instance Defines Decl where - defines = Set.singleton . dName - -instance Defines DeclGroup where - defines d = - case d of - NonRecursive x -> defines x - Recursive x -> defines x - - --------------------------------------------------------------------------------- - -type InstM = ReaderT ModPath - --- | Generate a new instance of a declared name. -freshenName :: FreshM m => Name -> InstM m Name -freshenName x = - do m <- ask - let sys = case nameInfo x of - Declared _ s -> s - _ -> UserName - liftSupply (mkDeclared (nameNamespace x) - m sys (nameIdent x) (nameFixity x) (nameLoc x)) - -freshParamName :: FreshM m => Name -> InstM m Name -freshParamName x = - do m <- ask - let newName = modParamIdent (nameIdent x) - liftSupply (mkDeclared (nameNamespace x) - m UserName newName (nameFixity x) (nameLoc x)) - - - - --- | Compute renaming environment from a module instantiation. --- computeEnv :: ModInst -> InstM Env -computeEnv :: FreshM m => - Module {- ^ Functor being instantiated -} -> - Map TParam Type {- replace type params by type -} -> - Map Name Name {- replace value parameters by other names -} -> - InstM m Env -computeEnv m tpMap vpMap = - do tss <- mapM freshTy (Map.toList (mTySyns m)) - nts <- mapM freshTy (Map.toList (mNewtypes m)) - let tnMap = Map.fromList (tss ++ nts) - - defHere <- mapM mkVParam (Set.toList (defines (mDecls m))) - let fnMap = Map.union vpMap (Map.fromList defHere) - - return Env { funNameMap = fnMap - , tyNameMap = tnMap - , tyParamMap = tpMap - } - where - freshTy (x,_) = do y <- freshenName x - return (x,y) - - mkVParam x = do y <- freshenName x - return (x,y) - - - --------------------------------------------------------------------------------- --- Do the renaming - -data Env = Env - { funNameMap :: Map Name Name - , tyNameMap :: Map Name Name - , tyParamMap :: Map TParam Type - } deriving Show - - -class Inst t where - inst :: Env -> t -> t - -instance Inst a => Inst [a] where - inst env = map (inst env) - -instance Inst Expr where - inst env = go - where - go expr = - case expr of - EVar x -> case Map.lookup x (funNameMap env) of - Just y -> EVar y - _ -> expr - - ELocated r e -> ELocated r (inst env e) - EList xs t -> EList (inst env xs) (inst env t) - ETuple es -> ETuple (inst env es) - ERec xs -> ERec (fmap go xs) - ESel e s -> ESel (go e) s - ESet ty e x v -> ESet (inst env ty) (go e) x (go v) - EIf e1 e2 e3 -> EIf (go e1) (go e2) (go e3) - EComp t1 t2 e mss -> EComp (inst env t1) (inst env t2) - (go e) - (inst env mss) - ETAbs t e -> ETAbs t (go e) - ETApp e t -> ETApp (go e) (inst env t) - EApp e1 e2 -> EApp (go e1) (go e2) - EAbs x t e -> EAbs x (inst env t) (go e) - EProofAbs p e -> EProofAbs (inst env p) (go e) - EProofApp e -> EProofApp (go e) - EWhere e ds -> EWhere (go e) (inst env ds) - - -instance Inst DeclGroup where - inst env dg = - case dg of - NonRecursive d -> NonRecursive (inst env d) - Recursive ds -> Recursive (inst env ds) - -instance Inst DeclDef where - inst env d = - case d of - DPrim -> DPrim - DExpr e -> DExpr (inst env e) - -instance Inst Decl where - inst env d = d { dSignature = inst env (dSignature d) - , dDefinition = inst env (dDefinition d) - , dName = Map.findWithDefault (dName d) (dName d) - (funNameMap env) - } - -instance Inst Match where - inst env m = - case m of - From x t1 t2 e -> From x (inst env t1) (inst env t2) (inst env e) - Let d -> Let (inst env d) - -instance Inst Schema where - inst env s = s { sProps = inst env (sProps s) - , sType = inst env (sType s) - } - -instance Inst Type where - inst env ty = - tRebuild $ - case ty of - TCon tc ts -> TCon (inst env tc) (inst env ts) - TVar tv -> - case tv of - TVBound tp | Just t <- Map.lookup tp (tyParamMap env) -> t - _ -> ty - TUser x ts t -> TUser y (inst env ts) (inst env t) - where y = Map.findWithDefault x x (tyNameMap env) - TRec fs -> TRec (fmap (inst env) fs) - TNewtype nt ts -> TNewtype (inst env nt) (inst env ts) - -instance Inst TCon where - inst env tc = - case tc of - TC x -> TC (inst env x) - _ -> tc - -instance Inst TC where - inst env tc = - case tc of - TCAbstract x -> TCAbstract (inst env x) - _ -> tc - -instance Inst UserTC where - inst env (UserTC x t) = UserTC y t - where y = Map.findWithDefault x x (tyNameMap env) - -instance Inst (ExportSpec Name) where - inst env (ExportSpec spec) = ExportSpec (Map.mapWithKey doNS spec) - where - doNS ns = - case ns of - NSType -> Set.map \x -> Map.findWithDefault x x (tyNameMap env) - NSValue -> Set.map \x -> Map.findWithDefault x x (funNameMap env) - NSModule -> id - - -instance Inst TySyn where - inst env ts = TySyn { tsName = instTyName env x - , tsParams = tsParams ts - , tsConstraints = inst env (tsConstraints ts) - , tsDef = inst env (tsDef ts) - , tsDoc = tsDoc ts - } - where x = tsName ts - -instance Inst Newtype where - inst env nt = Newtype { ntName = instTyName env x - , ntParams = ntParams nt - , ntConstraints = inst env (ntConstraints nt) - , ntFields = fmap (inst env) (ntFields nt) - , ntDoc = ntDoc nt - } - where x = ntName nt - -instance Inst AbstractType where - inst env a = AbstractType { atName = instTyName env (atName a) - , atKind = atKind a - , atCtrs = case atCtrs a of - (xs,ps) -> (xs, inst env ps) - , atFixitiy = atFixitiy a - , atDoc = atDoc a - } - -instTyName :: Env -> Name -> Name -instTyName env x = Map.findWithDefault x x (tyNameMap env) - - - - - - diff --git a/src/Cryptol/ModuleSystem/Interface.hs b/src/Cryptol/ModuleSystem/Interface.hs --- a/src/Cryptol/ModuleSystem/Interface.hs +++ b/src/Cryptol/ModuleSystem/Interface.hs @@ -9,30 +9,28 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} module Cryptol.ModuleSystem.Interface ( Iface , IfaceG(..) , IfaceDecls(..) - , IfaceTySyn, ifTySynName - , IfaceNewtype , IfaceDecl(..) - , IfaceParams(..) + , IfaceNames(..) + , ifModName , emptyIface , ifacePrimMap - , noIfaceParams - , isEmptyIfaceParams + , ifaceForgetName , ifaceIsFunctor - , flatPublicIface - , flatPublicDecls , filterIfaceDecls , ifaceDeclsNames + , ifaceOrigNameMap ) where import Data.Set(Set) import qualified Data.Set as Set +import Data.Map (Map) import qualified Data.Map as Map import Data.Semigroup import Data.Text (Text) @@ -44,74 +42,76 @@ import Prelude.Compat import Cryptol.ModuleSystem.Name -import Cryptol.Utils.Ident (ModName) +import Cryptol.Utils.Ident (ModName, OrigName(..)) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Fixity(Fixity) import Cryptol.Parser.AST(Pragma) -import Cryptol.Parser.Position(Located) import Cryptol.TypeCheck.Type +type Iface = IfaceG ModName --- | The resulting interface generated by a module that has been typechecked. -data IfaceG mname = Iface - { ifModName :: !mname -- ^ Module name - , ifPublic :: IfaceDecls -- ^ Exported definitions - , ifPrivate :: IfaceDecls -- ^ Private defintiions - , ifParams :: IfaceParams -- ^ Uninterpreted constants (aka module params) +-- | The interface repersenting a typecheck top-level module. +data IfaceG name = Iface + { ifNames :: IfaceNames name -- ^ Info about names in this module + , ifParams :: FunctorParams -- ^ Module parameters, if any + , ifDefines :: IfaceDecls -- ^ All things defines in the module + -- (includes nested definitions) } deriving (Show, Generic, NFData) -ifaceIsFunctor :: IfaceG mname -> Bool -ifaceIsFunctor = not . isEmptyIfaceParams . ifParams - --- | The public declarations in all modules, including nested --- The modules field contains public functors --- Assumes that we are not a functor. -flatPublicIface :: IfaceG mname -> IfaceDecls -flatPublicIface iface = flatPublicDecls (ifPublic iface) - - -flatPublicDecls :: IfaceDecls -> IfaceDecls -flatPublicDecls ifs = mconcat ( ifs { ifModules = fun } - : map flatPublicIface (Map.elems nofun) - ) +-- | Remove the name of a module. This is useful for dealing with collections +-- of modules, as in `Map (ImpName Name) (IfaceG ())`. +ifaceForgetName :: IfaceG name -> IfaceG () +ifaceForgetName i = i { ifNames = newNames } + where newNames = (ifNames i) { ifsName = () } - where - (fun,nofun) = Map.partition ifaceIsFunctor (ifModules ifs) +-- | Access the name of a module. +ifModName :: IfaceG name -> name +ifModName = ifsName . ifNames +-- | Information about the names in a module. +data IfaceNames name = IfaceNames + { ifsName :: name -- ^ Name of this submodule + , ifsNested :: Set Name -- ^ Things nested in this module + , ifsDefines :: Set Name -- ^ Things defined in this module + , ifsPublic :: Set Name -- ^ Subset of `ifsDefines` that is public + , ifsDoc :: !(Maybe Text) -- ^ Documentation + } deriving (Show, Generic, NFData) -type Iface = IfaceG ModName +-- | Is this interface for a functor. +ifaceIsFunctor :: IfaceG name -> Bool +ifaceIsFunctor = not . Map.null . ifParams -emptyIface :: mname -> IfaceG mname +emptyIface :: ModName -> Iface emptyIface nm = Iface - { ifModName = nm - , ifPublic = mempty - , ifPrivate = mempty - , ifParams = noIfaceParams - } - -data IfaceParams = IfaceParams - { ifParamTypes :: Map.Map Name ModTParam - , ifParamConstraints :: [Located Prop] -- ^ Constraints on param. types - , ifParamFuns :: Map.Map Name ModVParam - } deriving (Show, Generic, NFData) - -noIfaceParams :: IfaceParams -noIfaceParams = IfaceParams - { ifParamTypes = Map.empty - , ifParamConstraints = [] - , ifParamFuns = Map.empty + { ifNames = IfaceNames { ifsName = nm + , ifsDefines = mempty + , ifsPublic = mempty + , ifsNested = mempty + , ifsDoc = Nothing + } + , ifParams = mempty + , ifDefines = mempty } -isEmptyIfaceParams :: IfaceParams -> Bool -isEmptyIfaceParams IfaceParams { .. } = - Map.null ifParamTypes && null ifParamConstraints && Map.null ifParamFuns - +-- | Declarations in a module. Note that this includes things from nested +-- modules, but not things from nested functors, which are in `ifFunctors`. data IfaceDecls = IfaceDecls - { ifTySyns :: Map.Map Name IfaceTySyn - , ifNewtypes :: Map.Map Name IfaceNewtype - , ifAbstractTypes :: Map.Map Name IfaceAbstractType + { ifTySyns :: Map.Map Name TySyn + , ifNewtypes :: Map.Map Name Newtype + , ifAbstractTypes :: Map.Map Name AbstractType , ifDecls :: Map.Map Name IfaceDecl - , ifModules :: !(Map.Map Name (IfaceG Name)) + , ifModules :: !(Map.Map Name (IfaceNames Name)) + , ifSignatures :: !(Map.Map Name ModParamNames) + , ifFunctors :: !(Map.Map Name (IfaceG Name)) + {- ^ XXX: Maybe arg info? + Also, with the current implementation we aim to complete remove functors + by essentially inlining them. To achieve this with just interfaces + we'd have to store here the entire module, not just its interface. + At the moment we work around this by passing all loaded modules to the + type checker, so it looks up functors there, instead of in the interfaces, + but we'd need to change this if we want better support for separate + compilation. -} + } deriving (Show, Generic, NFData) filterIfaceDecls :: (Name -> Bool) -> IfaceDecls -> IfaceDecls @@ -121,6 +121,8 @@ , ifAbstractTypes = filterMap (ifAbstractTypes ifs) , ifDecls = filterMap (ifDecls ifs) , ifModules = filterMap (ifModules ifs) + , ifFunctors = filterMap (ifFunctors ifs) + , ifSignatures = filterMap (ifSignatures ifs) } where filterMap :: Map.Map Name a -> Map.Map Name a @@ -132,6 +134,8 @@ , Map.keysSet (ifAbstractTypes i) , Map.keysSet (ifDecls i) , Map.keysSet (ifModules i) + , Map.keysSet (ifFunctors i) + , Map.keysSet (ifSignatures i) ] @@ -142,30 +146,35 @@ , ifAbstractTypes = Map.union (ifAbstractTypes l) (ifAbstractTypes r) , ifDecls = Map.union (ifDecls l) (ifDecls r) , ifModules = Map.union (ifModules l) (ifModules r) + , ifFunctors = Map.union (ifFunctors l) (ifFunctors r) + , ifSignatures = ifSignatures l <> ifSignatures r } instance Monoid IfaceDecls where - mempty = IfaceDecls Map.empty Map.empty Map.empty Map.empty Map.empty - mappend = (<>) + mempty = IfaceDecls + { ifTySyns = mempty + , ifNewtypes = mempty + , ifAbstractTypes = mempty + , ifDecls = mempty + , ifModules = mempty + , ifFunctors = mempty + , ifSignatures = mempty + } + mappend = (<>) mconcat ds = IfaceDecls { ifTySyns = Map.unions (map ifTySyns ds) , ifNewtypes = Map.unions (map ifNewtypes ds) , ifAbstractTypes = Map.unions (map ifAbstractTypes ds) , ifDecls = Map.unions (map ifDecls ds) , ifModules = Map.unions (map ifModules ds) + , ifFunctors = Map.unions (map ifFunctors ds) + , ifSignatures = Map.unions (map ifSignatures ds) } -type IfaceTySyn = TySyn - -ifTySynName :: TySyn -> Name -ifTySynName = tsName - -type IfaceNewtype = Newtype -type IfaceAbstractType = AbstractType - data IfaceDecl = IfaceDecl { ifDeclName :: !Name -- ^ Name of thing , ifDeclSig :: Schema -- ^ Type + , ifDeclIsPrim :: !Bool , ifDeclPragmas :: [Pragma] -- ^ Pragmas , ifDeclInfix :: Bool -- ^ Is this an infix thing , ifDeclFixity :: Maybe Fixity -- ^ Fixity information @@ -176,15 +185,12 @@ -- | Produce a PrimMap from an interface. -- -- NOTE: the map will expose /both/ public and private names. +-- NOTE: this is a bit misnamed, as it is used to resolve known names +-- that Cryptol introduces (e.g., during type checking). These +-- names need not be primitives. A better way to do this in the future +-- might be to use original names instead (see #1522). ifacePrimMap :: Iface -> PrimMap -ifacePrimMap Iface { .. } = - PrimMap { primDecls = merge primDecls - , primTypes = merge primTypes } - where - merge f = Map.union (f public) (f private) - - public = ifaceDeclsPrimMap ifPublic - private = ifaceDeclsPrimMap ifPrivate +ifacePrimMap = ifaceDeclsPrimMap . ifDefines ifaceDeclsPrimMap :: IfaceDecls -> PrimMap ifaceDeclsPrimMap IfaceDecls { .. } = @@ -199,6 +205,36 @@ [ "Top level name not declared in a module?" , show n ] - exprs = map entry (Map.keys ifDecls) newtypes = map entry (Map.keys ifNewtypes) + exprs = map entry (Map.keys ifDecls) types = map entry (Map.keys ifTySyns) + + +-- | Given an interface computing a map from original names to actual names, +-- grouped by namespace. +ifaceOrigNameMap :: IfaceG name -> Map Namespace (Map OrigName Name) +ifaceOrigNameMap ifa = Map.unionsWith Map.union (here : nested) + where + here = Map.fromList $ + [ (NSValue, toMap vaNames) | not (Set.null vaNames) ] ++ + [ (NSType, toMap tyNames) | not (Set.null tyNames) ] ++ + [ (NSValue, toMap moNames) | not (Set.null moNames) ] + + nested = map ifaceOrigNameMap (Map.elems (ifFunctors decls)) + + toMap names = Map.fromList + [ (og,x) | x <- Set.toList names, Just og <- [ asOrigName x ] ] + + decls = ifDefines ifa + from f = Map.keysSet (f decls) + tyNames = Set.unions [ from ifTySyns, from ifNewtypes, from ifAbstractTypes ] + moNames = Set.unions [ from ifModules, from ifSignatures, from ifFunctors ] + vaNames = Set.unions [ newtypeCons, from ifDecls ] + newtypeCons = Set.fromList (map ntConName (Map.elems (ifNewtypes decls))) + + + + + + + diff --git a/src/Cryptol/ModuleSystem/Monad.hs b/src/Cryptol/ModuleSystem/Monad.hs --- a/src/Cryptol/ModuleSystem/Monad.hs +++ b/src/Cryptol/ModuleSystem/Monad.hs @@ -10,29 +10,33 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BlockArguments #-} module Cryptol.ModuleSystem.Monad where import Cryptol.Eval (EvalEnv,EvalOpts(..)) +import Cryptol.Backend.FFI (ForeignSrc) +import Cryptol.Backend.FFI.Error import qualified Cryptol.Backend.Monad as E import Cryptol.ModuleSystem.Env -import Cryptol.ModuleSystem.Fingerprint +import qualified Cryptol.ModuleSystem.Env as MEnv import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Name (FreshM(..),Supply) import Cryptol.ModuleSystem.Renamer (RenamerError(),RenamerWarning()) import Cryptol.ModuleSystem.NamingEnv(NamingEnv) import qualified Cryptol.Parser as Parser import qualified Cryptol.Parser.AST as P -import Cryptol.Parser.Position (Located) import Cryptol.Utils.Panic (panic) import qualified Cryptol.Parser.NoPat as NoPat +import qualified Cryptol.Parser.ExpandPropGuards as ExpandPropGuards import qualified Cryptol.Parser.NoInclude as NoInc import qualified Cryptol.TypeCheck as T import qualified Cryptol.TypeCheck.AST as T import qualified Cryptol.TypeCheck.Solver.SMT as SMT -import Cryptol.Parser.Position (Range) +import Cryptol.Parser.Position (Range, Located) import Cryptol.Utils.Ident (interactiveName, noModuleName) import Cryptol.Utils.PP import Cryptol.Utils.Logger(Logger) @@ -42,9 +46,10 @@ import Control.Exception (IOException) import Data.ByteString (ByteString) import Data.Function (on) +import Data.Functor.Identity import Data.Map (Map) -import Data.Maybe (isJust) import Data.Text.Encoding.Error (UnicodeException) +import Data.Traversable import MonadLib import System.Directory (canonicalizePath) @@ -60,6 +65,7 @@ data ImportSource = FromModule P.ModName | FromImport (Located P.Import) + | FromSigImport (Located P.ModName) | FromModuleInstance (Located P.ModName) deriving (Show, Generic, NFData) @@ -70,6 +76,7 @@ ppPrec _ is = case is of FromModule n -> text "module name" <+> pp n FromImport li -> text "import of module" <+> pp (P.iModule (P.thing li)) + FromSigImport l -> text "import of interface" <+> pp (P.thing l) FromModuleInstance l -> text "instantiation of module" <+> pp (P.thing l) @@ -79,6 +86,7 @@ FromModule n -> n FromImport li -> P.iModule (P.thing li) FromModuleInstance l -> P.thing l + FromSigImport l -> P.thing l data ModuleError @@ -98,6 +106,8 @@ -- ^ Problems during the renaming phase | NoPatErrors ImportSource [NoPat.Error] -- ^ Problems during the NoPat phase + | ExpandPropGuardsError ImportSource ExpandPropGuards.Error + -- ^ Problems during the ExpandPropGuards phase | NoIncludeErrors ImportSource [NoInc.IncludeError] -- ^ Problems during the NoInclude phase | TypeCheckingFailed ImportSource T.NameMap [(Range,T.Error)] @@ -108,11 +118,8 @@ -- ^ Module loaded by 'import' statement has the wrong module name | DuplicateModuleName P.ModName FilePath FilePath -- ^ Two modules loaded from different files have the same module name - | ImportedParamModule P.ModName - -- ^ Attempt to import a parametrized module that was not instantiated. - | FailedToParameterizeModDefs P.ModName [T.Name] - -- ^ Failed to add the module parameters to all definitions in a module. - | NotAParameterizedModule P.ModName + | FFILoadErrors P.ModName [FFILoadError] + -- ^ Errors loading foreign function implementations | ErrorInFile ModulePath ModuleError -- ^ This is just a tag on the error, indicating the file containing it. @@ -131,6 +138,7 @@ RecursiveModules mods -> mods `deepseq` () RenamerErrors src errs -> src `deepseq` errs `deepseq` () NoPatErrors src errs -> src `deepseq` errs `deepseq` () + ExpandPropGuardsError src err -> src `deepseq` err `deepseq` () NoIncludeErrors src errs -> src `deepseq` errs `deepseq` () TypeCheckingFailed nm src errs -> nm `deepseq` src `deepseq` errs `deepseq` () ModuleNameMismatch expected found -> @@ -138,9 +146,7 @@ DuplicateModuleName name path1 path2 -> name `deepseq` path1 `deepseq` path2 `deepseq` () OtherFailure x -> x `deepseq` () - ImportedParamModule x -> x `deepseq` () - FailedToParameterizeModDefs x xs -> x `deepseq` xs `deepseq` () - NotAParameterizedModule x -> x `deepseq` () + FFILoadErrors x errs -> x `deepseq` errs `deepseq` () ErrorInFile x y -> x `deepseq` y `deepseq` () instance PP ModuleError where @@ -178,6 +184,8 @@ NoPatErrors _src errs -> vcat (map pp errs) + ExpandPropGuardsError _src err -> pp err + NoIncludeErrors _src errs -> vcat (map NoInc.ppIncludeError errs) TypeCheckingFailed _src nm errs -> vcat (map (T.ppNamedError nm) errs) @@ -185,7 +193,7 @@ ModuleNameMismatch expected found -> hang (text "[error]" <+> pp (P.srcRange found) <.> char ':') 4 (vcat [ text "File name does not match module name:" - , text "Saw:" <+> pp (P.thing found) + , text " Actual:" <+> pp (P.thing found) , text "Expected:" <+> pp expected ]) @@ -196,16 +204,10 @@ OtherFailure x -> text x - ImportedParamModule p -> - text "[error] Import of a non-instantiated parameterized module:" <+> pp p - - FailedToParameterizeModDefs x xs -> - hang (text "[error] Parameterized module" <+> pp x <+> - text "has polymorphic parameters:") - 4 (commaSep (map pp xs)) - - NotAParameterizedModule x -> - text "[error] Module" <+> pp x <+> text "does not have parameters." + FFILoadErrors x errs -> + hang (text "[error] Failed to load foreign implementations for module" + <+> pp x <.> colon) + 4 (vcat $ map pp errs) ErrorInFile _ x -> ppPrec prec x @@ -238,6 +240,11 @@ src <- getImportSource ModuleT (raise (NoPatErrors src errs)) +expandPropGuardsError :: ExpandPropGuards.Error -> ModuleM a +expandPropGuardsError err = do + src <- getImportSource + ModuleT (raise (ExpandPropGuardsError src err)) + noIncludeErrors :: [NoInc.IncludeError] -> ModuleM a noIncludeErrors errs = do src <- getImportSource @@ -256,15 +263,8 @@ duplicateModuleName name path1 path2 = ModuleT (raise (DuplicateModuleName name path1 path2)) -importParamModule :: P.ModName -> ModuleM a -importParamModule x = ModuleT (raise (ImportedParamModule x)) - -failedToParameterizeModDefs :: P.ModName -> [T.Name] -> ModuleM a -failedToParameterizeModDefs x xs = - ModuleT (raise (FailedToParameterizeModDefs x xs)) - -notAParameterizedModule :: P.ModName -> ModuleM a -notAParameterizedModule x = ModuleT (raise (NotAParameterizedModule x)) +ffiLoadErrors :: P.ModName -> [FFILoadError] -> ModuleM a +ffiLoadErrors x errs = ModuleT (raise (FFILoadErrors x errs)) -- | Run the computation, and if it caused and error, tag the error -- with the given file. @@ -423,13 +423,17 @@ env <- get set $! f env -getLoadedMaybe :: P.ModName -> ModuleM (Maybe LoadedModule) +getLoadedMaybe :: P.ModName -> ModuleM (Maybe (LoadedModuleG T.TCTopEntity)) getLoadedMaybe mn = ModuleT $ do env <- get - return (lookupModule mn env) + return (lookupTCEntity mn env) +-- | This checks if the given name is loaded---it might refer to either +-- a module or a signature. isLoaded :: P.ModName -> ModuleM Bool -isLoaded mn = isJust <$> getLoadedMaybe mn +isLoaded mn = + do env <- ModuleT get + pure (MEnv.isLoaded mn (meLoadedModules env)) loadingImport :: Located P.Import -> ModuleM a -> ModuleM a loadingImport = loading . FromImport @@ -448,12 +452,12 @@ loading :: ImportSource -> ModuleM a -> ModuleM a loading src m = ModuleT $ do ro <- ask - let ro' = ro { roLoading = src : roLoading ro } + let new = src : roLoading ro -- check for recursive modules - when (src `elem` roLoading ro) (raise (RecursiveModules (roLoading ro'))) + when (src `elem` roLoading ro) (raise (RecursiveModules new)) - local ro' (unModuleT m) + local ro { roLoading = new } (unModuleT m) -- | Get the currently focused import source. getImportSource :: ModuleM ImportSource @@ -463,17 +467,17 @@ is : _ -> return is _ -> return (FromModule noModuleName) -getIface :: P.ModName -> ModuleM Iface -getIface mn = ($ mn) <$> getIfaces - -getIfaces :: ModuleM (P.ModName -> Iface) -getIfaces = doLookup <$> ModuleT get +getIfaces :: ModuleM (Map P.ModName (Either T.ModParamNames Iface)) +getIfaces = toMap <$> ModuleT get where - doLookup env mn = - case lookupModule mn env of - Just lm -> lmInterface lm - Nothing -> panic "ModuleSystem" ["Interface not available", show (pp mn)] + toMap env = cvt <$> getLoadedEntities (meLoadedModules env) + cvt ent = + case ent of + ALoadedInterface ifa -> Left (lmData ifa) + ALoadedFunctor mo -> Right (lmdInterface (lmData mo)) + ALoadedModule mo -> Right (lmdInterface (lmData mo)) + getLoaded :: P.ModName -> ModuleM T.Module getLoaded mn = ModuleT $ do env <- get @@ -481,6 +485,20 @@ Just lm -> return (lmModule lm) Nothing -> panic "ModuleSystem" ["Module not available", show (pp mn) ] +getAllLoaded :: ModuleM (P.ModName -> Maybe (T.ModuleG (), IfaceG ())) +getAllLoaded = ModuleT + do env <- get + pure \nm -> do lm <- lookupModule nm env + pure ( (lmModule lm) { T.mName = () } + , ifaceForgetName (lmInterface lm) + ) + +getAllLoadedSignatures :: ModuleM (P.ModName -> Maybe T.ModParamNames) +getAllLoadedSignatures = ModuleT + do env <- get + pure \nm -> lmData <$> lookupSignature nm env + + getNameSeeds :: ModuleM T.NameSeeds getNameSeeds = ModuleT (meNameSeeds `fmap` get) @@ -505,28 +523,42 @@ do env <- get set $! env { meSupply = supply } -unloadModule :: (LoadedModule -> Bool) -> ModuleM () +unloadModule :: (forall a. LoadedModuleG a -> Bool) -> ModuleM () unloadModule rm = ModuleT $ do env <- get set $! env { meLoadedModules = removeLoadedModule rm (meLoadedModules env) } loadedModule :: - ModulePath -> Fingerprint -> NamingEnv -> T.Module -> ModuleM () -loadedModule path fp nameEnv m = ModuleT $ do + ModulePath -> + FileInfo -> + NamingEnv -> + Maybe ForeignSrc -> + T.TCTopEntity -> + ModuleM () +loadedModule path fi nameEnv fsrc m = ModuleT $ do env <- get ident <- case path of InFile p -> unModuleT $ io (canonicalizePath p) InMem l _ -> pure l - set $! env { meLoadedModules = addLoadedModule path ident fp nameEnv m - (meLoadedModules env) } + let newLM = + case m of + T.TCTopModule mo -> addLoadedModule path ident fi nameEnv fsrc mo + T.TCTopSignature x s -> addLoadedSignature path ident fi nameEnv x s -modifyEvalEnv :: (EvalEnv -> E.Eval EvalEnv) -> ModuleM () -modifyEvalEnv f = ModuleT $ do + set $! env { meLoadedModules = newLM (meLoadedModules env) } + + +modifyEvalEnvM :: Traversable t => + (EvalEnv -> E.Eval (t EvalEnv)) -> ModuleM (t ()) +modifyEvalEnvM f = ModuleT $ do env <- get let evalEnv = meEvalEnv env - evalEnv' <- inBase $ E.runEval mempty (f evalEnv) - set $! env { meEvalEnv = evalEnv' } + tenv <- inBase (E.runEval mempty (f evalEnv)) + traverse (\evalEnv' -> set $! env { meEvalEnv = evalEnv' }) tenv + +modifyEvalEnv :: (EvalEnv -> E.Eval EvalEnv) -> ModuleM () +modifyEvalEnv = fmap runIdentity . modifyEvalEnvM . (fmap Identity .) getEvalEnv :: ModuleM EvalEnv getEvalEnv = ModuleT (meEvalEnv `fmap` get) diff --git a/src/Cryptol/ModuleSystem/Name.hs b/src/Cryptol/ModuleSystem/Name.hs --- a/src/Cryptol/ModuleSystem/Name.hs +++ b/src/Cryptol/ModuleSystem/Name.hs @@ -6,16 +6,15 @@ -- Stability : provisional -- Portability : portable -{-# LANGUAGE Trustworthy #-} - {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RankNTypes #-} -- for the instances of RunM and BaseM {-# LANGUAGE UndecidableInstances #-} @@ -25,12 +24,17 @@ , NameSource(..) , nameUnique , nameIdent + , mapNameIdent , nameInfo , nameLoc , nameFixity , nameNamespace , asPrim , asOrigName + , nameModPath + , nameModPathMaybe + , nameTopModule + , nameTopModuleMaybe , ppLocName , Namespace(..) , ModPath(..) @@ -38,15 +42,15 @@ -- ** Creation , mkDeclared - , mkParameter - , toParamInstName - , asParamName - , paramModRecParam + , mkLocal + , asLocal + , mkModParam -- ** Unique Supply , FreshM(..), nextUniqueM - , SupplyT(), runSupplyT + , SupplyT(), runSupplyT, runSupply , Supply(), emptySupply, nextUnique + , freshNameFor -- ** PrimMap , PrimMap(..) @@ -57,6 +61,7 @@ import Control.DeepSeq import qualified Data.Map as Map import qualified Data.Monoid as M +import Data.Functor.Identity(runIdentity) import GHC.Generics (Generic) import MonadLib import Prelude () @@ -66,36 +71,24 @@ -import Cryptol.Parser.Position (Range,Located(..),emptyRange) +import Cryptol.Parser.Position (Range,Located(..)) import Cryptol.Utils.Fixity import Cryptol.Utils.Ident import Cryptol.Utils.Panic import Cryptol.Utils.PP - +data NameInfo = GlobalName NameSource OrigName + | LocalName Namespace Ident + deriving (Generic, NFData, Show) -- Names ----------------------------------------------------------------------- --- | Information about the binding site of the name. -data NameInfo = Declared !ModPath !NameSource - -- ^ This name refers to a declaration from this module - | Parameter - -- ^ This name is a parameter (function or type) - deriving (Eq, Show, Generic, NFData) - - data Name = Name { nUnique :: {-# UNPACK #-} !Int -- ^ INVARIANT: this field uniquely identifies a name for one -- session with the Cryptol library. Names are unique to -- their binding site. , nInfo :: !NameInfo - -- ^ Information about the origin of this name. - , nNamespace :: !Namespace - - , nIdent :: !Ident - -- ^ The name of the identifier - , nFixity :: !(Maybe Fixity) -- ^ The associativity and precedence level of -- infix operators. 'Nothing' indicates an @@ -150,7 +143,12 @@ fmtPref og = case getNameFormat og disp of UnQualified -> "" Qualified q -> modNameToText q - NotInScope -> Text.pack $ show $ pp (ogModule og) + NotInScope -> + let m = Text.pack (show (pp (ogModule og))) + in + case ogSource og of + FromModParam q -> m <> "::" <> Text.pack (show (pp q)) + _ -> m -- Note that this assumes that `xs` is `l` and `ys` is `r` cmpText xs ys = @@ -173,10 +171,13 @@ -- the need for parentheses. ppName :: Name -> Doc ppName nm = - case asOrigName nm of - Just og -> pp og - Nothing -> pp (nameIdent nm) - + case nInfo nm of + GlobalName _ og -> pp og + LocalName _ i -> pp i + <.> + withPPCfg \cfg -> + if ppcfgShowNameUniques cfg then "_" <.> int (nameUnique nm) + else mempty instance PP Name where ppPrec _ = ppPrefixName @@ -184,12 +185,12 @@ instance PPName Name where ppNameFixity n = nameFixity n - ppInfixName n@Name { .. } - | isInfixIdent nIdent = ppName n + ppInfixName n + | isInfixIdent (nameIdent n) = ppName n | otherwise = panic "Name" [ "Non-infix name used infix" - , show nIdent ] + , show (nameIdent n) ] - ppPrefixName n@Name { .. } = optParens (isInfixIdent nIdent) (ppName n) + ppPrefixName n = optParens (isInfixIdent (nameIdent n)) (ppName n) -- | Pretty-print a name with its source location information. @@ -199,14 +200,26 @@ nameUnique :: Name -> Int nameUnique = nUnique +nameInfo :: Name -> NameInfo +nameInfo = nInfo + nameIdent :: Name -> Ident -nameIdent = nIdent +nameIdent n = case nInfo n of + GlobalName _ og -> ogName og + LocalName _ i -> i -nameNamespace :: Name -> Namespace -nameNamespace = nNamespace +mapNameIdent :: (Ident -> Ident) -> Name -> Name +mapNameIdent f n = + n { nInfo = + case nInfo n of + GlobalName x og -> GlobalName x og { ogName = f (ogName og) } + LocalName x i -> LocalName x (f i) + } -nameInfo :: Name -> NameInfo -nameInfo = nInfo +nameNamespace :: Name -> Namespace +nameNamespace n = case nInfo n of + GlobalName _ og -> ogNamespace og + LocalName ns _ -> ns nameLoc :: Name -> Range nameLoc = nLoc @@ -216,31 +229,43 @@ -- | Primtiives must be in a top level module, at least for now. asPrim :: Name -> Maybe PrimIdent -asPrim Name { .. } = - case nInfo of - Declared (TopModule m) _ -> Just $ PrimIdent m $ identText nIdent - _ -> Nothing - -toParamInstName :: Name -> Name -toParamInstName n = +asPrim n = case nInfo n of - Declared m s -> n { nInfo = Declared (apPathRoot paramInstModName m) s } - Parameter -> n + GlobalName _ og + | TopModule m <- ogModule og, not (ogFromModParam og) -> + Just $ PrimIdent m $ identText $ ogName og -asParamName :: Name -> Name -asParamName n = n { nInfo = Parameter } + _ -> Nothing asOrigName :: Name -> Maybe OrigName -asOrigName nm = - case nInfo nm of - Declared p _ -> - Just OrigName { ogModule = apPathRoot notParamInstModName p - , ogNamespace = nNamespace nm - , ogName = nIdent nm - } - Parameter -> Nothing +asOrigName n = + case nInfo n of + GlobalName _ og -> Just og + LocalName {} -> Nothing +-- | Get the module path for the given name. +nameModPathMaybe :: Name -> Maybe ModPath +nameModPathMaybe n = ogModule <$> asOrigName n +-- | Get the module path for the given name. +-- The name should be a top-level name. +nameModPath :: Name -> ModPath +nameModPath n = + case nameModPathMaybe n of + Just p -> p + Nothing -> panic "nameModPath" [ "Not a top-level name: ", show n ] + + +-- | Get the name of the top-level module that introduced this name. +nameTopModuleMaybe :: Name -> Maybe ModName +nameTopModuleMaybe = fmap topModuleFor . nameModPathMaybe + +-- | Get the name of the top-level module that introduced this name. +-- Works only for top-level names (i.e., that have original names) +nameTopModule :: Name -> ModName +nameTopModule = topModuleFor . nameModPath + + -- Name Supply ----------------------------------------------------------------- class Monad m => FreshM m where @@ -271,6 +296,9 @@ runSupplyT :: Monad m => Supply -> SupplyT m a -> m (a,Supply) runSupplyT s (SupplyT m) = runStateT s m +runSupply :: Supply -> (forall m. FreshM m => m a) -> (a,Supply) +runSupply s m = runIdentity (runSupplyT s m) + instance Monad m => Functor (SupplyT m) where fmap f (SupplyT m) = SupplyT (fmap f m) {-# INLINE fmap #-} @@ -315,8 +343,8 @@ emptySupply :: Supply emptySupply = Supply 0x1000 -- For one such name, see paramModRecParam --- XXX: perhaps we should simply not have such things, but that's the way --- for now. +-- XXX: perhaps we should simply not have such things +-- XXX: do we have these anymore? nextUnique :: Supply -> (Int,Supply) nextUnique (Supply n) = s' `seq` (n,s') @@ -330,26 +358,77 @@ mkDeclared :: Namespace -> ModPath -> NameSource -> Ident -> Maybe Fixity -> Range -> Supply -> (Name,Supply) -mkDeclared nNamespace m sys nIdent nFixity nLoc s = - let (nUnique,s') = nextUnique s - nInfo = Declared m sys - in (Name { .. }, s') +mkDeclared ns m sys ident fixity loc s = (name, s') + where + (u,s') = nextUnique s + name = Name { nUnique = u + , nFixity = fixity + , nLoc = loc + , nInfo = GlobalName + sys + OrigName + { ogNamespace = ns + , ogModule = m + , ogName = ident + , ogSource = FromDefinition + } + } -- | Make a new parameter name. -mkParameter :: Namespace -> Ident -> Range -> Supply -> (Name,Supply) -mkParameter nNamespace nIdent nLoc s = - let (nUnique,s') = nextUnique s - nFixity = Nothing - in (Name { nInfo = Parameter, .. }, s') +mkLocal :: Namespace -> Ident -> Range -> Supply -> (Name,Supply) +mkLocal ns ident loc s = (name, s') + where + (u,s') = nextUnique s + name = Name { nUnique = u + , nLoc = loc + , nFixity = Nothing + , nInfo = LocalName ns ident + } -paramModRecParam :: Name -paramModRecParam = Name { nInfo = Parameter - , nFixity = Nothing - , nIdent = packIdent "$modParams" - , nLoc = emptyRange - , nUnique = 0x01 - , nNamespace = NSValue - } +{- | Make a local name derived from the given name. +This is a bit questionable, +but it is used by the translation to SAW Core -} +asLocal :: Namespace -> Name -> Name +asLocal ns x = + case nameInfo x of + GlobalName _ og -> x { nInfo = LocalName ns (ogName og) } + LocalName {} -> x + +mkModParam :: + ModPath {- ^ Module containing the parameter -} -> + Ident {- ^ Name of the module parameter -} -> + Range {- ^ Location -} -> + Name {- ^ Name in the signature -} -> + Supply -> (Name, Supply) +mkModParam own pname rng n s = (name, s') + where + (u,s') = nextUnique s + name = Name { nUnique = u + , nInfo = GlobalName + UserName + OrigName + { ogModule = own + , ogName = nameIdent n + , ogNamespace = nameNamespace n + , ogSource = FromModParam pname + } + , nFixity = nFixity n + , nLoc = rng + } + +-- | This is used when instantiating functors +freshNameFor :: ModPath -> Name -> Supply -> (Name,Supply) +freshNameFor mpath x s = (newName, s1) + where + (u,s1) = nextUnique s + newName = + x { nUnique = u + , nInfo = + case nInfo x of + GlobalName src og -> GlobalName src og { ogModule = mpath + , ogSource = FromFunctorInst } + LocalName {} -> panic "freshNameFor" ["Unexpected local",show x] + } -- Prim Maps ------------------------------------------------------------------- diff --git a/src/Cryptol/ModuleSystem/Names.hs b/src/Cryptol/ModuleSystem/Names.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/ModuleSystem/Names.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE BlockArguments #-} +module Cryptol.ModuleSystem.Names where + +import Data.Set(Set) +import qualified Data.Set as Set +import Control.DeepSeq(NFData) +import GHC.Generics (Generic) + +import Cryptol.Utils.Panic (panic) +import Cryptol.ModuleSystem.Name + + +-- | A non-empty collection of names used by the renamer. +data Names = One Name | Ambig (Set Name) -- ^ Non-empty + deriving (Show,Generic,NFData) + +namesToList :: Names -> [Name] +namesToList xs = + case xs of + One x -> [x] + Ambig ns -> Set.toList ns + +anyOne :: Names -> Name +anyOne = head . namesToList + +instance Semigroup Names where + xs <> ys = + case (xs,ys) of + (One x, One y) + | x == y -> One x + | otherwise -> Ambig $! Set.fromList [x,y] + (One x, Ambig as) -> Ambig $! Set.insert x as + (Ambig as, One x) -> Ambig $! Set.insert x as + (Ambig as, Ambig bs) -> Ambig $! Set.union as bs + +namesFromSet :: Set Name {- ^ Non-empty -} -> Names +namesFromSet xs = + case Set.minView xs of + Just (a,ys) -> if Set.null ys then One a else Ambig xs + Nothing -> panic "namesFromSet" ["empty set"] + +unionManyNames :: [Names] -> Maybe Names +unionManyNames xs = + case xs of + [] -> Nothing + _ -> Just (foldr1 (<>) xs) + +mapNames :: (Name -> Name) -> Names -> Names +mapNames f xs = + case xs of + One x -> One (f x) + Ambig as -> namesFromSet (Set.map f as) + +filterNames :: (Name -> Bool) -> Names -> Maybe Names +filterNames p names = + case names of + One x -> if p x then Just (One x) else Nothing + Ambig xs -> do let ys = Set.filter p xs + (y,zs) <- Set.minView ys + if Set.null zs then Just (One y) else Just (Ambig ys) + +travNames :: Applicative f => (Name -> f Name) -> Names -> f Names +travNames f xs = + case xs of + One x -> One <$> f x + Ambig as -> namesFromSet . Set.fromList <$> traverse f (Set.toList as) + + +-- Names that are in the first but not the second +diffNames :: Names -> Names -> Maybe Names +diffNames x y = + case x of + One a -> + case y of + One b -> if a == b then Nothing + else Just (One a) + Ambig xs -> if a `Set.member` xs then Nothing else Just (One a) + Ambig xs -> + do (a,rest) <- Set.minView ys + pure if Set.null rest then One a else Ambig xs + + where + ys = case y of + One z -> Set.delete z xs + Ambig zs -> Set.difference xs zs + diff --git a/src/Cryptol/ModuleSystem/NamingEnv.hs b/src/Cryptol/ModuleSystem/NamingEnv.hs --- a/src/Cryptol/ModuleSystem/NamingEnv.hs +++ b/src/Cryptol/ModuleSystem/NamingEnv.hs @@ -7,112 +7,119 @@ -- Portability : portable {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Cryptol.ModuleSystem.NamingEnv where -import Data.List (nub) -import Data.Maybe (fromMaybe,mapMaybe,maybeToList) +import Data.Maybe (mapMaybe,maybeToList) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set -import Data.Semigroup -import MonadLib (runId,Id,StateT,runStateT,lift,sets_,forM_) +import Data.Foldable(foldl') import GHC.Generics (Generic) -import Control.DeepSeq - -import Prelude () -import Prelude.Compat +import Control.DeepSeq(NFData) import Cryptol.Utils.PP import Cryptol.Utils.Panic (panic) +import Cryptol.Utils.Ident(allNamespaces) import Cryptol.Parser.AST -import Cryptol.Parser.Name(isGeneratedName) -import Cryptol.Parser.Position import qualified Cryptol.TypeCheck.AST as T -import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Name +import Cryptol.ModuleSystem.Names +import Cryptol.ModuleSystem.Interface --- Naming Environment ---------------------------------------------------------- - -- | The 'NamingEnv' is used by the renamer to determine what -- identifiers refer to. -newtype NamingEnv = NamingEnv (Map Namespace (Map PName [Name])) +newtype NamingEnv = NamingEnv (Map Namespace (Map PName Names)) deriving (Show,Generic,NFData) --- | All names mentioned in the environment -namingEnvNames :: NamingEnv -> Set Name -namingEnvNames (NamingEnv xs) = - Set.fromList $ concatMap (concat . Map.elems) $ Map.elems xs +instance Monoid NamingEnv where + mempty = NamingEnv Map.empty + {-# INLINE mempty #-} +instance Semigroup NamingEnv where + NamingEnv l <> NamingEnv r = + NamingEnv (Map.unionWith (Map.unionWith (<>)) l r) --- | Get the names in a given namespace -namespaceMap :: Namespace -> NamingEnv -> Map PName [Name] -namespaceMap ns (NamingEnv env) = Map.findWithDefault Map.empty ns env +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)) --- | Resolve a name in the given namespace. -lookupNS :: Namespace -> PName -> NamingEnv -> [Name] -lookupNS ns x = Map.findWithDefault [] x . namespaceMap ns --- | Return a list of value-level names to which this parsed name may refer. -lookupValNames :: PName -> NamingEnv -> [Name] -lookupValNames = lookupNS NSValue - --- | Return a list of type-level names to which this parsed name may refer. -lookupTypeNames :: PName -> NamingEnv -> [Name] -lookupTypeNames = lookupNS NSType +{- | This "joins" two naming environments by matching the text name. +The result maps the unique names from the first environment with the +matching names in the second. This is used to compute the naming for +an instantiated functor: + * if the left environment has the defined names of the functor, and + * the right one has the defined names of the instantiation, then + * the result maps functor names to instance names. +-} +zipByTextName :: NamingEnv -> NamingEnv -> Map Name Name +zipByTextName (NamingEnv k) (NamingEnv v) = Map.fromList $ doInter doNS k v + where + doInter :: Ord k => (a -> b -> [c]) -> Map k a -> Map k b -> [c] + doInter f a b = concat (Map.elems (Map.intersectionWith f a b)) --- | Singleton renaming environment for the given namespace. -singletonNS :: Namespace -> PName -> Name -> NamingEnv -singletonNS ns pn n = NamingEnv (Map.singleton ns (Map.singleton pn [n])) + doNS :: Map PName Names -> Map PName Names -> [(Name,Name)] + doNS as bs = doInter doPName as bs --- | Singleton expression renaming environment. -singletonE :: PName -> Name -> NamingEnv -singletonE = singletonNS NSValue + doPName :: Names -> Names -> [(Name,Name)] + doPName xs ys = [ (x,y) | x <- namesToList xs, y <- namesToList ys ] + -- NOTE: we'd exepct that there are no ambiguities in the environments. --- | Singleton type renaming environment. -singletonT :: PName -> Name -> NamingEnv -singletonT = singletonNS NSType +-- | Keep only the bindings in the 1st environment that are *NOT* in the second. +without :: NamingEnv -> NamingEnv -> NamingEnv +NamingEnv keep `without` NamingEnv remove = NamingEnv result + where + result = Map.differenceWith rmInNS keep remove + rmInNS a b = let c = Map.differenceWith diffNames a b + in if Map.null c then Nothing else Just c +-- | All names mentioned in the environment +namingEnvNames :: NamingEnv -> Set Name +namingEnvNames (NamingEnv xs) = + case unionManyNames (mapMaybe (unionManyNames . Map.elems) (Map.elems xs)) of + Nothing -> Set.empty + Just (One x) -> Set.singleton x + Just (Ambig as) -> as -namingEnvRename :: (Name -> Name) -> NamingEnv -> NamingEnv -namingEnvRename f (NamingEnv mp) = NamingEnv (ren <$> mp) +-- | Get a unqualified naming environment for the given names +namingEnvFromNames :: Set Name -> NamingEnv +namingEnvFromNames xs = NamingEnv (foldl' add mempty xs) where - ren nsm = map f <$> nsm + add mp x = let ns = nameNamespace x + txt = nameIdent x + in Map.insertWith (Map.unionWith (<>)) + ns (Map.singleton (mkUnqual txt) (One x)) + mp -instance Semigroup NamingEnv where - NamingEnv l <> NamingEnv r = - NamingEnv (Map.unionWith (Map.unionWith merge) l r) - -instance Monoid NamingEnv where - mempty = NamingEnv Map.empty - {-# INLINE mempty #-} +-- | Get the names in a given namespace +namespaceMap :: Namespace -> NamingEnv -> Map PName Names +namespaceMap ns (NamingEnv env) = Map.findWithDefault Map.empty ns env +-- | Resolve a name in the given namespace. +lookupNS :: Namespace -> PName -> NamingEnv -> Maybe Names +lookupNS ns x env = Map.lookup x (namespaceMap ns env) --- | Merge two name maps, collapsing cases where the entries are the same, and --- producing conflicts otherwise. -merge :: [Name] -> [Name] -> [Name] -merge xs ys | xs == ys = xs - | otherwise = nub (xs ++ ys) +-- | Resolve a name in the given namespace. +lookupListNS :: Namespace -> PName -> NamingEnv -> [Name] +lookupListNS ns x env = + case lookupNS ns x env of + Nothing -> [] + Just as -> namesToList as -instance PP NamingEnv where - ppPrec _ (NamingEnv mps) = vcat $ map ppNS $ Map.toList mps - where ppNS (ns,xs) = pp ns $$ nest 2 (vcat (map ppNm (Map.toList xs))) - ppNm (x,as) = pp x <+> "->" <+> commaSep (map pp as) +-- | Singleton renaming environment for the given namespace. +singletonNS :: Namespace -> PName -> Name -> NamingEnv +singletonNS ns pn n = NamingEnv (Map.singleton ns (Map.singleton pn (One n))) -- | Generate a mapping from 'PrimIdent' to 'Name' for a -- given naming environment. @@ -124,7 +131,8 @@ } where fromNS ns = Map.fromList - [ entry x | xs <- Map.elems (namespaceMap ns env), x <- xs ] + [ entry x | xs <- Map.elems (namespaceMap ns env) + , x <- namesToList xs ] entry n = case asPrim n of Just p -> (p,n) @@ -139,9 +147,9 @@ where names = Map.fromList [ (og, qn) - | ns <- [ NSValue, NSType, NSModule ] + | ns <- allNamespaces , (pn,xs) <- Map.toList (namespaceMap ns env) - , x <- xs + , x <- namesToList xs , og <- maybeToList (asOrigName x) , let qn = case getModName pn of Just q -> Qualified q @@ -154,145 +162,127 @@ -- NOTE: if entries in the NamingEnv would have produced a name clash, -- they will be omitted from the resulting sets. visibleNames :: NamingEnv -> Map Namespace (Set Name) -visibleNames (NamingEnv env) = Set.fromList . mapMaybe check . Map.elems <$> env - where - check names = - case names of - [name] -> Just name - _ -> Nothing +visibleNames (NamingEnv env) = check <$> env + where check mp = Set.fromList [ a | One a <- Map.elems mp ] -- | Qualify all symbols in a 'NamingEnv' with the given prefix. qualify :: ModName -> NamingEnv -> NamingEnv qualify pfx (NamingEnv env) = NamingEnv (Map.mapKeys toQual <$> env) where - -- XXX we don't currently qualify fresh names + -- We don't qualify fresh names, because they should not be directly + -- visible to the end users (i.e., they shouldn't really be exported) toQual (Qual _ n) = Qual pfx n toQual (UnQual n) = Qual pfx n toQual n@NewName{} = n -filterNames :: (PName -> Bool) -> NamingEnv -> NamingEnv -filterNames p (NamingEnv env) = NamingEnv (Map.filterWithKey check <$> env) - where check n _ = p n - - --- | Like mappend, but when merging, prefer values on the lhs. -shadowing :: NamingEnv -> NamingEnv -> NamingEnv -shadowing (NamingEnv l) (NamingEnv r) = NamingEnv (Map.unionWith Map.union l r) +filterPNames :: (PName -> Bool) -> NamingEnv -> NamingEnv +filterPNames p (NamingEnv env) = NamingEnv (Map.mapMaybe checkNS env) + where + checkNS nsMap = let new = Map.filterWithKey (\n _ -> p n) nsMap + in if Map.null new then Nothing else Just new -travNamingEnv :: Applicative f => (Name -> f Name) -> NamingEnv -> f NamingEnv -travNamingEnv f (NamingEnv mp) = - NamingEnv <$> traverse (traverse (traverse f)) mp +filterUNames :: (Name -> Bool) -> NamingEnv -> NamingEnv +filterUNames p (NamingEnv env) = NamingEnv (Map.mapMaybe check env) + where + check nsMap = let new = Map.mapMaybe (filterNames p) nsMap + in if Map.null new then Nothing else Just new -{- | Do somethign in context. If `Nothing` than we are working with -a local declaration. Otherwise we are at the top-level of the -given module. -} -data InModule a = InModule (Maybe ModPath) a - deriving (Functor,Traversable,Foldable,Show) - +-- | Find the ambiguous entries in an environmet. +-- A name is ambiguous if it might refer to multiple entities. +findAmbig :: NamingEnv -> [ [Name] ] +findAmbig (NamingEnv ns) = + [ Set.toList xs + | mp <- Map.elems ns + , Ambig xs <- Map.elems mp + ] -newTop :: - FreshM m => Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name -newTop ns m thing fx rng = - liftSupply (mkDeclared ns m src (getIdent thing) fx rng) - where src = if isGeneratedName thing then SystemName else UserName +-- | Get the subset of the first environment that shadows something +-- in the second one. +findShadowing :: NamingEnv -> NamingEnv -> [ (PName,Name,[Name]) ] +findShadowing (NamingEnv lhs) rhs = + [ (p, anyOne xs, namesToList ys) + | (ns,mp) <- Map.toList lhs + , (p,xs) <- Map.toList mp + , Just ys <- [ lookupNS ns p rhs ] + ] -newLocal :: FreshM m => Namespace -> PName -> Range -> m Name -newLocal ns thing rng = liftSupply (mkParameter ns (getIdent thing) rng) +-- | Do an arbitrary choice for ambiguous names. +-- We do this to continue checking afetr we've reported an ambiguity error. +forceUnambig :: NamingEnv -> NamingEnv +forceUnambig (NamingEnv mp) = NamingEnv (fmap (One . anyOne) <$> mp) -newtype BuildNamingEnv = BuildNamingEnv { runBuild :: SupplyT Id NamingEnv } +-- | Like mappend, but when merging, prefer values on the lhs. +shadowing :: NamingEnv -> NamingEnv -> NamingEnv +shadowing (NamingEnv l) (NamingEnv r) = NamingEnv (Map.unionWith Map.union l r) +mapNamingEnv :: (Name -> Name) -> NamingEnv -> NamingEnv +mapNamingEnv f (NamingEnv mp) = NamingEnv (fmap (mapNames f) <$> mp) -buildNamingEnv :: BuildNamingEnv -> Supply -> (NamingEnv,Supply) -buildNamingEnv b supply = runId $ runSupplyT supply $ runBuild b +travNamingEnv :: Applicative f => (Name -> f Name) -> NamingEnv -> f NamingEnv +travNamingEnv f (NamingEnv mp) = + NamingEnv <$> traverse (traverse (travNames f)) mp --- | Generate a 'NamingEnv' using an explicit supply. -defsOf :: BindsNames a => a -> Supply -> (NamingEnv,Supply) -defsOf = buildNamingEnv . namingEnv +isEmptyNamingEnv :: NamingEnv -> Bool +isEmptyNamingEnv (NamingEnv mp) = Map.null mp +-- This assumes that we've been normalizing away empty maps, hopefully +-- we've been doing it everywhere. --------------------------------------------------------------------------------- --- Collect definitions of nested modules - -type NestedMods = Map Name NamingEnv -type CollectM = StateT NestedMods (SupplyT Id) - -collectNestedModules :: - NamingEnv -> Module PName -> Supply -> (NestedMods, Supply) -collectNestedModules env m = - collectNestedModulesDecls env (thing (mName m)) (mDecls m) - -collectNestedModulesDecls :: - NamingEnv -> ModName -> [TopDecl PName] -> Supply -> (NestedMods, Supply) -collectNestedModulesDecls env m ds sup = (mp,newS) +-- | Compute an unqualified naming environment, containing the various module +-- parameters. +modParamsNamingEnv :: T.ModParamNames -> NamingEnv +modParamsNamingEnv T.ModParamNames { .. } = + NamingEnv $ Map.fromList + [ (NSValue, Map.fromList $ map fromFu $ Map.keys mpnFuns) + , (NSType, Map.fromList $ map fromTS (Map.elems mpnTySyn) ++ + map fromTy (Map.elems mpnTypes)) + ] where - s0 = Map.empty - mpath = TopModule m - ((_,mp),newS) = runId $ runSupplyT sup $ runStateT s0 $ - collectNestedModulesDs mpath env ds - -collectNestedModulesDs :: ModPath -> NamingEnv -> [TopDecl PName] -> CollectM () -collectNestedModulesDs mpath env ds = - forM_ [ tlValue nm | DModule nm <- ds ] \(NestedModule nested) -> - do let pname = thing (mName nested) - name = case lookupNS NSModule pname env of - n : _ -> n -- if a name is ambiguous we may get - -- multiple answers, but we just pick one. - -- This should be OK, as the error should be - -- caught during actual renaming. - _ -> panic "collectedNestedModulesDs" - [ "Missing definition for " ++ show pname ] - newEnv <- lift (runBuild (moduleDefs (Nested mpath (nameIdent name)) nested)) - sets_ (Map.insert name newEnv) - let newMPath = Nested mpath (nameIdent name) - collectNestedModulesDs newMPath newEnv (mDecls nested) + toPName n = mkUnqual (nameIdent n) --------------------------------------------------------------------------------- + fromTy tp = let nm = T.mtpName tp + in (toPName nm, One nm) + fromFu f = (toPName f, One f) + fromTS ts = (toPName (T.tsName ts), One (T.tsName ts)) -instance Semigroup BuildNamingEnv where - BuildNamingEnv a <> BuildNamingEnv b = BuildNamingEnv $ - do x <- a - y <- b - return (mappend x y) - -instance Monoid BuildNamingEnv where - mempty = BuildNamingEnv (pure mempty) - - mappend = (<>) - - mconcat bs = BuildNamingEnv $ - do ns <- sequence (map runBuild bs) - return (mconcat ns) - --------------------------------------------------------------------------------- - +-- | Generate a naming environment from a declaration interface, where none of +-- the names are qualified. +unqualifiedEnv :: IfaceDecls -> NamingEnv +unqualifiedEnv IfaceDecls { .. } = + mconcat [ exprs, tySyns, ntTypes, absTys, ntExprs, mods, sigs ] + where + toPName n = mkUnqual (nameIdent n) + exprs = mconcat [ singletonNS NSValue (toPName n) n + | n <- Map.keys ifDecls ] --- | Things that define exported names. -class BindsNames a where - namingEnv :: a -> BuildNamingEnv + tySyns = mconcat [ singletonNS NSType (toPName n) n + | n <- Map.keys ifTySyns ] -instance BindsNames NamingEnv where - namingEnv env = BuildNamingEnv (return env) - {-# INLINE namingEnv #-} + ntTypes = mconcat [ n + | nt <- Map.elems ifNewtypes + , let tname = T.ntName nt + cname = T.ntConName nt + , n <- [ singletonNS NSType (toPName tname) tname + , singletonNS NSValue (toPName cname) cname + ] + ] -instance BindsNames a => BindsNames (Maybe a) where - namingEnv = foldMap namingEnv - {-# INLINE namingEnv #-} + absTys = mconcat [ singletonNS NSType (toPName n) n + | n <- Map.keys ifAbstractTypes ] -instance BindsNames a => BindsNames [a] where - namingEnv = foldMap namingEnv - {-# INLINE namingEnv #-} + ntExprs = mconcat [ singletonNS NSValue (toPName n) n + | n <- Map.keys ifNewtypes ] --- | Generate a type renaming environment from the parameters that are bound by --- this schema. -instance BindsNames (Schema PName) where - namingEnv (Forall ps _ _ _) = foldMap namingEnv ps - {-# INLINE namingEnv #-} + mods = mconcat [ singletonNS NSModule (toPName n) n + | n <- Map.keys ifModules ] + sigs = mconcat [ singletonNS NSModule (toPName n) n + | n <- Map.keys ifSignatures ] -- | Adapt the things exported by something to the specific import/open. @@ -309,166 +299,12 @@ -- restrict or hide imported symbols restricted | Just (Hiding ns) <- iSpec imp = - filterNames (\qn -> not (getIdent qn `elem` ns)) public + filterPNames (\qn -> not (getIdent qn `elem` ns)) public | Just (Only ns) <- iSpec imp = - filterNames (\qn -> getIdent qn `elem` ns) public + filterPNames (\qn -> getIdent qn `elem` ns) public | otherwise = public --- | Interpret an import in the context of an interface, to produce a name --- environment for the renamer, and a 'NameDisp' for pretty-printing. -interpImportIface :: Import {- ^ The import declarations -} -> - IfaceDecls {- ^ Declarations of imported module -} -> - NamingEnv -interpImportIface imp = interpImportEnv imp . unqualifiedEnv - - --- | Generate a naming environment from a declaration interface, where none of --- the names are qualified. -unqualifiedEnv :: IfaceDecls -> NamingEnv -unqualifiedEnv IfaceDecls { .. } = - mconcat [ exprs, tySyns, ntTypes, absTys, ntExprs, mods ] - where - toPName n = mkUnqual (nameIdent n) - - exprs = mconcat [ singletonE (toPName n) n | n <- Map.keys ifDecls ] - tySyns = mconcat [ singletonT (toPName n) n | n <- Map.keys ifTySyns ] - ntTypes = mconcat [ singletonT (toPName n) n | n <- Map.keys ifNewtypes ] - absTys = mconcat [ singletonT (toPName n) n | n <- Map.keys ifAbstractTypes ] - ntExprs = mconcat [ singletonE (toPName n) n | n <- Map.keys ifNewtypes ] - mods = mconcat [ singletonNS NSModule (toPName n) n - | n <- Map.keys ifModules ] - --- | Compute an unqualified naming environment, containing the various module --- parameters. -modParamsNamingEnv :: IfaceParams -> NamingEnv -modParamsNamingEnv IfaceParams { .. } = - NamingEnv $ Map.fromList - [ (NSValue, Map.fromList $ map fromFu $ Map.keys ifParamFuns) - , (NSType, Map.fromList $ map fromTy $ Map.elems ifParamTypes) - ] - where - toPName n = mkUnqual (nameIdent n) - - fromTy tp = let nm = T.mtpName tp - in (toPName nm, [nm]) - - fromFu f = (toPName f, [f]) - - - -data ImportIface = ImportIface Import Iface - --- | Produce a naming environment from an interface file, that contains a --- mapping only from unqualified names to qualified ones. -instance BindsNames ImportIface where - namingEnv (ImportIface imp Iface { .. }) = BuildNamingEnv $ - return (interpImportIface imp ifPublic) - {-# INLINE namingEnv #-} - --- | Introduce the name -instance BindsNames (InModule (Bind PName)) where - namingEnv (InModule mb b) = BuildNamingEnv $ - do let Located { .. } = bName b - n <- case mb of - Just m -> newTop NSValue m thing (bFixity b) srcRange - Nothing -> newLocal NSValue thing srcRange -- local fixitiies? - - return (singletonE thing n) - --- | Generate the naming environment for a type parameter. -instance BindsNames (TParam PName) where - namingEnv TParam { .. } = BuildNamingEnv $ - do let range = fromMaybe emptyRange tpRange - n <- newLocal NSType tpName range - return (singletonT tpName n) - --- | The naming environment for a single module. This is the mapping from --- unqualified names to fully qualified names with uniques. -instance BindsNames (Module PName) where - namingEnv m = moduleDefs (TopModule (thing (mName m))) m - - -moduleDefs :: ModPath -> ModuleG mname PName -> BuildNamingEnv -moduleDefs m Module { .. } = foldMap (namingEnv . InModule (Just m)) mDecls - - -instance BindsNames (InModule (TopDecl PName)) where - namingEnv (InModule ns td) = - case td of - Decl d -> namingEnv (InModule ns (tlValue d)) - DPrimType d -> namingEnv (InModule ns (tlValue d)) - TDNewtype d -> namingEnv (InModule ns (tlValue d)) - DParameterType d -> namingEnv (InModule ns d) - DParameterConstraint {} -> mempty - DParameterFun d -> namingEnv (InModule ns d) - Include _ -> mempty - DImport {} -> mempty -- see 'openLoop' in the renamer - DModule m -> namingEnv (InModule ns (tlValue m)) - - -instance BindsNames (InModule (NestedModule PName)) where - namingEnv (InModule ~(Just m) (NestedModule mdef)) = BuildNamingEnv $ - do let pnmame = mName mdef - nm <- newTop NSModule m (thing pnmame) Nothing (srcRange pnmame) - pure (singletonNS NSModule (thing pnmame) nm) - -instance BindsNames (InModule (PrimType PName)) where - namingEnv (InModule ~(Just m) PrimType { .. }) = - BuildNamingEnv $ - do let Located { .. } = primTName - nm <- newTop NSType m thing primTFixity srcRange - pure (singletonT thing nm) - -instance BindsNames (InModule (ParameterFun PName)) where - namingEnv (InModule ~(Just ns) ParameterFun { .. }) = BuildNamingEnv $ - do let Located { .. } = pfName - ntName <- newTop NSValue ns thing pfFixity srcRange - return (singletonE thing ntName) - -instance BindsNames (InModule (ParameterType PName)) where - namingEnv (InModule ~(Just ns) ParameterType { .. }) = BuildNamingEnv $ - -- XXX: we don't seem to have a fixity environment at the type level - do let Located { .. } = ptName - ntName <- newTop NSType ns thing Nothing srcRange - return (singletonT thing ntName) - --- NOTE: we use the same name at the type and expression level, as there's only --- ever one name introduced in the declaration. The names are only ever used in --- different namespaces, so there's no ambiguity. -instance BindsNames (InModule (Newtype PName)) where - namingEnv (InModule ~(Just ns) Newtype { .. }) = BuildNamingEnv $ - do let Located { .. } = nName - ntName <- newTop NSType ns thing Nothing srcRange - -- XXX: the name reuse here is sketchy - return (singletonT thing ntName `mappend` singletonE thing ntName) - --- | The naming environment for a single declaration. -instance BindsNames (InModule (Decl PName)) where - namingEnv (InModule pfx d) = case d of - DBind b -> namingEnv (InModule pfx b) - DSignature ns _sig -> foldMap qualBind ns - DPragma ns _p -> foldMap qualBind ns - DType syn -> qualType (tsName syn) (tsFixity syn) - DProp syn -> qualType (psName syn) (psFixity syn) - DLocated d' _ -> namingEnv (InModule pfx d') - DRec {} -> panic "namingEnv" [ "DRec" ] - DPatBind _pat _e -> panic "namingEnv" ["Unexpected pattern binding"] - DFixity{} -> panic "namingEnv" ["Unexpected fixity declaration"] - - where - - mkName ns ln fx = case pfx of - Just m -> newTop ns m (thing ln) fx (srcRange ln) - Nothing -> newLocal ns (thing ln) (srcRange ln) - - qualBind ln = BuildNamingEnv $ - do n <- mkName NSValue ln Nothing - return (singletonE (thing ln) n) - - qualType ln f = BuildNamingEnv $ - do n <- mkName NSType ln f - return (singletonT (thing ln) n) diff --git a/src/Cryptol/ModuleSystem/Renamer.hs b/src/Cryptol/ModuleSystem/Renamer.hs --- a/src/Cryptol/ModuleSystem/Renamer.hs +++ b/src/Cryptol/ModuleSystem/Renamer.hs @@ -10,9 +10,10 @@ {-# Language FlexibleInstances #-} {-# Language FlexibleContexts #-} {-# Language BlockArguments #-} +{-# Language OverloadedStrings #-} module Cryptol.ModuleSystem.Renamer ( NamingEnv(), shadowing - , BindsNames(..), InModule(..) + , BindsNames, InModule(..) , shadowNames , Rename(..), runRenamer, RenameM() , RenamerError(..) @@ -30,154 +31,301 @@ import Prelude.Compat import Data.Either(partitionEithers) -import Data.Maybe(fromJust) -import Data.List(find,foldl') +import Data.Maybe(mapMaybe) +import Data.List(find,groupBy,sortBy) +import Data.Function(on) import Data.Foldable(toList) -import Data.Map.Strict(Map) +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 MonadLib hiding (mapM, mapM_) import Cryptol.ModuleSystem.Name +import Cryptol.ModuleSystem.Names import Cryptol.ModuleSystem.NamingEnv import Cryptol.ModuleSystem.Exports -import Cryptol.Parser.Position(getLoc) +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,packModName) +import Cryptol.Utils.Ident(allNamespaces,OrigName(..),modPathCommon, + undefinedModName) +import Cryptol.Utils.PP import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Renamer.Error +import Cryptol.ModuleSystem.Binds import Cryptol.ModuleSystem.Renamer.Monad +import Cryptol.ModuleSystem.Renamer.Imports +import Cryptol.ModuleSystem.Renamer.ImplicitImports +{- +The Renamer Algorithm +===================== + +1. Add implicit imports for visible nested modules + +2. Compute what each module defines (see "Cryptol.ModuleSystem.Binds") + - This assigns unique names to names introduces by various declarations + - Here we detect repeated top-level definitions in a module. + - Module instantiations also get a name, but are not yet resolved, so + we don't know what's defined by them. + - We do not generate unique names for functor parameters---those will + be matched textually to the arguments when applied. + - We *do* generate unique names for declarations in "signatures" + * those are only really needed when renaming the signature (step 4) + (e.g., to determine if a name refers to something declared in the + signature or something else). + * when validating a module against a signature the names of the declarations + are matched textually, *not* using the unique names + (e.g., `x` in a signature is matched with the thing named `x` in a module, + even though these two `x`s will have different unique `id`s) + + +3. Resolve imports and instantiations (see "Cryptol.ModuleSystem.Imports") + - Resolves names in submodule imports + - Resolves functor instantiations: + * generate new names for declarations in the functors. + * this includes any nested modules, and things nested within them. + - At this point we have enough information to know what's exported by + each module. + +4. Do the renaming (this module) + - Using step 3 we compute the scoping environment for each module/signature + - We traverse all declarations and replace the parser names with the + corresponding names in scope: + * Here we detect ambiguity and undefined errors + * During this pass is also where we keep track of information of what + names are used by declarations: + - this is used to compute the dependencies between declarations + - which are in turn used to order the declarations in dependency order + * this is assumed by the TC + * here we also report errors about invalid recursive dependencies + * During this stage we also issue warning about unused type names + (and we should probably do unused value names too one day) + - During the rewriting we also do: + - rebalance expression trees using the operator fixities + - desugar record update notation +-} + + +-- | The result of renaming a module data RenamedModule = RenamedModule { rmModule :: Module Name -- ^ The renamed module , rmDefines :: NamingEnv -- ^ What this module defines , rmInScope :: NamingEnv -- ^ What's in scope in this module - , rmImported :: IfaceDecls -- ^ Imported declarations + , 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 let m = m0 { mDecls = snd (addImplicitNestedImports (mDecls m0)) } - env <- liftSupply (defsOf m) - nested <- liftSupply (collectNestedModules env m) - setNestedModule (nestedModuleNames nested) - do (ifs,(inScope,m1)) <- collectIfaceDeps - $ renameModule' nested env (TopModule (thing (mName m))) m + do -- Step 1: add implicit imports + let m = m0 { mDef = + case mDef m0 of + NormalModule ds -> + NormalModule (addImplicitNestedImports ds) + FunctorInstance f as i -> FunctorInstance f as i + InterfaceModule s -> InterfaceModule s + } + + -- Step 2: compute what's defined + (defs,errs) <- liftSupply (modBuilder (topModuleDefs m)) + mapM_ recordError errs + + -- Step 3: resolve imports + extern <- getExternal + resolvedMods <- liftSupply (resolveImports extern defs) + + let pathToName = Map.fromList [ (Nested (nameModPath x) (nameIdent x), x) + | ImpNested x <- Map.keys resolvedMods ] + + + let mname = ImpTop (thing (mName m)) + + setResolvedLocals resolvedMods $ + setNestedModule pathToName + do (ifs,(inScope,m1)) <- collectIfaceDeps (renameModule' mname m) + env <- rmodDefines <$> lookupResolved mname pure RenamedModule { rmModule = m1 , rmDefines = env , rmInScope = inScope , rmImported = ifs - -- XXX: maybe we should keep the nested defines too? + -- 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 let ds = snd (addImplicitNestedImports ds0) - let mpath = TopModule m - env <- liftSupply (defsOf (map (InModule (Just mpath)) ds)) - nested <- liftSupply (collectNestedModulesDecls env m ds) - setNestedModule (nestedModuleNames nested) - do ds1 <- shadowNames' CheckOverlap env - (renameTopDecls' (nested,mpath) ds) - -- record a use of top-level names to avoid - -- unused name warnings - let exports = concatMap exportedNames ds1 - mapM_ recordUse (foldMap (exported NSType) exports) + do -- Step 1: add implicit imports + let ds = addImplicitNestedImports ds0 - pure (env,ds1) + -- Step 2: compute what's defined + (defs,errs) <- liftSupply (modBuilder (topDeclsDefs (TopModule m) ds)) + mapM_ recordError errs --- | 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) = foldr classify ([], []) decls - (newDecls,exportedMods) = unzip (map processModule mods) - processModule m = - let NestedModule m1 = tlValue m - (childExs, ds1) = addImplicitNestedImports (mDecls m1) - mname = getIdent (thing (mName m1)) - imps = map (mname :) ([] : childExs) - isToName is = case is of - [i] -> mkUnqual i - _ -> mkQual (isToQual (init is)) (last is) - isToQual is = packModName (map identText is) - mkImp xs = DImport - Located - { srcRange = srcRange (mName m1) - , thing = Import - { iModule = ImpNested (isToName xs) - , iAs = Just (isToQual xs) - , iSpec = Nothing - } - } - in ( DModule m { tlValue = NestedModule m1 { mDecls = ds1 } } - : map mkImp imps - , case tlExport m of - Public -> imps - Private -> [] - ) + -- 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 ] - classify d (ms,ds) = - case d of - DModule tl -> (tl : ms, ds) - _ -> (ms, d : ds) + setResolvedLocals resolvedMods $ + setNestedModule pathToName + do env <- rmodDefines <$> lookupResolved (ImpTop m) -nestedModuleNames :: NestedMods -> Map ModPath Name -nestedModuleNames mp = Map.fromList (map entry (Map.keys mp)) - where - entry n = case nameInfo n of - Declared p _ -> (Nested p (nameIdent n),n) - _ -> panic "nestedModuleName" [ "Not a top-level name" ] + -- 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) --- | Returns: +-- | This is used for both top-level and nested modules. +-- Returns: -- --- * Interfaces for imported things, --- * Things defines in the module +-- * Things defined in the module -- * Renamed module renameModule' :: - NestedMods -> NamingEnv -> ModPath -> ModuleG mname PName -> + ImpName Name {- ^ Resolved name for this module -} -> + ModuleG mname PName -> RenameM (NamingEnv, ModuleG mname Name) -renameModule' thisNested env mpath m = - setCurMod mpath - do (moreNested,imps) <- mconcat <$> mapM doImport (mImports m) - let allNested = Map.union moreNested thisNested - openDs = map thing (mSubmoduleImports m) - allImps = openLoop allNested env openDs imps +renameModule' mname m = + setCurMod + case mname of + ImpTop r -> TopModule r + ImpNested r -> Nested (nameModPath r) (nameIdent r) - (inScope,decls') <- - shadowNames' CheckNone allImps $ - shadowNames' CheckOverlap env $ - -- maybe we should allow for a warning - -- if a local name shadows an imported one? - do inScope <- getNamingEnv - ds <- renameTopDecls' (allNested,mpath) (mDecls m) - pure (inScope, ds) - let m1 = m { mDecls = decls' } - exports = modExports m1 - mapM_ recordUse (exported NSType exports) - return (inScope, m1) + do resolved <- lookupResolved mname + shadowNames' CheckNone (rmodImports resolved) + case mDef m of + NormalModule ds -> + do let env = rmodDefines resolved + (paramEnv,params) <- + shadowNames' CheckNone env + (doModParams (mModParams m)) + + -- we check that defined names and ones that came + -- from parameters do not clash, as this would be + -- very confusing. + shadowNames' CheckOverlap (env <> paramEnv) $ + setModParams params + do ds1 <- renameTopDecls' ds + let exports = exportedDecls ds1 + mapM_ recordUse (exported NSType exports) + inScope <- getNamingEnv + pure (inScope, m { mDef = NormalModule ds1 }) + + -- The things defined by this module are the *results* + -- of the instantiation, so we should *not* add them + -- in scope when resolving. + FunctorInstance f as _ -> + do f' <- rnLocated rename f + as' <- rename as + checkFunctorArgs as' + + let l = Just (srcRange f') + imap <- mkInstMap l mempty (thing f') mname + + {- Now we need to compute what's "in scope" of the instantiated + module. This is used when the module is loaded at the command + line and users want to evalute things in the context of the + module -} + fuEnv <- if isFakeName (thing f') + then pure mempty + else lookupDefines (thing f') + let ren x = Map.findWithDefault x x imap + + -- XXX: This is not quite right as it only considers the things + -- defined in the module to be in scope. It misses things + -- that are *imported* by the functor, in particular the Cryptol + -- library + -- is missing. See #1455. + inScope <- shadowNames' CheckNone (mapNamingEnv ren fuEnv) + getNamingEnv + + pure (inScope, m { mDef = FunctorInstance f' as' imap }) + + InterfaceModule s -> + shadowNames' CheckNone (rmodDefines resolved) + do d <- InterfaceModule <$> renameIfaceModule mname s + inScope <- getNamingEnv + pure (inScope, m { mDef = d }) + + +checkFunctorArgs :: ModuleInstanceArgs Name -> RenameM () +checkFunctorArgs args = + case args of + DefaultInstAnonArg {} -> + panic "checkFunctorArgs" ["Nested DefaultInstAnonArg"] + DefaultInstArg l -> checkArg l + NamedInstArgs as -> mapM_ checkNamedArg as + where + checkNamedArg (ModuleInstanceNamedArg _ l) = checkArg l + + checkArg l = + case thing l of + ModuleArg m + | isFakeName m -> pure () + | otherwise -> checkIsModule (srcRange l) m AModule + ParameterArg {} -> pure () -- we check these in the type checker + AddParams -> pure () + +mkInstMap :: Maybe Range -> Map Name Name -> ImpName Name -> ImpName Name -> + RenameM (Map Name Name) +mkInstMap checkFun acc0 ogname iname + | isFakeName ogname = pure Map.empty + | otherwise = + do case checkFun of + Nothing -> pure () + Just r -> checkIsModule r ogname AFunctor + (onames,osubs) <- lookupDefinesAndSubs ogname + inames <- lookupDefines iname + let mp = zipByTextName onames inames + subs = [ (ImpNested k, ImpNested v) + | k <- Set.toList osubs, Just v <- [Map.lookup k mp] + ] + foldM doSub (Map.union mp acc0) subs + + where + doSub acc (k,v) = mkInstMap Nothing acc k v + + + +-- | This is used to rename local declarations (e.g. `where`) renameDecls :: [Decl PName] -> RenameM [Decl Name] renameDecls ds = do (ds1,deps) <- depGroup (traverse rename ds) @@ -192,14 +340,37 @@ CyclicSCC ds_xs -> let (rds,xs) = unzip ds_xs in case mapM validRecursiveD rds of - Nothing -> do record (InvalidDependency xs) + 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 @@ -212,24 +383,128 @@ case ms of a : as | let bad = [ fst b | b <- as, snd a /= snd b ] , not (null bad) -> - record $ InvalidDependency $ map NamedThing $ fst a : bad + recordError (InvalidDependency $ map NamedThing $ fst a : bad) _ -> pure () where - ms = [ (x,p) | NamedThing x <- xs, Declared p _ <- [ nameInfo x ] ] + ms = [ (x,ogModule og) + | NamedThing x <- xs, GlobalName _ og <- [ nameInfo x ] + ] -renameTopDecls' :: - (NestedMods,ModPath) -> [TopDecl PName] -> RenameM [TopDecl Name] -renameTopDecls' info ds = - do (ds1,deps) <- depGroup (traverse (renameWithMods info) ds) +{- NOTE: Dependencies on Top Level Constraints + =========================================== - let (noNameDs,nameDs) = partitionEithers (map topDeclName ds1) - ctrs = [ nm | (_,nm@(ConstratintAt {})) <- nameDs ] - toNode (d,x) = ((d,x),x, (if usesCtrs d then ctrs else []) ++ - map NamedThing - ( Set.toList - ( Map.findWithDefault Set.empty x deps) )) +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 @@ -237,7 +512,7 @@ CyclicSCC ds_xs -> let (rds,xs) = unzip ds_xs in case mapM valid rds of - Nothing -> do record (InvalidDependency xs) + Nothing -> do recordError (InvalidDependency xs) pure rds Just bs -> do checkSameModule xs @@ -253,36 +528,49 @@ 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 - DParameterType {} -> False - DParameterConstraint {} -> False - - DParameterFun {} -> True - -- Here we may need the constraints to validate the type - -- (e.g., if the parameter is of type `Z a`) + 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 - DRec {} -> True - DSignature {} -> bad "DSignature" - DFixity {} -> bad "DFixity" - DPragma {} -> bad "DPragma" - DPatBind {} -> bad "DPatBind" + DSignature {} -> bad "DSignature" + DFixity {} -> bad "DFixity" + DPragma {} -> bad "DPragma" + DPatBind {} -> bad "DPatBind" + bad msg = panic "renameTopDecls'" [msg] @@ -302,172 +590,243 @@ where bad x = panic "declName" [x] -topDeclName :: TopDecl Name -> Either (TopDecl Name) (TopDecl Name, DepName) +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))) - DParameterType d -> hasName (thing (ptName d)) - DParameterFun d -> hasName (thing (pfName d)) + TDNewtype d -> hasName' (thing (nName (tlValue d))) + [ nConName (tlValue d) ] DModule d -> hasName (thing (mName m)) where NestedModule m = tlValue d - DParameterConstraint ds -> - case ds of - [] -> noName - _ -> Right (topDecl, ConstratintAt (fromJust (getLoc ds))) + 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 = Right (topDecl, NamedThing n) + hasName n = hasName' n [] + hasName' n ms = Right (topDecl, NamedThing n, map NamedThing ms) + special x = Right (topDecl, x, []) bad x = panic "topDeclName" [x] --- | Returns: --- * The public interface of the imported module --- * Infromation about nested modules in this module --- * New names introduced through this import -doImport :: Located Import -> RenameM (NestedMods, NamingEnv) -doImport li = - do let i = thing li - decls <- lookupImport i - let declsOf = unqualifiedEnv . ifPublic - nested = declsOf <$> ifModules decls - pure (nested, interpImportIface i decls) +{- | 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. --------------------------------------------------------------------------------- --- Compute names coming through `open` statements. +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 -data OpenLoopState = OpenLoopState - { unresolvedOpen :: [ImportG PName] - , scopeImports :: NamingEnv -- names from open/impot - , scopeDefs :: NamingEnv -- names defined in this module - , scopingRel :: NamingEnv -- defs + imports with shadowing - -- (just a cache) - , openLoopChange :: Bool - } + (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.. --- | Processing of a single @open@ declaration -processOpen :: NestedMods -> OpenLoopState -> ImportG PName -> OpenLoopState -processOpen modEnvs s o = - case lookupNS NSModule (iModule o) (scopingRel s) of - [] -> s { unresolvedOpen = o : unresolvedOpen s } - [n] -> - case Map.lookup n modEnvs of - Nothing -> panic "openLoop" [ "Missing defintion for module", show n ] - Just def -> - let new = interpImportEnv o def - newImps = new <> scopeImports s - in s { scopeImports = newImps - , scopingRel = scopeDefs s `shadowing` newImps - , openLoopChange = True - } - _ -> s - {- Notes: - * ambiguity will be reported later when we do the renaming - * assumes scoping only grows, which should be true - * we are not adding the names from *either* of the imports - so this may give rise to undefined names, so we may want to - suppress reporing undefined names if there ambiguities for - module names. Alternatively we could add the defitions from - *all* options, but that might lead to spurious ambiguity errors. - -} + 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) -{- | Complete the set of import using @open@ declarations. -This should terminate because on each iteration either @unresolvedOpen@ -decreases or @openLoopChange@ remians @False@. We don't report errors -here, as they will be reported during renaming anyway. -} -openLoop :: - NestedMods {- ^ Definitions of all known nested modules -} -> - NamingEnv {- ^ Definitions of the module (these shadow) -} -> - [ImportG PName] {- ^ Open declarations -} -> - NamingEnv {- ^ Imported declarations -} -> - NamingEnv {- ^ Completed imports -} -openLoop modEnvs defs os imps = - scopingRel $ loop OpenLoopState - { unresolvedOpen = os - , scopeImports = imps - , scopeDefs = defs - , scopingRel = defs `shadowing` imps - , openLoopChange = True - } - where - loop s - | openLoopChange s = - loop $ foldl' (processOpen modEnvs) - s { unresolvedOpen = [], openLoopChange = False } - (unresolvedOpen s) - | otherwise = s + unless isFake + (checkIsModule (srcRange sigName) sigName' ASignature) + sigEnv <- if isFake then pure mempty else lookupDefines sigName' + {- XXX: It seems a bit odd to use "newModParam" for the names to + be used for the instantiated type synonyms, + but what other name could we use? -} + let newP x = do y <- lift (newModParam me (mpName mp) loc x) + sets_ (Map.insert y x) + pure y + (newEnv',nameMap) <- runStateT Map.empty (travNamingEnv newP sigEnv) + let paramName = mpAs mp + let newEnv = case paramName of + Nothing -> newEnv' + Just q -> qualify q newEnv' + pure ( newEnv + , RenModParam + { renModParamName = mpName mp + , renModParamRange = loc + , renModParamSig = sigName' + , renModParamInstance = nameMap + } + ) + +{- | Process the parameters of a module. +Should be executed in a context where everything's already in the context, +except the module parameters. +-} +doModParams :: [ModParam PName] -> RenameM (NamingEnv, [RenModParam]) +doModParams srcParams = + do (paramEnvs,params) <- unzip <$> mapM doModParam srcParams + + let repeated = groupBy ((==) `on` renModParamName) + $ sortBy (compare `on` renModParamName) params + + forM_ repeated \ps -> + case ps of + [_] -> pure () + ~(p : _) -> recordError (MultipleModParams (renModParamName p) + (map renModParamRange ps)) + + pure (mconcat paramEnvs,params) + + + + -------------------------------------------------------------------------------- +rnLocated :: (a -> RenameM b) -> Located a -> RenameM (Located b) +rnLocated f loc = withLoc loc $ + do a' <- f (thing loc) + return loc { thing = a' } -data WithMods f n = WithMods (NestedMods,ModPath) (f n) -forgetMods :: WithMods f n -> f n -forgetMods (WithMods _ td) = td -renameWithMods :: - Rename (WithMods f) => (NestedMods,ModPath) -> f PName -> RenameM (f Name) -renameWithMods info m = forgetMods <$> rename (WithMods info m) -instance Rename (WithMods TopDecl) where - rename (WithMods info td) = WithMods info <$> + +instance Rename TopDecl where + rename td = case td of - Decl d -> Decl <$> traverse rename d - DPrimType d -> DPrimType <$> traverse rename d - TDNewtype n -> TDNewtype <$> traverse rename n - Include n -> return (Include n) - DParameterFun f -> DParameterFun <$> rename f - DParameterType f -> DParameterType <$> rename f + Decl d -> Decl <$> traverse rename d + DPrimType d -> DPrimType <$> traverse rename d + TDNewtype n -> TDNewtype <$> traverse rename n + Include n -> return (Include n) + DModule m -> DModule <$> traverse rename m + DImport li -> DImport <$> renI li + DModParam mp -> DModParam <$> rename mp + DInterfaceConstraint d ds -> + depsOf (ConstratintAt (srcRange ds)) + (DInterfaceConstraint d <$> rnLocated (mapM rename) ds) + DParamDecl {} -> panic "rename" ["DParamDecl"] - DParameterConstraint ds -> - case ds of - [] -> pure (DParameterConstraint []) - _ -> depsOf (ConstratintAt (fromJust (getLoc ds))) - $ DParameterConstraint <$> mapM renameLocated ds - DModule m -> DModule <$> traverse (renameWithMods info) m - DImport li -> DImport <$> traverse renI li - where - renI i = do m <- rename (iModule i) - pure i { iModule = m } + +renI :: Located (ImportG (ImpName PName)) -> + RenameM (Located (ImportG (ImpName Name))) +renI li = + withLoc (srcRange li) + do m <- rename (iModule i) + unless (isFakeName m) (recordImport (srcRange li) m) + pure li { thing = i { iModule = m } } + where + i = thing li + + +instance Rename ModParam where + rename mp = + do x <- rnLocated rename (mpSignature mp) + depsOf (ModParamName (srcRange (mpSignature mp)) (mpName mp)) + do ren <- renModParamInstance <$> getModParam (mpName mp) + + {- Here we add 2 "uses" to all type-level names introduced, + so that we don't get unused warnings for type parameters. + -} + mapM_ recordUse [ s | t <- Map.keys ren, nameNamespace t == NSType + , s <- [t,t] ] + + pure mp { mpSignature = x, mpRenaming = ren } + + +renameIfaceModule :: ImpName Name -> Signature PName -> RenameM (Signature Name) +renameIfaceModule nm sig = + do env <- rmodDefines <$> lookupResolved nm + let depName = case nm of + ImpNested n -> NamedThing n + ImpTop t -> ModPath (TopModule t) + shadowNames' CheckOverlap env $ + depsOf depName + do imps <- traverse renI (sigImports sig) + tps <- traverse rename (sigTypeParams sig) + + ds <- renameSigDecls (sigDecls sig) + cts <- traverse (rnLocated rename) (sigConstraints sig) + fun <- traverse rename (sigFunParams sig) + + -- we record a use here to avoid getting a warning in interfaces + -- that declare only types, and so appear "unused". + forM_ tps \tp -> recordUse (thing (ptName tp)) + forM_ ds \d -> recordUse $ case d of + SigTySyn ts _ -> thing (tsName ts) + SigPropSyn ps _ -> thing (psName ps) + + pure Signature + { sigImports = imps + , sigTypeParams = tps + , sigDecls = ds + , sigConstraints = cts + , sigFunParams = fun + } + instance Rename ImpName where rename i = case i of ImpTop m -> pure (ImpTop m) ImpNested m -> ImpNested <$> resolveName NameUse NSModule m -instance Rename (WithMods NestedModule) where - rename (WithMods info (NestedModule m)) = WithMods info <$> - do let (nested,mpath) = info - lnm = mName 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 - newMPath = Nested mpath (getIdent nm) n <- resolveName NameBind NSModule nm depsOf (NamedThing n) - do let env = case Map.lookup n (fst info) of - Just defs -> defs - Nothing -> panic "rename" - [ "Missing environment for nested module", show n ] - -- XXX: we should store in scope somehwere if we want to browse + do -- XXX: we should store in scope somewhere if we want to browse -- nested modules properly - (_inScope,m1) <- renameModule' nested env newMPath m + let m' = m { mName = ImpNested <$> mName m } + (_inScope,m1) <- renameModule' (ImpNested n) m' pure (NestedModule m1 { mName = lnm { thing = n } }) -renameLocated :: Rename f => Located (f PName) -> RenameM (Located (f Name)) -renameLocated x = - do y <- rename (thing x) - return x { thing = y } - instance Rename PrimType where rename pt = do x <- rnLocated (renameType NameBind) (primTName pt) @@ -477,7 +836,7 @@ -- 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 incorret warnings + -- body of the signature. This prevents incorrect warnings -- about unused names. mapM_ (recordUse . tpName) (fst cts) @@ -495,10 +854,11 @@ do sig' <- renameSchema (pfSchema a) return a { pfName = n', pfSchema = snd sig' } -rnLocated :: (a -> RenameM b) -> Located a -> RenameM (Located b) -rnLocated f loc = withLoc loc $ - do a' <- f (thing loc) - return loc { thing = a' } +instance Rename 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 @@ -509,7 +869,7 @@ DLocated d' r -> withLoc r $ DLocated <$> rename d' <*> pure r - DFixity{} -> panic "renaem" [ "DFixity" ] + DFixity{} -> panic "rename" [ "DFixity" ] DSignature {} -> panic "rename" [ "DSignature" ] DPragma {} -> panic "rename" [ "DPragma" ] DPatBind {} -> panic "rename" [ "DPatBind " ] @@ -520,11 +880,16 @@ instance Rename Newtype where rename n = shadowNames (nParams n) $ - do name' <- rnLocated (renameType NameBind) (nName n) - depsOf (NamedThing (thing name')) $ + do nameT <- rnLocated (renameType NameBind) (nName n) + nameC <- renameVar NameBind (nConName n) + + depsOf (NamedThing nameC) (addDep (thing nameT)) + + depsOf (NamedThing (thing nameT)) $ do ps' <- traverse rename (nParams n) body' <- traverse (traverse rename) (nBody n) - return Newtype { nName = name' + return Newtype { nName = nameT + , nConName = nameC , nParams = ps' , nBody = body' } @@ -539,42 +904,57 @@ NSType -> recordUse _ -> const (pure ()) case lkpIn expected of - Just [n] -> - do case nt of - NameBind -> pure () - NameUse -> addDep n - use n -- for warning - return (Just n) - Just [] -> panic "Renamer" ["Invalid expression renaming environment"] - Just syms -> - do mapM_ use syms -- mark as used to avoid unused warnings - n <- located qn - record (MultipleSyms n syms) - return (Just (head syms)) + Just xs -> + case xs of + One n -> + do case nt of + NameBind -> pure () + NameUse -> addDep n + use n -- for warning + return (Just n) + Ambig symSet -> + do let syms = Set.toList symSet + mapM_ use syms -- mark as used to avoid unused warnings + n <- located qn + recordError (MultipleSyms n syms) + return (Just (head syms)) Nothing -> pure Nothing +reportUnboundName :: Namespace -> PName -> RenameM Name +reportUnboundName expected qn = + do ro <- RenameM ask + let lkpIn here = Map.lookup qn (namespaceMap here (roNames ro)) + others = [ ns | ns <- allNamespaces + , ns /= expected + , Just _ <- [lkpIn ns] ] + nm <- located qn + case others of + -- name exists in a different namespace + actual : _ -> recordError (WrongNamespace expected actual nm) + + -- the value is just missing + [] -> recordError (UnboundName expected nm) + + mkFakeName expected qn + +isFakeName :: ImpName Name -> Bool +isFakeName m = + case m of + ImpTop x -> x == undefinedModName + ImpNested x -> + case nameTopModuleMaybe x of + Just y -> y == undefinedModName + Nothing -> False + + -- | Resolve a name, and report error on failure resolveName :: NameType -> Namespace -> PName -> RenameM Name resolveName nt expected qn = do mb <- resolveNameMaybe nt expected qn case mb of Just n -> pure n - Nothing -> - 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 : _ -> record (WrongNamespace expected actual nm) - - -- the value is just missing - [] -> record (UnboundName expected nm) - - mkFakeName expected qn + Nothing -> reportUnboundName expected qn renameVar :: NameType -> PName -> RenameM Name @@ -590,7 +970,8 @@ mkFakeName :: Namespace -> PName -> RenameM Name mkFakeName ns pn = do ro <- RenameM ask - liftSupply (mkParameter ns (getIdent pn) (roLoc ro)) + 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. @@ -639,7 +1020,7 @@ TTuple fs -> TTuple <$> traverse rename fs TWild -> return TWild TLocated t' r -> withLoc r (TLocated <$> rename t' <*> pure r) - TParens t' -> TParens <$> rename t' + TParens t' k -> (`TParens` k) <$> rename t' TInfix a o _ b -> do o' <- renameTypeOp o a' <- rename a b' <- rename b @@ -653,7 +1034,7 @@ FCLeft -> return (TInfix t o2 f2 z) FCRight -> do r <- mkTInfix y op z return (TInfix x o1 f1 r) - FCError -> do record (FixityError o1 f1 o2 f2) + FCError -> do recordError (FixityError o1 f1 o2 f2) return (TInfix t o2 f2 z) mkTInfix (TLocated t' _) op z = @@ -683,8 +1064,14 @@ instance Rename BindDef where rename DPrim = return DPrim + rename DForeign = return DForeign rename (DExpr e) = DExpr <$> rename e + rename (DPropGuards cases) = DPropGuards <$> traverse rename cases +instance Rename PropGuardCase where + rename g = PropGuardCase <$> traverse (rnLocated rename) (pgcProps g) + <*> rename (pgcExpr g) + -- NOTE: this only renames types within the pattern. instance Rename Pattern where rename p = case p of @@ -712,7 +1099,8 @@ case more of [] -> case h of UpdSet -> UpdField UpdSet [l] <$> rename e - UpdFun -> UpdField UpdFun [l] <$> rename (EFun emptyFunDesc [PVar p] e) + UpdFun -> UpdField UpdFun [l] <$> + rename (EFun emptyFunDesc [PVar p] e) where p = UnQual . selName <$> last ls _ -> UpdField UpdFun [l] <$> rename (EUpd Nothing [ UpdField h more e]) @@ -728,9 +1116,6 @@ rename expr = case expr of EVar n -> EVar <$> renameVar NameUse n ELit l -> return (ELit l) - ENeg e -> ENeg <$> rename e - EComplement e -> EComplement - <$> rename e EGenerate e -> EGenerate <$> rename e ETuple es -> ETuple <$> traverse rename es @@ -786,6 +1171,7 @@ x' <- rename x z' <- rename z mkEInfix x' op z' + EPrefix op e -> EPrefix op <$> rename e checkLabels :: [UpdField PName] -> RenameM () @@ -795,7 +1181,7 @@ check done l = do case find (overlap l) done of - Just l' -> record (OverlappingRecordUpdate (reLoc l) (reLoc l')) + Just l' -> recordError (OverlappingRecordUpdate (reLoc l) (reLoc l')) Nothing -> pure () pure (l : done) @@ -827,9 +1213,25 @@ FCRight -> do r <- mkEInfix y op z return (EInfix x o1 f1 r) - FCError -> do record (FixityError o1 f1 o2 f2) + FCError -> do recordError (FixityError o1 f1 o2 f2) return (EInfix e o2 f2 z) +mkEInfix e@(EPrefix o1 x) op@(o2, f2) y = + case compareFixity (prefixFixity o1) f2 of + FCRight -> do + let warning = PrefixAssocChanged o1 x o2 f2 y + RenameM $ sets_ (\rw -> rw {rwWarnings = warning : rwWarnings rw}) + r <- mkEInfix x op y + return (EPrefix o1 r) + + -- Even if the fixities conflict, we make the prefix operator take + -- precedence. + _ -> return (EInfix e o2 f2 y) + +-- Note that for prefix operator on RHS of infix operator we make the prefix +-- operator always have precedence, so we allow a * -b instead of requiring +-- a * (-b). + mkEInfix (ELocated e' _) op z = mkEInfix e' op z @@ -921,9 +1323,9 @@ patternEnv = go where go (PVar Located { .. }) = - do n <- liftSupply (mkParameter NSValue (getIdent thing) srcRange) + do n <- liftSupply (mkLocal NSValue (getIdent thing) srcRange) -- XXX: for deps, we should record a use - return (singletonE thing n) + return (singletonNS NSValue thing n) go PWild = return mempty go (PTuple ps) = bindVars ps @@ -961,23 +1363,23 @@ -- of the type of the pattern. | null ps -> do loc <- curLoc - n <- liftSupply (mkParameter NSType (getIdent pn) loc) - return (singletonT pn n) + n <- liftSupply (mkLocal NSType (getIdent pn) loc) + return (singletonNS NSType pn n) -- This references a type synonym that's not in scope. Record an -- error and continue with a made up name. | otherwise -> do loc <- curLoc - record (UnboundName NSType (Located loc pn)) - n <- liftSupply (mkParameter NSType (getIdent pn) loc) - return (singletonT pn n) + recordError (UnboundName NSType (Located loc pn)) + n <- liftSupply (mkLocal NSType (getIdent pn) loc) + return (singletonNS NSType pn n) typeEnv (TRecord fs) = bindTypes (map snd (recordElements fs)) typeEnv (TTyApp fs) = bindTypes (map value fs) typeEnv (TTuple ts) = bindTypes ts typeEnv TWild = return mempty typeEnv (TLocated ty loc) = withLoc loc (typeEnv ty) - typeEnv (TParens ty) = typeEnv ty + typeEnv (TParens ty _) = typeEnv ty typeEnv (TInfix a _ _ b) = bindTypes [a,b] bindTypes [] = return mempty @@ -1005,3 +1407,20 @@ shadowNames ps do n' <- rnLocated (renameType NameBind) n PropSyn n' <$> pure f <*> traverse rename ps <*> traverse rename cs + +-------------------------------------------------------------------------------- + +instance PP RenamedModule where + ppPrec _ rn = updPPCfg (\cfg -> cfg { ppcfgShowNameUniques = True }) doc + where + doc = + vcat [ "// --- Defines -----------------------------" + , pp (rmDefines rn) + , "// --- In scope ----------------------------" + , pp (rmInScope rn) + , "// -- Module -------------------------------" + , pp (rmModule rn) + , "// -----------------------------------------" + ] + + diff --git a/src/Cryptol/ModuleSystem/Renamer/Error.hs b/src/Cryptol/ModuleSystem/Renamer/Error.hs --- a/src/Cryptol/ModuleSystem/Renamer/Error.hs +++ b/src/Cryptol/ModuleSystem/Renamer/Error.hs @@ -10,11 +10,14 @@ {-# Language OverloadedStrings #-} module Cryptol.ModuleSystem.Renamer.Error where +import Data.List(intersperse) + import Cryptol.ModuleSystem.Name import Cryptol.Parser.AST import Cryptol.Parser.Position import Cryptol.Parser.Selector(ppNestedSels) import Cryptol.Utils.PP +import Cryptol.Utils.Ident(modPathSplit) import GHC.Generics (Generic) import Control.DeepSeq @@ -41,35 +44,65 @@ | FixityError (Located Name) Fixity (Located Name) Fixity -- ^ When the fixity of two operators conflict - | InvalidConstraint (Type PName) - -- ^ When it's not possible to produce a Prop from a Type. - - | MalformedBuiltin (Type PName) PName - -- ^ When a builtin type/type-function is used incorrectly. - - | BoundReservedType PName (Maybe Range) Doc - -- ^ When a builtin type is named in a binder. - | OverlappingRecordUpdate (Located [Selector]) (Located [Selector]) -- ^ When record updates overlap (e.g., @{ r | x = e1, x.y = e2 }@) | InvalidDependency [DepName] - deriving (Show, Generic, NFData) + -- ^ Things that can't depend on each other + | MultipleModParams Ident [Range] + -- ^ Module parameters with the same name --- We use this because parameter constrstaints have no names + | InvalidFunctorImport (ImpName Name) + -- ^ Can't import functors directly + + | UnexpectedNest Range PName + -- ^ Nested modules were not supposed to appear here + + | ModuleKindMismatch Range (ImpName Name) ModKind ModKind + -- ^ Exepcted one kind (first one) but found the other (second one) + + deriving (Show, Generic, NFData, Eq, Ord) + + +{- | We use this to name dependencies. +In addition to normal names we have a way to refer to module parameters +and top-level module constraints, which have no explicit names -} data DepName = NamedThing Name - | ConstratintAt Range -- ^ identifed by location in source + -- ^ Something with a name + + | ModPath ModPath + -- ^ The module at this path + + | ModParamName Range Ident + {- ^ Note that the range is important not just for error + reporting but to distinguish module parameters with + the same name (e.g., in nested functors) -} + | ConstratintAt Range + -- ^ Identifed by location in source deriving (Eq,Ord,Show,Generic,NFData) -depNameLoc :: DepName -> Range +depNameLoc :: DepName -> Maybe Range depNameLoc x = case x of - NamedThing n -> nameLoc n - ConstratintAt r -> r - + NamedThing n -> Just (nameLoc n) + ConstratintAt r -> Just r + ModParamName r _ -> Just r + ModPath {} -> Nothing +data ModKind = AFunctor | ASignature | AModule + deriving (Show, Generic, NFData, Eq, Ord) + +instance PP ModKind where + ppPrec _ e = + case e of + AFunctor -> "a functor" + ASignature -> "an interface" + AModule -> "a module" + + + instance PP RenamerError where ppPrec _ e = case e of @@ -119,19 +152,6 @@ , text "are not compatible." , text "You may use explicit parentheses to disambiguate." ]) - InvalidConstraint ty -> - hang (hsep $ [text "[error]"] ++ maybe [] (\r -> [text "at" <+> pp r]) (getLoc ty)) - 4 (fsep [ pp ty, text "is not a valid constraint" ]) - - MalformedBuiltin ty pn -> - hang (hsep $ [text "[error]"] ++ maybe [] (\r -> [text "at" <+> pp r]) (getLoc ty)) - 4 (fsep [ text "invalid use of built-in type", pp pn - , text "in type", pp ty ]) - - BoundReservedType n loc src -> - hang (hsep $ [text "[error]"] ++ maybe [] (\r -> [text "at" <+> pp r]) loc) - 4 (fsep [ text "built-in type", quotes (pp n), text "shadowed in", src ]) - OverlappingRecordUpdate xs ys -> hang "[error] Overlapping record updates:" 4 (vcat [ ppLab xs, ppLab ys ]) @@ -140,10 +160,32 @@ InvalidDependency ds -> hang "[error] Invalid recursive dependency:" - 4 (vcat [ "•" <+> pp x <.> ", defined at" <+> ppR (depNameLoc x) + 4 (vcat [ "•" <+> pp x <.> + case depNameLoc x of + Just r -> ", defined at" <+> ppR r + Nothing -> mempty | x <- ds ]) where ppR r = pp (from r) <.> "--" <.> pp (to r) + MultipleModParams x rs -> + hang ("[error] Multiple parameters with name" <+> backticks (pp x)) + 4 (vcat [ "•" <+> pp r | r <- rs ]) + + InvalidFunctorImport x -> + hang ("[error] Invalid import of functor" <+> backticks (pp x)) + 4 "• Functors need to be instantiated before they can be imported." + + UnexpectedNest s x -> + hang ("[error] at" <+> pp s) + 4 ("submodule" <+> backticks (pp x) <+> "may not be defined here.") + + ModuleKindMismatch r x expected actual -> + hang ("[error] at" <+> pp r) + 4 (vcat [ "• Expected" <+> pp expected + , "•" <+> backticks (pp x) <+> "is" <+> pp actual + ]) + + instance PP DepName where ppPrec _ d = case d of @@ -153,6 +195,11 @@ NSModule -> "submodule" <+> pp n NSType -> "type" <+> pp n NSValue -> pp n + ModParamName _r i -> "module parameter" <+> pp i + ModPath mp -> + case modPathSplit mp of + (m,[]) -> "module" <+> pp m + (_,is) -> "submodule" <+> hcat (intersperse "::" (map pp is)) @@ -161,27 +208,29 @@ data RenamerWarning = SymbolShadowed PName Name [Name] | UnusedName Name + | PrefixAssocChanged PrefixOp (Expr Name) (Located Name) Fixity (Expr Name) deriving (Show, Generic, NFData) instance Eq RenamerWarning where x == y = compare x y == EQ --- used to determine in what order ot show things +-- used to determine in what order to show things instance Ord RenamerWarning where compare w1 w2 = - case w1 of - SymbolShadowed x y _ -> - case w2 of - SymbolShadowed x' y' _ -> compare (byStart y,x) (byStart y',x') - _ -> LT - UnusedName x -> - case w2 of - UnusedName y -> compare (byStart x) (byStart y) - _ -> GT + case (w1, w2) of + (SymbolShadowed x y _, SymbolShadowed x' y' _) -> + compare (byStart y, x) (byStart y', x') + (UnusedName x, UnusedName x') -> + compare (byStart x) (byStart x') + (PrefixAssocChanged _ _ op _ _, PrefixAssocChanged _ _ op' _ _) -> + compare (from $ srcRange op) (from $ srcRange op') + _ -> compare (priority w1) (priority w2) where byStart = from . nameLoc - + priority SymbolShadowed {} = 0 :: Int + priority UnusedName {} = 1 + priority PrefixAssocChanged {} = 2 instance PP RenamerWarning where ppPrec _ (SymbolShadowed k x os) = @@ -201,5 +250,12 @@ hang (text "[warning] at" <+> pp (nameLoc x)) 4 (text "Unused name:" <+> pp x) - + ppPrec _ (PrefixAssocChanged prefixOp x infixOp infixFixity y) = + hang (text "[warning] at" <+> pp (srcRange infixOp)) + 4 $ fsep [ backticks (pp old) + , "is now parsed as" + , backticks (pp new) ] + where + old = EInfix (EPrefix prefixOp x) infixOp infixFixity y + new = EPrefix prefixOp (EInfix x infixOp infixFixity y) diff --git a/src/Cryptol/ModuleSystem/Renamer/ImplicitImports.hs b/src/Cryptol/ModuleSystem/Renamer/ImplicitImports.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/ModuleSystem/Renamer/ImplicitImports.hs @@ -0,0 +1,114 @@ +{- | +We add implicit imports are for public nested modules. This allows +using definitions from nested modules without having to explicitly import +them, for example: + +module A where + + submodule B where + x = 0x20 + + y = x // This works because of the implicit import of `B` + +Restriction: +============ + +We only add impicit imports of modules that are syntactically visiable +in the source code. Consider the following example: + +module A where + submodule M = F {X} -- F,X are external modules (e.g., top-level) + +We will add an implicit import for `M`, but *NO* implicit imports for +any modules imported vial `M` as those are not sytnactically visible +in the source (i.e., we have to know what `F` refers to). + +This restriction allows us to add implicit imports before doing the +`Imports` pass. +-} + +module Cryptol.ModuleSystem.Renamer.ImplicitImports + ( addImplicitNestedImports + ) where + +import Data.List(partition) + +import Cryptol.Parser.Position(Range) +import Cryptol.Utils.Ident(packModName) +import Cryptol.Parser.AST + +{- | Add additional imports for modules nested withing this one -} +addImplicitNestedImports :: [TopDecl PName] -> [TopDecl PName] +addImplicitNestedImports = snd . addImplicitNestedImports' + +{- | Returns: + + * declarations with additional imports and + * the public module names of this module and its children. +-} +addImplicitNestedImports' :: + [TopDecl PName] -> ([[Ident]], [TopDecl PName]) +addImplicitNestedImports' decls = + (concat exportedMods, concat newDecls ++ other) + where + (mods,other) = partition isNestedMod decls + (newDecls,exportedMods) = unzip (map processModule mods) + + +processModule :: TopDecl PName -> ([TopDecl PName], [[Ident]]) +processModule ~dcl@(DModule m) = + let NestedModule m1 = tlValue m + in + case mDef m1 of + NormalModule ds -> + let (childExs, ds1) = addImplicitNestedImports' ds + mname = getIdent (thing (mName m1)) + imps = map (mname :) ([] : childExs) -- this & nested + loc = srcRange (mName m1) + in ( DModule m { tlValue = NestedModule m1 { mDef = NormalModule ds1 } } + : map (mkImp loc) imps + , case tlExport m of + Public -> imps + Private -> [] + ) + + FunctorInstance {} -> ([dcl], []) + InterfaceModule {} -> ([dcl], []) + + + + +isNestedMod :: TopDecl name -> Bool +isNestedMod d = + case d of + DModule tl -> case tlValue tl of + NestedModule m -> not (mIsFunctor m) + _ -> False + +-- | Make a name qualifier out of a list of identifiers. +isToQual :: [Ident] -> ModName +isToQual is = packModName (map identText is) + +-- | Make a module name out of a list of identifier. +-- This is the name of the module we are implicitly importing. +isToName :: [Ident] -> PName +isToName is = case is of + [i] -> mkUnqual i + _ -> mkQual (isToQual (init is)) (last is) + +-- | Make an implicit import declaration. +mkImp :: Range -> [Ident] -> TopDecl PName +mkImp loc xs = + DImport + Located + { srcRange = loc + , thing = Import + { iModule = ImpNested (isToName xs) + , iAs = Just (isToQual xs) + , iSpec = Nothing + , iInst = Nothing + } + } + + + diff --git a/src/Cryptol/ModuleSystem/Renamer/Imports.hs b/src/Cryptol/ModuleSystem/Renamer/Imports.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/ModuleSystem/Renamer/Imports.hs @@ -0,0 +1,576 @@ +{- | + +This module deals with imports of nested modules (@import submodule@). +This is more complex than it might seem at first because to resolve a +declaration like @import submodule X@ we need to resolve what @X@ +referes to before we know what it will import. + +Even triciker is the case for functor instantiations: + + module M = F { X } + import M + +In this case, even if we know what `M` referes to, we first need to +resolve `F`, so that we can generate the instantiation and generate +fresh names for names defined by `M`. + +If we want to support applicative semantics, then before instantiation +`M` we also need to resolve `X` so that we know if this instantiation has +already been generated. + +An overall guiding principle of the design is that we assume that declarations +can be ordered in dependency order, and submodules can be processed one +at a time. In particular, this does not allow recursion across modules, +or functor instantiations depending on their arguments. + +Thus, the following is OK: + +module A where + x = 0x2 + + submodule B where + y = x + + z = B::y + + +However, this is not OK: + + submodule A = F X + submodule F where + import A +-} + +{-# Language BlockArguments #-} +{-# Language TypeSynonymInstances, FlexibleInstances #-} +module Cryptol.ModuleSystem.Renamer.Imports + ( resolveImports + , ResolvedModule(..) + , ModKind(..) + , ResolvedLocal + , ResolvedExt + ) + where + +import Data.Maybe(fromMaybe) +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.List(foldl') +import Control.Monad(when) +import qualified MonadLib as M + +import Cryptol.Utils.PP(pp) +import Cryptol.Utils.Panic(panic) +import Cryptol.Utils.Ident(ModName,ModPath(..),Namespace(..),OrigName(..)) + +import Cryptol.Parser.AST + ( ImportG(..),PName, ModuleInstanceArgs(..), ImpName(..) ) +import Cryptol.ModuleSystem.Binds (Mod(..), TopDef(..), modNested, ModKind(..)) +import Cryptol.ModuleSystem.Name + ( Name, Supply, SupplyT, runSupplyT, liftSupply, freshNameFor + , asOrigName, nameIdent, nameTopModule ) +import Cryptol.ModuleSystem.Names(Names(..)) +import Cryptol.ModuleSystem.NamingEnv + ( NamingEnv(..), lookupNS, shadowing, travNamingEnv + , interpImportEnv, zipByTextName, filterUNames ) + + +{- | This represents a resolved module or signaure. +The type parameter helps us distinguish between two types of resolved modules: + + 1. Resolved modules that are *inputs* to the algorithm (i.e., they are + defined outside the current module). For such modules the type + parameter is @imps@ is () + + 2. Resolved modules that are *outputs* of the algorithm (i.e., they + are defined within the current module). For such modules the type + parameter @imps@ contains the naming environment for things + that came in through the import. + +Note that signaures are never "imported", however we do need to keep them +here so that signatures in a functor are properly instantiated when +the functor is instantiated. +-} +data ResolvedModule imps = ResolvedModule + { rmodDefines :: NamingEnv -- ^ Things defined by the module/signature. + , rmodPublic :: !(Set Name) -- ^ Exported names + , rmodKind :: ModKind -- ^ What sort of thing are we + , rmodNested :: Set Name -- ^ Modules and signatures nested in this one + , rmodImports :: imps + {- ^ Resolved imports. External modules need not specify this field, + it is just part of the thing we compute for local modules. -} + } + + +-- | A resolved module that's defined in (or is) the current top-level module +type ResolvedLocal = ResolvedModule NamingEnv + +-- | A resolved module that's not defined in the current top-level module +type ResolvedExt = ResolvedModule () + + +resolveImports :: + (ImpName Name -> Mod ()) -> + TopDef -> + Supply -> + (Map (ImpName Name) ResolvedLocal, Supply) +resolveImports ext def su = + case def of + + TopMod m mo -> + do let cur = todoModule mo + newS = doModuleStep CurState + { curMod = cur + , curTop = m + , externalModules = ext + , doneModules = mempty + , nameSupply = su + , changes = False + } + + + case tryFinishCurMod cur newS of + Just r -> add m r newS + Nothing -> add m r s1 + where (r,s1) = forceFinish newS + + TopInst m f as -> + do let s = CurState + { curMod = () + , curTop = m + , externalModules = ext + , doneModules = mempty + , nameSupply = su + , changes = False + } + + case tryInstanceMaybe s (ImpTop m) (f,as) of + Just (r,newS) -> add m r newS + Nothing -> (Map.singleton (ImpTop m) forceResolveInst, su) + + where + toNest m = Map.fromList [ (ImpNested k, v) | (k,v) <- Map.toList m ] + add m r s = ( Map.insert (ImpTop m) r (toNest (doneModules s)) + , nameSupply s + ) + + + + +-------------------------------------------------------------------------------- + + +-- | This keeps track of the current state of resolution of a module. +type Todo = Mod ModState + +data ModState = ModState + { modOuter :: NamingEnv + -- ^ Things which come in scope from outer modules + + , modImported :: NamingEnv + -- ^ Things which come in scope via imports. These shadow outer names. + } + + +-- | Initial state of a module that needs processing. +todoModule :: Mod () -> Todo +todoModule = fmap (const emptyModState) + where + emptyModState = + ModState + { modOuter = mempty + , modImported = mempty + } + +{- | A module is fully processed when we are done with all its: + + * submodule imports + * instantiations + * nested things (signatures and modules) +-} +isDone :: Todo -> Bool +isDone m = null (modImports m) && + Map.null (modInstances m) && + Map.null (modMods m) + + +-- | Finish up all unfinished modules as best as we can +forceFinish :: CurState -> (ResolvedLocal,CurState) +forceFinish s0 = + let this = curMod s0 + add k v s = s { doneModules = Map.insert k v (doneModules s) } + s1 = foldl' (\s k -> add k forceResolveInst s) s0 + (Map.keys (modInstances this)) + + doNestMod s (k,m) = + let (r,s') = forceFinish s { curMod = m } + in add k r s' + + in ( forceResolveMod this + , foldl' doNestMod s1 (Map.toList (modMods this)) + ) + + +-- | A place-holder entry for instnatitations we couldn't resolve. +forceResolveInst :: ResolvedLocal +forceResolveInst = + ResolvedModule + { rmodDefines = mempty + , rmodPublic = mempty + , rmodKind = AModule + , rmodNested = Set.empty + , rmodImports = mempty + } + +-- | Finish up unresolved modules as well as we can, in situations where +-- the program contains an error. +forceResolveMod :: Todo -> ResolvedLocal +forceResolveMod todo = + ResolvedModule + { rmodDefines = modDefines todo + , rmodPublic = modPublic todo + , rmodKind = modKind todo + , rmodNested = Map.keysSet (modMods todo) + , rmodImports = modImported (modState todo) + } + + + + + +pushImport :: ImportG (ImpName PName) -> Todo -> Todo +pushImport i m = m { modImports = i : modImports m } + +pushInst :: Name -> (ImpName PName, ModuleInstanceArgs PName) -> Todo -> Todo +pushInst k v m = m { modInstances = Map.insert k v (modInstances m) } + +pushMod :: Name -> Todo -> Todo -> Todo +pushMod k v m = m { modMods = Map.insert k v (modMods m) } + +updMS :: (ModState -> ModState) -> Todo -> Todo +updMS f m = m { modState = f (modState m) } +-------------------------------------------------------------------------------- + + + +externalMod :: Mod () -> ResolvedExt +externalMod m = ResolvedModule + { rmodDefines = modDefines m + , rmodPublic = modPublic m + , rmodKind = modKind m + , rmodNested = modNested m + , rmodImports = () + } + +{- | This is used when we need to use a local resolved module as an input + to another module. -} +forget :: ResolvedLocal -> ResolvedExt +forget r = r { rmodImports = () } + +type CurState = CurState' Todo + +data CurState' a = CurState + { curMod :: a + -- ^ This is what needs to be done + + , curTop :: !ModName + {- ^ The top-level module we are working on. This does not change + throught the algorithm, it is just convenient to pass it here with + all the other stuff. -} + + , externalModules :: ImpName Name -> Mod () + -- ^ Modules defined outside the current top-level modules + + , doneModules :: Map Name ResolvedLocal + {- ^ Nested modules/signatures in the current top-level modules. + These may be either defined locally, or be the result of + instantiating a functor. Note that the functor itself may be + either local or external. + -} + + , nameSupply :: Supply + -- ^ Use this to instantiate functors + + , changes :: Bool + -- ^ True if something changed on the last iteration + } + +updCur :: CurState -> (Todo -> Todo) -> CurState +updCur m f = m { curMod = f (curMod m) } + +updCurMS :: CurState -> (ModState -> ModState) -> CurState +updCurMS s f = updCur s (updMS f) + +class HasCurScope a where + curScope :: CurState' a -> NamingEnv + +instance HasCurScope () where + curScope _ = mempty + +instance HasCurScope Todo where + curScope s = modDefines m `shadowing` modImported ms `shadowing` modOuter ms + where + m = curMod s + ms = modState m + + +-- | Keep applying a transformation while things are changing +doStep :: (CurState -> CurState) -> (CurState -> CurState) +doStep f s0 = go (changes s0) s0 + where + go ch s = let s1 = f s { changes = False } + in if changes s1 + then go True s1 + else s { changes = ch } + +-- | Is this a known name for a module in the current scope? +knownPName :: HasCurScope a => CurState' a -> PName -> Maybe Name +knownPName s x = + do ns <- lookupNS NSModule x (curScope s) + case ns of + One n -> pure n + {- NOTE: since we build up what's in scope incrementally, + it is possible that this would eventually be ambiguous, + which we'll detect during actual renaming. -} + + Ambig {} -> Nothing + {- We treat ambiguous imports as undefined, which may lead to + spurious "undefined X" errors. To avoid this we should prioritize + reporting "ambiguous X" errors. -} + +-- | Is the module mentioned in this import known in the current scope? +knownImpName :: + HasCurScope a => CurState' a -> ImpName PName -> Maybe (ImpName Name) +knownImpName s i = + case i of + ImpTop m -> pure (ImpTop m) + ImpNested m -> ImpNested <$> knownPName s m + +-- | Is the module mentioned in the import already resolved? +knownModule :: + HasCurScope a => CurState' a -> ImpName Name -> Maybe ResolvedExt +knownModule s x + | root == curTop s = + case x of + ImpNested y -> forget <$> Map.lookup y (doneModules s) + ImpTop {} -> Nothing -- or panic? recursive import + + | otherwise = Just (externalMod (externalModules s x)) + + where + root = case x of + ImpTop r -> r + ImpNested n -> nameTopModule n + +-------------------------------------------------------------------------------- + + +{- | Try to resolve an import. If the imported module can be resolved, +and it refers to a module that's already been resolved, then we do the +import and extend the current scoping environment. Otherwise, we just +queue the import back on the @modImports@ of the current module to be tried +again later.-} +tryImport :: CurState -> ImportG (ImpName PName) -> CurState +tryImport s imp = + fromMaybe (updCur s (pushImport imp)) -- not ready, put it back on the q + do let srcName = iModule imp + mname <- knownImpName s srcName + ext <- knownModule s mname + + let isPub x = x `Set.member` rmodPublic ext + new = case rmodKind ext of + AModule -> interpImportEnv imp + (filterUNames isPub (rmodDefines ext)) + AFunctor -> mempty + ASignature -> mempty + + pure $ updCurMS s { changes = True } + \ms -> ms { modImported = new <> modImported ms } + +-- | Resolve all imports in the current modules +doImportStep :: CurState -> CurState +doImportStep s = foldl' tryImport s1 (modImports (curMod s)) + where + s1 = updCur s \m -> m { modImports = [] } + + +{- | Try to instantiate a functor. This succeeds if we can resolve the functor +and the arguments and the both refer to already resolved names. +Note: at the moment we ignore the arguments, but we'd have to do that in +order to implment applicative behavior with caching. -} +tryInstanceMaybe :: + HasCurScope a => + CurState' a -> + ImpName Name -> + (ImpName PName, ModuleInstanceArgs PName) + {- ^ Functor and arguments -} -> + Maybe (ResolvedLocal,CurState' a) +tryInstanceMaybe s mn (f,_xs) = + do fn <- knownImpName s f + let path = case mn of + ImpTop m -> TopModule m + ImpNested m -> + case asOrigName m of + Just og -> Nested (ogModule og) (ogName og) + Nothing -> + panic "tryInstanceMaybe" [ "Not a top-level name" ] + doInstantiateByName False path fn s + +{- | Try to instantiate a functor. If successful, then the newly instantiated +module (and all things nested in it) are going to be added to the +@doneModules@ field. Otherwise, we queue up the instantiatation in +@curMod@ for later processing -} +tryInstance :: + CurState -> + Name -> + (ImpName PName, ModuleInstanceArgs PName) -> + CurState +tryInstance s mn (f,xs) = + case tryInstanceMaybe s (ImpNested mn) (f,xs) of + Nothing -> updCur s (pushInst mn (f,xs)) + Just (def,s1) -> s1 { changes = True + , doneModules = Map.insert mn def (doneModules s1) + } + +{- | Generate a fresh instance for the functor with the given name. -} +doInstantiateByName :: + HasCurScope a => + Bool + {- ^ This indicates if the result is a functor or not. When instantiating + a functor applied to some arguments the result is not a functor. However, + if we are instantiating a functor nested within some functor that's being + instantiated, then the result is still a functor. -} -> + ModPath {- ^ Path for instantiated names -} -> + ImpName Name {- ^ Name of the functor/module being instantiated -} -> + CurState' a -> Maybe (ResolvedLocal,CurState' a) + +doInstantiateByName keepArgs mpath fname s = + do def <- knownModule s fname + pure (doInstantiate keepArgs mpath def s) + + + +{- | Generate a new instantiation of the given module/signature. +Note that the module might not be a functor itself (e.g., if we are +instantiating something nested in a functor -} +doInstantiate :: + HasCurScope a => + Bool {- ^ See `doInstantiateByName` -} -> + ModPath {- ^ Path for instantiated names -} -> + ResolvedExt {- ^ The thing being instantiated -} -> + CurState' a -> (ResolvedLocal,CurState' a) +doInstantiate keepArgs mpath def s = (newDef, Set.foldl' doSub newS nestedToDo) + where + ((newEnv,newNameSupply),nestedToDo) = + M.runId + $ M.runStateT Set.empty + $ runSupplyT (nameSupply s) + $ travNamingEnv instName + $ rmodDefines def + + newS = s { nameSupply = newNameSupply } + + pub = let inst = zipByTextName (rmodDefines def) newEnv + in Set.fromList [ case Map.lookup og inst of + Just newN -> newN + Nothing -> panic "doInstantiate.pub" + [ "Lost a name", show og ] + | og <- Set.toList (rmodPublic def) + ] + + + newDef = ResolvedModule { rmodDefines = newEnv + , rmodPublic = pub + , rmodKind = case rmodKind def of + AFunctor -> + if keepArgs then AFunctor + else AModule + ASignature -> ASignature + AModule -> AModule + + , rmodNested = Set.map snd nestedToDo + , rmodImports = mempty + {- we don't do name resolution on the instantiation + the usual way: instead the functor and the + arguments are renamed separately, then we + we do a pass where we replace: + defined names of functor by instantiations + parameter by actual names in arguments. + -} + } + + doSub st (oldSubName,newSubName) = + case doInstantiateByName True (Nested mpath (nameIdent newSubName)) + (ImpNested oldSubName) st of + Just (idef,st1) -> st1 { doneModules = Map.insert newSubName idef + (doneModules st1) } + Nothing -> panic "doInstantiate.doSub" + [ "Missing nested module:", show (pp oldSubName) ] + + instName :: Name -> SupplyT (M.StateT (Set (Name,Name)) M.Id) Name + instName x = + do y <- liftSupply (freshNameFor mpath x) + when (x `Set.member` rmodNested def) + (M.lift (M.sets_ (Set.insert (x,y)))) + pure y + + +-- | Try to make progress on all instantiations. +doInstancesStep :: CurState -> CurState +doInstancesStep s = Map.foldlWithKey' tryInstance s0 (modInstances (curMod s)) + where + s0 = updCur s \m' -> m' { modInstances = Map.empty } + +tryFinishCurMod :: Todo -> CurState -> Maybe ResolvedLocal +tryFinishCurMod m newS + | isDone newM = + Just ResolvedModule + { rmodDefines = modDefines m + , rmodPublic = modPublic m + , rmodKind = modKind m + , rmodNested = Set.unions + [ Map.keysSet (modInstances m) + , Map.keysSet (modMods m) + ] + , rmodImports = modImported (modState newM) + } + + | otherwise = Nothing + where newM = curMod newS + + +-- | Try to resolve the "normal" module with the given name. +tryModule :: CurState -> Name -> Todo -> CurState +tryModule s nm m = + case tryFinishCurMod m newS of + Just rMod -> + newS { curMod = curMod s + , doneModules = Map.insert nm rMod (doneModules newS) + , changes = True + } + Nothing -> newS { curMod = pushMod nm newM (curMod s) } + where + s1 = updCur s \_ -> updMS (\ms -> ms { modOuter = curScope s }) m + newS = doModuleStep s1 + newM = curMod newS + +-- | Process all submodules of a module. +doModulesStep :: CurState -> CurState +doModulesStep s = Map.foldlWithKey' tryModule s0 (modMods m) + where + m = curMod s + s0 = s { curMod = m { modMods = mempty } } + + + +-- | All steps involved in processing a module. +doModuleStep :: CurState -> CurState +doModuleStep = doStep step + where + step = doStep doModulesStep + . doStep doInstancesStep + . doStep doImportStep + + diff --git a/src/Cryptol/ModuleSystem/Renamer/Monad.hs b/src/Cryptol/ModuleSystem/Renamer/Monad.hs --- a/src/Cryptol/ModuleSystem/Renamer/Monad.hs +++ b/src/Cryptol/ModuleSystem/Renamer/Monad.hs @@ -9,30 +9,34 @@ {-# Language RecordWildCards #-} {-# Language FlexibleContexts #-} {-# Language BlockArguments #-} +{-# Language OverloadedStrings #-} module Cryptol.ModuleSystem.Renamer.Monad where -import Data.List(sort) +import Data.List(sort,foldl') import Data.Set(Set) import qualified Data.Set as Set -import qualified Data.Foldable as F import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map -import qualified Data.Sequence as Seq import qualified Data.Semigroup as S import MonadLib hiding (mapM, mapM_) import Prelude () import Prelude.Compat +import Cryptol.Utils.PP(pp) +import Cryptol.Utils.Panic(panic) +import Cryptol.Utils.Ident(modPathCommon,OrigName(..),OrigSource(..)) import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.NamingEnv +import Cryptol.ModuleSystem.Binds import Cryptol.ModuleSystem.Interface import Cryptol.Parser.AST +import Cryptol.TypeCheck.AST(ModParamNames) import Cryptol.Parser.Position -import Cryptol.Utils.Panic (panic) -import Cryptol.Utils.Ident(modPathCommon) 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 @@ -42,22 +46,41 @@ { renSupply :: Supply -- ^ Use to make new names , renContext :: ModPath -- ^ We are renaming things in here , renEnv :: NamingEnv -- ^ This is what's in scope - , renIfaces :: ModName -> Iface + , renIfaces :: Map ModName (Either ModParamNames Iface) + -- ^ External modules } newtype RenameM a = RenameM { unRenameM :: ReaderT RO (StateT RW Lift) a } data RO = RO - { roLoc :: Range - , roNames :: NamingEnv - , roIfaces :: ModName -> Iface - , roCurMod :: ModPath -- ^ Current module we are working on + { 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 :: !(Seq.Seq RenamerError) + , rwErrors :: !(Set RenamerError) , rwSupply :: !Supply , rwNameUseCount :: !(Map Name Int) -- ^ How many times did we refer to each name. @@ -72,11 +95,24 @@ -- see 'depsOf' , rwExternalDeps :: !IfaceDecls - -- ^ Info about imported things + -- ^ 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 = @@ -125,7 +161,7 @@ warns = sort (rwWarnings rw ++ warnUnused (renContext info) (renEnv info) rw) (a,rw) = runM (unRenameM m) ro - RW { rwErrors = Seq.empty + RW { rwErrors = Set.empty , rwWarnings = [] , rwSupply = renSupply info , rwNameUseCount = Map.empty @@ -136,15 +172,24 @@ ro = RO { roLoc = emptyRange , roNames = renEnv info - , roIfaces = renIfaces info + , roExternal = Map.mapWithKey toModMap (renIfaces info) , roCurMod = renContext info , roNestedMods = Map.empty + , roResolvedModules = mempty + , roModParams = mempty + , roFromModParam = mempty } - res | Seq.null (rwErrors rw) = Right (a,rwSupply rw) - | otherwise = Left (F.toList (rwErrors rw)) + res | Set.null (rwErrors rw) = Right (a,rwSupply rw) + | otherwise = Left (Set.toList (rwErrors rw)) + toModMap t ent = + case ent of + Left ps -> (Nothing, Map.singleton (ImpTop t) (ifaceSigToMod ps)) + Right i -> (Just i, modToMap (ImpTop t) (ifaceToMod i) mempty) + + setCurMod :: ModPath -> RenameM a -> RenameM a setCurMod mpath (RenameM m) = RenameM $ mapReader (\ro -> ro { roCurMod = mpath }) m @@ -155,7 +200,57 @@ getNamingEnv :: RenameM NamingEnv getNamingEnv = RenameM (asks roNames) +setResolvedLocals :: Map (ImpName Name) ResolvedLocal -> RenameM a -> RenameM a +setResolvedLocals mp (RenameM m) = + RenameM $ mapReader (\ro -> ro { roResolvedModules = mp }) m +lookupResolved :: ImpName Name -> RenameM ResolvedLocal +lookupResolved nm = + do mp <- RenameM (roResolvedModules <$> ask) + pure case Map.lookup nm mp of + Just r -> r + + -- XXX: could this happen because we couldn't resolve a module? + Nothing -> panic "lookupResolved" + [ "Missing module: " ++ show nm ] + +setModParams :: [RenModParam] -> RenameM a -> RenameM a +setModParams ps (RenameM m) = + do let pmap = Map.fromList [ (renModParamName p, p) | p <- ps ] + + newFrom = + foldLoop ps mempty \p mp -> + let nm = ModParamName (renModParamRange p) (renModParamName p) + in foldLoop (Map.keys (renModParamInstance p)) mp \x -> + Map.insert x nm + + upd ro = ro { roModParams = pmap + , roFromModParam = newFrom <> roFromModParam ro + } + + RenameM (mapReader upd m) + + +foldLoop :: [a] -> b -> (a -> b -> b) -> b +foldLoop xs b f = foldl' (flip f) b xs + +getModParam :: Ident -> RenameM RenModParam +getModParam p = + do ps <- RenameM (roModParams <$> ask) + case Map.lookup p ps of + Just r -> pure r + Nothing -> panic "getModParam" [ "Missing module paramter", show p ] + +getNamesFromModParams :: RenameM (Map Name DepName) +getNamesFromModParams = RenameM (roFromModParam <$> ask) + +getLocalModParamDeps :: RenameM (Map Ident DepName) +getLocalModParamDeps = + do ps <- RenameM (roModParams <$> ask) + let toName mp = ModParamName (renModParamRange mp) (renModParamName mp) + pure (toName <$> ps) + + setNestedModule :: Map ModPath Name -> RenameM a -> RenameM a setNestedModule mp (RenameM m) = RenameM $ mapReader (\ro -> ro { roNestedMods = mp }) m @@ -164,12 +259,16 @@ nestedModuleOrig x = RenameM (asks (Map.lookup x . roNestedMods)) --- | Record an error. XXX: use a better name -record :: RenamerError -> RenameM () -record f = RenameM $ +-- | Record an error. +recordError :: RenamerError -> RenameM () +recordError f = RenameM $ do RW { .. } <- get - set RW { rwErrors = rwErrors Seq.|> f, .. } + 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 @@ -191,7 +290,7 @@ pure a -- | This is used when renaming a group of things. The result contains --- dependencies between names defines and the group, and is intended to +-- 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 @@ -230,58 +329,39 @@ | CheckNone -- ^ Don't check the environment deriving (Eq,Show) +-- | Report errors if the given naming environemnt contains multiple +-- definitions for the same symbol +checkOverlap :: NamingEnv -> RenameM NamingEnv +checkOverlap env = + case findAmbig env of + [] -> pure env + ambig -> do mapM_ recordError [ OverlappingSyms xs | xs <- ambig ] + pure (forceUnambig env) + +-- | Issue warnings if entries in the first environment would +-- shadow something in the second. +checkShadowing :: NamingEnv -> NamingEnv -> RenameM () +checkShadowing envNew envOld = + mapM_ recordWarning + [ SymbolShadowed p x xs | (p,x,xs) <- findShadowing envNew envOld ] + + -- | Shadow the current naming environment with some more names. +-- XXX: The checks are really confusing shadowNames' :: BindsNames env => EnvCheck -> env -> RenameM a -> RenameM a shadowNames' check names m = do - do env <- liftSupply (defsOf names) - RenameM $ + 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 - env' <- sets (checkEnv check env (roNames ro)) - let ro' = ro { roNames = env' `shadowing` roNames ro } + let ro' = ro { roNames = env1 `shadowing` envOld } local ro' (unRenameM m) --- | Generate warnings when the left environment shadows things defined in --- the right. Additionally, generate errors when two names overlap in the --- left environment. -checkEnv :: EnvCheck -> NamingEnv -> NamingEnv -> RW -> (NamingEnv,RW) -checkEnv check (NamingEnv lenv) r rw0 - | check == CheckNone = (newEnv,rw0) - | otherwise = (newEnv,rwFin) - - where - newEnv = NamingEnv newMap - (rwFin,newMap) = Map.mapAccumWithKey doNS rw0 lenv -- lenv 1 ns at a time - doNS rw ns = Map.mapAccumWithKey (step ns) rw - - -- namespace, current state, k : parse name, xs : possible entities for k - step ns acc k xs = (acc', case check of - CheckNone -> xs - _ -> [head xs] - -- we've already reported an overlap error, - -- so resolve arbitrarily to the first entry - ) - where - acc' = acc - { rwWarnings = - if check == CheckAll - then case Map.lookup k (namespaceMap ns r) of - Just os | [x] <- xs - , let os' = filter (/=x) os - , not (null os') -> - SymbolShadowed k x os' : rwWarnings acc - _ -> rwWarnings acc - - else rwWarnings acc - , rwErrors = rwErrors acc Seq.>< containsOverlap xs - } - --- | Check the RHS of a single name rewrite for conflicting sources. -containsOverlap :: [Name] -> Seq.Seq RenamerError -containsOverlap [_] = Seq.empty -containsOverlap [] = panic "Renamer" ["Invalid naming environment"] -containsOverlap ns = Seq.singleton (OverlappingSyms ns) - - recordUse :: Name -> RenameM () recordUse x = RenameM $ sets_ $ \rw -> rw { rwNameUseCount = Map.insertWith (+) x 1 (rwNameUseCount rw) } @@ -306,7 +386,8 @@ addDep x = do cur <- getCurMod deps <- case nameInfo x of - Declared m _ | Just (c,_,i:_) <- modPathCommon cur m -> + 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] @@ -318,25 +399,111 @@ warnUnused :: ModPath -> NamingEnv -> RW -> [RenamerWarning] warnUnused m0 env rw = - map warn + map UnusedName $ Map.keys $ Map.filterWithKey keep $ rwNameUseCount rw where - warn x = UnusedName x 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 - Declared m sys -> sys == UserName && - m == m0 && nm `Set.notMember` oldNames - Parameter -> True + GlobalName sys og -> + sys == UserName && isNestd og && nm `Set.notMember` oldNames + LocalName {} -> True --- | Get the exported declarations in a module -lookupImport :: Import -> RenameM IfaceDecls -lookupImport imp = RenameM $ - do getIf <- roIfaces <$> ask - let ifs = ifPublic (getIf (iModule imp)) - sets_ \s -> s { rwExternalDeps = ifs <> rwExternalDeps s } - pure ifs +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) + ] + ) diff --git a/src/Cryptol/Parser.y b/src/Cryptol/Parser.y --- a/src/Cryptol/Parser.y +++ b/src/Cryptol/Parser.y @@ -38,7 +38,6 @@ import Cryptol.Parser.Token import Cryptol.Parser.ParserUtils import Cryptol.Parser.Unlit(PreProc(..), guessPreProc) -import Cryptol.Utils.Ident(paramInstModName) import Cryptol.Utils.RecordMap(RecordMap) import Paths_cryptol @@ -84,12 +83,14 @@ 'if' { Located $$ (Token (KW KW_if ) _)} 'then' { Located $$ (Token (KW KW_then ) _)} 'else' { Located $$ (Token (KW KW_else ) _)} + 'interface' { Located $$ (Token (KW KW_interface) _)} 'x' { Located $$ (Token (KW KW_x) _)} 'down' { Located $$ (Token (KW KW_down) _)} 'by' { Located $$ (Token (KW KW_by) _)} 'primitive' { Located $$ (Token (KW KW_primitive) _)} 'constraint'{ Located $$ (Token (KW KW_constraint) _)} + 'foreign' { Located $$ (Token (KW KW_foreign) _)} 'Prop' { Located $$ (Token (KW KW_Prop) _)} '[' { Located $$ (Token (Sym BracketL) _)} @@ -140,7 +141,7 @@ DOC { $$@(Located _ (Token (White DocStr) _)) } -%name vmodule vmodule +%name top_module top_module %name program program %name programLayout program_layout %name expr expr @@ -164,44 +165,78 @@ %% -vmodule :: { Module PName } - : 'module' module_def { $2 } - | 'v{' vmod_body 'v}' { mkAnonymousModule $2 } - +top_module :: { [Module PName] } + : 'module' module_def {% mkTopMods $2 } + | 'v{' vmod_body 'v}' {% mkAnonymousModule $2 } + | 'interface' 'module' modName 'where' 'v{' sig_body 'v}' + { mkTopSig $3 $6 } module_def :: { Module PName } : modName 'where' - 'v{' vmod_body 'v}' { mkModule $1 $4 } + 'v{' vmod_body 'v}' { mkModule $1 $4 } - | modName '=' modName 'where' - 'v{' vmod_body 'v}' { mkModuleInstance $1 $3 $6 } + | modName '=' impName 'where' + 'v{' vmod_body 'v}' { mkModuleInstanceAnon $1 $3 $6 } + | modName '=' impName '{' modInstParams '}' { mkModuleInstance $1 $3 $5 } + + +modInstParams :: { ModuleInstanceArgs PName } + : modInstParam { DefaultInstArg $1 } + | namedModInstParams { NamedInstArgs $1 } + +namedModInstParams :: { [ ModuleInstanceNamedArg PName ] } + : namedModInstParam { [$1] } + | namedModInstParams ',' namedModInstParam { $3 : $1 } + +namedModInstParam :: { ModuleInstanceNamedArg PName } + : ident '=' modInstParam { ModuleInstanceNamedArg $1 $3 } + +modInstParam :: { Located (ModuleInstanceArg PName) } + : impName { fmap ModuleArg $1 } + | 'interface' ident { fmap ParameterArg $2 } + | '_' { Located { thing = AddParams + , srcRange = $1 } } + vmod_body :: { [TopDecl PName] } : vtop_decls { reverse $1 } | {- empty -} { [] } --- XXX replace rComb with uses of at + +-- inverted +imports1 :: { [ Located (ImportG (ImpName PName)) ] } + : imports1 'v;' import { $3 : $1 } + | imports1 ';' import { $3 : $1 } + | import { [$1] } + + import :: { Located (ImportG (ImpName PName)) } - : 'import' impName mbAs mbImportSpec - { Located { srcRange = rComb $1 - $ fromMaybe (srcRange $2) - $ msum [ fmap srcRange $4 - , fmap srcRange $3 - ] - , thing = Import - { iModule = thing $2 - , iAs = fmap thing $3 - , iSpec = fmap thing $4 - } - } } + : 'import' impName optInst mbAs mbImportSpec optImportWhere + {% mkImport $1 $2 $3 $4 $5 $6 } + | 'import' impNameBT mbAs mbImportSpec {% mkBacktickImport $1 $2 $3 $4 } +optImportWhere :: { Maybe (Located [Decl PName]) } + : 'where' whereClause { Just $2 } + | {- empty -} { Nothing } + +optInst :: { Maybe (ModuleInstanceArgs PName) } + : '{' modInstParams '}' { Just $2 } + | {- empty -} { Nothing } + + impName :: { Located (ImpName PName) } : 'submodule' qname { ImpNested `fmap` $2 } | modName { ImpTop `fmap` $1 } +impNameBT :: { Located (ImpName PName) } + : 'submodule' '`' qname { ImpNested `fmap` $3 } + | '`' modName { ImpTop `fmap` $2 } + + + mbAs :: { Maybe (Located ModName) } : 'as' modName { Just $2 } | {- empty -} { Nothing } @@ -216,9 +251,9 @@ | {- empty -} { Nothing } name_list :: { [LIdent] } - : name_list ',' ident { $3 : $1 } - | ident { [$1] } - | {- empty -} { [] } + : name_list ',' var { fmap getIdent $3 : $1 } + | var { [fmap getIdent $1] } + | {- empty -} { [] } mbHiding :: { [Ident] -> ImportSpec } : 'hiding' { Hiding } @@ -251,12 +286,40 @@ { [exportDecl $1 Public (mkProperty $3 [] $5)] } | mbDoc newtype { [exportNewtype Public $1 $2] } | prim_bind { $1 } + | foreign_bind { $1 } | private_decls { $1 } - | parameter_decls { $1 } + | mbDoc 'interface' 'constraint' type {% mkInterfaceConstraint $1 $4 } + | parameter_decls { [ $1 ] } | mbDoc 'submodule' module_def {% ((:[]) . exportModule $1) `fmap` mkNested $3 } - | import { [DImport $1] } + | mbDoc sig_def { [mkSigDecl $1 $2] } + | mod_param_decl { [DModParam $1] } + | mbDoc import { [DImport $2] } + -- we allow for documentation here to avoid conflicts with module paramaters + -- currently that odcumentation is just discarded + + +sig_def :: { (Located PName, Signature PName) } + : 'interface' 'submodule' name 'where' 'v{' sig_body 'v}' + { ($3, $6) } + +sig_body :: { Signature PName } + : par_decls {% mkInterface [] $1 } + | imports1 'v;' par_decls {% mkInterface (reverse $1) $3 } + | imports1 ';' par_decls {% mkInterface (reverse $1) $3 } + + +mod_param_decl :: { ModParam PName } + : mbDoc + 'import' 'interface' + impName mbAs { ModParam { mpSignature = $4 + , mpAs = fmap thing $5 + , mpName = mkModParamName $4 $5 + , mpDoc = $1 + , mpRenaming = mempty } } + + top_decl :: { [TopDecl PName] } : decl { [Decl (TopLevel {tlExport = Public, tlValue = $1 })] } | 'include' STRLIT {% (return . Include) `fmap` fromStrLit $2 } @@ -273,22 +336,24 @@ | mbDoc 'primitive' '(' op ')' ':' schema { mkPrimDecl $1 $4 $7 } | mbDoc 'primitive' 'type' schema ':' kind {% mkPrimTypeDecl $1 $4 $6 } +foreign_bind :: { [TopDecl PName] } + : mbDoc 'foreign' name ':' schema {% mkForeignDecl $1 $3 $5 } -parameter_decls :: { [TopDecl PName] } - : 'parameter' 'v{' par_decls 'v}' { reverse $3 } - | doc 'parameter' 'v{' par_decls 'v}' { reverse $4 } +parameter_decls :: { TopDecl PName } + : 'parameter' 'v{' par_decls 'v}' { mkParDecls (reverse $3) } + | doc 'parameter' 'v{' par_decls 'v}' { mkParDecls (reverse $4) } -- Reversed -par_decls :: { [TopDecl PName] } +par_decls :: { [ParamDecl PName] } : par_decl { [$1] } | par_decls ';' par_decl { $3 : $1 } | par_decls 'v;' par_decl { $3 : $1 } -par_decl :: { TopDecl PName } +par_decl :: { ParamDecl PName } : mbDoc name ':' schema { mkParFun $1 $2 $4 } | mbDoc 'type' name ':' kind {% mkParType $1 $3 $5 } - | mbDoc 'type' 'constraint' type {% fmap (DParameterConstraint . distrLoc) - (mkProp $4) } + | mbDoc typeOrPropSyn { mkIfacePropSyn (thing `fmap` $1) $2 } + | mbDoc topTypeConstraint { DParameterConstraint (distrLoc $2) } doc :: { Located Text } @@ -298,11 +363,14 @@ : doc { Just $1 } | {- empty -} { Nothing } - decl :: { Decl PName } : vars_comma ':' schema { at (head $1,$3) $ DSignature (reverse $1) $3 } | ipat '=' expr { at ($1,$3) $ DPatBind $1 $3 } | '(' op ')' '=' expr { at ($1,$5) $ DPatBind (PVar $2) $5 } + | var apats_indices propguards_cases + {% mkPropGuardsDecl $1 $2 $3 } + | var propguards_cases + {% mkConstantPropGuardsDecl $1 $2 } | var apats_indices '=' expr { at ($1,$4) $ mkIndexedDecl $1 $2 $4 } @@ -320,18 +388,7 @@ , bExport = Public } } - | 'type' name '=' type {% at ($1,$4) `fmap` mkTySyn $2 [] $4 } - | 'type' name tysyn_params '=' type - {% at ($1,$5) `fmap` mkTySyn $2 (reverse $3) $5 } - | 'type' tysyn_param op tysyn_param '=' type - {% at ($1,$6) `fmap` mkTySyn $3 [$2, $4] $6 } - - | 'type' 'constraint' name '=' type - {% at ($2,$5) `fmap` mkPropSyn $3 [] $5 } - | 'type' 'constraint' name tysyn_params '=' type - {% at ($2,$6) `fmap` mkPropSyn $3 (reverse $4) $6 } - | 'type' 'constraint' tysyn_param op tysyn_param '=' type - {% at ($2,$7) `fmap` mkPropSyn $4 [$3, $5] $7 } + | typeOrPropSyn { $1 } | 'infixl' NUM ops {% mkFixity LeftAssoc $2 (reverse $3) } | 'infixr' NUM ops {% mkFixity RightAssoc $2 (reverse $3) } @@ -363,30 +420,35 @@ | 'let' vars_comma ':' schema { at (head $2,$4) $ DSignature (reverse $2) $4 } - | 'type' name '=' type {% at ($1,$4) `fmap` mkTySyn $2 [] $4 } - | 'type' name tysyn_params '=' type - {% at ($1,$5) `fmap` mkTySyn $2 (reverse $3) $5 } - | 'type' tysyn_param op tysyn_param '=' type - {% at ($1,$6) `fmap` mkTySyn $3 [$2, $4] $6 } - - | 'type' 'constraint' name '=' type - {% at ($2,$5) `fmap` mkPropSyn $3 [] $5 } - | 'type' 'constraint' name tysyn_params '=' type - {% at ($2,$6) `fmap` mkPropSyn $3 (reverse $4) $6 } - | 'type' 'constraint' tysyn_param op tysyn_param '=' type - {% at ($2,$7) `fmap` mkPropSyn $4 [$3, $5] $7 } + | typeOrPropSyn { $1 } | 'infixl' NUM ops {% mkFixity LeftAssoc $2 (reverse $3) } | 'infixr' NUM ops {% mkFixity RightAssoc $2 (reverse $3) } | 'infix' NUM ops {% mkFixity NonAssoc $2 (reverse $3) } -newtype :: { Newtype PName } - : 'newtype' qname '=' newtype_body - { Newtype $2 [] (thing $4) } - | 'newtype' qname tysyn_params '=' newtype_body - { Newtype $2 (reverse $3) (thing $5) } +typeOrPropSyn :: { Decl PName } + : 'type' 'constraint' type '=' type {% mkPropSyn $3 $5 } + | 'type' type '=' type {% mkTySyn $2 $4 } +topTypeConstraint :: { Located [Prop PName] } + : 'type' 'constraint' type {% mkProp $3 } + + +propguards_cases :: { [PropGuardCase PName] } + : propguards_cases propguards_case { $2 : $1 } + | propguards_case { [$1] } + +propguards_case :: { PropGuardCase PName } + : '|' propguards_quals '=>' expr { PropGuardCase $2 $4 } + +propguards_quals :: { [Located (Prop PName)] } + : type {% mkPropGuards $1 } + + +newtype :: { Newtype PName } + : 'newtype' type '=' newtype_body {% mkNewtype $2 $4 } + newtype_body :: { Located (RecordMap Ident (Range, Type PName)) } : '{' '}' {% mkRecord (rComb $1 $2) (Located emptyRange) [] } | '{' field_types '}' {% mkRecord (rComb $1 $3) (Located emptyRange) $2 } @@ -516,13 +578,13 @@ : expr 'then' expr { ($1, $3) } simpleRHS :: { Expr PName } - : '-' simpleApp { at ($1,$2) (ENeg $2) } - | '~' simpleApp { at ($1,$2) (EComplement $2) } + : '-' simpleApp { at ($1,$2) (EPrefix PrefixNeg $2) } + | '~' simpleApp { at ($1,$2) (EPrefix PrefixComplement $2) } | simpleApp { $1 } longRHS :: { Expr PName } - : '-' longApp { at ($1,$2) (ENeg $2) } - | '~' longApp { at ($1,$2) (EComplement $2) } + : '-' longApp { at ($1,$2) (EPrefix PrefixNeg $2) } + | '~' longApp { at ($1,$2) (EPrefix PrefixComplement $2) } | longApp { $1 } @@ -720,14 +782,6 @@ : schema_param { [$1] } | schema_params ',' schema_param { $3 : $1 } -tysyn_param :: { TParam PName } - : ident {% mkTParam $1 Nothing } - | '(' ident ':' kind ')' {% mkTParam (at ($1,$5) $2) (Just (thing $4)) } - -tysyn_params :: { [TParam PName] } - : tysyn_param { [$1] } - | tysyn_params tysyn_param { $2 : $1 } - type :: { Type PName } : infix_type '->' type { at ($1,$3) $ TFun $1 $3 } | infix_type { $1 } @@ -748,13 +802,17 @@ | NUM { at $1 $ TNum (getNum $1) } | CHARLIT { at $1 $ TChar (getChr $1) } | '[' type ']' { at ($1,$3) $ TSeq $2 TBit } - | '(' type ')' { at ($1,$3) $ TParens $2 } + | '(' ktype ')' { at ($1,$3) $2 } | '(' ')' { at ($1,$2) $ TTuple [] } | '(' tuple_types ')' { at ($1,$3) $ TTuple (reverse $2) } | '{' '}' {% mkRecord (rComb $1 $2) TRecord [] } | '{' field_types '}' {% mkRecord (rComb $1 $3) TRecord $2 } | '_' { at $1 TWild } +ktype :: { Type PName } + : type ':' kind { TParens $1 (Just (thing $3)) } + | type { TParens $1 Nothing } + atypes :: { [ Type PName ] } : atype { [ $1 ] } | atypes atype { $2 : $1 } @@ -795,8 +853,7 @@ modName :: { Located ModName } : smodName { $1 } - | '`' smodName { fmap paramInstModName $2 } - + | 'module' smodName { $2 } qname :: { Located PName } : name { $1 } @@ -860,8 +917,8 @@ Layout -> programLayout NoLayout -> program -parseModule :: Config -> Text -> Either ParseError (Module PName) -parseModule cfg = parse cfg { cfgModuleScope = True } vmodule +parseModule :: Config -> Text -> Either ParseError [Module PName] +parseModule cfg = parse cfg { cfgModuleScope = True } top_module parseProgram :: Layout -> Text -> Either ParseError (Program PName) parseProgram l = parseProgramWith defaultConfig { cfgLayout = l } diff --git a/src/Cryptol/Parser/AST.hs b/src/Cryptol/Parser/AST.hs --- a/src/Cryptol/Parser/AST.hs +++ b/src/Cryptol/Parser/AST.hs @@ -16,6 +16,8 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleInstances #-} module Cryptol.Parser.AST ( -- * Names Ident, mkIdent, mkInfix, isInfixIdent, nullIdent, identText @@ -39,8 +41,20 @@ -- * Declarations , Module , ModuleG(..) + , mDecls -- XXX: Temporary + , mImports - , mSubmoduleImports + , mModParams + , mIsFunctor + , isParamDecl + + , ModuleDefinition(..) + , ModuleInstanceArgs(..) + , ModuleInstanceNamedArg(..) + , ModuleInstanceArg(..) + , ModuleInstance + , emptyModuleInstance + , Program(..) , TopDecl(..) , Decl(..) @@ -59,6 +73,11 @@ , ParameterType(..) , ParameterFun(..) , NestedModule(..) + , Signature(..) + , SigDecl(..) + , ModParam(..) + , ParamDecl(..) + , PropGuardCase(..) -- * Interactive , ReplInput(..) @@ -74,6 +93,9 @@ , UpdHow(..) , FunDesc(..) , emptyFunDesc + , PrefixOp(..) + , prefixFixity + , asEApps -- * Positions , Located(..) @@ -92,9 +114,11 @@ import Cryptol.Utils.RecordMap import Cryptol.Utils.PP +import Data.Map(Map) +import qualified Data.Map as Map import Data.List(intersperse) import Data.Bits(shiftR) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes,mapMaybe) import Data.Ratio(numerator,denominator) import Data.Text (Text) import Numeric(showIntAtBase,showFloat,showHFloat) @@ -122,36 +146,85 @@ newtype Program name = Program [TopDecl name] deriving (Show) --- | A parsed module. +{- | A module for the pre-typechecker phasese. The two parameters are: + + * @mname@ the type of module names. This is because top-level and nested + modules use differnt types to identify a module. + + * @name@ the type of identifiers used by declarations. + In the parser this starts off as `PName` and after resolving names + in the renamer, this becomes `Name`. +-} data ModuleG mname name = Module { mName :: Located mname -- ^ Name of the module - , mInstance :: !(Maybe (Located ModName)) -- ^ Functor to instantiate - -- (if this is a functor instnaces) - -- , mImports :: [Located Import] -- ^ Imports for the module - , mDecls :: [TopDecl name] -- ^ Declartions for the module + , mDef :: ModuleDefinition name } deriving (Show, Generic, NFData) + +-- | Different flavours of module we have. +data ModuleDefinition name = + NormalModule [TopDecl name] + + | FunctorInstance (Located (ImpName name)) + (ModuleInstanceArgs name) + (ModuleInstance name) + -- ^ The instance is filled in by the renamer + + | InterfaceModule (Signature name) + deriving (Show, Generic, NFData) + +{- | Maps names in the original functor with names in the instnace. +Does *NOT* include the parameters, just names for the definitions. +This *DOES* include entrirs for all the name in the instantiated functor, +including names in modules nested inside the functor. -} +type ModuleInstance name = Map name name + +emptyModuleInstance :: Ord name => ModuleInstance name +emptyModuleInstance = mempty + + +-- XXX: Review all places this is used, that it actually makes sense +-- Probably shouldn't exist +mDecls :: ModuleG mname name -> [TopDecl name] +mDecls m = + case mDef m of + NormalModule ds -> ds + FunctorInstance _ _ _ -> [] + InterfaceModule {} -> [] + +-- | Imports of top-level (i.e. "file" based) modules. mImports :: ModuleG mname name -> [ Located Import ] mImports m = - [ li { thing = i { iModule = n } } - | DImport li <- mDecls m - , let i = thing li - , ImpTop n <- [iModule i] - ] + case mDef m of + NormalModule ds -> mapMaybe topImp [ li | DImport li <- ds ] + FunctorInstance {} -> [] + InterfaceModule sig -> mapMaybe topImp (sigImports sig) + where + topImp li = case iModule i of + ImpTop n -> Just li { thing = i { iModule = n } } + _ -> Nothing + where i = thing li -mSubmoduleImports :: ModuleG mname name -> [ Located (ImportG name) ] -mSubmoduleImports m = - [ li { thing = i { iModule = n } } - | DImport li <- mDecls m - , let i = thing li - , ImpNested n <- [iModule i] - ] +-- | Get the module parameters of a module (new module system) +mModParams :: ModuleG mname name -> [ ModParam name ] +mModParams m = [ p | DModParam p <- mDecls m ] +mIsFunctor :: ModuleG mname nmae -> Bool +mIsFunctor m = any isParamDecl (mDecls m) -type Module = ModuleG ModName +isParamDecl :: TopDecl a -> Bool +isParamDecl d = + case d of + DModParam {} -> True + DParamDecl {} -> True + _ -> False +-- | A top-level module +type Module = ModuleG ModName + +-- | A nested module. newtype NestedModule name = NestedModule (ModuleG name name) deriving (Show,Generic,NFData) @@ -164,39 +237,110 @@ , Just (Range { from = start, to = start, source = "" }) ] - +-- | A declaration that may only appear at the top level of a module. +-- The module may be nested, however. data TopDecl name = Decl (TopLevel (Decl name)) | DPrimType (TopLevel (PrimType name)) | TDNewtype (TopLevel (Newtype name)) -- ^ @newtype T as = t - | Include (Located FilePath) -- ^ @include File@ - | DParameterType (ParameterType name) -- ^ @parameter type T : #@ - | DParameterConstraint [Located (Prop name)] - -- ^ @parameter type constraint (fin T)@ + | Include (Located FilePath) -- ^ @include File@ (until NoInclude) + + | DParamDecl Range (Signature name) -- ^ @parameter ...@ (parser only) + + | DModule (TopLevel (NestedModule name)) -- ^ @submodule M where ...@ + | DImport (Located (ImportG (ImpName name))) -- ^ @import X@ + | DModParam (ModParam name) -- ^ @import interface X ...@ + | DInterfaceConstraint (Maybe Text) (Located [Prop name]) + -- ^ @interface constraint@ + deriving (Show, Generic, NFData) + + +-- | Things that maybe appear in an interface/parameter block. +-- These only exist during parsering. +data ParamDecl name = + + DParameterType (ParameterType name) -- ^ @parameter type T : #@ (parser only) | DParameterFun (ParameterFun name) -- ^ @parameter someVal : [256]@ - | DModule (TopLevel (NestedModule name)) -- ^ Nested module - | DImport (Located (ImportG (ImpName name))) -- ^ An import declaration - deriving (Show, Generic, NFData) + -- (parser only) -data ImpName name = - ImpTop ModName - | ImpNested name + | DParameterDecl (SigDecl name) -- ^ A delcaration in an interface + + | DParameterConstraint [Located (Prop name)] + -- ^ @parameter type constraint (fin T)@ + deriving (Show, Generic, NFData) + +-- | All arguments in a functor instantiation +data ModuleInstanceArgs name = + DefaultInstArg (Located (ModuleInstanceArg name)) + -- ^ Single parameter instantitaion + + | DefaultInstAnonArg [TopDecl name] + -- ^ Single parameter instantitaion using this anonymous module. + -- (parser only) + + | NamedInstArgs [ModuleInstanceNamedArg name] + + deriving (Show, Generic, NFData) + +-- | A named argument in a functor instantiation +data ModuleInstanceNamedArg name = + ModuleInstanceNamedArg (Located Ident) (Located (ModuleInstanceArg name)) + deriving (Show, Generic, NFData) + +-- | An argument in a functor instantiation +data ModuleInstanceArg name = + ModuleArg (ImpName name) -- ^ An argument that is a module + | ParameterArg Ident -- ^ An argument that is a parameter + | AddParams -- ^ Arguments adds extra parameters to decls. + -- ("backtick" import) + deriving (Show, Generic, NFData) + + +-- | The name of an imported module +data ImpName name = + ImpTop ModName -- ^ A top-level module + | ImpNested name -- ^ The module in scope with the given name + deriving (Show, Generic, NFData, Eq, Ord) + +-- | A simple declaration. Generally these are things that can appear +-- both at the top-level of a module and in `where` clauses. data Decl name = DSignature [Located name] (Schema name) + -- ^ A type signature. Eliminated in NoPat--after NoPat + -- signatures are in their associated Bind + | DFixity !Fixity [Located name] + -- ^ A fixity declaration. Eliminated in NoPat---after NoPat + -- fixities are in their associated Bind + | DPragma [Located name] Pragma + -- ^ A pragma declaration. Eliminated in NoPat---after NoPat + -- fixities are in their associated Bind + | DBind (Bind name) + -- ^ A non-recursive binding. + | DRec [Bind name] - -- ^ A group of recursive bindings, introduced by the renamer. + -- ^ A group of recursive bindings. Introduced by the renamer. + | DPatBind (Pattern name) (Expr name) + -- ^ A pattern binding. Eliminated in NoPat---after NoPat + -- fixities are in their associated Bind + | DType (TySyn name) + -- ^ A type synonym. + | DProp (PropSyn name) + -- ^ A constraint synonym. + | DLocated (Decl name) Range + -- ^ Keeps track of the location of a declaration. + deriving (Eq, Show, Generic, NFData, Functor) --- | A type parameter +-- | A type parameter for a module. data ParameterType name = ParameterType { ptName :: Located name -- ^ name of type parameter , ptKind :: Kind -- ^ kind of parameter @@ -205,7 +349,7 @@ , ptNumber :: !Int -- ^ number of the parameter } deriving (Eq,Show,Generic,NFData) --- | A value parameter +-- | A value parameter for a module. data ParameterFun name = ParameterFun { pfName :: Located name -- ^ name of value parameter , pfSchema :: Schema name -- ^ schema for parameter @@ -214,12 +358,67 @@ } deriving (Eq,Show,Generic,NFData) +{- | Interface Modules (aka types of functor arguments) + +IMPORTANT: Interface Modules are a language construct and are different from +the notion of "interface" in the Cryptol implementation. + +Note that the names *defined* in an interface module are only really used in the +other members of the interface module. When an interface module is "imported" +as a functor parameter these names are instantiated to new names, +because there could be multiple paramers using the same interface. -} +data Signature name = Signature + { sigImports :: ![Located (ImportG (ImpName name))] + -- ^ Add things in scope + , sigTypeParams :: [ParameterType name] -- ^ Type parameters + , sigConstraints :: [Located (Prop name)] + -- ^ Constraints on the type parameters and type synonyms. + , sigDecls :: [SigDecl name] + -- ^ Type and constraint synonyms + , sigFunParams :: [ParameterFun name] -- ^ Value parameters + } deriving (Show,Generic,NFData) + +-- | A constraint or type synonym declared in an interface. +data SigDecl name = + SigTySyn (TySyn name) (Maybe Text) + | SigPropSyn (PropSyn name) (Maybe Text) + deriving (Show,Generic,NFData) + +{- | A module parameter declaration. + +> import interface A +> import interface A as B + +The name of the parameter is derived from the `as` clause. If there +is no `as` clause then it is derived from the name of the interface module. + +If there is no `as` clause, then the type/value parameters are unqualified, +and otherwise they are qualified. +-} +data ModParam name = ModParam + { mpSignature :: Located (ImpName name) -- ^ Signature for parameter + , mpAs :: Maybe ModName -- ^ Qualified for actual params + , mpName :: !Ident + {- ^ Parameter name (for inst.) + Note that this is not resolved in the renamer, and is only used + when instantiating a functor. -} + + , mpDoc :: Maybe (Located Text) -- ^ Optional documentation + , mpRenaming :: !(Map name name) + {- ^ Filled in by the renamer. + Maps the actual (value/type) parameter names to the names in the + interface module. -} + } deriving (Eq,Show,Generic,NFData) + + -- | An import declaration. data ImportG mname = Import { iModule :: !mname , iAs :: Maybe ModName , iSpec :: Maybe ImportSpec - } deriving (Eq, Show, Generic, NFData) + , iInst :: !(Maybe (ModuleInstanceArgs PName)) + -- ^ `iInst' exists only during parsing + } deriving (Show, Generic, NFData) type Import = ImportG ModName @@ -276,17 +475,27 @@ type LBindDef = Located (BindDef PName) data BindDef name = DPrim + | DForeign | DExpr (Expr name) + | DPropGuards [PropGuardCase name] deriving (Eq, Show, Generic, NFData, Functor) +data PropGuardCase name = PropGuardCase + { pgcProps :: [Located (Prop name)] + , pgcExpr :: Expr name + } + deriving (Eq,Generic,NFData,Functor,Show) + data Pragma = PragmaNote String | PragmaProperty deriving (Eq, Show, Generic, NFData) -data Newtype name = Newtype { nName :: Located name -- ^ Type name - , nParams :: [TParam name] -- ^ Type params - , nBody :: Rec (Type name) -- ^ Body - } deriving (Eq, Show, Generic, NFData) +data Newtype name = Newtype + { nName :: Located name -- ^ Type name + , nParams :: [TParam name] -- ^ Type params + , nConName :: !name -- ^ Constructor function name + , nBody :: Rec (Type name) -- ^ Body + } deriving (Eq, Show, Generic, NFData) -- | A declaration for a type with no implementation. data PrimType name = PrimType { primTName :: Located name @@ -341,8 +550,6 @@ data Expr n = EVar n -- ^ @ x @ | ELit Literal -- ^ @ 0x10 @ - | ENeg (Expr n) -- ^ @ -1 @ - | EComplement (Expr n) -- ^ @ ~1 @ | EGenerate (Expr n) -- ^ @ generate f @ | ETuple [Expr n] -- ^ @ (1,2,3) @ | ERecord (Rec (Expr n)) -- ^ @ { x = 1, y = 2 } @ @@ -373,8 +580,20 @@ | ESplit (Expr n) -- ^ @ splitAt x @ (Introduced by NoPat) | EParens (Expr n) -- ^ @ (e) @ (Removed by Fixity) | EInfix (Expr n) (Located n) Fixity (Expr n)-- ^ @ a + b @ (Removed by Fixity) + | EPrefix PrefixOp (Expr n) -- ^ @ -1, ~1 @ deriving (Eq, Show, Generic, NFData, Functor) +-- | Prefix operator. +data PrefixOp = PrefixNeg -- ^ @ - @ + | PrefixComplement -- ^ @ ~ @ + deriving (Eq, Show, Generic, NFData) + +prefixFixity :: PrefixOp -> Fixity +prefixFixity op = Fixity { fAssoc = LeftAssoc, .. } + where fLevel = case op of + PrefixNeg -> 80 + PrefixComplement -> 100 + -- | Description of functions. Only trivial information is provided here -- by the parser. The NoPat pass fills this in as required. data FunDesc n = @@ -439,7 +658,7 @@ | TTuple [Type n] -- ^ @([8], [32])@ | TWild -- ^ @_@, just some type. | TLocated (Type n) Range -- ^ Location information - | TParens (Type n) -- ^ @ (ty) @ + | TParens (Type n) (Maybe Kind) -- ^ @ (ty) @ | TInfix (Type n) (Located n) Fixity (Type n) -- ^ @ ty + ty @ deriving (Eq, Show, Generic, NFData, Functor) @@ -530,12 +749,29 @@ DPrimType pt -> getLoc pt TDNewtype n -> getLoc n Include lfp -> getLoc lfp + DModule d -> getLoc d + DImport d -> getLoc d + DModParam d -> getLoc d + DParamDecl r _ -> Just r + DInterfaceConstraint _ ds -> getLoc ds + +instance HasLoc (ParamDecl name) where + getLoc pd = + case pd of DParameterType d -> getLoc d DParameterFun d -> getLoc d + DParameterDecl d -> getLoc d DParameterConstraint d -> getLoc d - DModule d -> getLoc d - DImport d -> getLoc d +instance HasLoc (SigDecl name) where + getLoc decl = + case decl of + SigTySyn ts _ -> getLoc ts + SigPropSyn ps _ -> getLoc ps + +instance HasLoc (ModParam name) where + getLoc mp = getLoc (mpSignature mp) + instance HasLoc (PrimType name) where getLoc pt = Just (rComb (srcRange (primTName pt)) (srcRange (primTKind pt))) @@ -565,7 +801,14 @@ where locs = catMaybes ([ getLoc (nName n)] ++ map (Just . fst . snd) (displayFields (nBody n))) +instance HasLoc (TySyn name) where + getLoc (TySyn x _ _ _) = getLoc x +instance HasLoc (PropSyn name) where + getLoc (PropSyn x _ _ _) = getLoc x + + + -------------------------------------------------------------------------------- @@ -588,22 +831,56 @@ instance (Show name, PPName mname, PPName name) => PP (ModuleG mname name) where - ppPrec _ = ppModule 0 + ppPrec _ = ppModule "module" +instance (Show name, PPName name) => PP (NestedModule name) where + ppPrec _ (NestedModule m) = ppModule "submodule" m + ppModule :: (Show name, PPName mname, PPName name) => - Int -> ModuleG mname name -> Doc -ppModule n m = - text "module" <+> ppL (mName m) <+> text "where" $$ nest n body + Doc -> ModuleG mname name -> Doc +ppModule kw m = kw' <+> ppL (mName m) <+> pp (mDef m) where - body = vcat (map ppL (mImports m)) - $$ vcat (map pp (mDecls m)) + kw' = case mDef m of + InterfaceModule {} -> "interface" <+> kw + _ -> kw +instance (Show name, PPName name) => PP (ModuleDefinition name) where + ppPrec _ def = + case def of + NormalModule ds -> "where" $$ indent 2 (vcat (map pp ds)) + FunctorInstance f as inst -> vcat ( ("=" <+> pp (thing f) <+> pp as) + : ppInst + ) + where + ppInst = if null inst then [] else [ indent 2 + (vcat ("/* Instance:" : + instLines ++ [" */"])) + ] + instLines = [ " *" <+> pp k <+> "->" <+> pp v + | (k,v) <- Map.toList inst ] + InterfaceModule s -> ppInterface "where" s -instance (Show name, PPName name) => PP (NestedModule name) where - ppPrec _ (NestedModule m) = ppModule 2 m +instance (Show name, PPName name) => PP (ModuleInstanceArgs name) where + ppPrec _ arg = + case arg of + DefaultInstArg x -> braces (pp (thing x)) + DefaultInstAnonArg ds -> "where" $$ indent 2 (vcat (map pp ds)) + NamedInstArgs xs -> braces (commaSep (map pp xs)) +instance (Show name, PPName name) => PP (ModuleInstanceNamedArg name) where + ppPrec _ (ModuleInstanceNamedArg x y) = pp (thing x) <+> "=" <+> pp (thing y) + + +instance (Show name, PPName name) => PP (ModuleInstanceArg name) where + ppPrec _ arg = + case arg of + ModuleArg x -> pp x + ParameterArg i -> "parameter" <+> pp i + AddParams -> "{}" + + instance (Show name, PPName name) => PP (Program name) where ppPrec _ (Program ds) = vcat (map pp ds) @@ -614,27 +891,77 @@ DPrimType p -> pp p TDNewtype n -> pp n Include l -> text "include" <+> text (show (thing l)) + DModule d -> pp d + DImport i -> pp (thing i) + DModParam s -> pp s + DParamDecl _ ds -> ppInterface "parameter" ds + DInterfaceConstraint _ ds -> + "interface constraint" <+> + case map pp (thing ds) of + [x] -> x + [] -> "()" + xs -> nest 1 (parens (commaSepFill xs)) + +instance (Show name, PPName name) => PP (ParamDecl name) where + ppPrec _ pd = + case pd of DParameterFun d -> pp d DParameterType d -> pp d + DParameterDecl d -> pp d DParameterConstraint d -> - "parameter" <+> "type" <+> "constraint" <+> prop - where prop = case map (pp . thing) d of - [x] -> x - [] -> "()" - xs -> nest 1 (parens (commaSepFill xs)) - DModule d -> pp d - DImport i -> pp (thing i) + "type constraint" <+> parens (commaSep (map (pp . thing) d)) +ppInterface :: (Show name, PPName name) => Doc -> Signature name -> Doc +ppInterface kw sig = kw $$ indent 2 (vcat (is ++ ds)) + where + is = map pp (sigImports sig) + cs = case sigConstraints sig of + [] -> [] + cs' -> ["type constraint" <+> + parens (commaSep (map (pp . thing) cs'))] + ds = map pp (sigTypeParams sig) + ++ map pp (sigDecls sig) + ++ cs + ++ map pp (sigFunParams sig) + +instance (Show name, PPName name) => PP (SigDecl name) where + ppPrec p decl = + case decl of + SigTySyn ts _ -> ppPrec p ts + SigPropSyn ps _ -> ppPrec p ps + + +instance (Show name, PPName name) => PP (ModParam name) where + ppPrec _ mp = vcat ( mbDoc + ++ [ "import interface" <+> + pp (thing (mpSignature mp)) <+> mbAs ] + ++ mbRen + ) + where + mbDoc = case mpDoc mp of + Nothing -> [] + Just d -> [pp d] + mbAs = case mpAs mp of + Nothing -> mempty + Just d -> "as" <+> pp d + mbRen + | Map.null (mpRenaming mp) = [] + | otherwise = + [ indent 2 $ vcat $ "/* Parameters" + : [ " *" <+> pp x <+> "->" <+> pp y + | (x,y) <- Map.toList (mpRenaming mp) ] + ++ [" */"] ] + instance (Show name, PPName name) => PP (PrimType name) where ppPrec _ pt = "primitive" <+> "type" <+> pp (primTName pt) <+> ":" <+> pp (primTKind pt) instance (Show name, PPName name) => PP (ParameterType name) where - ppPrec _ a = text "parameter" <+> text "type" <+> + ppPrec _ a = text "type" <+> ppPrefixName (ptName a) <+> text ":" <+> pp (ptKind a) instance (Show name, PPName name) => PP (ParameterFun name) where - ppPrec _ a = text "parameter" <+> ppPrefixName (pfName a) <+> text ":" + ppPrec _ a = ppPrefixName (pfName a) <+> text ":" <+> pp (pfSchema a) @@ -662,11 +989,23 @@ , ppRecord (map (ppNamed' ":") (displayFields (nBody nt))) ] -instance PP mname => PP (ImportG mname) where - ppPrec _ d = text "import" <+> sep ([pp (iModule d)] ++ mbAs ++ mbSpec) +instance (PP mname) => PP (ImportG mname) where + ppPrec _ d = vcat [ text "import" <+> sep ([pp (iModule d)] ++ mbInst ++ + mbAs ++ mbSpec) + , indent 2 mbWhere + ] where mbAs = maybe [] (\ name -> [text "as" <+> pp name]) (iAs d) mbSpec = maybe [] (\x -> [pp x]) (iSpec d) + mbInst = case iInst d of + Just (DefaultInstArg x) -> [ braces (pp (thing x)) ] + Just (NamedInstArgs xs) -> [ braces (commaSep (map pp xs)) ] + _ -> [] + mbWhere = case iInst d of + Just (DefaultInstAnonArg ds) -> + "where" $$ vcat (map pp ds) + _ -> mempty + instance PP name => PP (ImpName name) where ppPrec _ nm = @@ -713,7 +1052,9 @@ instance (Show name, PPName name) => PP (BindDef name) where ppPrec _ DPrim = text "" + ppPrec _ DForeign = text "" ppPrec p (DExpr e) = ppPrec p e + ppPrec _p (DPropGuards _guards) = text "propguards" instance PPName name => PP (TySyn name) where @@ -816,8 +1157,6 @@ EVar x -> ppPrefixName x ELit x -> pp x - ENeg x -> wrap n 3 (text "-" <.> ppPrec 4 x) - EComplement x -> wrap n 3 (text "~" <.> ppPrec 4 x) EGenerate x -> wrap n 3 (text "generate" <+> ppPrec 4 x) ETuple es -> parens (commaSep (map pp es)) @@ -877,12 +1216,19 @@ EParens e -> parens (pp e) + -- NOTE: these don't produce correctly parenthesized expressions without + -- explicit EParens nodes when necessary, since we don't check the actual + -- fixities of the operators. EInfix e1 op _ e2 -> wrap n 0 (pp e1 <+> ppInfixName (thing op) <+> pp e2) + + EPrefix op e -> wrap n 3 (text (prefixText op) <.> ppPrec 4 e) where isInfix (EApp (EApp (EVar ieOp) ieLeft) ieRight) = do ieFixity <- ppNameFixity ieOp return Infix { .. } isInfix _ = Nothing + prefixText PrefixNeg = "-" + prefixText PrefixComplement = "~" instance (Show name, PPName name) => PP (UpdField name) where ppPrec _ (UpdField h xs e) = ppNestedSels (map thing xs) <+> pp h <+> pp e @@ -963,7 +1309,10 @@ TLocated t _ -> ppPrec n t - TParens t -> parens (pp t) + TParens t mb -> parens + case mb of + Nothing -> pp t + Just k -> pp t <+> ":" <+> pp k TInfix t1 o _ t2 -> optParens (n > 2) $ sep [ppPrec 2 t1 <+> ppInfixName o, ppPrec 3 t2] @@ -972,6 +1321,8 @@ instance PPName name => PP (Prop name) where ppPrec n (CType t) = ppPrec n t +instance PPName name => PP [Prop name] where + ppPrec n props = parens . commaSep . fmap (ppPrec n) $ props -------------------------------------------------------------------------------- -- Drop all position information, so equality reflects program structure @@ -1000,10 +1351,27 @@ instance NoPos (ModuleG mname name) where noPos m = Module { mName = mName m - , mInstance = mInstance m - , mDecls = noPos (mDecls m) + , mDef = noPos (mDef m) } +instance NoPos (ModuleDefinition name) where + noPos m = + case m of + NormalModule ds -> NormalModule (noPos ds) + FunctorInstance f as ds -> FunctorInstance (noPos f) (noPos as) ds + InterfaceModule s -> InterfaceModule (noPos s) + +instance NoPos (ModuleInstanceArgs name) where + noPos as = + case as of + DefaultInstArg a -> DefaultInstArg (noPos a) + DefaultInstAnonArg ds -> DefaultInstAnonArg (noPos ds) + NamedInstArgs xs -> NamedInstArgs (noPos xs) + +instance NoPos (ModuleInstanceNamedArg name) where + noPos (ModuleInstanceNamedArg x y) = + ModuleInstanceNamedArg (noPos x) (noPos y) + instance NoPos (NestedModule name) where noPos (NestedModule m) = NestedModule (noPos m) @@ -1014,13 +1382,43 @@ DPrimType t -> DPrimType (noPos t) TDNewtype n -> TDNewtype(noPos n) Include x -> Include (noPos x) + DModule d -> DModule (noPos d) + DImport d -> DImport (noPos d) + DModParam d -> DModParam (noPos d) + DParamDecl _ ds -> DParamDecl rng (noPos ds) + where rng = Range { from = Position 0 0, to = Position 0 0, source = "" } + DInterfaceConstraint d ds -> DInterfaceConstraint d (noPos (noPos <$> ds)) + +instance NoPos (ParamDecl name) where + noPos pd = + case pd of DParameterFun d -> DParameterFun (noPos d) DParameterType d -> DParameterType (noPos d) + DParameterDecl d -> DParameterDecl (noPos d) DParameterConstraint d -> DParameterConstraint (noPos d) - DModule d -> DModule (noPos d) - DImport d -> DImport (noPos d) +instance NoPos (Signature name) where + noPos sig = Signature { sigImports = sigImports sig + , sigTypeParams = map noPos (sigTypeParams sig) + , sigDecls = map noPos (sigDecls sig) + , sigConstraints = map noPos (sigConstraints sig) + , sigFunParams = map noPos (sigFunParams sig) + } +instance NoPos (SigDecl name) where + noPos decl = + case decl of + SigTySyn ts mb -> SigTySyn (noPos ts) mb + SigPropSyn ps mb -> SigPropSyn (noPos ps) mb + +instance NoPos (ModParam name) where + noPos mp = ModParam { mpSignature = noPos (mpSignature mp) + , mpAs = mpAs mp + , mpName = mpName mp + , mpDoc = noPos <$> mpDoc mp + , mpRenaming = mpRenaming mp + } + instance NoPos (PrimType name) where noPos x = x @@ -1047,9 +1445,10 @@ DLocated x _ -> noPos x instance NoPos (Newtype name) where - noPos n = Newtype { nName = noPos (nName n) - , nParams = nParams n - , nBody = fmap noPos (nBody n) + noPos n = Newtype { nName = noPos (nName n) + , nParams = nParams n + , nConName = nConName n + , nBody = fmap noPos (nBody n) } instance NoPos (Bind name) where @@ -1082,8 +1481,6 @@ case expr of EVar x -> EVar x ELit x -> ELit x - ENeg x -> ENeg (noPos x) - EComplement x -> EComplement (noPos x) EGenerate x -> EGenerate (noPos x) ETuple x -> ETuple (noPos x) ERecord x -> ERecord (fmap noPos x) @@ -1110,6 +1507,7 @@ ESplit x -> ESplit (noPos x) EParens e -> EParens (noPos e) EInfix x y f z -> EInfix (noPos x) y f (noPos z) + EPrefix op x -> EPrefix op (noPos x) instance NoPos (UpdField name) where noPos (UpdField h xs e) = UpdField h xs (noPos e) @@ -1154,7 +1552,7 @@ TNum n -> TNum n TChar n -> TChar n TLocated x _ -> noPos x - TParens x -> TParens (noPos x) + TParens x k -> TParens (noPos x) k TInfix x y f z-> TInfix (noPos x) y f (noPos z) instance NoPos (Prop name) where diff --git a/src/Cryptol/Parser/ExpandPropGuards.hs b/src/Cryptol/Parser/ExpandPropGuards.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Parser/ExpandPropGuards.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- Module : Cryptol.Parser.PropGuards +-- Copyright : (c) 2022 Galois, Inc. +-- License : BSD3 +-- Maintainer : cryptol@galois.com +-- Stability : provisional +-- Portability : portable +-- +-- Expands PropGuards into a top-level definition for each case, and rewrites +-- the body of each case to be an appropriate call to the respectively generated +-- function. +module Cryptol.Parser.ExpandPropGuards where + +import Control.DeepSeq +import Cryptol.Parser.AST +import Cryptol.Utils.PP +import Cryptol.Utils.Panic (panic) +import Data.Text (pack) +import GHC.Generics (Generic) + +-- | Monad +type ExpandPropGuardsM a = Either Error a + +runExpandPropGuardsM :: ExpandPropGuardsM a -> Either Error a +runExpandPropGuardsM m = m + +-- | Error +data Error = NoSignature (Located PName) + deriving (Show, Generic, NFData) + +instance PP Error where + ppPrec _ err = case err of + NoSignature x -> + text "At" <+> pp (srcRange x) <.> colon + <+> text "Declarations using constraint guards require an explicit type signature." + +expandPropGuards :: ModuleG mname PName -> ExpandPropGuardsM (ModuleG mname PName) +expandPropGuards m = + do def <- expandModuleDef (mDef m) + pure m { mDef = def } + +expandModuleDef :: ModuleDefinition PName -> ExpandPropGuardsM (ModuleDefinition PName) +expandModuleDef m = + case m of + NormalModule ds -> NormalModule . concat <$> mapM expandTopDecl ds + FunctorInstance {} -> pure m + InterfaceModule {} -> pure m + +expandTopDecl :: TopDecl PName -> ExpandPropGuardsM [TopDecl PName] +expandTopDecl topDecl = + case topDecl of + Decl topLevelDecl -> + do ds <- expandDecl (tlValue topLevelDecl) + pure [ Decl topLevelDecl { tlValue = d } | d <- ds ] + + DModule tl | NestedModule m <- tlValue tl -> + do m1 <- expandPropGuards m + pure [DModule tl { tlValue = NestedModule m1 }] + + _ -> pure [topDecl] + +expandDecl :: Decl PName -> ExpandPropGuardsM [Decl PName] +expandDecl decl = + case decl of + DBind bind -> do bs <- expandBind bind + pure (map DBind bs) + _ -> pure [decl] + +expandBind :: Bind PName -> ExpandPropGuardsM [Bind PName] +expandBind bind = + case thing (bDef bind) of + DPropGuards guards -> do + Forall params props t rng <- + case bSignature bind of + Just schema -> pure schema + Nothing -> Left . NoSignature $ bName bind + let goGuard :: + PropGuardCase PName -> + ExpandPropGuardsM (PropGuardCase PName, Bind PName) + goGuard (PropGuardCase props' e) = do + bName' <- newName (bName bind) (thing <$> props') + -- call to generated function + tParams <- case bSignature bind of + Just (Forall tps _ _ _) -> pure tps + Nothing -> Left $ NoSignature (bName bind) + typeInsts <- + (\(TParam n _ _) -> Right . PosInst $ TUser n []) + `traverse` tParams + let e' = foldl EApp (EAppT (EVar $ thing bName') typeInsts) (patternToExpr <$> bParams bind) + pure + ( PropGuardCase props' e', + bind + { bName = bName', + -- include guarded props in signature + bSignature = Just (Forall params + (props <> map thing props') + t rng), + -- keeps same location at original bind + -- i.e. "on top of" original bind + bDef = (bDef bind) {thing = DExpr e} + } + ) + (guards', binds') <- unzip <$> mapM goGuard guards + pure $ + bind {bDef = DPropGuards guards' <$ bDef bind} : + binds' + _ -> pure [bind] + +patternToExpr :: Pattern PName -> Expr PName +patternToExpr (PVar locName) = EVar (thing locName) +patternToExpr _ = + panic "patternToExpr" + ["Unimplemented: patternToExpr of anything other than PVar"] + +newName :: Located PName -> [Prop PName] -> ExpandPropGuardsM (Located PName) +newName locName props = + pure case thing locName of + Qual modName ident -> + let txt = identText ident + txt' = pack $ show $ pp props + in Qual modName (mkIdent $ txt <> txt') <$ locName + UnQual ident -> + let txt = identText ident + txt' = pack $ show $ pp props + in UnQual (mkIdent $ txt <> txt') <$ locName + NewName _ _ -> + panic "mkName" + [ "During expanding prop guards" + , "tried to make new name from NewName case of PName" + ] diff --git a/src/Cryptol/Parser/Layout.hs b/src/Cryptol/Parser/Layout.hs --- a/src/Cryptol/Parser/Layout.hs +++ b/src/Cryptol/Parser/Layout.hs @@ -64,7 +64,11 @@ | let t = head ts0 rng = srcRange t blockCol = max 1 (col (from rng)) -- see startImplicitBlock - , isMod && tokenType (thing t) /= KW KW_module = + implictMod = case map (tokenType . thing) ts0 of + KW KW_module : _ -> False + KW KW_interface : KW KW_module : _ -> False + _ -> True + , isMod && implictMod = virt rng VCurlyL : go [ Virtual blockCol ] blockCol True ts0 | otherwise = diff --git a/src/Cryptol/Parser/Lexer.x b/src/Cryptol/Parser/Lexer.x --- a/src/Cryptol/Parser/Lexer.x +++ b/src/Cryptol/Parser/Lexer.x @@ -98,12 +98,12 @@ -- Please update the docs, if you add new entries. "else" { emit $ KW KW_else } -"extern" { emit $ KW KW_extern } "if" { emit $ KW KW_if } "private" { emit $ KW KW_private } "include" { emit $ KW KW_include } "module" { emit $ KW KW_module } "submodule" { emit $ KW KW_submodule } +"interface" { emit $ KW KW_interface } "newtype" { emit $ KW KW_newtype } "pragma" { emit $ KW KW_pragma } "property" { emit $ KW KW_property } @@ -115,7 +115,6 @@ "import" { emit $ KW KW_import } "as" { emit $ KW KW_as } "hiding" { emit $ KW KW_hiding } -"newtype" { emit $ KW KW_newtype } "down" { emit $ KW KW_down } "by" { emit $ KW KW_by } @@ -126,6 +125,7 @@ "primitive" { emit $ KW KW_primitive } "parameter" { emit $ KW KW_parameter } "constraint" { emit $ KW KW_constraint } +"foreign" { emit $ KW KW_foreign } "Prop" { emit $ KW KW_Prop } diff --git a/src/Cryptol/Parser/Name.hs b/src/Cryptol/Parser/Name.hs --- a/src/Cryptol/Parser/Name.hs +++ b/src/Cryptol/Parser/Name.hs @@ -7,6 +7,7 @@ -- Portability : portable {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} module Cryptol.Parser.Name where @@ -33,6 +34,7 @@ -- | Passes that can generate fresh names. data Pass = NoPat | MonoValues + | ExpandPropGuards String deriving (Eq,Ord,Show,Generic) instance NFData PName @@ -54,8 +56,9 @@ getIdent (NewName p i) = packIdent ("__" ++ pass ++ show i) where pass = case p of - NoPat -> "p" - MonoValues -> "mv" + NoPat -> "p" + MonoValues -> "mv" + ExpandPropGuards _ -> "epg" isGeneratedName :: PName -> Bool isGeneratedName x = diff --git a/src/Cryptol/Parser/Names.hs b/src/Cryptol/Parser/Names.hs --- a/src/Cryptol/Parser/Names.hs +++ b/src/Cryptol/Parser/Names.hs @@ -9,6 +9,8 @@ -- This module defines the scoping rules for value- and type-level -- names in Cryptol. +{-# LANGUAGE Safe #-} + module Cryptol.Parser.Names ( tnamesNT , tnamesT @@ -18,6 +20,7 @@ , tnamesD , namesB , namesP + , namesNT , boundNames , boundNamesSet @@ -33,6 +36,9 @@ tnamesNT :: Newtype name -> ([Located name], ()) tnamesNT x = ([ nName x ], ()) +namesNT :: Newtype name -> ([Located name], ()) +namesNT x = ([ (nName x) { thing = nConName x } ], ()) + -- | The names defined and used by a group of mutually recursive declarations. namesDs :: Ord name => [Decl name] -> ([Located name], Set name) namesDs ds = (defs, boundLNames defs (Set.unions frees)) @@ -63,7 +69,9 @@ namesDef :: Ord name => BindDef name -> Set name namesDef DPrim = Set.empty +namesDef DForeign = Set.empty namesDef (DExpr e) = namesE e +namesDef (DPropGuards guards) = Set.unions (map (namesE . pgcExpr) guards) -- | The names used by an expression. @@ -72,8 +80,6 @@ case expr of EVar x -> Set.singleton x ELit _ -> Set.empty - ENeg e -> namesE e - EComplement e -> namesE e EGenerate e -> namesE e ETuple es -> Set.unions (map namesE es) ERecord fs -> Set.unions (map (namesE . snd) (recordElements fs)) @@ -102,6 +108,7 @@ ESplit e -> namesE e EParens e -> namesE e EInfix a o _ b-> Set.insert (thing o) (Set.union (namesE a) (namesE b)) + EPrefix _ e -> namesE e namesUF :: Ord name => UpdField name -> Set name namesUF (UpdField _ _ e) = namesE e @@ -184,16 +191,20 @@ tnamesDef :: Ord name => BindDef name -> Set name tnamesDef DPrim = Set.empty +tnamesDef DForeign = Set.empty tnamesDef (DExpr e) = tnamesE e +tnamesDef (DPropGuards guards) = Set.unions (map tnamesPropGuardCase guards) +tnamesPropGuardCase :: Ord name => PropGuardCase name -> Set name +tnamesPropGuardCase c = + Set.unions (tnamesE (pgcExpr c) : map (tnamesC . thing) (pgcProps c)) + -- | The type names used by an expression. tnamesE :: Ord name => Expr name -> Set name tnamesE expr = case expr of EVar _ -> Set.empty ELit _ -> Set.empty - ENeg e -> tnamesE e - EComplement e -> tnamesE e EGenerate e -> tnamesE e ETuple es -> Set.unions (map tnamesE es) ERecord fs -> Set.unions (map (tnamesE . snd) (recordElements fs)) @@ -224,6 +235,7 @@ ESplit e -> tnamesE e EParens e -> tnamesE e EInfix a _ _ b -> Set.union (tnamesE a) (tnamesE b) + EPrefix _ e -> tnamesE e tnamesUF :: Ord name => UpdField name -> Set name tnamesUF (UpdField _ _ e) = tnamesE e @@ -277,6 +289,6 @@ TTyApp fs -> Set.unions (map (tnamesT . value) fs) TLocated t _ -> tnamesT t TUser x ts -> Set.insert x (Set.unions (map tnamesT ts)) - TParens t -> tnamesT t + TParens t _ -> tnamesT t TInfix a x _ c-> Set.insert (thing x) (Set.union (tnamesT a) (tnamesT c)) diff --git a/src/Cryptol/Parser/NoInclude.hs b/src/Cryptol/Parser/NoInclude.hs --- a/src/Cryptol/Parser/NoInclude.hs +++ b/src/Cryptol/Parser/NoInclude.hs @@ -9,6 +9,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BlockArguments #-} module Cryptol.Parser.NoInclude ( removeIncludesModule , IncludeError(..), ppIncludeError @@ -19,6 +20,8 @@ import qualified Control.Exception as X import qualified Control.Monad.Fail as Fail +import Data.Set(Set) +import qualified Data.Set as Set import Data.ByteString (ByteString) import Data.Either (partitionEithers) import Data.Text(Text) @@ -29,19 +32,20 @@ import System.Directory (makeAbsolute) import System.FilePath (takeDirectory,(),isAbsolute) +import Cryptol.Utils.PP hiding (()) import Cryptol.Parser (parseProgramWith) import Cryptol.Parser.AST import Cryptol.Parser.LexerUtils (Config(..),defaultConfig) import Cryptol.Parser.ParserUtils import Cryptol.Parser.Unlit (guessPreProc) -import Cryptol.Utils.PP hiding (()) removeIncludesModule :: (FilePath -> IO ByteString) -> FilePath -> Module PName -> - IO (Either [IncludeError] (Module PName)) -removeIncludesModule reader modPath m = runNoIncM reader modPath (noIncludeModule m) + IO (Either [IncludeError] (Module PName, Set FilePath)) +removeIncludesModule reader modPath m = + runNoIncM reader modPath (noIncludeModule m) data IncludeError = IncludeFailed (Located FilePath) @@ -72,20 +76,40 @@ newtype NoIncM a = M - { unM :: ReaderT Env (ExceptionT [IncludeError] IO) a } + { unM :: ReaderT Env + ( ExceptionT [IncludeError] + ( StateT Deps + IO + )) a } +type Deps = Set FilePath + data Env = Env { envSeen :: [Located FilePath] -- ^ Files that have been loaded + , envIncPath :: FilePath -- ^ The path that includes are relative to + , envFileReader :: FilePath -> IO ByteString -- ^ How to load files } -runNoIncM :: (FilePath -> IO ByteString) -> FilePath -> NoIncM a -> IO (Either [IncludeError] a) + +runNoIncM :: + (FilePath -> IO ByteString) -> + FilePath -> + NoIncM a -> IO (Either [IncludeError] (a,Deps)) runNoIncM reader sourcePath m = do incPath <- getIncPath sourcePath - runM (unM m) Env { envSeen = [], envIncPath = incPath, envFileReader = reader } + (mb,s) <- runM (unM m) + Env { envSeen = [] + , envIncPath = incPath + , envFileReader = reader + } + Set.empty + pure + do ok <- mb + pure (ok,s) tryNoIncM :: NoIncM a -> NoIncM (Either [IncludeError] a) tryNoIncM m = M (try (unM m)) @@ -107,11 +131,17 @@ fromIncPath :: FilePath -> NoIncM FilePath fromIncPath path | isAbsolute path = return path - | otherwise = M $ + | otherwise = M do Env { .. } <- ask return (envIncPath path) +addDep :: FilePath -> NoIncM () +addDep path = M + do s <- get + let s1 = Set.insert path s + s1 `seq` set s1 + instance Functor NoIncM where fmap = liftM @@ -161,9 +191,14 @@ -- | Remove includes from a module. noIncludeModule :: ModuleG mname PName -> NoIncM (ModuleG mname PName) -noIncludeModule m = update `fmap` collectErrors noIncTopDecl (mDecls m) +noIncludeModule m = + do newDef <- case mDef m of + NormalModule ds -> NormalModule <$> doDecls ds + FunctorInstance f as is -> pure (FunctorInstance f as is) + InterfaceModule s -> pure (InterfaceModule s) + pure m { mDef = newDef } where - update tds = m { mDecls = concat tds } + doDecls = fmap concat . collectErrors noIncTopDecl -- | Remove includes from a program. noIncludeProgram :: Program PName -> NoIncM (Program PName) @@ -177,9 +212,8 @@ Decl _ -> pure [td] DPrimType {} -> pure [td] TDNewtype _-> pure [td] - DParameterType {} -> pure [td] - DParameterConstraint {} -> pure [td] - DParameterFun {} -> pure [td] + DParamDecl {} -> pure [td] + DInterfaceConstraint {} -> pure [td] Include lf -> resolveInclude lf DModule tl -> case tlValue tl of @@ -187,13 +221,17 @@ do m1 <- noIncludeModule m pure [ DModule tl { tlValue = NestedModule m1 } ] DImport {} -> pure [td] + DModParam {} -> pure [td] -- | Resolve the file referenced by a include into a list of top-level -- declarations. resolveInclude :: Located FilePath -> NoIncM [TopDecl PName] resolveInclude lf = pushPath lf $ do source <- readInclude lf - case parseProgramWith (defaultConfig { cfgSource = thing lf, cfgPreProc = guessPreProc (thing lf) }) source of + let cfg = defaultConfig { cfgSource = thing lf + , cfgPreProc = guessPreProc (thing lf) + } + case parseProgramWith cfg source of Right prog -> do Program ds <- @@ -206,8 +244,9 @@ -- | Read a file referenced by an include. readInclude :: Located FilePath -> NoIncM Text readInclude path = do - readBytes <- envFileReader <$> M ask + readBytes <- envFileReader <$> M ask file <- fromIncPath (thing path) + addDep file sourceBytes <- readBytes file `failsWith` handler sourceText <- X.evaluate (T.decodeUtf8' sourceBytes) `failsWith` handler case sourceText of diff --git a/src/Cryptol/Parser/NoPat.hs b/src/Cryptol/Parser/NoPat.hs --- a/src/Cryptol/Parser/NoPat.hs +++ b/src/Cryptol/Parser/NoPat.hs @@ -8,8 +8,8 @@ -- -- The purpose of this module is to convert all patterns to variable -- patterns. It also eliminates pattern bindings by de-sugaring them --- into `Bind`. Furthermore, here we associate signatures and pragmas --- with the names to which they belong. +-- into `Bind`. Furthermore, here we associate signatures, fixities, +-- and pragmas with the names to which they belong. {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -17,6 +17,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BlockArguments #-} module Cryptol.Parser.NoPat (RemovePatterns(..),Error(..)) where import Cryptol.Parser.AST @@ -150,8 +151,6 @@ case expr of EVar {} -> return expr ELit {} -> return expr - ENeg e -> ENeg <$> noPatE e - EComplement e -> EComplement <$> noPatE e EGenerate e -> EGenerate <$> noPatE e ETuple es -> ETuple <$> mapM noPatE es ERecord es -> ERecord <$> traverse (traverse noPatE) es @@ -176,6 +175,7 @@ ESplit e -> ESplit <$> noPatE e EParens e -> EParens <$> noPatE e EInfix x y f z-> EInfix <$> noPatE x <*> pure y <*> pure f <*> noPatE z + EPrefix op e -> EPrefix op <$> noPatE e noPatUF :: UpdField PName -> NoPatM (UpdField PName) @@ -220,10 +220,29 @@ | otherwise -> panic "NoPat" [ "noMatchB: primitive with params" , show b ] + DForeign + | null (bParams b) -> return b + | otherwise -> panic "NoPat" [ "noMatchB: foreign with params" + , show b ] + DExpr e -> do e' <- noPatFun (Just (thing (bName b))) 0 (bParams b) e return b { bParams = [], bDef = DExpr e' <$ bDef b } + DPropGuards guards -> + do let nm = thing (bName b) + ps = bParams b + gs <- mapM (noPatPropGuardCase nm ps) guards + pure b { bParams = [], bDef = DPropGuards gs <$ bDef b } + +noPatPropGuardCase :: + PName -> + [Pattern PName] -> + PropGuardCase PName -> NoPatM (PropGuardCase PName) +noPatPropGuardCase f xs pc = + do e <- noPatFun (Just f) 0 xs (pgcExpr pc) + pure pc { pgcExpr = e } + noMatchD :: Decl PName -> NoPatM [Decl PName] noMatchD decl = case decl of @@ -334,8 +353,12 @@ noPatModule :: ModuleG mname PName -> NoPatM (ModuleG mname PName) noPatModule m = - do ds1 <- noPatTopDs (mDecls m) - return m { mDecls = ds1 } + do def <- + case mDef m of + NormalModule ds -> NormalModule <$> noPatTopDs ds + FunctorInstance f as i -> pure (FunctorInstance f as i) + InterfaceModule s -> pure (InterfaceModule s) + pure m { mDef = def } -------------------------------------------------------------------------------- @@ -372,23 +395,8 @@ let d1 = DPrimType tl { tlValue = pt } (d1 :) <$> annotTopDs ds - DParameterType p -> - do p1 <- annotParameterType p - (DParameterType p1 :) <$> annotTopDs ds - - DParameterConstraint {} -> (d :) <$> annotTopDs ds - - DParameterFun p -> - do AnnotMap { .. } <- get - let rm _ _ = Nothing - name = thing (pfName p) - case Map.updateLookupWithKey rm name annValueFs of - (Nothing,_) -> (d :) <$> annotTopDs ds - (Just f,fs1) -> - do mbF <- lift (checkFixs name f) - set AnnotMap { annValueFs = fs1, .. } - let p1 = p { pfFixity = mbF } - (DParameterFun p1 :) <$> annotTopDs ds + DParamDecl {} -> (d :) <$> annotTopDs ds + DInterfaceConstraint {} -> (d :) <$> annotTopDs ds -- XXX: we may want to add pragmas to newtypes? TDNewtype {} -> (d :) <$> annotTopDs ds @@ -401,6 +409,8 @@ DImport {} -> (d :) <$> annotTopDs ds + DModParam {} -> (d :) <$> annotTopDs ds + [] -> return [] @@ -482,15 +492,6 @@ annotPrimType pt = do f <- annotTyThing (thing (primTName pt)) pure pt { primTFixity = f } - --- | Annotate a module's type parameter. -annotParameterType :: Annotates (ParameterType PName) -annotParameterType pt = - do f <- annotTyThing (thing (ptName pt)) - pure pt { ptFixity = f } - - - -- | Check for multiple signatures. checkSigs :: PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName)) diff --git a/src/Cryptol/Parser/ParserUtils.hs b/src/Cryptol/Parser/ParserUtils.hs --- a/src/Cryptol/Parser/ParserUtils.hs +++ b/src/Cryptol/Parser/ParserUtils.hs @@ -12,16 +12,21 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Cryptol.Parser.ParserUtils where +import qualified Data.Text as Text +import Data.Char(isAlphaNum) import Data.Maybe(fromMaybe) import Data.Bits(testBit,setBit) +import Data.Maybe(mapMaybe) +import Data.List(foldl') import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE -import Control.Monad(liftM,ap,unless,guard) +import Control.Monad(liftM,ap,unless,guard,msum) import qualified Control.Monad.Fail as Fail import Data.Text(Text) import qualified Data.Text as T @@ -40,7 +45,13 @@ import Cryptol.Parser.Token(SelectorType(..)) import Cryptol.Parser.Position import Cryptol.Parser.Utils (translateExprToNumT,widthIdent) -import Cryptol.Utils.Ident(packModName,packIdent,modNameChunks) +import Cryptol.Utils.Ident( packModName,packIdent,modNameChunks + , identAnonArg, identAnonIfaceMod + , modNameArg, modNameIfaceMod + , modNameToText, modNameIsNormal + , modNameToNormalModName + , unpackIdent + ) import Cryptol.Utils.PP import Cryptol.Utils.Panic import Cryptol.Utils.RecordMap @@ -193,6 +204,27 @@ mkModName :: [Text] -> ModName mkModName = packModName +-- | This is how we derive the name of a module parameter from the +-- @import source@ declaration. +mkModParamName :: Located (ImpName PName) -> Maybe (Located ModName) -> Ident +mkModParamName lsig qual = + case qual of + Nothing -> + case thing lsig of + ImpTop t + | modNameIsNormal t -> packIdent (last (modNameChunks t)) + | otherwise -> identAnonIfaceMod + $ packIdent + $ last + $ modNameChunks + $ modNameToNormalModName t + ImpNested nm -> + case nm of + UnQual i -> i + Qual _ i -> i + NewName {} -> panic "mkModParamName" ["Unexpected NewName",show lsig] + Just m -> packIdent (last (modNameChunks (thing m))) + -- Note that type variables are not resolved at this point: they are tcons. mkSchema :: [TParam PName] -> [Prop PName] -> Type PName -> Schema PName mkSchema xs ps t = Forall xs ps t Nothing @@ -272,7 +304,9 @@ TWild -> bad "Wildcard types" TUser {} -> ok - TParens t -> validDemotedType rng t + TParens t mb -> case mb of + Nothing -> validDemotedType rng t + Just _ -> bad "kind annotation" TInfix{} -> ok where bad x = errorMessage rng [x ++ " cannot be demoted."] @@ -486,7 +520,7 @@ mkParFun :: Maybe (Located Text) -> Located PName -> Schema PName -> - TopDecl PName + ParamDecl PName mkParFun mbDoc n s = DParameterFun ParameterFun { pfName = n , pfSchema = s , pfDoc = thing <$> mbDoc @@ -496,7 +530,7 @@ mkParType :: Maybe (Located Text) -> Located PName -> Located Kind -> - ParseM (TopDecl PName) + ParseM (ParamDecl PName) mkParType mbDoc n k = do num <- P $ \_ _ s -> let nu = sNextTyParamNum s in Right (nu, s { sNextTyParamNum = nu + 1 }) @@ -511,16 +545,17 @@ changeExport :: ExportType -> [TopDecl PName] -> [TopDecl PName] changeExport e = map change where - change (Decl d) = Decl d { tlExport = e } - change (DPrimType t) = DPrimType t { tlExport = e } - change (TDNewtype n) = TDNewtype n { tlExport = e } - change (DModule m) = DModule m { tlExport = e } - change td@Include{} = td - change td@DImport{} = td - change (DParameterType {}) = panic "changeExport" ["private type parameter?"] - change (DParameterFun {}) = panic "changeExport" ["private value parameter?"] - change (DParameterConstraint {}) = - panic "changeExport" ["private type constraint parameter?"] + change decl = + case decl of + Decl d -> Decl d { tlExport = e } + DPrimType t -> DPrimType t { tlExport = e } + TDNewtype n -> TDNewtype n { tlExport = e } + DModule m -> DModule m { tlExport = e } + DModParam {} -> decl + Include{} -> decl + DImport{} -> decl + DParamDecl{} -> decl + DInterfaceConstraint {} -> decl mkTypeInst :: Named (Type PName) -> TypeInst PName mkTypeInst x | nullIdent (thing (name x)) = PosInst (value x) @@ -532,22 +567,99 @@ | n == widthIdent = errorMessage rng ["`width` is not a valid type parameter name."] | otherwise = return (TParam (mkUnqual n) k (Just rng)) -mkTySyn :: Located PName -> [TParam PName] -> Type PName -> ParseM (Decl PName) -mkTySyn ln ps b - | getIdent (thing ln) == widthIdent = - errorMessage (srcRange ln) ["`width` is not a valid type synonym name."] - | otherwise = - return $ DType $ TySyn ln Nothing ps b +mkTySyn :: Type PName -> Type PName -> ParseM (Decl PName) +mkTySyn thead tdef = + do (nm,params) <- typeToDecl thead + pure (DType (TySyn nm Nothing params tdef)) -mkPropSyn :: Located PName -> [TParam PName] -> Type PName -> ParseM (Decl PName) -mkPropSyn ln ps b - | getIdent (thing ln) == widthIdent = - errorMessage (srcRange ln) ["`width` is not a valid constraint synonym name."] +mkPropSyn :: Type PName -> Type PName -> ParseM (Decl PName) +mkPropSyn thead tdef = + do (nm,params) <- typeToDecl thead + ps <- thing <$> mkProp tdef + pure (DProp (PropSyn nm Nothing params ps)) - | otherwise = - DProp . PropSyn ln Nothing ps . thing <$> mkProp b +mkNewtype :: + Type PName -> + Located (RecordMap Ident (Range, Type PName)) -> + ParseM (Newtype PName) +mkNewtype thead def = + do (nm,params) <- typeToDecl thead + pure (Newtype nm params (thing nm) (thing def)) +typeToDecl :: Type PName -> ParseM (Located PName, [TParam PName]) +typeToDecl ty0 = + case ty0 of + TLocated ty loc -> goD loc ty + _ -> panic "typeToDecl" ["Type location is missing."] + + where + bad loc = errorMessage loc ["Invalid type declaration"] + badP loc = errorMessage loc ["Invalid declaration parameter"] + + + goN loc n = + case n of + UnQual {} -> pure () + _ -> errorMessage loc ["Invalid declaration name"] + + goP loc ty = + case ty of + TLocated ty1 loc1 -> goP loc1 ty1 + + TUser f [] -> + do goN loc f + pure TParam { tpName = f, tpKind = Nothing, tpRange = Just loc } + + TParens t mb -> + case mb of + Nothing -> badP loc + Just k -> + do p <- goP loc t + case tpKind p of + Nothing -> pure p { tpKind = Just k } + Just {} -> badP loc + + TInfix {} -> badP loc + TUser {} -> badP loc + TFun {} -> badP loc + TSeq {} -> badP loc + TBit {} -> badP loc + TNum {} -> badP loc + TChar {} -> badP loc + TRecord {} -> badP loc + TWild {} -> badP loc + TTyApp {} -> badP loc + TTuple {} -> badP loc + + + goD loc ty = + case ty of + + TLocated ty1 loc1 -> goD loc1 ty1 + + TUser f ts -> + do goN loc f + ps <- mapM (goP loc) ts + pure (Located { thing = f, srcRange = loc },ps) + + TInfix l f _ r -> + do goN (srcRange f) (thing f) + a <- goP loc l + b <- goP loc r + pure (f,[a,b]) + + TFun {} -> bad loc + TSeq {} -> bad loc + TBit {} -> bad loc + TNum {} -> bad loc + TChar {} -> bad loc + TRecord {} -> bad loc + TWild {} -> bad loc + TTyApp {} -> bad loc + TTuple {} -> bad loc + TParens {} -> bad loc + polyTerm :: Range -> Integer -> Integer -> ParseM (Bool, Integer) polyTerm rng k p | k == 0 = return (False, p) @@ -610,6 +722,35 @@ rhs = mkGenerate (reverse ixs) e -- NOTE: The lists of patterns are reversed! +mkPropGuardsDecl :: + LPName -> + ([Pattern PName], [Pattern PName]) -> + [PropGuardCase PName] -> + ParseM (Decl PName) +mkPropGuardsDecl f (ps, ixs) guards = + do unless (null ixs) $ + errorMessage (srcRange f) + ["Indexed sequence definitions may not use constraint guards"] + let gs = reverse guards + pure $ + DBind Bind { bName = f + , bParams = reverse ps + , bDef = Located (srcRange f) (DPropGuards gs) + , bSignature = Nothing + , bPragmas = [] + , bMono = False + , bInfix = False + , bFixity = Nothing + , bDoc = Nothing + , bExport = Public + } + +mkConstantPropGuardsDecl :: + LPName -> [PropGuardCase PName] -> ParseM (Decl PName) +mkConstantPropGuardsDecl f guards = + mkPropGuardsDecl f ([],[]) guards + +-- NOTE: The lists of patterns are reversed! mkIndexedExpr :: ([Pattern PName], [Pattern PName]) -> Expr PName -> Expr PName mkIndexedExpr (ps, ixs) body | null ps = mkGenerate (reverse ixs) body @@ -624,19 +765,36 @@ where addIfThen (cond, doexpr) elseExpr = EIf cond doexpr elseExpr --- | Generate a signature and a primitive binding. The reason for generating --- both instead of just adding the signature at this point is that it means the --- primitive declarations don't need to be treated differently in the noPat +mkPrimDecl :: Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName] +mkPrimDecl = mkNoImplDecl DPrim + +mkForeignDecl :: + Maybe (Located Text) -> LPName -> Schema PName -> ParseM [TopDecl PName] +mkForeignDecl mbDoc nm ty = + do let txt = unpackIdent (getIdent (thing nm)) + unless (all isOk txt) + (errorMessage (srcRange nm) + [ "`" ++ txt ++ "` is not a valid foreign name." + , "The name should contain only alpha-numeric characters or '_'." + ]) + pure (mkNoImplDecl DForeign mbDoc nm ty) + where + isOk c = c == '_' || isAlphaNum c + +-- | Generate a signature and a binding for value declarations with no +-- implementation (i.e. primitive or foreign declarations). The reason for +-- generating both instead of just adding the signature at this point is that it +-- means the declarations don't need to be treated differently in the noPat -- pass. This is also the reason we add the doc to the TopLevel constructor, -- instead of just place it on the binding directly. A better solution might be --- to just have a different constructor for primitives. -mkPrimDecl :: - Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName] -mkPrimDecl mbDoc ln sig = +-- to just have a different constructor for primitives and foreigns. +mkNoImplDecl :: BindDef PName + -> Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName] +mkNoImplDecl def mbDoc ln sig = [ exportDecl mbDoc Public $ DBind Bind { bName = ln , bParams = [] - , bDef = at sig (Located emptyRange DPrim) + , bDef = at sig (Located emptyRange def) , bSignature = Nothing , bPragmas = [] , bMono = False @@ -761,6 +919,10 @@ distrLoc x = [ Located { srcRange = r, thing = a } | a <- thing x ] where r = srcRange x +mkPropGuards :: Type PName -> ParseM [Located (Prop PName)] +mkPropGuards ty = + do lp <- mkProp ty + pure [ lp { thing = p } | p <- thing lp ] mkProp :: Type PName -> ParseM (Located [Prop PName]) mkProp ty = @@ -777,7 +939,10 @@ TInfix{} -> return [CType t] TUser{} -> return [CType t] TTuple ts -> concat `fmap` mapM (props r) ts - TParens t' -> props r t' + TParens t' mb -> case mb of + Nothing -> props r t' + Just _ -> err + TLocated t' r' -> props r' t' TFun{} -> err @@ -795,8 +960,7 @@ -- | Make an ordinary module mkModule :: Located ModName -> [TopDecl PName] -> Module PName mkModule nm ds = Module { mName = nm - , mInstance = Nothing - , mDecls = ds + , mDef = NormalModule ds } mkNested :: Module PName -> ParseM (NestedModule PName) @@ -809,23 +973,103 @@ nm = mName m r = srcRange nm +mkSigDecl :: Maybe (Located Text) -> (Located PName,Signature PName) -> TopDecl PName +mkSigDecl doc (nm,sig) = + DModule + TopLevel { tlExport = Public + , tlDoc = doc + , tlValue = NestedModule + Module { mName = nm + , mDef = InterfaceModule sig + } + } + +mkInterfaceConstraint :: + Maybe (Located Text) -> Type PName -> ParseM [TopDecl PName] +mkInterfaceConstraint mbDoc ty = + do ps <- mkProp ty + pure [DInterfaceConstraint (thing <$> mbDoc) ps] + +mkParDecls :: [ParamDecl PName] -> TopDecl PName +mkParDecls ds = DParamDecl loc (mkInterface' [] ds) + where loc = rCombs (mapMaybe getLoc ds) + +onlySimpleImports :: [Located (ImportG (ImpName PName))] -> ParseM () +onlySimpleImports = mapM_ check + where + check i = + case iInst (thing i) of + Nothing -> pure () + Just _ -> + errorMessage (srcRange i) + [ "Functor instantiations are not supported in this context." + , "The imported entity needs to be just the name of a module." + , "A workaround would be to do the instantion in the outer context." + ] + +mkInterface' :: [Located (ImportG (ImpName PName))] -> + [ParamDecl PName] -> Signature PName +mkInterface' is = + foldl' add + Signature { sigImports = is + , sigTypeParams = [] + , sigDecls = [] + , sigConstraints = [] + , sigFunParams = [] + } + where + add s d = + case d of + DParameterType pt -> s { sigTypeParams = pt : sigTypeParams s } + DParameterConstraint ps -> s { sigConstraints = ps ++ sigConstraints s } + DParameterDecl pd -> s { sigDecls = pd : sigDecls s } + DParameterFun pf -> s { sigFunParams = pf : sigFunParams s } + + + +mkInterface :: [Located (ImportG (ImpName PName))] -> + [ParamDecl PName] -> ParseM (Signature PName) +mkInterface is ps = + do onlySimpleImports is + pure (mkInterface' is ps) + +mkIfacePropSyn :: Maybe Text -> Decl PName -> ParamDecl PName +mkIfacePropSyn mbDoc d = + case d of + DLocated d1 _ -> mkIfacePropSyn mbDoc d1 + DType ts -> DParameterDecl (SigTySyn ts mbDoc) + DProp ps -> DParameterDecl (SigPropSyn ps mbDoc) + _ -> panic "mkIfacePropSyn" [ "Unexpected declaration", show (pp d) ] + + -- | Make an unnamed module---gets the name @Main@. -mkAnonymousModule :: [TopDecl PName] -> Module PName -mkAnonymousModule = mkModule Located { srcRange = emptyRange +mkAnonymousModule :: [TopDecl PName] -> ParseM [Module PName] +mkAnonymousModule = mkTopMods + . mkModule Located { srcRange = emptyRange , thing = mkModName [T.pack "Main"] } -- | Make a module which defines a functor instance. -mkModuleInstance :: Located ModName -> - Located ModName -> - [TopDecl PName] -> - Module PName -mkModuleInstance nm fun ds = - Module { mName = nm - , mInstance = Just fun - , mDecls = ds +mkModuleInstanceAnon :: Located ModName -> + Located (ImpName PName) -> + [TopDecl PName] -> + Module PName +mkModuleInstanceAnon nm fun ds = + Module { mName = nm + , mDef = FunctorInstance fun (DefaultInstAnonArg ds) mempty } +mkModuleInstance :: + Located ModName -> + Located (ImpName PName) -> + ModuleInstanceArgs PName -> + Module PName +mkModuleInstance m f as = + Module { mName = m + , mDef = FunctorInstance f as emptyModuleInstance + } + + ufToNamed :: UpdField PName -> ParseM (Named (Expr PName)) ufToNamed (UpdField h ls e) = case (h,ls) of @@ -876,5 +1120,237 @@ case tokenType tok of Selector (TupleSelectorTok n) -> TupleSel n Nothing Selector (RecordSelectorTok t) -> RecordSel (mkIdent t) Nothing - _ -> panic "mkSelector" - [ "Unexpected selector token", show tok ] + _ -> panic "mkSelector" [ "Unexpected selector token", show tok ] + +mkBacktickImport :: + Range -> + Located (ImpName PName) -> + Maybe (Located ModName) -> + Maybe (Located ImportSpec) -> + ParseM (Located (ImportG (ImpName PName))) +mkBacktickImport loc impName mbAs mbImportSpec = + mkImport loc impName (Just inst) mbAs mbImportSpec Nothing + where + inst = DefaultInstArg (fmap (const AddParams) impName) + + +mkImport :: + Range -> + Located (ImpName PName) -> + Maybe (ModuleInstanceArgs PName) -> + Maybe (Located ModName) -> + Maybe (Located ImportSpec) -> + Maybe (Located [Decl PName]) -> + ParseM (Located (ImportG (ImpName PName))) + +mkImport loc impName optInst mbAs mbImportSpec optImportWhere = + do i <- getInst + let end = fromMaybe (srcRange impName) + $ msum [ srcRange <$> optImportWhere + , srcRange <$> mbImportSpec + , srcRange <$> mbAs + ] + + pure Located { srcRange = rComb loc end + , thing = Import + { iModule = thing impName + , iAs = thing <$> mbAs + , iSpec = thing <$> mbImportSpec + , iInst = i + } + } + where + getInst = + case (optInst,optImportWhere) of + (Just _, Just _) -> + errorMessage loc [ "Invalid instantiating import." + , "Import should have at most one of:" + , " * { } instantiation, or" + , " * where instantiation" + ] + (Just a, Nothing) -> pure (Just a) + (Nothing, Just a) -> + pure (Just (DefaultInstAnonArg (map instTop (thing a)))) + where + instTop d = Decl TopLevel + { tlExport = Public + , tlDoc = Nothing + , tlValue = d + } + (Nothing, Nothing) -> pure Nothing + + + + + +mkTopMods :: Module PName -> ParseM [Module PName] +mkTopMods = desugarMod + +mkTopSig :: Located ModName -> Signature PName -> [Module PName] +mkTopSig nm sig = + [ Module { mName = nm + , mDef = InterfaceModule sig + } + ] + + +class MkAnon t where + mkAnon :: AnonThing -> t -> t + toImpName :: t -> ImpName PName + +data AnonThing = AnonArg | AnonIfaceMod + +instance MkAnon ModName where + mkAnon what = case what of + AnonArg -> modNameArg + AnonIfaceMod -> modNameIfaceMod + toImpName = ImpTop + +instance MkAnon PName where + mkAnon what = mkUnqual + . case what of + AnonArg -> identAnonArg + AnonIfaceMod -> identAnonIfaceMod + . getIdent + toImpName = ImpNested + + +desugarMod :: MkAnon name => ModuleG name PName -> ParseM [ModuleG name PName] +desugarMod mo = + case mDef mo of + + FunctorInstance f as _ | DefaultInstAnonArg lds <- as -> + do (ms,lds') <- desugarTopDs (mName mo) lds + case ms of + m : _ | InterfaceModule si <- mDef m + , l : _ <- map (srcRange . ptName) (sigTypeParams si) ++ + map (srcRange . pfName) (sigFunParams si) ++ + [ srcRange (mName mo) ] -> + errorMessage l + [ "Instantiation of a parameterized module may not itself be " + ++ "parameterized" ] + _ -> pure () + let i = mkAnon AnonArg (thing (mName mo)) + nm = Located { srcRange = srcRange (mName mo), thing = i } + as' = DefaultInstArg (ModuleArg . toImpName <$> nm) + pure [ Module { mName = nm, mDef = NormalModule lds' } + , mo { mDef = FunctorInstance f as' mempty } + ] + + NormalModule ds -> + do (newMs, newDs) <- desugarTopDs (mName mo) ds + pure (newMs ++ [ mo { mDef = NormalModule newDs } ]) + + _ -> pure [mo] + + +desugarTopDs :: + MkAnon name => + Located name -> + [TopDecl PName] -> + ParseM ([ModuleG name PName], [TopDecl PName]) +desugarTopDs ownerName = go emptySig + where + isEmpty s = + null (sigTypeParams s) && null (sigConstraints s) && null (sigFunParams s) + + emptySig = Signature + { sigImports = [] + , sigTypeParams = [] + , sigDecls = [] + , sigConstraints = [] + , sigFunParams = [] + } + + jnSig s1 s2 = Signature { sigImports = j sigImports + , sigTypeParams = j sigTypeParams + , sigDecls = j sigDecls + , sigConstraints = j sigConstraints + , sigFunParams = j sigFunParams + } + + where + j f = f s1 ++ f s2 + + addI i s = s { sigImports = i : sigImports s } + + go sig ds = + case ds of + + [] + | isEmpty sig -> pure ([],[]) + | otherwise -> + do let nm = mkAnon AnonIfaceMod <$> ownerName + pure ( [ Module { mName = nm + , mDef = InterfaceModule sig + } + ] + , [ DModParam + ModParam + { mpSignature = toImpName <$> nm + , mpAs = Nothing + , mpName = mkModParamName (toImpName <$> nm) + Nothing + , mpDoc = Nothing + , mpRenaming = mempty + } + ] + ) + + d : more -> + let cont emit sig' = + do (ms,ds') <- go sig' more + pure (ms, emit ++ ds') + in + case d of + + DImport i | ImpTop _ <- iModule (thing i) + , Nothing <- iInst (thing i) -> + cont [d] (addI i sig) + + DImport i | Just inst <- iInst (thing i) -> + do newDs <- desugarInstImport i inst + cont newDs sig + + DParamDecl _ ds' -> cont [] (jnSig ds' sig) + + DModule tl | NestedModule mo <- tlValue tl -> + do ms <- desugarMod mo + cont [ DModule tl { tlValue = NestedModule m } | m <- ms ] sig + + _ -> cont [d] sig + +desugarInstImport :: + Located (ImportG (ImpName PName)) {- ^ The import -} -> + ModuleInstanceArgs PName {- ^ The insantiation -} -> + ParseM [TopDecl PName] +desugarInstImport i inst = + do ms <- desugarMod + Module { mName = i { thing = iname } + , mDef = FunctorInstance + (iModule <$> i) inst emptyModuleInstance + } + pure (DImport (newImp <$> i) : map modTop ms) + + where + imp = thing i + iname = mkUnqual + $ mkIdent + $ "import of " <> nm <> " at " <> Text.pack (show (pp (srcRange i))) + where + nm = case iModule imp of + ImpTop f -> modNameToText f + ImpNested n -> "submodule " <> Text.pack (show (pp n)) + + newImp d = d { iModule = ImpNested iname + , iInst = Nothing + } + + modTop m = DModule TopLevel + { tlExport = Private + , tlDoc = Nothing + , tlValue = NestedModule m + } + + + diff --git a/src/Cryptol/Parser/Position.hs b/src/Cryptol/Parser/Position.hs --- a/src/Cryptol/Parser/Position.hs +++ b/src/Cryptol/Parser/Position.hs @@ -37,6 +37,11 @@ , source :: FilePath } deriving (Eq, Ord, Show, Generic, NFData) +-- | Returns `True` if the first range is contained in the second one. +rangeWithin :: Range -> Range -> Bool +a `rangeWithin` b = + source a == source b && from a >= from b && to a <= to b + -- | An empty range. -- -- Caution: using this on the LHS of a use of rComb will cause the empty source diff --git a/src/Cryptol/Parser/Token.hs b/src/Cryptol/Parser/Token.hs --- a/src/Cryptol/Parser/Token.hs +++ b/src/Cryptol/Parser/Token.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} module Cryptol.Parser.Token where import Data.Text(Text) @@ -20,7 +21,6 @@ deriving (Eq, Show, Generic, NFData) data TokenKW = KW_else - | KW_extern | KW_fin | KW_if | KW_private @@ -50,6 +50,8 @@ | KW_primitive | KW_parameter | KW_constraint + | KW_interface + | KW_foreign | KW_Prop | KW_by | KW_down diff --git a/src/Cryptol/Parser/Unlit.hs b/src/Cryptol/Parser/Unlit.hs --- a/src/Cryptol/Parser/Unlit.hs +++ b/src/Cryptol/Parser/Unlit.hs @@ -20,7 +20,7 @@ import Cryptol.Utils.Panic -data PreProc = None | Markdown | LaTeX +data PreProc = None | Markdown | LaTeX | RST knownExts :: [String] knownExts = @@ -28,6 +28,7 @@ , "tex" , "markdown" , "md" + , "rst" ] guessPreProc :: FilePath -> PreProc @@ -35,6 +36,7 @@ ".tex" -> LaTeX ".markdown" -> Markdown ".md" -> Markdown + ".rst" -> RST _ -> None unLit :: PreProc -> Text -> Text @@ -47,6 +49,7 @@ None -> return . Code Markdown -> markdown LaTeX -> latex + RST -> rst data Block = Code [Text] | Comment [Text] @@ -102,7 +105,7 @@ isOpenFence l | "```" `Text.isPrefixOf` l' = - Just $ case Text.drop 3 l' of + Just $ case Text.dropWhile isSpace (Text.drop 3 l') of l'' | "cryptol" `Text.isPrefixOf` l'' -> Code | isBlank l'' -> Code | otherwise -> Comment @@ -134,6 +137,35 @@ isBeginCode l = "\\begin{code}" `Text.isPrefixOf` l isEndCode l = "\\end{code}" `Text.isPrefixOf` l +rst :: [Text] -> [Block] +rst = comment [] + where + isBeginCode l = case filter (not . Text.null) (Text.split isSpace l) of + ["..", dir, "cryptol"] -> dir == "code-block::" || + dir == "sourcecode::" + _ -> False + isEmpty = Text.all isSpace + isCode l = case Text.uncons l of + Just (c, _) -> isSpace c + Nothing -> True + + comment acc ls = + case ls of + [] -> mk Comment acc + l : ls1 | isBeginCode l -> codeOptions (l : acc) ls1 + | otherwise -> comment (l : acc) ls1 + + codeOptions acc ls = + case ls of + [] -> mk Comment acc + l : ls1 | isEmpty l -> mk Comment (l : acc) ++ code [] ls1 + | otherwise -> codeOptions (l : acc) ls1 + + code acc ls = + case ls of + [] -> mk Code acc + l : ls1 | isCode l -> code (l : acc) ls1 + | otherwise -> mk Code acc ++ comment [] ls diff --git a/src/Cryptol/Parser/Utils.hs b/src/Cryptol/Parser/Utils.hs --- a/src/Cryptol/Parser/Utils.hs +++ b/src/Cryptol/Parser/Utils.hs @@ -10,6 +10,7 @@ -- from previous Cryptol versions. {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} module Cryptol.Parser.Utils ( translateExprToNumT @@ -41,7 +42,7 @@ return (TInfix e1 o f e2) EParens e -> do t <- translateExprToNumT e - return (TParens t) + return (TParens t Nothing) _ -> Nothing diff --git a/src/Cryptol/REPL/Browse.hs b/src/Cryptol/REPL/Browse.hs --- a/src/Cryptol/REPL/Browse.hs +++ b/src/Cryptol/REPL/Browse.hs @@ -13,7 +13,9 @@ import qualified Cryptol.TypeCheck.Type as T import Cryptol.Utils.PP -import Cryptol.ModuleSystem.Env(ModContext(..)) +import Cryptol.Utils.Ident (OrigName(..), modPathIsNormal, identIsNormal) + +import Cryptol.ModuleSystem.Env(ModContext(..),ModContextParams(..)) import Cryptol.ModuleSystem.NamingEnv(namingEnvNames) import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.Interface @@ -21,11 +23,14 @@ data BrowseHow = BrowseExported | BrowseInScope browseModContext :: BrowseHow -> ModContext -> PP.Doc Void -browseModContext how mc = runDoc (env disp) (vcat sections) +browseModContext how mc = + runDoc (env disp) (vcat sections) where sections = concat [ browseMParams (env disp) (mctxParams mc) + , browseSignatures disp decls , browseMods disp decls + , browseFunctors disp decls , browseTSyns disp decls , browsePrimTys disp decls , browseNewtypes disp decls @@ -35,7 +40,12 @@ disp = DispInfo { dispHow = how, env = mctxNameDisp mc } decls = filterIfaceDecls (`Set.member` visNames) (mctxDecls mc) allNames = namingEnvNames (mctxNames mc) - visNames = case how of + notAnon nm = identIsNormal (nameIdent nm) && + case nameModPathMaybe nm of + Just p -> modPathIsNormal p + _ -> True -- shouldn't happen? + visNames = Set.filter notAnon + case how of BrowseInScope -> allNames BrowseExported -> mctxExported mc @@ -44,33 +54,52 @@ -------------------------------------------------------------------------------- -browseMParams :: NameDisp -> IfaceParams -> [Doc] -browseMParams disp params = - ppSectionHeading "Module Parameters" - $ addEmpty - $ map ppParamTy (sortByName disp (Map.toList (ifParamTypes params))) ++ - map ppParamFu (sortByName disp (Map.toList (ifParamFuns params))) +browseMParams :: NameDisp -> ModContextParams -> [Doc] +browseMParams disp pars = + case pars of + NoParams -> [] + FunctorParams params -> + ppSectionHeading "Module Parameters" + $ [ "parameter" <+> pp (T.mpName p) <+> ":" <+> + "interface" <+> pp (T.mpIface p) $$ + indent 2 (vcat $ + map ppParamTy (sortByName disp (Map.toList (T.mpnTypes names))) ++ + map ppParamFu (sortByName disp (Map.toList (T.mpnFuns names))) + ) + | p <- Map.elems params + , let names = T.mpParameters p + ] ++ + [" "] + InterfaceParams ps -> [pp ps] -- XXX where ppParamTy p = nest 2 (sep ["type", pp (T.mtpName p) <+> ":", pp (T.mtpKind p)]) ppParamFu p = nest 2 (sep [pp (T.mvpName p) <+> ":", pp (T.mvpType p)]) -- XXX: should we print the constraints somewhere too? - addEmpty xs = case xs of - [] -> [] - _ -> xs ++ [" "] - browseMods :: DispInfo -> IfaceDecls -> [Doc] browseMods disp decls = - ppSection disp "Modules" ppM (ifModules decls) + ppSection disp "Submodules" ppM (ifModules decls) where - ppM m = "submodule" <+> pp (ifModName m) - -- XXX: can print a lot more information about the moduels, but - -- might be better to do that with a separate command + ppM m = pp (ifsName m) +browseFunctors :: DispInfo -> IfaceDecls -> [Doc] +browseFunctors disp decls = + ppSection disp "Parameterized Submodules" ppM (ifFunctors decls) + where + ppM m = pp (ifModName m) + +browseSignatures :: DispInfo -> IfaceDecls -> [Doc] +browseSignatures disp decls = + ppSection disp "Interface Submodules" + ppS (Map.mapWithKey (,) (ifSignatures decls)) + where + ppS (x,s) = pp x + + browseTSyns :: DispInfo -> IfaceDecls -> [Doc] browseTSyns disp decls = ppSection disp "Type Synonyms" pp tss @@ -142,8 +171,8 @@ where toEntry (n,a) = case nameInfo n of - Declared m _ -> Just (m,[(n,a)]) - _ -> Nothing + GlobalName _ og -> Just (ogModule og,[(n,a)]) + _ -> Nothing sortByName :: NameDisp -> [(Name,a)] -> [a] diff --git a/src/Cryptol/REPL/Command.hs b/src/Cryptol/REPL/Command.hs --- a/src/Cryptol/REPL/Command.hs +++ b/src/Cryptol/REPL/Command.hs @@ -59,19 +59,25 @@ import Cryptol.REPL.Monad import Cryptol.REPL.Trie import Cryptol.REPL.Browse +import Cryptol.REPL.Help import qualified Cryptol.ModuleSystem as M import qualified Cryptol.ModuleSystem.Name as M import qualified Cryptol.ModuleSystem.NamingEnv as M -import qualified Cryptol.ModuleSystem.Renamer as M (RenamerWarning(SymbolShadowed)) +import qualified Cryptol.ModuleSystem.Renamer as M + (RenamerWarning(SymbolShadowed, PrefixAssocChanged)) import qualified Cryptol.Utils.Ident as M import qualified Cryptol.ModuleSystem.Env as M +import Cryptol.ModuleSystem.Fingerprint(fingerprintHexString) +import Cryptol.Backend.FloatHelpers as FP import qualified Cryptol.Backend.Monad as E import qualified Cryptol.Backend.SeqMap as E import Cryptol.Eval.Concrete( Concrete(..) ) import qualified Cryptol.Eval.Concrete as Concrete import qualified Cryptol.Eval.Env as E +import Cryptol.Eval.FFI +import Cryptol.Eval.FFI.GenHeader import qualified Cryptol.Eval.Type as E import qualified Cryptol.Eval.Value as E import qualified Cryptol.Eval.Reference as R @@ -86,7 +92,8 @@ import qualified Cryptol.TypeCheck.Parseable as T import qualified Cryptol.TypeCheck.Subst as T import Cryptol.TypeCheck.Solve(defaultReplExpr) -import Cryptol.TypeCheck.PP (dump,ppWithNames,emptyNameMap) +import Cryptol.TypeCheck.PP (dump) +import qualified Cryptol.Utils.Benchmark as Bench import Cryptol.Utils.PP hiding (()) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.RecordMap @@ -104,28 +111,30 @@ import Control.Monad hiding (mapM, mapM) import qualified Control.Monad.Catch as Ex import Control.Monad.IO.Class(liftIO) +import Text.Read (readMaybe) +import Control.Applicative ((<|>)) +import qualified Data.Set as Set import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.Bits (shiftL, (.&.), (.|.)) import Data.Char (isSpace,isPunctuation,isSymbol,isAlphaNum,isAscii) import Data.Function (on) -import Data.List (intercalate, nub, isPrefixOf,intersperse) +import Data.List (intercalate, nub, isPrefixOf) import Data.Maybe (fromMaybe,mapMaybe,isNothing) import System.Environment (lookupEnv) import System.Exit (ExitCode(ExitSuccess)) import System.Process (shell,createProcess,waitForProcess) import qualified System.Process as Process(runCommand) -import System.FilePath((), isPathSeparator) +import System.FilePath((), (-<.>), isPathSeparator) import System.Directory(getHomeDirectory,setCurrentDirectory,doesDirectoryExist ,getTemporaryDirectory,setPermissions,removeFile ,emptyPermissions,setOwnerReadable) -import qualified Data.Map as Map -import qualified Data.Set as Set import System.IO (Handle,hFlush,stdout,openTempFile,hClose,openFile ,IOMode(..),hGetContents,hSeek,SeekMode(..)) -import System.Random.TF(newTFGen) +import qualified System.Random.TF as TF +import qualified System.Random.TF.Instances as TFI import Numeric (showFFloat) import qualified Data.Text as T import Data.IORef(newIORef,readIORef,writeIORef) @@ -137,6 +146,8 @@ import qualified Data.SBV.Internals as SBV (showTDiff) + + -- Commands -------------------------------------------------------------------- -- | Commands. @@ -251,6 +262,33 @@ , CommandDescr [ ":extract-coq" ] [] (NoArg allTerms) "Print out the post-typechecked AST of all currently defined terms,\nin a Coq-parseable format." "" + , CommandDescr [ ":time" ] ["EXPR"] (ExprArg timeCmd) + "Measure the time it takes to evaluate the given expression." + (unlines + [ "The expression will be evaluated many times to get accurate results." + , "Note that the first evaluation of a binding may take longer due to" + , " laziness, and this may affect the reported time. If this is not" + , " desired then make sure to evaluate the expression once first before" + , " running :time." + , "The amount of time to spend collecting measurements can be changed" + , " with the timeMeasurementPeriod option." + , "Reports the average wall clock time, CPU time, and cycles." + , " (Cycles are in unspecified units that may be CPU cycles.)" + , "Binds the result to" + , " it : { avgTime : Float64" + , " , avgCpuTime : Float64" + , " , avgCycles : Integer }" ]) + + , CommandDescr [ ":set-seed" ] ["SEED"] (OptionArg seedCmd) + "Seed the random number generator for operations using randomness" + (unlines + [ "A seed takes the form of either a single integer or a 4-tuple" + , "of unsigned 64-bit integers. Examples of commands using randomness" + , "are dumpTests and check." + ]) + , CommandDescr [ ":new-seed"] [] (NoArg newSeedCmd) + "Randomly generate and set a new seed for the random number generator" + "" ] commandList :: [CommandDescr] @@ -290,6 +328,23 @@ , "number of tests is determined by the \"tests\" option." ]) "" + , CommandDescr [ ":generate-foreign-header" ] ["FILE"] (FilenameArg genHeaderCmd) + "Generate a C header file from foreign declarations in a Cryptol file." + (unlines + [ "Converts all foreign declarations in the given Cryptol file into C" + , "function declarations, and writes them to a file with the same name" + , "but with a .h extension." ]) + + + , CommandDescr [ ":file-deps" ] [ "FILE" ] + (FilenameArg (moduleInfoCmd True)) + "Show information about the dependencies of a file" + "" + + , CommandDescr [ ":module-deps" ] [ "MODULE" ] + (ModNameArg (moduleInfoCmd False)) + "Show information about the dependencies of a module" + "" ] genHelp :: [CommandDescr] -> [String] @@ -368,14 +423,13 @@ (val, ty) <- replEvalExpr expr ppopts <- getPPValOpts testNum <- getKnownUser "tests" :: REPL Int - g <- io newTFGen tenv <- E.envTypes . M.deEnv <$> getDynEnv let tyv = E.evalValType tenv ty gens <- case TestR.dumpableType tyv of Nothing -> raise (TypeNotTestable ty) Just gens -> return gens - tests <- io $ TestR.returnTests g gens val testNum + tests <- withRandomGen (\g -> io $ TestR.returnTests' g gens val testNum) out <- forM tests $ \(args, x) -> do argOut <- mapM (rEval . E.ppValue Concrete ppopts) args @@ -431,10 +485,17 @@ T.Schema -> REPL TestReport qcExpr qcMode exprDoc texpr schema = - do (val,ty) <- replEvalCheckedExpr texpr schema + do (val,ty) <- replEvalCheckedExpr texpr schema >>= \mb_res -> case mb_res of + Just res -> pure res + -- If instance is not found, doesn't necessarily mean that there is no instance. + -- And due to nondeterminism in result from the solver (for finding solution to + -- numeric type constraints), `:check` can get to this exception sometimes, but + -- successfully find an instance and test with it other times. + Nothing -> raise (InstantiationsNotFound schema) testNum <- (toInteger :: Int -> Integer) <$> getKnownUser "tests" tenv <- E.envTypes . M.deEnv <$> getDynEnv let tyv = E.evalValType tenv ty + -- tv has already had polymorphism instantiated percentRef <- io $ newIORef Nothing testsRef <- io $ newIORef 0 @@ -460,11 +521,11 @@ Just (sz,tys,_,gens) | qcMode == QCRandom -> do rPutStrLn "Using random testing." prt testingMsg - g <- io newTFGen (res,num) <- - Ex.catch (randomTests (\n -> ppProgress percentRef testsRef n testNum) - testNum val gens g) - (\ex -> do rPutStrLn "\nTest interrupted..." + withRandomGen + (randomTests' (\n -> ppProgress percentRef testsRef n testNum) + testNum val gens) + `Ex.catch` (\ex -> do rPutStrLn "\nTest interrupted..." num <- io $ readIORef testsRef let report = TestReport exprDoc Pass num sz ppReport tys False report @@ -801,7 +862,9 @@ printSafetyViolation :: T.Expr -> T.Schema -> [E.GenValue Concrete] -> REPL () printSafetyViolation texpr schema vs = catch - (do (fn,_) <- replEvalCheckedExpr texpr schema + (do fn <- replEvalCheckedExpr texpr schema >>= \mb_res -> case mb_res of + Just (fn, _) -> pure fn + Nothing -> raise (EvalPolyError schema) rEval (E.forceValue =<< foldM (\f v -> E.fromVFun Concrete f (pure v)) fn vs)) (\case EvalError eex -> rPutStrLn (show (pp eex)) @@ -989,6 +1052,32 @@ rPrint $ runDoc fDisp $ group $ hang (ppPrec 2 expr <+> text ":") 2 (pp sig) +timeCmd :: String -> (Int, Int) -> Maybe FilePath -> REPL () +timeCmd str pos fnm = do + period <- getKnownUser "timeMeasurementPeriod" :: REPL Int + quiet <- getKnownUser "timeQuiet" + unless quiet $ + rPutStrLn $ "Measuring for " ++ show period ++ " seconds" + pExpr <- replParseExpr str pos fnm + (_, def, sig) <- replCheckExpr pExpr + replPrepareCheckedExpr def sig >>= \case + Nothing -> raise (EvalPolyError sig) + Just (_, expr) -> do + Bench.BenchmarkStats {..} <- liftModuleCmd + (rethrowEvalError . M.benchmarkExpr (fromIntegral period) expr) + unless quiet $ + rPutStrLn $ "Avg time: " ++ Bench.secs benchAvgTime + ++ " Avg CPU time: " ++ Bench.secs benchAvgCpuTime + ++ " Avg cycles: " ++ show benchAvgCycles + let mkStatsRec time cpuTime cycles = recordFromFields + [("avgTime", time), ("avgCpuTime", cpuTime), ("avgCycles", cycles)] + itType = E.TVRec $ mkStatsRec E.tvFloat64 E.tvFloat64 E.TVInteger + itVal = E.VRecord $ mkStatsRec + (pure $ E.VFloat $ FP.floatFromDouble benchAvgTime) + (pure $ E.VFloat $ FP.floatFromDouble benchAvgCpuTime) + (pure $ E.VInteger $ toInteger benchAvgCycles) + bindItVariableVal itType itVal + readFileCmd :: FilePath -> REPL () readFileCmd fp = do bytes <- replReadFile fp (\err -> rPutStrLn (show err) >> return Nothing) @@ -1062,11 +1151,9 @@ mb <- getLoadedMod case mb of Just lm -> - case lName lm of - Just m | M.isParamInstModName m -> loadHelper (M.loadModuleByName m) - _ -> case lPath lm of - M.InFile f -> loadCmd f - _ -> return () + case lPath lm of + M.InFile f -> loadCmd f + _ -> return () Nothing -> return () @@ -1127,16 +1214,14 @@ | null modString = return () | otherwise = do case parseModName modString of - Just m - | M.isParamInstModName m -> loadHelper (M.loadModuleByName m) - | otherwise -> - do mpath <- liftModuleCmd (M.findModule m) - case mpath of - M.InFile file -> - do setEditPath file - setLoadedMod LoadedModule { lName = Just m, lPath = mpath } - loadHelper (M.loadModuleByPath file) - M.InMem {} -> loadHelper (M.loadModuleByName m) + Just m -> + do mpath <- liftModuleCmd (M.findModule m) + case mpath of + M.InFile file -> + do setEditPath file + setLoadedMod LoadedModule { lName = Just m, lPath = mpath } + loadHelper (M.loadModuleByPath file) + M.InMem {} -> loadHelper (M.loadModuleByName m) Nothing -> rPutStrLn "Invalid module name." loadPrelude :: REPL () @@ -1153,13 +1238,14 @@ } loadHelper (M.loadModuleByPath path) -loadHelper :: M.ModuleCmd (M.ModulePath,T.Module) -> REPL () +loadHelper :: M.ModuleCmd (M.ModulePath,T.TCTopEntity) -> REPL () loadHelper how = do clearLoadedMod - (path,m) <- liftModuleCmd how - whenDebug (rPutStrLn (dump m)) + (path,ent) <- liftModuleCmd how + + whenDebug (rPutStrLn (dump ent)) setLoadedMod LoadedModule - { lName = Just (T.mName m) + { lName = Just (T.tcTopEntitytName ent) , lPath = path } -- after a successful load, the current module becomes the edit target @@ -1168,6 +1254,25 @@ M.InMem {} -> clearEditPath setDynEnv mempty +genHeaderCmd :: FilePath -> REPL () +genHeaderCmd path + | null path = pure () + | otherwise = do + (mPath, m) <- liftModuleCmd $ M.checkModuleByPath path + let decls = case m of + T.TCTopModule mo -> findForeignDecls mo + T.TCTopSignature {} -> [] + if null decls + then rPutStrLn $ "No foreign declarations in " ++ pretty mPath + else do + let header = generateForeignHeader decls + case mPath of + M.InFile p -> do + let hPath = p -<.> "h" + rPutStrLn $ "Writing header to " ++ hPath + replWriteFileString hPath header (rPutStrLn . show) + M.InMem _ _ -> rPutStrLn header + versionCmd :: REPL () versionCmd = displayVersion rPutStrLn @@ -1230,153 +1335,10 @@ cs -> void $ runCommand 1 Nothing (Ambiguous cmd0 (concatMap cNames cs)) | otherwise = case parseHelpName cmd of - Just qname -> - do fe <- getFocusedEnv - let params = M.mctxParams fe - env = M.mctxDecls fe - rnEnv = M.mctxNames fe - disp = M.mctxNameDisp fe - - vNames = M.lookupValNames qname rnEnv - tNames = M.lookupTypeNames qname rnEnv - mNames = M.lookupNS M.NSModule qname rnEnv - - let helps = map (showTypeHelp params env disp) tNames ++ - map (showValHelp params env disp qname) vNames ++ - map (showModHelp env disp) mNames - - separ = rPutStrLn " ---------" - sequence_ (intersperse separ helps) - - when (null (vNames ++ tNames ++ mNames)) $ - rPrint $ "Undefined name:" <+> pp qname - Nothing -> - rPutStrLn ("Unable to parse name: " ++ cmd) + Just qname -> helpForNamed qname + Nothing -> rPutStrLn ("Unable to parse name: " ++ cmd) where - noInfo nameEnv name = - case M.nameInfo name of - M.Declared m _ -> - rPrint $ runDoc nameEnv ("Name defined in module" <+> pp m) - M.Parameter -> rPutStrLn "// No documentation is available." - - - showModHelp _env disp x = - rPrint $ runDoc disp $ vcat [ "`" <> pp x <> "` is a module." ] - -- XXX: show doc. if any - - showTypeHelp params env nameEnv name = - fromMaybe (noInfo nameEnv name) $ - msum [ fromTySyn, fromPrimType, fromNewtype, fromTyParam ] - - where - fromTySyn = - do ts <- Map.lookup name (M.ifTySyns env) - return (doShowTyHelp nameEnv (pp ts) (T.tsDoc ts)) - - fromNewtype = - do nt <- Map.lookup name (M.ifNewtypes env) - let decl = pp nt $$ (pp name <+> text ":" <+> pp (T.newtypeConType nt)) - return $ doShowTyHelp nameEnv decl (T.ntDoc nt) - - fromPrimType = - do a <- Map.lookup name (M.ifAbstractTypes env) - pure $ do rPutStrLn "" - rPrint $ runDoc nameEnv $ nest 4 - $ "primitive type" <+> pp (T.atName a) - <+> ":" <+> pp (T.atKind a) - - let (vs,cs) = T.atCtrs a - unless (null cs) $ - do let example = T.TCon (T.abstractTypeTC a) - (map (T.TVar . T.tpVar) vs) - ns = T.addTNames vs emptyNameMap - rs = [ "•" <+> ppWithNames ns c | c <- cs ] - rPutStrLn "" - rPrint $ runDoc nameEnv $ indent 4 $ - backticks (ppWithNames ns example) <+> - "requires:" $$ indent 2 (vcat rs) - - doShowFix (T.atFixitiy a) - doShowDocString (T.atDoc a) - - fromTyParam = - do p <- Map.lookup name (M.ifParamTypes params) - let uses c = T.TVBound (T.mtpParam p) `Set.member` T.fvs c - ctrs = filter uses (map P.thing (M.ifParamConstraints params)) - ctrDoc = case ctrs of - [] -> [] - [x] -> [pp x] - xs -> [parens $ commaSep $ map pp xs] - decl = vcat $ - [ text "parameter" <+> pp name <+> text ":" - <+> pp (T.mtpKind p) ] - ++ ctrDoc - return $ doShowTyHelp nameEnv decl (T.mtpDoc p) - - doShowTyHelp nameEnv decl doc = - do rPutStrLn "" - rPrint (runDoc nameEnv (nest 4 decl)) - doShowDocString doc - - doShowFix fx = - case fx of - Just f -> - let msg = "Precedence " ++ show (P.fLevel f) ++ ", " ++ - (case P.fAssoc f of - P.LeftAssoc -> "associates to the left." - P.RightAssoc -> "associates to the right." - P.NonAssoc -> "does not associate.") - - in rPutStrLn ('\n' : msg) - - Nothing -> return () - - showValHelp params env nameEnv qname name = - fromMaybe (noInfo nameEnv name) - (msum [ fromDecl, fromNewtype, fromParameter ]) - where - fromDecl = - do M.IfaceDecl { .. } <- Map.lookup name (M.ifDecls env) - return $ - do rPutStrLn "" - - let property - | P.PragmaProperty `elem` ifDeclPragmas = [text "property"] - | otherwise = [] - rPrint $ runDoc nameEnv - $ indent 4 - $ hsep - - $ property ++ [pp qname, colon, pp (ifDeclSig)] - - doShowFix $ ifDeclFixity `mplus` - (guard ifDeclInfix >> return P.defaultFixity) - - doShowDocString ifDeclDoc - - fromNewtype = - do _ <- Map.lookup name (M.ifNewtypes env) - return $ return () - - fromParameter = - do p <- Map.lookup name (M.ifParamFuns params) - return $ - do rPutStrLn "" - rPrint $ runDoc nameEnv - $ indent 4 - $ text "parameter" <+> pp qname - <+> colon - <+> pp (T.mvpType p) - - doShowFix (T.mvpFixity p) - doShowDocString (T.mvpDoc p) - - doShowDocString doc = - case doc of - Nothing -> pure () - Just d -> rPutStrLn ('\n' : T.unpack d) - showCmdHelp c [arg] | ":set" `elem` cNames c = showOptionHelp arg showCmdHelp c _args = do rPutStrLn ("\n " ++ intercalate ", " (cNames c) ++ " " ++ intercalate " " (cArgs c)) @@ -1482,32 +1444,46 @@ } moduleCmdResult =<< io (cmd minp) +-- TODO: add filter for my exhaustie prop guards warning here + moduleCmdResult :: M.ModuleRes a -> REPL a moduleCmdResult (res,ws0) = do - warnDefaulting <- getKnownUser "warnDefaulting" - warnShadowing <- getKnownUser "warnShadowing" + warnDefaulting <- getKnownUser "warnDefaulting" + warnShadowing <- getKnownUser "warnShadowing" + warnPrefixAssoc <- getKnownUser "warnPrefixAssoc" + warnNonExhConGrds <- getKnownUser "warnNonExhaustiveConstraintGuards" -- XXX: let's generalize this pattern - let isDefaultWarn (T.DefaultingTo _ _) = True - isDefaultWarn _ = False - - filterDefaults w | warnDefaulting = Just w - filterDefaults (M.TypeCheckWarnings nameMap xs) = - case filter (not . isDefaultWarn . snd) xs of - [] -> Nothing - ys -> Just (M.TypeCheckWarnings nameMap ys) - filterDefaults w = Just w - - isShadowWarn (M.SymbolShadowed {}) = True + let isShadowWarn (M.SymbolShadowed {}) = True isShadowWarn _ = False - filterShadowing w | warnShadowing = Just w - filterShadowing (M.RenamerWarnings xs) = - case filter (not . isShadowWarn) xs of + isPrefixAssocWarn (M.PrefixAssocChanged {}) = True + isPrefixAssocWarn _ = False + + filterRenamer True _ w = Just w + filterRenamer _ check (M.RenamerWarnings xs) = + case filter (not . check) xs of [] -> Nothing ys -> Just (M.RenamerWarnings ys) - filterShadowing w = Just w + filterRenamer _ _ w = Just w - let ws = mapMaybe filterDefaults . mapMaybe filterShadowing $ ws0 + -- ignore certain warnings during typechecking + filterTypecheck :: M.ModuleWarning -> Maybe M.ModuleWarning + filterTypecheck (M.TypeCheckWarnings nameMap xs) = + case filter (allow . snd) xs of + [] -> Nothing + ys -> Just (M.TypeCheckWarnings nameMap ys) + where + allow :: T.Warning -> Bool + allow = \case + T.DefaultingTo _ _ | not warnDefaulting -> False + T.NonExhaustivePropGuards _ | not warnNonExhConGrds -> False + _ -> True + filterTypecheck w = Just w + + let ws = mapMaybe (filterRenamer warnShadowing isShadowWarn) + . mapMaybe (filterRenamer warnPrefixAssoc isPrefixAssocWarn) + . mapMaybe filterTypecheck + $ ws0 names <- M.mctxNameDisp <$> getFocusedEnv mapM_ (rPrint . runDoc names . pp) ws case res of @@ -1552,39 +1528,47 @@ replEvalExpr :: P.Expr P.PName -> REPL (Concrete.Value, T.Type) replEvalExpr expr = do (_,def,sig) <- replCheckExpr expr - replEvalCheckedExpr def sig + replEvalCheckedExpr def sig >>= \case + Just res -> pure res + Nothing -> raise (EvalPolyError sig) -replEvalCheckedExpr :: T.Expr -> T.Schema -> REPL (Concrete.Value, T.Type) +replEvalCheckedExpr :: T.Expr -> T.Schema -> REPL (Maybe (Concrete.Value, T.Type)) replEvalCheckedExpr def sig = - do validEvalContext def - validEvalContext sig + replPrepareCheckedExpr def sig >>= + traverse \(tys, def1) -> do + let su = T.listParamSubst tys + let ty = T.apSubst su (T.sType sig) + whenDebug (rPutStrLn (dump def1)) - s <- getTCSolver - mbDef <- io (defaultReplExpr s def sig) + tenv <- E.envTypes . M.deEnv <$> getDynEnv + let tyv = E.evalValType tenv ty - (def1,ty) <- - case mbDef of - Nothing -> raise (EvalPolyError sig) - Just (tys,def1) -> - do warnDefaults tys - let su = T.listParamSubst tys - return (def1, T.apSubst su (T.sType sig)) + -- add "it" to the namespace via a new declaration + itVar <- bindItVariable tyv def1 - whenDebug (rPutStrLn (dump def1)) + let itExpr = case getLoc def of + Nothing -> T.EVar itVar + Just rng -> T.ELocated rng (T.EVar itVar) - tenv <- E.envTypes . M.deEnv <$> getDynEnv - let tyv = E.evalValType tenv ty + -- evaluate the it variable + val <- liftModuleCmd (rethrowEvalError . M.evalExpr itExpr) + return (val,ty) - -- add "it" to the namespace via a new declaration - itVar <- bindItVariable tyv def1 +-- | Check that we are in a valid evaluation context and apply defaulting. +replPrepareCheckedExpr :: T.Expr -> T.Schema -> + REPL (Maybe ([(T.TParam, T.Type)], T.Expr)) +replPrepareCheckedExpr def sig = do + validEvalContext def + validEvalContext sig - let itExpr = case getLoc def of - Nothing -> T.EVar itVar - Just rng -> T.ELocated rng (T.EVar itVar) + s <- getTCSolver + mbDef <- io (defaultReplExpr s def sig) - -- evaluate the it variable - val <- liftModuleCmd (rethrowEvalError . M.evalExpr itExpr) - return (val,ty) + case mbDef of + Nothing -> pure Nothing + Just (tys, def1) -> do + warnDefaults tys + pure $ Just (tys, def1) where warnDefaults ts = case ts of @@ -1600,8 +1584,15 @@ itIdent = M.packIdent "it" replWriteFile :: FilePath -> BS.ByteString -> (X.SomeException -> REPL ()) -> REPL () -replWriteFile fp bytes handler = - do x <- io $ X.catch (BS.writeFile fp bytes >> return Nothing) (return . Just) +replWriteFile = replWriteFileWith BS.writeFile + +replWriteFileString :: FilePath -> String -> (X.SomeException -> REPL ()) -> REPL () +replWriteFileString = replWriteFileWith writeFile + +replWriteFileWith :: (FilePath -> a -> IO ()) -> FilePath -> a -> + (X.SomeException -> REPL ()) -> REPL () +replWriteFileWith write fp contents handler = + do x <- io $ X.catch (write fp contents >> return Nothing) (return . Just) maybe (return ()) handler x replReadFile :: FilePath -> (X.SomeException -> REPL (Maybe BS.ByteString)) -> REPL (Maybe BS.ByteString) @@ -1629,7 +1620,7 @@ } liftModuleCmd (M.evalDecls [T.NonRecursive decl]) denv <- getDynEnv - let nenv' = M.singletonE (P.UnQual itIdent) freshIt + let nenv' = M.singletonNS M.NSValue (P.UnQual itIdent) freshIt `M.shadowing` M.deNames denv setDynEnv $ denv { M.deNames = nenv' } return freshIt @@ -1675,7 +1666,32 @@ type CommandMap = Trie CommandDescr +newSeedCmd :: REPL () +newSeedCmd = + do seed <- createAndSetSeed + rPutStrLn "Seed initialized to:" + rPutStrLn (show seed) + where + createAndSetSeed = + withRandomGen $ \g0 -> + let (s1, g1) = TFI.random g0 + (s2, g2) = TFI.random g1 + (s3, g3) = TFI.random g2 + (s4, _) = TFI.random g3 + seed = (s1, s2, s3, s4) + in pure (seed, TF.seedTFGen seed) +seedCmd :: String -> REPL () +seedCmd s = + case mbGen of + Nothing -> rPutStrLn "Could not parse seed argument - expecting an integer or 4-tuple of integers." + Just gen -> setRandomGen gen + + where + mbGen = + (TF.mkTFGen <$> readMaybe s) + <|> (TF.seedTFGen <$> readMaybe s) + -- Command Parsing ------------------------------------------------------------- -- | Strip leading space. @@ -1774,3 +1790,42 @@ '"':rest -> Just $ quoted '"' rest _ -> let (a,b) = break isSpace ipt in if null a then Nothing else Just (length a, a, b) + + + +moduleInfoCmd :: Bool -> String -> REPL () +moduleInfoCmd isFile name + | isFile = showInfo =<< liftModuleCmd (M.getFileDependencies name) + | otherwise = + case parseModName name of + Just m -> showInfo =<< liftModuleCmd (M.getModuleDependencies m) + Nothing -> rPutStrLn "Invalid module name." + + where + showInfo (p,fi) = + do rPutStr "{ \"source\": " + case p of + M.InFile f -> rPutStrLn (show f) + M.InMem l _ -> rPutStrLn ("{ \"internal\": " ++ show l ++ " }") + + rPutStrLn (", \"fingerprint\": \"0x" ++ + fingerprintHexString (M.fiFingerprint fi) ++ "\"") + + let depList f x ys = + do rPutStr (", " ++ show (x :: String) ++ ":") + case ys of + [] -> rPutStrLn " []" + i : is -> + do rPutStrLn "" + rPutStrLn (" [ " ++ f i) + mapM_ (\j -> rPutStrLn (" , " ++ f j)) is + rPutStrLn " ]" + + depList show "includes" (Set.toList (M.fiIncludeDeps fi)) + depList (show . show . pp) "imports" (Set.toList (M.fiImportDeps fi)) + depList show "foreign" (Set.toList (M.fiForeignDeps fi)) + + rPutStrLn "}" + + + diff --git a/src/Cryptol/REPL/Help.hs b/src/Cryptol/REPL/Help.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/REPL/Help.hs @@ -0,0 +1,379 @@ +{-# Language BlockArguments #-} +{-# Language OverloadedStrings #-} +{-# Language RecordWildCards #-} +module Cryptol.REPL.Help (helpForNamed) where + +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Maybe(fromMaybe) +import Data.List(intersperse) +import Control.Monad(when,guard,unless,msum,mplus) + +import Cryptol.Utils.PP +import Cryptol.Utils.Ident(OrigName(..),identIsNormal) +import qualified Cryptol.Parser.AST as P +import qualified Cryptol.ModuleSystem as M +import qualified Cryptol.ModuleSystem.Name as M +import qualified Cryptol.ModuleSystem.NamingEnv as M +import qualified Cryptol.ModuleSystem.Env as M +import qualified Cryptol.ModuleSystem.Interface as M +import qualified Cryptol.ModuleSystem.Renamer.Error as M (ModKind(..)) +import qualified Cryptol.TypeCheck.AST as T +import Cryptol.TypeCheck.PP(emptyNameMap,ppWithNames) + +import Cryptol.REPL.Monad + +helpForNamed :: P.PName -> REPL () +helpForNamed qname = + do fe <- getFocusedEnv + let params = M.mctxParams fe + env = M.mctxDecls fe + rnEnv = M.mctxNames fe + disp = M.mctxNameDisp fe + + vNames = M.lookupListNS M.NSValue qname rnEnv + tNames = M.lookupListNS M.NSType qname rnEnv + mNames = M.lookupListNS M.NSModule qname rnEnv + + let helps = map (showTypeHelp params env disp) tNames ++ + map (showValHelp params env disp qname) vNames ++ + map (showModHelp env disp) mNames + + separ = rPutStrLn " ---------" + sequence_ (intersperse separ helps) + + when (null (vNames ++ tNames ++ mNames)) $ + rPrint $ "Undefined name:" <+> pp qname + + +noInfo :: NameDisp -> M.Name -> REPL () +noInfo nameEnv name = + case M.nameInfo name of + M.GlobalName _ og -> + rPrint (runDoc nameEnv ("Name defined in module" <+> pp (ogModule og))) + M.LocalName {} -> rPutStrLn "// No documentation is available." + + +-- | Show help for something in the module namespace. +showModHelp :: M.IfaceDecls -> NameDisp -> M.Name -> REPL () +showModHelp env nameEnv name = + fromMaybe (noInfo nameEnv name) $ + msum [ attempt M.ifModules showModuleHelp + , attempt M.ifFunctors showFunctorHelp + , attempt M.ifSignatures showSigHelp + ] + + where + attempt :: (M.IfaceDecls -> Map M.Name a) -> + (M.IfaceDecls -> NameDisp -> M.Name -> a -> REPL ()) -> + Maybe (REPL ()) + attempt inMap doShow = + do th <- Map.lookup name (inMap env) + pure (doShow env nameEnv name th) + +showModuleHelp :: + M.IfaceDecls -> NameDisp -> M.Name -> M.IfaceNames M.Name -> REPL () +showModuleHelp env _nameEnv name info = + showSummary M.AModule name (M.ifsDoc info) (ifaceSummary env info) + +ifaceSummary :: M.IfaceDecls -> M.IfaceNames M.Name -> ModSummary +ifaceSummary env info = + foldr addName emptySummary (Set.toList (M.ifsPublic info)) + where + addName x ns = fromMaybe ns + $ msum [ addT <$> msum [fromTS, fromNT, fromAT] + , addV <$> fromD + , addM <$> msum [ fromM, fromS, fromF ] + ] + where + addT (k,d) = ns { msTypes = T.ModTParam { T.mtpName = x + , T.mtpKind = k + , T.mtpDoc = d + } : msTypes ns } + + addV (t,d,f) = ns { msVals = T.ModVParam { T.mvpName = x + , T.mvpType = t + , T.mvpDoc = d + , T.mvpFixity = f + } : msVals ns } + + addM (k,d)= ns { msMods = (x, k, d) : msMods ns } + + + fromTS = do def <- Map.lookup x (M.ifTySyns env) + pure (T.kindOf def, T.tsDoc def) + + fromNT = do def <- Map.lookup x (M.ifNewtypes env) + pure (T.kindOf def, T.ntDoc def) + + fromAT = do def <- Map.lookup x (M.ifAbstractTypes env) + pure (T.kindOf def, T.atDoc def) + + fromD = do def <- Map.lookup x (M.ifDecls env) + pure (M.ifDeclSig def, M.ifDeclDoc def, M.ifDeclFixity def) + + fromM = do def <- Map.lookup x (M.ifModules env) + pure (M.AModule, M.ifsDoc def) + + fromF = do def <- Map.lookup x (M.ifFunctors env) + pure (M.AFunctor, M.ifsDoc (M.ifNames def)) + + fromS = do def <- Map.lookup x (M.ifSignatures env) + pure (M.ASignature, T.mpnDoc def) + + + +showFunctorHelp :: + M.IfaceDecls -> NameDisp -> M.Name -> M.IfaceG M.Name -> REPL () +showFunctorHelp _env _nameEnv name info = + showSummary M.AFunctor name (M.ifsDoc ns) summary + where + ns = M.ifNames info + summary = (ifaceSummary (M.ifDefines info) ns) + { msParams = [ (T.mpName p, T.mpIface p) + | p <- Map.elems (M.ifParams info) + ] + } + + +showSigHelp :: + M.IfaceDecls -> NameDisp -> M.Name -> T.ModParamNames -> REPL () +showSigHelp _env _nameEnv name info = + showSummary M.ASignature name (T.mpnDoc info) + emptySummary + { msTypes = Map.elems (T.mpnTypes info) + , msVals = Map.elems (T.mpnFuns info) + , msConstraints = map P.thing (T.mpnConstraints info) + } + +-------------------------------------------------------------------------------- +data ModSummary = ModSummary + { msParams :: [(P.Ident, P.ImpName M.Name)] + , msConstraints :: [T.Prop] + , msTypes :: [T.ModTParam] + , msVals :: [T.ModVParam] + , msMods :: [ (M.Name, M.ModKind, Maybe Text) ] + } + +emptySummary :: ModSummary +emptySummary = ModSummary + { msParams = [] + , msConstraints = [] + , msTypes = [] + , msVals = [] + , msMods = [] + } + +showSummary :: M.ModKind -> M.Name -> Maybe Text -> ModSummary -> REPL () +showSummary k name doc info = + do rPutStrLn "" + + rPrint $ runDoc disp + case k of + M.AModule -> + vcat [ "Module" <+> pp name <+> "exports:" + , indent 2 $ vcat [ ppTPs, ppFPs ] + ] + M.ASignature -> + vcat [ "Interface" <+> pp name <+> "requires:" + , indent 2 $ vcat [ ppTPs, ppCtrs, ppFPs ] + ] + M.AFunctor -> + vcat [ "Parameterized module" <+> pp name <+> "requires:" + , indent 2 $ ppPs + , " ", "and exports:" + , indent 2 $ vcat [ ppTPs, ppFPs ] + ] + + doShowDocString doc + + where + -- qualifying stuff is too noisy + disp = NameDisp \_ -> Just UnQualified + + withMaybeNest mb x = + case mb of + Nothing -> x + Just d -> vcat [x, indent 2 d] + + withDoc mb = withMaybeNest (pp <$> mb) + withFix mb = withMaybeNest (text . ppFixity <$> mb) + ppMany xs = case xs of + [] -> mempty + _ -> vcat (" " : xs) + + ppPs = ppMany (map ppP (msParams info)) + ppP (x,y) + | identIsNormal x = pp x <+> ": interface" <+> pp y + | otherwise = "(anonymous parameter)" + + + ppTPs = ppMany (map ppTP (msTypes info)) + ppTP x = withDoc (T.mtpDoc x) + $ hsep ["type", pp (T.mtpName x), ":", pp (T.mtpKind x)] + + ppCtrs = ppMany (map pp (msConstraints info)) + + ppFPs = ppMany (map ppFP (msVals info)) + ppFP x = withFix (T.mvpFixity x) + $ withDoc (T.mvpDoc x) + $ hsep [pp (T.mvpName x), ":" <+> pp (T.mvpType x) ] +-------------------------------------------------------------------------------- + + + + +showTypeHelp :: + M.ModContextParams -> M.IfaceDecls -> NameDisp -> T.Name -> REPL () +showTypeHelp ctxparams env nameEnv name = + fromMaybe (noInfo nameEnv name) $ + msum [ fromTySyn, fromPrimType, fromNewtype, fromTyParam ] + + where + fromTySyn = + do ts <- msum [ Map.lookup name (M.ifTySyns env) + , Map.lookup name + (T.mpnTySyn (M.modContextParamNames ctxparams)) + ] + return (doShowTyHelp nameEnv (pp ts) (T.tsDoc ts)) + + fromNewtype = + do nt <- Map.lookup name (M.ifNewtypes env) + let decl = pp nt $$ (pp name <+> text ":" <+> pp (T.newtypeConType nt)) + return $ doShowTyHelp nameEnv decl (T.ntDoc nt) + + fromPrimType = + do a <- Map.lookup name (M.ifAbstractTypes env) + pure $ do rPutStrLn "" + rPrint $ runDoc nameEnv $ nest 4 + $ "primitive type" <+> pp (T.atName a) + <+> ":" <+> pp (T.atKind a) + + let (vs,cs) = T.atCtrs a + unless (null cs) $ + do let example = T.TCon (T.abstractTypeTC a) + (map (T.TVar . T.tpVar) vs) + ns = T.addTNames vs emptyNameMap + rs = [ "•" <+> ppWithNames ns c | c <- cs ] + rPutStrLn "" + rPrint $ runDoc nameEnv $ indent 4 $ + backticks (ppWithNames ns example) <+> + "requires:" $$ indent 2 (vcat rs) + + doShowFix (T.atFixitiy a) + doShowDocString (T.atDoc a) + + allParamNames = + case ctxparams of + M.NoParams -> mempty + M.FunctorParams fparams -> + Map.unions + [ (\x -> (Just p,x)) <$> T.mpnTypes (T.mpParameters ps) + | (p, ps) <- Map.toList fparams + ] + M.InterfaceParams ps -> (\x -> (Nothing ,x)) <$> T.mpnTypes ps + + fromTyParam = + do (x,p) <- Map.lookup name allParamNames + pure do rPutStrLn "" + case x of + Just src -> doShowParameterSource src + Nothing -> pure () + let ty = "type" <+> pp name <+> ":" <+> pp (T.mtpKind p) + rPrint (runDoc nameEnv (indent 4 ty)) + doShowDocString (T.mtpDoc p) + + +doShowTyHelp :: NameDisp -> Doc -> Maybe Text -> REPL () +doShowTyHelp nameEnv decl doc = + do rPutStrLn "" + rPrint (runDoc nameEnv (nest 4 decl)) + doShowDocString doc + + + +showValHelp :: + M.ModContextParams -> M.IfaceDecls -> NameDisp -> P.PName -> T.Name -> REPL () + +showValHelp ctxparams env nameEnv qname name = + fromMaybe (noInfo nameEnv name) + (msum [ fromDecl, fromNewtype, fromParameter ]) + where + fromDecl = + do M.IfaceDecl { .. } <- Map.lookup name (M.ifDecls env) + return $ + do rPutStrLn "" + + let property + | P.PragmaProperty `elem` ifDeclPragmas = [text "property"] + | otherwise = [] + rPrint $ runDoc nameEnv + $ indent 4 + $ hsep + + $ property ++ [pp qname, colon, pp (ifDeclSig)] + + doShowFix $ ifDeclFixity `mplus` + (guard ifDeclInfix >> return P.defaultFixity) + + doShowDocString ifDeclDoc + + fromNewtype = + do _ <- Map.lookup name (M.ifNewtypes env) + return $ return () + + allParamNames = + case ctxparams of + M.NoParams -> mempty + M.FunctorParams fparams -> + Map.unions + [ (\x -> (Just p,x)) <$> T.mpnFuns (T.mpParameters ps) + | (p, ps) <- Map.toList fparams + ] + M.InterfaceParams ps -> (\x -> (Nothing,x)) <$> T.mpnFuns ps + + fromParameter = + do (x,p) <- Map.lookup name allParamNames + pure do rPutStrLn "" + case x of + Just src -> doShowParameterSource src + Nothing -> pure () + let ty = pp name <+> ":" <+> pp (T.mvpType p) + rPrint (runDoc nameEnv (indent 4 ty)) + doShowFix (T.mvpFixity p) + doShowDocString (T.mvpDoc p) + + +doShowParameterSource :: P.Ident -> REPL () +doShowParameterSource i = + do rPutStrLn (Text.unpack msg) + rPutStrLn "" + where + msg + | identIsNormal i = "Provided by module parameter " <> P.identText i <> "." + | otherwise = "Provided by `parameters` declaration." + + +doShowDocString :: Maybe Text -> REPL () +doShowDocString doc = + case doc of + Nothing -> pure () + Just d -> rPutStrLn ('\n' : Text.unpack d) + +ppFixity :: T.Fixity -> String +ppFixity f = "Precedence " ++ show (P.fLevel f) ++ ", " ++ + case P.fAssoc f of + P.LeftAssoc -> "associates to the left." + P.RightAssoc -> "associates to the right." + P.NonAssoc -> "does not associate." + +doShowFix :: Maybe T.Fixity -> REPL () +doShowFix fx = + case fx of + Just f -> rPutStrLn ('\n' : ppFixity f) + Nothing -> return () + + diff --git a/src/Cryptol/REPL/Monad.hs b/src/Cryptol/REPL/Monad.hs --- a/src/Cryptol/REPL/Monad.hs +++ b/src/Cryptol/REPL/Monad.hs @@ -15,6 +15,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Cryptol.REPL.Monad ( -- * REPL Monad @@ -57,6 +58,9 @@ , validEvalContext , updateREPLTitle , setUpdateREPLTitle + , withRandomGen + , setRandomGen + , getRandomGen -- ** Config Options , EnvVal(..) @@ -131,6 +135,7 @@ import Text.Read (readMaybe) import Data.SBV (SBVException) +import qualified System.Random.TF as TF import Prelude () import Prelude.Compat @@ -186,6 +191,9 @@ -- Used as a kind of id for the current solver, which helps avoid -- a race condition where the callback of a dead solver runs after -- a new one has been started. + + , eRandomGen :: TF.TFGen + -- ^ Random number generator for things like QC and dumpTests } @@ -193,6 +201,7 @@ defaultRW :: Bool -> Bool -> Logger -> IO RW defaultRW isBatch callStacks l = do env <- M.initialModuleEnv + rng <- TF.newTFGen let searchPath = M.meSearchPath env let solverConfig = T.defaultSolverConfig searchPath return RW @@ -209,6 +218,7 @@ , eTCConfig = solverConfig , eTCSolver = Nothing , eTCSolverRestarts = 0 + , eRandomGen = rng } -- | Build up the prompt for the REPL. @@ -224,10 +234,11 @@ case lName =<< eLoadedMod rw of Nothing -> show (pp I.preludeName) Just m - | M.isLoadedParamMod m (M.meLoadedModules (eModuleEnv rw)) -> - modName ++ "(parameterized)" + | M.isLoadedParamMod m loaded -> modName ++ "(parameterized)" + | M.isLoadedInterface m loaded -> modName ++ "(interface)" | otherwise -> modName where modName = pretty m + loaded = M.meLoadedModules (eModuleEnv rw) withFocus = case eLoadedMod rw of @@ -329,8 +340,9 @@ | Unsupported Unsupported | ModuleSystemError NameDisp M.ModuleError | EvalPolyError T.Schema + | InstantiationsNotFound T.Schema | TypeNotTestable T.Type - | EvalInParamModule [M.Name] + | EvalInParamModule [T.TParam] [M.Name] | SBVError String | SBVException SBVException | SBVPortfolioException SBVPortfolioException @@ -358,10 +370,13 @@ TooWide e -> pp e EvalPolyError s -> text "Cannot evaluate polymorphic value." $$ text "Type:" <+> pp s + InstantiationsNotFound s -> text "Cannot find instantiations for some type variables." + $$ text "Type:" <+> pp s TypeNotTestable t -> text "The expression is not of a testable type." $$ text "Type:" <+> pp t - EvalInParamModule xs -> nest 2 $ vsep $ + EvalInParamModule as xs -> nest 2 $ vsep $ [ text "Expression depends on definitions from a parameterized module:" ] + ++ map pp as ++ map pp xs SBVError s -> text "SBV error:" $$ text s SBVException e -> text "SBV exception:" $$ text (show e) @@ -552,17 +567,20 @@ let ds = T.freeVars a badVals = foldr badName Set.empty (T.valDeps ds) bad = foldr badName badVals (T.tyDeps ds) + badTs = T.tyParams ds badName nm bs = case M.nameInfo nm of - M.Declared (M.TopModule m) _ -- XXX: can we focus nested modules? - | M.isLoadedParamMod m (M.meLoadedModules me) -> Set.insert nm bs - _ -> bs - unless (Set.null bad) $ - raise (EvalInParamModule (Set.toList bad)) + -- XXX: Changes if focusing on nested modules + M.GlobalName _ I.OrigName { ogModule = I.TopModule m } + | M.isLoadedParamMod m (M.meLoadedModules me) -> Set.insert nm bs + | M.isLoadedInterface m (M.meLoadedModules me) -> Set.insert nm bs + _ -> bs + unless (Set.null bad && Set.null badTs) $ + raise (EvalInParamModule (Set.toList badTs) (Set.toList bad)) -- | Update the title updateREPLTitle :: REPL () @@ -649,7 +667,19 @@ me <- getModuleEnv setModuleEnv (me { M.meDynEnv = denv }) +getRandomGen :: REPL TF.TFGen +getRandomGen = eRandomGen <$> getRW +setRandomGen :: TF.TFGen -> REPL () +setRandomGen rng = modifyRW_ (\s -> s { eRandomGen = rng }) + +withRandomGen :: (TF.TFGen -> REPL (a, TF.TFGen)) -> REPL a +withRandomGen repl = + do g <- getRandomGen + (result, g') <- repl g + setRandomGen g' + pure result + -- | Given an existing qualified name, prefix it with a -- relatively-unique string. We make it unique by prefixing with a -- character @#@ that is not lexically valid in a module name. @@ -657,11 +687,12 @@ uniqify name = case M.nameInfo name of - M.Declared ns s -> + M.GlobalName s og -> M.liftSupply (M.mkDeclared (M.nameNamespace name) - ns s (M.nameIdent name) (M.nameFixity name) (M.nameLoc name)) + (I.ogModule og) s + (M.nameIdent name) (M.nameFixity name) (M.nameLoc name)) - M.Parameter -> + M.LocalName {} -> panic "[REPL] uniqify" ["tried to uniqify a parameter: " ++ pretty name] @@ -895,8 +926,12 @@ "Choose whether to display warnings when defaulting." , simpleOpt "warnShadowing" ["warn-shadowing"] (EnvBool True) noCheck "Choose whether to display warnings when shadowing symbols." + , simpleOpt "warnPrefixAssoc" ["warn-prefix-assoc"] (EnvBool True) noCheck + "Choose whether to display warnings when expression association has changed due to new prefix operator fixities." , simpleOpt "warnUninterp" ["warn-uninterp"] (EnvBool True) noCheck "Choose whether to issue a warning when uninterpreted functions are used to implement primitives in the symbolic simulator." + , simpleOpt "warnNonExhaustiveConstraintGuards" ["warn-nonexhaustive-constraintguards"] (EnvBool True) noCheck + "Choose whether to issue a warning when a use of constraint guards is not determined to be exhaustive." , simpleOpt "smtFile" ["smt-file"] (EnvString "-") noCheck "The file to use for SMT-Lib scripts (for debugging or offline proving).\nUse \"-\" for stdout." , OptionDescr "path" [] (EnvString "") noCheck @@ -978,6 +1013,18 @@ , " * display try to match the order they were written in the source code" , " * canonical use a predictable, canonical order" ] + + , simpleOpt "timeMeasurementPeriod" ["time-measurement-period"] (EnvNum 10) + checkTimeMeasurementPeriod + $ unlines + [ "The period of time in seconds to spend collecting measurements when" + , " running :time." + , "This is a lower bound and the actual time taken might be higher if the" + , " evaluation takes a long time." + ] + + , simpleOpt "timeQuiet" ["time-quiet"] (EnvBool False) noCheck + "Suppress output of :time command and only bind result to `it`." ] @@ -1072,6 +1119,14 @@ _ | Just n <- readMaybe s -> return (SomeSat n) _ -> panic "REPL.Monad.getUserSatNum" [ "invalid satNum option" ] + +checkTimeMeasurementPeriod :: Checker +checkTimeMeasurementPeriod (EnvNum n) + | n >= 1 = noWarns Nothing + | otherwise = noWarns $ + Just "timeMeasurementPeriod must be a positive integer" +checkTimeMeasurementPeriod _ = noWarns $ + Just "unable to parse value for timeMeasurementPeriod" -- Environment Utilities ------------------------------------------------------- diff --git a/src/Cryptol/Symbolic.hs b/src/Cryptol/Symbolic.hs --- a/src/Cryptol/Symbolic.hs +++ b/src/Cryptol/Symbolic.hs @@ -349,7 +349,7 @@ in case res of Left _ -> mismatch -- different fields Right efs -> - let f = foldl (\x t -> ETApp x (tNumValTy t)) (EVar (ntName nt)) ts + let f = foldl (\x t -> ETApp x (tNumValTy t)) (EVar (ntConName nt)) ts in EApp f (ERec efs) (FTRecord tfs, VarRecord vfs) -> diff --git a/src/Cryptol/Symbolic/SBV.hs b/src/Cryptol/Symbolic/SBV.hs --- a/src/Cryptol/Symbolic/SBV.hs +++ b/src/Cryptol/Symbolic/SBV.hs @@ -81,6 +81,7 @@ proverConfigs :: [(String, SBV.SMTConfig)] proverConfigs = [ ("cvc4" , SBV.cvc4 ) + , ("cvc5" , SBV.cvc5 ) , ("yices" , SBV.yices ) , ("z3" , SBV.z3 ) , ("boolector", SBV.boolector) @@ -90,6 +91,7 @@ , ("any" , SBV.defaultSMTCfg ) , ("sbv-cvc4" , SBV.cvc4 ) + , ("sbv-cvc5" , SBV.cvc5 ) , ("sbv-yices" , SBV.yices ) , ("sbv-z3" , SBV.z3 ) , ("sbv-boolector", SBV.boolector) @@ -298,9 +300,11 @@ ProverCommand -> M.ModuleT IO (Either String ([FinType], SBV.Symbolic SBV.SVal)) prepareQuery evo ProverCommand{..} = - do ds <- do (_mp, m) <- M.loadModuleFrom True (M.FromModule preludeReferenceName) + do ds <- do (_mp, ent) <- M.loadModuleFrom True (M.FromModule preludeReferenceName) + let m = tcTopEntityToModule ent + let decls = mDecls m - let nms = fst <$> Map.toList (M.ifDecls (M.ifPublic (M.genIface m))) + let nms = fst <$> Map.toList (M.ifDecls (M.ifDefines (M.genIface m))) let ds = Map.fromList [ (prelPrim (identText (M.nameIdent nm)), EWhere (EVar nm) decls) | nm <- nms ] pure ds @@ -409,7 +413,10 @@ -- otherwise something is wrong _ -> return $ ProverError (rshow results) -#if MIN_VERSION_sbv(8,8,0) +#if MIN_VERSION_sbv(10,0,0) + where rshow | isSat = show . (SBV.AllSatResult False False False) + -- sbv-10.0.0 removes the `allSatHasPrefixExistentials` field +#elif MIN_VERSION_sbv(8,8,0) where rshow | isSat = show . (SBV.AllSatResult False False False False) #else where rshow | isSat = show . SBV.AllSatResult . (False,False,False,) @@ -464,11 +471,19 @@ ProveQuery -> False SafetyQuery -> False SatQuery _ -> True + +#if MIN_VERSION_sbv(10,0,0) + generateSMTBenchmark + | isSat = SBV.generateSMTBenchmarkSat + | otherwise = SBV.generateSMTBenchmarkProof +#else + generateSMTBenchmark = SBV.generateSMTBenchmark isSat +#endif evo <- liftIO (M.minpEvalOpts minp) prepareQuery evo pc >>= \case Left msg -> return (Left msg) - Right (_ts, q) -> Right <$> M.io (SBV.generateSMTBenchmark isSat q) + Right (_ts, q) -> Right <$> M.io (generateSMTBenchmark q) protectStack :: (String -> M.ModuleCmd a) -> M.ModuleCmd a diff --git a/src/Cryptol/Symbolic/What4.hs b/src/Cryptol/Symbolic/What4.hs --- a/src/Cryptol/Symbolic/What4.hs +++ b/src/Cryptol/Symbolic/What4.hs @@ -18,6 +18,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} @@ -37,7 +38,7 @@ import Control.Monad.IO.Class import Control.Monad (when, foldM, forM_, void) import qualified Control.Exception as X -import System.IO (Handle) +import System.IO (Handle, IOMode(..), withFile) import Data.Time import Data.IORef import Data.List (intercalate, tails, inits) @@ -82,6 +83,7 @@ import What4.Solver import qualified What4.Solver.Boolector as W4 import qualified What4.Solver.CVC4 as W4 +import qualified What4.Solver.CVC5 as W4 import qualified What4.Solver.ExternalABC as W4 import qualified What4.Solver.Yices as W4 import qualified What4.Solver.Z3 as W4 @@ -160,6 +162,7 @@ proverConfigs :: [(String, W4ProverConfig)] proverConfigs = [ ("w4-cvc4" , W4ProverConfig cvc4OnlineAdapter) + , ("w4-cvc5" , W4ProverConfig cvc5OnlineAdapter) , ("w4-yices" , W4ProverConfig yicesOnlineAdapter) , ("w4-z3" , W4ProverConfig z3OnlineAdapter) , ("w4-boolector" , W4ProverConfig boolectorOnlineAdapter) @@ -185,6 +188,11 @@ AnOnlineAdapter "CVC4" W4.cvc4Features W4.cvc4Options (Proxy :: Proxy (W4.Writer W4.CVC4)) +cvc5OnlineAdapter :: AnAdapter +cvc5OnlineAdapter = + AnOnlineAdapter "CVC5" W4.cvc5Features W4.cvc5Options + (Proxy :: Proxy (W4.Writer W4.CVC5)) + boolectorOnlineAdapter :: AnAdapter boolectorOnlineAdapter = AnOnlineAdapter "Boolector" W4.boolectorFeatures W4.boolectorOptions @@ -194,6 +202,7 @@ allSolvers = W4Portfolio $ z3OnlineAdapter :| [ cvc4OnlineAdapter + , cvc5OnlineAdapter , boolectorOnlineAdapter , yicesOnlineAdapter , AnAdapter W4.externalABCAdapter @@ -333,9 +342,10 @@ do let lPutStrLn = M.withLogger logPutStrLn when pcVerbose (lPutStrLn "Simulating...") - ds <- do (_mp, m) <- M.loadModuleFrom True (M.FromModule preludeReferenceName) + ds <- do (_mp, ent) <- M.loadModuleFrom True (M.FromModule preludeReferenceName) + let m = tcTopEntityToModule ent let decls = mDecls m - let nms = fst <$> Map.toList (M.ifDecls (M.ifPublic (M.genIface m))) + let nms = fst <$> Map.toList (M.ifDecls (M.ifDefines (M.genIface m))) let ds = Map.fromList [ (prelPrim (identText (M.nameIdent nm)), EWhere (EVar nm) decls) | nm <- nms ] pure ds @@ -373,7 +383,7 @@ ProverCommand -> M.ModuleCmd (Maybe String, ProverResult) -satProve solverCfg hashConsing warnUninterp ProverCommand {..} = +satProve solverCfg hashConsing warnUninterp pc@ProverCommand {..} = protectStack proverError \modIn -> M.runModuleM modIn do w4sym <- liftIO makeSym @@ -414,13 +424,13 @@ Right (ts,args,safety,query) -> case pcQueryType of ProveQuery -> - singleQuery sym solverCfg primMap logData ts args (Just safety) query + singleQuery sym solverCfg pc primMap logData ts args (Just safety) query SafetyQuery -> - singleQuery sym solverCfg primMap logData ts args (Just safety) query + singleQuery sym solverCfg pc primMap logData ts args (Just safety) query SatQuery num -> - multiSATQuery sym solverCfg primMap logData ts args query num + multiSATQuery sym solverCfg pc primMap logData ts args query num printUninterpWarn :: Logger -> Set Text -> IO () printUninterpWarn lg uninterpWarns = @@ -477,6 +487,7 @@ sym ~ W4.ExprBuilder t CryptolState fm => What4 sym -> W4ProverConfig -> + ProverCommand -> PrimMap -> W4.LogData -> [FinType] -> @@ -485,23 +496,24 @@ SatNum -> IO (Maybe String, ProverResult) -multiSATQuery sym solverCfg primMap logData ts args query (SomeSat n) | n <= 1 = - singleQuery sym solverCfg primMap logData ts args Nothing query +multiSATQuery sym solverCfg pc primMap logData ts args query (SomeSat n) | n <= 1 = + singleQuery sym solverCfg pc primMap logData ts args Nothing query -multiSATQuery _sym W4OfflineConfig _primMap _logData _ts _args _query _satNum = +multiSATQuery _sym W4OfflineConfig _pc _primMap _logData _ts _args _query _satNum = fail "What4 offline solver cannot be used for multi-SAT queries" -multiSATQuery _sym (W4Portfolio _) _primMap _logData _ts _args _query _satNum = +multiSATQuery _sym (W4Portfolio _) _pc _primMap _logData _ts _args _query _satNum = fail "What4 portfolio solver cannot be used for multi-SAT queries" -multiSATQuery _sym (W4ProverConfig (AnAdapter adpt)) _primMap _logData _ts _args _query _satNum = +multiSATQuery _sym (W4ProverConfig (AnAdapter adpt)) _pc _primMap _logData _ts _args _query _satNum = fail ("Solver " ++ solver_adapter_name adpt ++ " does not support incremental solving and " ++ "cannot be used for multi-SAT queries.") multiSATQuery sym (W4ProverConfig (AnOnlineAdapter nm fs _opts (_ :: Proxy s))) - primMap _logData ts args query satNum0 = + ProverCommand{..} primMap _logData ts args query satNum0 = + withMaybeFile pcSmtFile WriteMode $ \smtFileHdl -> X.bracket - (W4.startSolverProcess fs Nothing (w4 sym)) + (W4.startSolverProcess fs smtFileHdl (w4 sym)) (void . W4.shutdownSolverProcess) (\ (proc :: W4.SolverProcess t s) -> do W4.assume (W4.solverConn proc) query @@ -627,6 +639,7 @@ sym ~ W4.ExprBuilder t CryptolState fm => What4 sym -> W4ProverConfig -> + ProverCommand -> PrimMap -> W4.LogData -> [FinType] -> @@ -635,12 +648,12 @@ W4.Pred sym -> IO (Maybe String, ProverResult) -singleQuery _ W4OfflineConfig _primMap _logData _ts _args _msafe _query = +singleQuery _ W4OfflineConfig _pc _primMap _logData _ts _args _msafe _query = -- this shouldn't happen... fail "What4 offline solver cannot be used for direct queries" -singleQuery sym (W4Portfolio ps) primMap logData ts args msafe query = - do as <- mapM async [ singleQuery sym (W4ProverConfig p) primMap logData ts args msafe query +singleQuery sym (W4Portfolio ps) pc primMap logData ts args msafe query = + do as <- mapM async [ singleQuery sym (W4ProverConfig p) pc primMap logData ts args msafe query | p <- NE.toList ps ] waitForResults [] as @@ -659,7 +672,7 @@ do forM_ others (\a -> X.throwTo (asyncThreadId a) ExitSuccess) return r -singleQuery sym (W4ProverConfig (AnAdapter adpt)) primMap logData ts args msafe query = +singleQuery sym (W4ProverConfig (AnAdapter adpt)) _pc primMap logData ts args msafe query = do pres <- W4.solver_adapter_check_sat adpt (w4 sym) logData [query] $ \res -> case res of W4.Unknown -> return (ProverError "Solver returned UNKNOWN") @@ -677,9 +690,10 @@ return (Just (W4.solver_adapter_name adpt), pres) singleQuery sym (W4ProverConfig (AnOnlineAdapter nm fs _opts (_ :: Proxy s))) - primMap _logData ts args msafe query = + ProverCommand{..} primMap _logData ts args msafe query = + withMaybeFile pcSmtFile WriteMode $ \smtFileHdl -> X.bracket - (W4.startSolverProcess fs Nothing (w4 sym)) + (W4.startSolverProcess fs smtFileHdl (w4 sym)) (void . W4.shutdownSolverProcess) (\ (proc :: W4.SolverProcess t s) -> do W4.assume (W4.solverConn proc) query @@ -698,6 +712,13 @@ Nothing -> return (Just nm, AllSatResult [ model ]) ) + +-- | Like 'withFile', but lifted to work over 'Maybe'. +withMaybeFile :: Maybe FilePath -> IOMode -> (Maybe Handle -> IO r) -> IO r +withMaybeFile mbFP mode action = + case mbFP of + Just fp -> withFile fp mode (action . Just) + Nothing -> action Nothing computeModelPred :: sym ~ W4.ExprBuilder t CryptolState fm => diff --git a/src/Cryptol/Testing/Random.hs b/src/Cryptol/Testing/Random.hs --- a/src/Cryptol/Testing/Random.hs +++ b/src/Cryptol/Testing/Random.hs @@ -23,8 +23,10 @@ , TestResult(..) , isPass , returnTests +, returnTests' , exhaustiveTests , randomTests +, randomTests' ) where import qualified Control.Exception as X @@ -96,23 +98,32 @@ go _ (_ : _) = panic "Cryptol.Testing.Random" ["Too many arguments to function while generating tests"] go v [] = return v - --- | Return a collection of random tests. returnTests :: RandomGen g => g -- ^ The random generator state -> [Gen g Concrete] -- ^ Generators for the function arguments -> Value -- ^ The function itself -> Int -- ^ How many tests? -> IO [([Value], Value)] -- ^ A list of pairs of random arguments and computed outputs -returnTests g gens fun num = go gens g 0 + -- as well as the new state of the RNG +returnTests g gens fun num = fst <$> returnTests' g gens fun num + +-- | Return a collection of random tests. +returnTests' :: RandomGen g + => g -- ^ The random generator state + -> [Gen g Concrete] -- ^ Generators for the function arguments + -> Value -- ^ The function itself + -> Int -- ^ How many tests? + -> IO ([([Value], Value)], g) -- ^ A list of pairs of random arguments and computed outputs + -- as well as the new state of the RNG +returnTests' g gens fun num = go gens g 0 where go args g0 n - | n >= num = return [] + | n >= num = return ([], g0) | otherwise = do let sz = toInteger (div (100 * (1 + n)) num) (inputs, output, g1) <- returnOneTest fun args sz g0 - more <- go args g1 (n + 1) - return ((inputs, output) : more) + (more, g2) <- go args g1 (n + 1) + return ((inputs, output) : more, g2) {- | Given a (function) type, compute generators for the function's arguments. -} @@ -447,14 +458,23 @@ [Gen g Concrete] {- ^ input value generators -} -> g {- ^ Inital random generator -} -> m (TestResult, Integer) -randomTests ppProgress maxTests val gens = go 0 +randomTests ppProgress maxTests val gens g = fst <$> randomTests' ppProgress maxTests val gens g + +randomTests' :: (MonadIO m, RandomGen g) => + (Integer -> m ()) {- ^ progress callback -} -> + Integer {- ^ Maximum number of tests to run -} -> + Value {- ^ function under test -} -> + [Gen g Concrete] {- ^ input value generators -} -> + g {- ^ Inital random generator -} -> + m ((TestResult, Integer), g) +randomTests' ppProgress maxTests val gens = go 0 where go !testNum g - | testNum >= maxTests = return (Pass, testNum) + | testNum >= maxTests = return ((Pass, testNum), g) | otherwise = do ppProgress testNum let sz' = div (100 * (1 + testNum)) maxTests (res, g') <- liftIO (runOneTest val gens sz' g) case res of Pass -> go (testNum+1) g' - failure -> return (failure, testNum) + failure -> return ((failure, testNum), g) diff --git a/src/Cryptol/Transform/AddModParams.hs b/src/Cryptol/Transform/AddModParams.hs deleted file mode 100644 --- a/src/Cryptol/Transform/AddModParams.hs +++ /dev/null @@ -1,314 +0,0 @@ --- | Transformed a parametrized module into an ordinary module --- where everything is parameterized by the module's parameters. --- Note that this reuses the names from the original parameterized module. -module Cryptol.Transform.AddModParams (addModParams) where - -import Data.Map ( Map ) -import qualified Data.Map as Map -import Data.Set ( Set ) -import qualified Data.Set as Set -import Data.Either(partitionEithers) -import Data.List(find,sortBy) -import Data.Ord(comparing) - -import Cryptol.TypeCheck.AST -import Cryptol.Parser.Position(thing) -import Cryptol.ModuleSystem.Name(toParamInstName,asParamName,nameIdent - ,paramModRecParam) -import Cryptol.Utils.Ident(paramInstModName) -import Cryptol.Utils.RecordMap(recordFromFields) - -{- -Note that we have to be careful when doing this transformation on -polyomorphic values. In particular, - - -Consider type parameters AS, with constraints CS, and value -parameters (xs : TS). - - f : {as} PS => t - f = f`{as} (<> ..) - - ~~> - - f : {AS ++ as} (CS ++ PS) => { TS } -> t - f = /\ (AS ++ as) -> - \\ (CS ++ PS) -> - \r -> f`{AS ++ as} (<> ...) r - -The tricky bit is that we can't just replace `f` with -a new version of `f` with some arguments, instead ew have -to modify the whole instantiation of `f` : f`{as} (<>...) - --} - - -addModParams :: Module -> Either [Name] Module -addModParams m = - case getParams m of - Left errs -> Left errs - Right ps -> - let toInst = Set.unions ( Map.keysSet (mTySyns m) - : Map.keysSet (mNewtypes m) - : map defs (mDecls m) - ) - inp = (toInst, ps { pTypeConstraints = inst inp (pTypeConstraints ps) }) - - in Right m { mName = paramInstModName (mName m) - , mTySyns = fixMap inp (mTySyns m) - , mNewtypes = fixMap inp (mNewtypes m) - , mDecls = fixUp inp (mDecls m) - , mParamTypes = Map.empty - , mParamConstraints = [] - , mParamFuns = Map.empty - } - -defs :: DeclGroup -> Set Name -defs dg = - case dg of - Recursive ds -> Set.fromList (map dName ds) - NonRecursive d -> Set.singleton (dName d) - -fixUp :: (AddParams a, Inst a) => Inp -> a -> a -fixUp i = addParams (snd i) . inst i - -fixMap :: (AddParams a, Inst a) => Inp -> Map Name a -> Map Name a -fixMap i m = - Map.fromList [ (toParamInstName x, fixUp i a) | (x,a) <- Map.toList m ] - --------------------------------------------------------------------------------- - -data Params = Params - { pTypes :: [TParam] - , pTypeConstraints :: [Prop] - , pFuns :: [(Name,Type)] - } - - -getParams :: Module -> Either [Name] Params -getParams m - | null errs = - let ps = Params { pTypes = map rnTP - $ sortBy (comparing mtpNumber) - $ Map.elems - $ mParamTypes m - , pTypeConstraints = map thing (mParamConstraints m) - , pFuns = oks - } - in Right ps - | otherwise = Left errs - where - (errs,oks) = partitionEithers (map checkFunP (Map.toList (mParamFuns m))) - - checkFunP (x,s) = case isMono (mvpType s) of - Just t -> Right (asParamName x, t) - Nothing -> Left x - - rnTP tp = mtpParam tp { mtpName = asParamName (mtpName tp) } - --------------------------------------------------------------------------------- - -class AddParams a where - addParams :: Params -> a -> a - -instance AddParams a => AddParams [a] where - addParams ps = map (addParams ps) - -instance AddParams Schema where - addParams ps s = s { sVars = pTypes ps ++ sVars s - , sProps = pTypeConstraints ps ++ sProps s - , sType = addParams ps (sType s) - } - -instance AddParams Type where - addParams ps t - | null (pFuns ps) = t - | otherwise = tFun (paramRecTy ps) t - - -instance AddParams Expr where - addParams ps e = foldr ETAbs withProps (pTypes ps ++ as) - where (as,rest1) = splitWhile splitTAbs e - (bs,rest2) = splitWhile splitProofAbs rest1 - withProps = foldr EProofAbs withArgs (pTypeConstraints ps ++ bs) - withArgs - | null (pFuns ps) = rest2 - | otherwise = EAbs paramModRecParam (paramRecTy ps) rest2 - - - -instance AddParams DeclGroup where - addParams ps dg = - case dg of - Recursive ds -> Recursive (addParams ps ds) - NonRecursive d -> NonRecursive (addParams ps d) - -instance AddParams Decl where - addParams ps d = - case dDefinition d of - DPrim -> d - DExpr e -> d { dSignature = addParams ps (dSignature d) - , dDefinition = DExpr (addParams ps e) - , dName = toParamInstName (dName d) - } - -instance AddParams TySyn where - addParams ps ts = ts { tsParams = pTypes ps ++ tsParams ts - , tsConstraints = pTypeConstraints ps ++ tsConstraints ts - -- do we need these here ^ ? - , tsName = toParamInstName (tsName ts) - } - -instance AddParams Newtype where - addParams ps nt = nt { ntParams = pTypes ps ++ ntParams nt - , ntConstraints = pTypeConstraints ps ++ ntConstraints nt - , ntName = toParamInstName (ntName nt) - } - - - --------------------------------------------------------------------------------- - - - - - --- | Adjust uses of names to account for the new parameters. --- Assumes unique names---no capture or shadowing. -class Inst a where - inst :: Inp -> a -> a - --- | Set of top-level names which need to be instantiate, and module parameters. -type Inp = (Set Name, Params) - - -paramRecTy :: Params -> Type -paramRecTy ps = tRec (recordFromFields [ (nameIdent x, t) | (x,t) <- pFuns ps ]) - - -nameInst :: Inp -> Name -> [Type] -> Int -> Expr -nameInst (_,ps) x ts prfs - | null (pFuns ps) = withProofs - | otherwise = EApp withProofs (EVar paramModRecParam) - where - withProofs = iterate EProofApp withTys !! - (length (pTypeConstraints ps) + prfs) - - withTys = foldl ETApp (EVar (toParamInstName x)) - (map (TVar . tpVar) (pTypes ps) ++ ts) - - --- | Extra parameters to dd when instantiating a type -instTyParams :: Inp -> [Type] -instTyParams (_,ps) = map (TVar . tpVar) (pTypes ps) - - -needsInst :: Inp -> Name -> Bool -needsInst (xs,_) x = Set.member x xs - -isVParam :: Inp -> Name -> Bool -isVParam (_,ps) x = x `elem` map fst (pFuns ps) - -isTParam :: Inp -> TVar -> Maybe TParam -isTParam (_,ps) x = - case x of - TVBound tp -> find thisName (pTypes ps) - where thisName y = tpName tp == tpName y - _ -> Nothing - - -instance Inst a => Inst [a] where - inst ps = map (inst ps) - -instance Inst Expr where - inst ps expr = - case expr of - EVar x - | needsInst ps x -> nameInst ps x [] 0 - | isVParam ps x -> - let sh = map (nameIdent . fst) (pFuns (snd ps)) - in ESel (EVar paramModRecParam) (RecordSel (nameIdent x) (Just sh)) - | otherwise -> EVar x - - ELocated r t -> ELocated r (inst ps t) - EList es t -> EList (inst ps es) (inst ps t) - ETuple es -> ETuple (inst ps es) - ERec fs -> ERec (fmap (inst ps) fs) - ESel e s -> ESel (inst ps e) s - ESet ty e s v -> ESet (inst ps ty) (inst ps e) s (inst ps v) - - EIf e1 e2 e3 -> EIf (inst ps e1) (inst ps e2) (inst ps e3) - EComp t1 t2 e ms -> EComp (inst ps t1) (inst ps t2) - (inst ps e) (inst ps ms) - - ETAbs x e -> ETAbs x (inst ps e) - ETApp e1 t -> - case splitExprInst expr of - (EVar x, ts, prfs) | needsInst ps x -> nameInst ps x ts prfs - _ -> ETApp (inst ps e1) t - - EApp e1 e2 -> EApp (inst ps e1) (inst ps e2) - EAbs x t e -> EAbs x (inst ps t) (inst ps e) - - EProofAbs p e -> EProofAbs (inst ps p) (inst ps e) - EProofApp e1 -> - case splitExprInst expr of - (EVar x, ts, prfs) | needsInst ps x -> nameInst ps x ts prfs - _ -> EProofApp (inst ps e1) - - EWhere e dgs -> EWhere (inst ps e) (inst ps dgs) - - -instance Inst Match where - inst ps m = - case m of - From x t1 t2 e -> From x (inst ps t1) (inst ps t2) (inst ps e) - Let d -> Let (inst ps d) - -instance Inst DeclGroup where - inst ps dg = - case dg of - Recursive ds -> Recursive (inst ps ds) - NonRecursive d -> NonRecursive (inst ps d) - -instance Inst Decl where - inst ps d = d { dDefinition = inst ps (dDefinition d) } - -instance Inst DeclDef where - inst ps d = - case d of - DPrim -> DPrim - DExpr e -> DExpr (inst ps e) - -instance Inst Type where - inst ps ty = - case ty of - TUser x ts t - | needsInst ps x -> TUser x (instTyParams ps ++ ts1) t1 - | otherwise -> TUser x ts1 t1 - where ts1 = inst ps ts - t1 = inst ps t - - TNewtype nt ts - | needsInst ps (ntName nt) -> TNewtype (inst ps nt) (instTyParams ps ++ ts1) - | otherwise -> TNewtype nt ts1 - where ts1 = inst ps ts - - TCon tc ts -> TCon tc (inst ps ts) - - TVar x | Just x' <- isTParam ps x -> TVar (TVBound x') - | otherwise -> ty - - TRec xs -> TRec (fmap (inst ps) xs) - -instance Inst TySyn where - inst ps ts = ts { tsConstraints = inst ps (tsConstraints ts) - , tsDef = inst ps (tsDef ts) - } - -instance Inst Newtype where - inst ps nt = nt { ntConstraints = inst ps (ntConstraints nt) - , ntFields = fmap (inst ps) (ntFields nt) - } - - diff --git a/src/Cryptol/Transform/MonoValues.hs b/src/Cryptol/Transform/MonoValues.hs --- a/src/Cryptol/Transform/MonoValues.hs +++ b/src/Cryptol/Transform/MonoValues.hs @@ -201,7 +201,9 @@ EWhere e dgs -> EWhere <$> go e <*> inLocal (mapM (rewDeclGroup rews) dgs) + EPropGuards guards ty -> EPropGuards <$> (\(props, e) -> (,) <$> pure props <*> go e) `traverse` guards <*> pure ty + rewM :: RewMap -> Match -> M Match rewM rews ma = case ma of @@ -216,8 +218,9 @@ return d { dDefinition = e } rewDef :: RewMap -> DeclDef -> M DeclDef -rewDef rews (DExpr e) = DExpr <$> rewE rews e -rewDef _ DPrim = return DPrim +rewDef rews (DExpr e) = DExpr <$> rewE rews e +rewDef _ DPrim = return DPrim +rewDef _ (DForeign t) = return $ DForeign t rewDeclGroup :: RewMap -> DeclGroup -> M DeclGroup rewDeclGroup rews dg = @@ -237,11 +240,12 @@ consider d = case dDefinition d of - DPrim -> Left d - DExpr e -> let (tps,props,e') = splitTParams e - in if not (null tps) && notFun e' - then Right (d, tps, props, e') - else Left d + DPrim -> Left d + DForeign _ -> Left d + DExpr e -> let (tps,props,e') = splitTParams e + in if not (null tps) && notFun e' + then Right (d, tps, props, e') + else Left d rewSame ds = do new <- forM (NE.toList ds) $ \(d,_,_,e) -> diff --git a/src/Cryptol/Transform/Specialize.hs b/src/Cryptol/Transform/Specialize.hs --- a/src/Cryptol/Transform/Specialize.hs +++ b/src/Cryptol/Transform/Specialize.hs @@ -19,13 +19,18 @@ import qualified Cryptol.ModuleSystem.Env as M import qualified Cryptol.ModuleSystem.Monad as M import Cryptol.ModuleSystem.Name +import Cryptol.Utils.Ident(OrigName(..)) +import Cryptol.Eval (checkProp) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (catMaybes) +import qualified Data.List as List import MonadLib hiding (mapM) +import Cryptol.ModuleSystem.Base (getPrimMap) + -- Specializer Monad ----------------------------------------------------------- -- | A 'Name' should have an entry in the 'SpecCache' iff it is @@ -102,7 +107,17 @@ EProofAbs p e -> EProofAbs p <$> specializeExpr e EProofApp {} -> specializeConst expr EWhere e dgs -> specializeEWhere e dgs + -- The type should be monomorphic, and the guarded expressions should + -- already be normalized, so we just need to choose the first expression + -- that's true. + EPropGuards guards ty -> + case List.find (all checkProp . fst) guards of + Just (_, e) -> specializeExpr e + Nothing -> do + pm <- liftSpecT getPrimMap + pure $ eError pm ty "no constraint guard was satisfied" + specializeMatch :: Match -> SpecM Match specializeMatch (From qn l t e) = From qn l t <$> specializeExpr e specializeMatch (Let decl) @@ -187,9 +202,10 @@ sig' <- instantiateSchema ts n (dSignature decl) modifySpecCache (Map.adjust (fmap (insertTM ts (qname', Nothing))) qname) rhs' <- case dDefinition decl of - DExpr e -> do e' <- specializeExpr =<< instantiateExpr ts n e - return (DExpr e') - DPrim -> return DPrim + DExpr e -> do e' <- specializeExpr =<< instantiateExpr ts n e + return (DExpr e') + DPrim -> return DPrim + DForeign t -> return $ DForeign t let decl' = decl { dName = qname', dSignature = sig', dDefinition = rhs' } modifySpecCache (Map.adjust (fmap (insertTM ts (qname', Just decl'))) qname) return (EVar qname') @@ -245,8 +261,8 @@ freshName :: Name -> [Type] -> SpecM Name freshName n _ = case nameInfo n of - Declared m s -> liftSupply (mkDeclared ns m s ident fx loc) - Parameter -> liftSupply (mkParameter ns ident loc) + GlobalName s og -> liftSupply (mkDeclared ns (ogModule og) s ident fx loc) + LocalName {} -> liftSupply (mkLocal ns ident loc) where ns = nameNamespace n fx = nameFixity n diff --git a/src/Cryptol/TypeCheck.hs b/src/Cryptol/TypeCheck.hs --- a/src/Cryptol/TypeCheck.hs +++ b/src/Cryptol/TypeCheck.hs @@ -9,7 +9,6 @@ module Cryptol.TypeCheck ( tcModule - , tcModuleInst , tcExpr , tcDecls , InferInput(..) @@ -28,12 +27,10 @@ , ppNamedError ) where -import Data.IORef(IORef,modifyIORef') import Data.Map(Map) import Cryptol.ModuleSystem.Name (liftSupply,mkDeclared,NameSource(..),ModPath(..)) -import Cryptol.ModuleSystem.NamingEnv(NamingEnv,namingEnvRename) import qualified Cryptol.Parser.AST as P import Cryptol.Parser.Position(Range,emptyRange) import Cryptol.TypeCheck.AST @@ -46,14 +43,10 @@ , nameSeeds , lookupVar , newLocalScope, endLocalScope - , newModuleScope, addParamType, addParameterConstraints - , endModuleInstance - , io ) -import Cryptol.TypeCheck.Infer (inferModule, inferBinds, checkTopDecls) +import Cryptol.TypeCheck.Infer (inferTopModule, inferBinds, checkTopDecls) import Cryptol.TypeCheck.InferTypes(VarType(..), SolverConfig(..), defaultSolverConfig) import Cryptol.TypeCheck.Solve(proveModuleTopLevel) -import Cryptol.TypeCheck.CheckModuleInstance(checkModuleInstance) -- import Cryptol.TypeCheck.Monad(withParamType,withParameterConstraints) import Cryptol.TypeCheck.PP(WithNames(..),NameMap) import Cryptol.Utils.Ident (exprModName,packIdent,Namespace(..)) @@ -62,27 +55,8 @@ -tcModule :: P.Module Name -> InferInput -> IO (InferOutput Module) -tcModule m inp = runInferM inp (inferModule m) - --- | Check a module instantiation, assuming that the functor has already --- been checked. --- XXX: This will change -tcModuleInst :: IORef NamingEnv {- ^ renaming environment of functor -} -> - Module {- ^ functor -} -> - P.Module Name {- ^ params -} -> - InferInput {- ^ TC settings -} -> - IO (InferOutput Module) {- ^ new version of instance -} -tcModuleInst renThis func m inp = runInferM inp $ - do x <- inferModule m - newModuleScope (mName func) [] mempty - mapM_ addParamType (mParamTypes x) - addParameterConstraints (mParamConstraints x) - (ren,y) <- checkModuleInstance func x - io $ modifyIORef' renThis (namingEnvRename ren) - proveModuleTopLevel - endModuleInstance - pure y +tcModule :: P.Module Name -> InferInput -> IO (InferOutput TCTopEntity) +tcModule m inp = runInferM inp (inferTopModule m) tcExpr :: P.Expr Name -> InferInput -> IO (InferOutput (Expr,Schema)) tcExpr e0 inp = runInferM inp diff --git a/src/Cryptol/TypeCheck/AST.hs b/src/Cryptol/TypeCheck/AST.hs --- a/src/Cryptol/TypeCheck/AST.hs +++ b/src/Cryptol/TypeCheck/AST.hs @@ -13,12 +13,14 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} module Cryptol.TypeCheck.AST ( module Cryptol.TypeCheck.AST , Name() , TFun(..) , Selector(..) - , Import, ImportG(..) + , Import, ImportG(..), ImpName(..) , ImportSpec(..) , ExportType(..) , ExportSpec(..), isExportedBind, isExportedType, isExported @@ -28,6 +30,10 @@ , module Cryptol.TypeCheck.Type ) where +import Data.Maybe(mapMaybe) + +import Cryptol.Utils.Panic(panic) +import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,PrimIdent,prelPrim) import Cryptol.Parser.Position(Located,Range,HasLoc(..)) import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.Interface @@ -36,72 +42,124 @@ import Cryptol.Parser.AST ( Selector(..),Pragma(..) , Import , ImportG(..), ImportSpec(..), ExportType(..) - , Fixity(..)) -import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,PrimIdent,prelPrim) + , Fixity(..) + , ImpName(..) + ) import Cryptol.Utils.RecordMap +import Cryptol.TypeCheck.FFI.FFIType import Cryptol.TypeCheck.PP import Cryptol.TypeCheck.Type import GHC.Generics (Generic) import Control.DeepSeq + +import Data.Set (Set) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Data.Text (Text) +data TCTopEntity = + TCTopModule (ModuleG ModName) + | TCTopSignature ModName ModParamNames + deriving (Show, Generic, NFData) + +tcTopEntitytName :: TCTopEntity -> ModName +tcTopEntitytName ent = + case ent of + TCTopModule m -> mName m + TCTopSignature m _ -> m + +-- | Panics if the entity is not a module +tcTopEntityToModule :: TCTopEntity -> Module +tcTopEntityToModule ent = + case ent of + TCTopModule m -> m + TCTopSignature {} -> panic "tcTopEntityToModule" [ "Not a module" ] + + -- | A Cryptol module. data ModuleG mname = Module { mName :: !mname + , mDoc :: !(Maybe Text) , mExports :: ExportSpec Name - , mImports :: [Import] - {-| Interfaces of submodules, including functors. - This is only the directly nested modules. - Info about more nested modules is in the - corresponding interface. -} - , mSubModules :: Map Name (IfaceG Name) - - -- params, if functor + -- Functors: , mParamTypes :: Map Name ModTParam - , mParamConstraints :: [Located Prop] , mParamFuns :: Map Name ModVParam + , mParamConstraints :: [Located Prop] + , mParams :: FunctorParams + -- ^ Parameters grouped by "import". - -- Declarations, including everything from non-functor - -- submodules + , mFunctors :: Map Name (ModuleG Name) + -- ^ Functors directly nested in this module. + -- Things further nested are in the modules in the + -- elements of the map. + + + , mNested :: !(Set Name) + -- ^ Submodules, functors, and interfaces nested directly + -- in this module + + -- These have everything from this module and all submodules , mTySyns :: Map Name TySyn , mNewtypes :: Map Name Newtype , mPrimTypes :: Map Name AbstractType , mDecls :: [DeclGroup] - , mFunctors :: Map Name (ModuleG Name) + , mSubmodules :: Map Name (IfaceNames Name) + , mSignatures :: !(Map Name ModParamNames) } deriving (Show, Generic, NFData) emptyModule :: mname -> ModuleG mname emptyModule nm = Module { mName = nm + , mDoc = Nothing , mExports = mempty - , mImports = [] - , mSubModules = mempty + , mParams = mempty , mParamTypes = mempty , mParamConstraints = mempty , mParamFuns = mempty + , mNested = mempty + , mTySyns = mempty , mNewtypes = mempty , mPrimTypes = mempty , mDecls = mempty , mFunctors = mempty + , mSubmodules = mempty + , mSignatures = mempty } +-- | Find all the foreign declarations in the module and return their names and FFIFunTypes. +findForeignDecls :: ModuleG mname -> [(Name, FFIFunType)] +findForeignDecls = mapMaybe getForeign . mDecls + where getForeign (NonRecursive Decl { dName, dDefinition = DForeign ffiType }) + = Just (dName, ffiType) + -- Recursive DeclGroups can't have foreign decls + getForeign _ = Nothing + +-- | Find all the foreign declarations that are in functors. +-- This is used to report an error +findForeignDeclsInFunctors :: ModuleG mname -> [Name] +findForeignDeclsInFunctors = concatMap fromM . Map.elems . mFunctors + where + fromM m = map fst (findForeignDecls m) ++ findForeignDeclsInFunctors m + + + + type Module = ModuleG ModName -- | Is this a parameterized module? isParametrizedModule :: ModuleG mname -> Bool -isParametrizedModule m = not (null (mParamTypes m) && +isParametrizedModule m = not (null (mParams m) && + null (mParamTypes m) && null (mParamConstraints m) && null (mParamFuns m)) @@ -149,6 +207,8 @@ | EWhere Expr [DeclGroup] + | EPropGuards [([Prop], Expr)] Type + deriving (Show, Generic, NFData) @@ -178,6 +238,7 @@ } deriving (Generic, NFData, Show) data DeclDef = DPrim + | DForeign FFIFunType | DExpr Expr deriving (Show, Generic, NFData) @@ -202,7 +263,14 @@ where v = fromEnum c w = 8 :: Int +instance PP TCTopEntity where + ppPrec _ te = + case te of + TCTopModule m -> pp m + TCTopSignature x p -> + ("interface" <+> pp x <+> "where") $$ nest 2 (pp p) + instance PP (WithNames Expr) where ppPrec prec (WithNames expr nm) = case expr of @@ -266,6 +334,12 @@ , hang "where" 2 (vcat (map ppW ds)) ] + EPropGuards guards _ -> + parens (text "propguards" <+> vsep (ppGuard <$> guards)) + where ppGuard (props, e) = indent 1 + $ pipe <+> commaSep (ppW <$> props) + <+> text "=>" <+> ppW e + where ppW x = ppWithNames nm x ppWP x = ppWithNamesPrec nm x @@ -296,24 +370,38 @@ Just (x,e1) -> let (xs,e2) = splitWhile f e1 in (x:xs,e2) +splitLoc :: Expr -> Maybe (Range, Expr) +splitLoc expr = + case expr of + ELocated r e -> Just (r,e) + _ -> Nothing + +-- | Remove outermost locations +dropLocs :: Expr -> Expr +dropLocs = snd . splitWhile splitLoc + splitAbs :: Expr -> Maybe ((Name,Type), Expr) -splitAbs (EAbs x t e) = Just ((x,t), e) -splitAbs _ = Nothing +splitAbs (dropLocs -> EAbs x t e) = Just ((x,t), e) +splitAbs _ = Nothing +splitApp :: Expr -> Maybe (Expr,Expr) +splitApp (dropLocs -> EApp f a) = Just (a, f) +splitApp _ = Nothing + splitTAbs :: Expr -> Maybe (TParam, Expr) -splitTAbs (ETAbs t e) = Just (t, e) -splitTAbs _ = Nothing +splitTAbs (dropLocs -> ETAbs t e) = Just (t, e) +splitTAbs _ = Nothing splitProofAbs :: Expr -> Maybe (Prop, Expr) -splitProofAbs (EProofAbs p e) = Just (p,e) -splitProofAbs _ = Nothing +splitProofAbs (dropLocs -> EProofAbs p e) = Just (p,e) +splitProofAbs _ = Nothing splitTApp :: Expr -> Maybe (Type,Expr) -splitTApp (ETApp e t) = Just (t, e) -splitTApp _ = Nothing +splitTApp (dropLocs -> ETApp e t) = Just (t, e) +splitTApp _ = Nothing splitProofApp :: Expr -> Maybe ((), Expr) -splitProofApp (EProofApp e) = Just ((), e) +splitProofApp (dropLocs -> EProofApp e) = Just ((), e) splitProofApp _ = Nothing -- | Deconstruct an expression, typically polymorphic, into @@ -368,8 +456,9 @@ ++ [ nest 2 (sep [pp dName <+> text "=", ppWithNames nm dDefinition]) ] instance PP (WithNames DeclDef) where - ppPrec _ (WithNames DPrim _) = text "" - ppPrec _ (WithNames (DExpr e) nm) = ppWithNames nm e + ppPrec _ (WithNames DPrim _) = text "" + ppPrec _ (WithNames (DForeign _) _) = text "" + ppPrec _ (WithNames (DExpr e) nm) = ppWithNames nm e instance PP Decl where ppPrec = ppWithNamesPrec IntMap.empty @@ -379,10 +468,21 @@ instance PP n => PP (WithNames (ModuleG n)) where ppPrec _ (WithNames Module { .. } nm) = - text "module" <+> pp mName $$ - -- XXX: Print exports? - vcat (map pp mImports) $$ - -- XXX: Print tysyns - -- XXX: Print abstarct types/functions - vcat (map (ppWithNames (addTNames mps nm)) mDecls) + vcat [ text "module" <+> pp mName + -- XXX: Print exports? + , vcat (map pp' (Map.elems mTySyns)) + -- XXX: Print abstarct types/functions + , vcat (map pp' mDecls) + + , vcat (map pp (Map.elems mFunctors)) + ] where mps = map mtpParam (Map.elems mParamTypes) + pp' :: PP (WithNames a) => a -> Doc + pp' = ppWithNames (addTNames mps nm) + +instance PP (WithNames TCTopEntity) where + ppPrec _ (WithNames ent nm) = + case ent of + TCTopModule m -> ppWithNames nm m + TCTopSignature n ps -> + hang ("interface module" <+> pp n <+> "where") 2 (pp ps) diff --git a/src/Cryptol/TypeCheck/CheckModuleInstance.hs b/src/Cryptol/TypeCheck/CheckModuleInstance.hs deleted file mode 100644 --- a/src/Cryptol/TypeCheck/CheckModuleInstance.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# Language OverloadedStrings #-} --- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module Cryptol.TypeCheck.CheckModuleInstance (checkModuleInstance) where - -import Data.Map ( Map ) -import qualified Data.Map as Map -import Control.Monad(unless) - -import Cryptol.Parser.Position(Located(..)) -import qualified Cryptol.Parser.AST as P -import Cryptol.ModuleSystem.Name (nameIdent, nameLoc) -import Cryptol.ModuleSystem.InstantiateModule(instantiateModule) -import Cryptol.TypeCheck.AST -import Cryptol.TypeCheck.Monad -import Cryptol.TypeCheck.Infer -import Cryptol.TypeCheck.Subst -import Cryptol.TypeCheck.Error -import Cryptol.Utils.Panic - - --- | Check that the instance provides what the functor needs. -checkModuleInstance :: Module {- ^ type-checked functor -} -> - Module {- ^ type-checked instance -} -> - InferM (Name->Name,Module) - -- ^ Renaming,Instantiated module -checkModuleInstance func inst - | not (null (mSubModules func) && null (mSubModules inst)) = - do recordError $ TemporaryError - "Cannot combine nested modules with old-style parameterized modules" - pure (id,func) -- doesn't matter? - | otherwise = - do tMap <- checkTyParams func inst - vMap <- checkValParams func tMap inst - (ren, ctrs, m) <- instantiateModule func (mName inst) tMap vMap - let toG p = Goal { goal = thing p - , goalRange = srcRange p - , goalSource = CtModuleInstance (mName inst) - } - addGoals (map toG ctrs) - return ( ren - , Module { mName = mName m - , mExports = mExports m - , mImports = mImports inst ++ mImports m - -- Note that this is just here to record - -- the full dependencies, the actual imports - -- might be ambiguous, but that shouldn't - -- matters as names have been already resolved - , mTySyns = Map.union (mTySyns inst) (mTySyns m) - , mNewtypes = Map.union (mNewtypes inst) (mNewtypes m) - , mPrimTypes = Map.union (mPrimTypes inst) (mPrimTypes m) - , mParamTypes = mParamTypes inst - , mParamConstraints = mParamConstraints inst - , mParamFuns = mParamFuns inst - , mDecls = mDecls inst ++ mDecls m - - , mSubModules = mempty - , mFunctors = mempty - } - ) - --- | Check that the type parameters of the functors all have appropriate --- definitions. -checkTyParams :: Module -> Module -> InferM (Map TParam Type) -checkTyParams func inst = - Map.fromList <$> mapM checkTParamDefined (Map.elems (mParamTypes func)) - - where - -- Maps to lookup things by identifier (i.e., lexical name) - -- rather than using the name unique. - identMap f m = Map.fromList [ (f x, ts) | (x,ts) <- Map.toList m ] - tySyns = identMap nameIdent (mTySyns inst) - newTys = identMap nameIdent (mNewtypes inst) - tParams = Map.fromList [ (tpId x, x) | x0 <- Map.elems (mParamTypes inst) - , let x = mtpParam x0 ] - - tpName' x = case tpName x of - Just n -> n - Nothing -> panic "inferModuleInstance.tpId" ["Missing name"] - - tpId = nameIdent . tpName' - - -- Find a definition for a given type parameter - checkTParamDefined tp0 = - let tp = mtpParam tp0 - x = tpId tp - in case Map.lookup x tySyns of - Just ts -> checkTySynDef tp ts - Nothing -> - case Map.lookup x newTys of - Just nt -> checkNewTyDef tp nt - Nothing -> - case Map.lookup x tParams of - Just tp1 -> checkTP tp tp1 - Nothing -> - do let x' = Located { thing = x, - srcRange = nameLoc (tpName' tp) } - recordError (MissingModTParam x') - return (tp, TVar (TVBound tp)) -- hm, maybe just stop! - - -- Check that a type parameter defined as a type synonym is OK - checkTySynDef tp ts = - do let k1 = kindOf tp - k2 = kindOf ts - unless (k1 == k2) (recordError (KindMismatch Nothing k1 k2)) - - let nm = tsName ts - src = CtPartialTypeFun nm - mapM_ (newGoal src) (tsConstraints ts) - - return (tp, TUser nm [] (tsDef ts)) - - -- Check that a type parameter defined a newtype is OK - -- This one is a bit weird: since the newtype is deinfed in the - -- instantiation, it will not be exported, and so won't be usable - -- in type signatures, directly. This could be worked around - -- if the parametrized module explictly exported a parameter via - -- a type synonym like this: `type T = p`, where `p` is one of - -- the parametersm and the declartion for `T` is public. - checkNewTyDef tp nt = - do let k1 = kindOf tp - k2 = kindOf nt - unless (k1 == k2) (recordError (KindMismatch Nothing k1 k2)) - - let nm = ntName nt - src = CtPartialTypeFun nm - mapM_ (newGoal src) (ntConstraints nt) - - return (tp, TNewtype nt []) - - -- Check that a type parameter defined as another type parameter is OK - checkTP tp tp1 = - do let k1 = kindOf tp - k2 = kindOf tp1 - unless (k1 == k2) (recordError (KindMismatch Nothing k1 k2)) - - return (tp, TVar (TVBound tp1)) - - - - -checkValParams :: Module {- ^ Parameterized module -} -> - Map TParam Type {- ^ Type instantiations -} -> - Module {- ^ Instantiation module -} -> - InferM (Map Name Expr) - -- ^ Definitions for the parameters -checkValParams func tMap inst = - Map.fromList <$> mapM checkParam (Map.elems (mParamFuns func)) - where - valMap = Map.fromList (defByParam ++ defByDef) - - defByDef = [ (nameIdent (dName d), (dName d, dSignature d)) - | dg <- mDecls inst, d <- groupDecls dg ] - - defByParam = [ (nameIdent x, (x, mvpType s)) | - (x,s) <- Map.toList (mParamFuns inst) ] - - su = listParamSubst (Map.toList tMap) - - checkParam pr = - let x = mvpName pr - sP = mvpType pr - in - case Map.lookup (nameIdent x) valMap of - Just (n,sD) -> do e <- makeValParamDef n sD (apSubst su sP) - return (x,e) - Nothing -> do recordError (MissingModVParam - Located { thing = nameIdent x - , srcRange = nameLoc x }) - return (x, panic "checkValParams" ["Should not use this"]) - - - --- | Given a parameter definition, compute an appropriate instantiation --- that will match the actual schema for the parameter. -makeValParamDef :: Name {- ^ Definition of parameter -} -> - Schema {- ^ Schema for parameter definition -} -> - Schema {- ^ Schema for parameter -} -> - InferM Expr {- ^ Expression to use for param definition -} - -makeValParamDef x sDef pDef = - withVar x sDef $ do ~(DExpr e) <- dDefinition <$> checkSigB bnd (pDef,[]) - return e - where - bnd = P.Bind { P.bName = loc x - , P.bParams = [] - , P.bDef = loc (P.DExpr (P.EVar x)) - - -- unused - , P.bSignature = Nothing - , P.bInfix = False - , P.bFixity = Nothing - , P.bPragmas = [] - , P.bMono = False - , P.bDoc = Nothing - , P.bExport = Public - } - loc a = P.Located { P.srcRange = nameLoc x, P.thing = a } - - - diff --git a/src/Cryptol/TypeCheck/Default.hs b/src/Cryptol/TypeCheck/Default.hs --- a/src/Cryptol/TypeCheck/Default.hs +++ b/src/Cryptol/TypeCheck/Default.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Safe #-} + module Cryptol.TypeCheck.Default where import qualified Data.Set as Set diff --git a/src/Cryptol/TypeCheck/Error.hs b/src/Cryptol/TypeCheck/Error.hs --- a/src/Cryptol/TypeCheck/Error.hs +++ b/src/Cryptol/TypeCheck/Error.hs @@ -12,15 +12,16 @@ import Data.List((\\),sortBy,groupBy,partition) import Data.Function(on) +import Cryptol.Utils.Ident(Ident,Namespace(..)) import qualified Cryptol.Parser.AST as P -import Cryptol.Parser.Position(Located(..), Range(..)) +import Cryptol.Parser.Position(Located(..), Range(..), rangeWithin) import Cryptol.TypeCheck.PP import Cryptol.TypeCheck.Type import Cryptol.TypeCheck.InferTypes import Cryptol.TypeCheck.Subst import Cryptol.TypeCheck.Unify(Path,isRootPath) +import Cryptol.TypeCheck.FFI.Error import Cryptol.ModuleSystem.Name(Name) -import Cryptol.Utils.Ident(Ident) import Cryptol.Utils.RecordMap cleanupErrors :: [(Range,Error)] -> [(Range,Error)] @@ -56,6 +57,8 @@ -- | Should the first error suppress the next one. subsumes :: (Range,Error) -> (Range,Error) -> Bool subsumes (_,NotForAll _ _ x _) (_,NotForAll _ _ y _) = x == y +subsumes (r1,UnexpectedTypeWildCard) (r2,UnsupportedFFIType{}) = + r1 `rangeWithin` r2 subsumes (r1,KindMismatch {}) (r2,err) = case err of KindMismatch {} -> r1 == r2 @@ -65,6 +68,7 @@ data Warning = DefaultingKind (P.TParam Name) P.Kind | DefaultingWildType P.Kind | DefaultingTo !TVarInfo Type + | NonExhaustivePropGuards Name deriving (Show, Generic, NFData) -- | Various errors that might happen during type checking/inference @@ -90,6 +94,10 @@ | TypeMismatch TypeSource Path Type Type -- ^ Expected type, inferred type + | SchemaMismatch Ident Schema Schema + -- ^ Name of module parameter, expected scehema, actual schema. + -- This may happen when instantiating modules. + | RecursiveType TypeSource Path Type Type -- ^ Unification results in a recursive type @@ -142,7 +150,28 @@ | TypeShadowing String Name String | MissingModTParam (Located Ident) | MissingModVParam (Located Ident) + | MissingModParam Ident + | FunctorInstanceMissingArgument Ident + | FunctorInstanceBadArgument Ident + | FunctorInstanceMissingName Namespace Ident + | FunctorInstanceBadBacktick BadBacktickInstance + + | UnsupportedFFIKind TypeSource TParam Kind + -- ^ Kind is not supported for FFI + | UnsupportedFFIType TypeSource FFITypeError + -- ^ Type is not supported for FFI + + | NestedConstraintGuard Ident + -- ^ Constraint guards may only apper at the top-level + + | DeclarationRequiresSignatureCtrGrd Ident + -- ^ All declarataions in a recursive group involving + -- constraint guards should have signatures + + | InvalidConstraintGuard Prop + -- ^ The given constraint may not be used as a constraint guard + | TemporaryError Doc -- ^ This is for errors that don't fit other cateogories. -- We should not use it much, and is generally to be used @@ -150,6 +179,15 @@ -- implementation. deriving (Show, Generic, NFData) +data BadBacktickInstance = + BIPolymorphicArgument Ident Ident + | BINested [(BIWhat, Name)] + | BIMultipleParams Ident + deriving (Show, Generic, NFData) + +data BIWhat = BIFunctor | BIInterface | BIPrimitive | BIForeign | BIAbstractType + deriving (Show, Generic, NFData) + -- | When we have multiple errors on the same location, we show only the -- ones with the has highest rating according to this function. errorImportance :: Error -> Int @@ -159,10 +197,17 @@ TemporaryError {} -> 11 -- show these as usually means the user used something that doesn't work + FunctorInstanceMissingArgument {} -> 10 + MissingModParam {} -> 10 + FunctorInstanceBadArgument {} -> 10 + FunctorInstanceMissingName {} -> 9 + FunctorInstanceBadBacktick {} -> 9 + KindMismatch {} -> 10 TyVarWithParams {} -> 9 TypeMismatch {} -> 8 + SchemaMismatch {} -> 7 RecursiveType {} -> 7 NotForAll {} -> 6 TypeVariableEscaped {} -> 5 @@ -199,7 +244,13 @@ AmbiguousSize {} -> 2 + UnsupportedFFIKind {} -> 10 + UnsupportedFFIType {} -> 7 + -- less than UnexpectedTypeWildCard + NestedConstraintGuard {} -> 10 + DeclarationRequiresSignatureCtrGrd {} -> 9 + InvalidConstraintGuard {} -> 5 instance TVars Warning where @@ -208,6 +259,7 @@ DefaultingKind {} -> warn DefaultingWildType {} -> warn DefaultingTo d ty -> DefaultingTo d $! (apSubst su ty) + NonExhaustivePropGuards {} -> warn instance FVS Warning where fvs warn = @@ -215,6 +267,7 @@ DefaultingKind {} -> Set.empty DefaultingWildType {} -> Set.empty DefaultingTo _ ty -> fvs ty + NonExhaustivePropGuards {} -> Set.empty instance TVars Error where apSubst su err = @@ -225,6 +278,8 @@ TooManyTySynParams {} -> err TooFewTyParams {} -> err RecursiveTypeDecls {} -> err + SchemaMismatch i t1 t2 -> + SchemaMismatch i !$ (apSubst su t1) !$ (apSubst su t2) TypeMismatch src pa t1 t2 -> TypeMismatch src pa !$ (apSubst su t1) !$ (apSubst su t2) RecursiveType src pa t1 t2 -> RecursiveType src pa !$ (apSubst su t1) !$ (apSubst su t2) UnsolvedGoals gs -> UnsolvedGoals !$ apSubst su gs @@ -248,7 +303,20 @@ TypeShadowing {} -> err MissingModTParam {} -> err MissingModVParam {} -> err + MissingModParam {} -> err + FunctorInstanceMissingArgument {} -> err + FunctorInstanceBadArgument {} -> err + FunctorInstanceMissingName {} -> err + FunctorInstanceBadBacktick {} -> err + + UnsupportedFFIKind {} -> err + UnsupportedFFIType src e -> UnsupportedFFIType src !$ apSubst su e + + NestedConstraintGuard {} -> err + DeclarationRequiresSignatureCtrGrd {} -> err + InvalidConstraintGuard p -> InvalidConstraintGuard $! apSubst su p + TemporaryError {} -> err @@ -261,6 +329,7 @@ TooManyTySynParams {} -> Set.empty TooFewTyParams {} -> Set.empty RecursiveTypeDecls {} -> Set.empty + SchemaMismatch _ t1 t2 -> fvs (t1,t2) TypeMismatch _ _ t1 t2 -> fvs (t1,t2) RecursiveType _ _ t1 t2 -> fvs (t1,t2) UnsolvedGoals gs -> fvs gs @@ -283,7 +352,20 @@ TypeShadowing {} -> Set.empty MissingModTParam {} -> Set.empty MissingModVParam {} -> Set.empty + MissingModParam {} -> Set.empty + FunctorInstanceMissingArgument {} -> Set.empty + FunctorInstanceBadArgument {} -> Set.empty + FunctorInstanceMissingName {} -> Set.empty + FunctorInstanceBadBacktick {} -> Set.empty + + UnsupportedFFIKind {} -> Set.empty + UnsupportedFFIType _ t -> fvs t + + NestedConstraintGuard {} -> Set.empty + DeclarationRequiresSignatureCtrGrd {} -> Set.empty + InvalidConstraintGuard p -> fvs p + TemporaryError {} -> Set.empty instance PP Warning where @@ -307,6 +389,10 @@ text "Defaulting" <+> pp (tvarDesc d) <+> text "to" <+> ppWithNames names ty + NonExhaustivePropGuards n -> + text "Could not prove that the constraint guards used in defining" <+> + pp n <+> text "were exhaustive." + instance PP (WithNames Error) where ppPrec _ (WithNames err names) = case err of @@ -321,8 +407,13 @@ UnexpectedTypeWildCard -> addTVarsDescsAfter names err $ - nested "Wild card types are not allowed in this context" - "(e.g., they cannot be used in type synonyms)." + nested "Wild card types are not allowed in this context" $ + vcat [ "They cannot be used in:" + , bullets [ "type synonyms" + , "FFI declarations" + , "declarations with constraint guards" + ] + ] KindMismatch mbsrc k1 k2 -> addTVarsDescsAfter names err $ @@ -370,6 +461,14 @@ ++ ppCtxt pa ++ ["When checking" <+> pp src] + SchemaMismatch i t1 t2 -> + addTVarsDescsAfter names err $ + nested ("Type mismatch in module parameter" <+> quotes (pp i)) $ + vcat $ + [ "Expected type:" <+> ppWithNames names t1 + , "Actual type:" <+> ppWithNames names t2 + ] + UnsolvableGoals gs -> explainUnsolvable names gs UnsolvedGoals gs @@ -456,6 +555,91 @@ "Missing definition for type parameter" <+> quotes (pp (thing x)) MissingModVParam x -> "Missing definition for value parameter" <+> quotes (pp (thing x)) + + MissingModParam x -> + "Missing module parameter" <+> quotes (pp x) + + FunctorInstanceMissingArgument i -> + "Missing functor argument" <+> quotes (pp i) + + FunctorInstanceBadArgument i -> + "Functor does not have parameter" <+> quotes (pp i) + + FunctorInstanceMissingName ns i -> + "Functor argument does not define" <+> sayNS <+> "parameter" <+> + quotes (pp i) + where + sayNS = + case ns of + NSValue -> "value" + NSType -> "type" + NSModule -> "module" + + FunctorInstanceBadBacktick bad -> + case bad of + BIPolymorphicArgument i x -> + nested "Value parameter may not have a polymorphic type:" $ + bullets + [ "Module parameter:" <+> pp i + , "Value parameter:" <+> pp x + , "When instantiatiating a functor using parameterization," + $$ "the value parameters need to have a simple type." + ] + + BINested what -> + nested "Invalid declarations in parameterized instantiation:" $ + bullets $ + [ it <+> pp n + | (w,n) <- what + , let it = case w of + BIFunctor -> "functor" + BIInterface -> "interface" + BIPrimitive -> "primitive" + BIAbstractType -> "abstract type" + BIForeign -> "foreign import" + ] ++ + [ "A functor instantiated using parameterization," $$ + "may not contain nested functors, interfaces, or primitives." + ] + BIMultipleParams x -> + nested "Repeated parameter name in parameterized instantiation:" $ + bullets + [ "Parameter name:" <+> pp x + , "Parameterized instantiation requires distinct parameter names" + ] + + + UnsupportedFFIKind src param k -> + nested "Kind of type variable unsupported for FFI: " $ + vcat + [ pp param <+> colon <+> pp k + , "Only type variables of kind" <+> pp KNum <+> "are supported" + , "When checking" <+> pp src ] + + UnsupportedFFIType src t -> vcat + [ ppWithNames names t + , "When checking" <+> pp src ] + + NestedConstraintGuard d -> + vcat [ "Local declaration" <+> backticks (pp d) + <+> "may not use constraint guards." + , "Constraint guards may only appear at the top-level of a module." + ] + + DeclarationRequiresSignatureCtrGrd d -> + vcat [ "The declaration of" <+> backticks (pp d) <+> + "requires a full type signature," + , "because it is part of a recursive group with constraint guards." + ] + + InvalidConstraintGuard p -> + let d = case tNoUser p of + TCon tc _ -> pp tc + _ -> ppWithNames names p + in + vcat [ backticks d <+> "may not be used in a constraint guard." + , "Constraint guards support only numeric comparisons and `fin`." + ] TemporaryError doc -> doc where diff --git a/src/Cryptol/TypeCheck/FFI.hs b/src/Cryptol/TypeCheck/FFI.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/TypeCheck/FFI.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE Safe #-} + +-- | Checking and conversion of 'Type's to 'FFIType's. +module Cryptol.TypeCheck.FFI + ( toFFIFunType + ) where + +import Data.Bifunctor +import Data.Containers.ListUtils +import Data.Either + +import Cryptol.TypeCheck.FFI.Error +import Cryptol.TypeCheck.FFI.FFIType +import Cryptol.TypeCheck.SimpType +import Cryptol.TypeCheck.Type +import Cryptol.Utils.RecordMap +import Cryptol.Utils.Types + +-- | Convert a 'Schema' to a 'FFIFunType', along with any 'Prop's that must be +-- satisfied for the 'FFIFunType' to be valid. +toFFIFunType :: Schema -> Either FFITypeError ([Prop], FFIFunType) +toFFIFunType (Forall params _ t) = + -- Remove all type synonyms and simplify the type before processing it + case go $ tRebuild' False t of + Just (Right (props, fft)) -> Right + -- Remove duplicate constraints + (nubOrd $ map (fin . TVar . TVBound) params ++ props, fft) + Just (Left errs) -> Left $ FFITypeError t $ FFIBadComponentTypes errs + Nothing -> Left $ FFITypeError t FFINotFunction + where go (TCon (TC TCFun) [argType, retType]) = Just + case toFFIType argType of + Right (ps, ffiArgType) -> + case go retType of + Just (Right (ps', ffiFunType)) -> Right + ( ps ++ ps' + , ffiFunType + { ffiArgTypes = ffiArgType : ffiArgTypes ffiFunType } ) + Just (Left errs) -> Left errs + Nothing -> + case toFFIType retType of + Right (ps', ffiRetType) -> Right + ( ps ++ ps' + , FFIFunType + { ffiTParams = params + , ffiArgTypes = [ffiArgType], .. } ) + Left err -> Left [err] + Left err -> Left + case go retType of + Just (Right _) -> [err] + Just (Left errs) -> err : errs + Nothing -> + case toFFIType retType of + Right _ -> [err] + Left err' -> [err, err'] + go _ = Nothing + +-- | Convert a 'Type' to a 'FFIType', along with any 'Prop's that must be +-- satisfied for the 'FFIType' to be valid. +toFFIType :: Type -> Either FFITypeError ([Prop], FFIType) +toFFIType t = + case t of + TCon (TC TCBit) [] -> Right ([], FFIBool) + (toFFIBasicType -> Just r) -> (\fbt -> ([], FFIBasic fbt)) <$> r + TCon (TC TCSeq) _ -> + (\(szs, fbt) -> (map fin szs, FFIArray szs fbt)) <$> go t + where go (toFFIBasicType -> Just r) = + case r of + Right fbt -> Right ([], fbt) + Left err -> Left $ FFITypeError t $ FFIBadComponentTypes [err] + go (TCon (TC TCSeq) [sz, ty]) = first (sz:) <$> go ty + go _ = Left $ FFITypeError t FFIBadArrayType + TCon (TC (TCTuple _)) ts -> + case partitionEithers $ map toFFIType ts of + ([], unzip -> (pss, fts)) -> Right (concat pss, FFITuple fts) + (errs, _) -> Left $ FFITypeError t $ FFIBadComponentTypes errs + TRec tMap -> + case sequence resMap of + Right resMap' -> Right $ FFIRecord <$> + recordMapAccum (\ps (ps', ft) -> (ps' ++ ps, ft)) [] resMap' + Left _ -> Left $ FFITypeError t $ + FFIBadComponentTypes $ lefts $ displayElements resMap + where resMap = fmap toFFIType tMap + _ -> Left $ FFITypeError t FFIBadType + +-- | Convert a 'Type' to a 'FFIBasicType', returning 'Nothing' if it isn't a +-- basic type and 'Left' if it is but there was some other issue with it. +toFFIBasicType :: Type -> Maybe (Either FFITypeError FFIBasicType) +toFFIBasicType t = + case t of + TCon (TC TCSeq) [TCon (TC (TCNum n)) [], TCon (TC TCBit) []] + | n <= 8 -> word FFIWord8 + | n <= 16 -> word FFIWord16 + | n <= 32 -> word FFIWord32 + | n <= 64 -> word FFIWord64 + | otherwise -> Just $ Left $ FFITypeError t FFIBadWordSize + where word = Just . Right . FFIBasicVal . FFIWord n + TCon (TC TCFloat) [TCon (TC (TCNum e)) [], TCon (TC (TCNum p)) []] + | (e, p) == float32ExpPrec -> float FFIFloat32 + | (e, p) == float64ExpPrec -> float FFIFloat64 + | otherwise -> Just $ Left $ FFITypeError t FFIBadFloatSize + where float = Just . Right . FFIBasicVal . FFIFloat e p + TCon (TC TCInteger) [] -> integer Nothing + TCon (TC TCIntMod) [n] -> integer $ Just n + TCon (TC TCRational) [] -> Just $ Right $ FFIBasicRef FFIRational + _ -> Nothing + where integer = Just . Right . FFIBasicRef . FFIInteger + +fin :: Type -> Prop +fin t = TCon (PC PFin) [t] diff --git a/src/Cryptol/TypeCheck/FFI/Error.hs b/src/Cryptol/TypeCheck/FFI/Error.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/TypeCheck/FFI/Error.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} + +-- | Errors from typechecking foreign functions. +module Cryptol.TypeCheck.FFI.Error where + +import Control.DeepSeq +import GHC.Generics + +import Cryptol.TypeCheck.PP +import Cryptol.TypeCheck.Subst +import Cryptol.TypeCheck.Type + +data FFITypeError = FFITypeError Type FFITypeErrorReason + deriving (Show, Generic, NFData) + +data FFITypeErrorReason + = FFIBadWordSize + | FFIBadFloatSize + | FFIBadArrayType + | FFIBadComponentTypes [FFITypeError] + | FFIBadType + | FFINotFunction + deriving (Show, Generic, NFData) + +instance TVars FFITypeError where + apSubst su (FFITypeError t r) = FFITypeError !$ apSubst su t !$ apSubst su r + +instance TVars FFITypeErrorReason where + apSubst su r = + case r of + FFIBadWordSize -> r + FFIBadFloatSize -> r + FFIBadArrayType -> r + FFIBadComponentTypes errs -> FFIBadComponentTypes !$ apSubst su errs + FFIBadType -> r + FFINotFunction -> r + +instance FVS FFITypeError where + fvs (FFITypeError t r) = fvs (t, r) + +instance FVS FFITypeErrorReason where + fvs r = + case r of + FFIBadWordSize -> mempty + FFIBadFloatSize -> mempty + FFIBadArrayType -> mempty + FFIBadComponentTypes errs -> fvs errs + FFIBadType -> mempty + FFINotFunction -> mempty + +instance PP (WithNames FFITypeError) where + ppPrec _ (WithNames (FFITypeError t r) names) = + nest 2 $ "Type unsupported for FFI:" $$ + vcat + [ ppWithNames names t + , "Due to:" + , ppWithNames names r ] + +instance PP (WithNames FFITypeErrorReason) where + ppPrec _ (WithNames r names) = + case r of + FFIBadWordSize -> vcat + [ "Unsupported word size" + , "Only words of up to 64 bits are supported" ] + FFIBadFloatSize -> vcat + [ "Unsupported Float format" + , "Only Float32 and Float64 are supported" ] + FFIBadArrayType -> vcat + [ "Unsupported sequence element type" + , "Only words or floats are supported as the element type of" + , "(possibly multidimensional) sequences" + ] + FFIBadComponentTypes errs -> + indent 2 $ vcat $ map (ppWithNames names) errs + FFIBadType -> vcat + [ "Only Bit, words, floats, Integer, Z, Rational, sequences, or structs" + , "or tuples of the above are supported as FFI argument or return types" + ] + FFINotFunction -> "FFI binding must be a function" diff --git a/src/Cryptol/TypeCheck/FFI/FFIType.hs b/src/Cryptol/TypeCheck/FFI/FFIType.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/TypeCheck/FFI/FFIType.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} + +-- | This module defines a nicer intermediate representation of Cryptol types +-- allowed for the FFI, which the typechecker generates then stores in the AST. +-- This way the FFI evaluation code does not have to examine the raw type +-- signatures again. +module Cryptol.TypeCheck.FFI.FFIType where + +import Control.DeepSeq +import GHC.Generics + +import Cryptol.TypeCheck.Type +import Cryptol.Utils.Ident +import Cryptol.Utils.RecordMap + +-- | Type of a foreign function. +data FFIFunType = FFIFunType + { -- | Note: any type variables within this function type must be bound here. + ffiTParams :: [TParam] + , ffiArgTypes :: [FFIType] + , ffiRetType :: FFIType } + deriving (Show, Generic, NFData) + +-- | Type of a value that can be passed to or returned from a foreign function. +data FFIType + = FFIBool + | FFIBasic FFIBasicType + -- | [n][m][p]T --> FFIArray [n, m, p] T + | FFIArray [Type] FFIBasicType + | FFITuple [FFIType] + | FFIRecord (RecordMap Ident FFIType) + deriving (Show, Generic, NFData) + +-- | Types which can be elements of FFI arrays. +data FFIBasicType + = FFIBasicVal FFIBasicValType + | FFIBasicRef FFIBasicRefType + deriving (Show, Generic, NFData) + +-- | Basic type which is passed and returned directly by value. +data FFIBasicValType + = FFIWord + Integer -- ^ The size of the Cryptol type + FFIWordSize -- ^ The machine word size that it corresponds to + | FFIFloat + Integer -- ^ Exponent + Integer -- ^ Precision + FFIFloatSize -- ^ The machine float size that it corresponds to + deriving (Show, Generic, NFData) + +data FFIWordSize + = FFIWord8 + | FFIWord16 + | FFIWord32 + | FFIWord64 + deriving (Show, Generic, NFData) + +data FFIFloatSize + = FFIFloat32 + | FFIFloat64 + deriving (Show, Generic, NFData) + +-- | Basic type which is passed and returned by reference through a parameter. +data FFIBasicRefType + = FFIInteger + (Maybe Type) -- ^ Modulus (Just for Z, Nothing for Integer) + | FFIRational + deriving (Show, Generic, NFData) diff --git a/src/Cryptol/TypeCheck/Infer.hs b/src/Cryptol/TypeCheck/Infer.hs --- a/src/Cryptol/TypeCheck/Infer.hs +++ b/src/Cryptol/TypeCheck/Infer.hs @@ -14,13 +14,16 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE Safe #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Redundant <$>" #-} +{-# HLINT ignore "Redundant <&>" #-} module Cryptol.TypeCheck.Infer ( checkE , checkSigB - , inferModule + , inferTopModule , inferBinds , checkTopDecls ) @@ -30,7 +33,7 @@ import qualified Data.Text as Text -import Cryptol.ModuleSystem.Name (lookupPrimDecl,nameLoc) +import Cryptol.ModuleSystem.Name (lookupPrimDecl,nameLoc, nameIdent) import Cryptol.Parser.Position import qualified Cryptol.Parser.AST as P import qualified Cryptol.ModuleSystem.Exports as P @@ -43,36 +46,58 @@ checkPropSyn,checkNewtype, checkParameterType, checkPrimType, - checkParameterConstraints) + checkParameterConstraints, + checkPropGuards) import Cryptol.TypeCheck.Instantiate import Cryptol.TypeCheck.Subst (listSubst,apSubst,(@@),isEmptySubst) import Cryptol.TypeCheck.Unify(rootPath) +import Cryptol.TypeCheck.Module +import Cryptol.TypeCheck.FFI +import Cryptol.TypeCheck.FFI.FFIType import Cryptol.Utils.Ident import Cryptol.Utils.Panic(panic) import Cryptol.Utils.RecordMap +import Cryptol.IR.TraverseNames(mapNames) +import Cryptol.Utils.PP (pp) import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Set as Set -import Data.List(foldl',sortBy,groupBy) +import Data.List(foldl', sortBy, groupBy, partition) import Data.Either(partitionEithers) import Data.Maybe(isJust, fromMaybe, mapMaybe) -import Data.List(partition) import Data.Ratio(numerator,denominator) import Data.Traversable(forM) import Data.Function(on) -import Control.Monad(zipWithM,unless,foldM,forM_,mplus) +import Control.Monad(zipWithM, unless, foldM, forM_, mplus, zipWithM, + unless, foldM, forM_, mplus, when) +-- import Debug.Trace +-- import Cryptol.TypeCheck.PP +inferTopModule :: P.Module Name -> InferM TCTopEntity +inferTopModule m = + case P.mDef m of + P.NormalModule ds -> + do newModuleScope (thing (P.mName m)) (P.exportedDecls ds) + checkTopDecls ds + proveModuleTopLevel + endModule -inferModule :: P.Module Name -> InferM Module -inferModule m = - do newModuleScope (thing (P.mName m)) (map thing (P.mImports m)) - (P.modExports m) - checkTopDecls (P.mDecls m) - proveModuleTopLevel - endModule + P.FunctorInstance f as inst -> + do mb <- doFunctorInst (P.ImpTop <$> P.mName m) f as inst Nothing + case mb of + Just mo -> pure mo + Nothing -> panic "inferModule" ["Didnt' get a module"] + P.InterfaceModule sig -> + do newTopSignatureScope (thing (P.mName m)) + checkSignature sig + endTopSignature + + + + -- | Construct a Prelude primitive in the parsed AST. mkPrim :: String -> InferM (P.Expr Name) mkPrim str = @@ -157,8 +182,6 @@ cs <- getCallStacks if cs then pure (ELocated r e') else pure e' - P.ENeg {} -> mono - P.EComplement {} -> mono P.EGenerate {} -> mono P.ETuple {} -> mono @@ -178,6 +201,7 @@ P.ETypeVal {} -> mono P.EFun {} -> mono P.ESplit {} -> mono + P.EPrefix {} -> mono P.EParens e -> appTys e ts tGoal P.EInfix a op _ b -> appTys (P.EVar (thing op) `P.EApp` a `P.EApp` b) ts tGoal @@ -221,14 +245,6 @@ checkHasType t tGoal return e' - P.ENeg e -> - do prim <- mkPrim "negate" - checkE (P.EApp prim e) tGoal - - P.EComplement e -> - do prim <- mkPrim "complement" - checkE (P.EApp prim e) tGoal - P.EGenerate e -> do prim <- mkPrim "generate" checkE (P.EApp prim e) tGoal @@ -454,6 +470,12 @@ P.EInfix a op _ b -> checkE (P.EVar (thing op) `P.EApp` a `P.EApp` b) tGoal + P.EPrefix op e -> + do prim <- mkPrim case op of + P.PrefixNeg -> "negate" + P.PrefixComplement -> "complement" + checkE (P.EApp prim e) tGoal + P.EParens e -> checkE e tGoal @@ -464,7 +486,7 @@ -- { _ | fs } ~~> \r -> { r | fs } Nothing -> - do r <- newParamName NSValue (packIdent "r") + do r <- newLocalName NSValue (packIdent "r") let p = P.PVar Located { srcRange = nameLoc r, thing = r } fe = P.EFun P.emptyFunDesc [p] (P.EUpd (Just (P.EVar r)) fs) checkE fe tGoal @@ -490,7 +512,7 @@ v1 <- checkE v (WithSource (tFun ft ft) src eloc) -- XXX: ^ may be used a different src? d <- newHasGoal s (twsType tGoal) ft - tmp <- newParamName NSValue (packIdent "rf") + tmp <- newLocalName NSValue (packIdent "rf") let e' = EVar tmp pure ( hasDoSet d e' (EApp v1 (hasDoSelect d e')) `EWhere` @@ -734,15 +756,18 @@ newGoals CtComprehension [ pFin n' ] return (m1 : ms', Map.insertWith (\_ old -> old) x t ds, tMul n n') --- | @inferBinds isTopLevel isRec binds@ performs inference for a --- strongly-connected component of 'P.Bind's. --- If any of the members of the recursive group are already marked --- as monomorphic, then we don't do generalization. --- If @isTopLevel@ is true, --- any bindings without type signatures will be generalized. If it is --- false, and the mono-binds flag is enabled, no bindings without type --- signatures will be generalized, but bindings with signatures will --- be unaffected. +{- | @inferBinds isTopLevel isRec binds@ performs inference for a +strongly-connected component of 'P.Bind's. +If any of the members of the recursive group are already marked +as monomorphic, then we don't do generalization. +If @isTopLevel@ is true, +any bindings without type signatures will be generalized. If it is +false, and the mono-binds flag is enabled, no bindings without type +signatures will be generalized, but bindings with signatures will +be unaffected. + +-} + inferBinds :: Bool -> Bool -> [P.Bind Name] -> InferM [Decl] inferBinds isTopLevel isRec binds = do -- when mono-binds is enabled, and we're not checking top-level @@ -790,6 +815,8 @@ genCs <- generalize bs1 cs return (done,genCs) + checkNumericConstraintGuardsOK isTopLevel sigs noSigs + rec let exprMap = Map.fromList (map monoUse genBs) (doneBs, genBs) <- check exprMap @@ -817,9 +844,40 @@ withQs = foldl' appP withTys qs +{- +Here we also check that: + * Numeric constraint guards appear only at the top level + * All definitions in a recursive groups with numberic constraint guards + have signatures +The reason is to avoid interference between local constraints coming +from the guards and type inference. It might be possible to +relex these requirements, but this requires some more careful thought on +the interaction between the two, and the effects on pricniple types. +-} +checkNumericConstraintGuardsOK :: + Bool -> [P.Bind Name] -> [P.Bind Name] -> InferM () +checkNumericConstraintGuardsOK isTopLevel haveSig noSig = + do unless isTopLevel + (mapM_ (mkErr NestedConstraintGuard) withGuards) + unless (null withGuards) + (mapM_ (mkErr DeclarationRequiresSignatureCtrGrd) noSig) + where + mkErr f b = + do let nm = P.bName b + inRange (srcRange nm) (recordError (f (nameIdent (thing nm)))) + withGuards = filter hasConstraintGuards haveSig + -- When desugaring constraint guards we check that they have signatures, + -- so no need to look at noSig + hasConstraintGuards b = + case thing (P.bDef b) of + P.DPropGuards {} -> True + _ -> False + + + {- | Come up with a type for recursive calls to a function, and decide how we are going to be checking the binding. Returns: (Name, type or schema, computation to check binding) @@ -836,7 +894,12 @@ case bSignature of Just s -> - do s1 <- checkSchema AllowWildCards s + do let wildOk = case thing bDef of + P.DForeign {} -> NoWildCards + P.DPrim -> NoWildCards + P.DExpr {} -> AllowWildCards + P.DPropGuards {} -> NoWildCards + s1 <- checkSchema wildOk s return ((name, ExtVar (fst s1)), Left (checkSigB b s1)) Nothing @@ -930,8 +993,9 @@ genE e = foldr ETAbs (foldr EProofAbs (apSubst su e) qs) asPs genB d = d { dDefinition = case dDefinition d of - DExpr e -> DExpr (genE e) - DPrim -> DPrim + DExpr e -> DExpr (genE e) + DPrim -> DPrim + DForeign t -> DForeign t , dSignature = Forall asPs qs $ apSubst su $ sType $ dSignature d } @@ -953,6 +1017,8 @@ P.DPrim -> panic "checkMonoB" ["Primitive with no signature?"] + P.DForeign -> panic "checkMonoB" ["Foreign with no signature?"] + P.DExpr e -> do let nm = thing (P.bName b) let tGoal = WithSource t (DefinitionOf nm) (getLoc b) @@ -967,70 +1033,253 @@ , dDoc = P.bDoc b } + P.DPropGuards _ -> + tcPanic "checkMonoB" + [ "Used constraint guards without a signature at " + , show . pp $ P.bName b ] + -- XXX: Do we really need to do the defaulting business in two different places? checkSigB :: P.Bind Name -> (Schema,[Goal]) -> InferM Decl -checkSigB b (Forall as asmps0 t0, validSchema) = case thing (P.bDef b) of +checkSigB b (Forall as asmps0 t0, validSchema) = + let name = thing (P.bName b) in + case thing (P.bDef b) of - -- XXX what should we do with validSchema in this case? - P.DPrim -> - do return Decl { dName = thing (P.bName b) - , dSignature = Forall as asmps0 t0 - , dDefinition = DPrim - , dPragmas = P.bPragmas b - , dInfix = P.bInfix b - , dFixity = P.bFixity b - , dDoc = P.bDoc b - } + -- XXX what should we do with validSchema in this case? + P.DPrim -> + return Decl + { dName = name + , dSignature = Forall as asmps0 t0 + , dDefinition = DPrim + , dPragmas = P.bPragmas b + , dInfix = P.bInfix b + , dFixity = P.bFixity b + , dDoc = P.bDoc b + } - P.DExpr e0 -> - inRangeMb (getLoc b) $ - withTParams as $ - do (e1,cs0) <- collectGoals $ - do let nm = thing (P.bName b) - tGoal = WithSource t0 (DefinitionOf nm) (getLoc b) - e1 <- checkFun (P.FunDesc (Just nm) 0) (P.bParams b) e0 tGoal - addGoals validSchema - () <- simplifyAllConstraints -- XXX: using `asmps` also? - return e1 + P.DForeign -> do + let loc = getLoc b + name' = thing $ P.bName b + src = DefinitionOf name' + inRangeMb loc do + -- Ensure all type params are of kind # + forM_ as \a -> + when (tpKind a /= KNum) $ + recordErrorLoc loc $ UnsupportedFFIKind src a $ tpKind a + withTParams as do + ffiFunType <- + case toFFIFunType (Forall as asmps0 t0) of + Right (props, ffiFunType) -> ffiFunType <$ do + ffiGoals <- traverse (newGoal (CtFFI name')) props + proveImplication True (Just name') as asmps0 $ + validSchema ++ ffiGoals + Left err -> do + recordErrorLoc loc $ UnsupportedFFIType src err + -- Just a placeholder type + pure FFIFunType + { ffiTParams = as, ffiArgTypes = [] + , ffiRetType = FFITuple [] } + pure Decl { dName = thing (P.bName b) + , dSignature = Forall as asmps0 t0 + , dDefinition = DForeign ffiFunType + , dPragmas = P.bPragmas b + , dInfix = P.bInfix b + , dFixity = P.bFixity b + , dDoc = P.bDoc b + } - asmps1 <- applySubstPreds asmps0 - cs <- applySubstGoals cs0 + P.DExpr e0 -> + inRangeMb (getLoc b) $ + withTParams as $ do + (t, asmps, e2) <- checkBindDefExpr [] asmps0 e0 - let findKeep vs keep todo = - let stays (_,cvs) = not $ Set.null $ Set.intersection vs cvs - (yes,perhaps) = partition stays todo - (stayPs,newVars) = unzip yes - in case stayPs of - [] -> (keep,map fst todo) - _ -> findKeep (Set.unions (vs:newVars)) (stayPs ++ keep) perhaps + return Decl + { dName = name + , dSignature = Forall as asmps t + , dDefinition = DExpr (foldr ETAbs (foldr EProofAbs e2 asmps) as) + , dPragmas = P.bPragmas b + , dInfix = P.bInfix b + , dFixity = P.bFixity b + , dDoc = P.bDoc b + } - let -- if a goal mentions any of these variables, we'll commit to - -- solving it now. - stickyVars = Set.fromList (map tpVar as) `Set.union` fvs asmps1 - (stay,leave) = findKeep stickyVars [] - [ (c, fvs c) | c <- cs ] + P.DPropGuards cases0 -> + inRangeMb (getLoc b) $ + withTParams as $ do + asmps1 <- applySubstPreds asmps0 + t1 <- applySubst t0 + cases1 <- mapM checkPropGuardCase cases0 - addGoals leave + exh <- checkExhaustive (P.bName b) as asmps1 (map fst cases1) + unless exh $ + -- didn't prove exhaustive i.e. none of the guarding props + -- necessarily hold + recordWarning (NonExhaustivePropGuards name) + let schema = Forall as asmps1 t1 - su <- proveImplication (Just (thing (P.bName b))) as asmps1 stay - extendSubst su + return Decl + { dName = name + , dSignature = schema + , dDefinition = DExpr + (foldr ETAbs + (foldr EProofAbs + (EPropGuards cases1 t1) + asmps1) + as) + , dPragmas = P.bPragmas b + , dInfix = P.bInfix b + , dFixity = P.bFixity b + , dDoc = P.bDoc b + } - let asmps = concatMap pSplitAnd (apSubst su asmps1) - t <- applySubst t0 - e2 <- applySubst e1 - return Decl - { dName = thing (P.bName b) - , dSignature = Forall as asmps t - , dDefinition = DExpr (foldr ETAbs (foldr EProofAbs e2 asmps) as) - , dPragmas = P.bPragmas b - , dInfix = P.bInfix b - , dFixity = P.bFixity b - , dDoc = P.bDoc b - } + where + checkBindDefExpr :: + [Prop] -> [Prop] -> P.Expr Name -> InferM (Type, [Prop], Expr) + checkBindDefExpr asmpsSign asmps1 e0 = do + (e1,cs0) <- collectGoals $ do + let nm = thing (P.bName b) + tGoal = WithSource t0 (DefinitionOf nm) (getLoc b) + e1 <- checkFun (P.FunDesc (Just nm) 0) (P.bParams b) e0 tGoal + addGoals validSchema + () <- simplifyAllConstraints -- XXX: using `asmps` also? + return e1 + asmps2 <- applySubstPreds asmps1 + cs <- applySubstGoals cs0 + + let findKeep vs keep todo = + let stays (_,cvs) = not $ Set.null $ Set.intersection vs cvs + (yes,perhaps) = partition stays todo + (stayPs,newVars) = unzip yes + in case stayPs of + [] -> (keep,map fst todo) + _ -> findKeep (Set.unions (vs:newVars)) (stayPs ++ keep) perhaps + + let -- if a goal mentions any of these variables, we'll commit to + -- solving it now. + stickyVars = Set.fromList (map tpVar as) `Set.union` fvs asmps2 + (stay,leave) = findKeep stickyVars [] + [ (c, fvs c) | c <- cs ] + + addGoals leave + + -- includes asmpsSign for the sake of implication, but doesn't actually + -- include them in the resulting asmps + su <- proveImplication True (Just (thing (P.bName b))) as (asmpsSign <> asmps2) stay + extendSubst su + + let asmps = concatMap pSplitAnd (apSubst su asmps2) + t <- applySubst t0 + e2 <- applySubst e1 + + pure (t, asmps, e2) + + + +{- | +Given a DPropGuards of the form + +@ +f : {...} A +f | (B1, B2) => ... + | (C1, C2, C2) => ... +@ + +we check that it is exhaustive by trying to prove the following +implications: + +@ + A /\ ~B1 => C1 /\ C2 /\ C3 + A /\ ~B2 => C1 /\ C2 /\ C3 +@ + +The implications were derive by the following general algorithm: +- Find that @(C1, C2, C3)@ is the guard that has the most conjuncts, so we + will keep it on the RHS of the generated implications in order to minimize + the number of implications we need to check. +- Negate @(B1, B2)@ which yields @(~B1) \/ (~B2)@. This is a disjunction, so + we need to consider a branch for each disjunct --- one branch gets the + assumption @~B1@ and another branch gets the assumption @~B2@. Each + branch's implications need to be proven independently. + +-} +checkExhaustive :: Located Name -> [TParam] -> [Prop] -> [[Prop]] -> InferM Bool +checkExhaustive name as asmps guards = + case sortBy cmpByLonger guards of + [] -> pure False -- XXX: we should check the asmps are unsatisfiable + longest : rest -> doGoals (theAlts rest) (map toGoal longest) + + where + cmpByLonger props1 props2 = compare (length props2) (length props1) + -- reversed, so that longets is first + + theAlts :: [[Prop]] -> [[Prop]] + theAlts = map concat . sequence . map chooseNeg + + -- Choose one of the things to negate + chooseNeg ps = + case ps of + [] -> [] + p : qs -> (pNegNumeric p ++ qs) : [ p : alts | alts <- chooseNeg qs ] + + + + -- Try to validate all cases + doGoals todo gs = + case todo of + [] -> pure True + alt : more -> + do ok <- canProve (asmps ++ alt) gs + if ok then doGoals more gs + else pure False + + toGoal :: Prop -> Goal + toGoal prop = + Goal + { goalSource = CtPropGuardsExhaustive (thing name) + , goalRange = srcRange name + , goal = prop + } + + canProve :: [Prop] -> [Goal] -> InferM Bool + canProve asmps' goals = + tryProveImplication (Just (thing name)) as asmps' goals + +{- | This function does not validate anything---it just translates into +the type-checkd syntax. The actual validation of the guard will happen +when the (automatically generated) function corresponding to the guard is +checked, assuming 'ExpandpropGuards' did its job correctly. + +-} +checkPropGuardCase :: P.PropGuardCase Name -> InferM ([Prop],Expr) +checkPropGuardCase (P.PropGuardCase guards e0) = + do ps <- checkPropGuards guards + tys <- mapM (`checkType` Nothing) ts + let rhsTs = foldl ETApp (getV eV) tys + rhsPs = foldl (\e _p -> EProofApp e) rhsTs ps + rhs = foldl EApp rhsPs (map getV es) + pure (ps,rhs) + + where + (e1,es) = P.asEApps e0 + (eV,ts) = case e1 of + P.EAppT ex1 tis -> (ex1, map getT tis) + _ -> (e1, []) + + getV ex = + case ex of + P.EVar x -> EVar x + _ -> bad "Expression is not a variable." + + getT ti = + case ti of + P.PosInst t -> t + P.NamedInst {} -> bad "Unexpeceted NamedInst" + + bad msg = panic "checkPropGuardCase" [msg] + -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- @@ -1059,29 +1308,115 @@ do t <- checkPrimType (P.tlValue tl) (thing <$> P.tlDoc tl) addPrimType t - P.DParameterType ty -> - do t <- checkParameterType ty (P.ptDoc ty) - addParamType t - P.DParameterConstraint cs -> - do cs1 <- checkParameterConstraints cs + P.DInterfaceConstraint _ cs -> + inRange (srcRange cs) + do cs1 <- checkParameterConstraints [ cs { thing = c } | c <- thing cs ] addParameterConstraints cs1 - P.DParameterFun pf -> - do x <- checkParameterFun pf - addParamFun x - P.DModule tl -> - do let P.NestedModule m = P.tlValue tl - newSubmoduleScope (thing (P.mName m)) (map thing (P.mImports m)) - (P.modExports m) - checkTopDecls (P.mDecls m) - endSubmodule + selectorScope + case P.mDef m of - P.DImport {} -> pure () - P.Include {} -> panic "checkTopDecl" [ "Unexpected `inlude`" ] + P.NormalModule ds -> + do newSubmoduleScope (thing (P.mName m)) + (thing <$> P.tlDoc tl) + (P.exportedDecls ds) + checkTopDecls ds + proveModuleTopLevel + endSubmodule + P.FunctorInstance f as inst -> + do let doc = thing <$> P.tlDoc tl + _ <- doFunctorInst (P.ImpNested <$> P.mName m) f as inst doc + pure () + P.InterfaceModule sig -> + do let doc = P.thing <$> P.tlDoc tl + inRange (srcRange (P.mName m)) + do newSignatureScope (thing (P.mName m)) doc + checkSignature sig + endSignature + + + where P.NestedModule m = P.tlValue tl + + P.DModParam p -> + inRange (srcRange (P.mpSignature p)) + do let binds = P.mpRenaming p + suMap = Map.fromList [ (y,x) | (x,y) <- Map.toList binds ] + actualName x = Map.findWithDefault x x suMap + + ips <- lookupSignature (thing (P.mpSignature p)) + let actualTys = [ mapNames actualName mp + | mp <- Map.elems (mpnTypes ips) ] + actualTS = [ mapNames actualName ts + | ts <- Map.elems (mpnTySyn ips) + ] + actualCtrs = [ mapNames actualName prop + | prop <- mpnConstraints ips ] + actualVals = [ mapNames actualName vp + | vp <- Map.elems (mpnFuns ips) ] + + param = + ModParam + { mpName = P.mpName p + , mpIface = thing (P.mpSignature p) + , mpQual = P.mpAs p + , mpParameters = + ModParamNames + { mpnTypes = Map.fromList [ (mtpName tp, tp) + | tp <- actualTys ] + , mpnTySyn = Map.fromList [ (tsName ts, ts) + | ts <- actualTS ] + , mpnConstraints = actualCtrs + , mpnFuns = Map.fromList [ (mvpName vp, vp) + | vp <- actualVals ] + , mpnDoc = thing <$> P.mpDoc p + } + } + + mapM_ addParamType actualTys + addParameterConstraints actualCtrs + mapM_ addParamFun actualVals + mapM_ addTySyn actualTS + addModParam param + + P.DImport {} -> pure () + P.Include {} -> bad "Include" + P.DParamDecl {} -> bad "DParamDecl" + + + bad x = panic "checkTopDecl" [ x ] + + +checkSignature :: P.Signature Name -> InferM () +checkSignature sig = + do forM_ (P.sigTypeParams sig) \pt -> + addParamType =<< checkParameterType pt + + mapM_ checkSigDecl (P.sigDecls sig) + + addParameterConstraints =<< + checkParameterConstraints (P.sigConstraints sig) + + forM_ (P.sigFunParams sig) \f -> + addParamFun =<< checkParameterFun f + + proveModuleTopLevel + +checkSigDecl :: P.SigDecl Name -> InferM () +checkSigDecl decl = + case decl of + + P.SigTySyn ts mbD -> + addTySyn =<< checkTySyn ts mbD + + P.SigPropSyn ps mbD -> + addTySyn =<< checkPropSyn ps mbD + + + checkDecl :: Bool -> P.Decl Name -> Maybe Text -> InferM () checkDecl isTopLevel d mbDoc = case d of @@ -1116,8 +1451,8 @@ checkParameterFun :: P.ParameterFun Name -> InferM ModVParam checkParameterFun x = do (s,gs) <- checkSchema NoWildCards (P.pfSchema x) - su <- proveImplication (Just (thing (P.pfName x))) - (sVars s) (sProps s) gs + su <- proveImplication False (Just (thing (P.pfName x))) + (sVars s) (sProps s) gs unless (isEmptySubst su) $ panic "checkParameterFun" ["Subst not empty??"] let n = thing (P.pfName x) diff --git a/src/Cryptol/TypeCheck/InferTypes.hs b/src/Cryptol/TypeCheck/InferTypes.hs --- a/src/Cryptol/TypeCheck/InferTypes.hs +++ b/src/Cryptol/TypeCheck/InferTypes.hs @@ -27,7 +27,7 @@ import Cryptol.TypeCheck.Subst import Cryptol.TypeCheck.TypePat import Cryptol.TypeCheck.SimpType(tMax) -import Cryptol.Utils.Ident (ModName, PrimIdent(..), preludeName) +import Cryptol.Utils.Ident (PrimIdent(..), preludeName) import Cryptol.Utils.Panic(panic) import Cryptol.Utils.Misc(anyJust) @@ -182,7 +182,8 @@ compare x y = compare (goal x) (goal y) data HasGoal = HasGoal - { hasName :: !Int + { hasName :: !Int -- ^ This is the "name" of the constraint, + -- used to find the solution for ellaboration. , hasGoal :: Goal } deriving Show @@ -219,7 +220,10 @@ | CtPartialTypeFun Name -- ^ Use of a partial type function. | CtImprovement | CtPattern TypeSource -- ^ Constraints arising from type-checking patterns - | CtModuleInstance ModName -- ^ Instantiating a parametrized module + | CtModuleInstance Range -- ^ Instantiating a parametrized module + | CtPropGuardsExhaustive Name -- ^ Checking that a use of prop guards is exhastive + | CtFFI Name -- ^ Constraints on a foreign declaration required + -- by the FFI (e.g. sequences must be finite) deriving (Show, Generic, NFData) selSrc :: Selector -> TypeSource @@ -247,6 +251,8 @@ CtImprovement -> src CtPattern _ -> src CtModuleInstance _ -> src + CtPropGuardsExhaustive _ -> src + CtFFI _ -> src instance FVS Goal where @@ -352,7 +358,9 @@ CtPartialTypeFun f -> "use of partial type function" <+> pp f CtImprovement -> "examination of collected goals" CtPattern ad -> "checking a pattern:" <+> pp ad - CtModuleInstance n -> "module instantiation" <+> pp n + CtModuleInstance r -> "module instantiation at" <+> pp r + CtPropGuardsExhaustive n -> "exhaustion check for prop guards used in defining" <+> pp n + CtFFI f -> "declaration of foreign function" <+> pp f ppUse :: Expr -> Doc ppUse expr = diff --git a/src/Cryptol/TypeCheck/Interface.hs b/src/Cryptol/TypeCheck/Interface.hs --- a/src/Cryptol/TypeCheck/Interface.hs +++ b/src/Cryptol/TypeCheck/Interface.hs @@ -1,73 +1,83 @@ +{-# LANGUAGE Safe #-} + module Cryptol.TypeCheck.Interface where import qualified Data.Map as Map +import Data.Set(Set) +import qualified Data.Set as Set -import Cryptol.Utils.Ident(Namespace(..)) import Cryptol.ModuleSystem.Interface +import Cryptol.ModuleSystem.Exports(allExported) import Cryptol.TypeCheck.AST +-- | Information about a declaration to be stored an in interface. mkIfaceDecl :: Decl -> IfaceDecl mkIfaceDecl d = IfaceDecl { ifDeclName = dName d , ifDeclSig = dSignature d + , ifDeclIsPrim = case dDefinition d of + DPrim {} -> True + _ -> False , ifDeclPragmas = dPragmas d , ifDeclInfix = dInfix d , ifDeclFixity = dFixity d , ifDeclDoc = dDoc d } --- | Generate an Iface from a typechecked module. -genIface :: ModuleG mname -> IfaceG mname -genIface m = Iface - { ifModName = mName m - - , ifPublic = IfaceDecls - { ifTySyns = tsPub - , ifNewtypes = ntPub - , ifAbstractTypes = atPub - , ifDecls = dPub - , ifModules = mPub - } - - , ifPrivate = IfaceDecls - { ifTySyns = tsPriv - , ifNewtypes = ntPriv - , ifAbstractTypes = atPriv - , ifDecls = dPriv - , ifModules = mPriv - } - - , ifParams = IfaceParams - { ifParamTypes = mParamTypes m - , ifParamConstraints = mParamConstraints m - , ifParamFuns = mParamFuns m - } +-- | Compute information about the names in a module. +genIfaceNames :: ModuleG name -> IfaceNames name +genIfaceNames m = IfaceNames + { ifsName = mName m + , ifsNested = mNested m + , ifsDefines = genModDefines m + , ifsPublic = allExported (mExports m) + , ifsDoc = mDoc m } - where - (tsPub,tsPriv) = - Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m ) - (mTySyns m) - (ntPub,ntPriv) = - Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m ) - (mNewtypes m) - - (atPub,atPriv) = - Map.partitionWithKey (\qn _ -> qn `isExportedType` mExports m) - (mPrimTypes m) +-- | Things defines by a module +genModDefines :: ModuleG name -> Set Name +genModDefines m = + Set.unions + [ Map.keysSet (mTySyns m) + , Map.keysSet (mNewtypes m) + , Set.fromList (map ntConName (Map.elems (mNewtypes m))) + , Map.keysSet (mPrimTypes m) + , Set.fromList (map dName (concatMap groupDecls (mDecls m))) + , Map.keysSet (mSubmodules m) + , Map.keysSet (mFunctors m) + , Map.keysSet (mSignatures m) + ] `Set.difference` nestedInSet (mNested m) + where + nestedInSet = Set.unions . map inNested . Set.toList + inNested x = case Map.lookup x (mSubmodules m) of + Just y -> ifsDefines y `Set.union` nestedInSet (ifsNested y) + Nothing -> Set.empty -- must be signature or a functor - (dPub,dPriv) = - Map.partitionWithKey (\ qn _ -> qn `isExportedBind` mExports m) - $ Map.fromList [ (qn,mkIfaceDecl d) | dg <- mDecls m - , d <- groupDecls dg - , let qn = dName d - ] +genIface :: ModuleG name -> IfaceG name +genIface m = genIfaceWithNames (genIfaceNames m) m - (mPub,mPriv) = - Map.partitionWithKey (\ qn _ -> isExported NSModule qn (mExports m)) - $ mSubModules m +-- | Generate an Iface from a typechecked module. +genIfaceWithNames :: IfaceNames name -> ModuleG ignored -> IfaceG name +genIfaceWithNames names m = + Iface + { ifNames = names + , ifDefines = IfaceDecls + { ifTySyns = mTySyns m + , ifNewtypes = mNewtypes m + , ifAbstractTypes = mPrimTypes m + , ifDecls = Map.fromList [ (qn,mkIfaceDecl d) + | dg <- mDecls m + , d <- groupDecls dg + , let qn = dName d + ] + , ifModules = mSubmodules m + , ifSignatures = mSignatures m + , ifFunctors = genIface <$> mFunctors m + } + , ifParams = mParams m + } diff --git a/src/Cryptol/TypeCheck/Kind.hs b/src/Cryptol/TypeCheck/Kind.hs --- a/src/Cryptol/TypeCheck/Kind.hs +++ b/src/Cryptol/TypeCheck/Kind.hs @@ -7,7 +7,7 @@ -- Portability : portable {-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE BlockArguments #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Cryptol.TypeCheck.Kind @@ -19,6 +19,7 @@ , checkPropSyn , checkParameterType , checkParameterConstraints + , checkPropGuards ) where import qualified Cryptol.Parser.AST as P @@ -38,9 +39,7 @@ import Data.Maybe(fromMaybe) import Data.Function(on) import Data.Text (Text) -import Control.Monad(unless,when) - - +import Control.Monad(unless,when,mplus) -- | Check a type signature. Returns validated schema, and any implicit -- constraints that we inferred. @@ -66,14 +65,38 @@ Nothing -> id Just r -> inRange r +{- | Validate parsed propositions that appear in the guard of a PropGuard. + + * Note that we don't validate the well-formedness constraints here---instead, + they'd be validated when the signature for the auto generated + function corresponding guard is checked. + + * We also check that there are no wild-cards in the constraints. +-} +checkPropGuards :: [Located (P.Prop Name)] -> InferM [Prop] +checkPropGuards props = + do (newPs,_gs) <- collectGoals (mapM check props) + pure newPs + where + check lp = + inRange (srcRange lp) + do let p = thing lp + (_,ps) <- withTParams NoWildCards schemaParam [] (checkProp p) + case tNoUser ps of + TCon (PC x) _ | x `elem` [PEqual,PNeq,PGeq,PFin,PTrue] -> pure () + _ -> recordError (InvalidConstraintGuard ps) + pure ps + + + -- | Check a module parameter declarations. Nothing much to check, -- we just translate from one syntax to another. -checkParameterType :: P.ParameterType Name -> Maybe Text -> InferM ModTParam -checkParameterType a mbDoc = - do let k = cvtK (P.ptKind a) +checkParameterType :: P.ParameterType Name -> InferM ModTParam +checkParameterType a = + do let mbDoc = P.ptDoc a + k = cvtK (P.ptKind a) n = thing (P.ptName a) - return ModTParam { mtpKind = k, mtpName = n, mtpDoc = mbDoc - , mtpNumber = P.ptNumber a } + return ModTParam { mtpKind = k, mtpName = n, mtpDoc = mbDoc } -- | Check a type-synonym declaration. @@ -111,7 +134,7 @@ -- | Check a newtype declaration. -- XXX: Do something with constraints. checkNewtype :: P.Newtype Name -> Maybe Text -> InferM Newtype -checkNewtype (P.Newtype x as fs) mbD = +checkNewtype (P.Newtype x as con fs) mbD = do ((as1,fs1),gs) <- collectGoals $ inRange (srcRange x) $ do r <- withTParams NoWildCards newtypeParam as $ @@ -123,6 +146,7 @@ return Newtype { ntName = thing x , ntParams = as1 , ntConstraints = map goal gs + , ntConName = con , ntFields = fs1 , ntDoc = mbD } @@ -386,8 +410,16 @@ P.TUser x ts -> checkTUser x ts k - P.TParens t -> doCheckType t k + P.TParens t mb -> + do newK <- case (k, cvtK <$> mb) of + (Just a, Just b) -> + do unless (a == b) + (kRecordError (KindMismatch Nothing a b)) + pure (Just b) + (a,b) -> pure (mplus a b) + doCheckType t newK + P.TInfix t x _ u-> doCheckType (P.TUser (thing x) [t, u]) k P.TTyApp _fs -> do kRecordError BareTypeApp @@ -398,7 +430,7 @@ -- | Validate a parsed proposition. checkProp :: P.Prop Name -- ^ Proposition that need to be checked - -> KindM Type -- ^ Checked representation + -> KindM Prop -- ^ Checked representation checkProp (P.CType t) = doCheckType t (Just KProp) @@ -411,5 +443,3 @@ | k1 /= k2 = do kRecordError (KindMismatch Nothing k1 k2) kNewType TypeErrorPlaceHolder k1 checkKind t _ _ = return t - - diff --git a/src/Cryptol/TypeCheck/Module.hs b/src/Cryptol/TypeCheck/Module.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/TypeCheck/Module.hs @@ -0,0 +1,376 @@ +{-# Language BlockArguments, ImplicitParams #-} +module Cryptol.TypeCheck.Module (doFunctorInst) where + +import Data.List(partition) +import Data.Text(Text) +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Control.Monad(unless,forM_) + + +import Cryptol.Utils.Panic(panic) +import Cryptol.Utils.Ident(Ident,Namespace(..),isInfixIdent) +import Cryptol.Parser.Position (Range,Located(..), thing) +import qualified Cryptol.Parser.AST as P +import Cryptol.ModuleSystem.Name(nameIdent) +import Cryptol.ModuleSystem.Interface + ( IfaceG(..), IfaceDecls(..), IfaceNames(..), IfaceDecl(..) + , filterIfaceDecls + ) +import Cryptol.TypeCheck.AST +import Cryptol.TypeCheck.Error +import Cryptol.TypeCheck.Subst(Subst,listParamSubst,apSubst,mergeDistinctSubst) +import Cryptol.TypeCheck.Solve(proveImplication) +import Cryptol.TypeCheck.Monad +import Cryptol.TypeCheck.Instantiate(instantiateWith) +import Cryptol.TypeCheck.ModuleInstance +import Cryptol.TypeCheck.ModuleBacktickInstance(MBQual, doBacktickInstance) + +doFunctorInst :: + Located (P.ImpName Name) {- ^ Name for the new module -} -> + Located (P.ImpName Name) {- ^ Functor being instantiated -} -> + P.ModuleInstanceArgs Name {- ^ Instance arguments -} -> + Map Name Name + {- ^ Instantitation. These is the renaming for the functor that arises from + generativity (i.e., it is something that will make the names "fresh"). + -} -> + Maybe Text {- ^ Documentation -} -> + InferM (Maybe TCTopEntity) +doFunctorInst m f as inst doc = + inRange (srcRange m) + do mf <- lookupFunctor (thing f) + argIs <- checkArity (srcRange f) mf as + m2 <- do as2 <- mapM checkArg argIs + let (tySus,decls) = unzip [ (su,ds) | DefinedInst su ds <- as2 ] + let ?tSu = mergeDistinctSubst tySus + ?vSu = inst + let m1 = moduleInstance mf + m2 = m1 { mName = m + , mDoc = Nothing + , mParamTypes = mempty + , mParamFuns = mempty + , mParamConstraints = mempty + , mParams = mempty + , mDecls = map NonRecursive (concat decls) ++ + mDecls m1 + } + let (tps,tcs,vps) = + unzip3 [ (xs,cs,fs) | ParamInst xs cs fs <- as2 ] + tpSet = Set.unions tps + tpSet' = Set.map snd (Set.unions tps) + emit p = Set.null (freeParams (thing p) + `Set.intersection` tpSet') + + (emitPs,delayPs) = partition emit (mParamConstraints m1) + + forM_ emitPs \lp -> + newGoals (CtModuleInstance (srcRange lp)) [thing lp] + + doBacktickInstance tpSet + (map thing delayPs ++ concat tcs) + (Map.unions vps) + m2 + + case thing m of + P.ImpTop mn -> newModuleScope mn (mExports m2) + P.ImpNested mn -> newSubmoduleScope mn doc (mExports m2) + + mapM_ addTySyn (Map.elems (mTySyns m2)) + mapM_ addNewtype (Map.elems (mNewtypes m2)) + mapM_ addPrimType (Map.elems (mPrimTypes m2)) + addSignatures (mSignatures m2) + addSubmodules (mSubmodules m2) + addFunctors (mFunctors m2) + mapM_ addDecls (mDecls m2) + + case thing m of + P.ImpTop {} -> Just <$> endModule + P.ImpNested {} -> endSubmodule >> pure Nothing + + +data ActualArg = + UseParameter ModParam -- ^ Instantiate using this parameter + | UseModule (IfaceG ()) -- ^ Instantiate using this module + | AddDeclParams -- ^ Instantiate by adding parameters + + + + +{- | Validate a functor application, just checking the argument names. +The result associates a module parameter with the concrete way it should +be instantiated, which could be: + + * `Left` instanciate using another parameter that is in scope + * `Right` instanciate using a module, with the given interface +-} +checkArity :: + Range {- ^ Location for reporting errors -} -> + ModuleG () {- ^ The functor being instantiated -} -> + P.ModuleInstanceArgs Name {- ^ The arguments -} -> + InferM [(Range, ModParam, ActualArg)] + {- ^ Associates functor parameters with the interfaces of the + instantiating modules -} +checkArity r mf args = + case args of + + P.DefaultInstArg arg -> + let i = Located { srcRange = srcRange arg + , thing = head (Map.keys ps0) + } + in checkArgs [] ps0 [ P.ModuleInstanceNamedArg i arg ] + + P.NamedInstArgs as -> checkArgs [] ps0 as + + P.DefaultInstAnonArg {} -> panic "checkArity" [ "DefaultInstAnonArg" ] + where + ps0 = mParams mf + + checkArgs done ps as = + case as of + + [] -> do forM_ (Map.keys ps) \p -> + recordErrorLoc (Just r) (FunctorInstanceMissingArgument p) + pure done + + P.ModuleInstanceNamedArg ll lm : more -> + case Map.lookup (thing ll) ps of + Just i -> + do arg <- case thing lm of + P.ModuleArg m -> Just . UseModule <$> lookupModule m + P.ParameterArg p -> + do mb <- lookupModParam p + case mb of + Nothing -> + do inRange (srcRange lm) + (recordError (MissingModParam p)) + pure Nothing + Just a -> pure (Just (UseParameter a)) + P.AddParams -> pure (Just AddDeclParams) + let next = case arg of + Nothing -> done + Just a -> (srcRange lm, i, a) : done + checkArgs next (Map.delete (thing ll) ps) more + + Nothing -> + do recordErrorLoc (Just (srcRange ll)) + (FunctorInstanceBadArgument (thing ll)) + checkArgs done ps more + + +data ArgInst = DefinedInst Subst [Decl] -- ^ Argument that defines the params + | ParamInst (Set (MBQual TParam)) [Prop] (Map (MBQual Name) Type) + -- ^ Argument that add parameters + -- The type parameters are in their module type parameter + -- form (i.e., tpFlav is TPModParam) + + + +{- | Check the argument to a functor parameter. +Returns: + + * A substitution which will replace the parameter types with + the concrete types that were provided + + * Some declarations that define the parameters in terms of the provided + values. + + * XXX: Extra parameters for instantiation by adding params +-} +checkArg :: + (Range, ModParam, ActualArg) -> InferM ArgInst +checkArg (r,expect,actual') = + case actual' of + AddDeclParams -> paramInst + UseParameter {} -> definedInst + UseModule {} -> definedInst + + where + paramInst = + do let as = Set.fromList + (map (qual . mtpParam) (Map.elems (mpnTypes params))) + cs = map thing (mpnConstraints params) + check = checkSimpleParameterValue r (mpName expect) + qual a = (mpQual expect, a) + fs <- Map.mapMaybeWithKey (\_ v -> v) <$> mapM check (mpnFuns params) + pure (ParamInst as cs (Map.mapKeys qual fs)) + + definedInst = + do tRens <- mapM (checkParamType r tyMap) (Map.toList (mpnTypes params)) + let renSu = listParamSubst (concat tRens) + + {- Note: the constraints from the signature are already added to the + constraints for the functor and they are checked all at once in + doFunctorInst -} + + + vDecls <- concat <$> + mapM (checkParamValue r vMap) + [ s { mvpType = apSubst renSu (mvpType s) } + | s <- Map.elems (mpnFuns params) ] + + pure (DefinedInst renSu vDecls) + + + params = mpParameters expect + + -- Things provided by the argument module + tyMap :: Map Ident (Kind, Type) + vMap :: Map Ident (Name, Schema) + (tyMap,vMap) = + case actual' of + UseParameter mp -> + ( nameMapToIdentMap fromTP (mpnTypes ps) + , nameMapToIdentMap fromVP (mpnFuns ps) + ) + where + ps = mpParameters mp + fromTP tp = (mtpKind tp, TVar (TVBound (mtpParam tp))) + fromVP vp = (mvpName vp, mvpType vp) + + UseModule actual -> + ( Map.unions [ nameMapToIdentMap fromTS (ifTySyns decls) + , nameMapToIdentMap fromNewtype (ifNewtypes decls) + , nameMapToIdentMap fromPrimT (ifAbstractTypes decls) + ] + + , nameMapToIdentMap fromD (ifDecls decls) + ) + + where + localNames = ifsPublic (ifNames actual) + isLocal x = x `Set.member` localNames + + -- Things defined by the argument module + decls = filterIfaceDecls isLocal (ifDefines actual) + + fromD d = (ifDeclName d, ifDeclSig d) + fromTS ts = (kindOf ts, tsDef ts) + fromNewtype nt = (kindOf nt, TNewtype nt []) + fromPrimT pt = (kindOf pt, TCon (abstractTypeTC pt) []) + + AddDeclParams -> panic "checkArg" ["AddDeclParams"] + + + +nameMapToIdentMap :: (a -> b) -> Map Name a -> Map Ident b +nameMapToIdentMap f m = + Map.fromList [ (nameIdent n, f v) | (n,v) <- Map.toList m ] + + + + +-- | Check a type parameter to a module. +checkParamType :: + Range {- ^ Location for error reporting -} -> + Map Ident (Kind,Type) {- ^ Actual types -} -> + (Name,ModTParam) {- ^ Type parameter -} -> + InferM [(TParam,Type)] {- ^ Mapping from parameter name to actual type -} +checkParamType r tyMap (name,mp) = + let i = nameIdent name + expectK = mtpKind mp + in + case Map.lookup i tyMap of + Nothing -> + do recordErrorLoc (Just r) (FunctorInstanceMissingName NSType i) + pure [] + Just (actualK,actualT) -> + do unless (expectK == actualK) + (recordErrorLoc (Just r) + (KindMismatch (Just (TVFromModParam name)) + expectK actualK)) + pure [(mtpParam mp, actualT)] + +-- | Check a value parameter to a module. +checkParamValue :: + Range {- ^ Location for error reporting -} -> + Map Ident (Name,Schema) {- ^ Actual values -} -> + ModVParam {- ^ The parameter we are checking -} -> + InferM [Decl] {- ^ Mapping from parameter name to definition -} +checkParamValue r vMap mp = + let name = mvpName mp + i = nameIdent name + expectT = mvpType mp + in case Map.lookup i vMap of + Nothing -> + do recordErrorLoc (Just r) (FunctorInstanceMissingName NSValue i) + pure [] + Just actual -> + do e <- mkParamDef r (name,expectT) actual + let d = Decl { dName = name + , dSignature = expectT + , dDefinition = DExpr e + , dPragmas = [] + , dInfix = isInfixIdent (nameIdent name) + , dFixity = mvpFixity mp + , dDoc = mvpDoc mp + } + + pure [d] + + + +checkSimpleParameterValue :: + Range {- ^ Location for error reporting -} -> + Ident {- ^ Name of functor parameter -} -> + ModVParam {- ^ Module parameter -} -> + InferM (Maybe Type) {- ^ Type to add to things, `Nothing` on err -} +checkSimpleParameterValue r i mp = + case (sVars sch, sProps sch) of + ([],[]) -> pure (Just (sType sch)) + _ -> + do recordErrorLoc (Just r) + (FunctorInstanceBadBacktick + (BIPolymorphicArgument i (nameIdent (mvpName mp)))) + pure Nothing + where + sch = mvpType mp + + +{- | Make an "adaptor" that instantiates the paramter into the form expected +by the functor. If the actual type is: + +> {x} P => t + +and the provided type is: + +> f : {y} Q => s + +The result, if successful would be: + + /\x \{P}. f @a {Q} + +To do this we need to find types `a` to instantiate `y`, and prove that: + {x} P => Q[a/y] /\ s = t +-} + +mkParamDef :: + Range {- ^ Location of instantiation for error reporting -} -> + (Name,Schema) {- ^ Name and type of parameter -} -> + (Name,Schema) {- ^ Name and type of actual argument -} -> + InferM Expr +mkParamDef r (pname,wantedS) (arg,actualS) = + do (e,todo) <- collectGoals + $ withTParams (sVars wantedS) + do (e,t) <- instantiateWith pname(EVar arg) actualS [] + props <- unify WithSource { twsType = sType wantedS + , twsSource = TVFromModParam arg + , twsRange = Just r + } + t + newGoals (CtModuleInstance r) props + pure e + su <- proveImplication False + (Just pname) + (sVars wantedS) + (sProps wantedS) + todo + let res = foldr ETAbs res1 (sVars wantedS) + res1 = foldr EProofAbs (apSubst su e) (sProps wantedS) + + applySubst res + + + + diff --git a/src/Cryptol/TypeCheck/ModuleBacktickInstance.hs b/src/Cryptol/TypeCheck/ModuleBacktickInstance.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/TypeCheck/ModuleBacktickInstance.hs @@ -0,0 +1,408 @@ +{-# Language ImplicitParams #-} +{-# Language FlexibleInstances #-} +{-# Language RecursiveDo #-} +{-# Language BlockArguments #-} +{-# Language RankNTypes #-} +{-# Language OverloadedStrings #-} +module Cryptol.TypeCheck.ModuleBacktickInstance + ( MBQual + , doBacktickInstance + ) where + +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Map(Map) +import qualified Data.Map as Map +import MonadLib +import Data.List(group,sort) +import Data.Maybe(mapMaybe) +import qualified Data.Text as Text + +import Cryptol.Utils.Ident(ModPath(..), modPathIsOrContains,Namespace(..) + , Ident, mkIdent, identText + , ModName, modNameChunksText ) +import Cryptol.Utils.PP(pp) +import Cryptol.Utils.Panic(panic) +import Cryptol.Utils.RecordMap(RecordMap,recordFromFields,recordFromFieldsErr) +import Cryptol.Parser.Position +import Cryptol.ModuleSystem.Name( + nameModPath, nameModPathMaybe, nameIdent, mapNameIdent) +import Cryptol.TypeCheck.AST +import Cryptol.TypeCheck.Error +import qualified Cryptol.TypeCheck.Monad as TC + + +type MBQual a = (Maybe ModName, a) + +{- | Rewrite declarations to add the given module parameters. +Assumes the renaming due to the instantiation has already happened. +The module being rewritten should not contain any nested functors +(or module with only top-level constraints) because it is not clear +how to parameterize the parameters. +-} +doBacktickInstance :: + Set (MBQual TParam) -> + [Prop] -> + Map (MBQual Name) Type -> + ModuleG (Located (ImpName Name)) -> + TC.InferM (ModuleG (Located (ImpName Name))) +doBacktickInstance as ps mp m + | null as && null ps && Map.null mp = pure m + | otherwise = + runReaderT + RO { isOurs = \x -> case nameModPathMaybe x of + Nothing -> False + Just y -> ourPath `modPathIsOrContains` y + , tparams = Set.toList as + , constraints = ps + , vparams = mp + , newNewtypes = Map.empty + } + + do unless (null bad) + (recordError (FunctorInstanceBadBacktick (BINested bad))) + + rec + ts <- doAddParams nt mTySyns + nt <- doAddParams nt mNewtypes + ds <- doAddParams nt mDecls + + pure m + { mTySyns = ts + , mNewtypes = nt + , mDecls = ds + } + + where + bad = mkBad mFunctors BIFunctor + ++ mkBad mPrimTypes BIAbstractType + ++ mkBad mSignatures BIInterface + + mkBad sel a = [ (a,k) | k <- Map.keys (sel m) ] + + ourPath = case thing (mName m) of + ImpTop mo -> TopModule mo + ImpNested mo -> Nested (nameModPath mo) (nameIdent mo) + + doAddParams nt sel = + mapReader (\ro -> ro { newNewtypes = nt }) (addParams (sel m)) + + +type RewM = ReaderT RO TC.InferM + +recordError :: Error -> RewM () +recordError e = lift (TC.recordError e) + +data RO = RO + { isOurs :: Name -> Bool + , tparams :: [MBQual TParam] + , constraints :: [Prop] + , vparams :: Map (MBQual Name) Type + , newNewtypes :: Map Name Newtype + } + + +class AddParams t where + addParams :: t -> RewM t + +instance AddParams a => AddParams (Map Name a) where + addParams = mapM addParams + +instance AddParams a => AddParams [a] where + addParams = mapM addParams + +instance AddParams Newtype where + addParams nt = + do (tps,cs) <- newTypeParams TPNewtypeParam + rProps <- rewTypeM tps (ntConstraints nt) + rFields <- rewTypeM tps (ntFields nt) + pure nt + { ntParams = pDecl tps ++ ntParams nt + , ntConstraints = cs ++ rProps + , ntFields = rFields + } + +instance AddParams TySyn where + addParams ts = + do (tps,cs) <- newTypeParams TPTySynParam + rProps <- rewTypeM tps (tsConstraints ts) + rDef <- rewTypeM tps (tsDef ts) + pure ts + { tsParams = pDecl tps ++ tsParams ts + , tsConstraints = cs ++ rProps + , tsDef = rDef + } + +instance AddParams DeclGroup where + addParams dg = + case dg of + Recursive ds -> Recursive <$> addParams ds + NonRecursive d -> NonRecursive <$> addParams d + +instance AddParams Decl where + addParams d = + case dDefinition d of + DPrim -> bad BIPrimitive + DForeign {} -> bad BIForeign + DExpr e -> + do (tps,cs) <- newTypeParams TPSchemaParam + (vps,bs) <- newValParams tps + let s = dSignature d + + ty1 <- rewTypeM tps (sType s) + ps1 <- rewTypeM tps (sProps s) + let ty2 = foldr tFun ty1 (map snd bs) + + e1 <- rewValM tps (length cs) vps e + let (das,e2) = splitWhile splitTAbs e1 + (dcs,e3) = splitWhile splitProofAbs e2 + e4 = foldr (uncurry EAbs) e3 bs + e5 = foldr EProofAbs e4 (cs ++ dcs) + e6 = foldr ETAbs e5 (pDecl tps ++ das) + + s1 = Forall + { sVars = pDecl tps ++ sVars s + , sProps = cs ++ ps1 + , sType = ty2 + } + + pure d { dDefinition = DExpr e6 + , dSignature = s1 + } + where + bad w = + do recordError (FunctorInstanceBadBacktick (BINested [(w,dName d)])) + pure d + +data Params decl use = Params + { pDecl :: [decl] + , pUse :: [use] + , pSubst :: Map decl use + } + +noParams :: Params decl use +noParams = Params + { pDecl = [] + , pUse = [] + , pSubst = Map.empty + } + +qualLabel :: Maybe ModName -> Ident -> Ident +qualLabel mb i = + case mb of + Nothing -> i + Just mn -> + let txt = Text.intercalate "'" (modNameChunksText mn ++ [identText i]) + in mkIdent txt + + +type TypeParams = Params TParam Type +type ValParams = Params Name Expr + +newTypeParams :: (Name -> TPFlavor) -> RewM (TypeParams,[Prop]) +newTypeParams flav = + do ro <- ask + let newFlaf q = flav . mapNameIdent (qualLabel q) + as <- lift (forM (tparams ro) \(q,a) -> TC.freshTParam (newFlaf q) a) + let bad = [ x + | x : _ : _ <- group (sort (map nameIdent (mapMaybe tpName as))) + ] + forM_ bad \i -> + recordError (FunctorInstanceBadBacktick (BIMultipleParams i)) + + let ts = map (TVar . TVBound) as + su = Map.fromList (zip (map snd (tparams ro)) ts) + ps = Params { pDecl = as, pUse = ts, pSubst = su } + cs <- rewTypeM ps (constraints ro) + pure (ps,cs) + +-- Note: we pass all value parameters as a record +newValParams :: TypeParams -> RewM (ValParams, [(Name,Type)]) +newValParams tps = + do ro <- ask + let vps = vparams ro + if Map.null vps + then pure (noParams, []) + else do xts <- forM (Map.toList vps) \((q,x),t) -> + do t1 <- rewTypeM tps t + let l = qualLabel q (nameIdent x) + pure (x, l, t1) + let (xs,ls,ts) = unzip3 xts + fs = zip ls ts + sel l = RecordSel l (Just ls) + + t <- case recordFromFieldsErr fs of + Right ok -> pure (TRec ok) + Left (x,_) -> + do recordError (FunctorInstanceBadBacktick + (BIMultipleParams x)) + pure (TRec (recordFromFields fs)) + + r <- lift (TC.newLocalName NSValue (mkIdent "params")) + let e = EVar r + pure + ( Params + { pDecl = [r] + , pUse = [e] + , pSubst = Map.fromList [ (x,ESel e (sel l)) + | (x,l) <- zip xs ls ] + } + , [ (r,t) ] + ) + +liftRew :: + ((?isOurs :: Name -> Bool, ?newNewtypes :: Map Name Newtype) => a) -> + RewM a +liftRew x = + do ro <- ask + let ?isOurs = isOurs ro + ?newNewtypes = newNewtypes ro + pure x + +rewTypeM :: RewType t => TypeParams -> t -> RewM t +rewTypeM ps x = + do let ?tparams = ps + liftRew rewType <*> pure x + +rewValM :: RewVal t => TypeParams -> Int -> ValParams -> t -> RewM t +rewValM ts cs vs x = + do let ?tparams = ts + ?cparams = cs + ?vparams = vs + liftRew rew <*> pure x + +class RewType t where + rewType :: + ( ?isOurs :: Name -> Bool + , ?newNewtypes :: Map Name Newtype -- Lazy + , ?tparams :: TypeParams + ) => t -> t + +instance RewType Type where + rewType ty = + case ty of + + TCon tc ts + | TC (TCAbstract (UserTC x _)) <- tc + , ?isOurs x -> TCon tc (pUse ?tparams ++ rewType ts) + | otherwise -> TCon tc (rewType ts) + + TVar x -> + case x of + TVBound x' -> + case Map.lookup x' (pSubst ?tparams) of + Just t -> t + Nothing -> ty + TVFree {} -> panic "rawType" ["Free unification variable"] + + TUser f ts t + | ?isOurs f -> TUser f (pUse ?tparams ++ rewType ts) (rewType t) + | otherwise -> TUser f (rewType ts) (rewType t) + + TRec fs -> TRec (rewType fs) + + TNewtype tdef ts + | ?isOurs nm -> TNewtype tdef' (pUse ?tparams ++ rewType ts) + | otherwise -> TNewtype tdef (rewType ts) + where + nm = ntName tdef + tdef' = case Map.lookup nm ?newNewtypes of + Just yes -> yes + Nothing -> panic "rewType" [ "Missing recursive newtype" + , show (pp nm) ] + +instance RewType a => RewType [a] where + rewType = fmap rewType + +instance RewType b => RewType (RecordMap a b) where + rewType = fmap rewType + +instance RewType Schema where + rewType sch = + Forall { sVars = sVars sch + , sProps = rewType (sProps sch) + , sType = rewType (sType sch) + } + + +class RewVal t where + rew :: + ( ?isOurs :: Name -> Bool + , ?newNewtypes :: Map Name Newtype -- Lazy + , ?tparams :: TypeParams + , ?cparams :: Int -- Number of constraitns + , ?vparams :: ValParams + ) => t -> t + +instance RewVal a => RewVal [a] where + rew = fmap rew + +instance RewVal b => RewVal (RecordMap a b) where + rew = fmap rew + +{- x as cs vs --> + e (newAs ++ as) (newCS ++ cs) (newVS ++ vs) +-} +instance RewVal Expr where + rew expr = + case expr of + EList es t -> EList (rew es) (rewType t) + ETuple es -> ETuple (rew es) + ERec fs -> ERec (rew fs) + ESel e l -> ESel (rew e) l + ESet t e1 s e2 -> ESet (rewType t) (rew e1) s (rew e2) + EIf e1 e2 e3 -> EIf (rew e1) (rew e2) (rew e3) + EComp t1 t2 e mss -> EComp (rewType t1) (rewType t2) (rew e) (rew mss) + EVar x -> tryVarApp + case Map.lookup x (pSubst ?vparams) of + Just p -> p + Nothing -> expr + + ETApp e t -> tryVarApp (ETApp (rew e) (rewType t)) + EProofApp e -> tryVarApp (EProofApp (rew e)) + + EApp e1 e2 -> EApp (rew e1) (rew e2) + ETAbs a e -> ETAbs a (rew e) + EAbs x t e -> EAbs x (rewType t) (rew e) + ELocated r e -> ELocated r (rew e) + EProofAbs p e -> EProofAbs (rewType p) (rew e) + EWhere e ds -> EWhere (rew e) (rew ds) + EPropGuards gs t -> EPropGuards gs' (rewType t) + where gs' = [ (rewType <$> p, rew e) | (p,e) <- gs ] + + where + tryVarApp orElse = + case splitExprInst expr of + (EVar x, ts, cs) | ?isOurs x -> + let ets = foldl ETApp (EVar x) (pUse ?tparams ++ rewType ts) + eps = iterate EProofApp ets !! (?cparams + cs) + evs = foldl EApp eps (pUse ?vparams) + in evs + _ -> orElse + + +instance RewVal DeclGroup where + rew dg = + case dg of + Recursive ds -> Recursive (rew ds) + NonRecursive d -> NonRecursive (rew d) + +instance RewVal Decl where + rew d = d { dDefinition = rew (dDefinition d) + , dSignature = rewType (dSignature d) + } + +instance RewVal DeclDef where + rew def = + case def of + DPrim -> def + DForeign {} -> def + DExpr e -> DExpr (rew e) + +instance RewVal Match where + rew ma = + case ma of + From x t1 t2 e -> From x (rewType t1) (rewType t2) (rew e) + Let d -> Let (rew d) + + diff --git a/src/Cryptol/TypeCheck/ModuleInstance.hs b/src/Cryptol/TypeCheck/ModuleInstance.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/TypeCheck/ModuleInstance.hs @@ -0,0 +1,168 @@ +{-# Language ImplicitParams, ConstraintKinds #-} +module Cryptol.TypeCheck.ModuleInstance where + +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Set(Set) +import qualified Data.Set as Set + +import Cryptol.Parser.Position(Located) +import Cryptol.ModuleSystem.Interface(IfaceNames(..)) +import Cryptol.IR.TraverseNames(TraverseNames,mapNames) +import Cryptol.TypeCheck.AST +import Cryptol.TypeCheck.Subst(Subst,TVars,apSubst) + + +{- | `?tSu` should be applied to all types. + `?vSu` shoudl be applied to all values. -} +type Su = (?tSu :: Subst, ?vSu :: Map Name Name) + +-- | Has value names but no types. +doVInst :: (Su, TraverseNames a) => a -> a +doVInst = mapNames (\x -> Map.findWithDefault x x ?vSu) + +-- | Has types but not values. +doTInst :: (Su, TVars a) => a -> a +doTInst = apSubst ?tSu + +-- | Has both value names and types. +doTVInst :: (Su, TVars a, TraverseNames a) => a -> a +doTVInst = apSubst ?tSu . doVInst + +doMap :: (Su, ModuleInstance a) => Map Name a -> Map Name a +doMap mp = + Map.fromList [ (moduleInstance x, moduleInstance d) | (x,d) <- Map.toList mp ] + +doSet :: Su => Set Name -> Set Name +doSet = Set.fromList . map moduleInstance . Set.toList + + + + +class ModuleInstance t where + moduleInstance :: Su => t -> t + +instance ModuleInstance a => ModuleInstance [a] where + moduleInstance = map moduleInstance + +instance ModuleInstance a => ModuleInstance (Located a) where + moduleInstance l = moduleInstance <$> l + +instance ModuleInstance Name where + moduleInstance = doVInst + +instance ModuleInstance name => ModuleInstance (ImpName name) where + moduleInstance x = + case x of + ImpTop t -> ImpTop t + ImpNested n -> ImpNested (moduleInstance n) + +instance ModuleInstance (ModuleG name) where + moduleInstance m = + Module { mName = mName m + , mDoc = Nothing + , mExports = doVInst (mExports m) + , mParamTypes = doMap (mParamTypes m) + , mParamFuns = doMap (mParamFuns m) + , mParamConstraints = moduleInstance (mParamConstraints m) + , mParams = moduleInstance <$> mParams m + , mFunctors = doMap (mFunctors m) + , mNested = doSet (mNested m) + , mTySyns = doMap (mTySyns m) + , mNewtypes = doMap (mNewtypes m) + , mPrimTypes = doMap (mPrimTypes m) + , mDecls = moduleInstance (mDecls m) + , mSubmodules = doMap (mSubmodules m) + , mSignatures = doMap (mSignatures m) + } + +instance ModuleInstance Type where + moduleInstance = doTInst + +instance ModuleInstance Schema where + moduleInstance = doTInst + +instance ModuleInstance TySyn where + moduleInstance ts = + TySyn { tsName = moduleInstance (tsName ts) + , tsParams = tsParams ts + , tsConstraints = moduleInstance (tsConstraints ts) + , tsDef = moduleInstance (tsDef ts) + , tsDoc = tsDoc ts + } + +instance ModuleInstance Newtype where + moduleInstance nt = + Newtype { ntName = moduleInstance (ntName nt) + , ntParams = ntParams nt + , ntConstraints = moduleInstance (ntConstraints nt) + , ntConName = moduleInstance (ntConName nt) + , ntFields = moduleInstance <$> ntFields nt + , ntDoc = ntDoc nt + } + +instance ModuleInstance AbstractType where + moduleInstance at = + AbstractType { atName = moduleInstance (atName at) + , atKind = atKind at + , atCtrs = let (ps,cs) = atCtrs at + in (ps, moduleInstance cs) + , atFixitiy = atFixitiy at + , atDoc = atDoc at + } + +instance ModuleInstance DeclGroup where + moduleInstance dg = + case dg of + Recursive ds -> Recursive (moduleInstance ds) + NonRecursive d -> NonRecursive (moduleInstance d) + +instance ModuleInstance Decl where + moduleInstance = doTVInst + + +instance ModuleInstance name => ModuleInstance (IfaceNames name) where + moduleInstance ns = + IfaceNames { ifsName = moduleInstance (ifsName ns) + , ifsNested = doSet (ifsNested ns) + , ifsDefines = doSet (ifsDefines ns) + , ifsPublic = doSet (ifsPublic ns) + , ifsDoc = ifsDoc ns + } + +instance ModuleInstance ModParamNames where + moduleInstance si = + ModParamNames { mpnTypes = doMap (mpnTypes si) + , mpnConstraints = moduleInstance (mpnConstraints si) + , mpnFuns = doMap (mpnFuns si) + , mpnTySyn = doMap (mpnTySyn si) + , mpnDoc = mpnDoc si + } + +instance ModuleInstance ModTParam where + moduleInstance mp = + ModTParam { mtpName = moduleInstance (mtpName mp) + , mtpKind = mtpKind mp + , mtpDoc = mtpDoc mp + } + +instance ModuleInstance ModVParam where + moduleInstance mp = + ModVParam { mvpName = moduleInstance (mvpName mp) + , mvpType = moduleInstance (mvpType mp) + , mvpDoc = mvpDoc mp + , mvpFixity = mvpFixity mp + } + +instance ModuleInstance ModParam where + moduleInstance p = + ModParam { mpName = mpName p + , mpIface = moduleInstance (mpIface p) + , mpParameters = moduleInstance (mpParameters p) + , mpQual = mpQual p + } + + + + + diff --git a/src/Cryptol/TypeCheck/Monad.hs b/src/Cryptol/TypeCheck/Monad.hs --- a/src/Cryptol/TypeCheck/Monad.hs +++ b/src/Cryptol/TypeCheck/Monad.hs @@ -5,7 +5,6 @@ -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable -{-# LANGUAGE Safe #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -22,6 +21,7 @@ import qualified Control.Applicative as A import qualified Control.Monad.Fail as Fail import Control.Monad.Fix(MonadFix(..)) +import Data.Text(Text) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Map (Map) @@ -38,13 +38,14 @@ import MonadLib hiding (mapM) import Cryptol.ModuleSystem.Name - (FreshM(..),Supply,mkParameter - , nameInfo, NameInfo(..),NameSource(..)) + (FreshM(..),Supply,mkLocal,asLocal + , nameInfo, NameInfo(..),NameSource(..), nameTopModule) +import qualified Cryptol.ModuleSystem.Interface as If import Cryptol.Parser.Position import qualified Cryptol.Parser.AST as P import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Subst -import Cryptol.TypeCheck.Interface(genIface) +import Cryptol.TypeCheck.Interface(genIfaceWithNames,genIfaceNames) import Cryptol.TypeCheck.Unify(doMGU, runResult, UnificationError(..) , Path, rootPath) import Cryptol.TypeCheck.InferTypes @@ -54,8 +55,8 @@ import qualified Cryptol.TypeCheck.SimpleSolver as Simple import qualified Cryptol.TypeCheck.Solver.SMT as SMT import Cryptol.TypeCheck.PP(NameMap) -import Cryptol.Utils.PP(pp, (<+>), text,commaSep,brackets) -import Cryptol.Utils.Ident(Ident,Namespace(..)) +import Cryptol.Utils.PP(pp, (<+>), text,commaSep,brackets,debugShowUniques) +import Cryptol.Utils.Ident(Ident,Namespace(..),ModName) import Cryptol.Utils.Panic(panic) -- | Information needed for type inference. @@ -64,15 +65,16 @@ , inpVars :: Map Name Schema -- ^ Variables that are in scope , inpTSyns :: Map Name TySyn -- ^ Type synonyms that are in scope , inpNewtypes :: Map Name Newtype -- ^ Newtypes in scope - , inpAbstractTypes :: Map Name AbstractType -- ^ Abstract types in scope + , inpAbstractTypes :: Map Name AbstractType -- ^ Abstract types in scope + , inpSignatures :: !(Map Name ModParamNames) -- ^ Signatures in scope + , inpTopModules :: ModName -> Maybe (ModuleG (), If.IfaceG ()) + , inpTopSignatures :: ModName -> Maybe ModParamNames + -- When typechecking a module these start off empty. -- We need them when type-checking an expression at the command -- line, for example. - , inpParamTypes :: !(Map Name ModTParam) -- ^ Type parameters - , inpParamConstraints :: !([Located Prop]) -- ^ Constraints on parameters - , inpParamFuns :: !(Map Name ModVParam) -- ^ Value parameters - + , inpParams :: !ModParamNames , inpNameSeeds :: NameSeeds -- ^ Private state of type-checker , inpMonoBinds :: Bool -- ^ Should local bindings without @@ -120,24 +122,35 @@ io $ modifyIORef' iSolveCounter (+1) runInferM :: TVars a => InferInput -> InferM a -> IO (InferOutput a) -runInferM info (IM m) = - do counter <- newIORef 0 +runInferM info m0 = + do let IM m = selectorScope m0 + counter <- newIORef 0 + let allPs = inpParams info + let env = Map.map ExtVar (inpVars info) - <> Map.map (ExtVar . newtypeConType) (inpNewtypes info) + <> Map.fromList + [ (ntConName nt, ExtVar (newtypeConType nt)) + | nt <- Map.elems (inpNewtypes info) + ] + <> Map.map (ExtVar . mvpType) (mpnFuns allPs) - rec ro <- return RO { iRange = inpRange info + let ro = RO { iRange = inpRange info , iVars = env + , iExtModules = inpTopModules info + , iExtSignatures = inpTopSignatures info , iExtScope = (emptyModule ExternalScope) - { mTySyns = inpTSyns info + { mTySyns = inpTSyns info <> + mpnTySyn allPs , mNewtypes = inpNewtypes info , mPrimTypes = inpAbstractTypes info - , mParamTypes = inpParamTypes info - , mParamFuns = inpParamFuns info - , mParamConstraints = inpParamConstraints info + , mParamTypes = mpnTypes allPs + , mParamFuns = mpnFuns allPs + , mParamConstraints = mpnConstraints allPs + , mSignatures = inpSignatures info } , iTVars = [] - , iSolvedHasLazy = iSolvedHas finalRW -- RECURSION + , iSolvedHasLazy = Map.empty , iMonoBinds = inpMonoBinds info , iCallStacks = inpCallStacks info , iSolver = inpSolver info @@ -145,29 +158,30 @@ , iSolveCounter = counter } - (result, finalRW) <- runStateT rw - $ runReaderT ro m -- RECURSION - - let theSu = iSubst finalRW - defSu = defaultingSubst theSu - warns = fmap' (fmap' (apSubst theSu)) (iWarnings finalRW) + mb <- runExceptionT (runStateT rw (runReaderT ro m)) + case mb of + Left errs -> inferFailed [] errs + Right (result, finalRW) -> + do let theSu = iSubst finalRW + defSu = defaultingSubst theSu + warns = fmap' (fmap' (apSubst theSu)) (iWarnings finalRW) - case iErrors finalRW of - [] -> - case (iCts finalRW, iHasCts finalRW) of - (cts,[]) - | nullGoals cts -> inferOk warns - (iNameSeeds finalRW) - (iSupply finalRW) - (apSubst defSu result) - (cts,has) -> - inferFailed warns - [ ( goalRange g - , UnsolvedGoals [apSubst theSu g] - ) | g <- fromGoals cts ++ map hasGoal has - ] + 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 inferOk ws a b c = pure (InferOK (computeFreeVarNames ws []) ws a b c) @@ -193,18 +207,70 @@ , iBindTypes = mempty } - - +{- | This introduces a new "selector scope" which is currently a module. +I think that it might be possible to have selectors scopes be groups +of recursive declarations instead, as we are not going to learn anything +additional once we are done with the recursive group that generated +the selectors constraints. We do it at the module level because this +allows us to report more errors at once. +A selector scope does the following: + * Keep track of the Has constraints generated in this scope + * Keep track of the solutions for discharged selector constraints: + - this uses a laziness trick where we build up a map containing the + solutions for the Has constraints in the state + - the *final* value for this map (i.e., at the value the end of the scope) + is passed in as thunk in the reader component of the moment + - as we type check expressions when we need the solution for a Has + constraint we look it up from the reader environment; note that + since the map is not yet built up we just get back a thunk, so we have + to be carefule to not force it until *after* we've solved the goals + - all of this happens in the `rec` block below + * At the end of a selector scope we make sure that all Has constraints were + discharged. If not, we *abort* further type checking. The reason for + aborting rather than just recording an error is that the expression + which produce contains thunks that will lead to non-termination if forced, + and some type-checking operations (e.g., instantiation a functor) + require us to traverse the expressions. +-} +selectorScope :: InferM a -> InferM a +selectorScope (IM m1) = IM + do ro <- ask + rw <- get + mb <- inBase + do rec let ro1 = ro { iSolvedHasLazy = solved } + rw1 = rw { iHasCts = [] : iHasCts rw } + mb <- runExceptionT (runStateT rw1 (runReaderT ro1 m1)) + let solved = case mb of + Left {} -> Map.empty + Right (_,rw2) -> iSolvedHas rw2 + pure mb + case mb of + Left err -> raise err + Right (a,rw1) -> + case iHasCts rw1 of + us : cs -> + do let errs = [ (goalRange g, UnsolvedGoals [g]) + | g <- map hasGoal us ] + set rw1 { iErrors = errs ++ iErrors rw1, iHasCts = cs } + unIM (abortIfErrors) + pure a + [] -> panic "selectorScope" ["No selector scope"] -newtype InferM a = IM { unIM :: ReaderT RO (StateT RW IO) a } +newtype InferM a = IM { unIM :: ReaderT RO + ( StateT RW + ( ExceptionT [(Range,Error)] + IO + )) a } data ScopeName = ExternalScope | LocalScope | SubModule Name + | SignatureScope Name (Maybe Text) -- ^ The Text is docs + | TopSignatureScope P.ModName | MTopModule P.ModName -- | Read-only component of the monad. @@ -219,10 +285,20 @@ , iTVars :: [TParam] -- ^ Type variable that are in scope + , iExtModules :: ModName -> Maybe (ModuleG (), If.IfaceG ()) + -- ^ An exteral top-level module. + -- We need the actual module when we instantiate functors, + -- because currently the type-checker desugars such modules. + + , iExtSignatures :: ModName -> Maybe ModParamNames + -- ^ External top-level signatures. + , iExtScope :: ModuleG ScopeName -- ^ These are things we know about, but are not part of the -- modules we are currently constructing. -- XXX: this sould probably be an interface + -- NOTE: External functors should be looked up in `iExtModules` + -- and not here, as they may be top-level modules. , iSolvedHasLazy :: Map Int HasGoalSln -- ^ NOTE: This field is lazy in an important way! It is the @@ -274,12 +350,18 @@ -- Constraints that need solving , iCts :: !Goals -- ^ Ordinary constraints - , iHasCts :: ![HasGoal] - {- ^ Tuple/record projection constraints. The 'Int' is the "name" - of the constraint, used so that we can name its solution properly. -} + , iHasCts :: ![[HasGoal]] + {- ^ Tuple/record projection constraints. These are separate from + the other constraints because solving them results in actual elaboration + of the term, indicating how to do the projection. The modification + of the term is done using lazyness, by looking up a thunk ahead of time + (@iSolvedHasLazy@ in RO), which is filled in when the constrait is + solved (@iSolvedHas@). See also `selectorScope`. + -} , iScope :: ![ModuleG ScopeName] -- ^ Nested scopes we are currently checking, most nested first. + -- These are basically partially built modules. , iBindTypes :: !(Map Name Schema) -- ^ Types of variables that we know about. We don't worry about scoping @@ -317,6 +399,7 @@ io :: IO a -> InferM a io m = IM $ inBase m + -- | The monadic computation is about the given range of source code. -- This is useful for error reporting. inRange :: Range -> InferM a -> InferM a @@ -345,7 +428,17 @@ IM $ sets_ $ \s -> s { iErrors = (r,e) : iErrors s } - +-- | If there are any recoded errors than abort firther type-checking. +abortIfErrors :: InferM () +abortIfErrors = + do rw <- IM get + case iErrors rw of + [] -> pure () + es -> + do es1 <- forM es \(l,e) -> + do e1 <- applySubst e + pure (l,e1) + IM (raise es1) recordWarning :: Warning -> InferM () recordWarning w = @@ -358,7 +451,7 @@ ignore | DefaultingTo d _ <- w , Just n <- tvSourceName (tvarDesc d) - , Declared _ SystemName <- nameInfo n + , GlobalName SystemName _ <- nameInfo n = True | otherwise = False @@ -443,22 +536,30 @@ newHasGoal l ty f = do goalName <- newGoalName g <- newGoal CtSelector (pHas l ty f) - IM $ sets_ $ \s -> s { iHasCts = HasGoal goalName g : iHasCts s } + IM $ sets_ \s -> case iHasCts s of + cs : more -> + s { iHasCts = (HasGoal goalName g : cs) : more } + [] -> panic "newHasGoal" ["no selector scope"] solns <- IM $ fmap iSolvedHasLazy ask return $ case Map.lookup goalName solns of Just e1 -> e1 Nothing -> panic "newHasGoal" ["Unsolved has goal in result"] --- | Add a previously generate has constrained +-- | Add a previously generated @Has@ constraint addHasGoal :: HasGoal -> InferM () -addHasGoal g = IM $ sets_ $ \s -> s { iHasCts = g : iHasCts s } +addHasGoal g = IM $ sets_ \s -> case iHasCts s of + cs : more -> s { iHasCts = (g : cs) : more } + [] -> panic "addHasGoal" ["No selector scope"] -- | Get the @Has@ constraints. Each of this should either be solved, -- or added back using 'addHasGoal'. getHasGoals :: InferM [HasGoal] -getHasGoals = do gs <- IM $ sets $ \s -> (iHasCts s, s { iHasCts = [] }) - applySubst gs +getHasGoals = + do gs <- IM $ sets \s -> case iHasCts s of + cs : more -> (cs, s { iHasCts = [] : more }) + [] -> panic "getHasGoals" ["No selector scope"] + applySubst gs -- | Specify the solution (@Expr -> Expr@) for the given constraint ('Int'). solveHasGoal :: Int -> HasGoalSln -> InferM () @@ -469,10 +570,10 @@ -------------------------------------------------------------------------------- -- | Generate a fresh variable name to be used in a local binding. -newParamName :: Namespace -> Ident -> InferM Name -newParamName ns x = +newLocalName :: Namespace -> Ident -> InferM Name +newLocalName ns x = do r <- curRange - liftSupply (mkParameter ns x r) + liftSupply (mkLocal ns x r) newName :: (NameSeeds -> (a , NameSeeds)) -> InferM a newName upd = IM $ sets $ \s -> let (x,seeds) = upd (iNameSeeds s) @@ -506,7 +607,7 @@ checkParamKind tp flav k = case flav of - TPModParam _ -> return () -- All kinds allowed as module parameters + TPModParam _ -> starOrHash TPPropSynParam _ -> starOrHashOrProp TPTySynParam _ -> starOrHash TPSchemaParam _ -> starOrHash @@ -547,7 +648,20 @@ checkParamKind tp flav k return tp +-- | Generate a new version of a type parameter. We use this when +-- instantiating module parameters (the "backtick" imports) +freshTParam :: (Name -> TPFlavor) -> TParam -> InferM TParam +freshTParam mkF tp = newName \s -> + let u = seedTVar s + in ( tp { tpUnique = u + , tpFlav = case tpName tp of + Just n -> mkF (asLocal NSType n) + Nothing -> tpFlav tp -- shouldn't happen? + } + , s { seedTVar = u + 1 } + ) + -- | Generate an unknown type. The doc is a note about what is this type about. newType :: TypeSource -> Kind -> InferM Type newType src k = TVar `fmap` newTVar src k @@ -635,7 +749,8 @@ case v of ExtVar sch -> getVars sch CurSCC _ t -> getVars t - sels <- IM $ fmap (map (goal . hasGoal) . iHasCts) get + hasCts <- IM (iHasCts <$> get) + let sels = map (goal . hasGoal) (concat hasCts) fromSels <- mapM getVars sels fromEx <- (getVars . concatMap Map.elems) =<< IM (fmap iExistTVars get) return (Set.unions fromEnv `Set.union` Set.unions fromSels @@ -656,8 +771,12 @@ do mb1 <- Map.lookup x . iBindTypes <$> IM get case mb1 of Just a -> pure (ExtVar a) - Nothing -> panic "lookupVar" [ "Undefined vairable" - , show x ] + Nothing -> + do mp <- IM $ asks iVars + panic "lookupVar" $ [ "Undefined vairable" + , show x + , "IVARS" + ] ++ map (show . debugShowUniques . pp) (Map.keys mp) -- | Lookup a type variable. Return `Nothing` if there is no such variable -- in scope, in which case we must be dealing with a type constant. @@ -680,10 +799,89 @@ lookupParamType :: Name -> InferM (Maybe ModTParam) lookupParamType x = Map.lookup x <$> getParamTypes --- | Lookup the schema for a parameter function. -lookupParamFun :: Name -> InferM (Maybe ModVParam) -lookupParamFun x = Map.lookup x <$> getParamFuns +lookupSignature :: P.ImpName Name -> InferM ModParamNames +lookupSignature nx = + case nx of + -- XXX: top + P.ImpNested x -> + do sigs <- getSignatures + case Map.lookup x sigs of + Just ips -> pure ips + Nothing -> panic "lookupSignature" + [ "Missing signature", show x ] + P.ImpTop t -> + do loaded <- iExtSignatures <$> IM ask + case loaded t of + Just ps -> pure ps + Nothing -> panic "lookupSignature" + [ "Top level signature is not loaded", show (pp nx) ] + +-- | Lookup an external (i.e., previously loaded) top module. +lookupTopModule :: ModName -> InferM (Maybe (ModuleG (), If.IfaceG ())) +lookupTopModule m = + do ms <- iExtModules <$> IM ask + pure (ms m) + +lookupFunctor :: P.ImpName Name -> InferM (ModuleG ()) +lookupFunctor iname = + case iname of + P.ImpTop m -> fst . fromMb <$> lookupTopModule m + P.ImpNested m -> + do localFuns <- getScope mFunctors + case Map.lookup m localFuns of + Just a -> pure a { mName = () } + Nothing -> + do mbTop <- lookupTopModule (nameTopModule m) + pure (fromMb do a <- fst <$> mbTop + b <- Map.lookup m (mFunctors a) + pure b { mName = () }) + where + fromMb mb = case mb of + Just a -> a + Nothing -> panic "lookupFunctor" + [ "Missing functor", show iname ] + + +{- | Get information about the things defined in the module. +Note that, in general, the interface may contain *more* than just the +definitions in the module, however the `ifNames` should indicate which +ones are part of the module. +-} +lookupModule :: P.ImpName Name -> InferM (If.IfaceG ()) +lookupModule iname = + case iname of + P.ImpTop m -> snd . fromMb <$> lookupTopModule m + P.ImpNested m -> + do localMods <- getScope mSubmodules + case Map.lookup m localMods of + Just names -> + do n <- genIfaceWithNames names <$> getCurDecls + pure (If.ifaceForgetName n) + + Nothing -> + do mb <- lookupTopModule (nameTopModule m) + pure (fromMb + do iface <- snd <$> mb + names <- Map.lookup m + (If.ifModules (If.ifDefines iface)) + pure iface + { If.ifNames = names { If.ifsName = () } }) + + where + fromMb mb = case mb of + Just a -> a + Nothing -> panic "lookupModule" + [ "Missing module", show iname ] + + + +lookupModParam :: P.Ident -> InferM (Maybe ModParam) +lookupModParam p = + do scope <- getScope mParams + pure (Map.lookup p scope) + + -- | Check if we already have a name for this existential type variable and, -- if so, return the definition. If not, try to create a new definition, -- if this is allowed. If not, returns nothing. @@ -717,10 +915,6 @@ getAbstractTypes :: InferM (Map Name AbstractType) getAbstractTypes = getScope mPrimTypes --- | Returns the parameter functions declarations -getParamFuns :: InferM (Map Name ModVParam) -getParamFuns = getScope mParamFuns - -- | Returns the abstract function declarations getParamTypes :: InferM (Map Name ModTParam) getParamTypes = getScope mParamTypes @@ -748,6 +942,11 @@ getCallStacks :: InferM Bool getCallStacks = IM (asks iCallStacks) +getSignatures :: InferM (Map Name ModParamNames) +getSignatures = getScope mSignatures + + + {- | We disallow shadowing between type synonyms and type variables because it is confusing. As a bonus, in the implementation we don't need to worry about where we lookup things (i.e., in the variable or @@ -795,15 +994,28 @@ newLocalScope :: InferM () newLocalScope = newScope LocalScope -newSubmoduleScope :: Name -> [Import] -> ExportSpec Name -> InferM () -newSubmoduleScope x is e = - do newScope (SubModule x) - updScope \m -> m { mImports = is, mExports = e } +newSignatureScope :: Name -> Maybe Text -> InferM () +newSignatureScope x doc = + do updScope \o -> o { mNested = Set.insert x (mNested o) } + newScope (SignatureScope x doc) -newModuleScope :: P.ModName -> [Import] -> ExportSpec Name -> InferM () -newModuleScope x is e = +newTopSignatureScope :: ModName -> InferM () +newTopSignatureScope x = newScope (TopSignatureScope x) + +{- | Start a new submodule scope. The imports and exports are just used +to initialize an empty module. As we type check declarations they are +added to this module's scope. -} +newSubmoduleScope :: + Name -> Maybe Text -> ExportSpec Name -> InferM () +newSubmoduleScope x docs e = + do updScope \o -> o { mNested = Set.insert x (mNested o) } + newScope (SubModule x) + updScope \m -> m { mDoc = docs, mExports = e } + +newModuleScope :: P.ModName -> ExportSpec Name -> InferM () +newModuleScope x e = do newScope (MTopModule x) - updScope \m -> m { mImports = is, mExports = e } + updScope \m -> m { mDoc = Nothing, mExports = e } -- | Update the current scope (first in the list). Assumes there is one. updScope :: (ModuleG ScopeName -> ModuleG ScopeName) -> InferM () @@ -829,40 +1041,85 @@ case iScope rw of x@Module { mName = SubModule m } : y : more -> rw { iScope = z : more } where - x1 = x { mName = m } - iface = genIface x1 - me = if isParametrizedModule x1 then Map.singleton m x1 else mempty - z = y { mImports = mImports x ++ mImports y -- just for deps - , mSubModules = Map.insert m iface (mSubModules y) + x1 = x { mName = m, mDecls = reverse (mDecls x) } - , mTySyns = mTySyns x <> mTySyns y - , mNewtypes = mNewtypes x <> mNewtypes y - , mPrimTypes = mPrimTypes x <> mPrimTypes y - , mDecls = mDecls x <> mDecls y - , mFunctors = me <> mFunctors x <> mFunctors y + isFun = isParametrizedModule x1 + + add :: Monoid a => (ModuleG ScopeName -> a) -> a + add f = if isFun then f y else f x <> f y + + z = Module + { mName = mName y + , mDoc = mDoc y + , mExports = mExports y + , mParamTypes = mParamTypes y + , mParamFuns = mParamFuns y + , mParamConstraints = mParamConstraints y + , mParams = mParams y + , mNested = mNested y + + , mTySyns = add mTySyns + , mNewtypes = add mNewtypes + , mPrimTypes = add mPrimTypes + , mDecls = add mDecls + , mSignatures = add mSignatures + , mSubmodules = if isFun + then mSubmodules y + else Map.insert m (genIfaceNames x1) + (mSubmodules x <> mSubmodules y) + , mFunctors = if isFun + then Map.insert m x1 (mFunctors y) + else mFunctors x <> mFunctors y } _ -> panic "endSubmodule" [ "Not a submodule" ] -endModule :: InferM Module +endModule :: InferM TCTopEntity endModule = IM $ sets \rw -> case iScope rw of [ x ] | MTopModule m <- mName x -> - ( x { mName = m, mDecls = reverse (mDecls x) } + ( TCTopModule x { mName = m, mDecls = reverse (mDecls x) } , rw { iScope = [] } ) _ -> panic "endModule" [ "Not a single top module" ] -endModuleInstance :: InferM () -endModuleInstance = +endSignature :: InferM () +endSignature = IM $ sets_ \rw -> case iScope rw of - [ x ] | MTopModule _ <- mName x -> rw { iScope = [] } - _ -> panic "endModuleInstance" [ "Not single top module" ] + x@Module { mName = SignatureScope m doc } : y : more -> + rw { iScope = z : more } + where + z = y { mSignatures = Map.insert m sig (mSignatures y) } + sig = ModParamNames + { mpnTypes = mParamTypes x + , mpnConstraints = mParamConstraints x + , mpnFuns = mParamFuns x + , mpnTySyn = mTySyns x + , mpnDoc = doc + } + _ -> panic "endSignature" [ "Not a signature scope" ] +endTopSignature :: InferM TCTopEntity +endTopSignature = + IM $ sets \rw -> + case iScope rw of + [ x ] | TopSignatureScope m <- mName x -> + ( TCTopSignature m ModParamNames + { mpnTypes = mParamTypes x + , mpnConstraints = mParamConstraints x + , mpnFuns = mParamFuns x + , mpnTySyn = mTySyns x + , mpnDoc = Nothing + } + , rw { iScope = [] } + ) + _ -> panic "endTopSignature" [ "Not a top-level signature" ] + + -- | Get an environment combining all nested scopes. getScope :: Semigroup a => (ModuleG ScopeName -> a) -> InferM a getScope f = @@ -870,6 +1127,39 @@ rw <- IM get pure (sconcat (f (iExtScope ro) :| map f (iScope rw))) +getCurDecls :: InferM (ModuleG ()) +getCurDecls = + do ro <- IM ask + rw <- IM get + pure (foldr (\m1 m2 -> mergeDecls (forget m1) m2) + (forget (iExtScope ro)) (iScope rw)) + + where + forget m = m { mName = () } + + mergeDecls m1 m2 = + Module + { mName = () + , mDoc = Nothing + , mExports = mempty + , mParams = mempty + , mParamTypes = mempty + , mParamConstraints = mempty + , mParamFuns = mempty + , mNested = mempty + + , mTySyns = uni mTySyns + , mNewtypes = uni mNewtypes + , mPrimTypes = uni mPrimTypes + , mDecls = uni mDecls + , mSubmodules = uni mSubmodules + , mFunctors = uni mFunctors + , mSignatures = uni mSignatures + } + where + uni f = f m1 <> f m2 + + addDecls :: DeclGroup -> InferM () addDecls ds = do updScope \r -> r { mDecls = ds : mDecls r } @@ -888,7 +1178,7 @@ addNewtype :: Newtype -> InferM () addNewtype t = do updScope \r -> r { mNewtypes = Map.insert (ntName t) t (mNewtypes r) } - IM $ sets_ \rw -> rw { iBindTypes = Map.insert (ntName t) + IM $ sets_ \rw -> rw { iBindTypes = Map.insert (ntConName t) (newtypeConType t) (iBindTypes rw) } @@ -897,10 +1187,26 @@ updScope \r -> r { mPrimTypes = Map.insert (atName t) t (mPrimTypes r) } + addParamType :: ModTParam -> InferM () addParamType a = updScope \r -> r { mParamTypes = Map.insert (mtpName a) a (mParamTypes r) } +addSignatures :: Map Name ModParamNames -> InferM () +addSignatures mp = + updScope \r -> r { mSignatures = Map.union mp (mSignatures r) } + +addSubmodules :: Map Name (If.IfaceNames Name) -> InferM () +addSubmodules mp = + updScope \r -> r { mSubmodules = Map.union mp (mSubmodules r) } + +addFunctors :: Map Name (ModuleG Name) -> InferM () +addFunctors mp = + updScope \r -> r { mFunctors = Map.union mp (mFunctors r) } + + + + -- | The sub-computation is performed with the given abstract function in scope. addParamFun :: ModVParam -> InferM () addParamFun x = @@ -912,6 +1218,10 @@ addParameterConstraints :: [Located Prop] -> InferM () addParameterConstraints ps = updScope \r -> r { mParamConstraints = ps ++ mParamConstraints r } + +addModParam :: ModParam -> InferM () +addModParam p = + updScope \r -> r { mParams = Map.insert (mpName p) p (mParams r) } diff --git a/src/Cryptol/TypeCheck/Parseable.hs b/src/Cryptol/TypeCheck/Parseable.hs --- a/src/Cryptol/TypeCheck/Parseable.hs +++ b/src/Cryptol/TypeCheck/Parseable.hs @@ -63,6 +63,8 @@ --NOTE: erase all "proofs" for now (change the following two lines to change that) showParseable (EProofAbs {-p-}_ e) = showParseable e --"(EProofAbs " ++ show p ++ showParseable e ++ ")" showParseable (EProofApp e) = showParseable e --"(EProofApp " ++ showParseable e ++ ")" + + showParseable (EPropGuards guards _) = parens (text "EPropGuards" $$ showParseable guards) instance (ShowParseable a, ShowParseable b) => ShowParseable (a,b) where showParseable (x,y) = parens (showParseable x <> comma <> showParseable y) @@ -93,6 +95,7 @@ instance ShowParseable DeclDef where showParseable DPrim = text (show DPrim) + showParseable (DForeign t) = text (show $ DForeign t) showParseable (DExpr e) = parens (text "DExpr" $$ showParseable e) instance ShowParseable DeclGroup where diff --git a/src/Cryptol/TypeCheck/Sanity.hs b/src/Cryptol/TypeCheck/Sanity.hs --- a/src/Cryptol/TypeCheck/Sanity.hs +++ b/src/Cryptol/TypeCheck/Sanity.hs @@ -5,12 +5,15 @@ -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable +{-# Language OverloadedStrings #-} module Cryptol.TypeCheck.Sanity ( tcExpr , tcDecls , tcModule , ProofObligation + , onlyNonTrivial , Error(..) + , AreSame(..) , same ) where @@ -19,8 +22,10 @@ import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Subst (apSubst, singleTParamSubst) import Cryptol.TypeCheck.Monad(InferInput(..)) +import Cryptol.ModuleSystem.Name(nameLoc) import Cryptol.Utils.Ident import Cryptol.Utils.RecordMap +import Cryptol.Utils.PP import Data.List (sort) import qualified Data.Set as Set @@ -48,7 +53,21 @@ k2 = withVars (Map.toList (fmap mvpType (mParamFuns m))) $ checkDecls (mDecls m) +onlyNonTrivial :: [ProofObligation] -> [ProofObligation] +onlyNonTrivial = filter (not . trivialProofObligation) +-- | Identify proof obligations that are obviously true. +-- We can filter these to avoid clutter +trivialProofObligation :: ProofObligation -> Bool +trivialProofObligation oblig = pIsTrue goal || simpleEq || goal `elem` asmps + where + goal = sType oblig + asmps = sProps oblig + simpleEq = case pIsEqual goal of + Just (t1,t2) -> t1 == t2 + Nothing -> False + + -------------------------------------------------------------------------------- checkDecls :: [DeclGroup] -> TcM () @@ -107,23 +126,68 @@ where check = do mapM_ (checkTypeIs KProp) ps checkTypeIs KType t +data AreSame = SameIf [Prop] + | NotSame +areSame :: AreSame +areSame = SameIf [] + +sameAnd :: AreSame -> AreSame -> AreSame +sameAnd x y = + case (x,y) of + (SameIf xs, SameIf ys) -> SameIf (xs ++ ys) + _ -> NotSame + +sameBool :: Bool -> AreSame +sameBool b = if b then areSame else NotSame + +sameTypes :: String -> Type -> Type -> TcM () +sameTypes msg x y = sameSchemas msg (tMono x) (tMono y) + +sameSchemas :: String -> Schema -> Schema -> TcM () +sameSchemas msg x y = + case same x y of + NotSame -> reportError (TypeMismatch msg x y) + SameIf ps -> mapM_ proofObligation ps + + + + class Same a where - same :: a -> a -> Bool + same :: a -> a -> AreSame instance Same a => Same [a] where - same [] [] = True - same (x : xs) (y : ys) = same x y && same xs ys - same _ _ = False + same [] [] = areSame + same (x : xs) (y : ys) = same x y `sameAnd` same xs ys + same _ _ = NotSame +data Field a b = Field a b + +instance (Eq a, Same b) => Same (Field a b) where + same (Field x a) (Field y b) = sameBool (x == y) `sameAnd` same a b + instance Same Type where - same t1 t2 = tNoUser t1 == tNoUser t2 + same t1 t2 + | k1 /= k2 = NotSame + | k1 == KNum = if t1 == t2 then SameIf [] else SameIf [ t1 =#= t2 ] + | otherwise = + case (tNoUser t1, tNoUser t2) of + (TVar x, TVar y) -> sameBool (x == y) + (TRec x, TRec y) -> same (mkRec x) (mkRec y) + (TNewtype x xs, TNewtype y ys) -> same (Field x xs) (Field y ys) + (TCon x xs, TCon y ys) -> same (Field x xs) (Field y ys) + _ -> NotSame + where + k1 = kindOf t1 + k2 = kindOf t2 + mkRec r = [ Field x y | (x,y) <- canonicalFields r ] instance Same Schema where - same (Forall xs ps s) (Forall ys qs t) = same xs ys && same ps qs && same s t + same (Forall xs ps s) (Forall ys qs t) = + same xs ys `sameAnd` same ps qs `sameAnd` same s t instance Same TParam where - same x y = tpName x == tpName y && tpKind x == tpKind y + same x y = sameBool (tpName x == tpName y && tpKind x == tpKind y) @@ -153,8 +217,7 @@ do checkTypeIs KType t forM_ es $ \e -> do t1 <- exprType e - unless (same t1 t) $ - reportError $ TypeMismatch "EList" (tMono t) (tMono t1) + sameTypes "EList" t1 t return $ tMono $ tSeq (tNum (length es)) t @@ -169,9 +232,7 @@ do ty <- exprType e expe <- checkHas ty x has <- exprType v - unless (same expe has) $ - reportError $ - TypeMismatch "ESet" (tMono expe) (tMono has) + sameTypes "ESet" expe has return (tMono ty) ESel e sel -> do ty <- exprType e @@ -180,13 +241,11 @@ EIf e1 e2 e3 -> do ty <- exprType e1 - unless (same tBit ty) $ - reportError $ TypeMismatch "EIf_condition" (tMono tBit) (tMono ty) + sameTypes "EIf_condition" tBit ty t1 <- exprType e2 t2 <- exprType e3 - unless (same t1 t2) $ - reportError $ TypeMismatch "EIf_arms" (tMono t1) (tMono t2) + sameTypes "EIf_arms" t1 t2 return $ tMono t1 @@ -238,7 +297,9 @@ case tNoUser t1 of TCon (TC TCFun) [ a, b ] - | same a t2 -> return (tMono b) + | SameIf ps <- same a t2 -> + do mapM_ proofObligation ps + return (tMono b) tf -> reportError (BadApplication tf t1) @@ -270,6 +331,9 @@ in go dgs + EPropGuards _guards typ -> + pure Forall {sVars = [], sProps = [], sType = typ} + checkHas :: Type -> Selector -> TcM Type checkHas t sel = case sel of @@ -398,12 +462,19 @@ do when checkSig $ checkSchema $ dSignature d return (dName d, dSignature d) + DForeign _ -> + do when checkSig $ checkSchema $ dSignature d + return (dName d, dSignature d) + DExpr e -> do let s = dSignature d when checkSig $ checkSchema s s1 <- exprSchema e - unless (same s s1) $ - reportError $ TypeMismatch "DExpr" s s1 + let nm = dName d + loc = "definition of " ++ show (pp nm) ++ + ", at " ++ show (pp (nameLoc nm)) + sameSchemas loc s s1 + return (dName d, s) checkDeclGroup :: DeclGroup -> TcM [(Name, Schema)] @@ -427,7 +498,9 @@ t1 <- exprType e case tNoUser t1 of TCon (TC TCSeq) [ l, el ] - | same elt el -> return ((x, tMono elt), l) + | SameIf ps <- same elt el -> + do mapM_ proofObligation ps + return ((x, tMono elt), l) | otherwise -> reportError $ TypeMismatch "From" (tMono elt) (tMono el) @@ -487,13 +560,15 @@ (Left err, _) -> Left err (Right a, s) -> Right (a, woProofObligations s) where + allPs = inpParams env + ro = RO { roTVars = Map.fromList [ (tpUnique x, x) - | tp <- Map.elems (inpParamTypes env) + | tp <- Map.elems (mpnTypes allPs) , let x = mtpParam tp ] - , roAsmps = map thing (inpParamConstraints env) + , roAsmps = map thing (mpnConstraints allPs) , roRange = emptyRange , roVars = Map.union - (fmap mvpType (inpParamFuns env)) + (fmap mvpType (mpnFuns allPs)) (inpVars env) } rw = RW { woProofObligations = [] } @@ -579,3 +654,114 @@ case Map.lookup x (roVars ro) of Just s -> return s Nothing -> reportError $ UndefinedVariable x + + +instance PP Error where + ppPrec _ err = + case err of + + TypeMismatch what expected actual -> + ppErr ("Type mismatch in" <+> text what) + [ "Expected:" <+> pp expected + , "Actual :" <+> pp actual + ] + + ExpectedMono s -> + ppErr "Not a monomorphic type" + [ pp s ] + + TupleSelectorOutOfRange sel sz -> + ppErr "Tuple selector out of range" + [ "Selector:" <+> int sel + , "Size :" <+> int sz + ] + + MissingField f fs -> + ppErr "Invalid record selector" + [ "Field: " <+> pp f + , "Fields:" <+> commaSep (map pp fs) + ] + + UnexpectedTupleShape expected actual -> + ppErr "Unexpected tuple shape" + [ "Expected:" <+> int expected + , "Actual :" <+> int actual + ] + + UnexpectedRecordShape expected actual -> + ppErr "Unexpected record shape" + [ "Expected:" <+> commaSep (map pp expected) + , "Actual :" <+> commaSep (map pp actual) + ] + + UnexpectedSequenceShape n t -> + ppErr "Unexpected sequence shape" + [ "Expected:" <+> int n + , "Actual :" <+> pp t + ] + + BadSelector sel t -> + ppErr "Bad selector" + [ "Selector:" <+> pp sel + , "Type :" <+> pp t + ] + + BadInstantiation -> + ppErr "Bad instantiation" [] + + Captured x -> + ppErr "Captured type variable" + [ "Variable:" <+> pp x ] + + BadProofNoAbs -> + ppErr "Proof application without a proof abstraction" [] + + BadProofTyVars xs -> + ppErr "Proof application with type abstraction" + [ "Type parameter:" <+> pp x | x <- xs ] + + KindMismatch expected actual -> + ppErr "Kind mismatch" + [ "Expected:" <+> pp expected + , "Actual :" <+> pp actual + ] + + NotEnoughArgumentsInKind k -> + ppErr "Not enough arguments in kind" [ pp k ] + + BadApplication t1 t2 -> + ppErr "Bad application" + [ "Function:" <+> pp t1 + , "Argument:" <+> pp t2 + ] + + FreeTypeVariable x -> + ppErr "Free type variable" + [ "Variable:" <+> pp x ] + + BadTypeApplication kf ka -> + ppErr "Bad type application" + [ "Function :" <+> pp kf + , "Arguments:" <+> commaSep (map pp ka) + ] + + RepeatedVariableInForall x -> + ppErr "Repeated variable in forall" + [ "Variable:" <+> pp x ] + + BadMatch t -> + ppErr "Bad match" + [ "Type:" <+> pp t ] + + EmptyArm -> ppErr "Empty comprehension arm" [] + + UndefinedTypeVaraible x -> + ppErr "Undefined type variable" + [ "Variable:" <+> pp x ] + + UndefinedVariable x -> + ppErr "Undefined variable" + [ "Variable:" <+> pp x ] + + where + ppErr x ys = hang x 2 (vcat [ "•" <+> y | y <- ys ]) diff --git a/src/Cryptol/TypeCheck/SimpType.hs b/src/Cryptol/TypeCheck/SimpType.hs --- a/src/Cryptol/TypeCheck/SimpType.hs +++ b/src/Cryptol/TypeCheck/SimpType.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE Safe #-} -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Cryptol.TypeCheck.SimpType where diff --git a/src/Cryptol/TypeCheck/Solve.hs b/src/Cryptol/TypeCheck/Solve.hs --- a/src/Cryptol/TypeCheck/Solve.hs +++ b/src/Cryptol/TypeCheck/Solve.hs @@ -7,10 +7,10 @@ -- Portability : portable {-# LANGUAGE PatternGuards, BangPatterns, RecordWildCards #-} -{-# LANGUAGE Safe #-} module Cryptol.TypeCheck.Solve ( simplifyAllConstraints , proveImplication + , tryProveImplication , proveModuleTopLevel , defaultAndSimplify , defaultReplExpr @@ -37,6 +37,7 @@ import Control.Applicative ((<|>)) import Control.Monad(mzero) +import Data.Containers.ListUtils (nubOrd) import Data.Map (Map) import qualified Data.Map as Map import Data.Set ( Set ) @@ -265,28 +266,49 @@ cs <- getParamConstraints case cs of [] -> addGoals gs1 - _ -> do su2 <- proveImplication Nothing [] [] gs1 + _ -> do su2 <- proveImplication False Nothing [] [] gs1 extendSubst su2 -- | Prove an implication, and return any improvements that we computed. -- Records errors, if any of the goals couldn't be solved. -proveImplication :: Maybe Name -> [TParam] -> [Prop] -> [Goal] -> InferM Subst -proveImplication lnam as ps gs = +proveImplication :: Bool -> Maybe Name -> + [TParam] -> [Prop] -> [Goal] -> InferM Subst +proveImplication dedupErrs lnam as ps gs = do evars <- varsWithAsmps solver <- getSolver extraAs <- (map mtpParam . Map.elems) <$> getParamTypes extra <- map thing <$> getParamConstraints - (mbErr,su) <- io (proveImplicationIO solver lnam evars + (mbErr,su) <- io (proveImplicationIO solver dedupErrs lnam evars (extraAs ++ as) (extra ++ ps) gs) case mbErr of Right ws -> mapM_ recordWarning ws Left errs -> mapM_ recordError errs return su +-- | Tries to prove an implication. If proved, then returns `Right (m_su :: +-- InferM Subst)` where `m_su` is an `InferM` computation that results in the +-- solution substitution, and records any warning invoked during proving. If not +-- proved, then returns `Left (m_err :: InferM ())`, which records all errors +-- invoked during proving. +tryProveImplication :: + Maybe Name -> [TParam] -> [Prop] -> [Goal] -> InferM Bool +tryProveImplication lnam as ps gs = + do evars <- varsWithAsmps + solver <- getSolver + extraAs <- (map mtpParam . Map.elems) <$> getParamTypes + extra <- map thing <$> getParamConstraints + + (mbErr,_su) <- io (proveImplicationIO solver False lnam evars + (extraAs ++ as) (extra ++ ps) gs) + case mbErr of + Left {} -> pure False + Right {} -> pure True + proveImplicationIO :: Solver + -> Bool -- ^ Whether to remove duplicate goals in errors -> Maybe Name -- ^ Checking this function -> Set TVar -- ^ These appear in the env., and we should -- not try to default them @@ -294,8 +316,8 @@ -> [Prop] -- ^ Assumed constraint -> [Goal] -- ^ Collected constraints -> IO (Either [Error] [Warning], Subst) -proveImplicationIO _ _ _ _ [] [] = return (Right [], emptySubst) -proveImplicationIO s f varsInEnv ps asmps0 gs0 = +proveImplicationIO _ _ _ _ _ [] [] = return (Right [], emptySubst) +proveImplicationIO s dedupErrs f varsInEnv ps asmps0 gs0 = do let ctxt = buildSolverCtxt asmps res <- quickSolverIO ctxt gs case res of @@ -315,7 +337,7 @@ return (Left (err gs3:errs), su) -- XXX: Old? (_,newGs,newSu,ws,errs) -> do let su1 = newSu @@ su - (res1,su2) <- proveImplicationIO s f varsInEnv ps + (res1,su2) <- proveImplicationIO s dedupErrs f varsInEnv ps (apSubst su1 asmps0) newGs let su3 = su2 @@ su1 case res1 of @@ -329,7 +351,7 @@ $ DelayedCt { dctSource = f , dctForall = ps , dctAsmps = asmps0 - , dctGoals = us + , dctGoals = if dedupErrs then nubOrd us else us } diff --git a/src/Cryptol/TypeCheck/Solver/Class.hs b/src/Cryptol/TypeCheck/Solver/Class.hs --- a/src/Cryptol/TypeCheck/Solver/Class.hs +++ b/src/Cryptol/TypeCheck/Solver/Class.hs @@ -7,6 +7,7 @@ -- Portability : portable -- -- Solving class constraints. +-- If you make changes to this file, please update the documenation in RefMan.md {-# LANGUAGE PatternGuards #-} module Cryptol.TypeCheck.Solver.Class diff --git a/src/Cryptol/TypeCheck/Solver/Improve.hs b/src/Cryptol/TypeCheck/Solver/Improve.hs --- a/src/Cryptol/TypeCheck/Solver/Improve.hs +++ b/src/Cryptol/TypeCheck/Solver/Improve.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Safe #-} + -- | Look for opportunity to solve goals by instantiating variables. module Cryptol.TypeCheck.Solver.Improve where diff --git a/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs b/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs --- a/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs +++ b/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs @@ -10,11 +10,13 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Safe #-} module Cryptol.TypeCheck.Solver.Numeric.Interval where import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Solver.InfNat +import Cryptol.TypeCheck.PP(NameMap,ppWithNames) import Cryptol.Utils.PP hiding (int) import Data.Map ( Map ) @@ -162,6 +164,14 @@ ppIntervals = vcat . map ppr . Map.toList where ppr (var,i) = pp var <.> char ':' <+> ppInterval i + +ppIntervalsWithNames :: NameMap -> Map TVar Interval -> Doc +ppIntervalsWithNames nms = vcat . map ppr . Map.toList + where + ppr :: (TVar,Interval) -> Doc + ppr (var,i) = ppWithNames nms var <.> char ':' <+> ppInterval i + + ppInterval :: Interval -> Doc ppInterval x = brackets (hsep [ ppr (iLower x) diff --git a/src/Cryptol/TypeCheck/Solver/SMT.hs b/src/Cryptol/TypeCheck/Solver/SMT.hs --- a/src/Cryptol/TypeCheck/Solver/SMT.hs +++ b/src/Cryptol/TypeCheck/Solver/SMT.hs @@ -10,7 +10,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# Language FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeSynonymInstances #-} module Cryptol.TypeCheck.Solver.SMT ( -- * Setup @@ -31,6 +30,9 @@ , checkUnsolvable , tryGetModel , shrinkModel + + -- * Lower level interactions + , inNewFrame, TVars, declareVars, assume, unsolvable ) where import SimpleSMT (SExpr) @@ -187,9 +189,6 @@ -------------------------------------------------------------------------------- - - - -- | Returns goals that were not proved proveImp :: Solver -> [Prop] -> [Goal] -> IO [Goal] proveImp sol ps gs0 = @@ -288,13 +287,26 @@ pop :: Solver -> IO () pop sol = SMT.pop (solver sol) +inNewFrame :: Solver -> IO a -> IO a +inNewFrame sol m = + do push sol + a <- m + pop sol + pure a + declareVar :: Solver -> Int -> TVar -> IO (TVar, SExpr) declareVar s x v = do let name = (if isFreeTV v then "fv" else "kv") ++ show x e <- SMT.declare (solver s) name cryInfNat SMT.assert (solver s) (SMT.fun "cryVar" [ e ]) return (v,e) + + +declareVars :: Solver -> [TVar] -> IO TVars +declareVars sol vs = + Map.fromList <$> zipWithM (declareVar sol) [ 0 .. ] + [ v | v <- vs, kindOf v == KNum ] assume :: Solver -> TVars -> Prop -> IO () assume s tvs p = SMT.assert (solver s) (SMT.fun "cryAssume" [ toSMT tvs p ]) diff --git a/src/Cryptol/TypeCheck/Solver/Selector.hs b/src/Cryptol/TypeCheck/Solver/Selector.hs --- a/src/Cryptol/TypeCheck/Solver/Selector.hs +++ b/src/Cryptol/TypeCheck/Solver/Selector.hs @@ -5,7 +5,7 @@ -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable -{-# LANGUAGE PatternGuards, Safe #-} +{-# LANGUAGE PatternGuards #-} module Cryptol.TypeCheck.Solver.Selector (tryHasGoal) where import Cryptol.Parser.Position(Range) @@ -13,7 +13,7 @@ import Cryptol.TypeCheck.InferTypes import Cryptol.TypeCheck.Monad( InferM, unify, newGoals , newType, applySubst, solveHasGoal - , newParamName + , newLocalName ) import Cryptol.TypeCheck.Subst (listParamSubst, apSubst) import Cryptol.Utils.Ident (Ident, packIdent,Namespace(..)) @@ -166,9 +166,9 @@ -- xs.s ~~> [ x.s | x <- xs ] -- { xs | s = ys } ~~> [ { x | s = y } | x <- xs | y <- ys ] liftSeq len el = - do x1 <- newParamName NSValue (packIdent "x") - x2 <- newParamName NSValue (packIdent "x") - y2 <- newParamName NSValue (packIdent "y") + do x1 <- newLocalName NSValue (packIdent "x") + x2 <- newLocalName NSValue (packIdent "x") + y2 <- newLocalName NSValue (packIdent "y") case tNoUser innerT of TCon _ [_,eli] -> do d <- mkSelSln s el eli @@ -190,8 +190,8 @@ -- f.s ~~> \x -> (f x).s -- { f | s = g } ~~> \x -> { f x | s = g x } liftFun t1 t2 = - do x1 <- newParamName NSValue (packIdent "x") - x2 <- newParamName NSValue (packIdent "x") + do x1 <- newLocalName NSValue (packIdent "x") + x2 <- newLocalName NSValue (packIdent "x") case tNoUser innerT of TCon _ [_,inT] -> do d <- mkSelSln s t2 inT diff --git a/src/Cryptol/TypeCheck/Solver/Types.hs b/src/Cryptol/TypeCheck/Solver/Types.hs --- a/src/Cryptol/TypeCheck/Solver/Types.hs +++ b/src/Cryptol/TypeCheck/Solver/Types.hs @@ -1,4 +1,5 @@ {-# Language OverloadedStrings, DeriveGeneric, DeriveAnyClass #-} +{-# LANGUAGE Safe #-} module Cryptol.TypeCheck.Solver.Types where import Data.Map(Map) diff --git a/src/Cryptol/TypeCheck/Subst.hs b/src/Cryptol/TypeCheck/Subst.hs --- a/src/Cryptol/TypeCheck/Subst.hs +++ b/src/Cryptol/TypeCheck/Subst.hs @@ -7,10 +7,7 @@ -- Portability : portable {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} @@ -35,6 +32,7 @@ , applySubstToVar , substToList , fmap', (!$), (.$) + , mergeDistinctSubst ) where import Data.Maybe @@ -85,6 +83,29 @@ , suDefaulting = False } +mergeDistinctSubst :: [Subst] -> Subst +mergeDistinctSubst sus = + case sus of + [] -> emptySubst + _ -> foldr1 merge sus + + where + merge s1 s2 = S { suFreeMap = jn suFreeMap s1 s2 + , suBoundMap = jn suBoundMap s1 s2 + , suDefaulting = if suDefaulting s1 || suDefaulting s2 + then err + else False + } + + err = panic "mergeDistinctSubst" [ "Not distinct" ] + bad _ _ = err + jn f x y = IntMap.unionWith bad (f x) (f y) + + + + + + -- | Reasons to reject a single-variable substitution. data SubstError = SubstRecursive @@ -241,7 +262,15 @@ Just (TUser f ts1 t1) TRec fs -> TRec `fmap` (anyJust (apSubstMaybe su) fs) - TNewtype nt ts -> TNewtype nt `fmap` anyJust (apSubstMaybe su) ts + + {- We apply the substitution to the newtype as well, because it might + contain module parameters, which need to be substituted when + instantiating a functor. -} + TNewtype nt ts -> + uncurry TNewtype <$> anyJust2 (applySubstToNewtype su) + (anyJust (apSubstMaybe su)) + (nt,ts) + TVar x -> applySubstToVar su x lookupSubst :: TVar -> Subst -> Maybe Type @@ -263,6 +292,16 @@ | suDefaulting su -> Just $! defaultFreeVar x | otherwise -> Nothing + +applySubstToNewtype :: Subst -> Newtype -> Maybe Newtype +applySubstToNewtype su nt = + do (cs,fs) <- anyJust2 + (anyJust (apSubstMaybe su)) + (anyJust (apSubstMaybe su)) + (ntConstraints nt, ntFields nt) + pure nt { ntConstraints = cs, ntFields = fs } + + class TVars t where apSubst :: Subst -> t -> t -- ^ Replaces free variables. To prevent space leaks when used with @@ -351,7 +390,16 @@ instance TVars Schema where apSubst su (Forall xs ps t) = - Forall xs !$ (concatMap pSplitAnd (apSubst su ps)) !$ (apSubst su t) + Forall xs !$ (map doProp ps) !$ (apSubst su t) + where + doProp = pAnd . pSplitAnd . apSubst su + {- NOTE: when applying a substitution to the predicates of a schema + we preserve the number of predicate, even if some of them became + "True" or and "And". This is to accomodate applying substitution + to already type checked code (e.g., when instantiating a functor) + where the predictes in the schema need to match the corresponding + EProofAbs in the term. + -} instance TVars Expr where apSubst su = go @@ -363,20 +411,16 @@ EAbs x t e1 -> EAbs x !$ (apSubst su t) !$ (go e1) ETAbs a e -> ETAbs a !$ (go e) ETApp e t -> ETApp !$ (go e) !$ (apSubst su t) - EProofAbs p e -> EProofAbs !$ hmm !$ (go e) - where hmm = case pSplitAnd (apSubst su p) of - [p1] -> p1 - res -> panic "apSubst@EProofAbs" - [ "Predicate split or disappeared after" - , "we applied a substitution." - , "Predicate:" - , show (pp p) - , "Became:" - , show (map pp res) - , "subst:" - , show (pp su) - ] + EProofAbs p e -> EProofAbs !$ p' !$ (go e) + where p' = pAnd (pSplitAnd (apSubst su p)) + {- NOTE: we used to panic if `pSplitAnd` didn't return a single result. + It is useful to avoid the panic if applying the substitution to + already type checked code (e.g., when we are instantitaing a + functor). In that case, we don't have the option to modify the + `EProofAbs` because we'd have to change all call sites, but things might + simplify because of the extra info in the substitution. -} + EProofApp e -> EProofApp !$ (go e) EVar {} -> expr @@ -391,6 +435,8 @@ EWhere e ds -> EWhere !$ (go e) !$ (apSubst su ds) + EPropGuards guards ty -> EPropGuards !$ (\(props, e) -> (apSubst su `fmap'` props, apSubst su e)) `fmap'` guards .$ ty + instance TVars Match where apSubst su (From x len t e) = From x !$ (apSubst su len) !$ (apSubst su t) !$ (apSubst su e) apSubst su (Let b) = Let !$ (apSubst su b) @@ -401,15 +447,25 @@ instance TVars Decl where apSubst su d = - let !sig' = id $! apSubst su (dSignature d) + let !sig' = apSubst su (dSignature d) !def' = apSubst su (dDefinition d) in d { dSignature = sig', dDefinition = def' } instance TVars DeclDef where - apSubst su (DExpr e) = DExpr !$ (apSubst su e) - apSubst _ DPrim = DPrim + apSubst su (DExpr e) = DExpr !$ (apSubst su e) + apSubst _ DPrim = DPrim + apSubst _ (DForeign t) = DForeign t -instance TVars Module where +-- WARNING: This applies the substitution only to the declarations. +instance TVars (ModuleG names) where apSubst su m = let !decls' = apSubst su (mDecls m) - in m { mDecls = decls' } + !funs' = apSubst su <$> mFunctors m + in m { mDecls = decls', mFunctors = funs' } + +-- WARNING: This applies the substitution only to the declarations in modules. +instance TVars TCTopEntity where + apSubst su ent = + case ent of + TCTopModule m -> TCTopModule (apSubst su m) + TCTopSignature {} -> ent diff --git a/src/Cryptol/TypeCheck/TCon.hs b/src/Cryptol/TypeCheck/TCon.hs --- a/src/Cryptol/TypeCheck/TCon.hs +++ b/src/Cryptol/TypeCheck/TCon.hs @@ -40,7 +40,7 @@ builtInType :: M.Name -> Maybe TCon builtInType nm = case M.nameInfo nm of - M.Declared m _ + M.GlobalName _ OrigName { ogModule = m } | m == M.TopModule preludeName -> Map.lookup (M.nameIdent nm) builtInTypes | m == M.TopModule floatName -> Map.lookup (M.nameIdent nm) builtInFloat | m == M.TopModule arrayName -> Map.lookup (M.nameIdent nm) builtInArray diff --git a/src/Cryptol/TypeCheck/Type.hs b/src/Cryptol/TypeCheck/Type.hs --- a/src/Cryptol/TypeCheck/Type.hs +++ b/src/Cryptol/TypeCheck/Type.hs @@ -16,6 +16,8 @@ import GHC.Generics (Generic) import Control.DeepSeq +import Data.Map(Map) +import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Data.Maybe (fromMaybe) import Data.Set (Set) @@ -23,9 +25,10 @@ import Data.Text (Text) import Cryptol.Parser.Selector -import Cryptol.Parser.Position(Range,emptyRange) +import Cryptol.Parser.Position(Located,thing,Range,emptyRange) +import Cryptol.Parser.AST(ImpName(..)) import Cryptol.ModuleSystem.Name -import Cryptol.Utils.Ident (Ident, isInfixIdent, exprModName) +import Cryptol.Utils.Ident (Ident, isInfixIdent, exprModName, ogModule, ModName) import Cryptol.TypeCheck.TCon import Cryptol.TypeCheck.PP import Cryptol.TypeCheck.Solver.InfNat @@ -37,18 +40,75 @@ infix 4 =#=, >== infixr 5 `tFun` + +-------------------------------------------------------------------------------- +-- Module parameters + +type FunctorParams = Map Ident ModParam + +-- | Compute the names from all functor parameters +allParamNames :: FunctorParams -> ModParamNames +allParamNames mps = + ModParamNames + { mpnTypes = Map.unions (map mpnTypes ps) + , mpnConstraints = concatMap mpnConstraints ps + , mpnFuns = Map.unions (map mpnFuns ps) + , mpnTySyn = Map.unions (map mpnTySyn ps) + , mpnDoc = Nothing + } + where + ps = map mpParameters (Map.elems mps) + + +-- | A module parameter. Corresponds to a "signature import". +-- A single module parameter can bring multiple things in scope. +data ModParam = ModParam + { mpName :: Ident + -- ^ The name of a functor parameter. + + , mpQual :: !(Maybe ModName) + -- ^ This is the qualifier for the parameter. We use it to + -- derive parameter names when doing `_` imports. + + , mpIface :: ImpName Name + -- ^ The interface corresponding to this parameter. + -- This is thing in `import interface` + + , mpParameters :: ModParamNames + {- ^ These are the actual parameters, not the ones in the interface + For example if the same interface is used for multiple parameters + the `ifmpParameters` would all be different. -} + } deriving (Show, Generic, NFData) + +-- | Information about the names brought in through an "interface import". +-- This is also used to keep information about. +data ModParamNames = ModParamNames + { mpnTypes :: Map Name ModTParam + -- ^ Type parameters + + , mpnTySyn :: !(Map Name TySyn) + -- ^ Type synonyms + + , mpnConstraints :: [Located Prop] + -- ^ Constraints on param. types + + + , mpnFuns :: Map.Map Name ModVParam + -- ^ Value parameters + + , mpnDoc :: !(Maybe Text) + -- ^ Documentation about the interface. + } deriving (Show, Generic, NFData) + -- | A type parameter of a module. data ModTParam = ModTParam { mtpName :: Name , mtpKind :: Kind - , mtpNumber :: !Int -- ^ The number of the parameter in the module - -- This is used when we move parameters from the module - -- level to individual declarations - -- (type synonyms in particular) , mtpDoc :: Maybe Text } deriving (Show,Generic,NFData) +-- | This is how module parameters appear in actual types. mtpParam :: ModTParam -> TParam mtpParam mtp = TParam { tpUnique = nameUnique (mtpName mtp) , tpKind = mtpKind mtp @@ -64,9 +124,9 @@ { mvpName :: Name , mvpType :: Schema , mvpDoc :: Maybe Text - , mvpFixity :: Maybe Fixity + , mvpFixity :: Maybe Fixity -- XXX: This should be in the name? } deriving (Show,Generic,NFData) - +-------------------------------------------------------------------------------- @@ -259,6 +319,7 @@ data Newtype = Newtype { ntName :: Name , ntParams :: [TParam] , ntConstraints :: [Prop] + , ntConName :: !Name , ntFields :: RecordMap Ident Type , ntDoc :: Maybe Text } deriving (Show, Generic, NFData) @@ -285,6 +346,8 @@ -------------------------------------------------------------------------------- +instance HasKind AbstractType where + kindOf at = foldr (:->) (atKind at) (map kindOf (fst (atCtrs at))) instance HasKind TVar where kindOf (TVFree _ k _ _) = k @@ -696,7 +759,7 @@ tFun a b = TCon (TC TCFun) [a,b] -- | Eliminate outermost type synonyms. -tNoUser :: Type -> Type +tNoUser :: Type -> Type tNoUser t = case t of TUser _ _ a -> tNoUser a _ -> t @@ -847,7 +910,50 @@ where prop = TCon (PC PPrime) [ty] +-- Negation -------------------------------------------------------------------- +{-| `pNegNumeric` negates a simple (i.e., not And, not prime, etc) prop +over numeric type vars. The result is a conjunction of properties. -} +pNegNumeric :: Prop -> [Prop] +pNegNumeric prop = + case tNoUser prop of + TCon tcon tys -> + case tcon of + PC pc -> + case pc of + + -- not (x == y) <=> x /= y + PEqual -> [TCon (PC PNeq) tys] + + -- not (x /= y) <=> x == y + PNeq -> [TCon (PC PEqual) tys] + + -- not (x >= y) <=> x /= y and y >= x + PGeq -> [TCon (PC PNeq) tys, TCon (PC PGeq) (reverse tys)] + + -- not (fin x) <=> x == Inf + PFin | [ty] <- tys -> [ty =#= tInf] + | otherwise -> bad + + -- not True <=> 0 == 1 + PTrue -> [TCon (PC PEqual) [tZero, tOne]] + + _ -> bad + + TError _ki -> [prop] -- propogates `TError` + + TC _tc -> bad + TF _tf -> bad + + _ -> bad + + where + bad = panic "pNegNumeric" + [ "Unexpeceted numeric constraint:" + , pretty prop + ] + + -------------------------------------------------------------------------------- noFreeVariables :: FVS t => t -> Bool @@ -873,6 +979,34 @@ TRec fs -> fvs (recordElements fs) TNewtype _nt ts -> fvs ts + +-- | Find the abstract types mentioned in a type. +class FreeAbstract t where + freeAbstract :: t -> Set UserTC + +instance FreeAbstract a => FreeAbstract [a] where + freeAbstract = Set.unions . map freeAbstract + +instance (FreeAbstract a, FreeAbstract b) => FreeAbstract (a,b) where + freeAbstract (a,b) = Set.union (freeAbstract a) (freeAbstract b) + +instance FreeAbstract TCon where + freeAbstract tc = + case tc of + TC (TCAbstract ut) -> Set.singleton ut + _ -> Set.empty + +instance FreeAbstract Type where + freeAbstract ty = + case ty of + TCon tc ts -> freeAbstract (tc,ts) + TVar {} -> Set.empty + TUser _ _ t -> freeAbstract t + TRec fs -> freeAbstract (recordElements fs) + TNewtype _nt ts -> freeAbstract ts + + + instance FVS a => FVS (Maybe a) where fvs Nothing = Set.empty fvs (Just x) = fvs x @@ -888,10 +1022,6 @@ Set.difference (Set.union (fvs ps) (fvs t)) bound where bound = Set.fromList (map tpVar as) - - - - -- Pretty Printing ------------------------------------------------------------- instance PP TParam where @@ -924,7 +1054,18 @@ ps = ntParams nt nm = addTNames ps emptyNameMap +ppNewtypeFull :: Newtype -> Doc +ppNewtypeFull nt = + text "newtype" <+> pp (ntName nt) <+> hsep (map (ppWithNamesPrec nm 9) ps) + $$ nest 2 (cs $$ ("=" <+> pp (ntConName nt) $$ nest 2 fs)) + where + ps = ntParams nt + nm = addTNames ps emptyNameMap + fs = vcat [ pp f <.> ":" <+> pp t | (f,t) <- canonicalFields (ntFields nt) ] + cs = vcat (map pp (ntConstraints nt)) + + instance PP Schema where ppPrec = ppWithNamesPrec IntMap.empty @@ -1115,7 +1256,8 @@ TypeParamInstPos f n -> mk (sh f ++ "_" ++ show n) DefinitionOf x -> case nameInfo x of - Declared m SystemName | m == TopModule exprModName -> mk "it" + GlobalName SystemName og + | ogModule og == TopModule exprModName -> mk "it" _ -> using x LenOfCompGen -> mk "n" GeneratorOfListComp -> "seq" @@ -1176,3 +1318,24 @@ GeneratorOfListComp -> "generator in a list comprehension" FunApp -> "function call" TypeErrorPlaceHolder -> "type error place-holder" + +instance PP ModParamNames where + ppPrec _ ps = + let tps = Map.elems (mpnTypes ps) + in + vcat $ map pp tps ++ + if null (mpnConstraints ps) then [] else + [ "type constraint" <+> + parens (commaSep (map (pp . thing) (mpnConstraints ps))) + ] ++ + [ pp t | t <- Map.elems (mpnTySyn ps) ] ++ + map pp (Map.elems (mpnFuns ps)) + +instance PP ModTParam where + ppPrec _ p = + "type" <+> pp (mtpName p) <+> ":" <+> pp (mtpKind p) + +instance PP ModVParam where + ppPrec _ p = pp (mvpName p) <+> ":" <+> pp (mvpType p) + + diff --git a/src/Cryptol/TypeCheck/TypeOf.hs b/src/Cryptol/TypeCheck/TypeOf.hs --- a/src/Cryptol/TypeCheck/TypeOf.hs +++ b/src/Cryptol/TypeCheck/TypeOf.hs @@ -9,6 +9,7 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE NamedFieldPuns #-} module Cryptol.TypeCheck.TypeOf ( fastTypeOf , fastSchemaOf @@ -43,6 +44,7 @@ Just (_, t) -> t Nothing -> panic "Cryptol.TypeCheck.TypeOf.fastTypeOf" [ "EApp with non-function operator" ] + EPropGuards _guards sType -> sType -- Polymorphic fragment EVar {} -> polymorphic ETAbs {} -> polymorphic @@ -111,8 +113,11 @@ EComp {} -> monomorphic EApp {} -> monomorphic EAbs {} -> monomorphic + + -- PropGuards + EPropGuards _ t -> Forall {sVars = [], sProps = [], sType = t} where - monomorphic = Forall [] [] (fastTypeOf tyenv expr) + monomorphic = Forall {sVars = [], sProps = [], sType = fastTypeOf tyenv expr} -- | Apply a substitution to a type *without* simplifying -- constraints like @Arith [n]a@ to @Arith a@. (This is in contrast to diff --git a/src/Cryptol/TypeCheck/TypePat.hs b/src/Cryptol/TypeCheck/TypePat.hs --- a/src/Cryptol/TypeCheck/TypePat.hs +++ b/src/Cryptol/TypeCheck/TypePat.hs @@ -1,5 +1,6 @@ -- See Note [-Wincomplete-uni-patterns and irrefutable patterns] {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE Safe #-} module Cryptol.TypeCheck.TypePat ( aInf, aNat, aNat' @@ -15,6 +16,7 @@ , aTVar , aFreeTVar + , anAbstractType , aBit , aSeq , aWord @@ -123,6 +125,11 @@ aTVar = \a -> case tNoUser a of TVar x -> return x _ -> mzero + +anAbstractType :: Pat Type UserTC +anAbstractType = \a -> case tNoUser a of + TCon (TC (TCAbstract ut)) [] -> pure ut + _ -> mzero aFreeTVar :: Pat Type TVar aFreeTVar t = diff --git a/src/Cryptol/Utils/Benchmark.hs b/src/Cryptol/Utils/Benchmark.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Utils/Benchmark.hs @@ -0,0 +1,36 @@ +-- | Simple benchmarking of IO functions. +module Cryptol.Utils.Benchmark + ( BenchmarkStats (..) + , benchmark + , secs + ) where + +import Criterion.Measurement (runBenchmark, secs, threshold) +import Criterion.Measurement.Types +import Data.Int +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U + +-- | Statistics returned by 'benchmark'. +-- +-- This is extremely crude compared to the full analysis that criterion can do, +-- but is enough for now. +data BenchmarkStats = BenchmarkStats + { benchAvgTime :: !Double + , benchAvgCpuTime :: !Double + , benchAvgCycles :: !Int64 + } deriving Show + +-- | Benchmark the application of the given function to the given input and the +-- execution of the resulting IO action to WHNF, spending at least the given +-- amount of time in seconds to collect measurements. +benchmark :: Double -> (a -> IO b) -> a -> IO BenchmarkStats +benchmark period f x = do + (meas, _) <- runBenchmark (whnfAppIO f x) period + let meas' = rescale <$> V.filter ((>= threshold) . measTime) meas + len = length meas' + sumMeasure sel = U.sum $ measure sel meas' + pure BenchmarkStats + { benchAvgTime = sumMeasure measTime / fromIntegral len + , benchAvgCpuTime = sumMeasure measCpuTime / fromIntegral len + , benchAvgCycles = sumMeasure measCycles `div` fromIntegral len } diff --git a/src/Cryptol/Utils/Fixity.hs b/src/Cryptol/Utils/Fixity.hs --- a/src/Cryptol/Utils/Fixity.hs +++ b/src/Cryptol/Utils/Fixity.hs @@ -23,10 +23,10 @@ -- | Information about associativity. data Assoc = LeftAssoc | RightAssoc | NonAssoc - deriving (Show, Eq, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData) data Fixity = Fixity { fAssoc :: !Assoc, fLevel :: !Int } - deriving (Eq, Generic, NFData, Show) + deriving (Eq, Ord, Generic, NFData, Show) data FixityCmp = FCError | FCLeft diff --git a/src/Cryptol/Utils/Ident.hs b/src/Cryptol/Utils/Ident.hs --- a/src/Cryptol/Utils/Ident.hs +++ b/src/Cryptol/Utils/Ident.hs @@ -6,24 +6,29 @@ -- Stability : provisional -- Portability : portable -{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} module Cryptol.Utils.Ident ( -- * Module names ModPath(..) , apPathRoot , modPathCommon + , modPathIsOrContains , topModuleFor , modPathSplit + , modPathIsNormal , ModName , modNameToText , textToModName , modNameChunks + , modNameChunksText , packModName , preludeName , preludeReferenceName + , undefinedModName , floatName , suiteBName , arrayName @@ -31,10 +36,10 @@ , interactiveName , noModuleName , exprModName - - , isParamInstModName - , paramInstModName - , notParamInstModName + , modNameArg + , modNameIfaceMod + , modNameToNormalModName + , modNameIsNormal -- * Identifiers , Ident @@ -47,6 +52,9 @@ , nullIdent , identText , modParamIdent + , identAnonArg + , identAnonIfaceMod + , identIsNormal -- * Namespaces , Namespace(..) @@ -54,6 +62,8 @@ -- * Original names , OrigName(..) + , OrigSource(..) + , ogFromModParam -- * Identifiers for primitives , PrimIdent(..) @@ -67,11 +77,14 @@ import Control.DeepSeq (NFData) import Data.Char (isSpace) import Data.List (unfoldr) +import Data.Text (Text) import qualified Data.Text as T import Data.String (IsString(..)) import GHC.Generics (Generic) +import Cryptol.Utils.Panic(panic) + -------------------------------------------------------------------------------- -- | Namespaces for names @@ -115,6 +128,14 @@ (x:xs',y:ys') | x == y -> findCommon (Nested com x) xs' ys' _ -> (com, xs, ys) +-- | Does the first module path contain the second? +-- This returns true if the paths are the same. +modPathIsOrContains :: ModPath -> ModPath -> Bool +modPathIsOrContains p1 p2 = + case modPathCommon p1 p2 of + Just (_,[],_) -> True + _ -> False + modPathSplit :: ModPath -> (ModName, [Ident]) modPathSplit p0 = (top,reverse xs) where @@ -125,47 +146,67 @@ Nested b i -> (a, i:bs) where (a,bs) = go b - +modPathIsNormal :: ModPath -> Bool +modPathIsNormal p = modNameIsNormal m && all identIsNormal is + where (m,is) = modPathSplit p -------------------------------------------------------------------------------- -- | Top-level Module names are just text. -data ModName = ModName T.Text +data ModName = ModName Text MaybeAnon deriving (Eq,Ord,Show,Generic) instance NFData ModName -modNameToText :: ModName -> T.Text -modNameToText (ModName x) = x +-- | Change a normal module name to a module name to be used for an +-- anonnymous argument. +modNameArg :: ModName -> ModName +modNameArg (ModName m fl) = + case fl of + NormalName -> ModName m AnonModArgName + AnonModArgName -> panic "modNameArg" ["Name is not normal"] + AnonIfaceModName -> panic "modNameArg" ["Name is not normal"] -textToModName :: T.Text -> ModName -textToModName = ModName +-- | Change a normal module name to a module name to be used for an +-- anonnymous interface. +modNameIfaceMod :: ModName -> ModName +modNameIfaceMod (ModName m fl) = + case fl of + NormalName -> ModName m AnonIfaceModName + AnonModArgName -> panic "modNameIfaceMod" ["Name is not normal"] + AnonIfaceModName -> panic "modNameIfaceMod" ["Name is not normal"] -modNameChunks :: ModName -> [String] -modNameChunks = unfoldr step . modNameToText . notParamInstModName - where - step str - | T.null str = Nothing - | otherwise = case T.breakOn modSep str of - (a,b) -> Just (T.unpack a,T.drop (T.length modSep) b) +-- | This is used when we check that the name of a module matches the +-- file where it is defined. +modNameToNormalModName :: ModName -> ModName +modNameToNormalModName (ModName t _) = ModName t NormalName -isParamInstModName :: ModName -> Bool -isParamInstModName (ModName x) = modInstPref `T.isPrefixOf` x +modNameToText :: ModName -> Text +modNameToText (ModName x fl) = maybeAnonText fl x --- | Convert a parameterized module's name to the name of the module --- containing the same definitions but with explicit parameters on each --- definition. -paramInstModName :: ModName -> ModName -paramInstModName (ModName x) - | modInstPref `T.isPrefixOf` x = ModName x - | otherwise = ModName (T.append modInstPref x) +-- | This is useful when we want to hide anonymous modules. +modNameIsNormal :: ModName -> Bool +modNameIsNormal (ModName _ fl) = isNormal fl +-- | Make a normal module name out of text. +textToModName :: T.Text -> ModName +textToModName txt = ModName txt NormalName -notParamInstModName :: ModName -> ModName -notParamInstModName (ModName x) - | modInstPref `T.isPrefixOf` x = ModName (T.drop (T.length modInstPref) x) - | otherwise = ModName x +-- | Break up a module name on the separators, `Text` version. +modNameChunksText :: ModName -> [T.Text] +modNameChunksText (ModName x fl) = unfoldr step x + where + step str + | T.null str = Nothing + | otherwise = + case T.breakOn modSep str of + (a,b) + | T.null b -> Just (maybeAnonText fl str, b) + | otherwise -> Just (a,T.drop (T.length modSep) b) +-- | Break up a module name on the separators, `String` version +modNameChunks :: ModName -> [String] +modNameChunks = map T.unpack . modNameChunksText packModName :: [T.Text] -> ModName packModName strs = textToModName (T.intercalate modSep (map trim strs)) @@ -176,13 +217,12 @@ modSep :: T.Text modSep = "::" -modInstPref :: T.Text -modInstPref = "`" - - preludeName :: ModName preludeName = packModName ["Cryptol"] +undefinedModName :: ModName +undefinedModName = packModName ["Undefined module"] + preludeReferenceName :: ModName preludeReferenceName = packModName ["Cryptol","Reference"] @@ -213,16 +253,32 @@ data OrigName = OrigName { ogNamespace :: Namespace , ogModule :: ModPath + , ogSource :: OrigSource , ogName :: Ident } deriving (Eq,Ord,Show,Generic,NFData) +-- | Describes where a top-level name came from +data OrigSource = + FromDefinition + | FromFunctorInst + | FromModParam Ident + deriving (Eq,Ord,Show,Generic,NFData) +-- | Returns true iff the 'ogSource' of the given 'OrigName' is 'FromModParam' +ogFromModParam :: OrigName -> Bool +ogFromModParam og = case ogSource og of + FromModParam _ -> True + _ -> False + + -------------------------------------------------------------------------------- --- | Identifiers, along with a flag that indicates whether or not they're infix --- operators. The boolean is present just as cached information from the lexer, --- and never used during comparisons. -data Ident = Ident Bool T.Text +{- | The type of identifiers. + * The boolean flag indicates whether or not they're infix operators. + The boolean is present just as cached information from the lexer, + and never used during comparisons. + * The MaybeAnon indicates if this is an anonymous name -} +data Ident = Ident Bool MaybeAnon T.Text deriving (Show,Generic) instance Eq Ident where @@ -230,39 +286,82 @@ a /= b = compare a b /= EQ instance Ord Ident where - compare (Ident _ i1) (Ident _ i2) = compare i1 i2 + compare (Ident _ mb1 i1) (Ident _ mb2 i2) = compare (mb1,i1) (mb2,i2) instance IsString Ident where fromString str = mkIdent (T.pack str) instance NFData Ident +-- | Make a normal (i.e., not anonymous) identifier packIdent :: String -> Ident packIdent = mkIdent . T.pack +-- | Make a normal (i.e., not anonymous) identifier packInfix :: String -> Ident packInfix = mkInfix . T.pack unpackIdent :: Ident -> String unpackIdent = T.unpack . identText +-- | Make a normal (i.e., not anonymous) identifier mkIdent :: T.Text -> Ident -mkIdent = Ident False +mkIdent = Ident False NormalName mkInfix :: T.Text -> Ident -mkInfix = Ident True +mkInfix = Ident True NormalName isInfixIdent :: Ident -> Bool -isInfixIdent (Ident b _) = b +isInfixIdent (Ident b _ _) = b nullIdent :: Ident -> Bool -nullIdent (Ident _ t) = T.null t +nullIdent = T.null . identText identText :: Ident -> T.Text -identText (Ident _ t) = t +identText (Ident _ mb t) = maybeAnonText mb t modParamIdent :: Ident -> Ident -modParamIdent (Ident x t) = Ident x (T.append (T.pack "module parameter ") t) +modParamIdent (Ident x a t) = + Ident x a (T.append (T.pack "module parameter ") t) + +-- | Make an anonymous identifier for the module corresponding to +-- a `where` block in a functor instantiation. +identAnonArg :: Ident -> Ident +identAnonArg (Ident b _ txt) = Ident b AnonModArgName txt + +-- | Make an anonymous identifier for the interface corresponding to +-- a `parameter` declaration. +identAnonIfaceMod :: Ident -> Ident +identAnonIfaceMod (Ident b _ txt) = Ident b AnonIfaceModName txt + +identIsNormal :: Ident -> Bool +identIsNormal (Ident _ mb _) = isNormal mb + +-------------------------------------------------------------------------------- + +-- | Information about anonymous names. +data MaybeAnon = NormalName -- ^ Not an anonymous name. + | AnonModArgName -- ^ Anonymous module (from `where`) + | AnonIfaceModName -- ^ Anonymous interface (from `parameter`) + deriving (Eq,Ord,Show,Generic) + +instance NFData MaybeAnon + +-- | Modify a name, if it is a nonymous +maybeAnonText :: MaybeAnon -> Text -> Text +maybeAnonText mb txt = + case mb of + NormalName -> txt + AnonModArgName -> "`where` argument of " <> txt + AnonIfaceModName -> "`parameter` interface of " <> txt + +isNormal :: MaybeAnon -> Bool +isNormal mb = + case mb of + NormalName -> True + _ -> False + + -------------------------------------------------------------------------------- diff --git a/src/Cryptol/Utils/PP.hs b/src/Cryptol/Utils/PP.hs --- a/src/Cryptol/Utils/PP.hs +++ b/src/Cryptol/Utils/PP.hs @@ -7,7 +7,7 @@ -- Portability : portable {-# LANGUAGE Safe #-} - +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} @@ -23,6 +23,7 @@ import Data.Void (Void) import GHC.Generics (Generic) import qualified Prettyprinter as PP +import qualified Prettyprinter.Util as PP import qualified Prettyprinter.Render.String as PP -- | How to pretty print things when evaluating @@ -49,7 +50,8 @@ | AutoExponent -- ^ Only show exponent when needed deriving Show -data FieldOrder = DisplayOrder | CanonicalOrder deriving (Bounded, Enum, Eq, Ord, Read, Show) +data FieldOrder = DisplayOrder | CanonicalOrder + deriving (Bounded, Enum, Eq, Ord, Read, Show) defaultPPOpts :: PPOpts @@ -91,7 +93,9 @@ -- | Never qualify names from this module. neverQualifyMod :: ModPath -> NameDisp neverQualifyMod mn = NameDisp $ \n -> - if ogModule n == mn then Just UnQualified else Nothing + case ogSource n of + FromDefinition | ogModule n == mn -> Just UnQualified + _ -> Nothing neverQualify :: NameDisp neverQualify = NameDisp $ \ _ -> Just UnQualified @@ -102,25 +106,52 @@ extend :: NameDisp -> NameDisp -> NameDisp extend = mappend --- | Get the format for a name. When 'Nothing' is returned, the name is not --- currently in scope. +-- | Get the format for a name. getNameFormat :: OrigName -> NameDisp -> NameFormat getNameFormat m (NameDisp f) = fromMaybe NotInScope (f m) getNameFormat _ EmptyNameDisp = NotInScope -- | Produce a document in the context of the current 'NameDisp'. withNameDisp :: (NameDisp -> Doc) -> Doc -withNameDisp k = Doc (\disp -> runDoc disp (k disp)) +withNameDisp k = withPPCfg (k . ppcfgNameDisp) +-- | Produce a document in the context of the current configuration. +withPPCfg :: (PPCfg -> Doc) -> Doc +withPPCfg k = Doc (\cfg -> runDocWith cfg (k cfg)) + -- | Fix the way that names are displayed inside of a doc. fixNameDisp :: NameDisp -> Doc -> Doc -fixNameDisp disp (Doc f) = Doc (\ _ -> f disp) +fixNameDisp disp d = + withPPCfg (\cfg -> fixPPCfg cfg { ppcfgNameDisp = disp } d) +-- | Fix the way that names are displayed inside of a doc. +fixPPCfg :: PPCfg -> Doc -> Doc +fixPPCfg cfg (Doc f) = Doc (\_ -> f cfg) +updPPCfg :: (PPCfg -> PPCfg) -> Doc -> Doc +updPPCfg f d = withPPCfg (\cfg -> fixPPCfg (f cfg) d) + +debugShowUniques :: Doc -> Doc +debugShowUniques = updPPCfg \cfg -> cfg { ppcfgShowNameUniques = True } + + + + -- Documents ------------------------------------------------------------------- -newtype Doc = Doc (NameDisp -> PP.Doc Void) deriving (Generic, NFData) +data PPCfg = PPCfg + { ppcfgNameDisp :: NameDisp + , ppcfgShowNameUniques :: Bool + } +defaultPPCfg :: PPCfg +defaultPPCfg = PPCfg + { ppcfgNameDisp = mempty + , ppcfgShowNameUniques = False + } + +newtype Doc = Doc (PPCfg -> PP.Doc Void) deriving (Generic, NFData) + instance Semigroup Doc where (<>) = liftPP2 (<>) @@ -128,18 +159,22 @@ mempty = liftPP mempty mappend = (<>) +runDocWith :: PPCfg -> Doc -> PP.Doc Void +runDocWith names (Doc f) = f names + runDoc :: NameDisp -> Doc -> PP.Doc Void -runDoc names (Doc f) = f names +runDoc disp = runDocWith defaultPPCfg { ppcfgNameDisp = disp } instance Show Doc where - show d = PP.renderString (PP.layoutPretty opts (runDoc mempty d)) - where opts = PP.defaultLayoutOptions{ PP.layoutPageWidth = PP.AvailablePerLine 100 0.666 } + show d = PP.renderString (PP.layoutPretty opts (runDocWith defaultPPCfg d)) + where opts = PP.defaultLayoutOptions + { PP.layoutPageWidth = PP.AvailablePerLine 100 0.666 } instance IsString Doc where fromString = text renderOneLine :: Doc -> String -renderOneLine d = PP.renderString (PP.layoutCompact (runDoc mempty d)) +renderOneLine d = PP.renderString (PP.layoutCompact (runDocWith defaultPPCfg d)) class PP a where ppPrec :: Int -> a -> Doc @@ -231,6 +266,9 @@ liftSep :: ([PP.Doc Void] -> PP.Doc Void) -> ([Doc] -> Doc) liftSep f ds = Doc (\e -> f [ d e | Doc d <- ds ]) +reflow :: T.Text -> Doc +reflow x = liftPP (PP.reflow x) + infixl 6 <.>, <+>, (<.>) :: Doc -> Doc -> Doc @@ -337,6 +375,10 @@ colon :: Doc colon = liftPP PP.colon +pipe :: Doc +pipe = liftPP PP.pipe + + instance PP T.Text where ppPrec _ str = text (T.unpack str) @@ -346,7 +388,6 @@ instance PP ModName where ppPrec _ = text . T.unpack . modNameToText - instance PP Assoc where ppPrec _ LeftAssoc = text "left-associative" ppPrec _ RightAssoc = text "right-associative" @@ -368,7 +409,10 @@ case getNameFormat og disp of UnQualified -> pp (ogName og) Qualified m -> ppQual (TopModule m) (pp (ogName og)) - NotInScope -> ppQual (ogModule og) (pp (ogName og)) + NotInScope -> ppQual (ogModule og) + case ogSource og of + FromModParam x -> pp x <.> "::" <.> pp (ogName og) + _ -> pp (ogName og) where ppQual mo x = case mo of @@ -380,6 +424,9 @@ instance PP Namespace where ppPrec _ ns = case ns of - NSValue -> "/*value*/" - NSType -> "/*type*/" - NSModule -> "/*module*/" + NSValue -> "/*value*/" + NSType -> "/*type*/" + NSModule -> "/*module*/" + +instance PP PrimIdent where + ppPrec _ (PrimIdent m t) = pp m <.> text (T.unpack t) diff --git a/src/Cryptol/Utils/Panic.hs b/src/Cryptol/Utils/Panic.hs --- a/src/Cryptol/Utils/Panic.hs +++ b/src/Cryptol/Utils/Panic.hs @@ -8,7 +8,7 @@ {-# LANGUAGE Trustworthy, TemplateHaskell #-} module Cryptol.Utils.Panic - (HasCallStack, CryptolPanic, Cryptol, Panic, panic) where + (HasCallStack, CryptolPanic, Cryptol, Panic, panic, xxxTODO) where import Panic hiding (panic) import qualified Panic as Panic @@ -19,6 +19,9 @@ panic :: HasCallStack => String -> [String] -> a panic = Panic.panic Cryptol + +xxxTODO :: HasCallStack => String -> a +xxxTODO x = panic "TODO" [x] instance PanicComponent Cryptol where panicComponentName _ = "Cryptol" diff --git a/src/Cryptol/Utils/Patterns.hs b/src/Cryptol/Utils/Patterns.hs --- a/src/Cryptol/Utils/Patterns.hs +++ b/src/Cryptol/Utils/Patterns.hs @@ -2,6 +2,7 @@ {-# Language FunctionalDependencies #-} {-# Language FlexibleInstances #-} {-# Language TypeFamilies, UndecidableInstances #-} +{-# Language TypeOperators #-} module Cryptol.Utils.Patterns where import Control.Monad(liftM,liftM2,ap,MonadPlus(..),guard) diff --git a/src/Cryptol/Utils/RecordMap.hs b/src/Cryptol/Utils/RecordMap.hs --- a/src/Cryptol/Utils/RecordMap.hs +++ b/src/Cryptol/Utils/RecordMap.hs @@ -14,6 +14,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Safe #-} module Cryptol.Utils.RecordMap ( RecordMap @@ -21,6 +22,7 @@ , canonicalFields , displayFields , recordElements + , displayElements , fieldSet , recordFromFields , recordFromFieldsErr @@ -88,6 +90,11 @@ -- | Return a list of field/value pairs in canonical order. canonicalFields :: RecordMap a b -> [(a,b)] canonicalFields = Map.toList . recordMap + +-- | Retrieve the elements of the record in display order +-- of the field names. +displayElements :: (Show a, Ord a) => RecordMap a b -> [b] +displayElements = map snd . displayFields -- | Return a list of field/value pairs in display order. displayFields :: (Show a, Ord a) => RecordMap a b -> [(a,b)] diff --git a/src/Cryptol/Utils/Types.hs b/src/Cryptol/Utils/Types.hs new file mode 100644 --- /dev/null +++ b/src/Cryptol/Utils/Types.hs @@ -0,0 +1,10 @@ +-- | Useful information about various types. +module Cryptol.Utils.Types where + +-- | Exponent and precision of 32-bit IEEE-754 floating point. +float32ExpPrec :: (Integer, Integer) +float32ExpPrec = (8, 24) + +-- | Exponent and precision of 64-bit IEEE-754 floating point. +float64ExpPrec :: (Integer, Integer) +float64ExpPrec = (11, 53) diff --git a/src/Cryptol/Version.hs b/src/Cryptol/Version.hs --- a/src/Cryptol/Version.hs +++ b/src/Cryptol/Version.hs @@ -6,7 +6,7 @@ -- Stability : provisional -- Portability : portable -{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} module Cryptol.Version ( commitHash @@ -39,6 +39,9 @@ putLn ("Cryptol " ++ ver) putLn ("Git commit " ++ commitHash) putLn (" branch " ++ commitBranch ++ dirtyLab) +#ifdef FFI_ENABLED + putLn "FFI enabled" +#endif where dirtyLab | commitDirty = " (non-committed files present during build)" | otherwise = ""