diff --git a/bench/Main.hs b/bench/Main.hs index aa1886f43..761c3c5c4 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -26,7 +26,6 @@ import qualified Cryptol.ModuleSystem.Base as M import qualified Cryptol.ModuleSystem.Env as M import qualified Cryptol.ModuleSystem.Monad as M import qualified Cryptol.ModuleSystem.NamingEnv as M -import Cryptol.ModuleSystem.Interface (noIfaceParams) import qualified Cryptol.Parser as P import qualified Cryptol.Parser.AST as P @@ -130,7 +129,7 @@ tc cd name path = , 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-remote-api/cryptol-eval-server/Main.hs b/cryptol-remote-api/cryptol-eval-server/Main.hs index b64cfcdbf..aa1048b05 100644 --- a/cryptol-remote-api/cryptol-eval-server/Main.hs +++ b/cryptol-remote-api/cryptol-eval-server/Main.hs @@ -26,7 +26,7 @@ import CryptolServer.Interrupt ( interruptServer, interruptServerDescr ) import Cryptol.ModuleSystem (ModuleInput(..), loadModuleByPath, loadModuleByName) import Cryptol.ModuleSystem.Monad (runModuleM, setFocusedModule) -import Cryptol.TypeCheck.AST (mName) +import Cryptol.TypeCheck.AST (tcTopEntitytName) import Cryptol.Utils.Ident (ModName, modNameToText, textToModName, preludeName) import Cryptol.Utils.Logger (quietLogger) @@ -77,7 +77,7 @@ main = customMain initMod initMod initMod initMod description buildApp case res of Left err -> die err Right (m, menv') -> - do res' <- fst <$> runModuleM minp{ minpModuleEnv = menv' } (setFocusedModule (mName (snd m))) + do res' <- fst <$> runModuleM minp{ minpModuleEnv = menv' } (setFocusedModule (tcTopEntitytName (snd m))) case res' of Left err -> die err Right (_, menv'') -> pure menv'' diff --git a/cryptol-remote-api/src/CryptolServer/Data/Expression.hs b/cryptol-remote-api/src/CryptolServer/Data/Expression.hs index b6d4ee26e..5bb043ab6 100644 --- a/cryptol-remote-api/src/CryptolServer/Data/Expression.hs +++ b/cryptol-remote-api/src/CryptolServer/Data/Expression.hs @@ -47,7 +47,7 @@ import qualified Cryptol.ModuleSystem.Base as Base import qualified Cryptol.ModuleSystem.Renamer as R import Cryptol.ModuleSystem.Name (Name, mkDeclared, NameSource( UserName ), liftSupply, nameIdent) -import Cryptol.ModuleSystem.NamingEnv (singletonE, shadowing, namespaceMap) +import Cryptol.ModuleSystem.NamingEnv (singletonNS, shadowing, namespaceMap) import qualified Cryptol.Parser as CP import qualified Cryptol.Parser.AST as CP @@ -649,7 +649,7 @@ bindValToFreshName nameBase ty val = do liftModuleCmd (evalDecls [TC.NonRecursive decl]) modifyModuleEnv $ \me -> let denv = meDynEnv me - in me {meDynEnv = denv { deNames = singletonE (CP.UnQual (mkIdent txt)) name `shadowing` deNames denv }} + in me {meDynEnv = denv { deNames = singletonNS NSValue (CP.UnQual (mkIdent txt)) name `shadowing` deNames denv }} return $ Just txt where genFresh :: CryptolCommand (Text, Name) @@ -660,7 +660,7 @@ bindValToFreshName nameBase ty val = do mpath = TopModule interactiveName name <- liftSupply (mkDeclared NSValue mpath UserName ident Nothing emptyRange) pure (txt, name) - where nextNewName :: Map CP.PName [Name] -> Int -> Text + where nextNewName :: Map CP.PName a -> Int -> Text nextNewName ns n = let txt = "CryptolServer'" <> nameBase <> (T.pack $ show n) pname = CP.UnQual (mkIdent txt) diff --git a/cryptol-remote-api/src/CryptolServer/Exceptions.hs b/cryptol-remote-api/src/CryptolServer/Exceptions.hs index ace98053b..214624b9c 100644 --- a/cryptol-remote-api/src/CryptolServer/Exceptions.hs +++ b/cryptol-remote-api/src/CryptolServer/Exceptions.hs @@ -102,16 +102,6 @@ cryptolError modErr warns = (20610, [ ("name", jsonPretty name) , ("paths", jsonList [jsonString path1, jsonString path2]) ]) - ImportedParamModule x -> - (20630, [ ("module", jsonPretty x) - ]) - FailedToParameterizeModDefs x xs -> - (20640, [ ("module", jsonPretty x) - , ("parameters", jsonList (map (jsonString . pretty) xs)) - ]) - NotAParameterizedModule x -> - (20650, [ ("module", jsonPretty x) - ]) FFILoadErrors x errs -> (20660, [ ("module", jsonPretty x) , ("errors", jsonList (map jsonPretty errs)) diff --git a/cryptol-remote-api/src/CryptolServer/Names.hs b/cryptol-remote-api/src/CryptolServer/Names.hs index 12b73e89c..3377fd383 100644 --- a/cryptol-remote-api/src/CryptolServer/Names.hs +++ b/cryptol-remote-api/src/CryptolServer/Names.hs @@ -15,6 +15,7 @@ import Data.Aeson ((.=)) import qualified Data.Map as Map import Data.Map (Map) import Data.Text (unpack) +import Data.Maybe(maybeToList) import Data.Typeable (Proxy(..), typeRep) import Cryptol.Parser.Name (PName(..)) @@ -22,7 +23,8 @@ import Cryptol.ModuleSystem.Env (ModContext(..), ModuleEnv(..), DynamicEnv(..), import Cryptol.ModuleSystem.Interface (IfaceDecl(..), IfaceDecls(..)) import Cryptol.ModuleSystem.Name (Name) import Cryptol.ModuleSystem.NamingEnv - (NamingEnv, namespaceMap, lookupValNames, shadowing) + (NamingEnv, namespaceMap, lookupNS, shadowing) +import Cryptol.ModuleSystem.Names(namesToList) import Cryptol.TypeCheck.Type (Schema(..)) import Cryptol.Utils.PP (pp) import Cryptol.Utils.Ident(Namespace(..)) @@ -71,7 +73,7 @@ getInfo rnEnv info n' = let ty = ifDeclSig i nameDocs = ifDeclDoc i in NameInfo (show (pp n')) (show (pp ty)) ty (unpack <$> nameDocs) - | n <- lookupValNames n' rnEnv + | ns <- maybeToList (lookupNS NSValue n' rnEnv), n <- namesToList ns ] data NameInfo = diff --git a/cryptol.cabal b/cryptol.cabal index 3b91b2683..0d18bfc43 100644 --- a/cryptol.cabal +++ b/cryptol.cabal @@ -71,6 +71,7 @@ library parameterized-utils >= 2.0.2, pretty, prettyprinter >= 1.7.0, + pretty-show, process >= 1.2, sbv >= 8.10 && < 9.1, simple-smt >= 0.9.7, @@ -137,10 +138,13 @@ library 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, @@ -153,7 +157,6 @@ library Cryptol.TypeCheck.Parseable, Cryptol.TypeCheck.Monad, Cryptol.TypeCheck.Infer, - Cryptol.TypeCheck.CheckModuleInstance, Cryptol.TypeCheck.InferTypes, Cryptol.TypeCheck.Interface, Cryptol.TypeCheck.Error, @@ -171,6 +174,8 @@ library Cryptol.TypeCheck.FFI, Cryptol.TypeCheck.FFI.Error, Cryptol.TypeCheck.FFI.FFIType, + Cryptol.TypeCheck.Module, + Cryptol.TypeCheck.ModuleInstance, Cryptol.TypeCheck.Solver.Types, Cryptol.TypeCheck.Solver.SMT, @@ -186,9 +191,9 @@ library Cryptol.Transform.MonoValues, Cryptol.Transform.Specialize, - Cryptol.Transform.AddModParams, Cryptol.IR.FreeVars, + Cryptol.IR.TraverseNames, Cryptol.Backend, Cryptol.Backend.Arch, @@ -227,6 +232,7 @@ library Cryptol.Symbolic.What4, Cryptol.REPL.Command, + Cryptol.REPL.Help, Cryptol.REPL.Browse, Cryptol.REPL.Monad, Cryptol.REPL.Trie diff --git a/docs/RefMan/Modules.rst b/docs/RefMan/Modules.rst index 7c8fafadd..d8e992314 100644 --- a/docs/RefMan/Modules.rst +++ b/docs/RefMan/Modules.rst @@ -335,11 +335,6 @@ another top-level module ``B`` requires two steps: Parameterized Modules --------------------- -.. warning:: - The documentation in this section is for the upcoming variant of - the feature, which is not yet part of main line Cryptol. - - Interface Modules ~~~~~~~~~~~~~~~~~ diff --git a/docs/RefMan/_build/doctrees/BasicSyntax.doctree b/docs/RefMan/_build/doctrees/BasicSyntax.doctree index 61a0b9c4a..7f66ad2d9 100644 Binary files a/docs/RefMan/_build/doctrees/BasicSyntax.doctree and b/docs/RefMan/_build/doctrees/BasicSyntax.doctree differ diff --git a/docs/RefMan/_build/doctrees/BasicTypes.doctree b/docs/RefMan/_build/doctrees/BasicTypes.doctree index dade46df2..44b4ed1a0 100644 Binary files a/docs/RefMan/_build/doctrees/BasicTypes.doctree and b/docs/RefMan/_build/doctrees/BasicTypes.doctree differ diff --git a/docs/RefMan/_build/doctrees/Expressions.doctree b/docs/RefMan/_build/doctrees/Expressions.doctree index 3b164e8fa..f3b3fcd84 100644 Binary files a/docs/RefMan/_build/doctrees/Expressions.doctree and b/docs/RefMan/_build/doctrees/Expressions.doctree differ diff --git a/docs/RefMan/_build/doctrees/FFI.doctree b/docs/RefMan/_build/doctrees/FFI.doctree index 4223404b1..c850378ca 100644 Binary files a/docs/RefMan/_build/doctrees/FFI.doctree and b/docs/RefMan/_build/doctrees/FFI.doctree differ diff --git a/docs/RefMan/_build/doctrees/Modules.doctree b/docs/RefMan/_build/doctrees/Modules.doctree index 5de0831f5..b1fb46f17 100644 Binary files a/docs/RefMan/_build/doctrees/Modules.doctree and b/docs/RefMan/_build/doctrees/Modules.doctree differ diff --git a/docs/RefMan/_build/doctrees/OverloadedOperations.doctree b/docs/RefMan/_build/doctrees/OverloadedOperations.doctree index 8797caaeb..31c32fdb5 100644 Binary files a/docs/RefMan/_build/doctrees/OverloadedOperations.doctree and b/docs/RefMan/_build/doctrees/OverloadedOperations.doctree differ diff --git a/docs/RefMan/_build/doctrees/RefMan.doctree b/docs/RefMan/_build/doctrees/RefMan.doctree index b6debdce8..360f7fca7 100644 Binary files a/docs/RefMan/_build/doctrees/RefMan.doctree and b/docs/RefMan/_build/doctrees/RefMan.doctree differ diff --git a/docs/RefMan/_build/doctrees/TypeDeclarations.doctree b/docs/RefMan/_build/doctrees/TypeDeclarations.doctree index 353c3286b..e78a6ba9c 100644 Binary files a/docs/RefMan/_build/doctrees/TypeDeclarations.doctree and b/docs/RefMan/_build/doctrees/TypeDeclarations.doctree differ diff --git a/docs/RefMan/_build/doctrees/environment.pickle b/docs/RefMan/_build/doctrees/environment.pickle index a6a301772..86245cd3e 100644 Binary files a/docs/RefMan/_build/doctrees/environment.pickle and b/docs/RefMan/_build/doctrees/environment.pickle differ diff --git a/docs/RefMan/_build/html/.buildinfo b/docs/RefMan/_build/html/.buildinfo index b0149fc3a..353327328 100644 --- a/docs/RefMan/_build/html/.buildinfo +++ b/docs/RefMan/_build/html/.buildinfo @@ -1,4 +1,4 @@ # Sphinx build info version 1 # This file hashes the configuration used when building these files. When it is not found, a full rebuild will be done. -config: 69485412ee215e2257ea16f8a42506fe +config: 766b28421f9ffa9f611038e48286ed1c tags: 645f666f9bcd5a90fca523b33c5a78b7 diff --git a/docs/RefMan/_build/html/BasicSyntax.html b/docs/RefMan/_build/html/BasicSyntax.html index 3bbc07fbb..79fc359cf 100644 --- a/docs/RefMan/_build/html/BasicSyntax.html +++ b/docs/RefMan/_build/html/BasicSyntax.html @@ -1,66 +1,34 @@ - - - - + - - - - - Basic Syntax — Cryptol 2.11.0 documentation - - - - - - + + + Basic Syntax — Cryptol 2.11.0 documentation + + + - - - - + - - - - - - - - + - - - +
- -
- - -
-
-

Numeric Constraint Guards

+ +
+

Numeric Constraint Guards

A declaration with a signature can use numeric constraint guards, which are used to change the behavior of a functoin depending on its numeric type parameters. For example:

-
len : {n} (fin n) => [n]a -> Integer
-len xs | n == 0 => 0
-       | n >  0 => 1 + len (drop `{1} xs)
+
len : {n} (fin n) => [n]a -> Integer
+len xs | n == 0 => 0
+       | n >  0 => 1 + len (drop `{1} xs)
 

 

 
Each behavior starts with | and lists some constraints on the numeric
@@ -194,9 +114,9 @@ 
Numeric Constraint Guardsif statement:

-
len' : {n} (fin n) => [n]a -> Integer
-len' xs = if `n == 0 => 0
-           | `n >  0 => 1 + len (drop `{1} xs)
+
len' : {n} (fin n) => [n]a -> Integer
+len' xs = if `n == 0 => 0
+           | `n >  0 => 1 + len (drop `{1} xs)
 

 

 
The definition of len' is rejected, because the value based if
@@ -222,45 +142,45 @@ 
Numeric Constraint Guards
-
Layout

+
+
+

Layout

Groups of declarations are organized based on indentation. Declarations with the same indentation belong to the same group. Lines of text that are indented more than the beginning of a declaration belong to that declaration, while lines of text that are indented less terminate a group of declarations. Consider, for example, the following Cryptol declarations:

-
f x = x + y + z
-  where
-  y = x * x
-  z = x + y
+
f x = x + y + z
+  where
+  y = x * x
+  z = x + y
 
-g y = y
+g y = y
 

 

 
This group has two declarations, one for f and one for g.  All the
 lines between f and g that are indented more than f belong to
 f.  The same principle applies to the declarations in the where block
 of f, which defines two more local names, y and z.

-
-
-

Comments

+
+
+

Comments

Cryptol supports block comments, which start with /* and end with */, and line comments, which start with // and terminate at the end of the line. Block comments may be nested arbitrarily.

-
/* This is a block comment */
-// This is a line comment
-/* This is a /* Nested */ block comment */
+
/* This is a block comment */
+// This is a line comment
+/* This is a /* Nested */ block comment */
 

 

 

 
Todo

 
Document /** */

 

-
-
-

Identifiers

+
+
+

Identifiers

Cryptol identifiers consist of one or more characters. The first character must be either an English letter or underscore (_). The following characters may be an English letter, a decimal digit, @@ -268,19 +188,19 @@

IdentifiersKeywords and Built-in Operators).

-
Examples of identifiers
-
name    name1    name'    longer_name
-Name    Name2    Name''   longerName
+
Examples of identifiers

+
name    name1    name'    longer_name
+Name    Name2    Name''   longerName
-
-
-

Keywords and Built-in Operators

+

+
+

Keywords and Built-in Operators

The following identifiers have special meanings in Cryptol, and may not be used for programmer defined names:

-
Keywords
+
Keywords
as              extern      include      interface      parameter      property      where
 by              hiding      infix        let            pragma         submodule     else
 constraint      if          infixl       module         primitive      then
@@ -292,7 +212,7 @@ 
Keywords and Built-in Operators
-Operator precedences
+Operator precedences
 
 
 
@@ -351,13 +271,13 @@ 
Keywords and Built-in Operators
-
Built-in Type-level Operators

+
+
+

Built-in Type-level Operators

Cryptol includes a variety of operators that allow computations on the numeric types used to specify the sizes of sequences.

- +@@ -406,21 +326,21 @@

Built-in Type-level Operators -

Numeric Literals

+ +
+

Numeric Literals

Numeric literals may be written in binary, octal, decimal, or hexadecimal notation. The base of a literal is determined by its prefix: 0b for binary, 0o for octal, no special prefix for decimal, and 0x for hexadecimal.

-
Examples of literals
-
254                 // Decimal literal
-0254                // Decimal literal
-0b11111110          // Binary literal
-0o376               // Octal literal
-0xFE                // Hexadecimal literal
-0xfe                // Hexadecimal literal
+
Examples of literals

+
254                 // Decimal literal
+0254                // Decimal literal
+0b11111110          // Binary literal
+0o376               // Octal literal
+0xFE                // Hexadecimal literal
+0xfe                // Hexadecimal literal
@@ -430,13 +350,13 @@

Numeric Literals -
Literals and their types
-
0b1010              // : [4],   1 * number of digits
-0o1234              // : [12],  3 * number of digits
-0x1234              // : [16],  4 * number of digits
+
Literals and their types

+
0b1010              // : [4],   1 * number of digits
+0o1234              // : [12],  3 * number of digits
+0x1234              // : [16],  4 * number of digits
 
-10                  // : {a}. (Literal 10 a) => a
-                    // a = Integer or [n] where n >= width 10
+10                  // : {a}. (Literal 10 a) => a
+                    // a = Integer or [n] where n >= width 10
@@ -445,9 +365,9 @@

Numeric Literals -
Polynomial literals
-
<| x^^6 + x^^4 + x^^2 + x^^1 + 1 |>  // : [7], equal to 0b1010111
-<| x^^4 + x^^3 + x |>                // : [5], equal to 0b11010
+
Polynomial literals

+
<| x^^6 + x^^4 + x^^2 + x^^1 + 1 |>  // : [7], equal to 0b1010111
+<| x^^4 + x^^3 + x |>                // : [5], equal to 0b11010
@@ -459,11 +379,11 @@

Numeric Literalse. Examples:

-
Fractional literals
-
10.2
-10.2e3            // 10.2 * 10^3
-0x30.1            // 3 * 64 + 1/16
-0x30.1p4          // (3 * 64 + 1/16) * 2^4
+
Fractional literals

+
10.2
+10.2e3            // 10.2 * 10^3
+0x30.1            // 3 * 64 + 1/16
+0x30.1p4          // (3 * 64 + 1/16) * 2^4
@@ -476,62 +396,44 @@

Numeric Literals_, which has no effect on the literal value but may be used to improve readability. Here are some examples:

-
Using _
-
0b_0000_0010
-0x_FFFF_FFEA
+
Using _

+
0b_0000_0010
+0x_FFFF_FFEA
-
-
+

+ - - - - - - - - - - - - - + \ No newline at end of file diff --git a/docs/RefMan/_build/html/BasicTypes.html b/docs/RefMan/_build/html/BasicTypes.html index edb6151cf..316076210 100644 --- a/docs/RefMan/_build/html/BasicTypes.html +++ b/docs/RefMan/_build/html/BasicTypes.html @@ -1,66 +1,34 @@ - - - - + - - - - - Basic Types — Cryptol 2.11.0 documentation - + + + Basic Types — Cryptol 2.11.0 documentation + + + - - - - - - - - - + - - - - - - - - + - - - +
- -
- - -

Type-level operatorsType-level operators
- +@@ -340,67 +260,49 @@

Sequences
[p1, p2, p3, p4]          // Sequence pattern
-p1 # p2                   // Split sequence pattern
+
[p1, p2, p3, p4]          // Sequence pattern
+p1 # p2                   // Split sequence pattern
 

 

-
-
-

Functions

-
\p1 p2 -> e              // Lambda expression
-f p1 p2 = e              // Function definition
+
+

+
Functions

+
\p1 p2 -> e              // Lambda expression
+f p1 p2 = e              // Function definition
 

 

-
-
+ +
- - - - - - - - - - - - - + \ No newline at end of file diff --git a/docs/RefMan/_build/html/Expressions.html b/docs/RefMan/_build/html/Expressions.html index 2541b6491..02d60cef9 100644 --- a/docs/RefMan/_build/html/Expressions.html +++ b/docs/RefMan/_build/html/Expressions.html @@ -1,66 +1,34 @@ - - - - + - - - - - Expressions — Cryptol 2.11.0 documentation - - - - - - + + + Expressions — Cryptol 2.11.0 documentation + + + - - - - + - - - - - - - - + - - - +
- -
- - -
-
-

Type Annotations

+ +
+

Type Annotations

Explicit type annotations may be added on expressions, patterns, and in argument definitions.

-
x : Bit         // specify that `x` has type `Bit`
-f x : Bit       // specify that `f x` has type `Bit`
-- f x : [8]     // specify that `- f x` has type `[8]`
-2 + 3 : [8]     // specify that `2 + 3` has type `[8]`
-\x -> x : [8]   // type annotation is on `x`, not the function
-if x
-  then y
-  else z : Bit  // the type annotation is on `z`, not the whole `if`
-[1..9 : [8]]    // specify that elements in `[1..9]` have type `[8]`
-
-f (x : [8]) = x + 1   // type annotation on patterns
+
x : Bit         // specify that `x` has type `Bit`
+f x : Bit       // specify that `f x` has type `Bit`
+- f x : [8]     // specify that `- f x` has type `[8]`
+2 + 3 : [8]     // specify that `2 + 3` has type `[8]`
+\x -> x : [8]   // type annotation is on `x`, not the function
+if x
+  then y
+  else z : Bit  // the type annotation is on `z`, not the whole `if`
+[1..9 : [8]]    // specify that elements in `[1..9]` have type `[8]`
+
+f (x : [8]) = x + 1   // type annotation on patterns
 

 

 

 
Todo

 
Patterns with type variables

 

-
-
-

Explicit Type Instantiation

+
+
+

Explicit Type Instantiation

If f is a polymorphic value with type:

-
f : { tyParam } tyParam
-f = zero
+
f : { tyParam } tyParam
+f = zero
 

 

 
you can evaluate f, passing it a type parameter:

-
f `{ tyParam = 13 }
+
f `{ tyParam = 13 }
 

 

-

-

-
Local Declarations

+
+
+

Local Declarations

Local declarations have the weakest precedence of all expressions.

-
2 + x : [T]
-  where
-  type T = 8
-  x      = 2          // `T` and `x` are in scope of `2 + x : `[T]`
+
2 + x : [T]
+  where
+  type T = 8
+  x      = 2          // `T` and `x` are in scope of `2 + x : `[T]`
 
-if x then 1 else 2
-  where x = 2         // `x` is in scope in the whole `if`
+if x then 1 else 2
+  where x = 2         // `x` is in scope in the whole `if`
 
-\y -> x + y
-  where x = 2         // `y` is not in scope in the defintion of `x`
+\y -> x + y
+  where x = 2         // `y` is not in scope in the defintion of `x`
 

 

-
-
-

Block Arguments

+
+
+

Block Arguments

When used as the last argument to a function call, if and lambda expressions do not need parens:

-
f \x -> x       // call `f` with one argument `x -> x`
-2 + if x
-      then y
-      else z    // call `+` with two arguments: `2` and `if ...`
+
f \x -> x       // call `f` with one argument `x -> x`
+2 + if x
+      then y
+      else z    // call `+` with two arguments: `2` and `if ...`
 

 

-
-
-

Conditionals

+
+
+

Conditionals

The if ... then ... else construct can be used with multiple branches. For example:

-
x = if y % 2 == 0 then 22 else 33
+
x = if y % 2 == 0 then 22 else 33
 
-x = if y % 2 == 0 then 1
-     | y % 3 == 0 then 2
-     | y % 5 == 0 then 3
-     else 7
+x = if y % 2 == 0 then 1
+     | y % 3 == 0 then 2
+     | y % 5 == 0 then 3
+     else 7
 

 

-
-
-

Demoting Numeric Types to Values

+
+
+

Demoting Numeric Types to Values

The value corresponding to a numeric type may be accessed using the following notation:

-
`t
+
`t
 

 

 
Here t should be a finite type expression with numeric kind.  The resulting
 expression will be of a numeric base type, which is sufficiently large
 to accommodate the value of the type:

-
`t : {a} (Literal t a) => a
+
`t : {a} (Literal t a) => a
 

 

 
This backtick notation is syntax sugar for an application of the
 number primtive, so the above may be written as:

-
number`{t} : {a} (Literal t a) => a
+
number`{t} : {a} (Literal t a) => a
 

 

 
If a type cannot be inferred from context, a suitable type will be
 automatically chosen if possible, usually Integer.

-

-

+
+
- - - - - - - - - - - - - + \ No newline at end of file diff --git a/docs/RefMan/_build/html/FFI.html b/docs/RefMan/_build/html/FFI.html index 2b0c8aea4..d31c35756 100644 --- a/docs/RefMan/_build/html/FFI.html +++ b/docs/RefMan/_build/html/FFI.html @@ -1,65 +1,33 @@ - - - - + - - - - - Foreign Function Interface — Cryptol 2.11.0 documentation - - - - - - + + + Foreign Function Interface — Cryptol 2.11.0 documentation + + + - - - - + - - - - - - - - + - - - +
- -
- - -

Sequence operations.Sequence operations.
@@ -314,9 +234,9 @@

Type parameters< 2^^64 instead of just fin, in practice this would be too cumbersome.)

- -
-

Bit

+ +
+

Bit

@@ -336,9 +256,9 @@

BitWhen converting to C, True is converted to 1 and False to 0. When converting to Cryptol, any nonzero number is converted to True and 0 is converted to False.

- -
-

Bit Vector Types

+ +
+

Bit Vector Types

Let K : # be a Cryptol type. Note K must be an actual fixed numeric type and not a type variable.

@@ -375,9 +295,9 @@

Bit Vector Types -

Floating point types

+ +
+

Floating point types

@@ -399,9 +319,9 @@

Floating point types

Note: the Cryptol Float types are defined in the built-in module Float. Other sizes of floating points are not supported.

- -
-

Math Types

+ +
+

Math Types

Values of high precision types and Z are represented using the GMP library.

@@ -433,9 +353,9 @@

Math Typesinit before their use and clear after.

- -
-

Sequences

+ +
+

Sequences

Let n1, n2, ..., nk : # be Cryptol types (with k >= 1), possibly containing type variables, that satisfy fin n1, fin n2, ..., fin nk, and T be one of the above Cryptol bit vector types, floating point types, or @@ -462,9 +382,9 @@

Sequencessize_t’s earlier, so the C code can always know the dimensions of the array.

-

-
-

Tuples and records

+ +
+

Tuples and records

Let T1, T2, ..., Tn be Cryptol types supported by the FFI (which may be any of the types mentioned above, or tuples and records themselves). Let U1, U2, ..., Un be the C types that T1, T2, ..., Tn respectively @@ -492,14 +412,14 @@

Tuples and records -

Type synonyms

+

+
+

Type synonyms

All type synonyms are expanded before applying the above rules, so you can use type synonyms in foreign declarations to improve readability.

-
-
-

Return values

+ +
+

Return values

If the Cryptol return type is Bit or one of the above bit vector types or floating point types, the value is returned directly from the C function. In that case, the return type of the C function will be the C type corresponding to @@ -511,9 +431,9 @@

Return valuesU will be a pointer U* instead, except in the case of math types and sequences, where the output and input versions are the same type, because it is already a pointer.

-

-
-

Quick reference

+ +
+

Quick reference

@@ -603,10 +523,10 @@

Quick referenceK is a constant number, ni are variable numbers, Ti is a type, Ui is its C argument type, and Vi is its C output argument type.

- - -
-

Memory

+ + +
+

Memory

When pointers are involved, namely in the cases of sequences and output arguments, they point to memory. This memory is always allocated and deallocated by Cryptol; the C code does not need to manage this memory.

@@ -619,71 +539,54 @@

Memory -

Evaluation

+

+
+

Evaluation

All Cryptol arguments are fully evaluated when a foreign function is called.

-
-
-

Example

+ +
+

Example

The Cryptol signature

-
foreign f : {n} (fin n) => [n][10] -> {a : Bit, b : [64]}
-                           -> (Float64, [n + 1][20])
+
foreign f : {n} (fin n) => [n][10] -> {a : Bit, b : [64]}
+                           -> (Float64, [n + 1][20])
 

 

 
corresponds to the C signature

-
void f(size_t n, uint16_t *in0, uint8_t in1_a, uint64_t in1_b,
-       double *out_0, uint32_t *out_1);
+
void f(size_t n, uint16_t *in0, uint8_t in1_a, uint64_t in1_b,
+       double *out_0, uint32_t *out_1);
 

 

-

-

+
+
- - - - - - - - - - - - - + \ No newline at end of file diff --git a/docs/RefMan/_build/html/Modules.html b/docs/RefMan/_build/html/Modules.html index 967ba8d57..19dee21b2 100644 --- a/docs/RefMan/_build/html/Modules.html +++ b/docs/RefMan/_build/html/Modules.html @@ -1,66 +1,34 @@ - - - - + - - - - - Modules — Cryptol 2.11.0 documentation - - - - - - + + + Modules — Cryptol 2.11.0 documentation + + + - - - - + - - - - - - - - + - - - +
- -
- - -
+
- - - - - - - - - - - - - + \ No newline at end of file diff --git a/docs/RefMan/_build/html/OverloadedOperations.html b/docs/RefMan/_build/html/OverloadedOperations.html index 06753d4fe..ace85180c 100644 --- a/docs/RefMan/_build/html/OverloadedOperations.html +++ b/docs/RefMan/_build/html/OverloadedOperations.html @@ -1,66 +1,34 @@ - - - - + - - - - - Overloaded Operations — Cryptol 2.11.0 documentation - - - - - - + + + Overloaded Operations — Cryptol 2.11.0 documentation + + + - - - - + - - - - - - - - + - - - +
- -
- - -
-
-

Signed Comparisons

-
SignedCmp
-  (<$)        : {a} (SignedCmp a) => a -> a -> Bit
-  (>$)        : {a} (SignedCmp a) => a -> a -> Bit
-  (<=$)       : {a} (SignedCmp a) => a -> a -> Bit
-  (>=$)       : {a} (SignedCmp a) => a -> a -> Bit
+
+

+
Signed Comparisons

+
SignedCmp
+  (<$)        : {a} (SignedCmp a) => a -> a -> Bit
+  (>$)        : {a} (SignedCmp a) => a -> a -> Bit
+  (<=$)       : {a} (SignedCmp a) => a -> a -> Bit
+  (>=$)       : {a} (SignedCmp a) => a -> a -> Bit
 

 

-
-
-

Zero

-
Zero
-  zero        : {a} (Zero a) => a
+
+

+
Zero

+
Zero
+  zero        : {a} (Zero a) => a
 

 

-
-
-

Logical Operations

-
Logic
-  (&&)        : {a} (Logic a) => a -> a -> a
-  (||)        : {a} (Logic a) => a -> a -> a
-  (^)         : {a} (Logic a) => a -> a -> a
-  complement  : {a} (Logic a) => a -> a
+
+

+
Logical Operations

+
Logic
+  (&&)        : {a} (Logic a) => a -> a -> a
+  (||)        : {a} (Logic a) => a -> a -> a
+  (^)         : {a} (Logic a) => a -> a -> a
+  complement  : {a} (Logic a) => a -> a
 

 

-
-
-

Basic Arithmetic

-
Ring
-  fromInteger : {a} (Ring a) => Integer -> a
-  (+)         : {a} (Ring a) => a -> a -> a
-  (-)         : {a} (Ring a) => a -> a -> a
-  (*)         : {a} (Ring a) => a -> a -> a
-  negate      : {a} (Ring a) => a -> a
-  (^^)        : {a, e} (Ring a, Integral e) => a -> e -> a
+
+

+
Basic Arithmetic

+
Ring
+  fromInteger : {a} (Ring a) => Integer -> a
+  (+)         : {a} (Ring a) => a -> a -> a
+  (-)         : {a} (Ring a) => a -> a -> a
+  (*)         : {a} (Ring a) => a -> a -> a
+  negate      : {a} (Ring a) => a -> a
+  (^^)        : {a, e} (Ring a, Integral e) => a -> e -> a
 

 

-
-
-

Integral Operations

-
Integral
-  (/)         : {a} (Integral a) => a -> a -> a
-  (%)         : {a} (Integral a) => a -> a -> a
-  (^^)        : {a, e} (Ring a, Integral e) => a -> e -> a
-  toInteger   : {a} (Integral a) => a -> Integer
-  infFrom     : {a} (Integral a) => a -> [inf]a
-  infFromThen : {a} (Integral a) => a -> a -> [inf]a
+
+

+
Integral Operations

+
Integral
+  (/)         : {a} (Integral a) => a -> a -> a
+  (%)         : {a} (Integral a) => a -> a -> a
+  (^^)        : {a, e} (Ring a, Integral e) => a -> e -> a
+  toInteger   : {a} (Integral a) => a -> Integer
+  infFrom     : {a} (Integral a) => a -> [inf]a
+  infFromThen : {a} (Integral a) => a -> a -> [inf]a
 

 

-
-
-

Division

-
Field
-  recip       : {a} (Field a) => a -> a
-  (/.)        : {a} (Field a) => a -> a -> a
+
+

+
Division

+
Field
+  recip       : {a} (Field a) => a -> a
+  (/.)        : {a} (Field a) => a -> a -> a
 

 

-
-
-

Rounding

-
Round
-  ceiling     : {a} (Round a) => a -> Integer
-  floor       : {a} (Round a) => a -> Integer
-  trunc       : {a} (Round a) => a -> Integer
-  roundAway   : {a} (Round a) => a -> Integer
-  roundToEven : {a} (Round a) => a -> Integer
+
+

+
Rounding

+
Round
+  ceiling     : {a} (Round a) => a -> Integer
+  floor       : {a} (Round a) => a -> Integer
+  trunc       : {a} (Round a) => a -> Integer
+  roundAway   : {a} (Round a) => a -> Integer
+  roundToEven : {a} (Round a) => a -> Integer
 

 

-
-
+ +
-
-
- -
- - - - - - - - - + \ No newline at end of file diff --git a/docs/RefMan/_build/html/RefMan.html b/docs/RefMan/_build/html/RefMan.html index b721a33da..fb0b60319 100644 --- a/docs/RefMan/_build/html/RefMan.html +++ b/docs/RefMan/_build/html/RefMan.html @@ -1,65 +1,33 @@ - - - - + - - - - - Cryptol Reference Manual — Cryptol 2.11.0 documentation - - - - - - + + + Cryptol Reference Manual — Cryptol 2.11.0 documentation + + + - - - - + - - - - - - - - + - - - +
- -
- - -
- - - - - - - - - + \ No newline at end of file diff --git a/docs/RefMan/_build/html/TypeDeclarations.html b/docs/RefMan/_build/html/TypeDeclarations.html index f895b09fb..d198f9833 100644 --- a/docs/RefMan/_build/html/TypeDeclarations.html +++ b/docs/RefMan/_build/html/TypeDeclarations.html @@ -1,66 +1,34 @@ - - - - + - - - - - Type Declarations — Cryptol 2.11.0 documentation - - - - - - + + + Type Declarations — Cryptol 2.11.0 documentation + + + - - - - + - - - - - - - - + - - - +
- -
- - -

or other required elements. - thead: [ 1, "
", "
" ], - col: [ 2, "", "
" ], - tr: [ 2, "", "
" ], - td: [ 3, "", "
" ], - - _default: [ 0, "", "" ] -}; - -wrapMap.tbody = wrapMap.tfoot = wrapMap.colgroup = wrapMap.caption = wrapMap.thead; -wrapMap.th = wrapMap.td; - -// Support: IE <=9 only -if ( !support.option ) { - wrapMap.optgroup = wrapMap.option = [ 1, "" ]; -} - - -function getAll( context, tag ) { - - // Support: IE <=9 - 11 only - // Use typeof to avoid zero-argument method invocation on host objects (#15151) - var ret; - - if ( typeof context.getElementsByTagName !== "undefined" ) { - ret = context.getElementsByTagName( tag || "*" ); - - } else if ( typeof context.querySelectorAll !== "undefined" ) { - ret = context.querySelectorAll( tag || "*" ); - - } else { - ret = []; - } - - if ( tag === undefined || tag && nodeName( context, tag ) ) { - return jQuery.merge( [ context ], ret ); - } - - return ret; -} - - -// Mark scripts as having already been evaluated -function setGlobalEval( elems, refElements ) { - var i = 0, - l = elems.length; - - for ( ; i < l; i++ ) { - dataPriv.set( - elems[ i ], - "globalEval", - !refElements || dataPriv.get( refElements[ i ], "globalEval" ) - ); - } -} - - -var rhtml = /<|&#?\w+;/; - -function buildFragment( elems, context, scripts, selection, ignored ) { - var elem, tmp, tag, wrap, attached, j, - fragment = context.createDocumentFragment(), - nodes = [], - i = 0, - l = elems.length; - - for ( ; i < l; i++ ) { - elem = elems[ i ]; - - if ( elem || elem === 0 ) { - - // Add nodes directly - if ( toType( elem ) === "object" ) { - - // Support: Android <=4.0 only, PhantomJS 1 only - // push.apply(_, arraylike) throws on ancient WebKit - jQuery.merge( nodes, elem.nodeType ? [ elem ] : elem ); - - // Convert non-html into a text node - } else if ( !rhtml.test( elem ) ) { - nodes.push( context.createTextNode( elem ) ); - - // Convert html into DOM nodes - } else { - tmp = tmp || fragment.appendChild( context.createElement( "div" ) ); - - // Deserialize a standard representation - tag = ( rtagName.exec( elem ) || [ "", "" ] )[ 1 ].toLowerCase(); - wrap = wrapMap[ tag ] || wrapMap._default; - tmp.innerHTML = wrap[ 1 ] + jQuery.htmlPrefilter( elem ) + wrap[ 2 ]; - - // Descend through wrappers to the right content - j = wrap[ 0 ]; - while ( j-- ) { - tmp = tmp.lastChild; - } - - // Support: Android <=4.0 only, PhantomJS 1 only - // push.apply(_, arraylike) throws on ancient WebKit - jQuery.merge( nodes, tmp.childNodes ); - - // Remember the top-level container - tmp = fragment.firstChild; - - // Ensure the created nodes are orphaned (#12392) - tmp.textContent = ""; - } - } - } - - // Remove wrapper from fragment - fragment.textContent = ""; - - i = 0; - while ( ( elem = nodes[ i++ ] ) ) { - - // Skip elements already in the context collection (trac-4087) - if ( selection && jQuery.inArray( elem, selection ) > -1 ) { - if ( ignored ) { - ignored.push( elem ); - } - continue; - } - - attached = isAttached( elem ); - - // Append to fragment - tmp = getAll( fragment.appendChild( elem ), "script" ); - - // Preserve script evaluation history - if ( attached ) { - setGlobalEval( tmp ); - } - - // Capture executables - if ( scripts ) { - j = 0; - while ( ( elem = tmp[ j++ ] ) ) { - if ( rscriptType.test( elem.type || "" ) ) { - scripts.push( elem ); - } - } - } - } - - return fragment; -} - - -var - rkeyEvent = /^key/, - rmouseEvent = /^(?:mouse|pointer|contextmenu|drag|drop)|click/, - rtypenamespace = /^([^.]*)(?:\.(.+)|)/; - -function returnTrue() { - return true; -} - -function returnFalse() { - return false; -} - -// Support: IE <=9 - 11+ -// focus() and blur() are asynchronous, except when they are no-op. -// So expect focus to be synchronous when the element is already active, -// and blur to be synchronous when the element is not already active. -// (focus and blur are always synchronous in other supported browsers, -// this just defines when we can count on it). -function expectSync( elem, type ) { - return ( elem === safeActiveElement() ) === ( type === "focus" ); -} - -// Support: IE <=9 only -// Accessing document.activeElement can throw unexpectedly -// https://bugs.jquery.com/ticket/13393 -function safeActiveElement() { - try { - return document.activeElement; - } catch ( err ) { } -} - -function on( elem, types, selector, data, fn, one ) { - var origFn, type; - - // Types can be a map of types/handlers - if ( typeof types === "object" ) { - - // ( types-Object, selector, data ) - if ( typeof selector !== "string" ) { - - // ( types-Object, data ) - data = data || selector; - selector = undefined; - } - for ( type in types ) { - on( elem, type, selector, data, types[ type ], one ); - } - return elem; - } - - if ( data == null && fn == null ) { - - // ( types, fn ) - fn = selector; - data = selector = undefined; - } else if ( fn == null ) { - if ( typeof selector === "string" ) { - - // ( types, selector, fn ) - fn = data; - data = undefined; - } else { - - // ( types, data, fn ) - fn = data; - data = selector; - selector = undefined; - } - } - if ( fn === false ) { - fn = returnFalse; - } else if ( !fn ) { - return elem; - } - - if ( one === 1 ) { - origFn = fn; - fn = function( event ) { - - // Can use an empty set, since event contains the info - jQuery().off( event ); - return origFn.apply( this, arguments ); - }; - - // Use same guid so caller can remove using origFn - fn.guid = origFn.guid || ( origFn.guid = jQuery.guid++ ); - } - return elem.each( function() { - jQuery.event.add( this, types, fn, data, selector ); - } ); -} - -/* - * Helper functions for managing events -- not part of the public interface. - * Props to Dean Edwards' addEvent library for many of the ideas. - */ -jQuery.event = { - - global: {}, - - add: function( elem, types, handler, data, selector ) { - - var handleObjIn, eventHandle, tmp, - events, t, handleObj, - special, handlers, type, namespaces, origType, - elemData = dataPriv.get( elem ); - - // Only attach events to objects that accept data - if ( !acceptData( elem ) ) { - return; - } - - // Caller can pass in an object of custom data in lieu of the handler - if ( handler.handler ) { - handleObjIn = handler; - handler = handleObjIn.handler; - selector = handleObjIn.selector; - } - - // Ensure that invalid selectors throw exceptions at attach time - // Evaluate against documentElement in case elem is a non-element node (e.g., document) - if ( selector ) { - jQuery.find.matchesSelector( documentElement, selector ); - } - - // Make sure that the handler has a unique ID, used to find/remove it later - if ( !handler.guid ) { - handler.guid = jQuery.guid++; - } - - // Init the element's event structure and main handler, if this is the first - if ( !( events = elemData.events ) ) { - events = elemData.events = Object.create( null ); - } - if ( !( eventHandle = elemData.handle ) ) { - eventHandle = elemData.handle = function( e ) { - - // Discard the second event of a jQuery.event.trigger() and - // when an event is called after a page has unloaded - return typeof jQuery !== "undefined" && jQuery.event.triggered !== e.type ? - jQuery.event.dispatch.apply( elem, arguments ) : undefined; - }; - } - - // Handle multiple events separated by a space - types = ( types || "" ).match( rnothtmlwhite ) || [ "" ]; - t = types.length; - while ( t-- ) { - tmp = rtypenamespace.exec( types[ t ] ) || []; - type = origType = tmp[ 1 ]; - namespaces = ( tmp[ 2 ] || "" ).split( "." ).sort(); - - // There *must* be a type, no attaching namespace-only handlers - if ( !type ) { - continue; - } - - // If event changes its type, use the special event handlers for the changed type - special = jQuery.event.special[ type ] || {}; - - // If selector defined, determine special event api type, otherwise given type - type = ( selector ? special.delegateType : special.bindType ) || type; - - // Update special based on newly reset type - special = jQuery.event.special[ type ] || {}; - - // handleObj is passed to all event handlers - handleObj = jQuery.extend( { - type: type, - origType: origType, - data: data, - handler: handler, - guid: handler.guid, - selector: selector, - needsContext: selector && jQuery.expr.match.needsContext.test( selector ), - namespace: namespaces.join( "." ) - }, handleObjIn ); - - // Init the event handler queue if we're the first - if ( !( handlers = events[ type ] ) ) { - handlers = events[ type ] = []; - handlers.delegateCount = 0; - - // Only use addEventListener if the special events handler returns false - if ( !special.setup || - special.setup.call( elem, data, namespaces, eventHandle ) === false ) { - - if ( elem.addEventListener ) { - elem.addEventListener( type, eventHandle ); - } - } - } - - if ( special.add ) { - special.add.call( elem, handleObj ); - - if ( !handleObj.handler.guid ) { - handleObj.handler.guid = handler.guid; - } - } - - // Add to the element's handler list, delegates in front - if ( selector ) { - handlers.splice( handlers.delegateCount++, 0, handleObj ); - } else { - handlers.push( handleObj ); - } - - // Keep track of which events have ever been used, for event optimization - jQuery.event.global[ type ] = true; - } - - }, - - // Detach an event or set of events from an element - remove: function( elem, types, handler, selector, mappedTypes ) { - - var j, origCount, tmp, - events, t, handleObj, - special, handlers, type, namespaces, origType, - elemData = dataPriv.hasData( elem ) && dataPriv.get( elem ); - - if ( !elemData || !( events = elemData.events ) ) { - return; - } - - // Once for each type.namespace in types; type may be omitted - types = ( types || "" ).match( rnothtmlwhite ) || [ "" ]; - t = types.length; - while ( t-- ) { - tmp = rtypenamespace.exec( types[ t ] ) || []; - type = origType = tmp[ 1 ]; - namespaces = ( tmp[ 2 ] || "" ).split( "." ).sort(); - - // Unbind all events (on this namespace, if provided) for the element - if ( !type ) { - for ( type in events ) { - jQuery.event.remove( elem, type + types[ t ], handler, selector, true ); - } - continue; - } - - special = jQuery.event.special[ type ] || {}; - type = ( selector ? special.delegateType : special.bindType ) || type; - handlers = events[ type ] || []; - tmp = tmp[ 2 ] && - new RegExp( "(^|\\.)" + namespaces.join( "\\.(?:.*\\.|)" ) + "(\\.|$)" ); - - // Remove matching events - origCount = j = handlers.length; - while ( j-- ) { - handleObj = handlers[ j ]; - - if ( ( mappedTypes || origType === handleObj.origType ) && - ( !handler || handler.guid === handleObj.guid ) && - ( !tmp || tmp.test( handleObj.namespace ) ) && - ( !selector || selector === handleObj.selector || - selector === "**" && handleObj.selector ) ) { - handlers.splice( j, 1 ); - - if ( handleObj.selector ) { - handlers.delegateCount--; - } - if ( special.remove ) { - special.remove.call( elem, handleObj ); - } - } - } - - // Remove generic event handler if we removed something and no more handlers exist - // (avoids potential for endless recursion during removal of special event handlers) - if ( origCount && !handlers.length ) { - if ( !special.teardown || - special.teardown.call( elem, namespaces, elemData.handle ) === false ) { - - jQuery.removeEvent( elem, type, elemData.handle ); - } - - delete events[ type ]; - } - } - - // Remove data and the expando if it's no longer used - if ( jQuery.isEmptyObject( events ) ) { - dataPriv.remove( elem, "handle events" ); - } - }, - - dispatch: function( nativeEvent ) { - - var i, j, ret, matched, handleObj, handlerQueue, - args = new Array( arguments.length ), - - // Make a writable jQuery.Event from the native event object - event = jQuery.event.fix( nativeEvent ), - - handlers = ( - dataPriv.get( this, "events" ) || Object.create( null ) - )[ event.type ] || [], - special = jQuery.event.special[ event.type ] || {}; - - // Use the fix-ed jQuery.Event rather than the (read-only) native event - args[ 0 ] = event; - - for ( i = 1; i < arguments.length; i++ ) { - args[ i ] = arguments[ i ]; - } - - event.delegateTarget = this; - - // Call the preDispatch hook for the mapped type, and let it bail if desired - if ( special.preDispatch && special.preDispatch.call( this, event ) === false ) { - return; - } - - // Determine handlers - handlerQueue = jQuery.event.handlers.call( this, event, handlers ); - - // Run delegates first; they may want to stop propagation beneath us - i = 0; - while ( ( matched = handlerQueue[ i++ ] ) && !event.isPropagationStopped() ) { - event.currentTarget = matched.elem; - - j = 0; - while ( ( handleObj = matched.handlers[ j++ ] ) && - !event.isImmediatePropagationStopped() ) { - - // If the event is namespaced, then each handler is only invoked if it is - // specially universal or its namespaces are a superset of the event's. - if ( !event.rnamespace || handleObj.namespace === false || - event.rnamespace.test( handleObj.namespace ) ) { - - event.handleObj = handleObj; - event.data = handleObj.data; - - ret = ( ( jQuery.event.special[ handleObj.origType ] || {} ).handle || - handleObj.handler ).apply( matched.elem, args ); - - if ( ret !== undefined ) { - if ( ( event.result = ret ) === false ) { - event.preventDefault(); - event.stopPropagation(); - } - } - } - } - } - - // Call the postDispatch hook for the mapped type - if ( special.postDispatch ) { - special.postDispatch.call( this, event ); - } - - return event.result; - }, - - handlers: function( event, handlers ) { - var i, handleObj, sel, matchedHandlers, matchedSelectors, - handlerQueue = [], - delegateCount = handlers.delegateCount, - cur = event.target; - - // Find delegate handlers - if ( delegateCount && - - // Support: IE <=9 - // Black-hole SVG instance trees (trac-13180) - cur.nodeType && - - // Support: Firefox <=42 - // Suppress spec-violating clicks indicating a non-primary pointer button (trac-3861) - // https://www.w3.org/TR/DOM-Level-3-Events/#event-type-click - // Support: IE 11 only - // ...but not arrow key "clicks" of radio inputs, which can have `button` -1 (gh-2343) - !( event.type === "click" && event.button >= 1 ) ) { - - for ( ; cur !== this; cur = cur.parentNode || this ) { - - // Don't check non-elements (#13208) - // Don't process clicks on disabled elements (#6911, #8165, #11382, #11764) - if ( cur.nodeType === 1 && !( event.type === "click" && cur.disabled === true ) ) { - matchedHandlers = []; - matchedSelectors = {}; - for ( i = 0; i < delegateCount; i++ ) { - handleObj = handlers[ i ]; - - // Don't conflict with Object.prototype properties (#13203) - sel = handleObj.selector + " "; - - if ( matchedSelectors[ sel ] === undefined ) { - matchedSelectors[ sel ] = handleObj.needsContext ? - jQuery( sel, this ).index( cur ) > -1 : - jQuery.find( sel, this, null, [ cur ] ).length; - } - if ( matchedSelectors[ sel ] ) { - matchedHandlers.push( handleObj ); - } - } - if ( matchedHandlers.length ) { - handlerQueue.push( { elem: cur, handlers: matchedHandlers } ); - } - } - } - } - - // Add the remaining (directly-bound) handlers - cur = this; - if ( delegateCount < handlers.length ) { - handlerQueue.push( { elem: cur, handlers: handlers.slice( delegateCount ) } ); - } - - return handlerQueue; - }, - - addProp: function( name, hook ) { - Object.defineProperty( jQuery.Event.prototype, name, { - enumerable: true, - configurable: true, - - get: isFunction( hook ) ? - function() { - if ( this.originalEvent ) { - return hook( this.originalEvent ); - } - } : - function() { - if ( this.originalEvent ) { - return this.originalEvent[ name ]; - } - }, - - set: function( value ) { - Object.defineProperty( this, name, { - enumerable: true, - configurable: true, - writable: true, - value: value - } ); - } - } ); - }, - - fix: function( originalEvent ) { - return originalEvent[ jQuery.expando ] ? - originalEvent : - new jQuery.Event( originalEvent ); - }, - - special: { - load: { - - // Prevent triggered image.load events from bubbling to window.load - noBubble: true - }, - click: { - - // Utilize native event to ensure correct state for checkable inputs - setup: function( data ) { - - // For mutual compressibility with _default, replace `this` access with a local var. - // `|| data` is dead code meant only to preserve the variable through minification. - var el = this || data; - - // Claim the first handler - if ( rcheckableType.test( el.type ) && - el.click && nodeName( el, "input" ) ) { - - // dataPriv.set( el, "click", ... ) - leverageNative( el, "click", returnTrue ); - } - - // Return false to allow normal processing in the caller - return false; - }, - trigger: function( data ) { - - // For mutual compressibility with _default, replace `this` access with a local var. - // `|| data` is dead code meant only to preserve the variable through minification. - var el = this || data; - - // Force setup before triggering a click - if ( rcheckableType.test( el.type ) && - el.click && nodeName( el, "input" ) ) { - - leverageNative( el, "click" ); - } - - // Return non-false to allow normal event-path propagation - return true; - }, - - // For cross-browser consistency, suppress native .click() on links - // Also prevent it if we're currently inside a leveraged native-event stack - _default: function( event ) { - var target = event.target; - return rcheckableType.test( target.type ) && - target.click && nodeName( target, "input" ) && - dataPriv.get( target, "click" ) || - nodeName( target, "a" ); - } - }, - - beforeunload: { - postDispatch: function( event ) { - - // Support: Firefox 20+ - // Firefox doesn't alert if the returnValue field is not set. - if ( event.result !== undefined && event.originalEvent ) { - event.originalEvent.returnValue = event.result; - } - } - } - } -}; - -// Ensure the presence of an event listener that handles manually-triggered -// synthetic events by interrupting progress until reinvoked in response to -// *native* events that it fires directly, ensuring that state changes have -// already occurred before other listeners are invoked. -function leverageNative( el, type, expectSync ) { - - // Missing expectSync indicates a trigger call, which must force setup through jQuery.event.add - if ( !expectSync ) { - if ( dataPriv.get( el, type ) === undefined ) { - jQuery.event.add( el, type, returnTrue ); - } - return; - } - - // Register the controller as a special universal handler for all event namespaces - dataPriv.set( el, type, false ); - jQuery.event.add( el, type, { - namespace: false, - handler: function( event ) { - var notAsync, result, - saved = dataPriv.get( this, type ); - - if ( ( event.isTrigger & 1 ) && this[ type ] ) { - - // Interrupt processing of the outer synthetic .trigger()ed event - // Saved data should be false in such cases, but might be a leftover capture object - // from an async native handler (gh-4350) - if ( !saved.length ) { - - // Store arguments for use when handling the inner native event - // There will always be at least one argument (an event object), so this array - // will not be confused with a leftover capture object. - saved = slice.call( arguments ); - dataPriv.set( this, type, saved ); - - // Trigger the native event and capture its result - // Support: IE <=9 - 11+ - // focus() and blur() are asynchronous - notAsync = expectSync( this, type ); - this[ type ](); - result = dataPriv.get( this, type ); - if ( saved !== result || notAsync ) { - dataPriv.set( this, type, false ); - } else { - result = {}; - } - if ( saved !== result ) { - - // Cancel the outer synthetic event - event.stopImmediatePropagation(); - event.preventDefault(); - return result.value; - } - - // If this is an inner synthetic event for an event with a bubbling surrogate - // (focus or blur), assume that the surrogate already propagated from triggering the - // native event and prevent that from happening again here. - // This technically gets the ordering wrong w.r.t. to `.trigger()` (in which the - // bubbling surrogate propagates *after* the non-bubbling base), but that seems - // less bad than duplication. - } else if ( ( jQuery.event.special[ type ] || {} ).delegateType ) { - event.stopPropagation(); - } - - // If this is a native event triggered above, everything is now in order - // Fire an inner synthetic event with the original arguments - } else if ( saved.length ) { - - // ...and capture the result - dataPriv.set( this, type, { - value: jQuery.event.trigger( - - // Support: IE <=9 - 11+ - // Extend with the prototype to reset the above stopImmediatePropagation() - jQuery.extend( saved[ 0 ], jQuery.Event.prototype ), - saved.slice( 1 ), - this - ) - } ); - - // Abort handling of the native event - event.stopImmediatePropagation(); - } - } - } ); -} - -jQuery.removeEvent = function( elem, type, handle ) { - - // This "if" is needed for plain objects - if ( elem.removeEventListener ) { - elem.removeEventListener( type, handle ); - } -}; - -jQuery.Event = function( src, props ) { - - // Allow instantiation without the 'new' keyword - if ( !( this instanceof jQuery.Event ) ) { - return new jQuery.Event( src, props ); - } - - // Event object - if ( src && src.type ) { - this.originalEvent = src; - this.type = src.type; - - // Events bubbling up the document may have been marked as prevented - // by a handler lower down the tree; reflect the correct value. - this.isDefaultPrevented = src.defaultPrevented || - src.defaultPrevented === undefined && - - // Support: Android <=2.3 only - src.returnValue === false ? - returnTrue : - returnFalse; - - // Create target properties - // Support: Safari <=6 - 7 only - // Target should not be a text node (#504, #13143) - this.target = ( src.target && src.target.nodeType === 3 ) ? - src.target.parentNode : - src.target; - - this.currentTarget = src.currentTarget; - this.relatedTarget = src.relatedTarget; - - // Event type - } else { - this.type = src; - } - - // Put explicitly provided properties onto the event object - if ( props ) { - jQuery.extend( this, props ); - } - - // Create a timestamp if incoming event doesn't have one - this.timeStamp = src && src.timeStamp || Date.now(); - - // Mark it as fixed - this[ jQuery.expando ] = true; -}; - -// jQuery.Event is based on DOM3 Events as specified by the ECMAScript Language Binding -// https://www.w3.org/TR/2003/WD-DOM-Level-3-Events-20030331/ecma-script-binding.html -jQuery.Event.prototype = { - constructor: jQuery.Event, - isDefaultPrevented: returnFalse, - isPropagationStopped: returnFalse, - isImmediatePropagationStopped: returnFalse, - isSimulated: false, - - preventDefault: function() { - var e = this.originalEvent; - - this.isDefaultPrevented = returnTrue; - - if ( e && !this.isSimulated ) { - e.preventDefault(); - } - }, - stopPropagation: function() { - var e = this.originalEvent; - - this.isPropagationStopped = returnTrue; - - if ( e && !this.isSimulated ) { - e.stopPropagation(); - } - }, - stopImmediatePropagation: function() { - var e = this.originalEvent; - - this.isImmediatePropagationStopped = returnTrue; - - if ( e && !this.isSimulated ) { - e.stopImmediatePropagation(); - } - - this.stopPropagation(); - } -}; - -// Includes all common event props including KeyEvent and MouseEvent specific props -jQuery.each( { - altKey: true, - bubbles: true, - cancelable: true, - changedTouches: true, - ctrlKey: true, - detail: true, - eventPhase: true, - metaKey: true, - pageX: true, - pageY: true, - shiftKey: true, - view: true, - "char": true, - code: true, - charCode: true, - key: true, - keyCode: true, - button: true, - buttons: true, - clientX: true, - clientY: true, - offsetX: true, - offsetY: true, - pointerId: true, - pointerType: true, - screenX: true, - screenY: true, - targetTouches: true, - toElement: true, - touches: true, - - which: function( event ) { - var button = event.button; - - // Add which for key events - if ( event.which == null && rkeyEvent.test( event.type ) ) { - return event.charCode != null ? event.charCode : event.keyCode; - } - - // Add which for click: 1 === left; 2 === middle; 3 === right - if ( !event.which && button !== undefined && rmouseEvent.test( event.type ) ) { - if ( button & 1 ) { - return 1; - } - - if ( button & 2 ) { - return 3; - } - - if ( button & 4 ) { - return 2; - } - - return 0; - } - - return event.which; - } -}, jQuery.event.addProp ); - -jQuery.each( { focus: "focusin", blur: "focusout" }, function( type, delegateType ) { - jQuery.event.special[ type ] = { - - // Utilize native event if possible so blur/focus sequence is correct - setup: function() { - - // Claim the first handler - // dataPriv.set( this, "focus", ... ) - // dataPriv.set( this, "blur", ... ) - leverageNative( this, type, expectSync ); - - // Return false to allow normal processing in the caller - return false; - }, - trigger: function() { - - // Force setup before trigger - leverageNative( this, type ); - - // Return non-false to allow normal event-path propagation - return true; - }, - - delegateType: delegateType - }; -} ); - -// Create mouseenter/leave events using mouseover/out and event-time checks -// so that event delegation works in jQuery. -// Do the same for pointerenter/pointerleave and pointerover/pointerout -// -// Support: Safari 7 only -// Safari sends mouseenter too often; see: -// https://bugs.chromium.org/p/chromium/issues/detail?id=470258 -// for the description of the bug (it existed in older Chrome versions as well). -jQuery.each( { - mouseenter: "mouseover", - mouseleave: "mouseout", - pointerenter: "pointerover", - pointerleave: "pointerout" -}, function( orig, fix ) { - jQuery.event.special[ orig ] = { - delegateType: fix, - bindType: fix, - - handle: function( event ) { - var ret, - target = this, - related = event.relatedTarget, - handleObj = event.handleObj; - - // For mouseenter/leave call the handler if related is outside the target. - // NB: No relatedTarget if the mouse left/entered the browser window - if ( !related || ( related !== target && !jQuery.contains( target, related ) ) ) { - event.type = handleObj.origType; - ret = handleObj.handler.apply( this, arguments ); - event.type = fix; - } - return ret; - } - }; -} ); - -jQuery.fn.extend( { - - on: function( types, selector, data, fn ) { - return on( this, types, selector, data, fn ); - }, - one: function( types, selector, data, fn ) { - return on( this, types, selector, data, fn, 1 ); - }, - off: function( types, selector, fn ) { - var handleObj, type; - if ( types && types.preventDefault && types.handleObj ) { - - // ( event ) dispatched jQuery.Event - handleObj = types.handleObj; - jQuery( types.delegateTarget ).off( - handleObj.namespace ? - handleObj.origType + "." + handleObj.namespace : - handleObj.origType, - handleObj.selector, - handleObj.handler - ); - return this; - } - if ( typeof types === "object" ) { - - // ( types-object [, selector] ) - for ( type in types ) { - this.off( type, selector, types[ type ] ); - } - return this; - } - if ( selector === false || typeof selector === "function" ) { - - // ( types [, fn] ) - fn = selector; - selector = undefined; - } - if ( fn === false ) { - fn = returnFalse; - } - return this.each( function() { - jQuery.event.remove( this, types, fn, selector ); - } ); - } -} ); - - -var - - // Support: IE <=10 - 11, Edge 12 - 13 only - // In IE/Edge using regex groups here causes severe slowdowns. - // See https://connect.microsoft.com/IE/feedback/details/1736512/ - rnoInnerhtml = /\s*$/g; - -// Prefer a tbody over its parent table for containing new rows -function manipulationTarget( elem, content ) { - if ( nodeName( elem, "table" ) && - nodeName( content.nodeType !== 11 ? content : content.firstChild, "tr" ) ) { - - return jQuery( elem ).children( "tbody" )[ 0 ] || elem; - } - - return elem; -} - -// Replace/restore the type attribute of script elements for safe DOM manipulation -function disableScript( elem ) { - elem.type = ( elem.getAttribute( "type" ) !== null ) + "/" + elem.type; - return elem; -} -function restoreScript( elem ) { - if ( ( elem.type || "" ).slice( 0, 5 ) === "true/" ) { - elem.type = elem.type.slice( 5 ); - } else { - elem.removeAttribute( "type" ); - } - - return elem; -} - -function cloneCopyEvent( src, dest ) { - var i, l, type, pdataOld, udataOld, udataCur, events; - - if ( dest.nodeType !== 1 ) { - return; - } - - // 1. Copy private data: events, handlers, etc. - if ( dataPriv.hasData( src ) ) { - pdataOld = dataPriv.get( src ); - events = pdataOld.events; - - if ( events ) { - dataPriv.remove( dest, "handle events" ); - - for ( type in events ) { - for ( i = 0, l = events[ type ].length; i < l; i++ ) { - jQuery.event.add( dest, type, events[ type ][ i ] ); - } - } - } - } - - // 2. Copy user data - if ( dataUser.hasData( src ) ) { - udataOld = dataUser.access( src ); - udataCur = jQuery.extend( {}, udataOld ); - - dataUser.set( dest, udataCur ); - } -} - -// Fix IE bugs, see support tests -function fixInput( src, dest ) { - var nodeName = dest.nodeName.toLowerCase(); - - // Fails to persist the checked state of a cloned checkbox or radio button. - if ( nodeName === "input" && rcheckableType.test( src.type ) ) { - dest.checked = src.checked; - - // Fails to return the selected option to the default selected state when cloning options - } else if ( nodeName === "input" || nodeName === "textarea" ) { - dest.defaultValue = src.defaultValue; - } -} - -function domManip( collection, args, callback, ignored ) { - - // Flatten any nested arrays - args = flat( args ); - - var fragment, first, scripts, hasScripts, node, doc, - i = 0, - l = collection.length, - iNoClone = l - 1, - value = args[ 0 ], - valueIsFunction = isFunction( value ); - - // We can't cloneNode fragments that contain checked, in WebKit - if ( valueIsFunction || - ( l > 1 && typeof value === "string" && - !support.checkClone && rchecked.test( value ) ) ) { - return collection.each( function( index ) { - var self = collection.eq( index ); - if ( valueIsFunction ) { - args[ 0 ] = value.call( this, index, self.html() ); - } - domManip( self, args, callback, ignored ); - } ); - } - - if ( l ) { - fragment = buildFragment( args, collection[ 0 ].ownerDocument, false, collection, ignored ); - first = fragment.firstChild; - - if ( fragment.childNodes.length === 1 ) { - fragment = first; - } - - // Require either new content or an interest in ignored elements to invoke the callback - if ( first || ignored ) { - scripts = jQuery.map( getAll( fragment, "script" ), disableScript ); - hasScripts = scripts.length; - - // Use the original fragment for the last item - // instead of the first because it can end up - // being emptied incorrectly in certain situations (#8070). - for ( ; i < l; i++ ) { - node = fragment; - - if ( i !== iNoClone ) { - node = jQuery.clone( node, true, true ); - - // Keep references to cloned scripts for later restoration - if ( hasScripts ) { - - // Support: Android <=4.0 only, PhantomJS 1 only - // push.apply(_, arraylike) throws on ancient WebKit - jQuery.merge( scripts, getAll( node, "script" ) ); - } - } - - callback.call( collection[ i ], node, i ); - } - - if ( hasScripts ) { - doc = scripts[ scripts.length - 1 ].ownerDocument; - - // Reenable scripts - jQuery.map( scripts, restoreScript ); - - // Evaluate executable scripts on first document insertion - for ( i = 0; i < hasScripts; i++ ) { - node = scripts[ i ]; - if ( rscriptType.test( node.type || "" ) && - !dataPriv.access( node, "globalEval" ) && - jQuery.contains( doc, node ) ) { - - if ( node.src && ( node.type || "" ).toLowerCase() !== "module" ) { - - // Optional AJAX dependency, but won't run scripts if not present - if ( jQuery._evalUrl && !node.noModule ) { - jQuery._evalUrl( node.src, { - nonce: node.nonce || node.getAttribute( "nonce" ) - }, doc ); - } - } else { - DOMEval( node.textContent.replace( rcleanScript, "" ), node, doc ); - } - } - } - } - } - } - - return collection; -} - -function remove( elem, selector, keepData ) { - var node, - nodes = selector ? jQuery.filter( selector, elem ) : elem, - i = 0; - - for ( ; ( node = nodes[ i ] ) != null; i++ ) { - if ( !keepData && node.nodeType === 1 ) { - jQuery.cleanData( getAll( node ) ); - } - - if ( node.parentNode ) { - if ( keepData && isAttached( node ) ) { - setGlobalEval( getAll( node, "script" ) ); - } - node.parentNode.removeChild( node ); - } - } - - return elem; -} - -jQuery.extend( { - htmlPrefilter: function( html ) { - return html; - }, - - clone: function( elem, dataAndEvents, deepDataAndEvents ) { - var i, l, srcElements, destElements, - clone = elem.cloneNode( true ), - inPage = isAttached( elem ); - - // Fix IE cloning issues - if ( !support.noCloneChecked && ( elem.nodeType === 1 || elem.nodeType === 11 ) && - !jQuery.isXMLDoc( elem ) ) { - - // We eschew Sizzle here for performance reasons: https://jsperf.com/getall-vs-sizzle/2 - destElements = getAll( clone ); - srcElements = getAll( elem ); - - for ( i = 0, l = srcElements.length; i < l; i++ ) { - fixInput( srcElements[ i ], destElements[ i ] ); - } - } - - // Copy the events from the original to the clone - if ( dataAndEvents ) { - if ( deepDataAndEvents ) { - srcElements = srcElements || getAll( elem ); - destElements = destElements || getAll( clone ); - - for ( i = 0, l = srcElements.length; i < l; i++ ) { - cloneCopyEvent( srcElements[ i ], destElements[ i ] ); - } - } else { - cloneCopyEvent( elem, clone ); - } - } - - // Preserve script evaluation history - destElements = getAll( clone, "script" ); - if ( destElements.length > 0 ) { - setGlobalEval( destElements, !inPage && getAll( elem, "script" ) ); - } - - // Return the cloned set - return clone; - }, - - cleanData: function( elems ) { - var data, elem, type, - special = jQuery.event.special, - i = 0; - - for ( ; ( elem = elems[ i ] ) !== undefined; i++ ) { - if ( acceptData( elem ) ) { - if ( ( data = elem[ dataPriv.expando ] ) ) { - if ( data.events ) { - for ( type in data.events ) { - if ( special[ type ] ) { - jQuery.event.remove( elem, type ); - - // This is a shortcut to avoid jQuery.event.remove's overhead - } else { - jQuery.removeEvent( elem, type, data.handle ); - } - } - } - - // Support: Chrome <=35 - 45+ - // Assign undefined instead of using delete, see Data#remove - elem[ dataPriv.expando ] = undefined; - } - if ( elem[ dataUser.expando ] ) { - - // Support: Chrome <=35 - 45+ - // Assign undefined instead of using delete, see Data#remove - elem[ dataUser.expando ] = undefined; - } - } - } - } -} ); - -jQuery.fn.extend( { - detach: function( selector ) { - return remove( this, selector, true ); - }, - - remove: function( selector ) { - return remove( this, selector ); - }, - - text: function( value ) { - return access( this, function( value ) { - return value === undefined ? - jQuery.text( this ) : - this.empty().each( function() { - if ( this.nodeType === 1 || this.nodeType === 11 || this.nodeType === 9 ) { - this.textContent = value; - } - } ); - }, null, value, arguments.length ); - }, - - append: function() { - return domManip( this, arguments, function( elem ) { - if ( this.nodeType === 1 || this.nodeType === 11 || this.nodeType === 9 ) { - var target = manipulationTarget( this, elem ); - target.appendChild( elem ); - } - } ); - }, - - prepend: function() { - return domManip( this, arguments, function( elem ) { - if ( this.nodeType === 1 || this.nodeType === 11 || this.nodeType === 9 ) { - var target = manipulationTarget( this, elem ); - target.insertBefore( elem, target.firstChild ); - } - } ); - }, - - before: function() { - return domManip( this, arguments, function( elem ) { - if ( this.parentNode ) { - this.parentNode.insertBefore( elem, this ); - } - } ); - }, - - after: function() { - return domManip( this, arguments, function( elem ) { - if ( this.parentNode ) { - this.parentNode.insertBefore( elem, this.nextSibling ); - } - } ); - }, - - empty: function() { - var elem, - i = 0; - - for ( ; ( elem = this[ i ] ) != null; i++ ) { - if ( elem.nodeType === 1 ) { - - // Prevent memory leaks - jQuery.cleanData( getAll( elem, false ) ); - - // Remove any remaining nodes - elem.textContent = ""; - } - } - - return this; - }, - - clone: function( dataAndEvents, deepDataAndEvents ) { - dataAndEvents = dataAndEvents == null ? false : dataAndEvents; - deepDataAndEvents = deepDataAndEvents == null ? dataAndEvents : deepDataAndEvents; - - return this.map( function() { - return jQuery.clone( this, dataAndEvents, deepDataAndEvents ); - } ); - }, - - html: function( value ) { - return access( this, function( value ) { - var elem = this[ 0 ] || {}, - i = 0, - l = this.length; - - if ( value === undefined && elem.nodeType === 1 ) { - return elem.innerHTML; - } - - // See if we can take a shortcut and just use innerHTML - if ( typeof value === "string" && !rnoInnerhtml.test( value ) && - !wrapMap[ ( rtagName.exec( value ) || [ "", "" ] )[ 1 ].toLowerCase() ] ) { - - value = jQuery.htmlPrefilter( value ); - - try { - for ( ; i < l; i++ ) { - elem = this[ i ] || {}; - - // Remove element nodes and prevent memory leaks - if ( elem.nodeType === 1 ) { - jQuery.cleanData( getAll( elem, false ) ); - elem.innerHTML = value; - } - } - - elem = 0; - - // If using innerHTML throws an exception, use the fallback method - } catch ( e ) {} - } - - if ( elem ) { - this.empty().append( value ); - } - }, null, value, arguments.length ); - }, - - replaceWith: function() { - var ignored = []; - - // Make the changes, replacing each non-ignored context element with the new content - return domManip( this, arguments, function( elem ) { - var parent = this.parentNode; - - if ( jQuery.inArray( this, ignored ) < 0 ) { - jQuery.cleanData( getAll( this ) ); - if ( parent ) { - parent.replaceChild( elem, this ); - } - } - - // Force callback invocation - }, ignored ); - } -} ); - -jQuery.each( { - appendTo: "append", - prependTo: "prepend", - insertBefore: "before", - insertAfter: "after", - replaceAll: "replaceWith" -}, function( name, original ) { - jQuery.fn[ name ] = function( selector ) { - var elems, - ret = [], - insert = jQuery( selector ), - last = insert.length - 1, - i = 0; - - for ( ; i <= last; i++ ) { - elems = i === last ? this : this.clone( true ); - jQuery( insert[ i ] )[ original ]( elems ); - - // Support: Android <=4.0 only, PhantomJS 1 only - // .get() because push.apply(_, arraylike) throws on ancient WebKit - push.apply( ret, elems.get() ); - } - - return this.pushStack( ret ); - }; -} ); -var rnumnonpx = new RegExp( "^(" + pnum + ")(?!px)[a-z%]+$", "i" ); - -var getStyles = function( elem ) { - - // Support: IE <=11 only, Firefox <=30 (#15098, #14150) - // IE throws on elements created in popups - // FF meanwhile throws on frame elements through "defaultView.getComputedStyle" - var view = elem.ownerDocument.defaultView; - - if ( !view || !view.opener ) { - view = window; - } - - return view.getComputedStyle( elem ); - }; - -var swap = function( elem, options, callback ) { - var ret, name, - old = {}; - - // Remember the old values, and insert the new ones - for ( name in options ) { - old[ name ] = elem.style[ name ]; - elem.style[ name ] = options[ name ]; - } - - ret = callback.call( elem ); - - // Revert the old values - for ( name in options ) { - elem.style[ name ] = old[ name ]; - } - - return ret; -}; - - -var rboxStyle = new RegExp( cssExpand.join( "|" ), "i" ); - - - -( function() { - - // Executing both pixelPosition & boxSizingReliable tests require only one layout - // so they're executed at the same time to save the second computation. - function computeStyleTests() { - - // This is a singleton, we need to execute it only once - if ( !div ) { - return; - } - - container.style.cssText = "position:absolute;left:-11111px;width:60px;" + - "margin-top:1px;padding:0;border:0"; - div.style.cssText = - "position:relative;display:block;box-sizing:border-box;overflow:scroll;" + - "margin:auto;border:1px;padding:1px;" + - "width:60%;top:1%"; - documentElement.appendChild( container ).appendChild( div ); - - var divStyle = window.getComputedStyle( div ); - pixelPositionVal = divStyle.top !== "1%"; - - // Support: Android 4.0 - 4.3 only, Firefox <=3 - 44 - reliableMarginLeftVal = roundPixelMeasures( divStyle.marginLeft ) === 12; - - // Support: Android 4.0 - 4.3 only, Safari <=9.1 - 10.1, iOS <=7.0 - 9.3 - // Some styles come back with percentage values, even though they shouldn't - div.style.right = "60%"; - pixelBoxStylesVal = roundPixelMeasures( divStyle.right ) === 36; - - // Support: IE 9 - 11 only - // Detect misreporting of content dimensions for box-sizing:border-box elements - boxSizingReliableVal = roundPixelMeasures( divStyle.width ) === 36; - - // Support: IE 9 only - // Detect overflow:scroll screwiness (gh-3699) - // Support: Chrome <=64 - // Don't get tricked when zoom affects offsetWidth (gh-4029) - div.style.position = "absolute"; - scrollboxSizeVal = roundPixelMeasures( div.offsetWidth / 3 ) === 12; - - documentElement.removeChild( container ); - - // Nullify the div so it wouldn't be stored in the memory and - // it will also be a sign that checks already performed - div = null; - } - - function roundPixelMeasures( measure ) { - return Math.round( parseFloat( measure ) ); - } - - var pixelPositionVal, boxSizingReliableVal, scrollboxSizeVal, pixelBoxStylesVal, - reliableTrDimensionsVal, reliableMarginLeftVal, - container = document.createElement( "div" ), - div = document.createElement( "div" ); - - // Finish early in limited (non-browser) environments - if ( !div.style ) { - return; - } - - // Support: IE <=9 - 11 only - // Style of cloned element affects source element cloned (#8908) - div.style.backgroundClip = "content-box"; - div.cloneNode( true ).style.backgroundClip = ""; - support.clearCloneStyle = div.style.backgroundClip === "content-box"; - - jQuery.extend( support, { - boxSizingReliable: function() { - computeStyleTests(); - return boxSizingReliableVal; - }, - pixelBoxStyles: function() { - computeStyleTests(); - return pixelBoxStylesVal; - }, - pixelPosition: function() { - computeStyleTests(); - return pixelPositionVal; - }, - reliableMarginLeft: function() { - computeStyleTests(); - return reliableMarginLeftVal; - }, - scrollboxSize: function() { - computeStyleTests(); - return scrollboxSizeVal; - }, - - // Support: IE 9 - 11+, Edge 15 - 18+ - // IE/Edge misreport `getComputedStyle` of table rows with width/height - // set in CSS while `offset*` properties report correct values. - // Behavior in IE 9 is more subtle than in newer versions & it passes - // some versions of this test; make sure not to make it pass there! - reliableTrDimensions: function() { - var table, tr, trChild, trStyle; - if ( reliableTrDimensionsVal == null ) { - table = document.createElement( "table" ); - tr = document.createElement( "tr" ); - trChild = document.createElement( "div" ); - - table.style.cssText = "position:absolute;left:-11111px"; - tr.style.height = "1px"; - trChild.style.height = "9px"; - - documentElement - .appendChild( table ) - .appendChild( tr ) - .appendChild( trChild ); - - trStyle = window.getComputedStyle( tr ); - reliableTrDimensionsVal = parseInt( trStyle.height ) > 3; - - documentElement.removeChild( table ); - } - return reliableTrDimensionsVal; - } - } ); -} )(); - - -function curCSS( elem, name, computed ) { - var width, minWidth, maxWidth, ret, - - // Support: Firefox 51+ - // Retrieving style before computed somehow - // fixes an issue with getting wrong values - // on detached elements - style = elem.style; - - computed = computed || getStyles( elem ); - - // getPropertyValue is needed for: - // .css('filter') (IE 9 only, #12537) - // .css('--customProperty) (#3144) - if ( computed ) { - ret = computed.getPropertyValue( name ) || computed[ name ]; - - if ( ret === "" && !isAttached( elem ) ) { - ret = jQuery.style( elem, name ); - } - - // A tribute to the "awesome hack by Dean Edwards" - // Android Browser returns percentage for some values, - // but width seems to be reliably pixels. - // This is against the CSSOM draft spec: - // https://drafts.csswg.org/cssom/#resolved-values - if ( !support.pixelBoxStyles() && rnumnonpx.test( ret ) && rboxStyle.test( name ) ) { - - // Remember the original values - width = style.width; - minWidth = style.minWidth; - maxWidth = style.maxWidth; - - // Put in the new values to get a computed value out - style.minWidth = style.maxWidth = style.width = ret; - ret = computed.width; - - // Revert the changed values - style.width = width; - style.minWidth = minWidth; - style.maxWidth = maxWidth; - } - } - - return ret !== undefined ? - - // Support: IE <=9 - 11 only - // IE returns zIndex value as an integer. - ret + "" : - ret; -} - - -function addGetHookIf( conditionFn, hookFn ) { - - // Define the hook, we'll check on the first run if it's really needed. - return { - get: function() { - if ( conditionFn() ) { - - // Hook not needed (or it's not possible to use it due - // to missing dependency), remove it. - delete this.get; - return; - } - - // Hook needed; redefine it so that the support test is not executed again. - return ( this.get = hookFn ).apply( this, arguments ); - } - }; -} - - -var cssPrefixes = [ "Webkit", "Moz", "ms" ], - emptyStyle = document.createElement( "div" ).style, - vendorProps = {}; - -// Return a vendor-prefixed property or undefined -function vendorPropName( name ) { - - // Check for vendor prefixed names - var capName = name[ 0 ].toUpperCase() + name.slice( 1 ), - i = cssPrefixes.length; - - while ( i-- ) { - name = cssPrefixes[ i ] + capName; - if ( name in emptyStyle ) { - return name; - } - } -} - -// Return a potentially-mapped jQuery.cssProps or vendor prefixed property -function finalPropName( name ) { - var final = jQuery.cssProps[ name ] || vendorProps[ name ]; - - if ( final ) { - return final; - } - if ( name in emptyStyle ) { - return name; - } - return vendorProps[ name ] = vendorPropName( name ) || name; -} - - -var - - // Swappable if display is none or starts with table - // except "table", "table-cell", or "table-caption" - // See here for display values: https://developer.mozilla.org/en-US/docs/CSS/display - rdisplayswap = /^(none|table(?!-c[ea]).+)/, - rcustomProp = /^--/, - cssShow = { position: "absolute", visibility: "hidden", display: "block" }, - cssNormalTransform = { - letterSpacing: "0", - fontWeight: "400" - }; - -function setPositiveNumber( _elem, value, subtract ) { - - // Any relative (+/-) values have already been - // normalized at this point - var matches = rcssNum.exec( value ); - return matches ? - - // Guard against undefined "subtract", e.g., when used as in cssHooks - Math.max( 0, matches[ 2 ] - ( subtract || 0 ) ) + ( matches[ 3 ] || "px" ) : - value; -} - -function boxModelAdjustment( elem, dimension, box, isBorderBox, styles, computedVal ) { - var i = dimension === "width" ? 1 : 0, - extra = 0, - delta = 0; - - // Adjustment may not be necessary - if ( box === ( isBorderBox ? "border" : "content" ) ) { - return 0; - } - - for ( ; i < 4; i += 2 ) { - - // Both box models exclude margin - if ( box === "margin" ) { - delta += jQuery.css( elem, box + cssExpand[ i ], true, styles ); - } - - // If we get here with a content-box, we're seeking "padding" or "border" or "margin" - if ( !isBorderBox ) { - - // Add padding - delta += jQuery.css( elem, "padding" + cssExpand[ i ], true, styles ); - - // For "border" or "margin", add border - if ( box !== "padding" ) { - delta += jQuery.css( elem, "border" + cssExpand[ i ] + "Width", true, styles ); - - // But still keep track of it otherwise - } else { - extra += jQuery.css( elem, "border" + cssExpand[ i ] + "Width", true, styles ); - } - - // If we get here with a border-box (content + padding + border), we're seeking "content" or - // "padding" or "margin" - } else { - - // For "content", subtract padding - if ( box === "content" ) { - delta -= jQuery.css( elem, "padding" + cssExpand[ i ], true, styles ); - } - - // For "content" or "padding", subtract border - if ( box !== "margin" ) { - delta -= jQuery.css( elem, "border" + cssExpand[ i ] + "Width", true, styles ); - } - } - } - - // Account for positive content-box scroll gutter when requested by providing computedVal - if ( !isBorderBox && computedVal >= 0 ) { - - // offsetWidth/offsetHeight is a rounded sum of content, padding, scroll gutter, and border - // Assuming integer scroll gutter, subtract the rest and round down - delta += Math.max( 0, Math.ceil( - elem[ "offset" + dimension[ 0 ].toUpperCase() + dimension.slice( 1 ) ] - - computedVal - - delta - - extra - - 0.5 - - // If offsetWidth/offsetHeight is unknown, then we can't determine content-box scroll gutter - // Use an explicit zero to avoid NaN (gh-3964) - ) ) || 0; - } - - return delta; -} - -function getWidthOrHeight( elem, dimension, extra ) { - - // Start with computed style - var styles = getStyles( elem ), - - // To avoid forcing a reflow, only fetch boxSizing if we need it (gh-4322). - // Fake content-box until we know it's needed to know the true value. - boxSizingNeeded = !support.boxSizingReliable() || extra, - isBorderBox = boxSizingNeeded && - jQuery.css( elem, "boxSizing", false, styles ) === "border-box", - valueIsBorderBox = isBorderBox, - - val = curCSS( elem, dimension, styles ), - offsetProp = "offset" + dimension[ 0 ].toUpperCase() + dimension.slice( 1 ); - - // Support: Firefox <=54 - // Return a confounding non-pixel value or feign ignorance, as appropriate. - if ( rnumnonpx.test( val ) ) { - if ( !extra ) { - return val; - } - val = "auto"; - } - - - // Support: IE 9 - 11 only - // Use offsetWidth/offsetHeight for when box sizing is unreliable. - // In those cases, the computed value can be trusted to be border-box. - if ( ( !support.boxSizingReliable() && isBorderBox || - - // Support: IE 10 - 11+, Edge 15 - 18+ - // IE/Edge misreport `getComputedStyle` of table rows with width/height - // set in CSS while `offset*` properties report correct values. - // Interestingly, in some cases IE 9 doesn't suffer from this issue. - !support.reliableTrDimensions() && nodeName( elem, "tr" ) || - - // Fall back to offsetWidth/offsetHeight when value is "auto" - // This happens for inline elements with no explicit setting (gh-3571) - val === "auto" || - - // Support: Android <=4.1 - 4.3 only - // Also use offsetWidth/offsetHeight for misreported inline dimensions (gh-3602) - !parseFloat( val ) && jQuery.css( elem, "display", false, styles ) === "inline" ) && - - // Make sure the element is visible & connected - elem.getClientRects().length ) { - - isBorderBox = jQuery.css( elem, "boxSizing", false, styles ) === "border-box"; - - // Where available, offsetWidth/offsetHeight approximate border box dimensions. - // Where not available (e.g., SVG), assume unreliable box-sizing and interpret the - // retrieved value as a content box dimension. - valueIsBorderBox = offsetProp in elem; - if ( valueIsBorderBox ) { - val = elem[ offsetProp ]; - } - } - - // Normalize "" and auto - val = parseFloat( val ) || 0; - - // Adjust for the element's box model - return ( val + - boxModelAdjustment( - elem, - dimension, - extra || ( isBorderBox ? "border" : "content" ), - valueIsBorderBox, - styles, - - // Provide the current computed size to request scroll gutter calculation (gh-3589) - val - ) - ) + "px"; -} - -jQuery.extend( { - - // Add in style property hooks for overriding the default - // behavior of getting and setting a style property - cssHooks: { - opacity: { - get: function( elem, computed ) { - if ( computed ) { - - // We should always get a number back from opacity - var ret = curCSS( elem, "opacity" ); - return ret === "" ? "1" : ret; - } - } - } - }, - - // Don't automatically add "px" to these possibly-unitless properties - cssNumber: { - "animationIterationCount": true, - "columnCount": true, - "fillOpacity": true, - "flexGrow": true, - "flexShrink": true, - "fontWeight": true, - "gridArea": true, - "gridColumn": true, - "gridColumnEnd": true, - "gridColumnStart": true, - "gridRow": true, - "gridRowEnd": true, - "gridRowStart": true, - "lineHeight": true, - "opacity": true, - "order": true, - "orphans": true, - "widows": true, - "zIndex": true, - "zoom": true - }, - - // Add in properties whose names you wish to fix before - // setting or getting the value - cssProps: {}, - - // Get and set the style property on a DOM Node - style: function( elem, name, value, extra ) { - - // Don't set styles on text and comment nodes - if ( !elem || elem.nodeType === 3 || elem.nodeType === 8 || !elem.style ) { - return; - } - - // Make sure that we're working with the right name - var ret, type, hooks, - origName = camelCase( name ), - isCustomProp = rcustomProp.test( name ), - style = elem.style; - - // Make sure that we're working with the right name. We don't - // want to query the value if it is a CSS custom property - // since they are user-defined. - if ( !isCustomProp ) { - name = finalPropName( origName ); - } - - // Gets hook for the prefixed version, then unprefixed version - hooks = jQuery.cssHooks[ name ] || jQuery.cssHooks[ origName ]; - - // Check if we're setting a value - if ( value !== undefined ) { - type = typeof value; - - // Convert "+=" or "-=" to relative numbers (#7345) - if ( type === "string" && ( ret = rcssNum.exec( value ) ) && ret[ 1 ] ) { - value = adjustCSS( elem, name, ret ); - - // Fixes bug #9237 - type = "number"; - } - - // Make sure that null and NaN values aren't set (#7116) - if ( value == null || value !== value ) { - return; - } - - // If a number was passed in, add the unit (except for certain CSS properties) - // The isCustomProp check can be removed in jQuery 4.0 when we only auto-append - // "px" to a few hardcoded values. - if ( type === "number" && !isCustomProp ) { - value += ret && ret[ 3 ] || ( jQuery.cssNumber[ origName ] ? "" : "px" ); - } - - // background-* props affect original clone's values - if ( !support.clearCloneStyle && value === "" && name.indexOf( "background" ) === 0 ) { - style[ name ] = "inherit"; - } - - // If a hook was provided, use that value, otherwise just set the specified value - if ( !hooks || !( "set" in hooks ) || - ( value = hooks.set( elem, value, extra ) ) !== undefined ) { - - if ( isCustomProp ) { - style.setProperty( name, value ); - } else { - style[ name ] = value; - } - } - - } else { - - // If a hook was provided get the non-computed value from there - if ( hooks && "get" in hooks && - ( ret = hooks.get( elem, false, extra ) ) !== undefined ) { - - return ret; - } - - // Otherwise just get the value from the style object - return style[ name ]; - } - }, - - css: function( elem, name, extra, styles ) { - var val, num, hooks, - origName = camelCase( name ), - isCustomProp = rcustomProp.test( name ); - - // Make sure that we're working with the right name. We don't - // want to modify the value if it is a CSS custom property - // since they are user-defined. - if ( !isCustomProp ) { - name = finalPropName( origName ); - } - - // Try prefixed name followed by the unprefixed name - hooks = jQuery.cssHooks[ name ] || jQuery.cssHooks[ origName ]; - - // If a hook was provided get the computed value from there - if ( hooks && "get" in hooks ) { - val = hooks.get( elem, true, extra ); - } - - // Otherwise, if a way to get the computed value exists, use that - if ( val === undefined ) { - val = curCSS( elem, name, styles ); - } - - // Convert "normal" to computed value - if ( val === "normal" && name in cssNormalTransform ) { - val = cssNormalTransform[ name ]; - } - - // Make numeric if forced or a qualifier was provided and val looks numeric - if ( extra === "" || extra ) { - num = parseFloat( val ); - return extra === true || isFinite( num ) ? num || 0 : val; - } - - return val; - } -} ); - -jQuery.each( [ "height", "width" ], function( _i, dimension ) { - jQuery.cssHooks[ dimension ] = { - get: function( elem, computed, extra ) { - if ( computed ) { - - // Certain elements can have dimension info if we invisibly show them - // but it must have a current display style that would benefit - return rdisplayswap.test( jQuery.css( elem, "display" ) ) && - - // Support: Safari 8+ - // Table columns in Safari have non-zero offsetWidth & zero - // getBoundingClientRect().width unless display is changed. - // Support: IE <=11 only - // Running getBoundingClientRect on a disconnected node - // in IE throws an error. - ( !elem.getClientRects().length || !elem.getBoundingClientRect().width ) ? - swap( elem, cssShow, function() { - return getWidthOrHeight( elem, dimension, extra ); - } ) : - getWidthOrHeight( elem, dimension, extra ); - } - }, - - set: function( elem, value, extra ) { - var matches, - styles = getStyles( elem ), - - // Only read styles.position if the test has a chance to fail - // to avoid forcing a reflow. - scrollboxSizeBuggy = !support.scrollboxSize() && - styles.position === "absolute", - - // To avoid forcing a reflow, only fetch boxSizing if we need it (gh-3991) - boxSizingNeeded = scrollboxSizeBuggy || extra, - isBorderBox = boxSizingNeeded && - jQuery.css( elem, "boxSizing", false, styles ) === "border-box", - subtract = extra ? - boxModelAdjustment( - elem, - dimension, - extra, - isBorderBox, - styles - ) : - 0; - - // Account for unreliable border-box dimensions by comparing offset* to computed and - // faking a content-box to get border and padding (gh-3699) - if ( isBorderBox && scrollboxSizeBuggy ) { - subtract -= Math.ceil( - elem[ "offset" + dimension[ 0 ].toUpperCase() + dimension.slice( 1 ) ] - - parseFloat( styles[ dimension ] ) - - boxModelAdjustment( elem, dimension, "border", false, styles ) - - 0.5 - ); - } - - // Convert to pixels if value adjustment is needed - if ( subtract && ( matches = rcssNum.exec( value ) ) && - ( matches[ 3 ] || "px" ) !== "px" ) { - - elem.style[ dimension ] = value; - value = jQuery.css( elem, dimension ); - } - - return setPositiveNumber( elem, value, subtract ); - } - }; -} ); - -jQuery.cssHooks.marginLeft = addGetHookIf( support.reliableMarginLeft, - function( elem, computed ) { - if ( computed ) { - return ( parseFloat( curCSS( elem, "marginLeft" ) ) || - elem.getBoundingClientRect().left - - swap( elem, { marginLeft: 0 }, function() { - return elem.getBoundingClientRect().left; - } ) - ) + "px"; - } - } -); - -// These hooks are used by animate to expand properties -jQuery.each( { - margin: "", - padding: "", - border: "Width" -}, function( prefix, suffix ) { - jQuery.cssHooks[ prefix + suffix ] = { - expand: function( value ) { - var i = 0, - expanded = {}, - - // Assumes a single number if not a string - parts = typeof value === "string" ? value.split( " " ) : [ value ]; - - for ( ; i < 4; i++ ) { - expanded[ prefix + cssExpand[ i ] + suffix ] = - parts[ i ] || parts[ i - 2 ] || parts[ 0 ]; - } - - return expanded; - } - }; - - if ( prefix !== "margin" ) { - jQuery.cssHooks[ prefix + suffix ].set = setPositiveNumber; - } -} ); - -jQuery.fn.extend( { - css: function( name, value ) { - return access( this, function( elem, name, value ) { - var styles, len, - map = {}, - i = 0; - - if ( Array.isArray( name ) ) { - styles = getStyles( elem ); - len = name.length; - - for ( ; i < len; i++ ) { - map[ name[ i ] ] = jQuery.css( elem, name[ i ], false, styles ); - } - - return map; - } - - return value !== undefined ? - jQuery.style( elem, name, value ) : - jQuery.css( elem, name ); - }, name, value, arguments.length > 1 ); - } -} ); - - -function Tween( elem, options, prop, end, easing ) { - return new Tween.prototype.init( elem, options, prop, end, easing ); -} -jQuery.Tween = Tween; - -Tween.prototype = { - constructor: Tween, - init: function( elem, options, prop, end, easing, unit ) { - this.elem = elem; - this.prop = prop; - this.easing = easing || jQuery.easing._default; - this.options = options; - this.start = this.now = this.cur(); - this.end = end; - this.unit = unit || ( jQuery.cssNumber[ prop ] ? "" : "px" ); - }, - cur: function() { - var hooks = Tween.propHooks[ this.prop ]; - - return hooks && hooks.get ? - hooks.get( this ) : - Tween.propHooks._default.get( this ); - }, - run: function( percent ) { - var eased, - hooks = Tween.propHooks[ this.prop ]; - - if ( this.options.duration ) { - this.pos = eased = jQuery.easing[ this.easing ]( - percent, this.options.duration * percent, 0, 1, this.options.duration - ); - } else { - this.pos = eased = percent; - } - this.now = ( this.end - this.start ) * eased + this.start; - - if ( this.options.step ) { - this.options.step.call( this.elem, this.now, this ); - } - - if ( hooks && hooks.set ) { - hooks.set( this ); - } else { - Tween.propHooks._default.set( this ); - } - return this; - } -}; - -Tween.prototype.init.prototype = Tween.prototype; - -Tween.propHooks = { - _default: { - get: function( tween ) { - var result; - - // Use a property on the element directly when it is not a DOM element, - // or when there is no matching style property that exists. - if ( tween.elem.nodeType !== 1 || - tween.elem[ tween.prop ] != null && tween.elem.style[ tween.prop ] == null ) { - return tween.elem[ tween.prop ]; - } - - // Passing an empty string as a 3rd parameter to .css will automatically - // attempt a parseFloat and fallback to a string if the parse fails. - // Simple values such as "10px" are parsed to Float; - // complex values such as "rotate(1rad)" are returned as-is. - result = jQuery.css( tween.elem, tween.prop, "" ); - - // Empty strings, null, undefined and "auto" are converted to 0. - return !result || result === "auto" ? 0 : result; - }, - set: function( tween ) { - - // Use step hook for back compat. - // Use cssHook if its there. - // Use .style if available and use plain properties where available. - if ( jQuery.fx.step[ tween.prop ] ) { - jQuery.fx.step[ tween.prop ]( tween ); - } else if ( tween.elem.nodeType === 1 && ( - jQuery.cssHooks[ tween.prop ] || - tween.elem.style[ finalPropName( tween.prop ) ] != null ) ) { - jQuery.style( tween.elem, tween.prop, tween.now + tween.unit ); - } else { - tween.elem[ tween.prop ] = tween.now; - } - } - } -}; - -// Support: IE <=9 only -// Panic based approach to setting things on disconnected nodes -Tween.propHooks.scrollTop = Tween.propHooks.scrollLeft = { - set: function( tween ) { - if ( tween.elem.nodeType && tween.elem.parentNode ) { - tween.elem[ tween.prop ] = tween.now; - } - } -}; - -jQuery.easing = { - linear: function( p ) { - return p; - }, - swing: function( p ) { - return 0.5 - Math.cos( p * Math.PI ) / 2; - }, - _default: "swing" -}; - -jQuery.fx = Tween.prototype.init; - -// Back compat <1.8 extension point -jQuery.fx.step = {}; - - - - -var - fxNow, inProgress, - rfxtypes = /^(?:toggle|show|hide)$/, - rrun = /queueHooks$/; - -function schedule() { - if ( inProgress ) { - if ( document.hidden === false && window.requestAnimationFrame ) { - window.requestAnimationFrame( schedule ); - } else { - window.setTimeout( schedule, jQuery.fx.interval ); - } - - jQuery.fx.tick(); - } -} - -// Animations created synchronously will run synchronously -function createFxNow() { - window.setTimeout( function() { - fxNow = undefined; - } ); - return ( fxNow = Date.now() ); -} - -// Generate parameters to create a standard animation -function genFx( type, includeWidth ) { - var which, - i = 0, - attrs = { height: type }; - - // If we include width, step value is 1 to do all cssExpand values, - // otherwise step value is 2 to skip over Left and Right - includeWidth = includeWidth ? 1 : 0; - for ( ; i < 4; i += 2 - includeWidth ) { - which = cssExpand[ i ]; - attrs[ "margin" + which ] = attrs[ "padding" + which ] = type; - } - - if ( includeWidth ) { - attrs.opacity = attrs.width = type; - } - - return attrs; -} - -function createTween( value, prop, animation ) { - var tween, - collection = ( Animation.tweeners[ prop ] || [] ).concat( Animation.tweeners[ "*" ] ), - index = 0, - length = collection.length; - for ( ; index < length; index++ ) { - if ( ( tween = collection[ index ].call( animation, prop, value ) ) ) { - - // We're done with this property - return tween; - } - } -} - -function defaultPrefilter( elem, props, opts ) { - var prop, value, toggle, hooks, oldfire, propTween, restoreDisplay, display, - isBox = "width" in props || "height" in props, - anim = this, - orig = {}, - style = elem.style, - hidden = elem.nodeType && isHiddenWithinTree( elem ), - dataShow = dataPriv.get( elem, "fxshow" ); - - // Queue-skipping animations hijack the fx hooks - if ( !opts.queue ) { - hooks = jQuery._queueHooks( elem, "fx" ); - if ( hooks.unqueued == null ) { - hooks.unqueued = 0; - oldfire = hooks.empty.fire; - hooks.empty.fire = function() { - if ( !hooks.unqueued ) { - oldfire(); - } - }; - } - hooks.unqueued++; - - anim.always( function() { - - // Ensure the complete handler is called before this completes - anim.always( function() { - hooks.unqueued--; - if ( !jQuery.queue( elem, "fx" ).length ) { - hooks.empty.fire(); - } - } ); - } ); - } - - // Detect show/hide animations - for ( prop in props ) { - value = props[ prop ]; - if ( rfxtypes.test( value ) ) { - delete props[ prop ]; - toggle = toggle || value === "toggle"; - if ( value === ( hidden ? "hide" : "show" ) ) { - - // Pretend to be hidden if this is a "show" and - // there is still data from a stopped show/hide - if ( value === "show" && dataShow && dataShow[ prop ] !== undefined ) { - hidden = true; - - // Ignore all other no-op show/hide data - } else { - continue; - } - } - orig[ prop ] = dataShow && dataShow[ prop ] || jQuery.style( elem, prop ); - } - } - - // Bail out if this is a no-op like .hide().hide() - propTween = !jQuery.isEmptyObject( props ); - if ( !propTween && jQuery.isEmptyObject( orig ) ) { - return; - } - - // Restrict "overflow" and "display" styles during box animations - if ( isBox && elem.nodeType === 1 ) { - - // Support: IE <=9 - 11, Edge 12 - 15 - // Record all 3 overflow attributes because IE does not infer the shorthand - // from identically-valued overflowX and overflowY and Edge just mirrors - // the overflowX value there. - opts.overflow = [ style.overflow, style.overflowX, style.overflowY ]; - - // Identify a display type, preferring old show/hide data over the CSS cascade - restoreDisplay = dataShow && dataShow.display; - if ( restoreDisplay == null ) { - restoreDisplay = dataPriv.get( elem, "display" ); - } - display = jQuery.css( elem, "display" ); - if ( display === "none" ) { - if ( restoreDisplay ) { - display = restoreDisplay; - } else { - - // Get nonempty value(s) by temporarily forcing visibility - showHide( [ elem ], true ); - restoreDisplay = elem.style.display || restoreDisplay; - display = jQuery.css( elem, "display" ); - showHide( [ elem ] ); - } - } - - // Animate inline elements as inline-block - if ( display === "inline" || display === "inline-block" && restoreDisplay != null ) { - if ( jQuery.css( elem, "float" ) === "none" ) { - - // Restore the original display value at the end of pure show/hide animations - if ( !propTween ) { - anim.done( function() { - style.display = restoreDisplay; - } ); - if ( restoreDisplay == null ) { - display = style.display; - restoreDisplay = display === "none" ? "" : display; - } - } - style.display = "inline-block"; - } - } - } - - if ( opts.overflow ) { - style.overflow = "hidden"; - anim.always( function() { - style.overflow = opts.overflow[ 0 ]; - style.overflowX = opts.overflow[ 1 ]; - style.overflowY = opts.overflow[ 2 ]; - } ); - } - - // Implement show/hide animations - propTween = false; - for ( prop in orig ) { - - // General show/hide setup for this element animation - if ( !propTween ) { - if ( dataShow ) { - if ( "hidden" in dataShow ) { - hidden = dataShow.hidden; - } - } else { - dataShow = dataPriv.access( elem, "fxshow", { display: restoreDisplay } ); - } - - // Store hidden/visible for toggle so `.stop().toggle()` "reverses" - if ( toggle ) { - dataShow.hidden = !hidden; - } - - // Show elements before animating them - if ( hidden ) { - showHide( [ elem ], true ); - } - - /* eslint-disable no-loop-func */ - - anim.done( function() { - - /* eslint-enable no-loop-func */ - - // The final step of a "hide" animation is actually hiding the element - if ( !hidden ) { - showHide( [ elem ] ); - } - dataPriv.remove( elem, "fxshow" ); - for ( prop in orig ) { - jQuery.style( elem, prop, orig[ prop ] ); - } - } ); - } - - // Per-property setup - propTween = createTween( hidden ? dataShow[ prop ] : 0, prop, anim ); - if ( !( prop in dataShow ) ) { - dataShow[ prop ] = propTween.start; - if ( hidden ) { - propTween.end = propTween.start; - propTween.start = 0; - } - } - } -} - -function propFilter( props, specialEasing ) { - var index, name, easing, value, hooks; - - // camelCase, specialEasing and expand cssHook pass - for ( index in props ) { - name = camelCase( index ); - easing = specialEasing[ name ]; - value = props[ index ]; - if ( Array.isArray( value ) ) { - easing = value[ 1 ]; - value = props[ index ] = value[ 0 ]; - } - - if ( index !== name ) { - props[ name ] = value; - delete props[ index ]; - } - - hooks = jQuery.cssHooks[ name ]; - if ( hooks && "expand" in hooks ) { - value = hooks.expand( value ); - delete props[ name ]; - - // Not quite $.extend, this won't overwrite existing keys. - // Reusing 'index' because we have the correct "name" - for ( index in value ) { - if ( !( index in props ) ) { - props[ index ] = value[ index ]; - specialEasing[ index ] = easing; - } - } - } else { - specialEasing[ name ] = easing; - } - } -} - -function Animation( elem, properties, options ) { - var result, - stopped, - index = 0, - length = Animation.prefilters.length, - deferred = jQuery.Deferred().always( function() { - - // Don't match elem in the :animated selector - delete tick.elem; - } ), - tick = function() { - if ( stopped ) { - return false; - } - var currentTime = fxNow || createFxNow(), - remaining = Math.max( 0, animation.startTime + animation.duration - currentTime ), - - // Support: Android 2.3 only - // Archaic crash bug won't allow us to use `1 - ( 0.5 || 0 )` (#12497) - temp = remaining / animation.duration || 0, - percent = 1 - temp, - index = 0, - length = animation.tweens.length; - - for ( ; index < length; index++ ) { - animation.tweens[ index ].run( percent ); - } - - deferred.notifyWith( elem, [ animation, percent, remaining ] ); - - // If there's more to do, yield - if ( percent < 1 && length ) { - return remaining; - } - - // If this was an empty animation, synthesize a final progress notification - if ( !length ) { - deferred.notifyWith( elem, [ animation, 1, 0 ] ); - } - - // Resolve the animation and report its conclusion - deferred.resolveWith( elem, [ animation ] ); - return false; - }, - animation = deferred.promise( { - elem: elem, - props: jQuery.extend( {}, properties ), - opts: jQuery.extend( true, { - specialEasing: {}, - easing: jQuery.easing._default - }, options ), - originalProperties: properties, - originalOptions: options, - startTime: fxNow || createFxNow(), - duration: options.duration, - tweens: [], - createTween: function( prop, end ) { - var tween = jQuery.Tween( elem, animation.opts, prop, end, - animation.opts.specialEasing[ prop ] || animation.opts.easing ); - animation.tweens.push( tween ); - return tween; - }, - stop: function( gotoEnd ) { - var index = 0, - - // If we are going to the end, we want to run all the tweens - // otherwise we skip this part - length = gotoEnd ? animation.tweens.length : 0; - if ( stopped ) { - return this; - } - stopped = true; - for ( ; index < length; index++ ) { - animation.tweens[ index ].run( 1 ); - } - - // Resolve when we played the last frame; otherwise, reject - if ( gotoEnd ) { - deferred.notifyWith( elem, [ animation, 1, 0 ] ); - deferred.resolveWith( elem, [ animation, gotoEnd ] ); - } else { - deferred.rejectWith( elem, [ animation, gotoEnd ] ); - } - return this; - } - } ), - props = animation.props; - - propFilter( props, animation.opts.specialEasing ); - - for ( ; index < length; index++ ) { - result = Animation.prefilters[ index ].call( animation, elem, props, animation.opts ); - if ( result ) { - if ( isFunction( result.stop ) ) { - jQuery._queueHooks( animation.elem, animation.opts.queue ).stop = - result.stop.bind( result ); - } - return result; - } - } - - jQuery.map( props, createTween, animation ); - - if ( isFunction( animation.opts.start ) ) { - animation.opts.start.call( elem, animation ); - } - - // Attach callbacks from options - animation - .progress( animation.opts.progress ) - .done( animation.opts.done, animation.opts.complete ) - .fail( animation.opts.fail ) - .always( animation.opts.always ); - - jQuery.fx.timer( - jQuery.extend( tick, { - elem: elem, - anim: animation, - queue: animation.opts.queue - } ) - ); - - return animation; -} - -jQuery.Animation = jQuery.extend( Animation, { - - tweeners: { - "*": [ function( prop, value ) { - var tween = this.createTween( prop, value ); - adjustCSS( tween.elem, prop, rcssNum.exec( value ), tween ); - return tween; - } ] - }, - - tweener: function( props, callback ) { - if ( isFunction( props ) ) { - callback = props; - props = [ "*" ]; - } else { - props = props.match( rnothtmlwhite ); - } - - var prop, - index = 0, - length = props.length; - - for ( ; index < length; index++ ) { - prop = props[ index ]; - Animation.tweeners[ prop ] = Animation.tweeners[ prop ] || []; - Animation.tweeners[ prop ].unshift( callback ); - } - }, - - prefilters: [ defaultPrefilter ], - - prefilter: function( callback, prepend ) { - if ( prepend ) { - Animation.prefilters.unshift( callback ); - } else { - Animation.prefilters.push( callback ); - } - } -} ); - -jQuery.speed = function( speed, easing, fn ) { - var opt = speed && typeof speed === "object" ? jQuery.extend( {}, speed ) : { - complete: fn || !fn && easing || - isFunction( speed ) && speed, - duration: speed, - easing: fn && easing || easing && !isFunction( easing ) && easing - }; - - // Go to the end state if fx are off - if ( jQuery.fx.off ) { - opt.duration = 0; - - } else { - if ( typeof opt.duration !== "number" ) { - if ( opt.duration in jQuery.fx.speeds ) { - opt.duration = jQuery.fx.speeds[ opt.duration ]; - - } else { - opt.duration = jQuery.fx.speeds._default; - } - } - } - - // Normalize opt.queue - true/undefined/null -> "fx" - if ( opt.queue == null || opt.queue === true ) { - opt.queue = "fx"; - } - - // Queueing - opt.old = opt.complete; - - opt.complete = function() { - if ( isFunction( opt.old ) ) { - opt.old.call( this ); - } - - if ( opt.queue ) { - jQuery.dequeue( this, opt.queue ); - } - }; - - return opt; -}; - -jQuery.fn.extend( { - fadeTo: function( speed, to, easing, callback ) { - - // Show any hidden elements after setting opacity to 0 - return this.filter( isHiddenWithinTree ).css( "opacity", 0 ).show() - - // Animate to the value specified - .end().animate( { opacity: to }, speed, easing, callback ); - }, - animate: function( prop, speed, easing, callback ) { - var empty = jQuery.isEmptyObject( prop ), - optall = jQuery.speed( speed, easing, callback ), - doAnimation = function() { - - // Operate on a copy of prop so per-property easing won't be lost - var anim = Animation( this, jQuery.extend( {}, prop ), optall ); - - // Empty animations, or finishing resolves immediately - if ( empty || dataPriv.get( this, "finish" ) ) { - anim.stop( true ); - } - }; - doAnimation.finish = doAnimation; - - return empty || optall.queue === false ? - this.each( doAnimation ) : - this.queue( optall.queue, doAnimation ); - }, - stop: function( type, clearQueue, gotoEnd ) { - var stopQueue = function( hooks ) { - var stop = hooks.stop; - delete hooks.stop; - stop( gotoEnd ); - }; - - if ( typeof type !== "string" ) { - gotoEnd = clearQueue; - clearQueue = type; - type = undefined; - } - if ( clearQueue ) { - this.queue( type || "fx", [] ); - } - - return this.each( function() { - var dequeue = true, - index = type != null && type + "queueHooks", - timers = jQuery.timers, - data = dataPriv.get( this ); - - if ( index ) { - if ( data[ index ] && data[ index ].stop ) { - stopQueue( data[ index ] ); - } - } else { - for ( index in data ) { - if ( data[ index ] && data[ index ].stop && rrun.test( index ) ) { - stopQueue( data[ index ] ); - } - } - } - - for ( index = timers.length; index--; ) { - if ( timers[ index ].elem === this && - ( type == null || timers[ index ].queue === type ) ) { - - timers[ index ].anim.stop( gotoEnd ); - dequeue = false; - timers.splice( index, 1 ); - } - } - - // Start the next in the queue if the last step wasn't forced. - // Timers currently will call their complete callbacks, which - // will dequeue but only if they were gotoEnd. - if ( dequeue || !gotoEnd ) { - jQuery.dequeue( this, type ); - } - } ); - }, - finish: function( type ) { - if ( type !== false ) { - type = type || "fx"; - } - return this.each( function() { - var index, - data = dataPriv.get( this ), - queue = data[ type + "queue" ], - hooks = data[ type + "queueHooks" ], - timers = jQuery.timers, - length = queue ? queue.length : 0; - - // Enable finishing flag on private data - data.finish = true; - - // Empty the queue first - jQuery.queue( this, type, [] ); - - if ( hooks && hooks.stop ) { - hooks.stop.call( this, true ); - } - - // Look for any active animations, and finish them - for ( index = timers.length; index--; ) { - if ( timers[ index ].elem === this && timers[ index ].queue === type ) { - timers[ index ].anim.stop( true ); - timers.splice( index, 1 ); - } - } - - // Look for any animations in the old queue and finish them - for ( index = 0; index < length; index++ ) { - if ( queue[ index ] && queue[ index ].finish ) { - queue[ index ].finish.call( this ); - } - } - - // Turn off finishing flag - delete data.finish; - } ); - } -} ); - -jQuery.each( [ "toggle", "show", "hide" ], function( _i, name ) { - var cssFn = jQuery.fn[ name ]; - jQuery.fn[ name ] = function( speed, easing, callback ) { - return speed == null || typeof speed === "boolean" ? - cssFn.apply( this, arguments ) : - this.animate( genFx( name, true ), speed, easing, callback ); - }; -} ); - -// Generate shortcuts for custom animations -jQuery.each( { - slideDown: genFx( "show" ), - slideUp: genFx( "hide" ), - slideToggle: genFx( "toggle" ), - fadeIn: { opacity: "show" }, - fadeOut: { opacity: "hide" }, - fadeToggle: { opacity: "toggle" } -}, function( name, props ) { - jQuery.fn[ name ] = function( speed, easing, callback ) { - return this.animate( props, speed, easing, callback ); - }; -} ); - -jQuery.timers = []; -jQuery.fx.tick = function() { - var timer, - i = 0, - timers = jQuery.timers; - - fxNow = Date.now(); - - for ( ; i < timers.length; i++ ) { - timer = timers[ i ]; - - // Run the timer and safely remove it when done (allowing for external removal) - if ( !timer() && timers[ i ] === timer ) { - timers.splice( i--, 1 ); - } - } - - if ( !timers.length ) { - jQuery.fx.stop(); - } - fxNow = undefined; -}; - -jQuery.fx.timer = function( timer ) { - jQuery.timers.push( timer ); - jQuery.fx.start(); -}; - -jQuery.fx.interval = 13; -jQuery.fx.start = function() { - if ( inProgress ) { - return; - } - - inProgress = true; - schedule(); -}; - -jQuery.fx.stop = function() { - inProgress = null; -}; - -jQuery.fx.speeds = { - slow: 600, - fast: 200, - - // Default speed - _default: 400 -}; - - -// Based off of the plugin by Clint Helfers, with permission. -// https://web.archive.org/web/20100324014747/http://blindsignals.com/index.php/2009/07/jquery-delay/ -jQuery.fn.delay = function( time, type ) { - time = jQuery.fx ? jQuery.fx.speeds[ time ] || time : time; - type = type || "fx"; - - return this.queue( type, function( next, hooks ) { - var timeout = window.setTimeout( next, time ); - hooks.stop = function() { - window.clearTimeout( timeout ); - }; - } ); -}; - - -( function() { - var input = document.createElement( "input" ), - select = document.createElement( "select" ), - opt = select.appendChild( document.createElement( "option" ) ); - - input.type = "checkbox"; - - // Support: Android <=4.3 only - // Default value for a checkbox should be "on" - support.checkOn = input.value !== ""; - - // Support: IE <=11 only - // Must access selectedIndex to make default options select - support.optSelected = opt.selected; - - // Support: IE <=11 only - // An input loses its value after becoming a radio - input = document.createElement( "input" ); - input.value = "t"; - input.type = "radio"; - support.radioValue = input.value === "t"; -} )(); - - -var boolHook, - attrHandle = jQuery.expr.attrHandle; - -jQuery.fn.extend( { - attr: function( name, value ) { - return access( this, jQuery.attr, name, value, arguments.length > 1 ); - }, - - removeAttr: function( name ) { - return this.each( function() { - jQuery.removeAttr( this, name ); - } ); - } -} ); - -jQuery.extend( { - attr: function( elem, name, value ) { - var ret, hooks, - nType = elem.nodeType; - - // Don't get/set attributes on text, comment and attribute nodes - if ( nType === 3 || nType === 8 || nType === 2 ) { - return; - } - - // Fallback to prop when attributes are not supported - if ( typeof elem.getAttribute === "undefined" ) { - return jQuery.prop( elem, name, value ); - } - - // Attribute hooks are determined by the lowercase version - // Grab necessary hook if one is defined - if ( nType !== 1 || !jQuery.isXMLDoc( elem ) ) { - hooks = jQuery.attrHooks[ name.toLowerCase() ] || - ( jQuery.expr.match.bool.test( name ) ? boolHook : undefined ); - } - - if ( value !== undefined ) { - if ( value === null ) { - jQuery.removeAttr( elem, name ); - return; - } - - if ( hooks && "set" in hooks && - ( ret = hooks.set( elem, value, name ) ) !== undefined ) { - return ret; - } - - elem.setAttribute( name, value + "" ); - return value; - } - - if ( hooks && "get" in hooks && ( ret = hooks.get( elem, name ) ) !== null ) { - return ret; - } - - ret = jQuery.find.attr( elem, name ); - - // Non-existent attributes return null, we normalize to undefined - return ret == null ? undefined : ret; - }, - - attrHooks: { - type: { - set: function( elem, value ) { - if ( !support.radioValue && value === "radio" && - nodeName( elem, "input" ) ) { - var val = elem.value; - elem.setAttribute( "type", value ); - if ( val ) { - elem.value = val; - } - return value; - } - } - } - }, - - removeAttr: function( elem, value ) { - var name, - i = 0, - - // Attribute names can contain non-HTML whitespace characters - // https://html.spec.whatwg.org/multipage/syntax.html#attributes-2 - attrNames = value && value.match( rnothtmlwhite ); - - if ( attrNames && elem.nodeType === 1 ) { - while ( ( name = attrNames[ i++ ] ) ) { - elem.removeAttribute( name ); - } - } - } -} ); - -// Hooks for boolean attributes -boolHook = { - set: function( elem, value, name ) { - if ( value === false ) { - - // Remove boolean attributes when set to false - jQuery.removeAttr( elem, name ); - } else { - elem.setAttribute( name, name ); - } - return name; - } -}; - -jQuery.each( jQuery.expr.match.bool.source.match( /\w+/g ), function( _i, name ) { - var getter = attrHandle[ name ] || jQuery.find.attr; - - attrHandle[ name ] = function( elem, name, isXML ) { - var ret, handle, - lowercaseName = name.toLowerCase(); - - if ( !isXML ) { - - // Avoid an infinite loop by temporarily removing this function from the getter - handle = attrHandle[ lowercaseName ]; - attrHandle[ lowercaseName ] = ret; - ret = getter( elem, name, isXML ) != null ? - lowercaseName : - null; - attrHandle[ lowercaseName ] = handle; - } - return ret; - }; -} ); - - - - -var rfocusable = /^(?:input|select|textarea|button)$/i, - rclickable = /^(?:a|area)$/i; - -jQuery.fn.extend( { - prop: function( name, value ) { - return access( this, jQuery.prop, name, value, arguments.length > 1 ); - }, - - removeProp: function( name ) { - return this.each( function() { - delete this[ jQuery.propFix[ name ] || name ]; - } ); - } -} ); - -jQuery.extend( { - prop: function( elem, name, value ) { - var ret, hooks, - nType = elem.nodeType; - - // Don't get/set properties on text, comment and attribute nodes - if ( nType === 3 || nType === 8 || nType === 2 ) { - return; - } - - if ( nType !== 1 || !jQuery.isXMLDoc( elem ) ) { - - // Fix name and attach hooks - name = jQuery.propFix[ name ] || name; - hooks = jQuery.propHooks[ name ]; - } - - if ( value !== undefined ) { - if ( hooks && "set" in hooks && - ( ret = hooks.set( elem, value, name ) ) !== undefined ) { - return ret; - } - - return ( elem[ name ] = value ); - } - - if ( hooks && "get" in hooks && ( ret = hooks.get( elem, name ) ) !== null ) { - return ret; - } - - return elem[ name ]; - }, - - propHooks: { - tabIndex: { - get: function( elem ) { - - // Support: IE <=9 - 11 only - // elem.tabIndex doesn't always return the - // correct value when it hasn't been explicitly set - // https://web.archive.org/web/20141116233347/http://fluidproject.org/blog/2008/01/09/getting-setting-and-removing-tabindex-values-with-javascript/ - // Use proper attribute retrieval(#12072) - var tabindex = jQuery.find.attr( elem, "tabindex" ); - - if ( tabindex ) { - return parseInt( tabindex, 10 ); - } - - if ( - rfocusable.test( elem.nodeName ) || - rclickable.test( elem.nodeName ) && - elem.href - ) { - return 0; - } - - return -1; - } - } - }, - - propFix: { - "for": "htmlFor", - "class": "className" - } -} ); - -// Support: IE <=11 only -// Accessing the selectedIndex property -// forces the browser to respect setting selected -// on the option -// The getter ensures a default option is selected -// when in an optgroup -// eslint rule "no-unused-expressions" is disabled for this code -// since it considers such accessions noop -if ( !support.optSelected ) { - jQuery.propHooks.selected = { - get: function( elem ) { - - /* eslint no-unused-expressions: "off" */ - - var parent = elem.parentNode; - if ( parent && parent.parentNode ) { - parent.parentNode.selectedIndex; - } - return null; - }, - set: function( elem ) { - - /* eslint no-unused-expressions: "off" */ - - var parent = elem.parentNode; - if ( parent ) { - parent.selectedIndex; - - if ( parent.parentNode ) { - parent.parentNode.selectedIndex; - } - } - } - }; -} - -jQuery.each( [ - "tabIndex", - "readOnly", - "maxLength", - "cellSpacing", - "cellPadding", - "rowSpan", - "colSpan", - "useMap", - "frameBorder", - "contentEditable" -], function() { - jQuery.propFix[ this.toLowerCase() ] = this; -} ); - - - - - // Strip and collapse whitespace according to HTML spec - // https://infra.spec.whatwg.org/#strip-and-collapse-ascii-whitespace - function stripAndCollapse( value ) { - var tokens = value.match( rnothtmlwhite ) || []; - return tokens.join( " " ); - } - - -function getClass( elem ) { - return elem.getAttribute && elem.getAttribute( "class" ) || ""; -} - -function classesToArray( value ) { - if ( Array.isArray( value ) ) { - return value; - } - if ( typeof value === "string" ) { - return value.match( rnothtmlwhite ) || []; - } - return []; -} - -jQuery.fn.extend( { - addClass: function( value ) { - var classes, elem, cur, curValue, clazz, j, finalValue, - i = 0; - - if ( isFunction( value ) ) { - return this.each( function( j ) { - jQuery( this ).addClass( value.call( this, j, getClass( this ) ) ); - } ); - } - - classes = classesToArray( value ); - - if ( classes.length ) { - while ( ( elem = this[ i++ ] ) ) { - curValue = getClass( elem ); - cur = elem.nodeType === 1 && ( " " + stripAndCollapse( curValue ) + " " ); - - if ( cur ) { - j = 0; - while ( ( clazz = classes[ j++ ] ) ) { - if ( cur.indexOf( " " + clazz + " " ) < 0 ) { - cur += clazz + " "; - } - } - - // Only assign if different to avoid unneeded rendering. - finalValue = stripAndCollapse( cur ); - if ( curValue !== finalValue ) { - elem.setAttribute( "class", finalValue ); - } - } - } - } - - return this; - }, - - removeClass: function( value ) { - var classes, elem, cur, curValue, clazz, j, finalValue, - i = 0; - - if ( isFunction( value ) ) { - return this.each( function( j ) { - jQuery( this ).removeClass( value.call( this, j, getClass( this ) ) ); - } ); - } - - if ( !arguments.length ) { - return this.attr( "class", "" ); - } - - classes = classesToArray( value ); - - if ( classes.length ) { - while ( ( elem = this[ i++ ] ) ) { - curValue = getClass( elem ); - - // This expression is here for better compressibility (see addClass) - cur = elem.nodeType === 1 && ( " " + stripAndCollapse( curValue ) + " " ); - - if ( cur ) { - j = 0; - while ( ( clazz = classes[ j++ ] ) ) { - - // Remove *all* instances - while ( cur.indexOf( " " + clazz + " " ) > -1 ) { - cur = cur.replace( " " + clazz + " ", " " ); - } - } - - // Only assign if different to avoid unneeded rendering. - finalValue = stripAndCollapse( cur ); - if ( curValue !== finalValue ) { - elem.setAttribute( "class", finalValue ); - } - } - } - } - - return this; - }, - - toggleClass: function( value, stateVal ) { - var type = typeof value, - isValidValue = type === "string" || Array.isArray( value ); - - if ( typeof stateVal === "boolean" && isValidValue ) { - return stateVal ? this.addClass( value ) : this.removeClass( value ); - } - - if ( isFunction( value ) ) { - return this.each( function( i ) { - jQuery( this ).toggleClass( - value.call( this, i, getClass( this ), stateVal ), - stateVal - ); - } ); - } - - return this.each( function() { - var className, i, self, classNames; - - if ( isValidValue ) { - - // Toggle individual class names - i = 0; - self = jQuery( this ); - classNames = classesToArray( value ); - - while ( ( className = classNames[ i++ ] ) ) { - - // Check each className given, space separated list - if ( self.hasClass( className ) ) { - self.removeClass( className ); - } else { - self.addClass( className ); - } - } - - // Toggle whole class name - } else if ( value === undefined || type === "boolean" ) { - className = getClass( this ); - if ( className ) { - - // Store className if set - dataPriv.set( this, "__className__", className ); - } - - // If the element has a class name or if we're passed `false`, - // then remove the whole classname (if there was one, the above saved it). - // Otherwise bring back whatever was previously saved (if anything), - // falling back to the empty string if nothing was stored. - if ( this.setAttribute ) { - this.setAttribute( "class", - className || value === false ? - "" : - dataPriv.get( this, "__className__" ) || "" - ); - } - } - } ); - }, - - hasClass: function( selector ) { - var className, elem, - i = 0; - - className = " " + selector + " "; - while ( ( elem = this[ i++ ] ) ) { - if ( elem.nodeType === 1 && - ( " " + stripAndCollapse( getClass( elem ) ) + " " ).indexOf( className ) > -1 ) { - return true; - } - } - - return false; - } -} ); - - - - -var rreturn = /\r/g; - -jQuery.fn.extend( { - val: function( value ) { - var hooks, ret, valueIsFunction, - elem = this[ 0 ]; - - if ( !arguments.length ) { - if ( elem ) { - hooks = jQuery.valHooks[ elem.type ] || - jQuery.valHooks[ elem.nodeName.toLowerCase() ]; - - if ( hooks && - "get" in hooks && - ( ret = hooks.get( elem, "value" ) ) !== undefined - ) { - return ret; - } - - ret = elem.value; - - // Handle most common string cases - if ( typeof ret === "string" ) { - return ret.replace( rreturn, "" ); - } - - // Handle cases where value is null/undef or number - return ret == null ? "" : ret; - } - - return; - } - - valueIsFunction = isFunction( value ); - - return this.each( function( i ) { - var val; - - if ( this.nodeType !== 1 ) { - return; - } - - if ( valueIsFunction ) { - val = value.call( this, i, jQuery( this ).val() ); - } else { - val = value; - } - - // Treat null/undefined as ""; convert numbers to string - if ( val == null ) { - val = ""; - - } else if ( typeof val === "number" ) { - val += ""; - - } else if ( Array.isArray( val ) ) { - val = jQuery.map( val, function( value ) { - return value == null ? "" : value + ""; - } ); - } - - hooks = jQuery.valHooks[ this.type ] || jQuery.valHooks[ this.nodeName.toLowerCase() ]; - - // If set returns undefined, fall back to normal setting - if ( !hooks || !( "set" in hooks ) || hooks.set( this, val, "value" ) === undefined ) { - this.value = val; - } - } ); - } -} ); - -jQuery.extend( { - valHooks: { - option: { - get: function( elem ) { - - var val = jQuery.find.attr( elem, "value" ); - return val != null ? - val : - - // Support: IE <=10 - 11 only - // option.text throws exceptions (#14686, #14858) - // Strip and collapse whitespace - // https://html.spec.whatwg.org/#strip-and-collapse-whitespace - stripAndCollapse( jQuery.text( elem ) ); - } - }, - select: { - get: function( elem ) { - var value, option, i, - options = elem.options, - index = elem.selectedIndex, - one = elem.type === "select-one", - values = one ? null : [], - max = one ? index + 1 : options.length; - - if ( index < 0 ) { - i = max; - - } else { - i = one ? index : 0; - } - - // Loop through all the selected options - for ( ; i < max; i++ ) { - option = options[ i ]; - - // Support: IE <=9 only - // IE8-9 doesn't update selected after form reset (#2551) - if ( ( option.selected || i === index ) && - - // Don't return options that are disabled or in a disabled optgroup - !option.disabled && - ( !option.parentNode.disabled || - !nodeName( option.parentNode, "optgroup" ) ) ) { - - // Get the specific value for the option - value = jQuery( option ).val(); - - // We don't need an array for one selects - if ( one ) { - return value; - } - - // Multi-Selects return an array - values.push( value ); - } - } - - return values; - }, - - set: function( elem, value ) { - var optionSet, option, - options = elem.options, - values = jQuery.makeArray( value ), - i = options.length; - - while ( i-- ) { - option = options[ i ]; - - /* eslint-disable no-cond-assign */ - - if ( option.selected = - jQuery.inArray( jQuery.valHooks.option.get( option ), values ) > -1 - ) { - optionSet = true; - } - - /* eslint-enable no-cond-assign */ - } - - // Force browsers to behave consistently when non-matching value is set - if ( !optionSet ) { - elem.selectedIndex = -1; - } - return values; - } - } - } -} ); - -// Radios and checkboxes getter/setter -jQuery.each( [ "radio", "checkbox" ], function() { - jQuery.valHooks[ this ] = { - set: function( elem, value ) { - if ( Array.isArray( value ) ) { - return ( elem.checked = jQuery.inArray( jQuery( elem ).val(), value ) > -1 ); - } - } - }; - if ( !support.checkOn ) { - jQuery.valHooks[ this ].get = function( elem ) { - return elem.getAttribute( "value" ) === null ? "on" : elem.value; - }; - } -} ); - - - - -// Return jQuery for attributes-only inclusion - - -support.focusin = "onfocusin" in window; - - -var rfocusMorph = /^(?:focusinfocus|focusoutblur)$/, - stopPropagationCallback = function( e ) { - e.stopPropagation(); - }; - -jQuery.extend( jQuery.event, { - - trigger: function( event, data, elem, onlyHandlers ) { - - var i, cur, tmp, bubbleType, ontype, handle, special, lastElement, - eventPath = [ elem || document ], - type = hasOwn.call( event, "type" ) ? event.type : event, - namespaces = hasOwn.call( event, "namespace" ) ? event.namespace.split( "." ) : []; - - cur = lastElement = tmp = elem = elem || document; - - // Don't do events on text and comment nodes - if ( elem.nodeType === 3 || elem.nodeType === 8 ) { - return; - } - - // focus/blur morphs to focusin/out; ensure we're not firing them right now - if ( rfocusMorph.test( type + jQuery.event.triggered ) ) { - return; - } - - if ( type.indexOf( "." ) > -1 ) { - - // Namespaced trigger; create a regexp to match event type in handle() - namespaces = type.split( "." ); - type = namespaces.shift(); - namespaces.sort(); - } - ontype = type.indexOf( ":" ) < 0 && "on" + type; - - // Caller can pass in a jQuery.Event object, Object, or just an event type string - event = event[ jQuery.expando ] ? - event : - new jQuery.Event( type, typeof event === "object" && event ); - - // Trigger bitmask: & 1 for native handlers; & 2 for jQuery (always true) - event.isTrigger = onlyHandlers ? 2 : 3; - event.namespace = namespaces.join( "." ); - event.rnamespace = event.namespace ? - new RegExp( "(^|\\.)" + namespaces.join( "\\.(?:.*\\.|)" ) + "(\\.|$)" ) : - null; - - // Clean up the event in case it is being reused - event.result = undefined; - if ( !event.target ) { - event.target = elem; - } - - // Clone any incoming data and prepend the event, creating the handler arg list - data = data == null ? - [ event ] : - jQuery.makeArray( data, [ event ] ); - - // Allow special events to draw outside the lines - special = jQuery.event.special[ type ] || {}; - if ( !onlyHandlers && special.trigger && special.trigger.apply( elem, data ) === false ) { - return; - } - - // Determine event propagation path in advance, per W3C events spec (#9951) - // Bubble up to document, then to window; watch for a global ownerDocument var (#9724) - if ( !onlyHandlers && !special.noBubble && !isWindow( elem ) ) { - - bubbleType = special.delegateType || type; - if ( !rfocusMorph.test( bubbleType + type ) ) { - cur = cur.parentNode; - } - for ( ; cur; cur = cur.parentNode ) { - eventPath.push( cur ); - tmp = cur; - } - - // Only add window if we got to document (e.g., not plain obj or detached DOM) - if ( tmp === ( elem.ownerDocument || document ) ) { - eventPath.push( tmp.defaultView || tmp.parentWindow || window ); - } - } - - // Fire handlers on the event path - i = 0; - while ( ( cur = eventPath[ i++ ] ) && !event.isPropagationStopped() ) { - lastElement = cur; - event.type = i > 1 ? - bubbleType : - special.bindType || type; - - // jQuery handler - handle = ( - dataPriv.get( cur, "events" ) || Object.create( null ) - )[ event.type ] && - dataPriv.get( cur, "handle" ); - if ( handle ) { - handle.apply( cur, data ); - } - - // Native handler - handle = ontype && cur[ ontype ]; - if ( handle && handle.apply && acceptData( cur ) ) { - event.result = handle.apply( cur, data ); - if ( event.result === false ) { - event.preventDefault(); - } - } - } - event.type = type; - - // If nobody prevented the default action, do it now - if ( !onlyHandlers && !event.isDefaultPrevented() ) { - - if ( ( !special._default || - special._default.apply( eventPath.pop(), data ) === false ) && - acceptData( elem ) ) { - - // Call a native DOM method on the target with the same name as the event. - // Don't do default actions on window, that's where global variables be (#6170) - if ( ontype && isFunction( elem[ type ] ) && !isWindow( elem ) ) { - - // Don't re-trigger an onFOO event when we call its FOO() method - tmp = elem[ ontype ]; - - if ( tmp ) { - elem[ ontype ] = null; - } - - // Prevent re-triggering of the same event, since we already bubbled it above - jQuery.event.triggered = type; - - if ( event.isPropagationStopped() ) { - lastElement.addEventListener( type, stopPropagationCallback ); - } - - elem[ type ](); - - if ( event.isPropagationStopped() ) { - lastElement.removeEventListener( type, stopPropagationCallback ); - } - - jQuery.event.triggered = undefined; - - if ( tmp ) { - elem[ ontype ] = tmp; - } - } - } - } - - return event.result; - }, - - // Piggyback on a donor event to simulate a different one - // Used only for `focus(in | out)` events - simulate: function( type, elem, event ) { - var e = jQuery.extend( - new jQuery.Event(), - event, - { - type: type, - isSimulated: true - } - ); - - jQuery.event.trigger( e, null, elem ); - } - -} ); - -jQuery.fn.extend( { - - trigger: function( type, data ) { - return this.each( function() { - jQuery.event.trigger( type, data, this ); - } ); - }, - triggerHandler: function( type, data ) { - var elem = this[ 0 ]; - if ( elem ) { - return jQuery.event.trigger( type, data, elem, true ); - } - } -} ); - - -// Support: Firefox <=44 -// Firefox doesn't have focus(in | out) events -// Related ticket - https://bugzilla.mozilla.org/show_bug.cgi?id=687787 -// -// Support: Chrome <=48 - 49, Safari <=9.0 - 9.1 -// focus(in | out) events fire after focus & blur events, -// which is spec violation - http://www.w3.org/TR/DOM-Level-3-Events/#events-focusevent-event-order -// Related ticket - https://bugs.chromium.org/p/chromium/issues/detail?id=449857 -if ( !support.focusin ) { - jQuery.each( { focus: "focusin", blur: "focusout" }, function( orig, fix ) { - - // Attach a single capturing handler on the document while someone wants focusin/focusout - var handler = function( event ) { - jQuery.event.simulate( fix, event.target, jQuery.event.fix( event ) ); - }; - - jQuery.event.special[ fix ] = { - setup: function() { - - // Handle: regular nodes (via `this.ownerDocument`), window - // (via `this.document`) & document (via `this`). - var doc = this.ownerDocument || this.document || this, - attaches = dataPriv.access( doc, fix ); - - if ( !attaches ) { - doc.addEventListener( orig, handler, true ); - } - dataPriv.access( doc, fix, ( attaches || 0 ) + 1 ); - }, - teardown: function() { - var doc = this.ownerDocument || this.document || this, - attaches = dataPriv.access( doc, fix ) - 1; - - if ( !attaches ) { - doc.removeEventListener( orig, handler, true ); - dataPriv.remove( doc, fix ); - - } else { - dataPriv.access( doc, fix, attaches ); - } - } - }; - } ); -} -var location = window.location; - -var nonce = { guid: Date.now() }; - -var rquery = ( /\?/ ); - - - -// Cross-browser xml parsing -jQuery.parseXML = function( data ) { - var xml; - if ( !data || typeof data !== "string" ) { - return null; - } - - // Support: IE 9 - 11 only - // IE throws on parseFromString with invalid input. - try { - xml = ( new window.DOMParser() ).parseFromString( data, "text/xml" ); - } catch ( e ) { - xml = undefined; - } - - if ( !xml || xml.getElementsByTagName( "parsererror" ).length ) { - jQuery.error( "Invalid XML: " + data ); - } - return xml; -}; - - -var - rbracket = /\[\]$/, - rCRLF = /\r?\n/g, - rsubmitterTypes = /^(?:submit|button|image|reset|file)$/i, - rsubmittable = /^(?:input|select|textarea|keygen)/i; - -function buildParams( prefix, obj, traditional, add ) { - var name; - - if ( Array.isArray( obj ) ) { - - // Serialize array item. - jQuery.each( obj, function( i, v ) { - if ( traditional || rbracket.test( prefix ) ) { - - // Treat each array item as a scalar. - add( prefix, v ); - - } else { - - // Item is non-scalar (array or object), encode its numeric index. - buildParams( - prefix + "[" + ( typeof v === "object" && v != null ? i : "" ) + "]", - v, - traditional, - add - ); - } - } ); - - } else if ( !traditional && toType( obj ) === "object" ) { - - // Serialize object item. - for ( name in obj ) { - buildParams( prefix + "[" + name + "]", obj[ name ], traditional, add ); - } - - } else { - - // Serialize scalar item. - add( prefix, obj ); - } -} - -// Serialize an array of form elements or a set of -// key/values into a query string -jQuery.param = function( a, traditional ) { - var prefix, - s = [], - add = function( key, valueOrFunction ) { - - // If value is a function, invoke it and use its return value - var value = isFunction( valueOrFunction ) ? - valueOrFunction() : - valueOrFunction; - - s[ s.length ] = encodeURIComponent( key ) + "=" + - encodeURIComponent( value == null ? "" : value ); - }; - - if ( a == null ) { - return ""; - } - - // If an array was passed in, assume that it is an array of form elements. - if ( Array.isArray( a ) || ( a.jquery && !jQuery.isPlainObject( a ) ) ) { - - // Serialize the form elements - jQuery.each( a, function() { - add( this.name, this.value ); - } ); - - } else { - - // If traditional, encode the "old" way (the way 1.3.2 or older - // did it), otherwise encode params recursively. - for ( prefix in a ) { - buildParams( prefix, a[ prefix ], traditional, add ); - } - } - - // Return the resulting serialization - return s.join( "&" ); -}; - -jQuery.fn.extend( { - serialize: function() { - return jQuery.param( this.serializeArray() ); - }, - serializeArray: function() { - return this.map( function() { - - // Can add propHook for "elements" to filter or add form elements - var elements = jQuery.prop( this, "elements" ); - return elements ? jQuery.makeArray( elements ) : this; - } ) - .filter( function() { - var type = this.type; - - // Use .is( ":disabled" ) so that fieldset[disabled] works - return this.name && !jQuery( this ).is( ":disabled" ) && - rsubmittable.test( this.nodeName ) && !rsubmitterTypes.test( type ) && - ( this.checked || !rcheckableType.test( type ) ); - } ) - .map( function( _i, elem ) { - var val = jQuery( this ).val(); - - if ( val == null ) { - return null; - } - - if ( Array.isArray( val ) ) { - return jQuery.map( val, function( val ) { - return { name: elem.name, value: val.replace( rCRLF, "\r\n" ) }; - } ); - } - - return { name: elem.name, value: val.replace( rCRLF, "\r\n" ) }; - } ).get(); - } -} ); - - -var - r20 = /%20/g, - rhash = /#.*$/, - rantiCache = /([?&])_=[^&]*/, - rheaders = /^(.*?):[ \t]*([^\r\n]*)$/mg, - - // #7653, #8125, #8152: local protocol detection - rlocalProtocol = /^(?:about|app|app-storage|.+-extension|file|res|widget):$/, - rnoContent = /^(?:GET|HEAD)$/, - rprotocol = /^\/\//, - - /* Prefilters - * 1) They are useful to introduce custom dataTypes (see ajax/jsonp.js for an example) - * 2) These are called: - * - BEFORE asking for a transport - * - AFTER param serialization (s.data is a string if s.processData is true) - * 3) key is the dataType - * 4) the catchall symbol "*" can be used - * 5) execution will start with transport dataType and THEN continue down to "*" if needed - */ - prefilters = {}, - - /* Transports bindings - * 1) key is the dataType - * 2) the catchall symbol "*" can be used - * 3) selection will start with transport dataType and THEN go to "*" if needed - */ - transports = {}, - - // Avoid comment-prolog char sequence (#10098); must appease lint and evade compression - allTypes = "*/".concat( "*" ), - - // Anchor tag for parsing the document origin - originAnchor = document.createElement( "a" ); - originAnchor.href = location.href; - -// Base "constructor" for jQuery.ajaxPrefilter and jQuery.ajaxTransport -function addToPrefiltersOrTransports( structure ) { - - // dataTypeExpression is optional and defaults to "*" - return function( dataTypeExpression, func ) { - - if ( typeof dataTypeExpression !== "string" ) { - func = dataTypeExpression; - dataTypeExpression = "*"; - } - - var dataType, - i = 0, - dataTypes = dataTypeExpression.toLowerCase().match( rnothtmlwhite ) || []; - - if ( isFunction( func ) ) { - - // For each dataType in the dataTypeExpression - while ( ( dataType = dataTypes[ i++ ] ) ) { - - // Prepend if requested - if ( dataType[ 0 ] === "+" ) { - dataType = dataType.slice( 1 ) || "*"; - ( structure[ dataType ] = structure[ dataType ] || [] ).unshift( func ); - - // Otherwise append - } else { - ( structure[ dataType ] = structure[ dataType ] || [] ).push( func ); - } - } - } - }; -} - -// Base inspection function for prefilters and transports -function inspectPrefiltersOrTransports( structure, options, originalOptions, jqXHR ) { - - var inspected = {}, - seekingTransport = ( structure === transports ); - - function inspect( dataType ) { - var selected; - inspected[ dataType ] = true; - jQuery.each( structure[ dataType ] || [], function( _, prefilterOrFactory ) { - var dataTypeOrTransport = prefilterOrFactory( options, originalOptions, jqXHR ); - if ( typeof dataTypeOrTransport === "string" && - !seekingTransport && !inspected[ dataTypeOrTransport ] ) { - - options.dataTypes.unshift( dataTypeOrTransport ); - inspect( dataTypeOrTransport ); - return false; - } else if ( seekingTransport ) { - return !( selected = dataTypeOrTransport ); - } - } ); - return selected; - } - - return inspect( options.dataTypes[ 0 ] ) || !inspected[ "*" ] && inspect( "*" ); -} - -// A special extend for ajax options -// that takes "flat" options (not to be deep extended) -// Fixes #9887 -function ajaxExtend( target, src ) { - var key, deep, - flatOptions = jQuery.ajaxSettings.flatOptions || {}; - - for ( key in src ) { - if ( src[ key ] !== undefined ) { - ( flatOptions[ key ] ? target : ( deep || ( deep = {} ) ) )[ key ] = src[ key ]; - } - } - if ( deep ) { - jQuery.extend( true, target, deep ); - } - - return target; -} - -/* Handles responses to an ajax request: - * - finds the right dataType (mediates between content-type and expected dataType) - * - returns the corresponding response - */ -function ajaxHandleResponses( s, jqXHR, responses ) { - - var ct, type, finalDataType, firstDataType, - contents = s.contents, - dataTypes = s.dataTypes; - - // Remove auto dataType and get content-type in the process - while ( dataTypes[ 0 ] === "*" ) { - dataTypes.shift(); - if ( ct === undefined ) { - ct = s.mimeType || jqXHR.getResponseHeader( "Content-Type" ); - } - } - - // Check if we're dealing with a known content-type - if ( ct ) { - for ( type in contents ) { - if ( contents[ type ] && contents[ type ].test( ct ) ) { - dataTypes.unshift( type ); - break; - } - } - } - - // Check to see if we have a response for the expected dataType - if ( dataTypes[ 0 ] in responses ) { - finalDataType = dataTypes[ 0 ]; - } else { - - // Try convertible dataTypes - for ( type in responses ) { - if ( !dataTypes[ 0 ] || s.converters[ type + " " + dataTypes[ 0 ] ] ) { - finalDataType = type; - break; - } - if ( !firstDataType ) { - firstDataType = type; - } - } - - // Or just use first one - finalDataType = finalDataType || firstDataType; - } - - // If we found a dataType - // We add the dataType to the list if needed - // and return the corresponding response - if ( finalDataType ) { - if ( finalDataType !== dataTypes[ 0 ] ) { - dataTypes.unshift( finalDataType ); - } - return responses[ finalDataType ]; - } -} - -/* Chain conversions given the request and the original response - * Also sets the responseXXX fields on the jqXHR instance - */ -function ajaxConvert( s, response, jqXHR, isSuccess ) { - var conv2, current, conv, tmp, prev, - converters = {}, - - // Work with a copy of dataTypes in case we need to modify it for conversion - dataTypes = s.dataTypes.slice(); - - // Create converters map with lowercased keys - if ( dataTypes[ 1 ] ) { - for ( conv in s.converters ) { - converters[ conv.toLowerCase() ] = s.converters[ conv ]; - } - } - - current = dataTypes.shift(); - - // Convert to each sequential dataType - while ( current ) { - - if ( s.responseFields[ current ] ) { - jqXHR[ s.responseFields[ current ] ] = response; - } - - // Apply the dataFilter if provided - if ( !prev && isSuccess && s.dataFilter ) { - response = s.dataFilter( response, s.dataType ); - } - - prev = current; - current = dataTypes.shift(); - - if ( current ) { - - // There's only work to do if current dataType is non-auto - if ( current === "*" ) { - - current = prev; - - // Convert response if prev dataType is non-auto and differs from current - } else if ( prev !== "*" && prev !== current ) { - - // Seek a direct converter - conv = converters[ prev + " " + current ] || converters[ "* " + current ]; - - // If none found, seek a pair - if ( !conv ) { - for ( conv2 in converters ) { - - // If conv2 outputs current - tmp = conv2.split( " " ); - if ( tmp[ 1 ] === current ) { - - // If prev can be converted to accepted input - conv = converters[ prev + " " + tmp[ 0 ] ] || - converters[ "* " + tmp[ 0 ] ]; - if ( conv ) { - - // Condense equivalence converters - if ( conv === true ) { - conv = converters[ conv2 ]; - - // Otherwise, insert the intermediate dataType - } else if ( converters[ conv2 ] !== true ) { - current = tmp[ 0 ]; - dataTypes.unshift( tmp[ 1 ] ); - } - break; - } - } - } - } - - // Apply converter (if not an equivalence) - if ( conv !== true ) { - - // Unless errors are allowed to bubble, catch and return them - if ( conv && s.throws ) { - response = conv( response ); - } else { - try { - response = conv( response ); - } catch ( e ) { - return { - state: "parsererror", - error: conv ? e : "No conversion from " + prev + " to " + current - }; - } - } - } - } - } - } - - return { state: "success", data: response }; -} - -jQuery.extend( { - - // Counter for holding the number of active queries - active: 0, - - // Last-Modified header cache for next request - lastModified: {}, - etag: {}, - - ajaxSettings: { - url: location.href, - type: "GET", - isLocal: rlocalProtocol.test( location.protocol ), - global: true, - processData: true, - async: true, - contentType: "application/x-www-form-urlencoded; charset=UTF-8", - - /* - timeout: 0, - data: null, - dataType: null, - username: null, - password: null, - cache: null, - throws: false, - traditional: false, - headers: {}, - */ - - accepts: { - "*": allTypes, - text: "text/plain", - html: "text/html", - xml: "application/xml, text/xml", - json: "application/json, text/javascript" - }, - - contents: { - xml: /\bxml\b/, - html: /\bhtml/, - json: /\bjson\b/ - }, - - responseFields: { - xml: "responseXML", - text: "responseText", - json: "responseJSON" - }, - - // Data converters - // Keys separate source (or catchall "*") and destination types with a single space - converters: { - - // Convert anything to text - "* text": String, - - // Text to html (true = no transformation) - "text html": true, - - // Evaluate text as a json expression - "text json": JSON.parse, - - // Parse text as xml - "text xml": jQuery.parseXML - }, - - // For options that shouldn't be deep extended: - // you can add your own custom options here if - // and when you create one that shouldn't be - // deep extended (see ajaxExtend) - flatOptions: { - url: true, - context: true - } - }, - - // Creates a full fledged settings object into target - // with both ajaxSettings and settings fields. - // If target is omitted, writes into ajaxSettings. - ajaxSetup: function( target, settings ) { - return settings ? - - // Building a settings object - ajaxExtend( ajaxExtend( target, jQuery.ajaxSettings ), settings ) : - - // Extending ajaxSettings - ajaxExtend( jQuery.ajaxSettings, target ); - }, - - ajaxPrefilter: addToPrefiltersOrTransports( prefilters ), - ajaxTransport: addToPrefiltersOrTransports( transports ), - - // Main method - ajax: function( url, options ) { - - // If url is an object, simulate pre-1.5 signature - if ( typeof url === "object" ) { - options = url; - url = undefined; - } - - // Force options to be an object - options = options || {}; - - var transport, - - // URL without anti-cache param - cacheURL, - - // Response headers - responseHeadersString, - responseHeaders, - - // timeout handle - timeoutTimer, - - // Url cleanup var - urlAnchor, - - // Request state (becomes false upon send and true upon completion) - completed, - - // To know if global events are to be dispatched - fireGlobals, - - // Loop variable - i, - - // uncached part of the url - uncached, - - // Create the final options object - s = jQuery.ajaxSetup( {}, options ), - - // Callbacks context - callbackContext = s.context || s, - - // Context for global events is callbackContext if it is a DOM node or jQuery collection - globalEventContext = s.context && - ( callbackContext.nodeType || callbackContext.jquery ) ? - jQuery( callbackContext ) : - jQuery.event, - - // Deferreds - deferred = jQuery.Deferred(), - completeDeferred = jQuery.Callbacks( "once memory" ), - - // Status-dependent callbacks - statusCode = s.statusCode || {}, - - // Headers (they are sent all at once) - requestHeaders = {}, - requestHeadersNames = {}, - - // Default abort message - strAbort = "canceled", - - // Fake xhr - jqXHR = { - readyState: 0, - - // Builds headers hashtable if needed - getResponseHeader: function( key ) { - var match; - if ( completed ) { - if ( !responseHeaders ) { - responseHeaders = {}; - while ( ( match = rheaders.exec( responseHeadersString ) ) ) { - responseHeaders[ match[ 1 ].toLowerCase() + " " ] = - ( responseHeaders[ match[ 1 ].toLowerCase() + " " ] || [] ) - .concat( match[ 2 ] ); - } - } - match = responseHeaders[ key.toLowerCase() + " " ]; - } - return match == null ? null : match.join( ", " ); - }, - - // Raw string - getAllResponseHeaders: function() { - return completed ? responseHeadersString : null; - }, - - // Caches the header - setRequestHeader: function( name, value ) { - if ( completed == null ) { - name = requestHeadersNames[ name.toLowerCase() ] = - requestHeadersNames[ name.toLowerCase() ] || name; - requestHeaders[ name ] = value; - } - return this; - }, - - // Overrides response content-type header - overrideMimeType: function( type ) { - if ( completed == null ) { - s.mimeType = type; - } - return this; - }, - - // Status-dependent callbacks - statusCode: function( map ) { - var code; - if ( map ) { - if ( completed ) { - - // Execute the appropriate callbacks - jqXHR.always( map[ jqXHR.status ] ); - } else { - - // Lazy-add the new callbacks in a way that preserves old ones - for ( code in map ) { - statusCode[ code ] = [ statusCode[ code ], map[ code ] ]; - } - } - } - return this; - }, - - // Cancel the request - abort: function( statusText ) { - var finalText = statusText || strAbort; - if ( transport ) { - transport.abort( finalText ); - } - done( 0, finalText ); - return this; - } - }; - - // Attach deferreds - deferred.promise( jqXHR ); - - // Add protocol if not provided (prefilters might expect it) - // Handle falsy url in the settings object (#10093: consistency with old signature) - // We also use the url parameter if available - s.url = ( ( url || s.url || location.href ) + "" ) - .replace( rprotocol, location.protocol + "//" ); - - // Alias method option to type as per ticket #12004 - s.type = options.method || options.type || s.method || s.type; - - // Extract dataTypes list - s.dataTypes = ( s.dataType || "*" ).toLowerCase().match( rnothtmlwhite ) || [ "" ]; - - // A cross-domain request is in order when the origin doesn't match the current origin. - if ( s.crossDomain == null ) { - urlAnchor = document.createElement( "a" ); - - // Support: IE <=8 - 11, Edge 12 - 15 - // IE throws exception on accessing the href property if url is malformed, - // e.g. http://example.com:80x/ - try { - urlAnchor.href = s.url; - - // Support: IE <=8 - 11 only - // Anchor's host property isn't correctly set when s.url is relative - urlAnchor.href = urlAnchor.href; - s.crossDomain = originAnchor.protocol + "//" + originAnchor.host !== - urlAnchor.protocol + "//" + urlAnchor.host; - } catch ( e ) { - - // If there is an error parsing the URL, assume it is crossDomain, - // it can be rejected by the transport if it is invalid - s.crossDomain = true; - } - } - - // Convert data if not already a string - if ( s.data && s.processData && typeof s.data !== "string" ) { - s.data = jQuery.param( s.data, s.traditional ); - } - - // Apply prefilters - inspectPrefiltersOrTransports( prefilters, s, options, jqXHR ); - - // If request was aborted inside a prefilter, stop there - if ( completed ) { - return jqXHR; - } - - // We can fire global events as of now if asked to - // Don't fire events if jQuery.event is undefined in an AMD-usage scenario (#15118) - fireGlobals = jQuery.event && s.global; - - // Watch for a new set of requests - if ( fireGlobals && jQuery.active++ === 0 ) { - jQuery.event.trigger( "ajaxStart" ); - } - - // Uppercase the type - s.type = s.type.toUpperCase(); - - // Determine if request has content - s.hasContent = !rnoContent.test( s.type ); - - // Save the URL in case we're toying with the If-Modified-Since - // and/or If-None-Match header later on - // Remove hash to simplify url manipulation - cacheURL = s.url.replace( rhash, "" ); - - // More options handling for requests with no content - if ( !s.hasContent ) { - - // Remember the hash so we can put it back - uncached = s.url.slice( cacheURL.length ); - - // If data is available and should be processed, append data to url - if ( s.data && ( s.processData || typeof s.data === "string" ) ) { - cacheURL += ( rquery.test( cacheURL ) ? "&" : "?" ) + s.data; - - // #9682: remove data so that it's not used in an eventual retry - delete s.data; - } - - // Add or update anti-cache param if needed - if ( s.cache === false ) { - cacheURL = cacheURL.replace( rantiCache, "$1" ); - uncached = ( rquery.test( cacheURL ) ? "&" : "?" ) + "_=" + ( nonce.guid++ ) + - uncached; - } - - // Put hash and anti-cache on the URL that will be requested (gh-1732) - s.url = cacheURL + uncached; - - // Change '%20' to '+' if this is encoded form body content (gh-2658) - } else if ( s.data && s.processData && - ( s.contentType || "" ).indexOf( "application/x-www-form-urlencoded" ) === 0 ) { - s.data = s.data.replace( r20, "+" ); - } - - // Set the If-Modified-Since and/or If-None-Match header, if in ifModified mode. - if ( s.ifModified ) { - if ( jQuery.lastModified[ cacheURL ] ) { - jqXHR.setRequestHeader( "If-Modified-Since", jQuery.lastModified[ cacheURL ] ); - } - if ( jQuery.etag[ cacheURL ] ) { - jqXHR.setRequestHeader( "If-None-Match", jQuery.etag[ cacheURL ] ); - } - } - - // Set the correct header, if data is being sent - if ( s.data && s.hasContent && s.contentType !== false || options.contentType ) { - jqXHR.setRequestHeader( "Content-Type", s.contentType ); - } - - // Set the Accepts header for the server, depending on the dataType - jqXHR.setRequestHeader( - "Accept", - s.dataTypes[ 0 ] && s.accepts[ s.dataTypes[ 0 ] ] ? - s.accepts[ s.dataTypes[ 0 ] ] + - ( s.dataTypes[ 0 ] !== "*" ? ", " + allTypes + "; q=0.01" : "" ) : - s.accepts[ "*" ] - ); - - // Check for headers option - for ( i in s.headers ) { - jqXHR.setRequestHeader( i, s.headers[ i ] ); - } - - // Allow custom headers/mimetypes and early abort - if ( s.beforeSend && - ( s.beforeSend.call( callbackContext, jqXHR, s ) === false || completed ) ) { - - // Abort if not done already and return - return jqXHR.abort(); - } - - // Aborting is no longer a cancellation - strAbort = "abort"; - - // Install callbacks on deferreds - completeDeferred.add( s.complete ); - jqXHR.done( s.success ); - jqXHR.fail( s.error ); - - // Get transport - transport = inspectPrefiltersOrTransports( transports, s, options, jqXHR ); - - // If no transport, we auto-abort - if ( !transport ) { - done( -1, "No Transport" ); - } else { - jqXHR.readyState = 1; - - // Send global event - if ( fireGlobals ) { - globalEventContext.trigger( "ajaxSend", [ jqXHR, s ] ); - } - - // If request was aborted inside ajaxSend, stop there - if ( completed ) { - return jqXHR; - } - - // Timeout - if ( s.async && s.timeout > 0 ) { - timeoutTimer = window.setTimeout( function() { - jqXHR.abort( "timeout" ); - }, s.timeout ); - } - - try { - completed = false; - transport.send( requestHeaders, done ); - } catch ( e ) { - - // Rethrow post-completion exceptions - if ( completed ) { - throw e; - } - - // Propagate others as results - done( -1, e ); - } - } - - // Callback for when everything is done - function done( status, nativeStatusText, responses, headers ) { - var isSuccess, success, error, response, modified, - statusText = nativeStatusText; - - // Ignore repeat invocations - if ( completed ) { - return; - } - - completed = true; - - // Clear timeout if it exists - if ( timeoutTimer ) { - window.clearTimeout( timeoutTimer ); - } - - // Dereference transport for early garbage collection - // (no matter how long the jqXHR object will be used) - transport = undefined; - - // Cache response headers - responseHeadersString = headers || ""; - - // Set readyState - jqXHR.readyState = status > 0 ? 4 : 0; - - // Determine if successful - isSuccess = status >= 200 && status < 300 || status === 304; - - // Get response data - if ( responses ) { - response = ajaxHandleResponses( s, jqXHR, responses ); - } - - // Use a noop converter for missing script - if ( !isSuccess && jQuery.inArray( "script", s.dataTypes ) > -1 ) { - s.converters[ "text script" ] = function() {}; - } - - // Convert no matter what (that way responseXXX fields are always set) - response = ajaxConvert( s, response, jqXHR, isSuccess ); - - // If successful, handle type chaining - if ( isSuccess ) { - - // Set the If-Modified-Since and/or If-None-Match header, if in ifModified mode. - if ( s.ifModified ) { - modified = jqXHR.getResponseHeader( "Last-Modified" ); - if ( modified ) { - jQuery.lastModified[ cacheURL ] = modified; - } - modified = jqXHR.getResponseHeader( "etag" ); - if ( modified ) { - jQuery.etag[ cacheURL ] = modified; - } - } - - // if no content - if ( status === 204 || s.type === "HEAD" ) { - statusText = "nocontent"; - - // if not modified - } else if ( status === 304 ) { - statusText = "notmodified"; - - // If we have data, let's convert it - } else { - statusText = response.state; - success = response.data; - error = response.error; - isSuccess = !error; - } - } else { - - // Extract error from statusText and normalize for non-aborts - error = statusText; - if ( status || !statusText ) { - statusText = "error"; - if ( status < 0 ) { - status = 0; - } - } - } - - // Set data for the fake xhr object - jqXHR.status = status; - jqXHR.statusText = ( nativeStatusText || statusText ) + ""; - - // Success/Error - if ( isSuccess ) { - deferred.resolveWith( callbackContext, [ success, statusText, jqXHR ] ); - } else { - deferred.rejectWith( callbackContext, [ jqXHR, statusText, error ] ); - } - - // Status-dependent callbacks - jqXHR.statusCode( statusCode ); - statusCode = undefined; - - if ( fireGlobals ) { - globalEventContext.trigger( isSuccess ? "ajaxSuccess" : "ajaxError", - [ jqXHR, s, isSuccess ? success : error ] ); - } - - // Complete - completeDeferred.fireWith( callbackContext, [ jqXHR, statusText ] ); - - if ( fireGlobals ) { - globalEventContext.trigger( "ajaxComplete", [ jqXHR, s ] ); - - // Handle the global AJAX counter - if ( !( --jQuery.active ) ) { - jQuery.event.trigger( "ajaxStop" ); - } - } - } - - return jqXHR; - }, - - getJSON: function( url, data, callback ) { - return jQuery.get( url, data, callback, "json" ); - }, - - getScript: function( url, callback ) { - return jQuery.get( url, undefined, callback, "script" ); - } -} ); - -jQuery.each( [ "get", "post" ], function( _i, method ) { - jQuery[ method ] = function( url, data, callback, type ) { - - // Shift arguments if data argument was omitted - if ( isFunction( data ) ) { - type = type || callback; - callback = data; - data = undefined; - } - - // The url can be an options object (which then must have .url) - return jQuery.ajax( jQuery.extend( { - url: url, - type: method, - dataType: type, - data: data, - success: callback - }, jQuery.isPlainObject( url ) && url ) ); - }; -} ); - -jQuery.ajaxPrefilter( function( s ) { - var i; - for ( i in s.headers ) { - if ( i.toLowerCase() === "content-type" ) { - s.contentType = s.headers[ i ] || ""; - } - } -} ); - - -jQuery._evalUrl = function( url, options, doc ) { - return jQuery.ajax( { - url: url, - - // Make this explicit, since user can override this through ajaxSetup (#11264) - type: "GET", - dataType: "script", - cache: true, - async: false, - global: false, - - // Only evaluate the response if it is successful (gh-4126) - // dataFilter is not invoked for failure responses, so using it instead - // of the default converter is kludgy but it works. - converters: { - "text script": function() {} - }, - dataFilter: function( response ) { - jQuery.globalEval( response, options, doc ); - } - } ); -}; - - -jQuery.fn.extend( { - wrapAll: function( html ) { - var wrap; - - if ( this[ 0 ] ) { - if ( isFunction( html ) ) { - html = html.call( this[ 0 ] ); - } - - // The elements to wrap the target around - wrap = jQuery( html, this[ 0 ].ownerDocument ).eq( 0 ).clone( true ); - - if ( this[ 0 ].parentNode ) { - wrap.insertBefore( this[ 0 ] ); - } - - wrap.map( function() { - var elem = this; - - while ( elem.firstElementChild ) { - elem = elem.firstElementChild; - } - - return elem; - } ).append( this ); - } - - return this; - }, - - wrapInner: function( html ) { - if ( isFunction( html ) ) { - return this.each( function( i ) { - jQuery( this ).wrapInner( html.call( this, i ) ); - } ); - } - - return this.each( function() { - var self = jQuery( this ), - contents = self.contents(); - - if ( contents.length ) { - contents.wrapAll( html ); - - } else { - self.append( html ); - } - } ); - }, - - wrap: function( html ) { - var htmlIsFunction = isFunction( html ); - - return this.each( function( i ) { - jQuery( this ).wrapAll( htmlIsFunction ? html.call( this, i ) : html ); - } ); - }, - - unwrap: function( selector ) { - this.parent( selector ).not( "body" ).each( function() { - jQuery( this ).replaceWith( this.childNodes ); - } ); - return this; - } -} ); - - -jQuery.expr.pseudos.hidden = function( elem ) { - return !jQuery.expr.pseudos.visible( elem ); -}; -jQuery.expr.pseudos.visible = function( elem ) { - return !!( elem.offsetWidth || elem.offsetHeight || elem.getClientRects().length ); -}; - - - - -jQuery.ajaxSettings.xhr = function() { - try { - return new window.XMLHttpRequest(); - } catch ( e ) {} -}; - -var xhrSuccessStatus = { - - // File protocol always yields status code 0, assume 200 - 0: 200, - - // Support: IE <=9 only - // #1450: sometimes IE returns 1223 when it should be 204 - 1223: 204 - }, - xhrSupported = jQuery.ajaxSettings.xhr(); - -support.cors = !!xhrSupported && ( "withCredentials" in xhrSupported ); -support.ajax = xhrSupported = !!xhrSupported; - -jQuery.ajaxTransport( function( options ) { - var callback, errorCallback; - - // Cross domain only allowed if supported through XMLHttpRequest - if ( support.cors || xhrSupported && !options.crossDomain ) { - return { - send: function( headers, complete ) { - var i, - xhr = options.xhr(); - - xhr.open( - options.type, - options.url, - options.async, - options.username, - options.password - ); - - // Apply custom fields if provided - if ( options.xhrFields ) { - for ( i in options.xhrFields ) { - xhr[ i ] = options.xhrFields[ i ]; - } - } - - // Override mime type if needed - if ( options.mimeType && xhr.overrideMimeType ) { - xhr.overrideMimeType( options.mimeType ); - } - - // X-Requested-With header - // For cross-domain requests, seeing as conditions for a preflight are - // akin to a jigsaw puzzle, we simply never set it to be sure. - // (it can always be set on a per-request basis or even using ajaxSetup) - // For same-domain requests, won't change header if already provided. - if ( !options.crossDomain && !headers[ "X-Requested-With" ] ) { - headers[ "X-Requested-With" ] = "XMLHttpRequest"; - } - - // Set headers - for ( i in headers ) { - xhr.setRequestHeader( i, headers[ i ] ); - } - - // Callback - callback = function( type ) { - return function() { - if ( callback ) { - callback = errorCallback = xhr.onload = - xhr.onerror = xhr.onabort = xhr.ontimeout = - xhr.onreadystatechange = null; - - if ( type === "abort" ) { - xhr.abort(); - } else if ( type === "error" ) { - - // Support: IE <=9 only - // On a manual native abort, IE9 throws - // errors on any property access that is not readyState - if ( typeof xhr.status !== "number" ) { - complete( 0, "error" ); - } else { - complete( - - // File: protocol always yields status 0; see #8605, #14207 - xhr.status, - xhr.statusText - ); - } - } else { - complete( - xhrSuccessStatus[ xhr.status ] || xhr.status, - xhr.statusText, - - // Support: IE <=9 only - // IE9 has no XHR2 but throws on binary (trac-11426) - // For XHR2 non-text, let the caller handle it (gh-2498) - ( xhr.responseType || "text" ) !== "text" || - typeof xhr.responseText !== "string" ? - { binary: xhr.response } : - { text: xhr.responseText }, - xhr.getAllResponseHeaders() - ); - } - } - }; - }; - - // Listen to events - xhr.onload = callback(); - errorCallback = xhr.onerror = xhr.ontimeout = callback( "error" ); - - // Support: IE 9 only - // Use onreadystatechange to replace onabort - // to handle uncaught aborts - if ( xhr.onabort !== undefined ) { - xhr.onabort = errorCallback; - } else { - xhr.onreadystatechange = function() { - - // Check readyState before timeout as it changes - if ( xhr.readyState === 4 ) { - - // Allow onerror to be called first, - // but that will not handle a native abort - // Also, save errorCallback to a variable - // as xhr.onerror cannot be accessed - window.setTimeout( function() { - if ( callback ) { - errorCallback(); - } - } ); - } - }; - } - - // Create the abort callback - callback = callback( "abort" ); - - try { - - // Do send the request (this may raise an exception) - xhr.send( options.hasContent && options.data || null ); - } catch ( e ) { - - // #14683: Only rethrow if this hasn't been notified as an error yet - if ( callback ) { - throw e; - } - } - }, - - abort: function() { - if ( callback ) { - callback(); - } - } - }; - } -} ); - - - - -// Prevent auto-execution of scripts when no explicit dataType was provided (See gh-2432) -jQuery.ajaxPrefilter( function( s ) { - if ( s.crossDomain ) { - s.contents.script = false; - } -} ); - -// Install script dataType -jQuery.ajaxSetup( { - accepts: { - script: "text/javascript, application/javascript, " + - "application/ecmascript, application/x-ecmascript" - }, - contents: { - script: /\b(?:java|ecma)script\b/ - }, - converters: { - "text script": function( text ) { - jQuery.globalEval( text ); - return text; - } - } -} ); - -// Handle cache's special case and crossDomain -jQuery.ajaxPrefilter( "script", function( s ) { - if ( s.cache === undefined ) { - s.cache = false; - } - if ( s.crossDomain ) { - s.type = "GET"; - } -} ); - -// Bind script tag hack transport -jQuery.ajaxTransport( "script", function( s ) { - - // This transport only deals with cross domain or forced-by-attrs requests - if ( s.crossDomain || s.scriptAttrs ) { - var script, callback; - return { - send: function( _, complete ) { - script = jQuery( " - - - + - - - - - - - - + - - - +
- -
- - -
- - - - - - - - - + \ No newline at end of file diff --git a/docs/RefMan/_build/html/search.html b/docs/RefMan/_build/html/search.html index 019a47816..c6df46639 100644 --- a/docs/RefMan/_build/html/search.html +++ b/docs/RefMan/_build/html/search.html @@ -1,65 +1,34 @@ - - - - + - - - - + + Search — Cryptol 2.11.0 documentation - - - - - - - - - - + + - + + + - - - - - - - - - + + + - - - +
- -
- - -
- - - - - - - - - - - + diff --git a/docs/RefMan/_build/html/searchindex.js b/docs/RefMan/_build/html/searchindex.js index bdab3b3a3..5a40b6437 100644 --- a/docs/RefMan/_build/html/searchindex.js +++ b/docs/RefMan/_build/html/searchindex.js @@ -1 +1 @@ -Search.setIndex({docnames:["BasicSyntax","BasicTypes","Expressions","FFI","Modules","OverloadedOperations","RefMan","TypeDeclarations"],envversion:{"sphinx.domains.c":2,"sphinx.domains.changeset":1,"sphinx.domains.citation":1,"sphinx.domains.cpp":3,"sphinx.domains.index":1,"sphinx.domains.javascript":2,"sphinx.domains.math":2,"sphinx.domains.python":2,"sphinx.domains.rst":2,"sphinx.domains.std":2,"sphinx.ext.todo":2,sphinx:56},filenames:["BasicSyntax.rst","BasicTypes.rst","Expressions.rst","FFI.rst","Modules.rst","OverloadedOperations.rst","RefMan.rst","TypeDeclarations.rst"],objects:{},objnames:{},objtypes:{},terms:{"0254":0,"0b1010":0,"0b1010111":0,"0b11010":0,"0b11111110":0,"0b_0000_0010":0,"0o1234":0,"0o376":0,"0x00000003":3,"0x01":4,"0x02":4,"0x03":4,"0x04":4,"0x0f":3,"0x1234":0,"0x30":0,"0x_ffff_ffea":0,"0xaf":3,"0xf":3,"0xfe":0,"100":1,"1p4":0,"254":0,"2e3":0,"case":[3,4],"float":[0,6],"function":[0,4,6,7],"import":[0,1,2,6],"long":0,"new":[4,7],"public":4,"return":6,"static":[0,3],"true":[1,3],"try":[3,4],"void":3,"while":[0,1,3],Adding:4,For:[0,1,2,3,4,7],Such:[0,4],That:3,The:[0,1,2,3,4],Then:[3,4],There:[0,1],These:3,Uses:4,Using:[0,4],abbrevi:1,abl:4,about:4,abov:[2,3,4],abs:5,access:[2,3,6],accommod:2,across:[3,4],actual:[0,3],add:[3,4],added:[2,3,4],addit:[0,4],adjac:3,after:3,alias:0,all:[0,2,3,4,7],alloc:3,allow:[0,3,4,7],along:3,alphabet:1,alreadi:3,also:[0,1,3,4],alwai:3,ani:[3,4,7],annot:6,anonym:6,anoth:4,appear:[1,7],appli:[0,3],applic:2,appropri:3,arbitrari:3,arbitrarili:0,argument:[3,6,7],arithmet:[1,6],arr:1,arrai:3,associ:0,assum:0,assumpt:[0,4],attempt:0,automat:[2,3],avoid:4,awai:4,back:1,backtick:2,baddef:1,base:[0,2],basic:6,becaus:[0,3,4],befor:[3,4],begin:0,behav:3,behavior:[0,1,3],being:4,belong:0,between:[0,6],binari:[0,3],bind:[1,3],bit:[0,1,2,4,5,6],bitvector:1,block:[0,6],bodi:[3,7],both:[1,3,4],bound:[1,3],brace:1,branch:[0,2],bring:[4,7],built:[3,6],call:[1,3,4,6],can:[0,1,2,3,4,7],cannot:[0,2],care:3,ceil:[0,5],certain:3,chang:0,charact:0,check:[0,3],checker:[0,7],chosen:2,clash:4,claus:4,clear:3,close:0,closest:0,cmp:5,code:[4,6],collect:[1,7],collis:4,combin:4,comma:1,command:3,comment:6,compar:1,comparison:6,compil:6,complement:5,complex:1,compon:[1,3],comprehens:1,comput:[0,1],concaten:1,concret:4,condit:6,consid:[0,4,7],consist:0,constant:[3,4],constrain:0,constraint:6,construct:[1,2,4],contain:[0,1,3,4],content:4,context:[0,2],contigu:3,control:0,conveni:4,convent:3,convers:3,convert:6,correct:3,correspond:[2,3],could:3,coupl:4,cours:4,creat:7,cry:[3,4],cryptol:[0,2,4],cryptolpath:4,cumbersom:[3,4],curli:1,current:3,curri:3,data:1,dealloc:3,decim:0,decis:0,declar:[3,4,6],defin:[0,1,3,4,7],definit:[0,1,2,4],defint:2,degre:0,demot:[0,6],depend:[0,3],deriv:4,describ:[3,4],descript:1,desrib:4,determin:[0,1],differ:[0,3,4],digit:0,dimens:3,dimension:1,directli:[3,7],directori:[3,4],distance2:1,distinct:7,divis:[0,6],dll:3,document:[0,4],doe:[0,3],don:3,done:[3,4],doubl:3,down:[0,1],downward:1,drop:0,dylib:3,dynam:3,dynamiclib:3,e11:1,e12:1,e21:1,e22:1,each:[0,3,4,7],earlier:3,easi:4,easier:4,effect:0,either:[0,3,4],element:[1,2,3],els:[0,2,4],empti:3,enclos:[1,4],end:[0,4],english:0,enough:3,entri:1,enumer:1,environment:0,equal:[0,1,6,7],equat:1,equival:4,error:[3,4],etc:0,evalu:[2,6],even:[0,7],everi:7,everyth:4,exact:3,examin:1,exampl:[0,1,2,4,6],except:[0,3,4],exclus:1,exhaust:0,exist:[4,7],expand:3,explicit:[1,4,6],explicitli:[0,3],expon:0,exponenti:0,express:[0,1,4,6,7],extend:4,extens:3,extern:0,extra:3,extract:7,fact:0,fals:[1,3],famili:0,featur:4,few:4,ffi:3,field:[3,5,6,7],file:[3,4],fill:4,fin:[0,3,4],finit:[1,2],first:[0,1,3,4],fit:3,fix:[0,1,3],flatten:3,float32:3,float64:3,floor:5,follow:[0,1,2,3,4],foo:3,foreign:6,form:7,fpic:3,fraction:0,from:[0,1,2,3,4],frominteg:5,front:1,fulli:3,functoin:0,functor:4,furthermor:3,gener:[1,3],get:1,getfst:1,given:3,glu:4,gmp:3,good:4,group:[0,4,7],guard:6,had:7,handi:1,handl:3,happen:4,has:[0,1,2,3],hash:4,have:[0,1,2,3,4,7],header:3,help:[3,4],helper1:4,helper2:4,helper:4,here:[0,2,4],hexadecim:0,hide:[0,6],hierarch:6,high:3,highest:0,hold:[1,3],how:3,howev:3,identifi:[1,4,6],ignor:3,impl1:4,impl2:4,impl:4,implement:[3,4],implicit:6,implict:0,impos:4,improv:[0,3],in0:3,in1_a:3,in1_b:3,includ:[0,3],indent:[0,4],independ:0,index:1,individu:3,inf:[1,5],infer:[0,2],inffrom:5,inffromthen:5,infinit:1,infix:[0,6],infixl:0,infixr:0,inform:1,init:3,input:3,instanc:3,instanti:6,instead:[0,3,4,7],insuffici:1,integ:[0,2,3,5,7],integr:[3,6],intend:4,interfac:[0,6],introduc:4,invalid:1,involv:3,irrelev:7,isposit:1,issu:0,its:[0,3,4],itself:[3,4],just:[3,4,7],keword:4,keyword:[4,6],kind:[2,3],know:3,known:1,label:1,lambda:[1,2],languag:[0,3],larg:[2,3],larger:3,last:[0,2,3],layout:[4,6],left:[0,1],len:0,length:[0,1],less:0,let:[0,3],letter:0,level:[4,6],lexicograph:1,lg2:0,libffi:3,librari:3,lift:1,like:[3,4,7],limit:3,line:[0,4,7],link:4,linux:3,list:[0,3,6],liter:[2,6],load:3,local:[0,4,6],locat:[1,4],logarithm:0,logic:6,longer_nam:0,longernam:0,look:[3,4],lowest:0,maco:3,mai:[0,1,2,3,4,7],main:[3,4],make:4,manag:[3,6],mani:[3,4],manual:3,map:3,mark:0,match:[0,1,3],math:6,matter:3,max:[0,5],maximum:0,mayb:4,mean:[0,3],member:7,memori:6,mention:[3,7],might:4,min:[0,5],minimum:0,mirror:1,modifi:3,modul:[0,3,6],modulu:0,more:[0,4],moreov:7,most:[1,4],mpq_t:3,mpz_q:3,mpz_t:3,multidimension:3,multipl:[0,1,2,3,4],must:[0,3,4],myf:4,name1:0,name2:0,name:[0,1,3,6,7],need:[0,2,3,4],negat:5,nest:[0,1,3,6],newt:7,newtyp:[0,4,6],non:[0,3],nonzero:3,notat:[0,1,2,4],note:[1,3,4],noth:4,notion:4,now:3,number:[0,1,2,3],numer:[3,4,6],obtain:[1,3,4],occasion:4,octal:0,often:1,old:1,onc:[3,4],one:[0,2,3,4],onli:[0,1,3,4,7],open:0,oper:[3,6],option:[0,7],order:[1,3,4],ordinari:4,organ:0,other:[0,3,4,7],otherwis:7,our:3,out:3,out_0:3,out_1:3,outer:4,output:3,outsid:4,over:0,overal:6,overload:[0,6],overview:2,p11:1,p12:1,p21:1,p22:1,packag:1,pad:[0,3],pair:2,paramet:[0,2,6],parameter:6,paren:2,parenthes:1,parmaet:4,part:4,pass:[2,3,6],pattern:[1,2],piec:3,place:4,platform:6,point:[1,6],pointer:3,pointwis:1,polymorph:[2,3],polynomi:0,portabl:3,posit:1,possibl:[2,3,4],practic:[3,4],pragma:0,pre:7,preced:[2,4],precis:[0,3],prefix:[0,4,6],presum:4,previou:[0,4],prime:0,primit:0,primtiv:2,principl:0,privat:[0,6],process:3,program:1,programm:0,project:7,properti:0,prototyp:3,prove:0,provid:[0,2,4],purpos:[1,7],qualifi:6,quick:6,quickli:1,quit:[0,1,4],rather:0,ration:[0,3],read:3,readabl:[0,3],recip:5,record:[6,7],recurs:[3,4,7],reduc:4,refer:4,reject:0,rel:1,relat:4,remain:4,repl:1,repres:[0,3],represent:[0,3],requir:[0,3,4],respect:3,result:[0,1,2,3,4],right:[0,1],ring:5,rotat:1,round:[0,6],roundawai:5,roundtoeven:5,rule:3,runtim:3,same:[0,1,3,4,7],satisfi:[0,3],scope:[2,4,7],search:4,section:[2,3,4],see:[0,4],selector:1,semant:4,separ:[1,4],seq:7,sequenc:[0,6],set:[0,1,3],sha256:4,shadow:4,shape:1,share:3,shift:1,should:[0,1,2,3],sign:[1,6],signatur:[3,6],signedcmp:5,similar:[0,3],similarli:1,simpl:[3,4],simpli:0,sinc:[3,4],singl:4,site:7,situat:4,size:[0,1,3],size_t:3,slight:4,smaller:3,some:[0,4],someth:3,sometim:4,somewher:4,sourc:[3,4],special:0,specif:3,specifi:[0,2,4],split:[1,3],standard:3,start:[0,1],statement:0,step:[1,4],still:3,store:3,straight:4,stream:1,stride:1,structur:[4,6],sub:[1,4],submdul:4,submodul:[0,4],submould:4,subtract:0,suffici:[1,2],sugar:[2,4],suitabl:2,sum:7,sumbodul:4,support:[0,4,6],suppos:3,sure:4,symbol:[0,3,4],synonym:[4,6],syntact:4,syntax:[1,2,6],system:[3,4],tabl:[0,3],take:3,tend:4,term:0,termin:0,test:3,text:0,than:[0,3,4],thei:[0,1,3,4,7],them:4,themselv:3,thi:[0,1,2,3,4],thing:4,those:[1,4],though:7,three:1,through:[1,6],thu:[1,4],time:4,togeth:[1,4],tointeg:5,too:3,top:[3,4],translat:3,transpar:7,treat:[3,4,7],trunc:5,tupl:6,two:[0,1,2,4,7],typaram:2,type:[4,6],typecheck:7,typeclass:7,uint16_t:3,uint32_t:3,uint64_t:3,uint8_t:3,unari:[0,2],undefin:3,underscor:0,understand:[3,4],unfold:7,uniniti:3,unlik:7,upcom:4,updat:6,updateend:1,updatesend:1,usag:6,use:[0,1,3,4,7],used:[0,1,2,3,4,7],useful:4,user:7,uses:[3,4],using:[0,1,2,3,4],usual:2,valid:1,valu:[0,1,4,6,7],variabl:[2,3],variant:4,variat:4,varieti:0,vector:6,version:3,via:1,wai:[1,3,4],want:[3,4],warn:0,warnnonexhaustiveconstraintguard:0,weakest:2,what:3,when:[0,1,2,3,4],where:[0,1,2,3,4],wherea:1,which:[0,2,3,4,7],whole:[2,3,4],width:[0,4],window:3,wise:1,withing:4,without:4,word:[1,3],work:[3,4],worth:3,would:[3,4,7],write:[0,1,3],written:[0,1,2,3,7],xpo:1,yet:4,you:[2,3,4],your:3,ypo:1,zero:[2,3,6]},titles:["Basic Syntax","Basic Types","Expressions","Foreign Function Interface","Modules","Overloaded Operations","Cryptol Reference Manual","Type Declarations"],titleterms:{"float":3,"function":[1,2,3],"import":4,"return":3,access:1,annot:2,anonym:4,argument:[2,4],arithmet:5,basic:[0,1,3,5],between:3,bit:3,block:[2,4],built:0,call:2,code:3,comment:0,comparison:5,compil:3,condit:2,constraint:[0,4],convert:3,cryptol:[3,6],declar:[0,2,7],demot:2,divis:5,equal:5,evalu:3,exampl:3,explicit:2,express:2,field:1,foreign:3,guard:0,hide:4,hierarch:4,identifi:0,implicit:4,infix:2,instanti:[2,4],integr:5,interfac:[3,4],keyword:0,layout:0,level:0,list:4,liter:0,local:2,logic:5,manag:4,manual:6,math:3,memori:3,modul:4,name:4,nest:4,newtyp:7,numer:[0,2],oper:[0,1,2,5],overal:3,overload:5,paramet:[3,4],parameter:4,pass:4,platform:3,point:3,preced:0,prefix:2,privat:4,qualifi:4,quick:3,record:[1,3],refer:[3,6],round:5,sequenc:[1,3],sign:5,signatur:0,structur:3,support:3,synonym:[3,7],syntax:0,through:4,todo:[0,2],tupl:[1,3],type:[0,1,2,3,7],updat:1,usag:3,valu:[2,3],vector:3,zero:5}}) \ No newline at end of file +Search.setIndex({docnames:["BasicSyntax","BasicTypes","Expressions","FFI","Modules","OverloadedOperations","RefMan","TypeDeclarations"],envversion:{"sphinx.domains.c":2,"sphinx.domains.changeset":1,"sphinx.domains.citation":1,"sphinx.domains.cpp":4,"sphinx.domains.index":1,"sphinx.domains.javascript":2,"sphinx.domains.math":2,"sphinx.domains.python":3,"sphinx.domains.rst":2,"sphinx.domains.std":2,"sphinx.ext.todo":2,sphinx:56},filenames:["BasicSyntax.rst","BasicTypes.rst","Expressions.rst","FFI.rst","Modules.rst","OverloadedOperations.rst","RefMan.rst","TypeDeclarations.rst"],objects:{},objnames:{},objtypes:{},terms:{"0":[0,1,2,3],"0254":0,"0b":0,"0b1010":0,"0b1010111":0,"0b11010":0,"0b11111110":0,"0b_0000_0010":0,"0o":0,"0o1234":0,"0o376":0,"0x":0,"0x00000003":3,"0x01":4,"0x02":4,"0x03":4,"0x04":4,"0x0f":3,"0x1234":0,"0x30":0,"0x_ffff_ffea":0,"0xaf":3,"0xf":3,"0xfe":0,"1":[0,1,2,3,4,7],"10":[0,1,3,4],"100":1,"11":4,"12":[0,4],"13":2,"15":1,"16":[0,3],"1p4":0,"2":[0,1,2,3,4,7],"20":[1,3],"22":2,"25":1,"254":0,"26":4,"2e3":0,"3":[0,1,2,4,7],"30":[1,4],"32":[3,4],"33":2,"4":[0,3],"5":[0,1,2,4],"6":[0,7],"64":[0,3],"7":[0,2,4],"8":[2,3,4],"9":2,"case":[3,4],"do":[0,2,3,4,7],"float":[0,6],"function":[0,4,6,7],"import":[0,1,2,6],"long":0,"new":[4,7],"public":4,"return":6,"static":[0,3],"true":[1,3],"try":[3,4],"void":3,"while":[0,1,3],A:[0,1,3,4,7],For:[0,1,2,3,4,7],If:[2,3,4],In:[3,4],It:[3,4],On:3,Such:[0,4],That:3,The:[0,1,2,3,4],Then:[3,4],There:[0,1],These:3,To:4,_:[0,1],a1:3,ab:5,abbrevi:1,abl:4,about:4,abov:[2,3,4],access:[2,3,6],accommod:2,across:[3,4],actual:[0,3],ad:[2,3,4],add:[3,4],addit:[0,4],adjac:3,after:3,ak:3,alias:0,all:[0,2,3,4,7],alloc:3,allow:[0,3,4,7],along:3,alphabet:1,alreadi:3,also:[0,1,3,4],alwai:3,an:[0,1,2,3,6],ani:[3,4,7],annot:6,anonym:6,anoth:4,appear:[1,7],appli:[0,3],applic:2,appropri:3,ar:[0,1,2,3,4,7],arbitrari:3,arbitrarili:0,argument:[3,6,7],arithmet:[1,6],arr:1,arrai:3,associ:0,assum:0,assumpt:[0,4],attempt:0,automat:[2,3],avoid:4,awai:4,b:[0,3,4,5,7],back:1,backtick:2,baddef:1,base:[0,2],basic:6,becaus:[0,3,4],befor:[3,4],begin:0,behav:3,behavior:[0,1,3],being:4,belong:0,between:[0,6],binari:[0,3],bind:[1,3],bit:[0,1,2,4,5,6],bitvector:1,block:[0,6],bodi:[3,7],both:[1,3,4],bound:[1,3],brace:1,branch:[0,2],bring:[4,7],built:[3,6],c1:3,c:6,call:[1,3,4,6],can:[0,1,2,3,4,7],cannot:[0,2],care:3,cc:3,ceil:[0,5],certain:3,chang:0,charact:0,check:[0,3],checker:[0,7],chosen:2,clash:4,claus:4,clear:3,close:0,closest:0,cmp:5,cn:3,code:[4,6],collect:[1,7],collis:4,combin:4,comma:1,command:3,comment:6,compar:1,comparison:6,compil:6,complement:5,complex:1,compon:[1,3],comprehens:1,comput:[0,1],concaten:1,concret:4,condit:6,consid:[0,4,7],consist:0,constant:[3,4],constrain:0,constraint:6,construct:[1,2,4],contain:[0,1,3,4],content:4,context:[0,2],contigu:3,control:0,conveni:4,convent:3,convers:3,convert:6,correct:3,correspond:[2,3],could:3,coupl:4,cours:4,creat:7,cry:[3,4],cryptol:[0,2,4],cryptolpath:4,cumbersom:[3,4],curli:1,current:3,curri:3,data:1,dealloc:3,decim:0,decis:0,declar:[3,4,6],defin:[0,1,3,4,7],definit:[0,1,2,4],defint:2,degre:0,demot:[0,6],depend:[0,3],deriv:4,describ:[3,4],descript:1,desrib:4,determin:[0,1],differ:[0,3,4],digit:0,dimens:3,dimension:1,directli:[3,7],directori:[3,4],distance2:1,distinct:7,divis:[0,6],dll:3,document:0,doe:[0,3],don:3,done:[3,4],doubl:3,down:[0,1],downward:1,drop:0,dylib:3,dynam:3,dynamiclib:3,e11:1,e12:1,e1:1,e21:1,e22:1,e2:1,e3:1,e:[0,1,4,5],each:[0,3,4,7],earlier:3,easi:4,easier:4,effect:0,either:[0,3,4],element:[1,2,3],els:[0,2,4],empti:3,enclos:[1,4],end:[0,4],english:0,enough:3,entri:1,enumer:1,environment:0,eq:5,equal:[0,1,6,7],equat:1,equival:4,error:[3,4],etc:0,evalu:[2,6],even:[0,7],everi:7,everyth:4,ex:1,exact:3,examin:1,exampl:[0,1,2,4,6],except:[0,3,4],exclus:1,exhaust:0,exist:[4,7],expand:3,explicit:[1,4,6],explicitli:[0,3],expon:0,exponenti:0,express:[0,1,4,6,7],extend:4,extens:3,extern:0,extra:3,extract:7,f1:3,f2:3,f:[0,1,2,3,4],fact:0,fals:[1,3],famili:0,few:4,ffi:3,field:[3,5,6,7],file:[3,4],fill:4,fin:[0,3,4],finit:[1,2],first:[0,1,3,4],fit:3,fix:[0,1,3],flatten:3,float32:3,float64:3,floor:5,fn:3,follow:[0,1,2,3,4],foo:3,foreign:6,form:7,fpic:3,fraction:0,from:[0,1,2,3,4],frominteg:5,front:1,fulli:3,functoin:0,functor:4,furthermor:3,g:[0,2,4],gener:[1,3],get:1,getfst:1,given:3,glu:4,gmp:3,good:4,group:[0,4,7],guard:6,h:[2,3,4],ha:[0,1,2,3],had:7,handi:1,handl:3,happen:4,hash:4,have:[0,1,2,3,4,7],header:3,help:[3,4],helper1:4,helper2:4,helper:4,here:[0,2,4],hexadecim:0,hide:[0,6],hierarch:6,high:3,highest:0,hold:[1,3],how:3,howev:3,i:[0,1,4],identifi:[1,4,6],ignor:3,impl1:4,impl2:4,impl:4,implement:[3,4],implicit:6,implict:0,impos:4,improv:[0,3],in0:3,in1_a:3,in1_b:3,includ:[0,3],indent:[0,4],independ:0,index:1,individu:3,inf:[1,5],infer:[0,2],inffrom:5,inffromthen:5,infinit:1,infix:[0,6],infixl:0,infixr:0,inform:1,init:3,input:3,instanc:3,instanti:6,instead:[0,3,4,7],insuffici:1,integ:[0,2,3,5,7],integr:[3,6],intend:4,interfac:[0,6],introduc:4,invalid:1,involv:3,irrelev:7,isposit:1,issu:0,its:[0,3,4],itself:[3,4],j:[1,4],just:[3,4,7],k:3,keword:4,keyword:[4,6],kind:[2,3],know:3,known:1,l:[1,3],label:1,lambda:[1,2],languag:[0,3],larg:[2,3],larger:3,last:[0,2,3],layout:[4,6],left:[0,1],len:0,length:[0,1],less:0,let:[0,3],letter:0,level:[4,6],lexicograph:1,lg2:0,libffi:3,librari:3,lift:1,like:[3,4,7],limit:3,line:[0,7],link:4,linux:3,list:[0,3,6],liter:[2,6],load:3,local:[0,4,6],locat:[1,4],logarithm:0,logic:6,longer_nam:0,longernam:0,look:[3,4],lowest:0,m:4,maco:3,mai:[0,1,2,3,4,7],main:3,make:4,manag:[3,6],mani:[3,4],manual:3,map:3,mark:0,match:[0,1,3],math:6,matter:3,max:[0,5],maximum:0,mayb:4,mean:[0,3],member:7,memori:6,mention:[3,7],might:4,min:[0,5],minimum:0,mirror:1,modifi:3,modul:[0,3,6],modulu:0,more:[0,4],moreov:7,most:[1,4],mpq_t:3,mpz_q:3,mpz_t:3,multidimension:3,multipl:[0,1,2,3,4],must:[0,3,4],my:4,myf:4,n1:3,n2:3,n:[0,1,3,4],name1:0,name2:0,name:[0,1,3,6,7],need:[0,2,3,4],negat:5,nest:[0,1,3,6],newt:7,newtyp:[0,4,6],ni:3,nk:3,non:[0,3],nonzero:3,notat:[0,1,2,4],note:[1,3,4],noth:4,notion:4,now:3,number:[0,1,2,3],numer:[3,4,6],o:3,obtain:[1,3,4],occasion:4,octal:0,often:1,old:1,onc:[3,4],one:[0,2,3,4],onli:[0,1,3,4,7],open:0,oper:[3,6],option:[0,7],order:[1,3,4],ordinari:4,organ:0,other:[0,3,4,7],otherwis:7,our:3,out:3,out_0:3,out_1:3,outer:4,output:3,outsid:4,over:0,overal:6,overload:[0,6],overview:2,ox:0,p11:1,p12:1,p1:1,p21:1,p22:1,p2:1,p3:1,p4:1,p:[0,1,4],packag:1,pad:[0,3],pair:2,paramet:[0,2,6],parameter:6,paren:2,parenthes:1,parmaet:4,pass:[2,3,6],pattern:[1,2],piec:3,place:4,platform:6,point:[1,6],pointer:3,pointwis:1,polymorph:[2,3],polynomi:0,portabl:3,posit:1,possibl:[2,3,4],practic:[3,4],pragma:0,pre:7,preced:[2,4],precis:[0,3],prefix:[0,4,6],presum:4,previou:[0,4],prime:0,primit:0,primtiv:2,principl:0,privat:[0,6],process:3,program:1,programm:0,project:7,properti:0,prototyp:3,prove:0,provid:[0,2,4],pt:1,purpos:[1,7],qualifi:6,quick:6,quickli:1,quit:[0,1,4],r:1,rather:0,ration:[0,3],read:3,readabl:[0,3],recip:5,record:[6,7],recurs:[3,4,7],reduc:4,refer:4,reject:0,rel:1,relat:4,remain:4,repl:1,repres:[0,3],represent:[0,3],requir:[0,3,4],respect:3,result:[0,1,2,3,4],right:[0,1],ring:5,rotat:1,round:[0,6],roundawai:5,roundtoeven:5,rule:3,runtim:3,s:[0,2,3,4],same:[0,1,3,4,7],satisfi:[0,3],scope:[2,4,7],search:4,section:[2,3,4],see:[0,4],selector:1,semant:4,separ:[1,4],seq:7,sequenc:[0,6],set:[0,1,3],sha256:4,shadow:4,shape:1,share:3,shift:1,should:[0,1,2,3],sign:[1,6],signatur:[3,6],signedcmp:5,similar:[0,3],similarli:1,simpl:[3,4],simpli:0,sinc:[3,4],singl:4,site:7,situat:4,size:[0,1,3],size_t:3,slight:4,smaller:3,so:[0,1,2,3,4],some:[0,4],someth:3,sometim:4,somewher:4,sourc:[3,4],special:0,specif:3,specifi:[0,2,4],split:[1,3],standard:3,start:[0,1],statement:0,step:[1,4],still:3,store:3,straight:4,stream:1,stride:1,structur:[4,6],sub:[1,4],submdul:4,submodul:[0,4],submould:4,subtract:0,suffici:[1,2],sugar:[2,4],suitabl:2,sum:7,sumbodul:4,support:[0,4,6],suppos:3,sure:4,symbol:[0,3,4],synonym:[4,6],syntact:4,syntax:[1,2,6],system:[3,4],t1:[1,3],t2:[1,3],t3:1,t:[0,1,2,3,4,7],tabl:[0,3],take:3,tend:4,term:0,termin:0,test:3,text:0,than:[0,3,4],thei:[0,1,3,4,7],them:4,themselv:3,thi:[0,1,2,3,4],thing:4,those:[1,4],though:7,three:1,through:[1,6],thu:[1,4],ti:3,time:4,tm:3,tn:3,togeth:[1,4],tointeg:5,too:3,top:[3,4],tr:3,translat:3,transpar:7,treat:[3,4,7],trunc:5,tupl:6,two:[0,1,2,4,7],typaram:2,type:[4,6],typecheck:7,typeclass:7,u1:3,u2:3,u:3,ui:3,uint16_t:3,uint32_t:3,uint64_t:3,uint8_t:3,un:3,unari:[0,2],undefin:3,underscor:0,understand:[3,4],unfold:7,uniniti:3,unlik:7,up:0,updat:6,updateend:1,updatesend:1,us:[0,1,2,3,4,7],usag:6,user:7,usual:2,v1:3,v2:3,valid:1,valu:[0,1,4,6,7],variabl:[2,3],variat:4,varieti:0,vector:6,version:3,vi:3,via:1,vn:3,wa:4,wai:[1,3,4],want:[3,4],warn:0,warnnonexhaustiveconstraintguard:0,we:[1,3,4],weakest:2,what:3,when:[0,1,2,3,4],where:[0,1,2,3,4],wherea:1,which:[0,2,3,4,7],whole:[2,3,4],width:[0,4],window:3,wise:1,withing:4,without:4,word:[1,3],work:[3,4],worth:3,would:[3,4,7],write:[0,1,3],written:[0,1,2,3,7],x:[0,1,2,3,4,7],xpo:1,xs:[0,1],y:[0,1,2,3,4],you:[2,3,4],your:3,ypo:1,z:[0,2,3,4],zero:[2,3,6]},titles:["Basic Syntax","Basic Types","Expressions","Foreign Function Interface","Modules","Overloaded Operations","Cryptol Reference Manual","Type Declarations"],titleterms:{"float":3,"function":[1,2,3],"import":4,"return":3,access:1,an:4,annot:2,anonym:4,argument:[2,4],arithmet:5,basic:[0,1,3,5],between:3,bit:3,block:[2,4],built:0,c:3,call:2,code:3,comment:0,comparison:5,compil:3,condit:2,constraint:[0,4],convert:3,cryptol:[3,6],declar:[0,2,7],demot:2,divis:5,equal:5,evalu:3,exampl:3,explicit:2,express:2,field:1,foreign:3,guard:0,hide:4,hierarch:4,identifi:0,implicit:4,infix:2,instanti:[2,4],integr:5,interfac:[3,4],keyword:0,layout:0,level:0,list:4,liter:0,local:2,logic:5,manag:4,manual:6,math:3,memori:3,modul:4,name:4,nest:4,newtyp:7,numer:[0,2],oper:[0,1,2,5],overal:3,overload:5,paramet:[3,4],parameter:4,pass:4,platform:3,point:3,preced:0,prefix:2,privat:4,qualifi:4,quick:3,record:[1,3],refer:[3,6],round:5,sequenc:[1,3],sign:5,signatur:0,structur:3,support:3,synonym:[3,7],syntax:0,through:4,todo:[0,2],tupl:[1,3],type:[0,1,2,3,7],updat:1,usag:3,valu:[2,3],vector:3,zero:5}}) \ No newline at end of file diff --git a/docs/chop.hs b/docs/chop.hs index b73aa0127..68c729af9 100755 --- a/docs/chop.hs +++ b/docs/chop.hs @@ -9,12 +9,12 @@ -- Portability : portable {- A utility for spliting a long column of stuff into multiple columns. -} -import Data.List(transpose) +import Data.List(transpose,sort) rs = 4 -- number of rows per column spacing = 4 -- blanks between columns -main = interact (unlines . map concat . transpose . map toCol . chop rs . lines) +main = interact (unlines . map concat . transpose . map toCol . chop rs . sort . lines) colWidth xs = spacing + maximum (0 : map length xs) diff --git a/examples/AE.cry b/examples/AE.cry index 5844790a4..1ac25e774 100644 --- a/examples/AE.cry +++ b/examples/AE.cry @@ -16,14 +16,18 @@ parameter type constraint (fin p, fin n, n >= tagAmount) // Process a single block using this key and tweak - tweak_cipher : K -> Tweak -> [n] -> [n] + tweak_cipher : K -> { nonce : [n], state : A, z : [64] } -> [n] -> [n] // Cost for using the tweak - Cost : Int - - Enc : K -> Tweak -> Node -> Node - Dec : K -> Tweak -> Node -> Node - Tag : K -> Tweak -> State -> [n] + Cost : [64] + + Enc : K -> { nonce : [n], state : A, z : [64] } + -> { message : [p*n], state : [p*n] } + -> { message : [p*n], state : [p*n] } + Dec : K -> { nonce : [n], state : A, z : [64] } + -> { message : [p*n], state : [p*n] } + -> { message : [p*n], state : [p*n] } + Tag : K -> { nonce : [n], state : A, z : [64] } -> [p*n] -> [n] // The unit at which `Enc` operates type Node = { message : WorkBlock, state : State } diff --git a/examples/param_modules/AES.cry b/examples/param_modules/AES.cry index e904a2835..3bc3dee66 100644 --- a/examples/param_modules/AES.cry +++ b/examples/param_modules/AES.cry @@ -1,38 +1,47 @@ module AES where -import `AES::Algorithm as AES -import `AES::ExpandKey +import AES::Algorithm as AES where + type Mode = m + encRound = AESRound + decRound = AESInvRound + +import AES::ExpandKey where + type Nk = AES::Nk + type Nr = AES::Nr + import AES::TBox -type constraint ValidKey k m = (k == 128 + m * 64, 2 >= m) +parameter + /** 0: AES128, 1: AES192, 2: AES256 */ + type m : # + type k : # + type constraint (k == 128 + m * 64, 2 >= m) -type EncKey m = AES::KeySchedule m -type DecKey m = AES::KeySchedule m +type EncKey = AES::KeySchedule +type DecKey = AES::KeySchedule -encrypt : {k,m} ValidKey k m => [k] -> [128] -> [128] +encrypt : [k] -> [128] -> [128] encrypt k = encryptWithSchedule (expandKeyEnc k) -decrypt : {k,m} ValidKey k m => [k] -> [128] -> [128] +decrypt : [k] -> [128] -> [128] decrypt k = decryptWithSchedule (expandKeyDec k) -expandKeyEnc : {k,m} ValidKey k m => [k] -> EncKey m -expandKeyEnc = expandKey`{Nk = AES::Nk m, Nr = AES::Nr m} - -encryptWithSchedule : {k,m} ValidKey k m => EncKey m -> [128] -> [128] -encryptWithSchedule = AES::encrypt params +expandKeyEnc : [k] -> EncKey +expandKeyEnc = expandKey +encryptWithSchedule : EncKey -> [128] -> [128] +encryptWithSchedule = AES::encrypt -expandKeyDec : {k,m} ValidKey k m => [k] -> EncKey m -expandKeyDec k = makeDecKey (expandKey`{Nk = AES::Nk m, Nr = AES::Nr m} k) -decryptWithSchedule : {k,m} ValidKey k m => DecKey m -> [128] -> [128] -decryptWithSchedule = AES::decrypt params +expandKeyDec : [k] -> EncKey +expandKeyDec k = makeDecKey (expandKey k) +decryptWithSchedule : DecKey -> [128] -> [128] +decryptWithSchedule = AES::decrypt -params = { encRound = AESRound, decRound = AESInvRound } property test k pt = decrypt k (encrypt k pt) == pt diff --git a/examples/param_modules/AES_GCM_SIV_Test.cry b/examples/param_modules/AES_GCM_SIV_Test.cry index 978b15604..015de0f3f 100644 --- a/examples/param_modules/AES_GCM_SIV_Test.cry +++ b/examples/param_modules/AES_GCM_SIV_Test.cry @@ -1,8 +1,10 @@ -import `Common::AES_GCM_SIV +import Common::AES_GCM_SIV as AES_GCM_SIV_0_56 where + type Mode = 0 + type AAD = 56 property test0 = - aes_gcm_siv + AES_GCM_SIV_0_56::aes_gcm_siv { key = 0xee8e1ed9ff2540ae8f2ba9f50bc2f27c , nonce = 0x752abad3e0afb5f434dc4310 , aad = join "example" @@ -12,8 +14,13 @@ property test0 = 0x5d349ead175ef6b1def6fd # 0x4fbcdeb7e4793f4a1d7e4faa70100af1 + +import Common::AES_GCM_SIV as AES_GCM_SIV_0_0 where + type Mode = 0 + type AAD = 0 + property test1 = - aes_gcm_siv + AES_GCM_SIV_0_0::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = [] @@ -23,7 +30,7 @@ property test1 = 0xdc20e2d83f25705bb49e439eca56de25 property test2 = - aes_gcm_siv + AES_GCM_SIV_0_0::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = [] @@ -34,7 +41,7 @@ property test2 = 0x5b287c22493a364c property test3 = - aes_gcm_siv + AES_GCM_SIV_0_0::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = [] @@ -45,7 +52,7 @@ property test3 = 0x57391a0bc4fdec8b0d106639 property test4 = - aes_gcm_siv + AES_GCM_SIV_0_0::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = [] @@ -56,7 +63,7 @@ property test4 = 0x303aaf90f6fe21199c6068577437a0c4 property test5 = - aes_gcm_siv + AES_GCM_SIV_0_0::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = [] @@ -69,7 +76,7 @@ property test5 = 0x1a8e45dcd4578c667cd86847bf6155ff property test6 = - aes_gcm_siv + AES_GCM_SIV_0_0::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = [] @@ -84,7 +91,7 @@ property test6 = 0x5e6e311dbf395d35b0fe39c2714388f8 property test7 = - aes_gcm_siv + AES_GCM_SIV_0_0::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = [] @@ -100,8 +107,13 @@ property test7 = 0x36697f25b4cd169c6590d1dd39566d3f # 0x8a263dd317aa88d56bdf3936dba75bb8 + +import Common::AES_GCM_SIV as AES_GCM_SIV_0_8 where + type Mode = 0 + type AAD = 8 + property test8 = - aes_gcm_siv + AES_GCM_SIV_0_8::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = 0x01 @@ -112,7 +124,7 @@ property test8 = 0x790d99759abd1508 property test9 = - aes_gcm_siv + AES_GCM_SIV_0_8::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = 0x01 @@ -123,7 +135,7 @@ property test9 = 0x02745aaa3a0c469fad9e075a property test10 = - aes_gcm_siv + AES_GCM_SIV_0_8::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = 0x01 @@ -134,7 +146,7 @@ property test10 = 0x8f8936ec039e4e4bb97ebd8c4457441f property test11 = - aes_gcm_siv + AES_GCM_SIV_0_8::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = 0x01 @@ -147,7 +159,7 @@ property test11 = 0xe6af6a7f87287da059a71684ed3498e1 property test12 = - aes_gcm_siv + AES_GCM_SIV_0_8::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = 0x01 @@ -162,7 +174,7 @@ property test12 = 0x6a8cc3865f76897c2e4b245cf31c51f2 property test13 = - aes_gcm_siv + AES_GCM_SIV_0_8::aes_gcm_siv { key = 0x01000000000000000000000000000000 , nonce = 0x030000000000000000000000 , aad = 0x01 @@ -179,8 +191,12 @@ property test13 = 0xcdc46ae475563de037001ef84ae21744 +import Common::AES_GCM_SIV as AES_GCM_SIV_0_96 where + type Mode = 0 + type AAD = 96 + property test14 = - aes_gcm_siv + AES_GCM_SIV_0_96::aes_gcm_siv { msg = 0x02000000 , aad = 0x010000000000000000000000 , key = 0x01000000000000000000000000000000 @@ -190,8 +206,13 @@ property test14 = 0xa8fe3e8707eb1f84fb28f8cb73de8e99 # 0xe2f48a14 + +import Common::AES_GCM_SIV as AES_GCM_SIV_0_144 where + type Mode = 0 + type AAD = 144 + property test15 = - aes_gcm_siv + AES_GCM_SIV_0_144::aes_gcm_siv { msg = 0x03000000000000000000000000000000 # 0x04000000 , aad = 0x01000000000000000000000000000000 # @@ -205,8 +226,12 @@ property test15 = 0xfe106514 +import Common::AES_GCM_SIV as AES_GCM_SIV_0_160 where + type Mode = 0 + type AAD = 160 + property test16 = - aes_gcm_siv + AES_GCM_SIV_0_160::aes_gcm_siv { msg = 0x03000000000000000000000000000000 # 0x0400 , aad = 0x01000000000000000000000000000000 # @@ -219,8 +244,9 @@ property test16 = 0x2adabff9b2ef00fb47920cc72a0c0f13 # 0xb9fd + property test16' = - aes_gcm_siv + AES_GCM_SIV_0_0::aes_gcm_siv { msg = [] , aad = [] , key = 0xe66021d5eb8e4f4066d4adb9c33560e4 @@ -228,8 +254,13 @@ property test16' = } == 0xa4194b79071b01a87d65f706e3949578 + +import Common::AES_GCM_SIV as AES_GCM_SIV_0_40 where + type Mode = 0 + type AAD = 40 + property test17 = - aes_gcm_siv + AES_GCM_SIV_0_40::aes_gcm_siv { msg = 0x7a806c , aad = 0x46bb91c3c5 , key = 0x36864200e0eaf5284d884a0e77d31646 @@ -239,8 +270,12 @@ property test17 = 0xa428a8 +import Common::AES_GCM_SIV as AES_GCM_SIV_0_80 where + type Mode = 0 + type AAD = 80 + property test18 = - aes_gcm_siv + AES_GCM_SIV_0_80::aes_gcm_siv { msg = 0xbdc66f146545 , aad = 0xfc880c94a95198874296 , key = 0xaedb64a6c590bc84d1a5e269e4b47801 @@ -250,8 +285,12 @@ property test18 = 0x743dba20f966 +import Common::AES_GCM_SIV as AES_GCM_SIV_0_120 where + type Mode = 0 + type AAD = 120 + property test19 = - aes_gcm_siv + AES_GCM_SIV_0_120::aes_gcm_siv { msg = 0x1177441f195495860f , aad = 0x046787f3ea22c127aaf195d1894728 , key = 0xd5cc1fd161320b6920ce07787f86743b @@ -262,7 +301,7 @@ property test19 = property test20 = - aes_gcm_siv + AES_GCM_SIV_0_160::aes_gcm_siv { msg = 0x9f572c614b4745914474e7c7 , aad = 0xc9882e5386fd9f92ec489c8fde2be2cf # 0x97e74e93 @@ -272,8 +311,13 @@ property test20 = == 0xf54673c5ddf710c745641c8bc1dc2f87 # 0x1fb7561da1286e655e24b7b0 + +import Common::AES_GCM_SIV as AES_GCM_SIV_0_200 where + type Mode = 0 + type AAD = 200 + property test21 = - aes_gcm_siv + AES_GCM_SIV_0_200::aes_gcm_siv { msg = 0x0d8c8451178082355c9e940fea2f58 , aad = 0x2950a70d5a1db2316fd568378da107b5 # 0x2b0da55210cc1c1b0a @@ -284,8 +328,12 @@ property test21 = 0xb3449b9f39552de99dc214a1190b0b +import Common::AES_GCM_SIV as AES_GCM_SIV_0_240 where + type Mode = 0 + type AAD = 240 + property test22 = - aes_gcm_siv + AES_GCM_SIV_0_240::aes_gcm_siv { msg = 0x6b3db4da3d57aa94842b9803a96e07fb # 0x6de7 , aad = 0x1860f762ebfbd08284e421702de0de18 # @@ -298,8 +346,12 @@ property test22 = 0xdb84 +import Common::AES_GCM_SIV as AES_GCM_SIV_0_280 where + type Mode = 0 + type AAD = 280 + property test23 = - aes_gcm_siv + AES_GCM_SIV_0_280::aes_gcm_siv { msg = 0xe42a3c02c25b64869e146d7b233987bd # 0xdfc240871d , aad = 0x7576f7028ec6eb5ea7e298342a94d4b2 # @@ -312,8 +364,13 @@ property test23 = 0xb3ee197d052d15506c84a9edd65e13e9 # 0xd24a2a6e70 + +import Common::AES_GCM_SIV as AES_GCM_SIV_1_0 where + type Mode = 1 + type AAD = 0 + property test24 = - aes_gcm_siv + AES_GCM_SIV_1_0::aes_gcm_siv { msg = [] , aad = [] , key = 0x01000000000000000000000000000000 # @@ -322,9 +379,8 @@ property test24 = } == 0x07f5f4169bbf55a8400cd47ea6fd400f - property test25 = - aes_gcm_siv + AES_GCM_SIV_1_0::aes_gcm_siv { msg = 0x0100000000000000 , aad = [] , key = 0x01000000000000000000000000000000 # @@ -335,7 +391,7 @@ property test25 = 0x61e0b97427e3df28 property test26 = - aes_gcm_siv + AES_GCM_SIV_1_0::aes_gcm_siv { msg = 0x010000000000000000000000 , aad = [] , key = 0x01000000000000000000000000000000 # @@ -346,7 +402,7 @@ property test26 = 0xae6559e48fd10f6e5c9ca17e property test27 = - aes_gcm_siv + AES_GCM_SIV_1_0::aes_gcm_siv { msg = 0x01000000000000000000000000000000 , aad = [] , key = 0x01000000000000000000000000000000 # @@ -356,9 +412,8 @@ property test27 = == 0x85a01b63025ba19b7fd3ddfc033b3e76 # 0xc9eac6fa700942702e90862383c6c366 - property test28 = - aes_gcm_siv + AES_GCM_SIV_1_0::aes_gcm_siv { msg = 0x01000000000000000000000000000000 # 0x02000000000000000000000000000000 , aad = [] @@ -370,9 +425,8 @@ property test28 = 0x21ec9cf850948a7c86c68ac7539d027f # 0xe819e63abcd020b006a976397632eb5d - property test29 = - aes_gcm_siv + AES_GCM_SIV_1_0::aes_gcm_siv { msg = 0x01000000000000000000000000000000 # 0x02000000000000000000000000000000 # 0x03000000000000000000000000000000 @@ -387,9 +441,8 @@ property test29 = 0x9cf6c748837b61f6ee3adcee17534ed5 # 0x790bc96880a99ba804bd12c0e6a22cc4 - property test30 = - aes_gcm_siv + AES_GCM_SIV_1_0::aes_gcm_siv { msg = 0x01000000000000000000000000000000 # 0x02000000000000000000000000000000 # 0x03000000000000000000000000000000 # @@ -406,8 +459,12 @@ property test30 = 0x112864c269fc0d9d88c61fa47e39aa08 +import Common::AES_GCM_SIV as AES_GCM_SIV_1_8 where + type Mode = 1 + type AAD = 8 + property test31 = - aes_gcm_siv + AES_GCM_SIV_1_8::aes_gcm_siv { msg = 0x0200000000000000 , aad = 0x01 , key = 0x01000000000000000000000000000000 # @@ -417,9 +474,8 @@ property test31 = == 0x1de22967237a813291213f267e3b452f # 0x02d01ae33e4ec854 - property test32 = - aes_gcm_siv + AES_GCM_SIV_1_8::aes_gcm_siv { msg = 0x020000000000000000000000 , aad = 0x01 , key = 0x01000000000000000000000000000000 # @@ -429,9 +485,8 @@ property test32 = == 0x163d6f9cc1b346cd453a2e4cc1a4a19a # 0xe800941ccdc57cc8413c277f - property test33 = - aes_gcm_siv + AES_GCM_SIV_1_8::aes_gcm_siv { msg = 0x02000000000000000000000000000000 , aad = 0x01 , key = 0x01000000000000000000000000000000 # @@ -441,9 +496,8 @@ property test33 = == 0xc91545823cc24f17dbb0e9e807d5ec17 # 0xb292d28ff61189e8e49f3875ef91aff7 - property test34 = - aes_gcm_siv + AES_GCM_SIV_1_8::aes_gcm_siv { msg = 0x02000000000000000000000000000000 # 0x03000000000000000000000000000000 , aad = 0x01 @@ -455,9 +509,8 @@ property test34 = 0x6f255510aa654f920ac81b94e8bad365 # 0xaea1bad12702e1965604374aab96dbbc - property test35 = - aes_gcm_siv + AES_GCM_SIV_1_8::aes_gcm_siv { msg = 0x02000000000000000000000000000000 # 0x03000000000000000000000000000000 # 0x04000000000000000000000000000000 @@ -471,9 +524,8 @@ property test35 = 0xfbca3b5f749cdf564527f2314f42fe25 # 0x03332742b228c647173616cfd44c54eb - property test36 = - aes_gcm_siv + AES_GCM_SIV_1_8::aes_gcm_siv { msg = 0x02000000000000000000000000000000 # 0x03000000000000000000000000000000 # 0x04000000000000000000000000000000 # @@ -490,8 +542,12 @@ property test36 = 0x5bde0285037c5de81e5b570a049b62a0 +import Common::AES_GCM_SIV as AES_GCM_SIV_1_96 where + type Mode = 1 + type AAD = 96 + property test37 = - aes_gcm_siv + AES_GCM_SIV_1_96::aes_gcm_siv { msg = 0x02000000 , aad = 0x010000000000000000000000 , key = 0x01000000000000000000000000000000 # @@ -502,8 +558,12 @@ property test37 = 0x661b74cf +import Common::AES_GCM_SIV as AES_GCM_SIV_1_144 where + type Mode = 1 + type AAD = 144 + property test38 = - aes_gcm_siv + AES_GCM_SIV_1_144::aes_gcm_siv { msg = 0x03000000000000000000000000000000 # 0x04000000 , aad = 0x01000000000000000000000000000000 # @@ -517,8 +577,12 @@ property test38 = 0xcabfe307 +import Common::AES_GCM_SIV as AES_GCM_SIV_1_160 where + type Mode = 1 + type AAD = 160 + property test39 = - aes_gcm_siv + AES_GCM_SIV_1_160::aes_gcm_siv { msg = 0x03000000000000000000000000000000 # 0x0400 , aad = 0x01000000000000000000000000000000 # @@ -531,8 +595,9 @@ property test39 = 0xa075cfcdf5042112aa29685c912fc205 # 0x6543 + property test40 = - aes_gcm_siv + AES_GCM_SIV_1_0::aes_gcm_siv { msg = [] , aad = [] , key = 0xe66021d5eb8e4f4066d4adb9c33560e4 # @@ -542,8 +607,12 @@ property test40 = == 0x169fbb2fbf389a995f6390af22228a62 +import Common::AES_GCM_SIV as AES_GCM_SIV_1_40 where + type Mode = 1 + type AAD = 40 + property test41 = - aes_gcm_siv + AES_GCM_SIV_1_40::aes_gcm_siv { msg = 0x671fdd , aad = 0x4fbdc66f14 , key = 0xbae8e37fc83441b16034566b7a806c46 # @@ -554,8 +623,12 @@ property test41 = 0x19719d +import Common::AES_GCM_SIV as AES_GCM_SIV_1_80 where + type Mode = 1 + type AAD = 80 + property test42 = - aes_gcm_siv + AES_GCM_SIV_1_80::aes_gcm_siv { msg = 0x195495860f04 , aad = 0x6787f3ea22c127aaf195 , key = 0x6545fc880c94a95198874296d5cc1fd1 # @@ -566,8 +639,12 @@ property test42 = 0xc12020ec8c2c +import Common::AES_GCM_SIV as AES_GCM_SIV_1_120 where + type Mode = 1 + type AAD = 120 + property test43 = - aes_gcm_siv + AES_GCM_SIV_1_120::aes_gcm_siv { msg = 0xc9882e5386fd9f92ec , aad = 0x489c8fde2be2cf97e74e932d4ed87d , key = 0xd1894728b3fed1473c528b8426a58299 # @@ -579,7 +656,7 @@ property test43 = property test44 = - aes_gcm_siv + AES_GCM_SIV_1_160::aes_gcm_siv { msg = 0x1db2316fd568378da107b52b , aad = 0x0da55210cc1c1b0abde3b2f204d1e9f8 # 0xb06bc47f @@ -591,8 +668,12 @@ property test44 = 0x587f64979f21826706d497d5 +import Common::AES_GCM_SIV as AES_GCM_SIV_1_200 where + type Mode = 1 + type AAD = 200 + property test45 = - aes_gcm_siv + AES_GCM_SIV_1_200::aes_gcm_siv { msg = 0x21702de0de18baa9c9596291b08466 , aad = 0xf37de21c7ff901cfe8a69615a93fdf7a # 0x98cad481796245709f @@ -604,8 +685,12 @@ property test45 = 0x080d28f6ebb5d3648ce97bd5ba67fd +import Common::AES_GCM_SIV as AES_GCM_SIV_1_240 where + type Mode = 1 + type AAD = 240 + property test46 = - aes_gcm_siv + AES_GCM_SIV_1_240::aes_gcm_siv { msg = 0xb202b370ef9768ec6561c4fe6b7e7296 # 0xfa85 , aad = 0x9c2159058b1f0fe91433a5bdc20e214e # @@ -619,8 +704,12 @@ property test46 = 0x0a49 +import Common::AES_GCM_SIV as AES_GCM_SIV_1_280 where + type Mode = 1 + type AAD = 280 + property test47 = - aes_gcm_siv + AES_GCM_SIV_1_280::aes_gcm_siv { msg = 0xced532ce4159b035277d4dfbb7db6296 # 0x8b13cd4eec , aad = 0x734320ccc9d9bbbb19cb81b2af4ecbc3 # @@ -636,7 +725,7 @@ property test47 = property test48 = - aes_gcm_siv + AES_GCM_SIV_1_0::aes_gcm_siv { msg = 0x00000000000000000000000000000000 # 0x4db923dc793ee6497c76dcc03a98e108 , aad = [] @@ -648,9 +737,8 @@ property test48 = 0xc537703b5ba70324a6793a7bf218d3ea # 0xffffffff000000000000000000000000 - property test49 = - aes_gcm_siv + AES_GCM_SIV_1_0::aes_gcm_siv { msg = 0xeb3640277c7ffd1303c7a542d02d3e4c # 0x0000000000000000 , aad = [] @@ -665,7 +753,7 @@ property test49 = property test50 = - aes_gcm_siv + AES_GCM_SIV_0_0::aes_gcm_siv { msg = 0x01000000000000000000000000000000 # 0x02000000000000000000000000000000 # 0x03000000000000000000000000000000 # diff --git a/examples/param_modules/Common/AES_GCM_SIV.cry b/examples/param_modules/Common/AES_GCM_SIV.cry index 8b61d9896..0db0fbbe7 100644 --- a/examples/param_modules/Common/AES_GCM_SIV.cry +++ b/examples/param_modules/Common/AES_GCM_SIV.cry @@ -10,7 +10,9 @@ https://tools.ietf.org/html/draft-irtf-cfrg-gcmsiv-06 module Common::AES_GCM_SIV where -import AES as AES +import AES as AES where + type m = (2 * Mode) + type k = K parameter /** 0: use AES128, 1: use AES256 */ @@ -22,7 +24,7 @@ parameter type K = 128 + 128 * Mode -type KS = AES::EncKey (2 * Mode) +type KS = AES::EncKey /** Note the weird byte-swapping business (also in `blockify` and `unblockify`) diff --git a/examples/param_modules/GCM_AES_Tests.cry b/examples/param_modules/GCM_AES_Tests.cry index 3492b22d7..47b297632 100644 --- a/examples/param_modules/GCM_AES_Tests.cry +++ b/examples/param_modules/GCM_AES_Tests.cry @@ -1,12 +1,27 @@ module GCM_AES_Tests where -import `Common::GCM as GCM -import AES as AES +import AES as AES128 where + type m = 0 + type k = 128 -gcmEncrypt = GCM::encrypt { E = AES::encrypt } +import AES as AES192 where + type m = 1 + type k = 192 + +import AES as AES256 where + type m = 2 + type k = 256 + + +import Common::GCM as GCM_128_96_0_128 where + type K = 128 + type IV = 96 + type AAD = 0 + type T = 128 + E = AES128::encrypt property test1 = - gcmEncrypt + GCM_128_96_0_128::encrypt { key = 0x00000000000000000000000000000000 , pt = [] , iv = 0x000000000000000000000000 @@ -18,7 +33,7 @@ property test1 = } property test2 = - gcmEncrypt + GCM_128_96_0_128::encrypt { key = 0x00000000000000000000000000000000 , pt = 0x00000000000000000000000000000000 , iv = 0x000000000000000000000000 @@ -29,9 +44,8 @@ property test2 = , tag = 0xab6e47d42cec13bdf53a67b21257bddf } - property test3 = - gcmEncrypt + GCM_128_96_0_128::encrypt { key = 0xfeffe9928665731c6d6a8f9467308308 , pt = 0xd9313225f88406e5a55909c5aff5269a # 0x86a7a9531534f7da2e4c303d8a318a72 # @@ -49,8 +63,15 @@ property test3 = } +import Common::GCM as GCM_128_96_160_128 where + type K = 128 + type IV = 96 + type AAD = 160 + type T = 128 + E = AES128::encrypt + property test4 = - gcmEncrypt + GCM_128_96_160_128::encrypt { key = 0xfeffe9928665731c6d6a8f9467308308 , pt = 0xd9313225f88406e5a55909c5aff5269a # 0x86a7a9531534f7da2e4c303d8a318a72 # @@ -68,8 +89,16 @@ property test4 = , tag = 0x5bc94fbc3221a5db94fae95ae7121a47 } + +import Common::GCM as GCM_128_64_160_128 where + type K = 128 + type IV = 64 + type AAD = 160 + type T = 128 + E = AES128::encrypt + property test5 = - gcmEncrypt + GCM_128_64_160_128::encrypt { key = 0xfeffe9928665731c6d6a8f9467308308 , pt = 0xd9313225f88406e5a55909c5aff5269a # 0x86a7a9531534f7da2e4c303d8a318a72 # @@ -87,8 +116,16 @@ property test5 = , tag = 0x3612d2e79e3b0785561be14aaca2fccb } + +import Common::GCM as GCM_128_480_160_128 where + type K = 128 + type IV = 480 + type AAD = 160 + type T = 128 + E = AES128::encrypt + property test6 = - gcmEncrypt + GCM_128_480_160_128::encrypt { key = 0xfeffe9928665731c6d6a8f9467308308 , pt = 0xd9313225f88406e5a55909c5aff5269a # 0x86a7a9531534f7da2e4c303d8a318a72 # @@ -109,8 +146,16 @@ property test6 = , tag = 0x619cc5aefffe0bfa462af43c1699d050 } + +import Common::GCM as GCM_192_96_0_128 where + type K = 192 + type IV = 96 + type AAD = 0 + type T = 128 + E = AES192::encrypt + property test7 = - gcmEncrypt + GCM_192_96_0_128::encrypt { key = 0x00000000000000000000000000000000 # 0x0000000000000000 , pt = [] @@ -123,7 +168,7 @@ property test7 = } property test8 = - gcmEncrypt + GCM_192_96_0_128::encrypt { key = 0x00000000000000000000000000000000 # 0x0000000000000000 , pt = 0x00000000000000000000000000000000 @@ -136,7 +181,7 @@ property test8 = } property test9 = - gcmEncrypt + GCM_192_96_0_128::encrypt { key = 0xfeffe9928665731c6d6a8f9467308308 # 0xfeffe9928665731c , pt = 0xd9313225f88406e5a55909c5aff5269a # @@ -154,8 +199,16 @@ property test9 = , tag = 0x9924a7c8587336bfb118024db8674a14 } + +import Common::GCM as GCM_192_96_160_128 where + type K = 192 + type IV = 96 + type AAD = 160 + type T = 128 + E = AES192::encrypt + property test10 = - gcmEncrypt + GCM_192_96_160_128::encrypt { key = 0xfeffe9928665731c6d6a8f9467308308 # 0xfeffe9928665731c , pt = 0xd9313225f88406e5a55909c5aff5269a # @@ -174,8 +227,16 @@ property test10 = , tag = 0x2519498e80f1478f37ba55bd6d27618c } + +import Common::GCM as GCM_192_64_160_128 where + type K = 192 + type IV = 64 + type AAD = 160 + type T = 128 + E = AES192::encrypt + property test11 = - gcmEncrypt + GCM_192_64_160_128::encrypt { key = 0xfeffe9928665731c6d6a8f9467308308 # 0xfeffe9928665731c , pt = 0xd9313225f88406e5a55909c5aff5269a # @@ -194,8 +255,16 @@ property test11 = , tag = 0x65dcc57fcf623a24094fcca40d3533f8 } + +import Common::GCM as GCM_192_480_160_128 where + type K = 192 + type IV = 480 + type AAD = 160 + type T = 128 + E = AES192::encrypt + property test12 = - gcmEncrypt + GCM_192_480_160_128::encrypt { key = 0xfeffe9928665731c6d6a8f9467308308 # 0xfeffe9928665731c , pt = 0xd9313225f88406e5a55909c5aff5269a # @@ -217,8 +286,16 @@ property test12 = , tag = 0xdcf566ff291c25bbb8568fc3d376a6d9 } + +import Common::GCM as GCM_256_96_0_128 where + type K = 256 + type IV = 96 + type AAD = 0 + type T = 128 + E = AES256::encrypt + property test13 = - gcmEncrypt + GCM_256_96_0_128::encrypt { key = 0x00000000000000000000000000000000 # 0x00000000000000000000000000000000 , pt = [] @@ -231,7 +308,7 @@ property test13 = } property test14 = - gcmEncrypt + GCM_256_96_0_128::encrypt { key = 0x00000000000000000000000000000000 # 0x00000000000000000000000000000000 , pt = 0x00000000000000000000000000000000 @@ -244,7 +321,7 @@ property test14 = } property test15 = - gcmEncrypt + GCM_256_96_0_128::encrypt { key = 0xfeffe9928665731c6d6a8f9467308308 # 0xfeffe9928665731c6d6a8f9467308308 , pt = 0xd9313225f88406e5a55909c5aff5269a # @@ -262,8 +339,16 @@ property test15 = , tag = 0xb094dac5d93471bdec1a502270e3cc6c } + +import Common::GCM as GCM_256_96_160_128 where + type K = 256 + type IV = 96 + type AAD = 160 + type T = 128 + E = AES256::encrypt + property test16 = - gcmEncrypt + GCM_256_96_160_128::encrypt { key = 0xfeffe9928665731c6d6a8f9467308308 # 0xfeffe9928665731c6d6a8f9467308308 , pt = 0xd9313225f88406e5a55909c5aff5269a # @@ -282,8 +367,16 @@ property test16 = , tag = 0x76fc6ece0f4e1768cddf8853bb2d551b } + +import Common::GCM as GCM_256_64_160_128 where + type K = 256 + type IV = 64 + type AAD = 160 + type T = 128 + E = AES256::encrypt + property test17 = - gcmEncrypt + GCM_256_64_160_128::encrypt { key = 0xfeffe9928665731c6d6a8f9467308308 # 0xfeffe9928665731c6d6a8f9467308308 , pt = 0xd9313225f88406e5a55909c5aff5269a # @@ -302,8 +395,16 @@ property test17 = , tag = 0x3a337dbf46a792c45e454913fe2ea8f2 } + +import Common::GCM as GCM_256_480_160_128 where + type K = 256 + type IV = 480 + type AAD = 160 + type T = 128 + E = AES256::encrypt + property test18 = - gcmEncrypt + GCM_256_480_160_128::encrypt { key = 0xfeffe9928665731c6d6a8f9467308308 # 0xfeffe9928665731c6d6a8f9467308308 , pt = 0xd9313225f88406e5a55909c5aff5269a # diff --git a/examples/param_modules/SHA.cry b/examples/param_modules/SHA.cry index 5276fc8ec..d1a5c8b7b 100644 --- a/examples/param_modules/SHA.cry +++ b/examples/param_modules/SHA.cry @@ -1,44 +1,9 @@ module SHA where -import `Common::SHA +import SHA256 as SHA256 sha256 : {n} (64 >= width n) => [n] -> [256] -sha256 = sha - { SIGMA_0 = \x -> (x >>> 2) ^ (x >>> 13) ^ (x >>> 22) - , SIGMA_1 = \x -> (x >>> 6) ^ (x >>> 11) ^ (x >>> 25) - , sigma_0 = \x -> (x >>> 7) ^ (x >>> 18) ^ (x >> 3) - , sigma_1 = \x -> (x >>> 17) ^ (x >>> 19) ^ (x >> 10) - - , H0 = [ 0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a - , 0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19 - ] - - , K = [ 0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5 - , 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5 - - , 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3 - , 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174 - - , 0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc - , 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da - - , 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7 - , 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967 - - , 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13 - , 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85 - - , 0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3 - , 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070 - - , 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5 - , 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3 - - , 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208 - , 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2 - ] - } - +sha256 = SHA256::sha property katsPass = ~zero == [test == kat | (test,kat) <- sha256tests ] diff --git a/module_system_example.txt b/module_system_example.txt new file mode 100644 index 000000000..6f68a1578 --- /dev/null +++ b/module_system_example.txt @@ -0,0 +1,52 @@ + +signature S where -- u1 + type n : # -- u5 + +module M where -- u2 + parameter X : S -- X, u1 + -- introduces: u6 + -- to do this, we need to resolve `S` first + + + + f : [X.n] -- u7, u6 + f = ... -- u7 + +module N where -- u2 + type n = 16 -- u9 + +module I = -- u4 + M with X = N -- u2, X, u3 + +import I -- u4 + -- introduces: u10 + +g = f -- u8, u10 + +-------------------------------------------------------------------------------- +Defines (naming env) + +toplevel: + NS Names Uniq + module S u1 + module M u2 + module N u3 + module I u4 + value g u8 + +u1: + type n u5 + +u2: + type X.n u6 + value f u7 + +u3: + type n u9 + +u4: + value f u10 + + + + diff --git a/src/Cryptol/Backend/FFI/Error.hs b/src/Cryptol/Backend/FFI/Error.hs index 2e4adda41..af66516ea 100644 --- a/src/Cryptol/Backend/FFI/Error.hs +++ b/src/Cryptol/Backend/FFI/Error.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Safe #-} -- | Errors from dynamic loading of shared libraries for FFI. @@ -9,6 +10,7 @@ import Control.DeepSeq import GHC.Generics import Cryptol.Utils.PP +import Cryptol.ModuleSystem.Name data FFILoadError = CantLoadFFISrc @@ -17,16 +19,26 @@ data FFILoadError | 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 (text "Could not load foreign source for module located at" + hang ("Could not load foreign source for module located at" <+> text path <.> colon) 4 (text msg) CantLoadFFIImpl name msg -> - hang (text "Could not load foreign implementation for binding" + 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/Eval.hs b/src/Cryptol/Eval.hs index 64d614dfa..3553dcb39 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -174,8 +174,9 @@ evalExpr sym env expr = case expr of 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 @@ -243,6 +244,7 @@ checkProp = \case -- 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 @@ -257,7 +259,12 @@ checkProp = \case -- to `envTypes` and expanding all type synonyms via `tNoUser`. evalProp :: GenEvalEnv sym -> Prop -> Prop evalProp env@EvalEnv { envTypes } = \case - TCon tc tys -> TCon tc (toType . evalType envTypes <$> tys) + 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"] diff --git a/src/Cryptol/Eval/FFI.hs b/src/Cryptol/Eval/FFI.hs index 7907ee6d8..5c80cc32f 100644 --- a/src/Cryptol/Eval/FFI.hs +++ b/src/Cryptol/Eval/FFI.hs @@ -17,8 +17,6 @@ module Cryptol.Eval.FFI , evalForeignDecls ) where -import Data.Maybe - import Cryptol.Backend.FFI import Cryptol.Backend.FFI.Error import Cryptol.Eval @@ -58,15 +56,6 @@ import Cryptol.Utils.RecordMap #endif --- | Find all the foreign declarations in the module and return their names and --- FFIFunTypes. -findForeignDecls :: Module -> [(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 - #ifdef FFI_ENABLED -- | Add the given foreign declarations to the environment, loading their diff --git a/src/Cryptol/IR/TraverseNames.hs b/src/Cryptol/IR/TraverseNames.hs new file mode 100644 index 000000000..d9c289d29 --- /dev/null +++ b/src/Cryptol/IR/TraverseNames.hs @@ -0,0 +1,265 @@ +{-# 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) + <*> traverseRecordMap (\_ -> traverseNamesIP) + (ntFields nt) + where + mk a b c d = nt { ntName = a + , ntParams = b + , ntConstraints = c + , ntFields = d + } + +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 index 630d86d7b..95871c4eb 100644 --- a/src/Cryptol/ModuleSystem.hs +++ b/src/Cryptol/ModuleSystem.hs @@ -31,8 +31,7 @@ module Cryptol.ModuleSystem ( , renameType -- * Interfaces - , Iface, IfaceG(..), IfaceParams(..), IfaceDecls(..), T.genIface - , IfaceTySyn, IfaceDecl(..) + , Iface, IfaceG(..), IfaceDecls(..), T.genIface, IfaceDecl(..) ) where import Data.Map (Map) @@ -66,31 +65,33 @@ findModule :: P.ModName -> ModuleCmd ModulePath findModule n env = runModuleM env (Base.findModule n) -- | Load the module contained in the given file. -loadModuleByPath :: FilePath -> ModuleCmd (ModulePath,T.Module) +loadModuleByPath :: FilePath -> ModuleCmd (ModulePath,T.TCTopEntity) loadModuleByPath path minp = do moduleEnv' <- resetModuleEnv $ minpModuleEnv minp runModuleM minp{ minpModuleEnv = moduleEnv' } $ do unloadModule ((InFile path ==) . lmFilePath) - (mPath, m) <- Base.loadModuleByPath True path - setFocusedModule (T.mName m) - return (mPath,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 :: 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.Module) +checkModuleByPath :: FilePath -> ModuleCmd (ModulePath, T.TCTopEntity) checkModuleByPath path minp = do (res, warns) <- runModuleM minp $ Base.loadModuleByPath False path -- restore the old environment - pure (fmap (minpModuleEnv minp <$) res, warns) + let res1 = do (x,_newEnv) <- res + pure ((InFile path, x), minpModuleEnv minp) + pure (res1, warns) -- Extended Environments ------------------------------------------------------- diff --git a/src/Cryptol/ModuleSystem/Base.hs b/src/Cryptol/ModuleSystem/Base.hs index fa76ec242..a3d650f9c 100644 --- a/src/Cryptol/ModuleSystem/Base.hs +++ b/src/Cryptol/ModuleSystem/Base.hs @@ -14,15 +14,17 @@ {-# 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.Maybe (fromMaybe) +import Data.List(sortBy,groupBy) +import Data.Function(on) import Data.Monoid ((<>)) import Data.Text.Encoding (decodeUtf8') -import Data.IORef(newIORef,readIORef) import System.Directory (doesFileExist, canonicalizePath) import System.FilePath ( addExtension , isAbsolute @@ -44,11 +46,12 @@ 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 ( lookupModule + , lookupTCEntity + , LoadedModuleG(..), lmInterface , meCoreLint, CoreLint(..) - , ModContext(..) + , ModContext(..), ModContextParams(..) , ModulePath(..), modulePathLabel) import Cryptol.Backend.FFI import qualified Cryptol.Eval as E @@ -69,11 +72,11 @@ 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) @@ -132,7 +135,7 @@ expandPropGuards a = -- Parsing --------------------------------------------------------------------- -- | Parse a module and expand includes -parseModule :: ModulePath -> ModuleM (Fingerprint, P.Module PName) +parseModule :: ModulePath -> ModuleM (Fingerprint, [P.Module PName]) parseModule path = do getBytes <- getByteReader @@ -164,15 +167,16 @@ parseModule path = do } 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) - case mb of - Right ok -> pure ok - Left err -> noIncludeErrors err + forM pms \pm -> + do mb <- io (removeIncludesModule r p pm) + case mb of + Right ok -> pure ok + Left err -> noIncludeErrors err {- We don't do "include" resolution for in-memory files because at the moment the include resolution pass requires @@ -180,54 +184,58 @@ parseModule path = do 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 + InMem {} -> pure pms fp `seq` return (fp, pm1) Left err -> moduleParseError path err --- Modules --------------------------------------------------------------------- +-- Top Level Modules and Signatures ---------------------------------------------- -- | Load a module by its path. -loadModuleByPath :: Bool {- ^ evaluate declarations in the module -} -> - FilePath -> ModuleM (ModulePath, T.Module) +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) - - -- 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 -> do - m <- doLoadModule eval False (FromModule n) (InFile foundPath) fp pm - pure (InFile foundPath, m) - Just lm - | path' == loaded -> return (lmFilePath lm, lmModule lm) - | otherwise -> duplicateModuleName n path' loaded - where loaded = lmModuleId lm + (fp, pms) <- parseModule (InFile foundPath) + last <$> + forM pms \pm -> + do let n = thing (P.mName pm) + + -- Check whether this module name has already been loaded from a + -- different file + env <- getModuleEnv + -- path' is the resolved, absolute path, used only for checking + -- whether it's already been loaded + path' <- io (canonicalizePath foundPath) + + case lookupTCEntity n env of + -- loadModule will calculate the canonical path again + Nothing -> + doLoadModule eval False (FromModule n) (InFile foundPath) fp 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 True quiet isrc path fp pm - return (path,m) + do (fp, pms) <- parseModule path + ms <- mapM (doLoadModule True quiet isrc path fp) pms + return (path,last ms) -- | Load dependencies, typecheck, and add to the eval environment. doLoadModule :: @@ -237,42 +245,47 @@ doLoadModule :: ModulePath -> Fingerprint -> P.Module PName -> - ModuleM T.Module + ModuleM T.TCTopEntity doLoadModule eval quiet isrc path fp pm0 = loading isrc $ do let pm = addPrelude pm0 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 - let shouldEval = eval && not (T.isParametrizedModule tcm) - foreignSrc <- if shouldEval then evalForeign tcm else pure Nothing - when shouldEval $ - modifyEvalEnv (E.moduleEnv Concrete 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 + loadedModule path fp 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 + where evalForeign tcm + | not (null foreignFs) = ffiLoadErrors (T.mName tcm) (map FFI.FFIInFunctor foreignFs) + | not (null dups) = ffiLoadErrors (T.mName tcm) (map FFI.FFIDuplicates dups) | null foreigns = pure Nothing | otherwise = case path of InFile p -> io (canonicalizePath p >>= loadForeignSrc) >>= @@ -290,8 +303,11 @@ doLoadModule eval quiet isrc path fp pm0 = 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 - + 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: @@ -337,48 +353,88 @@ findModule n = do -- | 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 () loadDeps m = - do mapM_ loadI (P.mImports m) - mapM_ loadF (P.mInstance m) + case mDef m of + NormalModule ds -> mapM_ depsOfDecl ds + FunctorInstance f as _ -> + do loadImpName FromModuleInstance f + case as of + DefaultInstArg a -> loadInstArg a + DefaultInstAnonArg ds -> mapM_ depsOfDecl ds + NamedInstArgs args -> mapM_ loadNamedInstArg args + InterfaceModule s -> mapM_ 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 = do _ <- loadModuleFrom False i + pure () + + loadImpName src l = + case thing l of + ImpTop f -> loadI (src l { thing = f }) + _ -> pure () + + 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 } + _ -> pure () + + depsOfDecl d = + case d of + DImport li -> loadImpD li + + DModule TopLevel { tlValue = NestedModule nm } -> loadDeps nm + + DModParam mo -> loadImpName FromSigImport s + where s = mpSignature mo + + _ -> pure () + + @@ -444,38 +500,17 @@ getPrimMap = 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 @@ -487,6 +522,15 @@ checkSingleModule how isrc m = do -- rename everything renMod <- renameModule epgm + +{- + -- dump renamed + unless (thing (mName (R.rmModule renMod)) == preludeName) + do (io $ print (T.pp renMod)) + -- io $ exitSuccess +--} + + -- when generating the prim map for the typechecker, if we're checking the -- prelude, we have to generate the map from the renaming environment, as we -- don't have the interface yet. @@ -495,21 +539,22 @@ checkSingleModule how isrc m = do 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 } @@ -545,6 +590,17 @@ moduleLinter m = TCLinter , 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 @@ -554,8 +610,8 @@ data TCAction i o = TCAction } 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) @@ -587,8 +643,9 @@ typecheck act i params env = do 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 @@ -596,25 +653,29 @@ genInferInput r prims params env' = do 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 } diff --git a/src/Cryptol/ModuleSystem/Binds.hs b/src/Cryptol/ModuleSystem/Binds.hs new file mode 100644 index 000000000..774d79ada --- /dev/null +++ b/src/Cryptol/ModuleSystem/Binds.hs @@ -0,0 +1,437 @@ +{-# 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 <- sigConstraints 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) + +-- 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 (singletonNS NSType thing ntName `mappend` singletonNS NSValue 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 (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 + SigConstraint {} -> mempty + 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 methdods 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 index da596685a..db35f35d8 100644 --- a/src/Cryptol/ModuleSystem/Env.hs +++ b/src/Cryptol/ModuleSystem/Env.hs @@ -12,6 +12,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Cryptol.ModuleSystem.Env where #ifndef RELOCATABLE @@ -35,6 +36,7 @@ import Control.Monad (guard,mplus) import qualified Control.Exception as X import Data.Function (on) import Data.Set(Set) +import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map import Data.Semigroup @@ -104,7 +106,7 @@ data CoreLint = NoCoreLint -- ^ Don't run core lint resetModuleEnv :: ModuleEnv -> IO ModuleEnv resetModuleEnv env = do for_ (getLoadedModules $ meLoadedModules env) $ \lm -> - case lmForeignSrc lm of + case lmForeignSrc (lmData lm) of Just fsrc -> unloadForeignSrc fsrc _ -> pure () pure env @@ -178,9 +180,9 @@ loadedModules = map lmModule . getLoadedModules . meLoadedModules 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)) ] @@ -191,10 +193,15 @@ hasParamModules = not . null . lmLoadedParamModules . meLoadedModules allDeclGroups :: ModuleEnv -> [T.DeclGroup] allDeclGroups = concatMap T.mDecls . loadedNonParamModules +data ModContextParams = + InterfaceParams T.ModParamNames + | FunctorParams T.FunctorParams + | NoParams + -- | 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 @@ -206,7 +213,7 @@ data ModContext = ModContext -- 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 @@ -215,14 +222,15 @@ instance Semigroup ModContext where 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 @@ -236,16 +244,36 @@ modContextOf mname me = 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 = 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 = ifParams localIface - , mctxExported = ifaceDeclsNames (ifPublic localIface) - , mctxDecls = mconcat (ifPrivate localIface : loadedDecls) + { 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 @@ -310,24 +338,44 @@ data LoadedModules = LoadedModules , lmLoadedParamModules :: [LoadedModule] -- ^ Loaded parameterized modules. + , lmLoadedSignatures :: ![LoadedSignature] + } deriving (Show, Generic, NFData) +getLoadedEntities :: + LoadedModules -> Map ModName (Either LoadedSignature LoadedModule) +getLoadedEntities lm = + Map.fromList $ [ (lmName x, Right x) | x <- lmLoadedModules lm ] ++ + [ (lmName x, Right x) | x <- lmLoadedParamModules lm ] ++ + [ (lmName x, Left 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' @@ -342,32 +390,81 @@ data LoadedModule = LoadedModule , lmNamingEnv :: !R.NamingEnv -- ^ What's in scope in this module - , lmInterface :: Iface + , lmFingerprint :: Fingerprint + + , 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 -> Fingerprint -> R.NamingEnv -> + ModName -> T.ModParamNames -> + LoadedModules -> LoadedModules +addLoadedSignature path ident fp 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 + , lmFingerprint = fp + } -- | Add a freshly loaded module. If it was previously loaded, then -- the new version is ignored. @@ -386,20 +483,24 @@ addLoadedModule path ident fp nameEnv fsrc tm lm , lmFilePath = path , lmModuleId = ident , lmNamingEnv = nameEnv - , lmInterface = T.genIface tm - , lmModule = tm + , lmData = LoadedModuleData + { lmdInterface = T.genIface tm + , lmdModule = tm + , lmForeignSrc = fsrc + } , lmFingerprint = fp - , lmForeignSrc = fsrc } -- | 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) } -- Dynamic Environments -------------------------------------------------------- @@ -444,6 +545,8 @@ deIfaceDecls DEnv { deDecls = dgs, deTySyns = tySyns } = , 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 index d6a251232..d35110b64 100644 --- a/src/Cryptol/ModuleSystem/Exports.hs +++ b/src/Cryptol/ModuleSystem/Exports.hs @@ -14,27 +14,28 @@ import Cryptol.Parser.AST import Cryptol.Parser.Names(namesD,tnamesD,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) }] - -names :: (a -> ([Located a'], b)) -> TopLevel a -> [TopLevel a'] -names by td = [ td { tlValue = thing n } | n <- fst (by (tlValue td)) ] +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) + Include {} -> [] + DImport {} -> [] + DParamDecl {} -> [] + DInterfaceConstraint {} -> [] + DModule nested -> + case tlValue nested of + NestedModule x -> + [exportName NSModule nested { tlValue = thing (mName x) }] + DModParam {} -> [] + where + names by td = [ td { tlValue = thing n } | n <- fst (by (tlValue td)) ] + newtype ExportSpec name = ExportSpec (Map Namespace (Set name)) @@ -55,6 +56,9 @@ exportName ns n $ 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/InstantiateModule.hs b/src/Cryptol/ModuleSystem/InstantiateModule.hs deleted file mode 100644 index 8cf44a94c..000000000 --- a/src/Cryptol/ModuleSystem/InstantiateModule.hs +++ /dev/null @@ -1,330 +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) - - -- TODO: this doesn't exist in the new module system, so it will have to - -- be implemented differently there anyway - EPropGuards _guards _ty -> panic "inst" ["This is not implemented for EPropGuards yet."] - - -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 - DForeign t -> DForeign t - 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 index b49ba62ba..7eab31ca9 100644 --- a/src/Cryptol/ModuleSystem/Interface.hs +++ b/src/Cryptol/ModuleSystem/Interface.hs @@ -16,18 +16,14 @@ module Cryptol.ModuleSystem.Interface ( Iface , IfaceG(..) , IfaceDecls(..) - , IfaceTySyn, ifTySynName - , IfaceNewtype , IfaceDecl(..) - , IfaceParams(..) + , IfaceNames(..) + , ifModName , emptyIface , ifacePrimMap - , noIfaceParams - , isEmptyIfaceParams + , ifaceForgetName , ifaceIsFunctor - , flatPublicIface - , flatPublicDecls , filterIfaceDecls , ifaceDeclsNames ) where @@ -49,70 +45,72 @@ import Cryptol.Utils.Ident (ModName) 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) - ) - - where - (fun,nofun) = Map.partition ifaceIsFunctor (ifModules ifs) +-- | Remove the name of a module. This is useful for dealing with collections +-- of modules, as in `Map (ImpName Name) (IfaceG ())`. +ifaceForgetName :: IfaceG name -> IfaceG () +ifaceForgetName i = i { ifNames = newNames } + where newNames = (ifNames i) { ifsName = () } + +-- | Access the name of a module. +ifModName :: IfaceG name -> name +ifModName = ifsName . ifNames + +-- | Information about the names in a module. +data IfaceNames name = IfaceNames + { ifsName :: name -- ^ Name of this submodule + , ifsNested :: Set Name -- ^ Things nested in this module + , ifsDefines :: Set Name -- ^ Things defined in this module + , ifsPublic :: Set Name -- ^ Subset of `ifsDefines` that is public + , ifsDoc :: !(Maybe Text) -- ^ Documentation + } deriving (Show, Generic, NFData) +-- | Is this interface for a functor. +ifaceIsFunctor :: IfaceG name -> Bool +ifaceIsFunctor = not . Map.null . ifParams -type Iface = IfaceG ModName - -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 @@ -122,6 +120,8 @@ filterIfaceDecls p ifs = IfaceDecls , 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 @@ -133,6 +133,8 @@ ifaceDeclsNames i = Set.unions [ Map.keysSet (ifTySyns i) , Map.keysSet (ifAbstractTypes i) , Map.keysSet (ifDecls i) , Map.keysSet (ifModules i) + , Map.keysSet (ifFunctors i) + , Map.keysSet (ifSignatures i) ] @@ -143,27 +145,31 @@ instance Semigroup IfaceDecls where , 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 l r = l <> r mconcat ds = IfaceDecls { ifTySyns = Map.unions (map ifTySyns ds) , ifNewtypes = Map.unions (map ifNewtypes ds) , ifAbstractTypes = Map.unions (map ifAbstractTypes ds) , ifDecls = Map.unions (map ifDecls ds) , 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 @@ -178,14 +184,7 @@ data IfaceDecl = IfaceDecl -- -- NOTE: the map will expose /both/ public and private names. ifacePrimMap :: Iface -> PrimMap -ifacePrimMap Iface { .. } = - PrimMap { primDecls = merge primDecls - , primTypes = merge primTypes } - where - merge f = Map.union (f public) (f private) - - public = ifaceDeclsPrimMap ifPublic - private = ifaceDeclsPrimMap ifPrivate +ifacePrimMap = ifaceDeclsPrimMap . ifDefines ifaceDeclsPrimMap :: IfaceDecls -> PrimMap ifaceDeclsPrimMap IfaceDecls { .. } = diff --git a/src/Cryptol/ModuleSystem/Monad.hs b/src/Cryptol/ModuleSystem/Monad.hs index 203cc70cd..b811a5b90 100644 --- a/src/Cryptol/ModuleSystem/Monad.hs +++ b/src/Cryptol/ModuleSystem/Monad.hs @@ -10,6 +10,8 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BlockArguments #-} module Cryptol.ModuleSystem.Monad where import Cryptol.Eval (EvalEnv,EvalOpts(..)) @@ -19,6 +21,7 @@ import Cryptol.Backend.FFI.Error import qualified Cryptol.Backend.Monad as E import Cryptol.ModuleSystem.Env +import qualified Cryptol.ModuleSystem.Env as MEnv import Cryptol.ModuleSystem.Fingerprint import Cryptol.ModuleSystem.Interface import Cryptol.ModuleSystem.Name (FreshM(..),Supply) @@ -47,7 +50,6 @@ 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 @@ -65,6 +67,7 @@ import Prelude.Compat data ImportSource = FromModule P.ModName | FromImport (Located P.Import) + | FromSigImport (Located P.ModName) | FromModuleInstance (Located P.ModName) deriving (Show, Generic, NFData) @@ -75,6 +78,7 @@ instance PP ImportSource where ppPrec _ is = case is of FromModule n -> text "module name" <+> pp n FromImport li -> text "import of module" <+> pp (P.iModule (P.thing li)) + FromSigImport l -> text "import of interface" <+> pp (P.thing l) FromModuleInstance l -> text "instantiation of module" <+> pp (P.thing l) @@ -84,6 +88,7 @@ importedModule is = FromModule n -> n FromImport li -> P.iModule (P.thing li) FromModuleInstance l -> P.thing l + FromSigImport l -> P.thing l data ModuleError @@ -115,11 +120,6 @@ data ModuleError -- ^ 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 @@ -148,9 +148,6 @@ instance NFData ModuleError where 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` () @@ -209,17 +206,6 @@ instance PP ModuleError where 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) @@ -279,16 +265,6 @@ duplicateModuleName :: P.ModName -> FilePath -> FilePath -> ModuleM a duplicateModuleName name path1 path2 = ModuleT (raise (DuplicateModuleName name path1 path2)) -importParamModule :: P.ModName -> ModuleM a -importParamModule x = ModuleT (raise (ImportedParamModule x)) - -failedToParameterizeModDefs :: P.ModName -> [T.Name] -> ModuleM a -failedToParameterizeModDefs x xs = - ModuleT (raise (FailedToParameterizeModDefs x xs)) - -notAParameterizedModule :: P.ModName -> ModuleM a -notAParameterizedModule x = ModuleT (raise (NotAParameterizedModule x)) - ffiLoadErrors :: P.ModName -> [FFILoadError] -> ModuleM a ffiLoadErrors x errs = ModuleT (raise (FFILoadErrors x errs)) @@ -449,13 +425,17 @@ modifyModuleEnv f = ModuleT $ do 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 @@ -474,12 +454,12 @@ interactive = loadingModule interactiveName 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 @@ -489,16 +469,15 @@ getImportSource = ModuleT $ do 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 + Left sig -> Left (lmData sig) + Right mo -> Right (lmdInterface (lmData mo)) getLoaded :: P.ModName -> ModuleM T.Module getLoaded mn = ModuleT $ @@ -507,6 +486,20 @@ getLoaded mn = ModuleT $ 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) @@ -531,13 +524,13 @@ setSupply supply = ModuleT $ 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 -> Maybe ForeignSrc -> T.Module -> + ModulePath -> Fingerprint -> NamingEnv -> Maybe ForeignSrc -> T.TCTopEntity -> ModuleM () loadedModule path fp nameEnv fsrc m = ModuleT $ do env <- get @@ -545,16 +538,21 @@ loadedModule path fp nameEnv fsrc m = ModuleT $ do InFile p -> unModuleT $ io (canonicalizePath p) InMem l _ -> pure l - set $! env { meLoadedModules = addLoadedModule path ident fp nameEnv fsrc m - (meLoadedModules env) } + let newLM = + case m of + T.TCTopModule mo -> addLoadedModule path ident fp nameEnv fsrc mo + T.TCTopSignature x s -> addLoadedSignature path ident fp nameEnv x s + + set $! env { meLoadedModules = newLM (meLoadedModules env) } + modifyEvalEnvM :: Traversable t => (EvalEnv -> E.Eval (t EvalEnv)) -> ModuleM (t ()) modifyEvalEnvM f = ModuleT $ do env <- get let evalEnv = meEvalEnv env - inBase (E.runEval mempty (f evalEnv)) - >>= traverse (\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 .) diff --git a/src/Cryptol/ModuleSystem/Name.hs b/src/Cryptol/ModuleSystem/Name.hs index beab470a5..1b1f14134 100644 --- a/src/Cryptol/ModuleSystem/Name.hs +++ b/src/Cryptol/ModuleSystem/Name.hs @@ -16,6 +16,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RankNTypes #-} -- for the instances of RunM and BaseM {-# LANGUAGE UndecidableInstances #-} @@ -31,6 +33,10 @@ module Cryptol.ModuleSystem.Name ( , nameNamespace , asPrim , asOrigName + , nameModPath + , nameModPathMaybe + , nameTopModule + , nameTopModuleMaybe , ppLocName , Namespace(..) , ModPath(..) @@ -38,15 +44,15 @@ module Cryptol.ModuleSystem.Name ( -- ** 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 +63,7 @@ module Cryptol.ModuleSystem.Name ( 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,35 +73,23 @@ import Data.Char(isAlpha,toUpper) -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 @@ -150,7 +145,12 @@ cmpNameDisplay disp l r = 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 +173,13 @@ cmpNameDisplay disp l r = -- 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 +187,12 @@ instance PP Name where 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 +202,18 @@ ppLocName n = pp Located { srcRange = nameLoc n, thing = n } 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 - -nameInfo :: Name -> NameInfo -nameInfo = nInfo +nameNamespace n = case nInfo n of + GlobalName _ og -> ogNamespace og + LocalName ns _ -> ns nameLoc :: Name -> Range nameLoc = nLoc @@ -216,29 +223,41 @@ nameFixity = nFixity -- | 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 ----------------------------------------------------------------- @@ -271,6 +290,9 @@ newtype SupplyT m a = SupplyT { unSupply :: StateT Supply m a } runSupplyT :: Monad m => Supply -> SupplyT m a -> m (a,Supply) runSupplyT s (SupplyT m) = runStateT s m +runSupply :: Supply -> (forall m. FreshM m => m a) -> (a,Supply) +runSupply s m = runIdentity (runSupplyT s m) + instance Monad m => Functor (SupplyT m) where fmap f (SupplyT m) = SupplyT (fmap f m) {-# INLINE fmap #-} @@ -315,8 +337,8 @@ data Supply = Supply !Int 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 +352,77 @@ nextUnique (Supply n) = s' `seq` (n,s') 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') - -paramModRecParam :: Name -paramModRecParam = Name { nInfo = Parameter - , nFixity = Nothing - , nIdent = packIdent "$modParams" - , nLoc = emptyRange - , nUnique = 0x01 - , nNamespace = NSValue - } +mkLocal :: Namespace -> Ident -> Range -> Supply -> (Name,Supply) +mkLocal ns ident loc s = (name, s') + where + (u,s') = nextUnique s + name = Name { nUnique = u + , nLoc = loc + , nFixity = Nothing + , nInfo = LocalName ns ident + } + +{- | Make a local name derived from the given name. +This is a bit questionable, +but it is used by the translation to SAW Core -} +asLocal :: Namespace -> Name -> Name +asLocal ns x = + case nameInfo x of + GlobalName _ og -> x { nInfo = LocalName ns (ogName og) } + LocalName {} -> x + +mkModParam :: + ModPath {- ^ Module containing the parameter -} -> + Ident {- ^ Name of the module parameter -} -> + Range {- ^ Location -} -> + Name {- ^ Name in the signature -} -> + Supply -> (Name, Supply) +mkModParam own pname rng n s = (name, s') + where + (u,s') = nextUnique s + name = Name { nUnique = u + , nInfo = GlobalName + UserName + OrigName + { ogModule = own + , ogName = nameIdent n + , ogNamespace = nameNamespace n + , ogSource = FromModParam pname + } + , nFixity = nFixity n + , nLoc = rng + } + +-- | This is used when instantiating functors +freshNameFor :: ModPath -> Name -> Supply -> (Name,Supply) +freshNameFor mpath x s = (newName, s1) + where + (u,s1) = nextUnique s + newName = + x { nUnique = u + , nInfo = + case nInfo x of + GlobalName src og -> GlobalName src og { ogModule = mpath + , ogSource = FromFunctorInst } + LocalName {} -> panic "freshNameFor" ["Unexpected local",show x] + } -- Prim Maps ------------------------------------------------------------------- diff --git a/src/Cryptol/ModuleSystem/Names.hs b/src/Cryptol/ModuleSystem/Names.hs new file mode 100644 index 000000000..52d6031fe --- /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 index 91969b482..dc4f931eb 100644 --- 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) +instance Monoid NamingEnv where + mempty = NamingEnv Map.empty + {-# INLINE mempty #-} + +instance Semigroup NamingEnv where + NamingEnv l <> NamingEnv r = + NamingEnv (Map.unionWith (Map.unionWith (<>)) l r) + +instance PP NamingEnv where + ppPrec _ (NamingEnv mps) = vcat $ map ppNS $ Map.toList mps + where ppNS (ns,xs) = nest 2 (vcat (pp ns : map ppNm (Map.toList xs))) + ppNm (x,as) = pp x <+> "->" <+> commaSep (map pp (namesToList as)) + + +{- | This "joins" two naming environments by matching the text name. +The result maps the unique names from the first environment with the +matching names in the second. This is used to compute the naming for +an instantiated functor: + * if the left environment has the defined names of the functor, and + * the right one has the defined names of the instantiation, then + * the result maps functor names to instance names. +-} +zipByTextName :: NamingEnv -> NamingEnv -> Map Name Name +zipByTextName (NamingEnv k) (NamingEnv v) = Map.fromList $ doInter doNS k v + where + doInter :: Ord k => (a -> b -> [c]) -> Map k a -> Map k b -> [c] + doInter f a b = concat (Map.elems (Map.intersectionWith f a b)) + + doNS :: Map PName Names -> Map PName Names -> [(Name,Name)] + doNS as bs = doInter doPName as bs + + doPName :: Names -> Names -> [(Name,Name)] + doPName xs ys = [ (x,y) | x <- namesToList xs, y <- namesToList ys ] + -- NOTE: we'd exepct that there are no ambiguities in the environments. + +-- | Keep only the bindings in the 1st environment that are *NOT* in the second. +without :: NamingEnv -> NamingEnv -> NamingEnv +NamingEnv keep `without` NamingEnv remove = NamingEnv result + where + result = Map.differenceWith rmInNS keep remove + rmInNS a b = let c = Map.differenceWith diffNames a b + in if Map.null c then Nothing else Just c + -- | All names mentioned in the environment namingEnvNames :: NamingEnv -> Set Name namingEnvNames (NamingEnv xs) = - Set.fromList $ concatMap (concat . Map.elems) $ Map.elems xs + case unionManyNames (mapMaybe (unionManyNames . Map.elems) (Map.elems xs)) of + Nothing -> Set.empty + Just (One x) -> Set.singleton x + Just (Ambig as) -> as + +-- | Get a unqualified naming environment for the given names +namingEnvFromNames :: Set Name -> NamingEnv +namingEnvFromNames xs = NamingEnv (foldl' add mempty xs) + where + add mp x = let ns = nameNamespace x + txt = nameIdent x + in Map.insertWith (Map.unionWith (<>)) + ns (Map.singleton (mkUnqual txt) (One x)) + mp -- | Get the names in a given namespace -namespaceMap :: Namespace -> NamingEnv -> Map PName [Name] +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 -> [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 +lookupNS :: Namespace -> PName -> NamingEnv -> Maybe Names +lookupNS ns x env = Map.lookup x (namespaceMap ns env) --- | Return a list of type-level names to which this parsed name may refer. -lookupTypeNames :: PName -> NamingEnv -> [Name] -lookupTypeNames = lookupNS NSType +-- | Resolve a name in the given namespace. +lookupListNS :: Namespace -> PName -> NamingEnv -> [Name] +lookupListNS ns x env = + case lookupNS ns x env of + Nothing -> [] + Just as -> namesToList as -- | Singleton renaming environment for the given namespace. singletonNS :: Namespace -> PName -> Name -> NamingEnv -singletonNS ns pn n = NamingEnv (Map.singleton ns (Map.singleton pn [n])) - --- | Singleton expression renaming environment. -singletonE :: PName -> Name -> NamingEnv -singletonE = singletonNS NSValue - --- | Singleton type renaming environment. -singletonT :: PName -> Name -> NamingEnv -singletonT = singletonNS NSType - - -namingEnvRename :: (Name -> Name) -> NamingEnv -> NamingEnv -namingEnvRename f (NamingEnv mp) = NamingEnv (ren <$> mp) - where - ren nsm = map f <$> nsm - - -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 #-} - - --- | 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) - -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) +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 @@ toPrimMap env = } 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 @@ toNameDisp env = NameDisp (`Map.lookup` names) 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,122 @@ toNameDisp env = NameDisp (`Map.lookup` names) -- 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 +filterPNames :: (PName -> Bool) -> NamingEnv -> NamingEnv +filterPNames p (NamingEnv env) = NamingEnv (Map.mapMaybe checkNS env) + where + checkNS nsMap = let new = Map.filterWithKey (\n _ -> p n) nsMap + in if Map.null new then Nothing else Just new +filterUNames :: (Name -> Bool) -> NamingEnv -> NamingEnv +filterUNames p (NamingEnv env) = NamingEnv (Map.mapMaybe check env) + where + check nsMap = let new = Map.mapMaybe (filterNames p) nsMap + in if Map.null new then Nothing else Just new + + +-- | Find the ambiguous entries in an environmet. +-- A name is ambiguous if it might refer to multiple entities. +findAmbig :: NamingEnv -> [ [Name] ] +findAmbig (NamingEnv ns) = + [ Set.toList xs + | mp <- Map.elems ns + , Ambig xs <- Map.elems mp + ] + +-- | Get the subset of the first environment that shadows something +-- in the second one. +findShadowing :: NamingEnv -> NamingEnv -> [ (PName,Name,[Name]) ] +findShadowing (NamingEnv lhs) rhs = + [ (p, anyOne xs, namesToList ys) + | (ns,mp) <- Map.toList lhs + , (p,xs) <- Map.toList mp + , Just ys <- [ lookupNS ns p rhs ] + ] + +-- | Do an arbitrary choice for ambiguous names. +-- We do this to continue checking afetr we've reported an ambiguity error. +forceUnambig :: NamingEnv -> NamingEnv +forceUnambig (NamingEnv mp) = NamingEnv (fmap (One . anyOne) <$> mp) -- | Like mappend, but when merging, prefer values on the lhs. shadowing :: NamingEnv -> NamingEnv -> NamingEnv shadowing (NamingEnv l) (NamingEnv r) = NamingEnv (Map.unionWith Map.union l r) +mapNamingEnv :: (Name -> Name) -> NamingEnv -> NamingEnv +mapNamingEnv f (NamingEnv mp) = NamingEnv (fmap (mapNames f) <$> mp) + travNamingEnv :: Applicative f => (Name -> f Name) -> NamingEnv -> f NamingEnv travNamingEnv f (NamingEnv mp) = - NamingEnv <$> traverse (traverse (traverse f)) mp - - -{- | 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) + NamingEnv <$> traverse (traverse (travNames f)) mp +isEmptyNamingEnv :: NamingEnv -> Bool +isEmptyNamingEnv (NamingEnv mp) = Map.null mp +-- This assumes that we've been normalizing away empty maps, hopefully +-- we've been doing it everywhere. -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 (mkParameter ns (getIdent thing) rng) -newtype BuildNamingEnv = BuildNamingEnv { runBuild :: SupplyT Id NamingEnv } - - -buildNamingEnv :: BuildNamingEnv -> Supply -> (NamingEnv,Supply) -buildNamingEnv b supply = runId $ runSupplyT supply $ runBuild b - --- | Generate a 'NamingEnv' using an explicit supply. -defsOf :: BindsNames a => a -> Supply -> (NamingEnv,Supply) -defsOf = buildNamingEnv . namingEnv - - --------------------------------------------------------------------------------- --- 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) - --------------------------------------------------------------------------------- - - - - -instance Semigroup BuildNamingEnv where - BuildNamingEnv a <> BuildNamingEnv b = BuildNamingEnv $ - do x <- a - y <- b - return (mappend x y) + toPName n = mkUnqual (nameIdent n) -instance Monoid BuildNamingEnv where - mempty = BuildNamingEnv (pure mempty) + fromTy tp = let nm = T.mtpName tp + in (toPName nm, One nm) - mappend = (<>) + fromFu f = (toPName f, One f) - mconcat bs = BuildNamingEnv $ - do ns <- sequence (map runBuild bs) - return (mconcat ns) + fromTS ts = (toPName (T.tsName ts), One (T.tsName ts)) --------------------------------------------------------------------------------- +-- | Generate a naming environment from a declaration interface, where none of +-- the names are qualified. +unqualifiedEnv :: IfaceDecls -> NamingEnv +unqualifiedEnv IfaceDecls { .. } = + mconcat [ exprs, tySyns, ntTypes, absTys, ntExprs, mods, sigs ] + where + toPName n = mkUnqual (nameIdent n) + exprs = mconcat [ singletonNS NSValue (toPName n) n + | n <- Map.keys ifDecls ] --- | 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 [ singletonNS NSType (toPName n) n + | n <- Map.keys ifNewtypes ] -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 +294,12 @@ interpImportEnv imp public = qualified -- 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 index 9e932149a..51f7d371e 100644 --- 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,279 @@ import Prelude () 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 delcarations 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) - - pure (env,ds1) - --- | 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 -> [] - ) - - - classify d (ms,ds) = - case d of - DModule tl -> (tl : ms, ds) - _ -> (ms, d : ds) + do -- Step 1: add implicit importgs + let ds = addImplicitNestedImports ds0 -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" ] + -- Step 2: compute what's defined + (defs,errs) <- liftSupply (modBuilder (topDeclsDefs (TopModule m) ds)) + mapM_ recordError errs + + -- Step 3: resolve imports + extern <- getExternal + resolvedMods <- liftSupply (resolveImports extern (TopMod m defs)) + + let pathToName = Map.fromList [ (Nested (nameModPath x) (nameIdent x), x) + | ImpNested x <- Map.keys resolvedMods ] + + + setResolvedLocals resolvedMods $ + setNestedModule pathToName + do env <- rmodDefines <$> lookupResolved (ImpTop m) + + -- we already checked for duplicates in Step 2 + ds1 <- shadowNames' CheckNone env (renameTopDecls' ds) + -- record a use of top-level names to avoid + -- unused name warnings + let exports = exportedDecls ds1 + mapM_ recordUse (exported NSType exports) + + pure (env,ds1) + +-------------------------------------------------------------------------------- +-- Stuff below is related to Step 4 of the algorighm. 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 - - (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) +renameModule' mname m = + setCurMod + case mname of + ImpTop r -> TopModule r + ImpNested r -> Nested (nameModPath r) (nameIdent r) + + do resolved <- lookupResolved mname + let env = rmodDefines resolved + + + (inScope,newDef) <- + shadowNames' CheckNone (rmodImports resolved) + do (paramEnv,params) <- + shadowNames' CheckNone env (doModParams (mModParams m)) + + shadowNames' CheckOverlap (env <> paramEnv) $ + -- we check that defined names and ones that came from parameters + -- do not clash, as this would be very confusing. + + setModParams params + do inScope <- getNamingEnv + newDef <- case mDef m of + NormalModule ds -> + do ds1 <- renameTopDecls' ds + let exports = exportedDecls ds1 + mapM_ recordUse (exported NSType exports) + pure (NormalModule ds1) + + 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 + pure (FunctorInstance f' as' imap) + + InterfaceModule s -> + InterfaceModule <$> renameIfaceModule mname s + + pure (inScope, newDef) + return (inScope, m { mDef = newDef }) + +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 + +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,7 +318,7 @@ renameDecls ds = 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 @@ -212,24 +338,125 @@ checkSameModule xs = 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 ] + ] + + + +{- NOTE: Dependincies on Top Level Constraints + =========================================== + +For the new module system, things using a parameter depend on the parameter +declaration (i.e., `import signature`), which depends on the signature, +so dependencies on constraints in there should be OK. + +However, we'd like to have a mechanism for declaring top level constraints in +a functor, that can impose constraints across types from *different* +parameters. For the moment, we reuse `parameter type constrint 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 -renameTopDecls' :: - (NestedMods,ModPath) -> [TopDecl PName] -> RenameM [TopDecl Name] -renameTopDecls' info ds = - do (ds1,deps) <- depGroup (traverse (renameWithMods info) ds) + let rawDepsFor x = Map.findWithDefault Set.empty x deps + isTyParam x = nameNamespace x == NSType && x `Map.member` fromParams - let (noNameDs,nameDs) = partitionEithers (map topDeclName ds1) + + (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 + + + {- See [NOTE: Dependincies 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 + ModuleArg {} -> [] + ParameterArg p -> + case Map.lookup p localParams of + Just i -> [i] + Nothing -> [] + _ -> [] + + mkDepName x = case Map.lookup x fromParams of + Just dn -> dn + Nothing -> NamedThing x + + toNode (d,x) = ((d,x),x, addCtrs (d,x) ++ + addModParams d ++ + map mkDepName ( Set.toList ( Map.findWithDefault Set.empty x deps) )) + ordered = stronglyConnComp (map toNode nameDs) fromSCC x = case x of @@ -237,7 +464,7 @@ renameTopDecls' info ds = 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,35 +480,46 @@ renameTopDecls' info ds = rds <- mapM fromSCC ordered pure (concat (noNameDs:rds)) where + + -- This indicates if a declaration might depend on the constraints in scope. + -- Since uses of contraints are not implicitly named, value declarations + -- are assumed to potentially use the constraints. + + -- XXX: This is inacurate, 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 mentiones at least one + -- type parameter somewhere. + + -- XXX: Besides, types might need constraints for well-formedness... + -- This is just bogus 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] @@ -308,136 +546,187 @@ topDeclName topDecl = 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)) 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 -> Right (topDecl, ConstratintAt (srcRange ds)) + DImport {} -> noName + DModParam m -> Right ( topDecl + , ModParamName (srcRange (mpSignature m)) + (mpName m)) + Include {} -> bad "Include" + DParamDecl {} -> bad "DParamDecl" where noName = Left topDecl hasName n = Right (topDecl, NamedThing n) 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 containg everything that's in scope +except for the module parameters. We don't need to compute a fixed point here +because the signatures (and hence module parameters) cannot contain signatures. + +The resulting naming environment contains the new names introduced by this +parameter. +-} +doModParam :: + ModParam PName -> + RenameM (NamingEnv, RenModParam) +doModParam mp = + do let sigName = mpSignature mp + loc = srcRange sigName + withLoc loc + do me <- getCurMod + + (sigName',isFake) <- + case thing sigName of + ImpTop t -> pure (ImpTop t, False) + -- XXX: should we record a dpendency here? + -- Not sure what the dependencies are for.. + + ImpNested n -> + do mb <- resolveNameMaybe NameUse NSModule n + (nm,isFake) <- case mb of + Just rnm -> pure (rnm,False) + Nothing -> + do rnm <- reportUnboundName NSModule n + pure (rnm,True) + case modPathCommon me (nameModPath nm) of + Just (_,[],_) -> + recordError + (InvalidDependency [ModPath me, NamedThing nm]) + _ -> pure () + pure (ImpNested nm, isFake) + + unless isFake + (checkIsModule (srcRange sigName) sigName' ASignature) + sigEnv <- if isFake then pure mempty else lookupDefines sigName' + + + -- XXX: It seems a bit odd to use "newModParam" for the names to be used + -- for the instaciated 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) --------------------------------------------------------------------------------- --- Compute names coming through `open` statements. - -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 - } --- | 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. - -} - -{- | 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 -------------------------------------------------------------------------------- +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 - - 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 } + Decl d -> Decl <$> traverse rename d + DPrimType d -> DPrimType <$> traverse rename d + TDNewtype n -> TDNewtype <$> traverse rename n + Include n -> return (Include n) + DModule m -> DModule <$> traverse rename m + DImport li -> DImport <$> renI li + DModParam mp -> DModParam <$> rename mp + DInterfaceConstraint d ds -> + depsOf (ConstratintAt (srcRange ds)) + (DInterfaceConstraint d <$> rnLocated (mapM rename) ds) + DParamDecl {} -> panic "rename" ["DParamDecl"] + + + +renI :: Located (ImportG (ImpName PName)) -> + RenameM (Located (ImportG (ImpName Name))) +renI li = + withLoc (srcRange li) + do m <- rename (iModule i) + unless (isFakeName m) (recordImport (srcRange li) m) + pure li { thing = i { iModule = m } } + where + i = thing li + + +instance Rename ModParam where + rename mp = + do x <- rnLocated rename (mpSignature mp) + depsOf (ModParamName (srcRange (mpSignature mp)) (mpName mp)) + do ren <- renModParamInstance <$> getModParam (mpName mp) + + {- Here we add 2 "uses" to all type-level names intorduced, + 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) + + -- 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)) + + cts <- traverse rename (sigConstraints sig) + fun <- traverse rename (sigFunParams sig) + pure Signature + { sigImports = imps + , sigTypeParams = tps + , sigConstraints = cts + , sigFunParams = fun + } instance Rename ImpName where rename i = @@ -445,29 +734,37 @@ instance Rename ImpName where 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) + + +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 somehwere 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) @@ -495,10 +792,12 @@ instance Rename ParameterFun where 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 + SigConstraint ps -> SigConstraint <$> traverse (rnLocated rename) ps + 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 +808,7 @@ instance Rename Decl where 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 " ] @@ -539,42 +838,57 @@ resolveNameMaybe nt expected qn = 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 +904,8 @@ renameType nt = resolveName nt NSType 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. @@ -653,7 +968,7 @@ mkTInfix t@(TInfix x o1 f1 y) op@(o2,f2) z = 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 = @@ -718,7 +1033,8 @@ instance Rename UpdField where 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]) @@ -799,7 +1115,7 @@ checkLabels = foldM_ check [] . map labs 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) @@ -831,7 +1147,7 @@ mkEInfix e@(EInfix x o1 f1 y) op@(o2,f2) z = 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 = @@ -941,9 +1257,9 @@ patternEnv :: Pattern PName -> RenameM NamingEnv 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 @@ -981,16 +1297,16 @@ patternEnv = go -- 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) @@ -1025,3 +1341,20 @@ instance Rename PropSyn where 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 index 0f2d7894f..9e78652f7 100644 --- 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,33 +44,61 @@ data RenamerError | 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 + | InvalidFunctorImport (ImpName Name) + -- ^ Can't import functors directly --- We use this because parameter constrstaints have no names + | 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 normla 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 + | 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 @@ -119,19 +150,6 @@ instance PP RenamerError where , 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 +158,32 @@ instance PP RenamerError where 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 +193,11 @@ instance PP DepName where 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)) diff --git a/src/Cryptol/ModuleSystem/Renamer/ImplicitImports.hs b/src/Cryptol/ModuleSystem/Renamer/ImplicitImports.hs new file mode 100644 index 000000000..443cbf526 --- /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 index 000000000..b7edb70b6 --- /dev/null +++ b/src/Cryptol/ModuleSystem/Renamer/Imports.hs @@ -0,0 +1,577 @@ +{- | + +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 -> panic "resolveImports" + [ "Failed to finish a top-level instantiation" ] + + 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 withing 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 index 2c71969d4..b7880f707 100644 --- 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 @@ data RenamerInfo = RenamerInfo { renSupply :: Supply -- ^ Use to make new names , renContext :: ModPath -- ^ We are renaming things in here , renEnv :: NamingEnv -- ^ This is what's in scope - , renIfaces :: 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 @@ data RW = RW -- 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 @@ runRenamer info m = (res, warns) 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,13 +172,22 @@ runRenamer info m = (res, warns) 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 @@ -155,6 +200,56 @@ getCurMod = RenameM $ asks roCurMod getNamingEnv :: RenameM NamingEnv getNamingEnv = RenameM (asks roNames) +setResolvedLocals :: Map (ImpName Name) ResolvedLocal -> RenameM a -> RenameM a +setResolvedLocals mp (RenameM m) = + RenameM $ mapReader (\ro -> ro { roResolvedModules = mp }) m + +lookupResolved :: ImpName Name -> RenameM ResolvedLocal +lookupResolved nm = + do mp <- RenameM (roResolvedModules <$> ask) + pure case Map.lookup nm mp of + Just r -> r + + -- XXX: could this happen because we couldn't resolve a module? + Nothing -> panic "lookupResolved" + [ "Missing module: " ++ show nm ] + +setModParams :: [RenModParam] -> RenameM a -> RenameM a +setModParams ps (RenameM m) = + do let pmap = Map.fromList [ (renModParamName p, p) | p <- ps ] + + newFrom = + foldLoop ps mempty \p mp -> + let nm = ModParamName (renModParamRange p) (renModParamName p) + in foldLoop (Map.keys (renModParamInstance p)) mp \x -> + Map.insert x nm + + upd ro = ro { roModParams = pmap + , roFromModParam = newFrom <> roFromModParam ro + } + + RenameM (mapReader upd m) + + +foldLoop :: [a] -> b -> (a -> b -> b) -> b +foldLoop xs b f = foldl' (flip f) b xs + +getModParam :: Ident -> RenameM RenModParam +getModParam p = + do ps <- RenameM (roModParams <$> ask) + case Map.lookup p ps of + Just r -> pure r + Nothing -> panic "getModParam" [ "Missing module paramter", show p ] + +getNamesFromModParams :: RenameM (Map Name DepName) +getNamesFromModParams = RenameM (roFromModParam <$> ask) + +getLocalModParamDeps :: RenameM (Map Ident DepName) +getLocalModParamDeps = + do ps <- RenameM (roModParams <$> ask) + let toName mp = ModParamName (renModParamRange mp) (renModParamName mp) + pure (toName <$> ps) + setNestedModule :: Map ModPath Name -> RenameM a -> RenameM a setNestedModule mp (RenameM m) = @@ -164,11 +259,15 @@ nestedModuleOrig :: ModPath -> RenameM (Maybe Name) 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) = @@ -230,58 +329,39 @@ data EnvCheck = CheckAll -- ^ Check for overlap and shadowing | 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 :: Name -> RenameM () 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 @@ addDep x = 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) - isLocal nm = case nameInfo nm of - Declared m sys -> sys == UserName && - m == m0 && nm `Set.notMember` oldNames - Parameter -> 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 + -- returns true iff the name comes from a definition in a nested module, + -- including the current module + isNestd og = case modPathCommon m0 (ogModule og) of + Just (_,[],_) | FromDefinition <- ogSource og -> True + _ -> False + + isLocal nm = case nameInfo nm of + GlobalName sys og -> + sys == UserName && isNestd og && nm `Set.notMember` oldNames + LocalName {} -> True + + +getExternal :: RenameM (ImpName Name -> Mod ()) +getExternal = + do mp <- roExternal <$> RenameM ask + pure \nm -> let mb = do t <- case nm of + ImpTop t -> pure t + ImpNested x -> nameTopModuleMaybe x + (_,mp1) <- Map.lookup t mp + Map.lookup nm mp1 + in case mb of + Just m -> m + Nothing -> panic "getExternal" + ["Missing external name", show (pp nm) ] + +getExternalMod :: ImpName Name -> RenameM (Mod ()) +getExternalMod nm = ($ nm) <$> getExternal + +-- | Returns `Nothing` if the name does not refer to a module (i.e., it is a sig) +getTopModuleIface :: ImpName Name -> RenameM (Maybe Iface) +getTopModuleIface nm = + do mp <- roExternal <$> RenameM ask + let t = case nm of + ImpTop t' -> t' + ImpNested x -> nameTopModule x + case Map.lookup t mp of + Just (mb, _) -> pure mb + Nothing -> panic "getTopModuleIface" + ["Missing external module", show (pp nm) ] + +{- | Record an import: + * record external dependency if the name refers to an external import + * record an error if the imported thing is a functor +-} +recordImport :: Range -> ImpName Name -> RenameM () +recordImport r i = + do ro <- RenameM ask + case Map.lookup i (roResolvedModules ro) of + Just loc -> + case rmodKind loc of + AModule -> pure () + k -> recordError (ModuleKindMismatch r i AModule k) + Nothing -> + do mb <- getTopModuleIface i + case mb of + Nothing -> recordError (ModuleKindMismatch r i AModule ASignature) + Just iface + | ifaceIsFunctor iface -> + recordError (ModuleKindMismatch r i AModule AFunctor) + | otherwise -> + RenameM $ sets_ \s -> s { rwExternalDeps = ifDefines iface <> + rwExternalDeps s } + + +-- | Lookup a name either in the locally resolved thing or in an external module +lookupModuleThing :: ImpName Name -> RenameM (Either ResolvedLocal (Mod ())) +lookupModuleThing nm = + do ro <- RenameM ask + case Map.lookup nm (roResolvedModules ro) of + Just loc -> pure (Left loc) + Nothing -> Right <$> getExternalMod nm + +lookupDefines :: ImpName Name -> RenameM NamingEnv +lookupDefines nm = + do thing <- lookupModuleThing nm + pure case thing of + Left loc -> rmodDefines loc + Right e -> modDefines e + +checkIsModule :: Range -> ImpName Name -> ModKind -> RenameM () +checkIsModule r nm expect = + do thing <- lookupModuleThing nm + let actual = case thing of + Left rmod -> rmodKind rmod + Right mo -> modKind mo + unless (actual == expect) + (recordError (ModuleKindMismatch r nm expect actual)) + +lookupDefinesAndSubs :: ImpName Name -> RenameM (NamingEnv, Set Name) +lookupDefinesAndSubs nm = + do thing <- lookupModuleThing nm + pure case thing of + Left rmod -> ( rmodDefines rmod, rmodNested rmod) + Right m -> + ( modDefines m + , Set.unions [ Map.keysSet (modMods m) + , Map.keysSet (modInstances m) + ] + ) diff --git a/src/Cryptol/Parser.y b/src/Cryptol/Parser.y index a29cabc29..ff9733366 100644 --- a/src/Cryptol/Parser.y +++ b/src/Cryptol/Parser.y @@ -38,7 +38,6 @@ import Cryptol.Parser.LexerUtils hiding (mkIdent) 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,6 +83,7 @@ import Paths_cryptol '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) _)} @@ -141,7 +141,7 @@ import Paths_cryptol DOC { $$@(Located _ (Token (White DocStr) _)) } -%name vmodule vmodule +%name top_module top_module %name program program %name programLayout program_layout %name expr expr @@ -165,38 +165,62 @@ import Paths_cryptol %% -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 '=' 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 } - | modName '=' modName 'where' - 'v{' vmod_body 'v}' { mkModuleInstance $1 $3 $6 } +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 } 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 } + +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 } @@ -254,10 +278,37 @@ vtop_decl :: { [TopDecl PName] } | 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 })] } @@ -278,21 +329,28 @@ prim_bind :: { [TopDecl PName] } 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 'type' 'constraint' '(' type ')' + {% fmap (DParameterConstraint . + SigConstraint . distrLoc) (mkProp $5)} + | mbDoc 'type' 'constraint' '(' tuple_types ')' + {% fmap (DParameterConstraint . + SigConstraint . distrLoc) + (mkProp (at ($4,$6) (TTuple $5))) } + + | mbDoc typeOrPropSyn { mkIfacePropSyn (thing `fmap` $1) $2 } doc :: { Located Text } @@ -370,7 +428,16 @@ let_decl :: { Decl PName } | 'let' vars_comma ':' schema { at (head $2,$4) $ DSignature (reverse $2) $4 } - | 'type' name '=' type {% at ($1,$4) `fmap` mkTySyn $2 [] $4 } + | typeOrPropSyn { $1 } + + | 'infixl' NUM ops {% mkFixity LeftAssoc $2 (reverse $3) } + | 'infixr' NUM ops {% mkFixity RightAssoc $2 (reverse $3) } + | 'infix' NUM ops {% mkFixity NonAssoc $2 (reverse $3) } + + + +typeOrPropSyn :: { Decl PName } + : 'type' 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 @@ -383,10 +450,6 @@ let_decl :: { Decl PName } | 'type' 'constraint' tysyn_param op tysyn_param '=' type {% at ($2,$7) `fmap` mkPropSyn $4 [$3, $5] $7 } - | 'infixl' NUM ops {% mkFixity LeftAssoc $2 (reverse $3) } - | 'infixr' NUM ops {% mkFixity RightAssoc $2 (reverse $3) } - | 'infix' NUM ops {% mkFixity NonAssoc $2 (reverse $3) } - @@ -815,7 +878,8 @@ smodName :: { Located ModName } modName :: { Located ModName } : smodName { $1 } - | '`' smodName { fmap paramInstModName $2 } + | 'module' smodName { $2 } + | '`' smodName {% errorMessage $1 ["Backtick module imports are no longer supported."] } qname :: { Located PName } @@ -880,8 +944,8 @@ parseProgramWith cfg s = case res s of 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 index f53da61a9..0a5174741 100644 --- a/src/Cryptol/Parser/AST.hs +++ b/src/Cryptol/Parser/AST.hs @@ -16,6 +16,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleInstances #-} module Cryptol.Parser.AST ( -- * Names @@ -40,8 +41,20 @@ module Cryptol.Parser.AST -- * Declarations , Module , ModuleG(..) + , mDecls -- XXX: Temporary + , mImports - , mSubmoduleImports + , mModParams + , mIsFunctor + , isParamDecl + + , ModuleDefinition(..) + , ModuleInstanceArgs(..) + , ModuleInstanceNamedArg(..) + , ModuleInstanceArg(..) + , ModuleInstance + , emptyModuleInstance + , Program(..) , TopDecl(..) , Decl(..) @@ -60,6 +73,10 @@ module Cryptol.Parser.AST , ParameterType(..) , ParameterFun(..) , NestedModule(..) + , Signature(..) + , SigDecl(..) + , ModParam(..) + , ParamDecl(..) , PropGuardCase(..) -- * Interactive @@ -97,9 +114,11 @@ import Cryptol.Utils.Ident import Cryptol.Utils.RecordMap import Cryptol.Utils.PP +import Data.Map(Map) +import qualified Data.Map as Map import Data.List(intersperse) import Data.Bits(shiftR) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes,mapMaybe) import Data.Ratio(numerator,denominator) import Data.Text (Text) import Numeric(showIntAtBase,showFloat,showHFloat) @@ -127,36 +146,85 @@ type Rec e = RecordMap Ident (Range, e) 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) + +isParamDecl :: TopDecl a -> Bool +isParamDecl d = + case d of + DModParam {} -> True + DParamDecl {} -> True + _ -> False -type Module = ModuleG ModName +-- | A top-level module +type Module = ModuleG ModName +-- | A nested module. newtype NestedModule name = NestedModule (ModuleG name name) deriving (Show,Generic,NFData) @@ -169,39 +237,104 @@ modRange m = rCombs $ catMaybes , 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 + | DParameterConstraint (SigDecl 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 + 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 @@ -210,7 +343,7 @@ data ParameterType name = ParameterType , 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 @@ -219,12 +352,68 @@ data ParameterFun name = ParameterFun } 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 :: [SigDecl name] + -- ^ Constraints on the type parameters and type synonyms. + -- These are in order, because we should check them in the order they are written. + + , sigFunParams :: [ParameterFun name] -- ^ Value parameters + } deriving (Show,Generic,NFData) + +-- | A constraint or type synonym declared in an interface. +data SigDecl name = + SigConstraint [Located (Prop 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 @@ -553,11 +742,28 @@ instance HasLoc (TopDecl name) where 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 DParameterConstraint d -> getLoc d - DModule d -> getLoc d - DImport d -> getLoc d + +instance HasLoc (SigDecl name) where + getLoc decl = + case decl of + SigConstraint ps -> getLoc ps + 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))) @@ -588,6 +794,13 @@ instance HasLoc (Newtype name) where 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 + + -------------------------------------------------------------------------------- @@ -611,20 +824,53 @@ ppNamed' s (i,(_,v)) = pp i <+> text s <+> pp v 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)) - - - -instance (Show name, PPName name) => PP (NestedModule name) where - ppPrec _ (NestedModule m) = ppModule 2 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 (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 instance (Show name, PPName name) => PP (Program name) where @@ -637,27 +883,73 @@ instance (Show name, PPName name) => PP (TopDecl name) where DPrimType p -> pp p TDNewtype n -> pp n Include l -> text "include" <+> text (show (thing l)) - DParameterFun d -> pp d - DParameterType d -> pp d - DParameterConstraint d -> - "parameter" <+> "type" <+> "constraint" <+> prop - where prop = case map (pp . thing) d of - [x] -> x - [] -> "()" - xs -> nest 1 (parens (commaSepFill xs)) 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 + DParameterConstraint d -> pp 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) + ds = map pp (sigTypeParams sig) + ++ map pp (sigConstraints sig) + ++ map pp (sigFunParams sig) + +instance (Show name, PPName name) => PP (SigDecl name) where + ppPrec p decl = + case decl of + SigConstraint ps -> + "type constraint" <+> parens (commaSep (map (pp . thing) ps)) + + 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) @@ -685,11 +977,23 @@ instance PPName name => PP (Newtype name) where , 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 = @@ -1032,10 +1336,27 @@ instance NoPos (Program name) where 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) @@ -1046,12 +1367,41 @@ instance NoPos (TopDecl name) where 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) 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) + , sigConstraints = map noPos (sigConstraints sig) + , sigFunParams = map noPos (sigFunParams sig) + } + +instance NoPos (SigDecl name) where + noPos decl = + case decl of + SigConstraint ps -> SigConstraint (map noPos ps) + 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 diff --git a/src/Cryptol/Parser/ExpandPropGuards.hs b/src/Cryptol/Parser/ExpandPropGuards.hs index 4e8c9f54b..aae67ecb8 100644 --- a/src/Cryptol/Parser/ExpandPropGuards.hs +++ b/src/Cryptol/Parser/ExpandPropGuards.hs @@ -41,10 +41,17 @@ instance PP Error where text "At" <+> pp (srcRange x) <.> colon <+> text "Declarations using constraint guards require an explicit type signature." -expandPropGuards :: ModuleG m PName -> ExpandPropGuardsM (ModuleG m PName) +expandPropGuards :: ModuleG mname PName -> ExpandPropGuardsM (ModuleG mname PName) expandPropGuards m = - do mDecls' <- mapM expandTopDecl (mDecls m) - pure m {mDecls = concat mDecls' } + 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 = diff --git a/src/Cryptol/Parser/Layout.hs b/src/Cryptol/Parser/Layout.hs index 28e4b241c..1c635f924 100644 --- a/src/Cryptol/Parser/Layout.hs +++ b/src/Cryptol/Parser/Layout.hs @@ -64,7 +64,11 @@ layout isMod ts0 | 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 index 7b82be8b8..a1f8309b0 100644 --- a/src/Cryptol/Parser/Lexer.x +++ b/src/Cryptol/Parser/Lexer.x @@ -104,6 +104,7 @@ $white+ { emit $ White Space } "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 } diff --git a/src/Cryptol/Parser/NoInclude.hs b/src/Cryptol/Parser/NoInclude.hs index 1fd35c3f8..215b80df0 100644 --- a/src/Cryptol/Parser/NoInclude.hs +++ b/src/Cryptol/Parser/NoInclude.hs @@ -29,12 +29,12 @@ import MonadLib import System.Directory (makeAbsolute) import System.FilePath (takeDirectory,(),isAbsolute) +import Cryptol.Utils.PP hiding (()) import Cryptol.Parser (parseProgramWith) import Cryptol.Parser.AST import Cryptol.Parser.LexerUtils (Config(..),defaultConfig) import Cryptol.Parser.ParserUtils import Cryptol.Parser.Unlit (guessPreProc) -import Cryptol.Utils.PP hiding (()) removeIncludesModule :: (FilePath -> IO ByteString) -> @@ -161,9 +161,14 @@ collectErrors f ts = do -- | 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 +182,8 @@ noIncTopDecl td = case td of 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,6 +191,7 @@ noIncTopDecl td = case td of 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. diff --git a/src/Cryptol/Parser/NoPat.hs b/src/Cryptol/Parser/NoPat.hs index 73cde0320..300dac7f2 100644 --- 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 @@ -352,8 +353,12 @@ noPatProg (Program topDs) = Program <$> noPatTopDs topDs 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 } -------------------------------------------------------------------------------- @@ -390,23 +395,8 @@ annotTopDs tds = 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 @@ -419,6 +409,8 @@ annotTopDs tds = DImport {} -> (d :) <$> annotTopDs ds + DModParam {} -> (d :) <$> annotTopDs ds + [] -> return [] @@ -501,15 +493,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)) checkSigs _ [] = return Nothing diff --git a/src/Cryptol/Parser/ParserUtils.hs b/src/Cryptol/Parser/ParserUtils.hs index 490ee797b..ef80a53ad 100644 --- a/src/Cryptol/Parser/ParserUtils.hs +++ b/src/Cryptol/Parser/ParserUtils.hs @@ -12,17 +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 @@ -41,7 +45,13 @@ import Cryptol.Parser.Lexer import Cryptol.Parser.Token(SelectorType(..)) import Cryptol.Parser.Position import Cryptol.Parser.Utils (translateExprToNumT,widthIdent) -import Cryptol.Utils.Ident(packModName,packIdent,modNameChunks,unpackIdent) +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 @@ -194,6 +204,27 @@ expected x = P $ \cfg _ s -> 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 @@ -487,7 +518,7 @@ exportModule mbDoc m = DModule TopLevel { tlExport = Public 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 @@ -497,7 +528,7 @@ mkParFun mbDoc n s = DParameterFun ParameterFun { pfName = n 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 }) @@ -512,16 +543,17 @@ mkParType mbDoc n k = 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) @@ -846,8 +878,7 @@ mkProp ty = -- | 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) @@ -860,23 +891,83 @@ mkNested m = 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) + +mkInterface :: [Located (ImportG (ImpName PName))] -> + [ParamDecl PName] -> Signature PName +mkInterface is = + rev . + foldl' add + Signature { sigImports = is + , sigTypeParams = [] + , sigConstraints = [] + , sigFunParams = [] + } + + where + add s d = + case d of + DParameterType pt -> s { sigTypeParams = pt : sigTypeParams s } + DParameterConstraint ps -> s { sigConstraints = ps : sigConstraints s } + DParameterFun pf -> s { sigFunParams = pf : sigFunParams s } + rev x = x { sigConstraints = reverse (sigConstraints x) } + +mkIfacePropSyn :: Maybe Text -> Decl PName -> ParamDecl PName +mkIfacePropSyn mbDoc d = + case d of + DLocated d1 _ -> mkIfacePropSyn mbDoc d1 + DType ts -> DParameterConstraint (SigTySyn ts mbDoc) + DProp ps -> DParameterConstraint (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 @@ -927,5 +1018,221 @@ mkSelector tok = case tokenType tok of Selector (TupleSelectorTok n) -> TupleSel n Nothing Selector (RecordSelectorTok t) -> RecordSel (mkIdent t) Nothing - _ -> panic "mkSelector" - [ "Unexpected selector token", show tok ] + _ -> panic "mkSelector" [ "Unexpected selector token", show tok ] + + +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 {} <- mDef m -> + errorMessage (srcRange (mName mo)) + [ "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 = [] + , sigConstraints = [] + , sigFunParams = [] + } + + jnSig s1 s2 = Signature { sigImports = j sigImports + , sigTypeParams = j sigTypeParams + , 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/Token.hs b/src/Cryptol/Parser/Token.hs index 3722dcfc6..20a8d4228 100644 --- a/src/Cryptol/Parser/Token.hs +++ b/src/Cryptol/Parser/Token.hs @@ -51,6 +51,7 @@ data TokenKW = KW_else | KW_primitive | KW_parameter | KW_constraint + | KW_interface | KW_foreign | KW_Prop | KW_by diff --git a/src/Cryptol/REPL/Browse.hs b/src/Cryptol/REPL/Browse.hs index b53f5fb9b..7dc6829b5 100644 --- a/src/Cryptol/REPL/Browse.hs +++ b/src/Cryptol/REPL/Browse.hs @@ -13,7 +13,9 @@ import Cryptol.Parser.AST(Pragma(..)) 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 @@ import Cryptol.ModuleSystem.Interface 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 @@ browseModContext how mc = runDoc (env disp) (vcat sections) 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 @@ data DispInfo = DispInfo { dispHow :: BrowseHow, env :: NameDisp } -------------------------------------------------------------------------------- -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 = pp (ifsName m) + +browseFunctors :: DispInfo -> IfaceDecls -> [Doc] +browseFunctors disp decls = + ppSection disp "Parameterized Submodules" ppM (ifFunctors 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 (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 @@ groupDecls disp = Map.toList 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 index c4a0702f3..ccb7c4556 100644 --- a/src/Cryptol/REPL/Command.hs +++ b/src/Cryptol/REPL/Command.hs @@ -59,6 +59,7 @@ module Cryptol.REPL.Command ( 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 @@ -90,7 +91,7 @@ import qualified Cryptol.TypeCheck.Error as T import qualified Cryptol.TypeCheck.Parseable as T import qualified Cryptol.TypeCheck.Subst as T import Cryptol.TypeCheck.Solve(defaultReplExpr) -import Cryptol.TypeCheck.PP (dump,ppWithNames,emptyNameMap) +import Cryptol.TypeCheck.PP (dump) import qualified Cryptol.Utils.Benchmark as Bench import Cryptol.Utils.PP hiding (()) import Cryptol.Utils.Panic(panic) @@ -115,7 +116,7 @@ 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)) @@ -125,8 +126,6 @@ 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(..)) @@ -1124,11 +1123,9 @@ reloadCmd = do mb <- getLoadedMod case mb of Just lm -> - case lName lm of - Just m | M.isParamInstModName m -> loadHelper (M.loadModuleByName m) - _ -> case lPath lm of - M.InFile f -> loadCmd f - _ -> return () + case lPath lm of + M.InFile f -> loadCmd f + _ -> return () Nothing -> return () @@ -1189,16 +1186,14 @@ moduleCmd modString | 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 () @@ -1215,13 +1210,14 @@ loadCmd path } 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 @@ -1235,7 +1231,9 @@ genHeaderCmd path | null path = pure () | otherwise = do (mPath, m) <- liftModuleCmd $ M.checkModuleByPath path - let decls = findForeignDecls m + 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 @@ -1309,153 +1307,10 @@ helpCmd cmd 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)) @@ -1737,7 +1592,7 @@ bindItVariable ty expr = do } 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 diff --git a/src/Cryptol/REPL/Help.hs b/src/Cryptol/REPL/Help.hs new file mode 100644 index 000000000..2b2f70b62 --- /dev/null +++ b/src/Cryptol/REPL/Help.hs @@ -0,0 +1,376 @@ +{-# 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 <- 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) + + 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 index aab9651a3..5f400ff65 100644 --- 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 @@ -224,10 +225,11 @@ mkPrompt rw 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 @@ -331,7 +333,7 @@ data REPLException | EvalPolyError T.Schema | InstantiationsNotFound T.Schema | TypeNotTestable T.Type - | EvalInParamModule [M.Name] + | EvalInParamModule [T.TParam] [M.Name] | SBVError String | SBVException SBVException | SBVPortfolioException SBVPortfolioException @@ -363,8 +365,9 @@ instance PP REPLException where $$ 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) @@ -555,17 +558,20 @@ validEvalContext a = 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 () @@ -660,11 +666,12 @@ uniqify :: M.Name -> REPL M.Name 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] diff --git a/src/Cryptol/Symbolic/SBV.hs b/src/Cryptol/Symbolic/SBV.hs index 7679c9648..cd3f7d92b 100644 --- a/src/Cryptol/Symbolic/SBV.hs +++ b/src/Cryptol/Symbolic/SBV.hs @@ -298,9 +298,11 @@ prepareQuery :: 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 diff --git a/src/Cryptol/Symbolic/What4.hs b/src/Cryptol/Symbolic/What4.hs index d3ca83f8a..1a02934b8 100644 --- a/src/Cryptol/Symbolic/What4.hs +++ b/src/Cryptol/Symbolic/What4.hs @@ -333,9 +333,10 @@ prepareQuery sym ProverCommand { .. } = do 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 diff --git a/src/Cryptol/Transform/AddModParams.hs b/src/Cryptol/Transform/AddModParams.hs deleted file mode 100644 index 4a625b86f..000000000 --- a/src/Cryptol/Transform/AddModParams.hs +++ /dev/null @@ -1,318 +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) -import Data.Bifunctor (Bifunctor(second)) - -{- -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 - DForeign _ -> 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) - EPropGuards guards ty -> EPropGuards (second (inst ps) <$> guards) ty - - -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 - DForeign t -> DForeign t - 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/Specialize.hs b/src/Cryptol/Transform/Specialize.hs index 904f6a205..0c2fc449b 100644 --- a/src/Cryptol/Transform/Specialize.hs +++ b/src/Cryptol/Transform/Specialize.hs @@ -19,6 +19,7 @@ import qualified Cryptol.ModuleSystem as M import qualified Cryptol.ModuleSystem.Env as M import qualified Cryptol.ModuleSystem.Monad as M import Cryptol.ModuleSystem.Name +import Cryptol.Utils.Ident(OrigName(..)) import Cryptol.Eval (checkProp) import Data.Map (Map) @@ -260,8 +261,8 @@ destETAbs = go [] 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 index ae541fa27..86603bcbd 100644 --- 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 @@ module Cryptol.TypeCheck , 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 @@ import Cryptol.TypeCheck.Monad , 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 @@ import Cryptol.Utils.Panic(panic) -tcModule :: P.Module Name -> InferInput -> IO (InferOutput Module) -tcModule m inp = runInferM inp (inferModule m) - --- | Check a module instantiation, assuming that the functor has already --- been checked. --- 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 index c373bc1d1..39a3df8b6 100644 --- a/src/Cryptol/TypeCheck/AST.hs +++ b/src/Cryptol/TypeCheck/AST.hs @@ -13,6 +13,7 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} module Cryptol.TypeCheck.AST ( module Cryptol.TypeCheck.AST , Name() @@ -28,6 +29,10 @@ module Cryptol.TypeCheck.AST , 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 @@ -37,7 +42,6 @@ import Cryptol.Parser.AST ( Selector(..),Pragma(..) , Import , ImportG(..), ImportSpec(..), ExportType(..) , Fixity(..)) -import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,PrimIdent,prelPrim) import Cryptol.Utils.RecordMap import Cryptol.TypeCheck.FFI.FFIType import Cryptol.TypeCheck.PP @@ -46,63 +50,115 @@ 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)) @@ -397,3 +453,10 @@ instance PP n => PP (WithNames (ModuleG n)) where -- XXX: Print abstarct types/functions vcat (map (ppWithNames (addTNames mps nm)) mDecls) where mps = map mtpParam (Map.elems mParamTypes) + +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 index f5ca13c78..000000000 --- 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/Error.hs b/src/Cryptol/TypeCheck/Error.hs index 17fc95699..565285ac3 100644 --- a/src/Cryptol/TypeCheck/Error.hs +++ b/src/Cryptol/TypeCheck/Error.hs @@ -12,6 +12,7 @@ import GHC.Generics(Generic) import Data.List((\\),sortBy,groupBy,partition) import Data.Function(on) +import Cryptol.Utils.Ident(Ident,Namespace(..)) import qualified Cryptol.Parser.AST as P import Cryptol.Parser.Position(Located(..), Range(..), rangeWithin) import Cryptol.TypeCheck.PP @@ -21,7 +22,6 @@ 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)] @@ -94,6 +94,10 @@ data Error = KindMismatch (Maybe TypeSource) Kind Kind | 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 @@ -146,6 +150,11 @@ data Error = KindMismatch (Maybe TypeSource) Kind Kind | TypeShadowing String Name String | MissingModTParam (Located Ident) | MissingModVParam (Located Ident) + | MissingModParam Ident + + | FunctorInstanceMissingArgument Ident + | FunctorInstanceBadArgument Ident + | FunctorInstanceMissingName Namespace Ident | UnsupportedFFIKind TypeSource TParam Kind -- ^ Kind is not supported for FFI @@ -178,10 +187,16 @@ errorImportance err = TemporaryError {} -> 11 -- show these as usually means the user used something that doesn't work + FunctorInstanceMissingArgument {} -> 10 + MissingModParam {} -> 10 + FunctorInstanceBadArgument {} -> 10 + FunctorInstanceMissingName {} -> 9 + KindMismatch {} -> 10 TyVarWithParams {} -> 9 TypeMismatch {} -> 8 + SchemaMismatch {} -> 7 RecursiveType {} -> 7 NotForAll {} -> 6 TypeVariableEscaped {} -> 5 @@ -252,6 +267,8 @@ instance TVars Error where 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 @@ -275,6 +292,11 @@ instance TVars Error where TypeShadowing {} -> err MissingModTParam {} -> err MissingModVParam {} -> err + MissingModParam {} -> err + + FunctorInstanceMissingArgument {} -> err + FunctorInstanceBadArgument {} -> err + FunctorInstanceMissingName {} -> err UnsupportedFFIKind {} -> err UnsupportedFFIType src e -> UnsupportedFFIType src !$ apSubst su e @@ -295,6 +317,7 @@ instance FVS Error where 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 @@ -317,6 +340,11 @@ instance FVS Error where TypeShadowing {} -> Set.empty MissingModTParam {} -> Set.empty MissingModVParam {} -> Set.empty + MissingModParam {} -> Set.empty + + FunctorInstanceMissingArgument {} -> Set.empty + FunctorInstanceBadArgument {} -> Set.empty + FunctorInstanceMissingName {} -> Set.empty UnsupportedFFIKind {} -> Set.empty UnsupportedFFIType _ t -> fvs t @@ -420,6 +448,14 @@ instance PP (WithNames Error) where ++ 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 @@ -507,6 +543,25 @@ instance PP (WithNames Error) where 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" + UnsupportedFFIKind src param k -> nested "Kind of type variable unsupported for FFI: " $ vcat diff --git a/src/Cryptol/TypeCheck/Infer.hs b/src/Cryptol/TypeCheck/Infer.hs index 8e0336b75..591880e88 100644 --- a/src/Cryptol/TypeCheck/Infer.hs +++ b/src/Cryptol/TypeCheck/Infer.hs @@ -25,7 +25,7 @@ module Cryptol.TypeCheck.Infer ( checkE , checkSigB - , inferModule + , inferTopModule , inferBinds , checkTopDecls ) @@ -53,11 +53,13 @@ import Cryptol.TypeCheck.Kind(checkType,checkSchema,checkTySyn, 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 @@ -75,13 +77,29 @@ import Control.Monad(zipWithM, unless, foldM, forM_, mplus, zipWithM, -- import Debug.Trace -- import Cryptol.TypeCheck.PP -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 +inferTopModule :: P.Module Name -> InferM TCTopEntity +inferTopModule m = + case P.mDef m of + P.NormalModule ds -> + do newModuleScope (thing (P.mName m)) (map thing (P.mImports m)) + (P.exportedDecls ds) + checkTopDecls ds + proveModuleTopLevel + endModule + + P.FunctorInstance f as inst -> + do mb <- doFunctorInst (P.ImpTop <$> P.mName m) f as inst Nothing + case mb of + Just mo -> pure mo + Nothing -> panic "inferModule" ["Didnt' get a module"] + + P.InterfaceModule sig -> + do newTopSignatureScope (thing (P.mName m)) + checkSignature sig + endTopSignature + + + -- | Construct a Prelude primitive in the parsed AST. mkPrim :: String -> InferM (P.Expr Name) @@ -471,7 +489,7 @@ checkRecUpd mb fs tGoal = -- { _ | 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 @@ -497,7 +515,7 @@ checkRecUpd mb fs tGoal = 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` @@ -1293,27 +1311,113 @@ checkTopDecls = mapM_ checkTopDecl 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 - - P.DImport {} -> pure () - P.Include {} -> panic "checkTopDecl" [ "Unexpected `inlude`" ] + selectorScope + case P.mDef m of + + P.NormalModule ds -> + do newSubmoduleScope (thing (P.mName m)) + (thing <$> P.tlDoc tl) + (map thing (P.mImports m)) + (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) + , 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.sigConstraints sig) + + forM_ (P.sigFunParams sig) \f -> + addParamFun =<< checkParameterFun f + + proveModuleTopLevel + +checkSigDecl :: P.SigDecl Name -> InferM () +checkSigDecl decl = + case decl of + + P.SigConstraint cs -> + addParameterConstraints =<< checkParameterConstraints cs + + P.SigTySyn ts mbD -> + addTySyn =<< checkTySyn ts mbD + + P.SigPropSyn ps mbD -> + addTySyn =<< checkPropSyn ps mbD + checkDecl :: Bool -> P.Decl Name -> Maybe Text -> InferM () diff --git a/src/Cryptol/TypeCheck/InferTypes.hs b/src/Cryptol/TypeCheck/InferTypes.hs index 2fa9ea832..d3b28083f 100644 --- a/src/Cryptol/TypeCheck/InferTypes.hs +++ b/src/Cryptol/TypeCheck/InferTypes.hs @@ -27,7 +27,7 @@ import Cryptol.TypeCheck.PP 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 @@ instance Ord Goal where 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,7 @@ data ConstraintSource | CtPartialTypeFun Name -- ^ Use of a partial type function. | CtImprovement | CtPattern TypeSource -- ^ Constraints arising from type-checking patterns - | CtModuleInstance ModName -- ^ Instantiating a parametrized module + | CtModuleInstance -- ^ 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) @@ -249,7 +250,7 @@ instance TVars ConstraintSource where CtPartialTypeFun _ -> src CtImprovement -> src CtPattern _ -> src - CtModuleInstance _ -> src + CtModuleInstance -> src CtPropGuardsExhaustive _ -> src CtFFI _ -> src @@ -357,7 +358,7 @@ instance PP ConstraintSource where 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 -> "module instantiation" CtPropGuardsExhaustive n -> "exhaustion check for prop guards used in defining" <+> pp n CtFFI f -> "declaration of foreign function" <+> pp f diff --git a/src/Cryptol/TypeCheck/Interface.hs b/src/Cryptol/TypeCheck/Interface.hs index f784580c1..1c9c89684 100644 --- a/src/Cryptol/TypeCheck/Interface.hs +++ b/src/Cryptol/TypeCheck/Interface.hs @@ -3,12 +3,15 @@ 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 @@ -19,57 +22,58 @@ mkIfaceDecl d = IfaceDecl , 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) - - (dPub,dPriv) = - Map.partitionWithKey (\ qn _ -> qn `isExportedBind` mExports m) - $ Map.fromList [ (qn,mkIfaceDecl d) | dg <- mDecls m - , d <- groupDecls dg - , let qn = dName d - ] +-- | Things defines by a module +genModDefines :: ModuleG name -> Set Name +genModDefines m = + Set.unions + [ Map.keysSet (mTySyns m) + , Map.keysSet (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 - (mPub,mPriv) = - Map.partitionWithKey (\ qn _ -> isExported NSModule qn (mExports m)) - $ mSubModules m +genIface :: ModuleG name -> IfaceG name +genIface m = genIfaceWithNames (genIfaceNames m) m +-- | Generate an Iface from a typechecked module. +genIfaceWithNames :: IfaceNames name -> ModuleG ignored -> IfaceG name +genIfaceWithNames names m = + Iface + { ifNames = names + + , ifDefines = IfaceDecls + { ifTySyns = mTySyns m + , ifNewtypes = mNewtypes m + , ifAbstractTypes = mPrimTypes m + , ifDecls = Map.fromList [ (qn,mkIfaceDecl d) + | dg <- mDecls m + , d <- groupDecls dg + , let qn = dName d + ] + , ifModules = mSubmodules m + , ifSignatures = mSignatures m + , ifFunctors = genIface <$> mFunctors m + } + , ifParams = mParams m + } diff --git a/src/Cryptol/TypeCheck/Kind.hs b/src/Cryptol/TypeCheck/Kind.hs index 3125d22d8..96cb8d185 100644 --- a/src/Cryptol/TypeCheck/Kind.hs +++ b/src/Cryptol/TypeCheck/Kind.hs @@ -92,12 +92,12 @@ checkPropGuards props = -- | 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. diff --git a/src/Cryptol/TypeCheck/Module.hs b/src/Cryptol/TypeCheck/Module.hs new file mode 100644 index 000000000..f742feb99 --- /dev/null +++ b/src/Cryptol/TypeCheck/Module.hs @@ -0,0 +1,308 @@ +{-# Language BlockArguments, ImplicitParams #-} +module Cryptol.TypeCheck.Module (doFunctorInst) where + +import Data.Text(Text) +import Data.Map(Map) +import qualified Data.Map as Map +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 + +doFunctorInst :: + Located (P.ImpName Name) {- ^ Name for the new module -} -> + Located (P.ImpName Name) {- ^ Functor being instantiation -} -> + 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 + (tySus,decls) <- unzip <$> mapM checkArg argIs + + + let ?tSu = mergeDistinctSubst tySus + ?vSu = inst + let m1 = moduleInstance mf + m2 = m1 { mName = m + , mDoc = Nothing + , mParamTypes = mempty + , mParamFuns = mempty + , mParamConstraints = mempty + , mParams = mempty + -- XXX: Should we modify `mImports` to record dependencies + -- on parameters? + , mDecls = map NonRecursive (concat decls) ++ mDecls m1 + } + + newGoals CtModuleInstance (map thing (mParamConstraints m1)) + + case thing m of + P.ImpTop mn -> newModuleScope mn (mImports m2) (mExports m2) + P.ImpNested mn -> newSubmoduleScope mn doc (mImports m2) (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 + + + + +{- | 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, Either ModParam (IfaceG ())) ] + {- ^ 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 . Right <$> 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 (Left a)) + 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 + + +{- | 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. +-} +checkArg :: + (Range, ModParam, Either ModParam (IfaceG ())) -> InferM (Subst, [Decl]) +checkArg (r,expect,actual') = + 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 (renSu, vDecls) + + + + + where + params = mpParameters expect + + tyMap :: Map Ident (Kind, Type) + vMap :: Map Ident (Name, Schema) + (tyMap,vMap) = + case actual' of + Left 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) + + Right 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 + + 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) []) + + + +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] + +{- | 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 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) + + pure res + + + + diff --git a/src/Cryptol/TypeCheck/ModuleInstance.hs b/src/Cryptol/TypeCheck/ModuleInstance.hs new file mode 100644 index 000000000..ddddd5a36 --- /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.Parser.AST(ImpName(..)) +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) + , mImports = mImports 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) + , 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) + } + + + + + diff --git a/src/Cryptol/TypeCheck/Monad.hs b/src/Cryptol/TypeCheck/Monad.hs index 6f2951da1..653b1b2f5 100644 --- a/src/Cryptol/TypeCheck/Monad.hs +++ b/src/Cryptol/TypeCheck/Monad.hs @@ -22,6 +22,7 @@ module Cryptol.TypeCheck.Monad 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 +39,14 @@ import Control.DeepSeq import MonadLib hiding (mapM) import Cryptol.ModuleSystem.Name - (FreshM(..),Supply,mkParameter - , nameInfo, NameInfo(..),NameSource(..)) + (FreshM(..),Supply,mkLocal + , 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 @@ -55,7 +57,7 @@ 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.Ident(Ident,Namespace(..),ModName) import Cryptol.Utils.Panic(panic) -- | Information needed for type inference. @@ -64,15 +66,16 @@ data InferInput = InferInput , 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 +123,32 @@ bumpCounter = do RO { .. } <- IM ask 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.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 +156,30 @@ runInferM info (IM m) = , iSolveCounter = counter } - (result, finalRW) <- runStateT rw - $ runReaderT ro m -- RECURSION - - 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 - ] - - errs -> inferFailed warns [(r,apSubst theSu e) | (r,e) <- errs] + mb <- runExceptionT (runStateT rw (runReaderT ro m)) + case mb of + Left errs -> inferFailed [] errs + Right (result, finalRW) -> + do let theSu = iSubst finalRW + defSu = defaultingSubst theSu + warns = fmap' (fmap' (apSubst theSu)) (iWarnings finalRW) + + case iErrors finalRW of + [] -> + case iCts finalRW of + cts + | nullGoals cts -> inferOk warns + (iNameSeeds finalRW) + (iSupply finalRW) + (apSubst defSu result) + cts -> + inferFailed warns + [ ( goalRange g + , UnsolvedGoals [apSubst theSu g] + ) | g <- fromGoals cts + ] + + errs -> inferFailed warns [(r,apSubst theSu e) | (r,e) <- errs] where inferOk ws a b c = pure (InferOK (computeFreeVarNames ws []) ws a b c) @@ -193,18 +205,70 @@ runInferM info (IM m) = , 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 +283,20 @@ data RO = RO , 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 +348,18 @@ data RW = RW -- 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 +397,7 @@ instance FreshM InferM where 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 +426,17 @@ recordErrorLoc rng e = 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 +449,7 @@ recordWarning w = ignore | DefaultingTo d _ <- w , Just n <- tvSourceName (tvarDesc d) - , Declared _ SystemName <- nameInfo n + , GlobalName SystemName _ <- nameInfo n = True | otherwise = False @@ -443,22 +534,30 @@ newHasGoal :: P.Selector -> Type -> Type -> InferM HasGoalSln newHasGoal l ty f = do goalName <- newGoalName g <- newGoal CtSelector (pHas l ty f) - IM $ sets_ $ \s -> s { iHasCts = HasGoal goalName g : iHasCts s } + 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 +568,10 @@ solveHasGoal n e = -------------------------------------------------------------------------------- -- | 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) @@ -635,7 +734,8 @@ varsWithAsmps = 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 +756,12 @@ lookupVar x = 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 . 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,9 +784,88 @@ lookupAbstractType x = Map.lookup x <$> getAbstractTypes 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 <$> getCurScope + 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, @@ -717,10 +900,6 @@ getNewtypes = getScope mNewtypes 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 +927,11 @@ getMonoBinds = IM (asks iMonoBinds) getCallStacks :: InferM Bool getCallStacks = IM (asks iCallStacks) +getSignatures :: InferM (Map Name ModParamNames) +getSignatures = getScope mSignatures + + + {- | We disallow shadowing between type synonyms and type variables because it is confusing. As a bonus, in the implementation we don't need to worry about where we lookup things (i.e., in the variable or @@ -795,15 +979,28 @@ newScope nm = IM $ sets_ \rw -> rw { iScope = emptyModule nm : iScope rw } 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) + +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 -> [Import] -> ExportSpec Name -> InferM () +newSubmoduleScope x docs is e = + do updScope \o -> o { mNested = Set.insert x (mNested o) } + newScope (SubModule x) + updScope \m -> m { mDoc = docs, mImports = is, mExports = e } newModuleScope :: P.ModName -> [Import] -> ExportSpec Name -> InferM () newModuleScope x is e = do newScope (MTopModule x) - updScope \m -> m { mImports = is, mExports = e } + updScope \m -> m { mDoc = Nothing, mImports = is, mExports = e } -- | Update the current scope (first in the list). Assumes there is one. updScope :: (ModuleG ScopeName -> ModuleG ScopeName) -> InferM () @@ -829,38 +1026,84 @@ endSubmodule = 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) - - , 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 + x1 = x { mName = m, mDecls = reverse (mDecls x) } + + isFun = isParametrizedModule x1 + + add :: Monoid a => (ModuleG ScopeName -> a) -> a + add f = if isFun then f y else f x <> f y + + z = Module + { mName = mName y + , mDoc = mDoc y + , mExports = mExports y + , mParamTypes = mParamTypes y + , mParamFuns = mParamFuns y + , mParamConstraints = mParamConstraints y + , mParams = mParams y + , mNested = mNested y + + , mImports = add mImports -- just for deps + , 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. @@ -870,6 +1113,13 @@ getScope f = rw <- IM get pure (sconcat (f (iExtScope ro) :| map f (iScope rw))) +getCurScope :: InferM (ModuleG ScopeName) +getCurScope = + do rw <- IM get + case iScope rw of + m : _ -> pure m + [] -> panic "getCurScope" ["No current scope."] + addDecls :: DeclGroup -> InferM () addDecls ds = do updScope \r -> r { mDecls = ds : mDecls r } @@ -897,10 +1147,26 @@ addPrimType t = updScope \r -> r { mPrimTypes = Map.insert (atName t) t (mPrimTypes r) } + addParamType :: ModTParam -> InferM () addParamType a = updScope \r -> r { mParamTypes = Map.insert (mtpName a) a (mParamTypes r) } +addSignatures :: Map Name ModParamNames -> InferM () +addSignatures mp = + updScope \r -> r { mSignatures = Map.union mp (mSignatures r) } + +addSubmodules :: Map Name (If.IfaceNames Name) -> InferM () +addSubmodules mp = + updScope \r -> r { mSubmodules = Map.union mp (mSubmodules r) } + +addFunctors :: Map Name (ModuleG Name) -> InferM () +addFunctors mp = + updScope \r -> r { mFunctors = Map.union mp (mFunctors r) } + + + + -- | The sub-computation is performed with the given abstract function in scope. addParamFun :: ModVParam -> InferM () addParamFun x = @@ -913,6 +1179,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/Sanity.hs b/src/Cryptol/TypeCheck/Sanity.hs index 0abba1ed9..3596895bf 100644 --- a/src/Cryptol/TypeCheck/Sanity.hs +++ b/src/Cryptol/TypeCheck/Sanity.hs @@ -560,13 +560,15 @@ runTcM env (TcM m) = (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 = [] } diff --git a/src/Cryptol/TypeCheck/Solver/Selector.hs b/src/Cryptol/TypeCheck/Solver/Selector.hs index f58f1507e..1677f05a4 100644 --- a/src/Cryptol/TypeCheck/Solver/Selector.hs +++ b/src/Cryptol/TypeCheck/Solver/Selector.hs @@ -13,7 +13,7 @@ import Cryptol.TypeCheck.AST 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 @@ mkSelSln s outerT innerT = -- 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 @@ mkSelSln s outerT innerT = -- 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/Subst.hs b/src/Cryptol/TypeCheck/Subst.hs index b50b9fec7..c458d48f4 100644 --- a/src/Cryptol/TypeCheck/Subst.hs +++ b/src/Cryptol/TypeCheck/Subst.hs @@ -35,6 +35,7 @@ module Cryptol.TypeCheck.Subst , applySubstToVar , substToList , fmap', (!$), (.$) + , mergeDistinctSubst ) where import Data.Maybe @@ -85,6 +86,29 @@ emptySubst = , 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 @@ -351,7 +375,16 @@ that variable scopes will be properly preserved. -} instance TVars Schema where apSubst su (Forall xs ps t) = - Forall xs !$ (concatMap pSplitAnd (apSubst su ps)) !$ (apSubst su t) + 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,19 +396,15 @@ instance TVars Expr where 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) @@ -412,7 +441,15 @@ instance TVars DeclDef where apSubst _ DPrim = DPrim apSubst _ (DForeign t) = DForeign t +-- WARNING: This applies the substitution only to the declarations. instance TVars Module where apSubst su m = let !decls' = apSubst su (mDecls m) in m { mDecls = decls' } + +-- 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 index f4a8df4e9..1e83bf479 100644 --- a/src/Cryptol/TypeCheck/TCon.hs +++ b/src/Cryptol/TypeCheck/TCon.hs @@ -40,7 +40,7 @@ infixPrimTy = \tc -> Map.lookup tc mp 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 index c053aa5b4..417e341a8 100644 --- a/src/Cryptol/TypeCheck/Type.hs +++ b/src/Cryptol/TypeCheck/Type.hs @@ -16,6 +16,8 @@ module Cryptol.TypeCheck.Type import GHC.Generics (Generic) import Control.DeepSeq +import Data.Map(Map) +import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Data.Maybe (fromMaybe) import Data.Set (Set) @@ -23,9 +25,10 @@ import qualified Data.Set as Set 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) import Cryptol.TypeCheck.TCon import Cryptol.TypeCheck.PP import Cryptol.TypeCheck.Solver.InfNat @@ -37,18 +40,71 @@ import Prelude infix 4 =#=, >== infixr 5 `tFun` + +-------------------------------------------------------------------------------- +-- Module parameters + +type FunctorParams = Map Ident ModParam + +-- | Compute the names from all functor parameters +allParamNames :: FunctorParams -> ModParamNames +allParamNames mps = + ModParamNames + { mpnTypes = Map.unions (map mpnTypes ps) + , mpnConstraints = concatMap mpnConstraints ps + , mpnFuns = Map.unions (map mpnFuns ps) + , mpnTySyn = Map.unions (map mpnTySyn ps) + , mpnDoc = Nothing + } + where + ps = map mpParameters (Map.elems mps) + + +-- | A module parameter. Corresponds to a "signature import". +-- A single module parameter can bring multiple things in scope. +data ModParam = ModParam + { mpName :: Ident + -- ^ The name of a functor parameter. + + , 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 +120,9 @@ data ModVParam = ModVParam { mvpName :: Name , mvpType :: Schema , mvpDoc :: Maybe Text - , mvpFixity :: Maybe Fixity + , mvpFixity :: Maybe Fixity -- XXX: This should be in the name? } deriving (Show,Generic,NFData) - +-------------------------------------------------------------------------------- @@ -285,6 +341,8 @@ data AbstractType = AbstractType -------------------------------------------------------------------------------- +instance HasKind AbstractType where + kindOf at = foldr (:->) (atKind at) (map kindOf (fst (atCtrs at))) instance HasKind TVar where kindOf (TVFree _ k _ _) = k @@ -916,6 +974,34 @@ instance FVS Type where 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 @@ -1154,7 +1240,8 @@ pickTVarName k src uni = 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" @@ -1215,3 +1302,24 @@ instance PP TypeSource where 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/TypePat.hs b/src/Cryptol/TypeCheck/TypePat.hs index 53023830c..8db4afc30 100644 --- a/src/Cryptol/TypeCheck/TypePat.hs +++ b/src/Cryptol/TypeCheck/TypePat.hs @@ -16,6 +16,7 @@ module Cryptol.TypeCheck.TypePat , aTVar , aFreeTVar + , anAbstractType , aBit , aSeq , aWord @@ -125,6 +126,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 = do v <- aTVar t diff --git a/src/Cryptol/Utils/Fixity.hs b/src/Cryptol/Utils/Fixity.hs index 5a0267d60..de8600bed 100644 --- a/src/Cryptol/Utils/Fixity.hs +++ b/src/Cryptol/Utils/Fixity.hs @@ -23,10 +23,10 @@ import Control.DeepSeq -- | 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 index ef212db70..9e8b74f5a 100644 --- a/src/Cryptol/Utils/Ident.hs +++ b/src/Cryptol/Utils/Ident.hs @@ -8,7 +8,7 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE OverloadedStrings #-} module Cryptol.Utils.Ident ( -- * Module names @@ -17,14 +17,17 @@ module Cryptol.Utils.Ident , modPathCommon , topModuleFor , modPathSplit + , modPathIsNormal , ModName , modNameToText , textToModName , modNameChunks + , modNameChunksText , packModName , preludeName , preludeReferenceName + , undefinedModName , floatName , suiteBName , arrayName @@ -32,10 +35,10 @@ module Cryptol.Utils.Ident , interactiveName , noModuleName , exprModName - - , isParamInstModName - , paramInstModName - , notParamInstModName + , modNameArg + , modNameIfaceMod + , modNameToNormalModName + , modNameIsNormal -- * Identifiers , Ident @@ -48,6 +51,9 @@ module Cryptol.Utils.Ident , nullIdent , identText , modParamIdent + , identAnonArg + , identAnonIfaceMod + , identIsNormal -- * Namespaces , Namespace(..) @@ -55,6 +61,8 @@ module Cryptol.Utils.Ident -- * Original names , OrigName(..) + , OrigSource(..) + , ogFromModParam -- * Identifiers for primitives , PrimIdent(..) @@ -68,10 +76,13 @@ module Cryptol.Utils.Ident 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) + -------------------------------------------------------------------------------- @@ -126,47 +137,67 @@ modPathSplit p0 = (top,reverse xs) 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"] + +-- | Change a normal module name to a module name to be used for an +-- anonnymous interface. +modNameIfaceMod :: ModName -> ModName +modNameIfaceMod (ModName m fl) = + case fl of + NormalName -> ModName m AnonIfaceModName + AnonModArgName -> panic "modNameIfaceMod" ["Name is not normal"] + AnonIfaceModName -> panic "modNameIfaceMod" ["Name is not normal"] + +-- | This is used when we check that the name of a module matches the +-- file where it is defined. +modNameToNormalModName :: ModName -> ModName +modNameToNormalModName (ModName t _) = ModName t NormalName + +modNameToText :: ModName -> Text +modNameToText (ModName x fl) = maybeAnonText fl x + +-- | This is useful when we want to hide anonymous modules. +modNameIsNormal :: ModName -> Bool +modNameIsNormal (ModName _ fl) = isNormal fl + +-- | Make a normal module name out of text. textToModName :: T.Text -> ModName -textToModName = ModName +textToModName txt = ModName txt NormalName -modNameChunks :: ModName -> [String] -modNameChunks = unfoldr step . modNameToText . notParamInstModName +-- | 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) -> Just (T.unpack a,T.drop (T.length modSep) b) - -isParamInstModName :: ModName -> Bool -isParamInstModName (ModName x) = modInstPref `T.isPrefixOf` x - --- | Convert a parameterized module's name to the name of the module --- containing the same definitions but with explicit parameters on each --- definition. -paramInstModName :: ModName -> ModName -paramInstModName (ModName x) - | modInstPref `T.isPrefixOf` x = ModName x - | otherwise = ModName (T.append modInstPref x) - - -notParamInstModName :: ModName -> ModName -notParamInstModName (ModName x) - | modInstPref `T.isPrefixOf` x = ModName (T.drop (T.length modInstPref) x) - | otherwise = ModName x + | 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)) @@ -177,13 +208,12 @@ packModName strs = textToModName (T.intercalate modSep (map trim strs)) 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"] @@ -214,16 +244,32 @@ exprModName = packModName [""] 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 @@ -231,39 +277,82 @@ instance Eq Ident where 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 index 1af1c9fd2..6794c8ca1 100644 --- 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 qualified Data.Text as T import Data.Void (Void) import GHC.Generics (Generic) import qualified Prettyprinter as PP +import qualified Prettyprinter.Util as PP import qualified Prettyprinter.Render.String as PP -- | How to pretty print things when evaluating @@ -49,7 +50,8 @@ data PPFloatExp = ForceExponent -- ^ Always show an exponent | AutoExponent -- ^ Only show exponent when needed deriving Show -data FieldOrder = DisplayOrder | CanonicalOrder deriving (Bounded, Enum, Eq, Ord, Read, Show) +data FieldOrder = DisplayOrder | CanonicalOrder + deriving (Bounded, Enum, Eq, Ord, Read, Show) defaultPPOpts :: PPOpts @@ -91,7 +93,9 @@ data NameFormat = UnQualified -- | 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,24 +106,51 @@ neverQualify = NameDisp $ \ _ -> Just UnQualified 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 @@ instance Monoid Doc where mempty = liftPP mempty mappend = (<>) +runDocWith :: PPCfg -> Doc -> PP.Doc Void +runDocWith names (Doc f) = f names + runDoc :: NameDisp -> Doc -> PP.Doc Void -runDoc 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 @@ liftPP2 f (Doc a) (Doc b) = Doc (\e -> f (a e) (b e)) liftSep :: ([PP.Doc Void] -> PP.Doc Void) -> ([Doc] -> Doc) liftSep f ds = Doc (\e -> f [ d e | Doc d <- ds ]) +reflow :: T.Text -> Doc +reflow x = liftPP (PP.reflow x) + infixl 6 <.>, <+>, (<.>) :: Doc -> Doc -> Doc @@ -370,7 +408,10 @@ instance PP OrigName where 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 @@ -382,6 +423,6 @@ instance PP OrigName where instance PP Namespace where ppPrec _ ns = case ns of - NSValue -> "/*value*/" - NSType -> "/*type*/" - NSModule -> "/*module*/" + NSValue -> "/*value*/" + NSType -> "/*type*/" + NSModule -> "/*module*/" diff --git a/src/Cryptol/Utils/Panic.hs b/src/Cryptol/Utils/Panic.hs index 2cc0e69ae..caef4c28a 100644 --- 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 @@ -20,6 +20,9 @@ type CryptolPanic = Panic Cryptol panic :: HasCallStack => String -> [String] -> a panic = Panic.panic Cryptol +xxxTODO :: HasCallStack => String -> a +xxxTODO x = panic "TODO" [x] + instance PanicComponent Cryptol where panicComponentName _ = "Cryptol" panicComponentIssues _ = "https://github.com/GaloisInc/cryptol/issues" diff --git a/tests/constraint-guards/nestFun.cry b/tests/constraint-guards/nestFun.cry new file mode 100644 index 000000000..3dab883e5 --- /dev/null +++ b/tests/constraint-guards/nestFun.cry @@ -0,0 +1,17 @@ + +submodule A where + + parameter + type n : # + + f : Bool + f | n == 0 => True + | n > 0 => False + +import submodule A as Two where + type n = 2 + +import submodule A as Zero where + type n = 0 + + diff --git a/tests/constraint-guards/nestFun.icry b/tests/constraint-guards/nestFun.icry new file mode 100644 index 000000000..53b8ccde2 --- /dev/null +++ b/tests/constraint-guards/nestFun.icry @@ -0,0 +1,3 @@ +:load nestFun.cry +Two::f +Zero::f diff --git a/tests/modsys/T8.icry.stdout b/tests/constraint-guards/nestFun.icry.stdout similarity index 50% rename from tests/modsys/T8.icry.stdout rename to tests/constraint-guards/nestFun.icry.stdout index 28118cd5e..6e8b4478b 100644 --- a/tests/modsys/T8.icry.stdout +++ b/tests/constraint-guards/nestFun.icry.stdout @@ -1,4 +1,5 @@ Loading module Cryptol Loading module Cryptol -Loading module T8::Main -f : {x : [8]} -> [8] +Loading module Main +False +True diff --git a/tests/constraint-guards/noNested.icry.stdout b/tests/constraint-guards/noNested.icry.stdout index 963f3a63e..8def66d58 100644 --- a/tests/constraint-guards/noNested.icry.stdout +++ b/tests/constraint-guards/noNested.icry.stdout @@ -1,8 +1,6 @@ Loading module Cryptol Loading module Cryptol Loading module Main -[warning] at noNested.cry:2:5--2:10: - Assuming n to have a numeric type [error] at noNested.cry:6:3--6:9: Local declaration `nested` may not use constraint guards. diff --git a/tests/constraint-guards/noPrim.icry.stdout b/tests/constraint-guards/noPrim.icry.stdout index 72a8e800e..7fc76db1f 100644 --- a/tests/constraint-guards/noPrim.icry.stdout +++ b/tests/constraint-guards/noPrim.icry.stdout @@ -1,8 +1,6 @@ Loading module Cryptol Loading module Cryptol Loading module Main -[warning] at noPrim.cry:3:1--3:2: - Could not prove that the constraint guards used in defining Main::f were exhaustive. [error] at noPrim.cry:3:7--3:14: `prime` may not be used in a constraint guard. diff --git a/tests/examples/allexamples.icry.stdout b/tests/examples/allexamples.icry.stdout index 3aa735d9f..c5972d2b7 100644 --- a/tests/examples/allexamples.icry.stdout +++ b/tests/examples/allexamples.icry.stdout @@ -1,5 +1,6 @@ Loading module Cryptol Loading module Cryptol +Loading interface module `parameter` interface of Main Loading module Main Loading module Cryptol Loading module AES @@ -86,40 +87,56 @@ Loading module AES::SubBytePlain Loading module AES::SBox Loading module AES::SubByteSBox Loading module AES::Round +Loading module AES::TBox +Loading interface module `parameter` interface of AES +Loading interface module `parameter` interface of AES::Algorithm Loading module AES::Algorithm +Loading interface module `parameter` interface of AES::ExpandKey Loading module AES::ExpandKey -Loading module AES::TBox Loading module AES Loading module Cryptol +Loading interface module `parameter` interface of Common::AES_GCM_SIV Loading module AES::GF28 Loading module AES::State Loading module AES::SubBytePlain Loading module AES::SBox Loading module AES::SubByteSBox Loading module AES::Round +Loading module AES::TBox +Loading interface module `parameter` interface of AES +Loading interface module `parameter` interface of AES::Algorithm Loading module AES::Algorithm +Loading interface module `parameter` interface of AES::ExpandKey Loading module AES::ExpandKey -Loading module AES::TBox Loading module AES Loading module Common::AES_GCM_SIV Loading module Main Loading module Cryptol -Loading module Common::GCM Loading module AES::GF28 Loading module AES::State Loading module AES::SubBytePlain Loading module AES::SBox Loading module AES::SubByteSBox Loading module AES::Round +Loading module AES::TBox +Loading interface module `parameter` interface of AES +Loading interface module `parameter` interface of AES::Algorithm Loading module AES::Algorithm +Loading interface module `parameter` interface of AES::ExpandKey Loading module AES::ExpandKey -Loading module AES::TBox Loading module AES +Loading interface module `parameter` interface of Common::GCM +Loading module Common::GCM Loading module GCM_AES_Tests Loading module Cryptol +Loading module `where` argument of SHA256 +Loading interface module `parameter` interface of Common::SHA Loading module Common::SHA +Loading module SHA256 Loading module SHA Loading module Cryptol +Loading module `where` argument of SHA256 +Loading interface module `parameter` interface of Common::SHA Loading module Common::SHA Loading module SHA256 Loading module Cryptol diff --git a/tests/ffi/ffi-no-dup.cry b/tests/ffi/ffi-no-dup.cry new file mode 100644 index 000000000..de11d08b2 --- /dev/null +++ b/tests/ffi/ffi-no-dup.cry @@ -0,0 +1,7 @@ + + +foreign f : () -> [8] + +submodule A where + foreign f : () -> [16] + diff --git a/tests/ffi/ffi-no-dup.icry b/tests/ffi/ffi-no-dup.icry new file mode 100644 index 000000000..28b7ceb7b --- /dev/null +++ b/tests/ffi/ffi-no-dup.icry @@ -0,0 +1 @@ +:load ffi-no-dup.cry diff --git a/tests/ffi/ffi-no-dup.icry.stdout b/tests/ffi/ffi-no-dup.icry.stdout new file mode 100644 index 000000000..5cca6738f --- /dev/null +++ b/tests/ffi/ffi-no-dup.icry.stdout @@ -0,0 +1,8 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main + +[error] Failed to load foreign implementations for module Main: + Multiple foreign declarations with the same name: + `f` defined at ffi-no-dup.cry:6:11--6:12 + ffi-no-dup.cry:3:9--3:10 diff --git a/tests/ffi/ffi-no-functor.cry b/tests/ffi/ffi-no-functor.cry new file mode 100644 index 000000000..b7e30ddaa --- /dev/null +++ b/tests/ffi/ffi-no-functor.cry @@ -0,0 +1,7 @@ + +submodule A where + parameter + type n : # + + foreign f : (fin n) => [n][8] -> [8] + diff --git a/tests/ffi/ffi-no-functor.icry b/tests/ffi/ffi-no-functor.icry new file mode 100644 index 000000000..0bb5075b1 --- /dev/null +++ b/tests/ffi/ffi-no-functor.icry @@ -0,0 +1 @@ +:load ffi-no-functor.cry diff --git a/tests/ffi/ffi-no-functor.icry.stdout b/tests/ffi/ffi-no-functor.icry.stdout new file mode 100644 index 000000000..509b2a107 --- /dev/null +++ b/tests/ffi/ffi-no-functor.icry.stdout @@ -0,0 +1,7 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main + +[error] Failed to load foreign implementations for module Main: + ffi-no-functor.cry:6:11--6:12: + Foreign declaration `f` may not appear in a parameterized module. diff --git a/tests/ffi/test-ffi.c b/tests/ffi/test-ffi.c index 3bf61934d..bc90fa097 100644 --- a/tests/ffi/test-ffi.c +++ b/tests/ffi/test-ffi.c @@ -147,3 +147,4 @@ void iQ2Qi(mpz_t in_0, mpq_t in_1, mpq_t out_0, mpz_t out_1) { mpq_set(out_0, in_1); } +uint8_t nested() { return 72; } diff --git a/tests/ffi/test-ffi.cry b/tests/ffi/test-ffi.cry index c3b3359dd..d2271dee6 100644 --- a/tests/ffi/test-ffi.cry +++ b/tests/ffi/test-ffi.cry @@ -50,4 +50,9 @@ foreign iQ2Qi : (Integer,Rational) -> (Rational,Integer) foreign i2Z5 : Integer -> Z 5 foreign i2Z : {n} (fin n, n >= 1) => Integer -> Z n +// In a nested module +submodule A where + foreign nested : () -> [8] + + diff --git a/tests/ffi/test-ffi.h b/tests/ffi/test-ffi.h index ab61a1e06..520953082 100644 --- a/tests/ffi/test-ffi.h +++ b/tests/ffi/test-ffi.h @@ -1,6 +1,7 @@ #include #include #include +uint8_t nested(void); uint8_t add8(uint8_t in0, uint8_t in1); uint16_t sub16(uint16_t in0, uint16_t in1); uint32_t mul32(uint32_t in0, uint32_t in1); diff --git a/tests/ffi/test-ffi.icry b/tests/ffi/test-ffi.icry index cf9e520ca..1d5f45947 100644 --- a/tests/ffi/test-ffi.icry +++ b/tests/ffi/test-ffi.icry @@ -41,3 +41,5 @@ iQ2Qi (72,37) i2Z5 2 i2Z5 10 i2Z 123 : Z 10 + +A::nested () diff --git a/tests/ffi/test-ffi.icry.stdout b/tests/ffi/test-ffi.icry.stdout index 9e2a30455..920a3bccd 100644 --- a/tests/ffi/test-ffi.icry.stdout +++ b/tests/ffi/test-ffi.icry.stdout @@ -42,3 +42,4 @@ True 2 0 1 +0x48 diff --git a/tests/ffi/test-ffi.icry.stdout.darwin b/tests/ffi/test-ffi.icry.stdout.darwin index e6e9956ba..3b1a2f80f 100644 --- a/tests/ffi/test-ffi.icry.stdout.darwin +++ b/tests/ffi/test-ffi.icry.stdout.darwin @@ -42,3 +42,4 @@ True 2 0 1 +0x48 diff --git a/tests/ffi/test-ffi.icry.stdout.mingw32 b/tests/ffi/test-ffi.icry.stdout.mingw32 index f7bb90872..031fd4103 100644 --- a/tests/ffi/test-ffi.icry.stdout.mingw32 +++ b/tests/ffi/test-ffi.icry.stdout.mingw32 @@ -42,3 +42,4 @@ True 2 0 1 +0x48 diff --git a/tests/issues/T1439.cry b/tests/issues/T1439.cry new file mode 100644 index 000000000..83d7d2e3e --- /dev/null +++ b/tests/issues/T1439.cry @@ -0,0 +1,35 @@ +module T where + // sanity check: functions outside submodule each load + f : {n} [1][n] -> [n] + f [x] = x + + p : {a,b} (a,b) -> a + p (x,_) = x + + interface submodule I where + type n : # + + submodule F where + import interface submodule I + + h : [1][n] -> [n] + h [x] = x + + g : {m} [1][m] -> [m] + g [x] = x + + q, q1, q2 : {b} (b,_) -> b + q (x,_) = x + + q1 x = x.0 + q2 x = y + where + (y,z) = x + + submodule P1 where + type n = 1 + + submodule S = submodule F { submodule P1 } + + import submodule S + diff --git a/tests/issues/T1439.icry b/tests/issues/T1439.icry new file mode 100644 index 000000000..eb7ae7d09 --- /dev/null +++ b/tests/issues/T1439.icry @@ -0,0 +1 @@ +:load T1439.cry diff --git a/tests/issues/T1439.icry.stdout b/tests/issues/T1439.icry.stdout new file mode 100644 index 000000000..ff69cbd42 --- /dev/null +++ b/tests/issues/T1439.icry.stdout @@ -0,0 +1,3 @@ +Loading module Cryptol +Loading module Cryptol +Loading module T diff --git a/tests/issues/T1440.cry b/tests/issues/T1440.cry new file mode 100644 index 000000000..089285c1e --- /dev/null +++ b/tests/issues/T1440.cry @@ -0,0 +1,16 @@ +import interface submodule X + +import submodule Y + +interface submodule I where + type n : # + +submodule M where + import interface submodule I + +submodule N where + x = 2 + +submodule M1 = submodule M { submodule U1 } +submodule M2 = submodule U2 { submodule N } + diff --git a/tests/issues/T1440.icry b/tests/issues/T1440.icry new file mode 100644 index 000000000..5ee9cf4ea --- /dev/null +++ b/tests/issues/T1440.icry @@ -0,0 +1 @@ +:load T1440.cry diff --git a/tests/issues/T1440.icry.stdout b/tests/issues/T1440.icry.stdout new file mode 100644 index 000000000..12b4d1ca6 --- /dev/null +++ b/tests/issues/T1440.icry.stdout @@ -0,0 +1,12 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main + +[error] at T1440.cry:1:28--1:29 + Module not in scope: X +[error] at T1440.cry:3:1--3:19 + Module not in scope: Y +[error] at T1440.cry:14:40--14:42 + Module not in scope: U1 +[error] at T1440.cry:15:26--15:28 + Module not in scope: U2 diff --git a/tests/issues/issue1240.icry.stdout b/tests/issues/issue1240.icry.stdout index eb41aed59..32c8a035e 100644 --- a/tests/issues/issue1240.icry.stdout +++ b/tests/issues/issue1240.icry.stdout @@ -1,3 +1,4 @@ Loading module Cryptol Loading module Cryptol +Loading interface module `parameter` interface of test Loading module test diff --git a/tests/issues/issue1372.icry b/tests/issues/issue1372.icry new file mode 100644 index 000000000..dee7de705 --- /dev/null +++ b/tests/issues/issue1372.icry @@ -0,0 +1 @@ +:l issue1372/M.cry \ No newline at end of file diff --git a/tests/issues/issue1372.icry.stdout b/tests/issues/issue1372.icry.stdout new file mode 100644 index 000000000..a9923568e --- /dev/null +++ b/tests/issues/issue1372.icry.stdout @@ -0,0 +1,5 @@ +Loading module Cryptol +Loading module Cryptol +Loading interface module I +Loading module A +Loading module M diff --git a/tests/issues/issue1372/A.cry b/tests/issues/issue1372/A.cry new file mode 100644 index 000000000..92c5d4259 --- /dev/null +++ b/tests/issues/issue1372/A.cry @@ -0,0 +1,3 @@ +module A where + import interface I + type T = 5 \ No newline at end of file diff --git a/tests/issues/issue1372/I.cry b/tests/issues/issue1372/I.cry new file mode 100644 index 000000000..76844d846 --- /dev/null +++ b/tests/issues/issue1372/I.cry @@ -0,0 +1,2 @@ +interface module I where + type n : # \ No newline at end of file diff --git a/tests/issues/issue1372/M.cry b/tests/issues/issue1372/M.cry new file mode 100644 index 000000000..f72a8ebcb --- /dev/null +++ b/tests/issues/issue1372/M.cry @@ -0,0 +1,9 @@ +module M where + +submodule N where + type n = 7 + +submodule B = A { submodule N } +import submodule B + +type MyT = T diff --git a/tests/issues/issue513.icry.stdout b/tests/issues/issue513.icry.stdout index f178fe367..ab31060f2 100644 --- a/tests/issues/issue513.icry.stdout +++ b/tests/issues/issue513.icry.stdout @@ -5,6 +5,7 @@ Loading module Main Assuming a to have a numeric type module Main import Cryptol + /* Recursive */ Main::test : {a} [1 + a] Main::test = diff --git a/tests/issues/issue565.icry.stdout b/tests/issues/issue565.icry.stdout index 822031567..3fbacd08a 100644 --- a/tests/issues/issue565.icry.stdout +++ b/tests/issues/issue565.icry.stdout @@ -1,5 +1,4 @@ Loading module Cryptol -Loading module Cryptol -Loading module T -[error] Module T does not have parameters. +Parse error at issue565/I.cry:3:8--3:9 + Backtick module imports are no longer supported. diff --git a/tests/issues/issue565.icry.stdout.mingw32 b/tests/issues/issue565.icry.stdout.mingw32 new file mode 100644 index 000000000..201cbc61e --- /dev/null +++ b/tests/issues/issue565.icry.stdout.mingw32 @@ -0,0 +1,4 @@ +Loading module Cryptol + +Parse error at issue565\I.cry:3:8--3:9 + Backtick module imports are no longer supported. diff --git a/tests/issues/issue796.icry.stdout b/tests/issues/issue796.icry.stdout index a40bb511e..f90d8634a 100644 --- a/tests/issues/issue796.icry.stdout +++ b/tests/issues/issue796.icry.stdout @@ -1,4 +1,4 @@ Loading module Cryptol -Loading module Cryptol -Loading module Issue796_Sig -Loading module Issue796 + +Parse error at Issue796.cry:4:8--4:10 + Instantiation of a parameterized module may not itself be parameterized diff --git a/tests/issues/issue845.icry.stdout b/tests/issues/issue845.icry.stdout index 57f9291c7..4145e2858 100644 --- a/tests/issues/issue845.icry.stdout +++ b/tests/issues/issue845.icry.stdout @@ -1,10 +1,6 @@ Loading module Cryptol Loading module Cryptol Loading module Main -[warning] at issue845.cry:1:9--1:24: - Assuming n to have a numeric type -[warning] at issue845.cry:1:9--1:24: - Assuming m to have a numeric type [error] at issue845.cry:2:1--2:37: Failed to validate user-specified signature. diff --git a/tests/issues/issue883.icry.stdout b/tests/issues/issue883.icry.stdout index 8f7e2e57c..fc4f49d1f 100644 --- a/tests/issues/issue883.icry.stdout +++ b/tests/issues/issue883.icry.stdout @@ -1,5 +1,7 @@ Loading module Cryptol Loading module Cryptol +Loading module `where` argument of Issue883_Impl +Loading interface module `parameter` interface of Issue883_Sig Loading module Issue883_Sig Loading module Issue883_Impl Loading module Issue883 diff --git a/tests/issues/issue883_A.icry.stdout b/tests/issues/issue883_A.icry.stdout index f2e511217..5cc01962c 100644 --- a/tests/issues/issue883_A.icry.stdout +++ b/tests/issues/issue883_A.icry.stdout @@ -1,3 +1,4 @@ Loading module Cryptol Loading module Cryptol +Loading interface module `parameter` interface of Issue883_A Loading module Issue883_A diff --git a/tests/modsys/T007.cry b/tests/modsys/T007.cry new file mode 100644 index 000000000..2907f6511 --- /dev/null +++ b/tests/modsys/T007.cry @@ -0,0 +1,19 @@ + + +submodule F where + parameter + type n : # + x : [n] + type constraint (fin n, n >= 4) + + y : [n] + y = x + 11 + + +submodule I where + type n = 8 + x = 2 + +submodule M = submodule F { submodule I } + +import submodule M as M diff --git a/tests/modsys/T10.icry b/tests/modsys/T10.icry deleted file mode 100644 index 6c4bb8549..000000000 --- a/tests/modsys/T10.icry +++ /dev/null @@ -1,2 +0,0 @@ -:module `T10::Main -:browse `T10::Main diff --git a/tests/modsys/T10.icry.stdout b/tests/modsys/T10.icry.stdout deleted file mode 100644 index 15dfd7181..000000000 --- a/tests/modsys/T10.icry.stdout +++ /dev/null @@ -1,8 +0,0 @@ -Loading module Cryptol -Loading module Cryptol -Loading module T10::Main -Symbols -======= - - f : {T} {x : T} -> T - diff --git a/tests/modsys/T10/Main.cry b/tests/modsys/T10/Main.cry deleted file mode 100644 index 5b4085ef1..000000000 --- a/tests/modsys/T10/Main.cry +++ /dev/null @@ -1,9 +0,0 @@ -module T10::Main where - -parameter - type T : * - x : T - -f : T -f = x - diff --git a/tests/modsys/T11.icry b/tests/modsys/T11.icry deleted file mode 100644 index c1d02e79d..000000000 --- a/tests/modsys/T11.icry +++ /dev/null @@ -1 +0,0 @@ -:module T11::Main diff --git a/tests/modsys/T11.icry.stdout b/tests/modsys/T11.icry.stdout deleted file mode 100644 index ffc6540c9..000000000 --- a/tests/modsys/T11.icry.stdout +++ /dev/null @@ -1,4 +0,0 @@ -Loading module Cryptol -Loading module Cryptol -Loading module T11::A -Loading module T11::Main diff --git a/tests/modsys/T11/A.cry b/tests/modsys/T11/A.cry deleted file mode 100644 index b64c1773d..000000000 --- a/tests/modsys/T11/A.cry +++ /dev/null @@ -1,12 +0,0 @@ -module T11::A where - -parameter - type X : # - type Y : # - -type T = ([X],[Y]) - -f : T -> [X] -f (x,_) = x - - diff --git a/tests/modsys/T11/Main.cry b/tests/modsys/T11/Main.cry deleted file mode 100644 index a3e3b2361..000000000 --- a/tests/modsys/T11/Main.cry +++ /dev/null @@ -1,9 +0,0 @@ -module T11::Main where - -import `T11::A as X - - -f : X::T 1 2 -> [1] -f = X::f - - diff --git a/tests/modsys/T12.icry.stdout b/tests/modsys/T12.icry.stdout index 2c1e106ac..af0b9dda8 100644 --- a/tests/modsys/T12.icry.stdout +++ b/tests/modsys/T12.icry.stdout @@ -1,4 +1,4 @@ Loading module Cryptol -Loading module Cryptol -Loading module T12::A -Loading module T12::Main + +Parse error at T12/Main.cry:4:8--4:9 + Instantiation of a parameterized module may not itself be parameterized diff --git a/tests/modsys/T12.icry.stdout.mingw32 b/tests/modsys/T12.icry.stdout.mingw32 new file mode 100644 index 000000000..923ebd435 --- /dev/null +++ b/tests/modsys/T12.icry.stdout.mingw32 @@ -0,0 +1,4 @@ +Loading module Cryptol + +Parse error at T12\Main.cry:4:8--4:9 + Instantiation of a parameterized module may not itself be parameterized diff --git a/tests/modsys/T13.icry.stdout b/tests/modsys/T13.icry.stdout index 69eca9590..80fce06a9 100644 --- a/tests/modsys/T13.icry.stdout +++ b/tests/modsys/T13.icry.stdout @@ -1,5 +1,7 @@ Loading module Cryptol Loading module Cryptol +Loading module `where` argument of T13::B +Loading interface module `parameter` interface of T13::A Loading module T13::A Loading module T13::B Loading module T13::Main diff --git a/tests/modsys/T2.icry.stdout b/tests/modsys/T2.icry.stdout index a4a2d2de8..2568ae58f 100644 --- a/tests/modsys/T2.icry.stdout +++ b/tests/modsys/T2.icry.stdout @@ -1,5 +1,7 @@ Loading module Cryptol Loading module Cryptol +Loading module `where` argument of T2::Main +Loading interface module `parameter` interface of T2::A Loading module T2::A Loading module T2::Main 0x00 diff --git a/tests/modsys/T3.icry.stdout b/tests/modsys/T3.icry.stdout index 73bd2d827..08e660e52 100644 --- a/tests/modsys/T3.icry.stdout +++ b/tests/modsys/T3.icry.stdout @@ -1,5 +1,11 @@ Loading module Cryptol Loading module Cryptol +Loading interface module `parameter` interface of T3::A Loading module T3::A +Loading module T3::Main -[error] Import of a non-instantiated parameterized module: T3::A +[error] at T3/Main.cry:5:8--5:15 + Value not in scope: X::main +[error] at T3/Main.cry:3:1--3:18 + • Expected a module + • `T3::A` is a functor diff --git a/tests/modsys/T3.icry.stdout.mingw32 b/tests/modsys/T3.icry.stdout.mingw32 new file mode 100644 index 000000000..3c79013c6 --- /dev/null +++ b/tests/modsys/T3.icry.stdout.mingw32 @@ -0,0 +1,11 @@ +Loading module Cryptol +Loading module Cryptol +Loading interface module `parameter` interface of T3::A +Loading module T3::A +Loading module T3::Main + +[error] at T3\Main.cry:5:8--5:15 + Value not in scope: X::main +[error] at T3\Main.cry:3:1--3:18 + • Expected a module + • `T3::A` is a functor diff --git a/tests/modsys/T4.icry.stdout b/tests/modsys/T4.icry.stdout index 698fea6a1..b1ec94150 100644 --- a/tests/modsys/T4.icry.stdout +++ b/tests/modsys/T4.icry.stdout @@ -1,5 +1,7 @@ Loading module Cryptol Loading module Cryptol +Loading module `where` argument of T4::Main +Loading interface module `parameter` interface of T4::A Loading module T4::A Loading module T4::Main main : [8] diff --git a/tests/modsys/T5.icry.stdout b/tests/modsys/T5.icry.stdout index c31b045af..c1d6a708c 100644 --- a/tests/modsys/T5.icry.stdout +++ b/tests/modsys/T5.icry.stdout @@ -1,7 +1,12 @@ Loading module Cryptol Loading module Cryptol -Loading module T5::A -Loading module T5::B -Loading module T5::Main -main : [8] -0x11 +Loading module `where` argument of T5::Main + +Parse error at ./T5/B.cry:4:3--4:4 + Instantiation of a parameterized module may not itself be parameterized + +[error] at T5.icry:2:4--2:8 + Value not in scope: main + +[error] at T5.icry:3:1--3:5 + Value not in scope: main diff --git a/tests/modsys/T5.icry.stdout.mingw32 b/tests/modsys/T5.icry.stdout.mingw32 new file mode 100644 index 000000000..5ca5e768b --- /dev/null +++ b/tests/modsys/T5.icry.stdout.mingw32 @@ -0,0 +1,12 @@ +Loading module Cryptol +Loading module Cryptol +Loading module `where` argument of T5::Main + +Parse error at .\T5\B.cry:4:3--4:4 + Instantiation of a parameterized module may not itself be parameterized + +[error] at T5.icry:2:4--2:8 + Value not in scope: main + +[error] at T5.icry:3:1--3:5 + Value not in scope: main diff --git a/tests/modsys/T6.icry.stdout b/tests/modsys/T6.icry.stdout index c31b045af..935eaa99a 100644 --- a/tests/modsys/T6.icry.stdout +++ b/tests/modsys/T6.icry.stdout @@ -1,7 +1,12 @@ Loading module Cryptol Loading module Cryptol -Loading module T5::A -Loading module T5::B -Loading module T5::Main -main : [8] -0x11 +Loading module `where` argument of T5::Main + +Parse error at ./T5/B.cry:4:3--4:4 + Instantiation of a parameterized module may not itself be parameterized + +[error] at T6.icry:2:4--2:8 + Value not in scope: main + +[error] at T6.icry:3:1--3:5 + Value not in scope: main diff --git a/tests/modsys/T6.icry.stdout.mingw32 b/tests/modsys/T6.icry.stdout.mingw32 new file mode 100644 index 000000000..7bea913ac --- /dev/null +++ b/tests/modsys/T6.icry.stdout.mingw32 @@ -0,0 +1,12 @@ +Loading module Cryptol +Loading module Cryptol +Loading module `where` argument of T5::Main + +Parse error at .\T5\B.cry:4:3--4:4 + Instantiation of a parameterized module may not itself be parameterized + +[error] at T6.icry:2:4--2:8 + Value not in scope: main + +[error] at T6.icry:3:1--3:5 + Value not in scope: main diff --git a/tests/modsys/T7.icry.stdout b/tests/modsys/T7.icry.stdout index 1c4e5a799..106885a00 100644 --- a/tests/modsys/T7.icry.stdout +++ b/tests/modsys/T7.icry.stdout @@ -1,5 +1,6 @@ Loading module Cryptol Loading module Cryptol +Loading interface module `parameter` interface of T7::Main Loading module T7::Main Expression depends on definitions from a parameterized module: diff --git a/tests/modsys/T8.icry b/tests/modsys/T8.icry deleted file mode 100644 index 0a3bdb32c..000000000 --- a/tests/modsys/T8.icry +++ /dev/null @@ -1,2 +0,0 @@ -:module `T8::Main -:t f diff --git a/tests/modsys/T9.icry b/tests/modsys/T9.icry deleted file mode 100644 index fc0bfd618..000000000 --- a/tests/modsys/T9.icry +++ /dev/null @@ -1,3 +0,0 @@ -:module T9::Main -:t main -main diff --git a/tests/modsys/T9.icry.stdout b/tests/modsys/T9.icry.stdout deleted file mode 100644 index 3fa0c6da5..000000000 --- a/tests/modsys/T9.icry.stdout +++ /dev/null @@ -1,6 +0,0 @@ -Loading module Cryptol -Loading module Cryptol -Loading module T9::A -Loading module T9::Main -main : [16] -0x1010 diff --git a/tests/modsys/T9/A.cry b/tests/modsys/T9/A.cry deleted file mode 100644 index 132197119..000000000 --- a/tests/modsys/T9/A.cry +++ /dev/null @@ -1,10 +0,0 @@ -module T9::A where - -parameter - type n : # - type constraint fin n - x : [n] - -f : [n+n] -f = x # x - diff --git a/tests/modsys/T9/Main.cry b/tests/modsys/T9/Main.cry deleted file mode 100644 index 3cd1ecaa0..000000000 --- a/tests/modsys/T9/Main.cry +++ /dev/null @@ -1,7 +0,0 @@ -module T9::Main where - -import `T9::A - -main = f { x = 0x10 } - - diff --git a/tests/modsys/functors/T001.cry b/tests/modsys/functors/T001.cry new file mode 100644 index 000000000..51abcf0e4 --- /dev/null +++ b/tests/modsys/functors/T001.cry @@ -0,0 +1,16 @@ +interface submodule A where + type n : # + type constraint (fin n, n >= 1) + x : [n] + +submodule F where + import interface submodule A + + y : [n] + y = 1 + x + +submodule I where + type n = 0 + x = x : [n] + +submodule M = submodule F { submodule I } diff --git a/tests/modsys/functors/T001.icry b/tests/modsys/functors/T001.icry new file mode 100644 index 000000000..d3ad5353c --- /dev/null +++ b/tests/modsys/functors/T001.icry @@ -0,0 +1 @@ +:load T001.cry diff --git a/tests/modsys/functors/T001.icry.stdout b/tests/modsys/functors/T001.icry.stdout new file mode 100644 index 000000000..e7a2864b3 --- /dev/null +++ b/tests/modsys/functors/T001.icry.stdout @@ -0,0 +1,10 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main + +[error] at T001.cry:16:11--16:12: + • Unsolvable constraint: + 0 >= 1 + arising from + module instantiation + at T001.cry:16:11--16:12 diff --git a/tests/modsys/functors/T002.cry b/tests/modsys/functors/T002.cry new file mode 100644 index 000000000..3cf105e7a --- /dev/null +++ b/tests/modsys/functors/T002.cry @@ -0,0 +1,18 @@ +interface submodule A where + type n : # + type constraint (fin n, n >= 1) + x : [n] + +submodule F where + import interface submodule A + + y : [n] + y = 1 + x + +submodule I where + type n = 8 + x = 2 : [n] + +submodule M = submodule F { submodule I } + +import submodule M as M diff --git a/tests/modsys/functors/T002.icry b/tests/modsys/functors/T002.icry new file mode 100644 index 000000000..adc589fde --- /dev/null +++ b/tests/modsys/functors/T002.icry @@ -0,0 +1,2 @@ +:load T002.cry +M::y diff --git a/tests/modsys/functors/T002.icry.stdout b/tests/modsys/functors/T002.icry.stdout new file mode 100644 index 000000000..aa0e86e34 --- /dev/null +++ b/tests/modsys/functors/T002.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x03 diff --git a/tests/modsys/functors/T003.cry b/tests/modsys/functors/T003.cry new file mode 100644 index 000000000..fc8fec791 --- /dev/null +++ b/tests/modsys/functors/T003.cry @@ -0,0 +1,20 @@ +interface submodule A where + type n : # + type constraint (fin n, n >= 1) + x : [n] + +submodule F where + import interface submodule A + + y : [n] + y = 1 + x + +submodule I where + type n = 8 + + x : {a} Literal 42 a => a + x = 42 + +submodule M = submodule F { submodule I } + +import submodule M as M diff --git a/tests/modsys/functors/T003.icry b/tests/modsys/functors/T003.icry new file mode 100644 index 000000000..2abaa4543 --- /dev/null +++ b/tests/modsys/functors/T003.icry @@ -0,0 +1,2 @@ +:load T003.cry +M::y diff --git a/tests/modsys/functors/T003.icry.stdout b/tests/modsys/functors/T003.icry.stdout new file mode 100644 index 000000000..3dbf46654 --- /dev/null +++ b/tests/modsys/functors/T003.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x2b diff --git a/tests/modsys/functors/T004.cry b/tests/modsys/functors/T004.cry new file mode 100644 index 000000000..1e164c5a7 --- /dev/null +++ b/tests/modsys/functors/T004.cry @@ -0,0 +1,31 @@ +interface submodule A where + type n : # + type constraint (fin n, n >= 1) + x : [n] + +submodule F where + import interface submodule A as X + import interface submodule A as Y + + interface constraint (X::n == Y::n) + + y : [X::n] + y = X::x + Y::x + + +submodule I where + type n = 8 + + x : {a} (Ring a, Literal 1 a, Literal 2 a) => a + x = 1 + 2 + +submodule J where + type n = 8 + + x : {a} (Ring a, Literal 1 a, Literal 2 a) => a + x = 1 + 2 + +submodule M = submodule F { X = submodule I, Y = submodule J } + +import submodule M as M + diff --git a/tests/modsys/functors/T004.icry b/tests/modsys/functors/T004.icry new file mode 100644 index 000000000..01a6f0d6e --- /dev/null +++ b/tests/modsys/functors/T004.icry @@ -0,0 +1,2 @@ +:load T004.cry +M::y diff --git a/tests/modsys/functors/T004.icry.stdout b/tests/modsys/functors/T004.icry.stdout new file mode 100644 index 000000000..9685a2a14 --- /dev/null +++ b/tests/modsys/functors/T004.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x06 diff --git a/tests/modsys/functors/T005.cry b/tests/modsys/functors/T005.cry new file mode 100644 index 000000000..0b0233323 --- /dev/null +++ b/tests/modsys/functors/T005.cry @@ -0,0 +1,31 @@ +interface submodule A where + type n : # + type constraint (fin n, n >= 1) + x : [n] + +submodule F where + import interface submodule A as X + import interface submodule A as Y + + interface constraint (X::n == Y::n) + + y : [X::n] + y = X::x + Y::x + + +submodule I where + type n = 8 + + x : {a} (Ring a, Literal 1 a, Literal 2 a) => a + x = 1 + 2 + +submodule J where + type n = 9 + + x : {a} (Ring a, Literal 1 a, Literal 2 a) => a + x = 1 + 2 + +submodule M = submodule F { X = submodule I, Y = submodule J } + +import submodule M as M + diff --git a/tests/modsys/functors/T005.icry b/tests/modsys/functors/T005.icry new file mode 100644 index 000000000..273468ecc --- /dev/null +++ b/tests/modsys/functors/T005.icry @@ -0,0 +1 @@ +:load T005.cry diff --git a/tests/modsys/functors/T005.icry.stdout b/tests/modsys/functors/T005.icry.stdout new file mode 100644 index 000000000..69d3d6129 --- /dev/null +++ b/tests/modsys/functors/T005.icry.stdout @@ -0,0 +1,10 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main + +[error] at T005.cry:28:11--28:12: + • Unsolvable constraint: + 8 == 9 + arising from + module instantiation + at T005.cry:28:11--28:12 diff --git a/tests/modsys/functors/T006.cry b/tests/modsys/functors/T006.cry new file mode 100644 index 000000000..7daad8221 --- /dev/null +++ b/tests/modsys/functors/T006.cry @@ -0,0 +1,38 @@ +interface submodule A where + type n : # + type constraint (fin n, n >= 1) + x : [n] + +submodule F where + import interface submodule A as X + + interface constraint (X::n >= 3) + + submodule G where + import interface submodule A + interface constraint (X::n == n) + + y : [n] + y = 5 * X::x + x + + y : [X::n] + y = 5 * X::x + + +submodule I where + type n = 8 + + x : {a} (Ring a, Literal 1 a, Literal 2 a) => a + x = 1 + 2 + +submodule M = submodule F { submodule I } + +import submodule M as M + +submodule N = submodule M::G { submodule I } + +import submodule N as N + + + + diff --git a/tests/modsys/functors/T006.icry b/tests/modsys/functors/T006.icry new file mode 100644 index 000000000..7993c80e0 --- /dev/null +++ b/tests/modsys/functors/T006.icry @@ -0,0 +1,3 @@ +:load T006.cry +M::y +N::y diff --git a/tests/modsys/functors/T006.icry.stdout b/tests/modsys/functors/T006.icry.stdout new file mode 100644 index 000000000..18a124149 --- /dev/null +++ b/tests/modsys/functors/T006.icry.stdout @@ -0,0 +1,5 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x0f +0x12 diff --git a/tests/modsys/functors/T007.cry b/tests/modsys/functors/T007.cry new file mode 100644 index 000000000..2907f6511 --- /dev/null +++ b/tests/modsys/functors/T007.cry @@ -0,0 +1,19 @@ + + +submodule F where + parameter + type n : # + x : [n] + type constraint (fin n, n >= 4) + + y : [n] + y = x + 11 + + +submodule I where + type n = 8 + x = 2 + +submodule M = submodule F { submodule I } + +import submodule M as M diff --git a/tests/modsys/functors/T007.icry b/tests/modsys/functors/T007.icry new file mode 100644 index 000000000..c39bcad6d --- /dev/null +++ b/tests/modsys/functors/T007.icry @@ -0,0 +1,2 @@ +:load T007.cry +M::y diff --git a/tests/modsys/functors/T007.icry.stdout b/tests/modsys/functors/T007.icry.stdout new file mode 100644 index 000000000..43c470464 --- /dev/null +++ b/tests/modsys/functors/T007.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x0d diff --git a/tests/modsys/functors/T008.cry b/tests/modsys/functors/T008.cry new file mode 100644 index 000000000..2aa268563 --- /dev/null +++ b/tests/modsys/functors/T008.cry @@ -0,0 +1,17 @@ + +submodule F where + parameter + type n : # + type constraint (fin n, n >= 2) + + x : [n] + x = 2 + + +submodule M = submodule F where + type n = 2 + +import submodule M as M + + + diff --git a/tests/modsys/functors/T008.icry b/tests/modsys/functors/T008.icry new file mode 100644 index 000000000..259a86d0d --- /dev/null +++ b/tests/modsys/functors/T008.icry @@ -0,0 +1,2 @@ +:load T008.cry +M::x diff --git a/tests/modsys/functors/T008.icry.stdout b/tests/modsys/functors/T008.icry.stdout new file mode 100644 index 000000000..74d3f7bf9 --- /dev/null +++ b/tests/modsys/functors/T008.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x2 diff --git a/tests/modsys/functors/T009.cry b/tests/modsys/functors/T009.cry new file mode 100644 index 000000000..ee72ff9c0 --- /dev/null +++ b/tests/modsys/functors/T009.cry @@ -0,0 +1,11 @@ + +/* Test that importing signatures from another module works */ + +import T009_S + +submodule F where + import interface submodule A + y : [n] + y = 1 + + diff --git a/tests/modsys/functors/T009.icry b/tests/modsys/functors/T009.icry new file mode 100644 index 000000000..fd7c0eaf8 --- /dev/null +++ b/tests/modsys/functors/T009.icry @@ -0,0 +1 @@ +:load T009.cry diff --git a/tests/modsys/functors/T009.icry.stdout b/tests/modsys/functors/T009.icry.stdout new file mode 100644 index 000000000..8e124ba5f --- /dev/null +++ b/tests/modsys/functors/T009.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module T009_S +Loading module Main diff --git a/tests/modsys/functors/T009_S.cry b/tests/modsys/functors/T009_S.cry new file mode 100644 index 000000000..153c9f211 --- /dev/null +++ b/tests/modsys/functors/T009_S.cry @@ -0,0 +1,8 @@ +module T009_S where + +interface submodule A where + type n : # + type constraint (fin n, n >= 1) + x : [n] + +z = 0x22 diff --git a/tests/modsys/functors/T010.cry b/tests/modsys/functors/T010.cry new file mode 100644 index 000000000..53900538e --- /dev/null +++ b/tests/modsys/functors/T010.cry @@ -0,0 +1,3 @@ +module T010 = T010_F where + type n = 8 + x = 7 diff --git a/tests/modsys/functors/T010.icry b/tests/modsys/functors/T010.icry new file mode 100644 index 000000000..3c9afb907 --- /dev/null +++ b/tests/modsys/functors/T010.icry @@ -0,0 +1,2 @@ +:load T010.cry +y diff --git a/tests/modsys/functors/T010.icry.stdout b/tests/modsys/functors/T010.icry.stdout new file mode 100644 index 000000000..a3836dedd --- /dev/null +++ b/tests/modsys/functors/T010.icry.stdout @@ -0,0 +1,7 @@ +Loading module Cryptol +Loading module Cryptol +Loading module `where` argument of T010 +Loading module T010_S +Loading module T010_F +Loading module T010 +0x0a diff --git a/tests/modsys/functors/T010_F.cry b/tests/modsys/functors/T010_F.cry new file mode 100644 index 000000000..a1abaa8c5 --- /dev/null +++ b/tests/modsys/functors/T010_F.cry @@ -0,0 +1,7 @@ +module T010_F where + +import T010_S +import interface submodule A + +y = x + 3 + diff --git a/tests/modsys/functors/T010_S.cry b/tests/modsys/functors/T010_S.cry new file mode 100644 index 000000000..edfe7ca02 --- /dev/null +++ b/tests/modsys/functors/T010_S.cry @@ -0,0 +1,8 @@ +module T010_S where + +interface submodule A where + type n : # + x : [n] + type constraint (fin n, n >= 8) + + diff --git a/tests/modsys/functors/T011.cry b/tests/modsys/functors/T011.cry new file mode 100644 index 000000000..84f16348c --- /dev/null +++ b/tests/modsys/functors/T011.cry @@ -0,0 +1,22 @@ +// Test importing in a signature + + +submodule A where + type T = [8] + +interface submodule S where + import submodule A + x : T + +submodule F where + import interface submodule S + + y = 2 * x + +submodule I where + x = 28 + +submodule M = submodule F { submodule I } + +import submodule M as M + diff --git a/tests/modsys/functors/T011.icry b/tests/modsys/functors/T011.icry new file mode 100644 index 000000000..bfa726e77 --- /dev/null +++ b/tests/modsys/functors/T011.icry @@ -0,0 +1,2 @@ +:load T011.cry +M::y diff --git a/tests/modsys/functors/T011.icry.stdout b/tests/modsys/functors/T011.icry.stdout new file mode 100644 index 000000000..c9603eca1 --- /dev/null +++ b/tests/modsys/functors/T011.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x38 diff --git a/tests/modsys/functors/T012.cry b/tests/modsys/functors/T012.cry new file mode 100644 index 000000000..f8b61e9dd --- /dev/null +++ b/tests/modsys/functors/T012.cry @@ -0,0 +1,18 @@ +// Test importing in a signature + +interface submodule S where + import T012_M + x : T + +submodule F where + import interface submodule S + + y = 2 * x + +submodule I where + x = 28 + +submodule M = submodule F { submodule I } + +import submodule M as M + diff --git a/tests/modsys/functors/T012.icry b/tests/modsys/functors/T012.icry new file mode 100644 index 000000000..de4de9113 --- /dev/null +++ b/tests/modsys/functors/T012.icry @@ -0,0 +1,2 @@ +:load T012.cry +M::y diff --git a/tests/modsys/functors/T012.icry.stdout b/tests/modsys/functors/T012.icry.stdout new file mode 100644 index 000000000..11c5b732c --- /dev/null +++ b/tests/modsys/functors/T012.icry.stdout @@ -0,0 +1,5 @@ +Loading module Cryptol +Loading module Cryptol +Loading module T012_M +Loading module Main +0x38 diff --git a/tests/modsys/functors/T012_M.cry b/tests/modsys/functors/T012_M.cry new file mode 100644 index 000000000..7a8b4172e --- /dev/null +++ b/tests/modsys/functors/T012_M.cry @@ -0,0 +1,4 @@ +module T012_M where + +type T = [8] + diff --git a/tests/modsys/functors/T013.cry b/tests/modsys/functors/T013.cry new file mode 100644 index 000000000..497409baa --- /dev/null +++ b/tests/modsys/functors/T013.cry @@ -0,0 +1,6 @@ + +submodule A where + x = 2 + +submodule F where + import interface submodule A diff --git a/tests/modsys/functors/T013.icry b/tests/modsys/functors/T013.icry new file mode 100644 index 000000000..7fac89c6d --- /dev/null +++ b/tests/modsys/functors/T013.icry @@ -0,0 +1 @@ +:load T013.cry diff --git a/tests/modsys/functors/T013.icry.stdout b/tests/modsys/functors/T013.icry.stdout new file mode 100644 index 000000000..bd62e51ec --- /dev/null +++ b/tests/modsys/functors/T013.icry.stdout @@ -0,0 +1,7 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main + +[error] at T013.cry:6:30--6:31 + • Expected an interface + • `submodule Main::A` is a module diff --git a/tests/modsys/functors/T014.cry b/tests/modsys/functors/T014.cry new file mode 100644 index 000000000..d5262c16e --- /dev/null +++ b/tests/modsys/functors/T014.cry @@ -0,0 +1,6 @@ + +interface submodule A where + type T : # + +import submodule A + diff --git a/tests/modsys/functors/T014.icry b/tests/modsys/functors/T014.icry new file mode 100644 index 000000000..556d8249d --- /dev/null +++ b/tests/modsys/functors/T014.icry @@ -0,0 +1 @@ +:load T014.cry diff --git a/tests/modsys/functors/T014.icry.stdout b/tests/modsys/functors/T014.icry.stdout new file mode 100644 index 000000000..8f6183247 --- /dev/null +++ b/tests/modsys/functors/T014.icry.stdout @@ -0,0 +1,7 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main + +[error] at T014.cry:5:1--5:19 + • Expected a module + • `submodule Main::A` is an interface diff --git a/tests/modsys/functors/T015.cry b/tests/modsys/functors/T015.cry new file mode 100644 index 000000000..c9aa061ad --- /dev/null +++ b/tests/modsys/functors/T015.cry @@ -0,0 +1,6 @@ + +submodule F where + import interface module T015_S + + x : n + x = 0 diff --git a/tests/modsys/functors/T015.icry b/tests/modsys/functors/T015.icry new file mode 100644 index 000000000..5a52d4aa5 --- /dev/null +++ b/tests/modsys/functors/T015.icry @@ -0,0 +1 @@ +:load T015.cry diff --git a/tests/modsys/functors/T015.icry.stdout b/tests/modsys/functors/T015.icry.stdout new file mode 100644 index 000000000..953adc64d --- /dev/null +++ b/tests/modsys/functors/T015.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading interface module T015_S +Loading module Main diff --git a/tests/modsys/functors/T015_S.cry b/tests/modsys/functors/T015_S.cry new file mode 100644 index 000000000..5b7a19d27 --- /dev/null +++ b/tests/modsys/functors/T015_S.cry @@ -0,0 +1,7 @@ +interface module T015_S where + +type n : * + +type constraint (Literal 0 n) + + diff --git a/tests/modsys/functors/T016.cry b/tests/modsys/functors/T016.cry new file mode 100644 index 000000000..c3fb971c2 --- /dev/null +++ b/tests/modsys/functors/T016.cry @@ -0,0 +1,15 @@ + +interface submodule S where + x : [8] + +submodule F where + import interface submodule S + + y = x + +submodule I where + private + x = 2 + +submodule M = submodule F { submodule I } + diff --git a/tests/modsys/functors/T016.icry b/tests/modsys/functors/T016.icry new file mode 100644 index 000000000..538a366a3 --- /dev/null +++ b/tests/modsys/functors/T016.icry @@ -0,0 +1 @@ +:load T016.cry diff --git a/tests/modsys/functors/T016.icry.stdout b/tests/modsys/functors/T016.icry.stdout new file mode 100644 index 000000000..b8bfd491e --- /dev/null +++ b/tests/modsys/functors/T016.icry.stdout @@ -0,0 +1,6 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main + +[error] at T016.cry:14:39--14:40: + Functor argument does not define value parameter 'x' diff --git a/tests/modsys/functors/T017.cry b/tests/modsys/functors/T017.cry new file mode 100644 index 000000000..0dbd2fde3 --- /dev/null +++ b/tests/modsys/functors/T017.cry @@ -0,0 +1 @@ +module T017 = T017_F { T017_M } diff --git a/tests/modsys/functors/T017.icry b/tests/modsys/functors/T017.icry new file mode 100644 index 000000000..20ee0a7e4 --- /dev/null +++ b/tests/modsys/functors/T017.icry @@ -0,0 +1,2 @@ +:load T017.cry +y diff --git a/tests/modsys/functors/T017.icry.stdout b/tests/modsys/functors/T017.icry.stdout new file mode 100644 index 000000000..3239aab48 --- /dev/null +++ b/tests/modsys/functors/T017.icry.stdout @@ -0,0 +1,7 @@ +Loading module Cryptol +Loading module Cryptol +Loading interface module `parameter` interface of T017_F +Loading module T017_F +Loading module T017_M +Loading module T017 +0x04 diff --git a/tests/modsys/functors/T017_F.cry b/tests/modsys/functors/T017_F.cry new file mode 100644 index 000000000..aebca4451 --- /dev/null +++ b/tests/modsys/functors/T017_F.cry @@ -0,0 +1,6 @@ +module T017_F where + +parameter + x : [8] + +y = x + x diff --git a/tests/modsys/functors/T017_M.cry b/tests/modsys/functors/T017_M.cry new file mode 100644 index 000000000..e8a0970cf --- /dev/null +++ b/tests/modsys/functors/T017_M.cry @@ -0,0 +1,4 @@ +module T017_M where + +x : [8] +x = 2 diff --git a/tests/modsys/functors/T018.cry b/tests/modsys/functors/T018.cry new file mode 100644 index 000000000..7bddf52f4 --- /dev/null +++ b/tests/modsys/functors/T018.cry @@ -0,0 +1,11 @@ +module T1 where + +parameter + anything : Bit + +submodule A where + x = 0x02 + +import submodule A + +y = x diff --git a/tests/modsys/functors/T018.icry b/tests/modsys/functors/T018.icry new file mode 100644 index 000000000..14fa52b07 --- /dev/null +++ b/tests/modsys/functors/T018.icry @@ -0,0 +1,2 @@ +:load T018.cry +y diff --git a/tests/modsys/functors/T018.icry.stdout b/tests/modsys/functors/T018.icry.stdout new file mode 100644 index 000000000..b7ec00d76 --- /dev/null +++ b/tests/modsys/functors/T018.icry.stdout @@ -0,0 +1,7 @@ +Loading module Cryptol +Loading module Cryptol +Loading interface module `parameter` interface of T1 +Loading module T1 + +Expression depends on definitions from a parameterized module: + T1::y diff --git a/tests/modsys/functors/T019.icry b/tests/modsys/functors/T019.icry new file mode 100644 index 000000000..e7c78b38b --- /dev/null +++ b/tests/modsys/functors/T019.icry @@ -0,0 +1,2 @@ +// a version of test/modsys/T5 with parameterized modules desugared +:module T019::Main diff --git a/tests/modsys/functors/T019.icry.stdout b/tests/modsys/functors/T019.icry.stdout new file mode 100644 index 000000000..7d6659ab0 --- /dev/null +++ b/tests/modsys/functors/T019.icry.stdout @@ -0,0 +1,11 @@ +Loading module Cryptol +Loading module Cryptol +Loading interface module T019::J +Loading module `where` argument of T019::B +Loading interface module T019::I +Loading module T019::A +Loading module T019::B + +[error] at ./T019/B.cry:1:8--1:15 + • Expected a module + • ``where` argument of T019::B` is a functor diff --git a/tests/modsys/functors/T019.icry.stdout.mingw32 b/tests/modsys/functors/T019.icry.stdout.mingw32 new file mode 100644 index 000000000..050eeb248 --- /dev/null +++ b/tests/modsys/functors/T019.icry.stdout.mingw32 @@ -0,0 +1,11 @@ +Loading module Cryptol +Loading module Cryptol +Loading interface module T019::J +Loading module `where` argument of T019::B +Loading interface module T019::I +Loading module T019::A +Loading module T019::B + +[error] at .\T019\B.cry:1:8--1:15 + • Expected a module + • ``where` argument of T019::B` is a functor diff --git a/tests/modsys/functors/T019/A.cry b/tests/modsys/functors/T019/A.cry new file mode 100644 index 000000000..4ca3e0dce --- /dev/null +++ b/tests/modsys/functors/T019/A.cry @@ -0,0 +1,5 @@ +module T019::A where + +import interface T019::I + +main = x + y diff --git a/tests/modsys/functors/T019/B.cry b/tests/modsys/functors/T019/B.cry new file mode 100644 index 000000000..616e572ee --- /dev/null +++ b/tests/modsys/functors/T019/B.cry @@ -0,0 +1,6 @@ +module T019::B = T019::A where + +import interface T019::J + +x = z +y = 10 diff --git a/tests/modsys/functors/T019/I.cry b/tests/modsys/functors/T019/I.cry new file mode 100644 index 000000000..04a6bc481 --- /dev/null +++ b/tests/modsys/functors/T019/I.cry @@ -0,0 +1,4 @@ +interface module T019::I where + +x : [8] +y : [8] diff --git a/tests/modsys/functors/T019/J.cry b/tests/modsys/functors/T019/J.cry new file mode 100644 index 000000000..9edb488b5 --- /dev/null +++ b/tests/modsys/functors/T019/J.cry @@ -0,0 +1,3 @@ +interface module T019::J where + +z : [8] diff --git a/tests/modsys/functors/T019/Main.cry b/tests/modsys/functors/T019/Main.cry new file mode 100644 index 000000000..3e3d52a55 --- /dev/null +++ b/tests/modsys/functors/T019/Main.cry @@ -0,0 +1,7 @@ +module T019::Main where + +submodule BInst = T019::B where + z = 7 +import submodule BInst as B + +main = B::main diff --git a/tests/modsys/functors/T020.icry b/tests/modsys/functors/T020.icry new file mode 100644 index 000000000..7fa050f86 --- /dev/null +++ b/tests/modsys/functors/T020.icry @@ -0,0 +1,5 @@ +// a fixed version of test/modsys/T5 with all parameterized modules and +// anonymous instantiations desugared +:module T020::Main +:t main +main diff --git a/tests/modsys/functors/T020.icry.stdout b/tests/modsys/functors/T020.icry.stdout new file mode 100644 index 000000000..69d612660 --- /dev/null +++ b/tests/modsys/functors/T020.icry.stdout @@ -0,0 +1,9 @@ +Loading module Cryptol +Loading module Cryptol +Loading interface module T020::J +Loading interface module T020::I +Loading module T020::A +Loading module T020::B +Loading module T020::Main +main : [8] +0x11 diff --git a/tests/modsys/functors/T020/A.cry b/tests/modsys/functors/T020/A.cry new file mode 100644 index 000000000..ad2524e20 --- /dev/null +++ b/tests/modsys/functors/T020/A.cry @@ -0,0 +1,5 @@ +module T020::A where + +import interface T020::I + +main = x + y diff --git a/tests/modsys/functors/T020/B.cry b/tests/modsys/functors/T020/B.cry new file mode 100644 index 000000000..a59238967 --- /dev/null +++ b/tests/modsys/functors/T020/B.cry @@ -0,0 +1,10 @@ +module T020::B where + +import interface T020::J + +submodule AInst = T020::A where + x = z + y = 10 +import submodule AInst as A + +main = A::main diff --git a/tests/modsys/functors/T020/I.cry b/tests/modsys/functors/T020/I.cry new file mode 100644 index 000000000..e8082f337 --- /dev/null +++ b/tests/modsys/functors/T020/I.cry @@ -0,0 +1,4 @@ +interface module T020::I where + +x : [8] +y : [8] diff --git a/tests/modsys/functors/T020/J.cry b/tests/modsys/functors/T020/J.cry new file mode 100644 index 000000000..2f14da2a7 --- /dev/null +++ b/tests/modsys/functors/T020/J.cry @@ -0,0 +1,3 @@ +interface module T020::J where + +z : [8] diff --git a/tests/modsys/functors/T020/Main.cry b/tests/modsys/functors/T020/Main.cry new file mode 100644 index 000000000..58fff1d88 --- /dev/null +++ b/tests/modsys/functors/T020/Main.cry @@ -0,0 +1,7 @@ +module T020::Main where + +submodule BInst = T020::B where + z = 7 +import submodule BInst as B + +main = B::main \ No newline at end of file diff --git a/tests/modsys/functors/T021.cry b/tests/modsys/functors/T021.cry new file mode 100644 index 000000000..ce1b0ba8f --- /dev/null +++ b/tests/modsys/functors/T021.cry @@ -0,0 +1,12 @@ + +submodule F where + parameter + x : [8] + + y = x + 1 + + +import submodule F where + x = 2 + + diff --git a/tests/modsys/functors/T021.icry b/tests/modsys/functors/T021.icry new file mode 100644 index 000000000..47218e5c6 --- /dev/null +++ b/tests/modsys/functors/T021.icry @@ -0,0 +1,2 @@ +:load T021.cry +y diff --git a/tests/modsys/functors/T021.icry.stdout b/tests/modsys/functors/T021.icry.stdout new file mode 100644 index 000000000..aa0e86e34 --- /dev/null +++ b/tests/modsys/functors/T021.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x03 diff --git a/tests/modsys/functors/T022.cry b/tests/modsys/functors/T022.cry new file mode 100644 index 000000000..0d49b9dd9 --- /dev/null +++ b/tests/modsys/functors/T022.cry @@ -0,0 +1,14 @@ + +interface submodule S where + type n : # + type constraint (fin n) + x : [n] + +submodule F where + import interface submodule S as A + + z = A::x + A::x + +import submodule F where + type n = 8 + x = 2 diff --git a/tests/modsys/functors/T022.icry b/tests/modsys/functors/T022.icry new file mode 100644 index 000000000..c4cd292cd --- /dev/null +++ b/tests/modsys/functors/T022.icry @@ -0,0 +1,2 @@ +:load T022.cry +z diff --git a/tests/modsys/functors/T022.icry.stdout b/tests/modsys/functors/T022.icry.stdout new file mode 100644 index 000000000..a2244dbbd --- /dev/null +++ b/tests/modsys/functors/T022.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x04 diff --git a/tests/modsys/functors/T023.cry b/tests/modsys/functors/T023.cry new file mode 100644 index 000000000..5b5733723 --- /dev/null +++ b/tests/modsys/functors/T023.cry @@ -0,0 +1,13 @@ +module T023 where + +submodule F where + parameter + x : [8] + + y = x + 1 + +submodule G where + x = 2 + +import submodule F { submodule G } + diff --git a/tests/modsys/functors/T023.icry b/tests/modsys/functors/T023.icry new file mode 100644 index 000000000..776d6ab76 --- /dev/null +++ b/tests/modsys/functors/T023.icry @@ -0,0 +1,2 @@ +:load T023.cry +y diff --git a/tests/modsys/functors/T023.icry.stdout b/tests/modsys/functors/T023.icry.stdout new file mode 100644 index 000000000..0b5ff8305 --- /dev/null +++ b/tests/modsys/functors/T023.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module T023 +0x03 diff --git a/tests/modsys/functors/T024.cry b/tests/modsys/functors/T024.cry new file mode 100644 index 000000000..77533c698 --- /dev/null +++ b/tests/modsys/functors/T024.cry @@ -0,0 +1,14 @@ +module T023 where + +submodule F where + parameter + x : [8] + + y = x + 1 + +submodule G where + x = 2 + +import submodule F { submodule G } + where z = 2 + diff --git a/tests/modsys/functors/T024.icry b/tests/modsys/functors/T024.icry new file mode 100644 index 000000000..daa247d56 --- /dev/null +++ b/tests/modsys/functors/T024.icry @@ -0,0 +1 @@ +:load T024.cry diff --git a/tests/modsys/functors/T024.icry.stdout b/tests/modsys/functors/T024.icry.stdout new file mode 100644 index 000000000..c852c17d0 --- /dev/null +++ b/tests/modsys/functors/T024.icry.stdout @@ -0,0 +1,7 @@ +Loading module Cryptol + +Parse error at T024.cry:12:1--12:7 + Invalid instantiating import. + Import should have at most one of: + * { } instantiation, or + * where instantiation diff --git a/tests/modsys/functors/T025.cry b/tests/modsys/functors/T025.cry new file mode 100644 index 000000000..127854d7e --- /dev/null +++ b/tests/modsys/functors/T025.cry @@ -0,0 +1,17 @@ +interface submodule S where + x : [8] + +submodule G where + import interface submodule S + y = x + 1 + +submodule F where + import interface submodule S as A + import submodule G { interface A } + z = A::x + y + +import submodule F where + x = 5 + + + diff --git a/tests/modsys/functors/T025.icry b/tests/modsys/functors/T025.icry new file mode 100644 index 000000000..452122431 --- /dev/null +++ b/tests/modsys/functors/T025.icry @@ -0,0 +1,2 @@ +:load T025.cry +z diff --git a/tests/modsys/functors/T025.icry.stdout b/tests/modsys/functors/T025.icry.stdout new file mode 100644 index 000000000..cd5beea70 --- /dev/null +++ b/tests/modsys/functors/T025.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x0b diff --git a/tests/modsys/functors/T026.cry b/tests/modsys/functors/T026.cry new file mode 100644 index 000000000..3fac7ea56 --- /dev/null +++ b/tests/modsys/functors/T026.cry @@ -0,0 +1,21 @@ +interface submodule S where + x : [8] + +submodule G where + import interface submodule S + y = x + 1 + +submodule F where + import interface submodule S as A + + submodule H where + import submodule G { interface A } + z = A::x + y + +import submodule F where + x = 5 + +import submodule H + + + diff --git a/tests/modsys/functors/T026.icry b/tests/modsys/functors/T026.icry new file mode 100644 index 000000000..138a90739 --- /dev/null +++ b/tests/modsys/functors/T026.icry @@ -0,0 +1,2 @@ +:load T026.cry +z diff --git a/tests/modsys/functors/T026.icry.stdout b/tests/modsys/functors/T026.icry.stdout new file mode 100644 index 000000000..cd5beea70 --- /dev/null +++ b/tests/modsys/functors/T026.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x0b diff --git a/tests/modsys/functors/T027.cry b/tests/modsys/functors/T027.cry new file mode 100644 index 000000000..2ccb5ed38 --- /dev/null +++ b/tests/modsys/functors/T027.cry @@ -0,0 +1,23 @@ +interface submodule S where + x : [8] + +submodule G where + import interface submodule S + y = x + 1 + +submodule F where + import interface submodule S as A + + submodule H where + import interface submodule S as A + import submodule G { interface A } + z = A::x + y + +import submodule F where + x = 5 + +import submodule H where + x = 6 + + + diff --git a/tests/modsys/functors/T027.icry b/tests/modsys/functors/T027.icry new file mode 100644 index 000000000..a2ec83ba7 --- /dev/null +++ b/tests/modsys/functors/T027.icry @@ -0,0 +1,2 @@ +:load T027.cry +z diff --git a/tests/modsys/functors/T027.icry.stdout b/tests/modsys/functors/T027.icry.stdout new file mode 100644 index 000000000..43c470464 --- /dev/null +++ b/tests/modsys/functors/T027.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x0d diff --git a/tests/modsys/functors/T028.cry b/tests/modsys/functors/T028.cry new file mode 100644 index 000000000..09ec99a2e --- /dev/null +++ b/tests/modsys/functors/T028.cry @@ -0,0 +1,17 @@ +interface submodule S where + x : [8] + +submodule G where + import interface submodule S + y = x + 1 + +submodule F where + import interface submodule S + import submodule G { interface S } + z = x + y + +import submodule F where + x = 5 + + + diff --git a/tests/modsys/functors/T028.icry b/tests/modsys/functors/T028.icry new file mode 100644 index 000000000..f94655b37 --- /dev/null +++ b/tests/modsys/functors/T028.icry @@ -0,0 +1,2 @@ +:load T028.cry +z diff --git a/tests/modsys/functors/T028.icry.stdout b/tests/modsys/functors/T028.icry.stdout new file mode 100644 index 000000000..cd5beea70 --- /dev/null +++ b/tests/modsys/functors/T028.icry.stdout @@ -0,0 +1,4 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +0x0b diff --git a/tests/modsys/functors/T029.cry b/tests/modsys/functors/T029.cry new file mode 100644 index 000000000..7b17b0f6b --- /dev/null +++ b/tests/modsys/functors/T029.cry @@ -0,0 +1,11 @@ +submodule F where + parameter + type n : # + + f : (2 < n) => () + f = () + +submodule M = submodule F where + type n = 8 + +import submodule M as M diff --git a/tests/modsys/functors/T029.icry b/tests/modsys/functors/T029.icry new file mode 100644 index 000000000..3417f244f --- /dev/null +++ b/tests/modsys/functors/T029.icry @@ -0,0 +1,3 @@ +:set coreLint=on +:load T029.cry +M::f diff --git a/tests/modsys/functors/T029.icry.stdout b/tests/modsys/functors/T029.icry.stdout new file mode 100644 index 000000000..76ed2acfb --- /dev/null +++ b/tests/modsys/functors/T029.icry.stdout @@ -0,0 +1,9 @@ +Loading module Cryptol +Loading module Cryptol +{n, a, b, c} n == min n n +{a, n} (fin n) => inf == inf * (1 * (1 * 1)) +{a, n} (fin n) => n / 2 == n - n /^ 2 +{n, a, b} n == min n n +{n} (n >= 1, fin n) => (fin n, n >= 1) +Loading module Main +() diff --git a/tests/modsys/nested/T16.cry b/tests/modsys/nested/T16.cry new file mode 100644 index 000000000..8bf63bee8 --- /dev/null +++ b/tests/modsys/nested/T16.cry @@ -0,0 +1,2 @@ +import T16_M +import submodule A diff --git a/tests/modsys/nested/T16.icry b/tests/modsys/nested/T16.icry new file mode 100644 index 000000000..69915c77e --- /dev/null +++ b/tests/modsys/nested/T16.icry @@ -0,0 +1 @@ +:load T16.cry diff --git a/tests/modsys/nested/T16.icry.stdout b/tests/modsys/nested/T16.icry.stdout new file mode 100644 index 000000000..938fa713c --- /dev/null +++ b/tests/modsys/nested/T16.icry.stdout @@ -0,0 +1,7 @@ +Loading module Cryptol +Loading module Cryptol +Loading module T16_M +Loading module Main + +[error] at T16.cry:2:1--2:19 + Module not in scope: A diff --git a/tests/modsys/nested/T16_M.cry b/tests/modsys/nested/T16_M.cry new file mode 100644 index 000000000..549e5382c --- /dev/null +++ b/tests/modsys/nested/T16_M.cry @@ -0,0 +1,4 @@ +module T16_M where +private + submodule A where + x = 0x02 diff --git a/tests/modsys/nested/T5.icry.stdout b/tests/modsys/nested/T5.icry.stdout index 73f1f89ef..34fd07c7e 100644 --- a/tests/modsys/nested/T5.icry.stdout +++ b/tests/modsys/nested/T5.icry.stdout @@ -3,10 +3,10 @@ Loading module Cryptol Loading module T4 Loading module T5 0x02 -Modules -======= +Submodules +========== - submodule A + A Symbols ======= diff --git a/tests/modsys/nested/T6.icry.stdout b/tests/modsys/nested/T6.icry.stdout index 8e70e8b15..7abaed456 100644 --- a/tests/modsys/nested/T6.icry.stdout +++ b/tests/modsys/nested/T6.icry.stdout @@ -3,10 +3,10 @@ Loading module Cryptol Loading module T4 Loading module T6 -Modules -======= +Submodules +========== - submodule A + A Symbols ======= diff --git a/tests/mono-binds/test01.icry.stdout b/tests/mono-binds/test01.icry.stdout index a165f4c64..2e2c2c566 100644 --- a/tests/mono-binds/test01.icry.stdout +++ b/tests/mono-binds/test01.icry.stdout @@ -3,6 +3,7 @@ Loading module Cryptol Loading module test01 module test01 import Cryptol + /* Not recursive */ test01::a : {n, a} (fin n) => [n]a -> [2 * n]a test01::a = @@ -18,6 +19,7 @@ Loading module Cryptol Loading module test01 module test01 import Cryptol + /* Not recursive */ test01::a : {n, a} (fin n) => [n]a -> [2 * n]a test01::a = diff --git a/tests/mono-binds/test02.icry.stdout b/tests/mono-binds/test02.icry.stdout index 0c39c671f..99655db62 100644 --- a/tests/mono-binds/test02.icry.stdout +++ b/tests/mono-binds/test02.icry.stdout @@ -3,6 +3,7 @@ Loading module Cryptol Loading module test02 module test02 import Cryptol + /* Not recursive */ test02::test : {a, b} a -> b test02::test = @@ -20,6 +21,7 @@ Loading module Cryptol Loading module test02 module test02 import Cryptol + /* Not recursive */ test02::test : {a, b} b -> a test02::test = diff --git a/tests/mono-binds/test03.icry.stdout b/tests/mono-binds/test03.icry.stdout index 53c98ad99..53fdff1df 100644 --- a/tests/mono-binds/test03.icry.stdout +++ b/tests/mono-binds/test03.icry.stdout @@ -3,6 +3,7 @@ Loading module Cryptol Loading module test03 module test03 import Cryptol + /* Not recursive */ test03::test : {a} (fin a, a >= width a) => [a] test03::test = @@ -18,6 +19,7 @@ Loading module Cryptol Loading module test03 module test03 import Cryptol + /* Not recursive */ test03::test : {a} (fin a, a >= width a) => [a] test03::test = diff --git a/tests/mono-binds/test04.icry.stdout b/tests/mono-binds/test04.icry.stdout index ab707e1c4..650d8d615 100644 --- a/tests/mono-binds/test04.icry.stdout +++ b/tests/mono-binds/test04.icry.stdout @@ -3,6 +3,7 @@ Loading module Cryptol Loading module test04 module test04 import Cryptol + /* Not recursive */ test04::test : {a, b} (Literal 10 b) => a -> ((a, ()), (a, b)) test04::test = diff --git a/tests/mono-binds/test05.icry.stdout b/tests/mono-binds/test05.icry.stdout index 14b100735..e4b856cd4 100644 --- a/tests/mono-binds/test05.icry.stdout +++ b/tests/mono-binds/test05.icry.stdout @@ -9,6 +9,7 @@ Loading module test05 test05.cry:9:3--9:6 module test05 import Cryptol + /* Not recursive */ test05::foo : [10] test05::foo = Cryptol::number 10 [10] <> diff --git a/tests/mono-binds/test06.icry.stdout b/tests/mono-binds/test06.icry.stdout index a579c3686..477092a3d 100644 --- a/tests/mono-binds/test06.icry.stdout +++ b/tests/mono-binds/test06.icry.stdout @@ -3,6 +3,7 @@ Loading module Cryptol Loading module test06 module test06 import Cryptol + /* Not recursive */ test06::test : {a} (Zero a) => a -> a test06::test = @@ -22,6 +23,7 @@ Loading module Cryptol Loading module test06 module test06 import Cryptol + /* Not recursive */ test06::test : {a} (Zero a) => a -> a test06::test = diff --git a/tests/regression/tc-errors.icry.stdout b/tests/regression/tc-errors.icry.stdout index 834216dc4..afd956f78 100644 --- a/tests/regression/tc-errors.icry.stdout +++ b/tests/regression/tc-errors.icry.stdout @@ -72,8 +72,6 @@ Loading module Main at tc-errors-3.cry:2:5--2:6 Loading module Cryptol Loading module Main -[warning] at tc-errors-4.cry:1:10--1:11: - Assuming _ to have a numeric type [error] at tc-errors-4.cry:1:10--1:11: Wild card types are not allowed in this context