GaloisInc/cryptol
1
1
Fork 0
mirror of https://github.com/GaloisInc/cryptol.git synced 2024-09-11 14:06:13 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'release/2.4.0' into releases

Browse Source
This commit is contained in:
Adam C. Foltzer 2016-07-06 08:31:42 -07:00
commit a904a6726e
No known key found for this signature in database
GPG Key ID: EAB0F62047E6F9A6
165 changed files with 6221 additions and 5351 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Makefile
View File

@ -4,7 +4,7 @@ UNAME := $(shell uname -s)
ARCH := $(shell uname -m)
TESTS ?= parser issues regression renamer mono-binds
TEST_DIFF ?= meld
DIFF ?= meld
IGNORE_EXPECTED ?= --ignore-expected
@ -34,7 +34,7 @@ PKG := cryptol-${VERSION}-${SYSTEM_DESC}
ifneq (,$(findstring _NT,${UNAME}))
DIST := ${PKG}.msi
EXE_EXT := .exe
adjust-path = '$(shell cygpath -w $1)'
adjust-path = '$(shell /usr/bin/cygpath -w $1)'
PREFIX ?=
# For a systemwide distribution .msi, use:
# PREFIX ?= ${PROGRAM_FILES}/Galois/Cryptol\ ${VERSION}
@ -260,7 +260,7 @@ test: ${CS_BIN}/cryptol-test-runner
-T --hide-successes \
-T --jxml=$(call adjust-path,$(CURDIR)/results.xml) \
$(IGNORE_EXPECTED) \
$(if $(TEST_DIFF),-p $(TEST_DIFF),) \
$(if $(DIFF),-p $(DIFF),) \
)
# Since this is meant for development rather than end-user builds,

8
README.md
View File

@ -50,6 +50,14 @@ install Cryptol using Homebrew, Z3 will be installed automatically.
After installation, make sure that `z3` (or `z3.exe` on Windows)
is on your PATH.
### Note for 64-bit Linux Users
On some 64-bit Linux configurations, 32-bit binaries do not work. This
can lead to unhelpful error messages like `z3: no such file or
directory`, even when `z3` is clearly present. To fix this, either
install 32-bit compatibility packages for your distribution, or
download the `x64` version of Z3.
# Building Cryptol From Source
In addition to the binaries, the Cryptol source is available publicly

4
bench/data/AES.cry
View File

@ -32,7 +32,7 @@ type AESKeySize = (Nk*32)
type GF28 = [8]
type State = [4][Nb]GF28
type RoundKey = State
type KeySchedule = (RoundKey, [Nr-1]RoundKey, RoundKey)
type KeySchedule = (RoundKey, [Nr-1]RoundKey, RoundKey)
// GF28 operations
gf28Add : {n} (fin n) => [n]GF28 -> GF28
gf28Add ps = sums ! 0
@ -196,7 +196,7 @@ aesDecrypt : ([128], [AESKeySize]) -> [128]
aesDecrypt (ct, key) = stateToMsg (AESFinalInvRound (kFinal, rounds ! 0))
where (kFinal, ks, kInit) = ExpandKey key
state0 = AddRoundKey(kInit, msgToState ct)
rounds = [state0] # [ AESInvRound (rk, s)
rounds = [state0] # [ AESInvRound (rk, s)
| rk <- reverse ks
| s <- rounds
]

0
cabal.GHC7102.config → cabal.GHC710.config
View File

1071
cabal.GHC783.config
View File

File diff suppressed because it is too large Load Diff

1314
cabal.GHC80.config Normal file
View File

File diff suppressed because it is too large Load Diff

10
cryptol-server/Cryptol/Aeson.hs
View File

@ -5,7 +5,7 @@
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
--
-- Orphan 'FromJSON' and 'ToJSON' instances for certain Cryptol
-- types. Since these are meant to be consumed over a wire, they are
-- mostly focused on base values and interfaces rather than a full
@ -23,6 +23,7 @@ import Control.Applicative
import Control.Exception
import Data.Aeson
import Data.Aeson.TH
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Cryptol.Eval.Error as E
@ -42,6 +43,7 @@ import Cryptol.REPL.Monad
import qualified Cryptol.Testing.Concrete as Test
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.TypeCheck.InferTypes as T
import Cryptol.Utils.Ident
import Cryptol.Utils.PP hiding (empty)
instance ToJSON Doc where
@ -129,6 +131,10 @@ instance ToJSON Test.TestResult where
Test.FailError err args -> object
[ "FailError" .= show (pp err), "args" .= args ]
instance (ToJSON v) => ToJSON (M.Map Name v) where
toJSON = toJSON . M.mapKeys (unpackIdent . nameIdent)
{-# INLINE toJSON #-}
$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''NameInfo)
$(deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''E.EvalError)
$(deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''P.ParseError)
@ -160,7 +166,7 @@ $(deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''T.Select
$(deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } { fieldLabelModifier = drop 1 } ''T.Fixity)
$(deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''T.Pragma)
$(deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Assoc)
$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Name)
$(deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Name)
$(deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''IfaceDecl)
$(deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''T.Newtype)
$(deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''T.TySyn)

35
cryptol.cabal
View File

@ -1,5 +1,5 @@
Name: cryptol
Version: 2.3.0
Version: 2.4.0
Synopsis: Cryptol: The Language of Cryptography
Description: Cryptol is a domain-specific language for specifying cryptographic algorithms. A Cryptol implementation of an algorithm resembles its mathematical specification more closely than an implementation in a general purpose language. For more, see <http://www.cryptol.net/>.
License: BSD3
@ -12,6 +12,7 @@ Copyright: 2013-2016 Galois Inc.
Category: Language
Build-type: Simple
Cabal-version: >= 1.18
extra-source-files: bench/data/*.cry
data-files: *.cry Cryptol/*.cry
data-dir: lib
@ -23,7 +24,7 @@ source-repository head
source-repository this
type: git
location: https://github.com/GaloisInc/cryptol.git
tag: v2.3.0
tag: 2.4.0
flag static
default: False
@ -40,18 +41,16 @@ flag server
library
Default-language:
Haskell98
Build-depends: base >= 4.7 && < 5,
Build-depends: base >= 4.8 && < 5,
base-compat >= 0.6,
bytestring >= 0.10,
array >= 0.4,
async >= 2.0,
containers >= 0.5,
deepseq >= 1.3,
deepseq-generics >= 0.1 && < 0.2,
directory >= 1.2,
directory >= 1.2.2.0,
filepath >= 1.3,
gitrev >= 1.0,
generic-trie >= 0.3.0.1,
GraphSCC >= 1.0.4,
heredoc >= 0.2,
monad-control >= 1.0,
@ -62,7 +61,7 @@ library
process >= 1.2,
QuickCheck >= 2.7,
random >= 1.0.1,
sbv >= 5.7,
sbv >= 5.12,
smtLib >= 1.0.7,
simple-smt >= 0.6.0,
syb >= 0.4,
@ -168,9 +167,9 @@ library
GitRev
GHC-options: -Wall -O2 -fsimpl-tick-factor=140
-- the `fsimpl-tick-factor` is needed to finish optimizing the
-- generic trie.
ghc-prof-options: -fprof-auto -prof
if impl(ghc >= 8.0.1)
ghc-options: -Wno-redundant-constraints
ghc-prof-options: -fprof-auto
if flag(relocatable)
cpp-options: -DRELOCATABLE
@ -200,8 +199,10 @@ executable cryptol
, sbv
, tf-random
, transformers
GHC-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
ghc-prof-options: -auto-all -prof -rtsopts
GHC-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N1
if impl(ghc >= 8.0.1)
ghc-options: -Wno-redundant-constraints
ghc-prof-options: -auto-all -rtsopts
if os(linux) && flag(static)
ld-options: -static -pthread
@ -212,8 +213,10 @@ executable cryptol-server
other-modules: Cryptol.Aeson
default-language: Haskell2010
default-extensions: OverloadedStrings
GHC-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
ghc-prof-options: -auto-all -prof -rtsopts
GHC-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N1
if impl(ghc >= 8.0.1)
ghc-options: -Wno-redundant-constraints
ghc-prof-options: -auto-all -rtsopts
if os(linux) && flag(static)
ld-options: -static -pthread
if flag(server)
@ -241,7 +244,9 @@ benchmark cryptol-bench
hs-source-dirs: bench
default-language: Haskell2010
GHC-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
ghc-prof-options: -auto-all -prof -rtsopts
if impl(ghc >= 8.0.1)
ghc-options: -Wno-redundant-constraints
ghc-prof-options: -auto-all -rtsopts
if os(linux) && flag(static)
ld-options: -static -pthread
build-depends: base

48
cryptol/Main.hs
View File

@ -25,13 +25,18 @@ import Cryptol.Utils.PP
import Cryptol.Version (commitHash, commitBranch, commitDirty)
import Paths_cryptol (version)
import Control.Monad (when)
import Data.Maybe (isJust)
import Data.Version (showVersion)
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import System.Console.GetOpt
(OptDescr(..),ArgOrder(..),ArgDescr(..),getOpt,usageInfo)
import System.Directory (getTemporaryDirectory, removeFile)
import System.Environment (getArgs, getProgName, lookupEnv)
import System.Exit (exitFailure)
import System.FilePath (searchPathSeparator, splitSearchPath, takeDirectory)
import System.IO (hClose, hPutStr, openTempFile)
import Prelude ()
import Prelude.Compat
@ -41,6 +46,7 @@ data Options = Options
, optVersion :: Bool
, optHelp :: Bool
, optBatch :: Maybe FilePath
, optCommands :: [String]
, optCryptolrc :: Cryptolrc
, optCryptolPathOnly :: Bool
} deriving (Show)
@ -51,6 +57,7 @@ defaultOptions = Options
, optVersion = False
, optHelp = False
, optBatch = Nothing
, optCommands = []
, optCryptolrc = CryrcDefault
, optCryptolPathOnly = False
}
@ -60,6 +67,12 @@ options =
[ Option "b" ["batch"] (ReqArg setBatchScript "FILE")
"run the script provided and exit"
, Option "c" ["command"] (ReqArg addCommand "COMMAND")
(concat [ "run the given command and then exit; if multiple --command "
, "arguments are given, run them in the order they appear "
, "on the command line (overrides --batch)"
])
, Option "v" ["version"] (NoArg setVersion)
"display version number"
@ -81,6 +94,11 @@ options =
addFile :: String -> OptParser Options
addFile path = modify $ \ opts -> opts { optLoad = [ path ] }
-- | Add a command to be run on interpreter startup.
addCommand :: String -> OptParser Options
addCommand cmd =
modify $ \ opts -> opts { optCommands = cmd : optCommands opts }
-- | Set a batch script to be run.
setBatchScript :: String -> OptParser Options
setBatchScript path = modify $ \ opts -> opts { optBatch = Just path }
@ -160,9 +178,27 @@ main = do
Right opts
| optHelp opts -> displayHelp []
| optVersion opts -> displayVersion
| otherwise -> repl (optCryptolrc opts)
(optBatch opts)
(setupREPL opts)
| otherwise -> do
(opts', mCleanup) <- setupCmdScript opts
repl (optCryptolrc opts')
(optBatch opts')
(setupREPL opts')
case mCleanup of
Nothing -> return ()
Just cmdFile -> removeFile cmdFile
setupCmdScript :: Options -> IO (Options, Maybe FilePath)
setupCmdScript opts =
case optCommands opts of
[] -> return (opts, Nothing)
cmds -> do
tmpdir <- getTemporaryDirectory
(path, h) <- openTempFile tmpdir "cmds.icry"
hPutStr h (unlines cmds)
hClose h
when (isJust (optBatch opts)) $
putStrLn "[warning] --command argument specified; ignoring batch file"
return (opts { optBatch = Just path }, Just path)
setupREPL :: Options -> REPL ()
setupREPL opts = do
@ -193,5 +229,9 @@ setupREPL opts = do
Just file -> prependSearchPath [ takeDirectory file ]
case optLoad opts of
[] -> loadPrelude `REPL.catch` \x -> io $ print $ pp x
[l] -> loadCmd l `REPL.catch` \x -> io $ print $ pp x
[l] -> loadCmd l `REPL.catch` \x -> do
io $ print $ pp x
-- If the requested file fails to load, load the prelude instead
loadPrelude `REPL.catch` \y -> do
io $ print $ pp y
_ -> io $ putStrLn "Only one file may be loaded at the command line."

28
cryptol/REPL/Haskeline.hs
View File

@ -23,7 +23,7 @@ import qualified Control.Monad.Trans.Class as MTL
import Control.Monad.Trans.Control
import Data.Char (isAlphaNum, isSpace)
import Data.Function (on)
import Data.List (isPrefixOf,nub,sortBy)
import Data.List (isPrefixOf,nub,sortBy,sort)
import System.Console.ANSI (setTitle)
import System.Console.Haskeline
import System.Directory ( doesFileExist
@ -197,19 +197,30 @@ cmdArgument ct cursor@(l,_) = case ct of
NoArg _ -> return (l,[])
FileExprArg _ -> completeExpr cursor
-- | Additional keywords to suggest in the REPL
-- autocompletion list.
keywords :: [String]
keywords =
[ "else"
, "if"
, "let"
, "then"
, "where"
]
-- | Complete a name from the expression environment.
completeExpr :: CompletionFunc REPL
completeExpr (l,_) = do
ns <- getExprNames
let n = reverse (takeWhile isIdentChar l)
vars = filter (n `isPrefixOf`) ns
ns <- (keywords++) <$> getExprNames
let n = reverse (takeIdent l)
vars = sort $ filter (n `isPrefixOf`) ns
return (l,map (nameComp n) vars)
-- | Complete a name from the type synonym environment.
completeType :: CompletionFunc REPL
completeType (l,_) = do
ns <- getTypeNames
let n = reverse (takeWhile isIdentChar l)
let n = reverse (takeIdent l)
vars = filter (n `isPrefixOf`) ns
return (l,map (nameComp n) vars)
@ -221,6 +232,13 @@ nameComp prefix c = Completion
, isFinished = True
}
-- | Return longest identifier (possibly a qualified name) that is a
-- prefix of the given string
takeIdent :: String -> String
takeIdent (c : cs) | isIdentChar c = c : takeIdent cs
takeIdent (':' : ':' : cs) = ':' : ':' : takeIdent cs
takeIdent _ = []
isIdentChar :: Char -> Bool
isIdentChar c = isAlphaNum c || c `elem` "_\'"

1
docs/CryptolPrims.md
View File

@ -74,7 +74,6 @@ Sequences
// Abbreviations
splitBy n = split`{parts = n}
groupBy n = split`{each = n}
tail n = splitAt`{front = 1}.1
take n = splitAt`{front = n}.0

BIN
docs/CryptolPrims.pdf
View File

Binary file not shown.

BIN
docs/ProgrammingCryptol.pdf
View File

Binary file not shown.

3
docs/ProgrammingCryptol/Makefile
View File

@ -16,7 +16,8 @@ AUX = ${wildcard ${TMP}/*.blg} ${wildcard ${TMP}/*.bbl} ${wildcard ${TMP}/
${wildcard ${TMP}/*.ind} ${wildcard ${TMP}/*.brf} ${wildcard ${TMP}/*.glg} \
${wildcard ${TMP}/*.glo} ${wildcard ${TMP}/*.gls} ${wildcard ${TMP}/*.ist} \
LATEX = xelatex -output-driver=xdvipdfmx -output-directory=${TMP} -halt-on-error -file-line-error
LATEX = xelatex -output-directory=${TMP} -halt-on-error -file-line-error
# LATEX = xelatex -output-driver=xdvipdfmx -output-directory=${TMP} -halt-on-error -file-line-error
BIBTEX = bibtex
MAKEINDEX = makeindex

6
docs/ProgrammingCryptol/aes/AES.cry
View File

@ -32,7 +32,7 @@ type AESKeySize = (Nk*32)
type GF28 = [8]
type State = [4][Nb]GF28
type RoundKey = State
type KeySchedule = (RoundKey, [Nr-1]RoundKey, RoundKey)
type KeySchedule = (RoundKey, [Nr-1]RoundKey, RoundKey)
// GF28 operations
gf28Add : {n} (fin n) => [n]GF28 -> GF28
gf28Add ps = sums ! 0
@ -88,7 +88,7 @@ InvSubByte : GF28 -> GF28
InvSubByte b = gf28Inverse (xformByte' b)
InvSubBytes : State -> State
InvSubBytes state =[ [ InvSubByte b | b <- row ] | row <- state ]
InvSubBytes state = [ [ InvSubByte b | b <- row ] | row <- state ]
// The ShiftRows transform and its inverse
ShiftRows : State -> State
@ -196,7 +196,7 @@ aesDecrypt : ([128], [AESKeySize]) -> [128]
aesDecrypt (ct, key) = stateToMsg (AESFinalInvRound (kFinal, rounds ! 0))
where (kFinal, ks, kInit) = ExpandKey key
state0 = AddRoundKey(kInit, msgToState ct)
rounds = [state0] # [ AESInvRound (rk, s)
rounds = [state0] # [ AESInvRound (rk, s)
| rk <- reverse ks
| s <- rounds
]

36
docs/ProgrammingCryptol/aes/AES.tex
View File

@ -90,8 +90,8 @@ The following derived type is helpful in signatures:
\end{code}
%=====================================================================
\section{Polynomials in \texorpdfstring{GF($2^8$)}{GF(2,8)}}
\label{sec:polynomials}
% \section{Polynomials in \texorpdfstring{GF($2^8$)}{GF(2,8)}}
% \label{sec:polynomials}
\sectionWithAnswers{Polynomials in \texorpdfstring{GF($2^8$)}{GF(2,8)}}{sec:polynomials}
AES\indAES works on a two-dimensional representation of the input
@ -345,8 +345,8 @@ Cryptol run long enough to complete the {\tt :prove
\end{Answer}
%=====================================================================
\section{The {\ttfamily{\textbf SubBytes}} transformation}
\label{aes:subbytes}
% \section{The {\ttfamily{\textbf SubBytes}} transformation}
% \label{aes:subbytes}
\sectionWithAnswers{The {\ttfamily{\textbf SubBytes}} transformation}{aes:subbytes}
\todo[inline]{Introduce a figure here, perhaps lifted from the
@ -554,8 +554,8 @@ us~\cite[Section 5.1.1]{aes}. We capture this table below in Cryptol:
\end{code}
\begin{Exercise}\label{ex:sbox}
Write and prove a property stating that {\tt SubByte} and {\tt
SubByte'} are equivalent.
Write and prove a property stating that {\tt SubByte} and
{\tt SubByte'} are equivalent.
\end{Exercise}
\begin{Answer}\ansref{ex:sbox}
\begin{code}
@ -568,7 +568,7 @@ We have:
\end{Verbatim}
\end{Answer}
\nb{The {\tt SubByte'} and {\tt SubBytes'} versions are going to be
\note{The {\tt SubByte'} and {\tt SubBytes'} versions are going to be
more efficient for execution, naturally. We should emphasize that
this mode of development is quite common in modern cryptography.
Ciphers are typically designed using ideas from mathematics, often
@ -603,8 +603,8 @@ We have:
% \end{Answer}
%=====================================================================
\section{The {\ttfamily{\textbf ShiftRows}} transformation}
\label{aes:shiftrows}
% \section{The {\ttfamily{\textbf ShiftRows}} transformation}
% \label{aes:shiftrows}
\sectionWithAnswers{The {\ttfamily{\textbf ShiftRows}} transformation}{aes:shiftrows}
\todo[inline]{Need a figure here to get reader in the right frame of
@ -652,8 +652,8 @@ Of course, any multiple of 4 would have the same effect.
\end{Answer}
%=====================================================================
\section{The {\ttfamily{\textbf MixColumns}} transformation}
\label{sec:aesmixcolumns}
% \section{The {\ttfamily{\textbf MixColumns}} transformation}
% \label{sec:aesmixcolumns}
\sectionWithAnswers{The {\ttfamily{\textbf MixColumns}} transformation}{sec:aesmixcolumns}
The third major transformation AES\indAES performs is the {\tt
@ -797,8 +797,8 @@ Cryptol's concrete syntax, it makes little sense to do anything but
row-based ordering.
%=====================================================================
\section{Key expansion}
\label{aes:keyexpansion}
% \section{Key expansion}
% \label{aes:keyexpansion}
\sectionWithAnswers{Key expansion}{aes:keyexpansion}
\todo[inline]{Will we push the pipeline of verification all the way
@ -975,7 +975,7 @@ above, written in a functional style to compute the mask:
then SubWord(prev)
else prev
\end{code}
\nb{It is well worth studying the pseudo-code above and the Cryptol
\note{It is well worth studying the pseudo-code above and the Cryptol
equivalent to convince yourself they are expressing the same idea!}
To compute the key schedule we start with the initial key as the
@ -1090,8 +1090,8 @@ Notice that Cryptol's {\tt \Verb|^|} operator applies structurally to
arbitrary shapes, computing the exclusive-or element-wise.
%=====================================================================
\section{AES encryption}
\label{sec:aes:encryption}
% \section{AES encryption}
% \label{sec:aes:encryption}
\sectionWithAnswers{AES encryption}{sec:aes:encryption}
We now have all the necessary machinery to perform AES\indAES
@ -1219,8 +1219,8 @@ merely need to set {\tt Nk} to be 8 for AES256.
\end{Exercise}
%=====================================================================
\section{Decryption}
\label{sec:aesdecryption}
% \section{Decryption}
% \label{sec:aesdecryption}
\sectionWithAnswers{Decryption}{sec:aesdecryption}
AES decryption is fairly similar to encryption, except it uses inverse

2
docs/ProgrammingCryptol/appendices/Makefile Normal file
View File

@ -0,0 +1,2 @@
Syntax.tex : ../../Syntax.md
pandoc ../../Syntax.md --to latex > Syntax.tex

178
docs/ProgrammingCryptol/appendices/Syntax.tex
View File

@ -4,7 +4,7 @@ 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 declaration. Groups of declarations appear at the top level of
group of declarations. Groups of declarations appear at the top level of
a Cryptol file, and inside \texttt{where} blocks in expressions. For
example, consider the following declaration group
@ -48,9 +48,9 @@ Examples:
Cryptol identifiers consist of one or more characters. The first
character must be either an English letter or underscore (\texttt{\_}).
The following characters may be an English letter, a decimal digit,
underscore (\texttt{\_}), or a prime (\texttt{'}). Some identifiers have
special meaning in the language, so they may not be used in
programmer-defined names (see
underscore (\texttt{\_}), or a prime (\texttt{\textquotesingle{}}). Some
identifiers have special meaning in the language, so they may not be
used in programmer-defined names (see
\hyperref[keywords-and-built-in-operators]{Keywords}).
Examples:
@ -66,6 +66,11 @@ Built-in Operators}\label{keywords-and-built-in-operators}}
The following identifiers have special meanings in Cryptol, and may not
be used for programmer defined names:
\textless{}!--- The table below can be generated by running
\texttt{chop.hs} on this list: Arith Bit Cmp False Inf True else export
extern fin if import inf lg2 max min module newtype pragma property then
type where width ---\textgreater{}
\begin{verbatim}
Arith Inf extern inf module then
Bit True fin lg2 newtype type
@ -77,42 +82,32 @@ The following table contains Cryptol's operators and their associativity
with lowest precedence operators first, and highest precedence last.
\begin{longtable}[c]{@{}ll@{}}
\toprule\addlinespace
Operator & Associativity
\\\addlinespace
\midrule\endhead
\texttt{\textbar{}\textbar{}} & left
\\\addlinespace
\texttt{\^{}} & left
\\\addlinespace
\texttt{\&\&} & left
\\\addlinespace
\texttt{-\textgreater{}} (types) & right
\\\addlinespace
\texttt{!=} \texttt{==} & not associative
\\\addlinespace
\caption{Operator precedences.}\tabularnewline
\toprule
Operator & Associativity\tabularnewline
\midrule
\endfirsthead
\toprule
Operator & Associativity\tabularnewline
\midrule
\endhead
\texttt{\textbar{}\textbar{}} & left\tabularnewline
\texttt{\^{}} & left\tabularnewline
\texttt{\&\&} & left\tabularnewline
\texttt{-\textgreater{}} (types) & right\tabularnewline
\texttt{!=} \texttt{==} & not associative\tabularnewline
\texttt{\textgreater{}} \texttt{\textless{}} \texttt{\textless{}=}
\texttt{\textgreater{}=} & not associative
\\\addlinespace
\texttt{\#} & right
\\\addlinespace
\texttt{\textgreater{}=} & not associative\tabularnewline
\texttt{\#} & right\tabularnewline
\texttt{\textgreater{}\textgreater{}} \texttt{\textless{}\textless{}}
\texttt{\textgreater{}\textgreater{}\textgreater{}}
\texttt{\textless{}\textless{}\textless{}} & left
\\\addlinespace
\texttt{+} \texttt{-} & left
\\\addlinespace
\texttt{*} \texttt{/} \texttt{\%} & left
\\\addlinespace
\texttt{\^{}\^{}} & right
\\\addlinespace
\texttt{!} \texttt{!!} \texttt{@} \texttt{@@} & left
\\\addlinespace
(unary) \texttt{-} \texttt{\textasciitilde{}} & right
\\\addlinespace
\texttt{\textless{}\textless{}\textless{}} & left\tabularnewline
\texttt{+} \texttt{-} & left\tabularnewline
\texttt{*} \texttt{/} \texttt{\%} & left\tabularnewline
\texttt{\^{}\^{}} & right\tabularnewline
\texttt{!} \texttt{!!} \texttt{@} \texttt{@@} & left\tabularnewline
(unary) \texttt{-} \texttt{\textasciitilde{}} & right\tabularnewline
\bottomrule
\addlinespace
\caption{Operator precedences.}
\end{longtable}
\section{Numeric Literals}\label{numeric-literals}
@ -158,31 +153,28 @@ The type \texttt{Bit} has two inhabitants: \texttt{True} and
operators, or constructed as results of comparisons.
\begin{longtable}[c]{@{}lll@{}}
\toprule\addlinespace
Operator & Associativity & Description
\\\addlinespace
\midrule\endhead
\texttt{\textbar{}\textbar{}} & left & Logical or
\\\addlinespace
\texttt{\^{}} & left & Exclusive-or
\\\addlinespace
\texttt{\&\&} & left & Logical and
\\\addlinespace
\texttt{!=} \texttt{==} & none & Not equals, equals
\\\addlinespace
\caption{Bit operations.}\tabularnewline
\toprule
Operator & Associativity & Description\tabularnewline
\midrule
\endfirsthead
\toprule
Operator & Associativity & Description\tabularnewline
\midrule
\endhead
\texttt{\textbar{}\textbar{}} & left & Logical or\tabularnewline
\texttt{\^{}} & left & Exclusive-or\tabularnewline
\texttt{\&\&} & left & Logical and\tabularnewline
\texttt{!=} \texttt{==} & none & Not equals, equals\tabularnewline
\texttt{\textgreater{}} \texttt{\textless{}} \texttt{\textless{}=}
\texttt{\textgreater{}=} & none & Comparisons
\\\addlinespace
\texttt{\textasciitilde{}} & right & Logical negation
\\\addlinespace
\texttt{\textgreater{}=} & none & Comparisons\tabularnewline
\texttt{\textasciitilde{}} & right & Logical negation\tabularnewline
\bottomrule
\addlinespace
\caption{Bit operations.}
\end{longtable}
\section{If Then Else with Multiway}\label{if-then-else-with-multiway}
\texttt{If then else} has been extended to support multi-way
\texttt{If\ then\ else} has been extended to support multi-way
conditionals. Examples:
\begin{verbatim}
@ -207,7 +199,7 @@ of records are a label and a value separated by an equal sign. Examples:
() // A tuple with no components
{ x = 1, y = 2 } // A record with two fields, `x` and `y`
{} // A record with no fileds
{} // A record with no fields
\end{verbatim}
The components of tuples are identified by position, while the
@ -238,20 +230,20 @@ sufficient type information to determine the shape of the tuple or
record. For example:
\begin{verbatim}
type T = { sign :: Bit, number :: [15] }
type T = { sign : Bit, number : [15] }
// Valid defintion:
// Valid definition:
// the type of the record is known.
isPositive : T -> Bit
isPositive x = x.sign
// Invalid defintion:
// Invalid definition:
// insufficient type information.
badDef x = x.f
\end{verbatim}
The components of a tuple or a record may also be access by using
pattern matching. Patterns for tuples and records mirror the syntax for
The components of a tuple or a record may also be accessed using pattern
matching. Patterns for tuples and records mirror the syntax for
constructing values: tuple patterns use parenthesis, while record
patterns use braces. Examples:
@ -260,17 +252,18 @@ getFst (x,_) = x
distance2 { x = xPos, y = yPos } = xPos ^^ 2 + yPos ^^ 2
f x = fst + snd where
f p = x + y where
(x, y) = p
\end{verbatim}
\section{Sequences}\label{sequences}
A sequence is a fixed-length collection of element of the same type. The
type of a finite sequence of length \texttt{n}, with elements of type
\texttt{a} is \texttt{{[}n{]} a}. Often, a finite sequence of bits,
\texttt{{[}n{]} Bit}, is called a \emph{word}. We may abbreviate the
type \texttt{{[}n{]} Bit} as \texttt{{[}n{]}}. An infinite sequence with
elements of type \texttt{a} has type \texttt{{[}inf{]} a}, and
A sequence is a fixed-length collection of elements of the same type.
The type of a finite sequence of length \texttt{n}, with elements of
type \texttt{a} is \texttt{{[}n{]}\ a}. Often, a finite sequence of
bits, \texttt{{[}n{]}\ Bit}, is called a \emph{word}. We may abbreviate
the type \texttt{{[}n{]}\ Bit} as \texttt{{[}n{]}}. An infinite sequence
with elements of type \texttt{a} has type \texttt{{[}inf{]}\ a}, and
\texttt{{[}inf{]}} is an infinite stream of bits.
\begin{verbatim}
@ -292,25 +285,25 @@ expressions, while the bounds in bounded-finite and infinite sequences
are value expressions.
\begin{longtable}[c]{@{}ll@{}}
\toprule\addlinespace
Operator & Description
\\\addlinespace
\midrule\endhead
\texttt{\#} & Sequence concatenation
\\\addlinespace
\caption{Sequence operations.}\tabularnewline
\toprule
Operator & Description\tabularnewline
\midrule
\endfirsthead
\toprule
Operator & Description\tabularnewline
\midrule
\endhead
\texttt{\#} & Sequence concatenation\tabularnewline
\texttt{\textgreater{}\textgreater{}} \texttt{\textless{}\textless{}} &
Shift (right,left)
\\\addlinespace
Shift (right,left)\tabularnewline
\texttt{\textgreater{}\textgreater{}\textgreater{}}
\texttt{\textless{}\textless{}\textless{}} & Rotate (right,left)
\\\addlinespace
\texttt{@} \texttt{!} & Access elements (front,back)
\\\addlinespace
\texttt{@@} \texttt{!!} & Access sub-sequence (front,back)
\\\addlinespace
\texttt{\textless{}\textless{}\textless{}} & Rotate
(right,left)\tabularnewline
\texttt{@} \texttt{!} & Access elements (front,back)\tabularnewline
\texttt{@@} \texttt{!!} & Access sub-sequence
(front,back)\tabularnewline
\bottomrule
\addlinespace
\caption{Sequence operations.}
\end{longtable}
There are also lifted point-wise operations.
@ -333,9 +326,9 @@ f p1 p2 = e // Function definition
e where ds
\end{verbatim}
Note that by default, any local declarations without type signatures
are monomorphized. If you need a local declaration to be polymorphic,
use an explicit type signature.
Note that by default, any local declarations without type signatures are
monomorphized. If you need a local declaration to be polymorphic, use an
explicit type signature.
\section{Explicit Type Instantiation}\label{explicit-type-instantiation}
@ -343,8 +336,13 @@ If \texttt{f} is a polymorphic value with type:
\begin{verbatim}
f : { tyParam }
f = zero
\end{verbatim}
f `{ tyParam = t }
you can evaluate \texttt{f}, passing it a type parameter:
\begin{verbatim}
f `{ tyParam = 13 }
\end{verbatim}
\section{Demoting Numeric Types to
@ -359,10 +357,10 @@ following notation:
Here \texttt{t} should be a type expression with numeric kind. The
resulting expression is a finite word, which is sufficiently large to
accomodate the value of the type:
accommodate the value of the type:
\begin{verbatim}
`{t} :: {w >= width t}. [w]
`{t} : {w >= width t}. [w]
\end{verbatim}
\section{Explicit Type Annotations}\label{explicit-type-annotations}

10
docs/ProgrammingCryptol/appendices/grammar.tex
View File

@ -1,17 +1,17 @@
\chapter{Cryptol Syntax}
\label{cha:crypt-synt}
\todo[inline]{To be written or, preferably, generated.}
% \todo[inline]{To be written or, preferably, generated.}
%=====================================================================
\label{sec:crypt-synt-summ}
\input{appendices/Syntax.tex}
%=====================================================================
\chapter{The Cryptol Grammar}
\label{cha:cryptol-grammar}
This appendix to be filled in soon.
%% \chapter{The Cryptol Grammar}
%% \label{cha:cryptol-grammar}
%%
%% This appendix to be filled in soon.
%% \input{appendices/CryptolEBNF.tex}
%%% Local Variables:

35
docs/ProgrammingCryptol/classic/Classic.tex
View File

@ -1,3 +1,9 @@
\commentout{
\begin{code}
module Classic where
\end{code}
}
\chapter{Classic ciphers}
\label{chapter:classic}
@ -41,7 +47,7 @@ inverses of each other.
To check the correctness of an \emph{implementation} $I$ of a
cryptographic function $C$ means that one must show that the
implementation $I$ behaves as the specification ($C$) stipulates. In
the context of cryptography, the minimal conformance necesssary is
the context of cryptography, the minimal conformance necessary is
that $I$'s output \emph{exactly} conforms to the output characterized
by $C$. But just because a cryptographic implementation is
\emph{functionally correct} does not mean it is \emph{secure}. The
@ -57,8 +63,8 @@ an interesting and useful feature, it is not part of Cryptol's current
capabilities.
%=====================================================================
\section{Caesar's cipher}
\label{sec:caesar}
% \section{Caesar's cipher}
% \label{sec:caesar}
\sectionWithAnswers{Caesar's cipher}{sec:caesar}
Caesar's cipher (a.k.a. Caesar's shift) is one of the simplest
@ -256,8 +262,8 @@ $255$.) The change in {\tt dCaesar'} is analogous:\indRotRight
\end{Answer}
%=====================================================================
\section{\texorpdfstring{Vigen\`{e}re}{Vigenere} cipher}
\label{sec:vigenere}
% \section{\texorpdfstring{Vigen\`{e}re}{Vigenere} cipher}
% \label{sec:vigenere}
\sectionWithAnswers{\texorpdfstring{Vigen\`{e}re}{Vigenere} cipher}{sec:vigenere}
The Vigen\`{e}re cipher is a variation on the Caesar's cipher, where
@ -441,8 +447,8 @@ where we would only need one character to crack it.\indCaesarscipher
%% \end{Answer}
%=====================================================================
\section{The atbash}
\label{sec:atbash}
% \section{The atbash}
% \label{sec:atbash}
\sectionWithAnswers{The atbash}{sec:atbash}
The atbash cipher is a form of a shift cipher, where each letter is
@ -490,8 +496,8 @@ We have:
\end{Answer}
%=====================================================================
\section{Substitution ciphers}
\label{section:subst}
% \section{Substitution ciphers}
% \label{section:subst}
\sectionWithAnswers{Substitution ciphers}{section:subst}
Substitution ciphers\indSubstitutioncipher generalize all the ciphers
@ -639,8 +645,8 @@ choices.
\end{Answer}
%=====================================================================
\section{The scytale}
\label{sec:scytale}
% \section{The scytale}
% \label{sec:scytale}
\sectionWithAnswers{The scytale}{sec:scytale}
The scytale is one of the oldest cryptographic devices ever, dating
@ -695,10 +701,11 @@ The signature\indSignature on {\tt msg'} is revealing: We are taking a
string that has {\tt diameter * row} characters in it, and chopping it
up so that it has {\tt row} elements, each of which is a string that
has {\tt diameter} characters in it. Here is Cryptol in action,
encrypting the message {\tt ATTACKATDAWN}:
encrypting the message {\tt ATTACKATDAWN}, with {\tt diameter} set to
{\tt 3}:
\begin{Verbatim}
Cryptol> :set ascii=on
Cryptol> scytale "ATTACKATDAWN"
Cryptol> scytale `{diameter=3} "ATTACKATDAWN"
"ACDTKATAWATN"
\end{Verbatim}
Decryption is essentially the same process, except we have to {\tt
@ -718,7 +725,7 @@ precisely the same, except for the signature on {\tt msg'}! When
viewed as a matrix, the types precisely tell which transposition we
want at each step. We have:
\begin{Verbatim}
Cryptol> dScytale "ACDTKATAWATN"
Cryptol> dScytale `{diameter=3} "ACDTKATAWATN"
"ATTACKATDAWN"
\end{Verbatim}

4637
docs/ProgrammingCryptol/cover/CryptolCover.ai
View File

File diff suppressed because one or more lines are too long

BIN
docs/ProgrammingCryptol/cover/CryptolCover.pdf Normal file
View File

Binary file not shown.

BIN
docs/ProgrammingCryptol/cover/CryptolSmallCover.pdf
View File

Binary file not shown.

236
docs/ProgrammingCryptol/crashCourse/CrashCourse.tex
View File

@ -26,8 +26,8 @@ time.
% \todo[inline]{2.1: Add list here of language features not yet
% covered.}
The full grammar for Cryptol is included
in~\autoref{cha:cryptol-grammar}.
% TODO The full grammar for Cryptol is included
% in~\autoref{cha:cryptol-grammar}.
%=====================================================================
\section{Basic data types}
@ -54,8 +54,6 @@ means the value {\tt 12} has type {\tt [8]}, i.e., it is an 8-bit
word. We shall see other examples of this in the following discussion.
%=====================================================================
\section{Bits: Booleans}
\label{sec:bits}
\sectionWithAnswers{Bits: Booleans}{sec:bits}
The type {\tt Bit}\indTheBitType represents a single bit of
@ -107,8 +105,6 @@ Here is the response from Cryptol, in order:
\end{tip}
%=====================================================================
\section{Words: Numbers}
\label{sec:words}
\sectionWithAnswers{Words: Numbers}{sec:words}
A word is simply a numeric value, corresponding to the usual notion of
@ -188,8 +184,8 @@ the same value, so {\tt a} and {\tt A} both represent 10.
Section~\ref{sec:words2}, after we learn about sequences.}
%=====================================================================
\section{Tuples: Heterogeneous collections}
\label{sec:tuple}
% \section{Tuples: Heterogeneous collections}
% \label{sec:tuple}
\sectionWithAnswers{Tuples: Heterogeneous collections}{sec:tuple}
A tuple is a simple collection of arbitrary ordered values of
@ -281,8 +277,8 @@ The required expression would be:
\end{tip}
%=====================================================================
\section{Sequences: Homogeneous collections}
\label{sec:sequences}
% \section{Sequences: Homogeneous collections}
% \label{sec:sequences}
\sectionWithAnswers{Sequences: Homogeneous collections}{sec:sequences}
While tuples contain heterogeneous data, sequences are used for
@ -388,8 +384,12 @@ summation, product, maximum, or minimum), though such comprehensions
can certainly be defined using Cryptol comprehensions.
\begin{Exercise}\label{ex:seq:4}
The components of a Cryptol sequence comprehension are
an expression of one or more variables (which defines each element of
the sequence), followed by one or more {\em arms}, each preceded by
a vertical bar, which define how the variables' values are generated.
A comprehension with a single arm is called a {\em cartesian
comprehension}. We can have one or more components in a cartesian
comprehension}. We can have one or more components in a cartesian
comprehension. Experiment with the following
expressions:\indComp\indCartesian
\begin{Verbatim}
@ -464,13 +464,14 @@ Comprehensions may be nested.\indNestedComp In this pattern, the
element value expression of the outer nesting is a sequence
comprehension (which may refer to values generated by the outer
generator). The pattern looks like this:
\begin{minipage}{\textwidth} %% trying to avoid splitting this across pages
\begin{Verbatim}
[ [ <expr with x & y> // \
| y <- [1 .. 5] // inner generator -- outer elements
] /
| x <- [1 .. 5] // outer generator
]
[ [ <expr with x & y> // \
| y <- [1 .. 5] // inner generator -- outer
] / elements
| x <- [1 .. 5] // outer generator
]
\end{Verbatim}
\end{minipage}
@ -633,7 +634,7 @@ Try the following infinite enumerations:
[100, 102, 104, 106, 108, ...]
\end{Verbatim}
\end{Answer}
\note{Note that we are explicitly telling Cryptol to use 32-bit words
\note{We are explicitly telling Cryptol to use 32-bit words
as the elements. The reason for doing so will become clear when we
study arithmetic shortly.}
\begin{Exercise}\label{ex:seq:10}
@ -671,11 +672,11 @@ worthwhile to try the following exercises to gain basic familiarity
with the basic operations.
\begin{Exercise}\label{ex:seq:11}
Try the following expressions:\indTake\indDrop\indSplitBy\indGroup\indJoin\indTranspose
Try the following expressions:\indTake\indDrop\indSplit\indGroup\indJoin\indTranspose
\begin{Verbatim}
take`{3} [1 .. 12]
drop`{3} [1 .. 12]
splitBy`{3} [1 .. 12]
split`{3} [1 .. 12]
groupBy`{3} [1 .. 12]
join [[1 .. 4], [5 .. 8], [9 .. 12]]
join [[1, 2, 3], [4, 5, 6], [7, 8, 9], [10, 11, 12]]
@ -695,7 +696,7 @@ Here are Cryptol's responses:
[1, 2, 3]
Cryptol> drop`{3} [1 .. 12]
[4, 5, 6, 7, 8, 9, 10, 11, 12]
Cryptol> splitBy`{3}[1 .. 12]
Cryptol> split`{3}[1 .. 12]
[[1, 2, 3, 4], [5, 6, 7, 8], [9, 10, 11, 12]]
Cryptol> groupBy`{3} [1 .. 12]
[[1, 2, 3], [4, 5, 6], [7, 8, 9], [10, 11, 12]]
@ -715,10 +716,10 @@ Here are Cryptol's responses:
\begin{Exercise}\label{ex:seq:12}
Based on your intuitions from the previous exercise, derive laws
between the following pairs of functions: {\tt take} and {\tt drop};
{\tt join} and {\tt splitBy}; {\tt join} and {\tt groupBy}; {\tt
splitBy} and {\tt groupBy} and {\tt transpose} and itself. For
{\tt join} and {\tt split}; {\tt join} and {\tt groupBy}; {\tt
split} and {\tt groupBy} and {\tt transpose} and itself. For
instance, {\tt take} and {\tt drop} satisfy the following
equality:\indTake\indDrop\indJoin\indSplitBy\indGroup\indTranspose
equality:\indTake\indDrop\indJoin\indSplit\indGroup\indTranspose
\begin{Verbatim}
(take`{n} xs) # (drop`{n} xs) == xs
\end{Verbatim}
@ -728,11 +729,11 @@ satisfy.
\end{Exercise}
\begin{Answer}\ansref{ex:seq:12}
The following equalities are the simplest
candidates:\indJoin\indSplitBy\indGroup\indTranspose
candidates:\indJoin\indSplit\indGroup\indTranspose
\begin{Verbatim}
join (splitBy`{parts=n} xs) == xs
join (split`{parts=n} xs) == xs
join (groupBy`{each=n} xs) == xs
splitBy`{parts=n} xs == groupBy`{each=m} xs
split`{parts=n} xs == groupBy`{each=m} xs
transpose (transpose xs) == xs
\end{Verbatim}
In the first two equalities {\tt n} must be a divisor of the length of
@ -756,13 +757,12 @@ holds for all equal length sequences {\tt xs0}, {\tt xs1}, $\ldots$,
{\tt xsN}.
\end{Answer}
\paragraph*{Type-directed splits} We have studied the functions {\tt
groupBy}\indGroup and {\tt splitBy}\indSplitBy above. Cryptol also
provides a function {\tt split}\indSplit that can split a sequence
into any number of equal-length segments. A common way to use {\tt
split} is to be explicit about the type of its result, instead of
passing arguments as we did above with {\tt splitBy} and {\tt
groupBy}.
\paragraph*{Type-directed splits} The Cryptol primitive function {\tt
split}\indSplit splits a sequence into any number of equal-length
parts. An explicit result type is often used with {\tt split}, since
the number of parts and the number of elements in each part are not
given as arguments, but are determined by the type of the argument
sequence and the result context.
\begin{Verbatim}
Cryptol> split [1..12] : [1][12][8]
[[1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]]
@ -775,10 +775,11 @@ Here is what happens if we do {\em not} give an explicit signature on
the result:\indSignature
\begin{Verbatim}
Cryptol> split [1..12]
<polymorphic value>
Cannot evaluate polymorphic value.
Type: {a, b, c} (fin b, fin c, b * a == 12, c >= 4) => [a][b][c]
Cryptol> :t split [1..12]
split [1 .. 12] : {a, b, c} (a >= 4, fin a, fin c,
12 == b * c) => [b][c][a]
split [1 .. 12] : {a, b, c} (fin b, fin c, b * a == 12,
c >= 4) => [a][b][c]
\end{Verbatim}
%% cryptol 1 said: : {a b c} (fin c,c >= 4,a*b == 12) => [a][b][c]
@ -900,8 +901,8 @@ Here are Cryptol's responses:
\end{Answer}
%=====================================================================
\section{Words revisited}
\label{sec:words2}
% \section{Words revisited}
% \label{sec:words2}
\sectionWithAnswers{Words revisited}{sec:words2}
In Section~\ref{sec:words} we have introduced numbers as a distinct
@ -1056,7 +1057,7 @@ remaining expressions.
[0, 0, 1, 4]
\end{Verbatim}
We will show the evaluation steps for {\tt groupBy} here, and urge the
reader to do the same for {\tt splitBy}:
reader to do the same for {\tt split}:
\begin{Verbatim}
groupBy`{3} (12:[12])
= groupBy`{3} [False, False, False, False, False, False,
@ -1153,8 +1154,8 @@ operations on them; including arithmetic:
\end{Verbatim}
%=====================================================================
\section{Records: Named collections}
\label{sec:records}
% \section{Records: Named collections}
% \label{sec:records}
\sectionWithAnswers{Records: Named collections}{sec:records}
In Cryptol, records are simply collections of named fields. In this
@ -1218,8 +1219,8 @@ Here are Cryptol's responses:
functionality in our current study.}
%=====================================================================
\section{\texorpdfstring{The {\tt zero}}{The zero}}
\label{sec:zero}
% \section{\texorpdfstring{The {\tt zero}}{The zero}}
% \label{sec:zero}
\sectionWithAnswers{\texorpdfstring{The {\tt zero}}{The zero}}{sec:zero}
Before proceeding further, we have to take a detour and talk briefly
@ -1244,7 +1245,7 @@ following examples should illustrate the idea:
\noindent On the other extreme, the value {\tt zero} combined with the
complement operator {\tt \Verb|~|}\indComplement gives us values that
consist of all all {\tt True}\indTrue bits:
consist of all {\tt True}\indTrue bits:
\begin{Verbatim}
Cryptol> ~zero : Bit
True
@ -1281,8 +1282,8 @@ The {\tt zero} function returns {\tt 0}, ignoring its argument.
\end{Answer}
%=====================================================================
\section{Arithmetic}
\label{sec:arithmetic}
% \section{Arithmetic}
% \label{sec:arithmetic}
\sectionWithAnswers{Arithmetic}{sec:arithmetic}
Cryptol supports the usual binary arithmetic operators {\tt +}, {\tt
@ -1480,11 +1481,11 @@ precisely 1-bits, and hence the arithmetic is done modulo $2^1 = 2$,
giving us the sequence $1$-$0$-$1$-$0$ \ldots. In particular, an
enumeration of the form:
\begin{Verbatim}
[k ..]
[k ...]
\end{Verbatim}
will be treated as if the user has written:
\begin{Verbatim}
[k, (k+1) ..]
[k, (k+1) ...]
\end{Verbatim}
and type inference will assign the smallest bit-size possible to
represent {\tt k}. \note{if the user evaluates the value of {\tt
@ -1537,15 +1538,15 @@ element is at least $4$-bits wide.
\end{Answer}
%=====================================================================
\section{Types}
\label{sec:types}
% \section{Types}
% \label{sec:types}
\sectionWithAnswers{Types}{sec:types}
Cryptol's type system is one of its key features\footnote{The Cryptol
type system is based on the traditional Hindley-Milner style,
extended with size types and arithmetic
predicates~\cite{erkok-carlsson-wick-cryptolCoverification-09,
erkok-matthews-cryptolEqChecking-09, Hin97}}. You have seen that
predicates (for details, see~\cite{erkok-carlsson-wick-cryptolCoverification-09,
erkok-matthews-cryptolEqChecking-09, Hin97})}. You have seen that
types can be used to specify the exact width of values, or shapes of
sequences using a rich yet concise notation. In some cases, it may
make sense to omit a type signature and let Cryptol {\em infer} the
@ -1725,7 +1726,7 @@ our running examples:
\begin{center}
\begin{adjustbox}{width={\textwidth},keepaspectratio}
\begin{tabular}[h]{c||c|c|l}
{\tt [a+1]b -> [a][b]} & {\tt a} & {\tt b} & Notes \\ \hline\hline
{\tt [a+1]b -> [a]b} & {\tt a} & {\tt b} & Notes \\ \hline\hline
{\tt [5][8] -> [4][8]} & 4 & {\tt [8]} & {\tt a+1 = 5} $\Rightarrow$ {\tt a = 4} \\\hline
{\tt [10][32] -> [9][32]} & 9 & {\tt [32]} & {\tt a+1 = 10} $ \Rightarrow$ {\tt a = 9} \\\hline
{\tt [3](Bit, [8]) -> [2](Bit, [8])} & 2 & {\tt (Bit, [8])} & The type {\tt b} is now a tuple \\\hline
@ -1800,21 +1801,6 @@ Cryptol divides {\tt 10} (the size of the second argument) by {\tt 3}
does not match what we told it to use for {\tt parts}, i.e., {\tt
2}. It is not hard to see that there is no instantiation to make this
work, since {\tt 10} is not divisible by {\tt 3}.
The message we get for the last equation is truly interesting:\indFin
\begin{Verbatim}
Cryptol> groupBy`{3} [1..10]
<polymorphic value>
Cryptol> :t groupBy`{3} [1..10]
{a, b} (a >= 4, fin a, 10 == 3 * b) => [b][3][a]
\end{Verbatim}
Cryptol is telling us that the result is a polymorphic value, for all
values of {\tt a} such that {\tt 3*a} is {\tt 10}. Type inference in
the presence of arbitrary expressions is undecidable,\indUndecidable
and hence Cryptol tells us that this value will be instantiated to a
concrete type as soon as we tell it what that {\tt a} must be. Since
there is no such {\tt a}, we will never be able to use this value in a
monomorphic context.
\end{Answer}
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@ -1996,8 +1982,8 @@ bit-precise programming problems it has been designed
for~\cite{lewis2003}.
%=====================================================================
\section{Defining functions}
\label{sec:funcs}
% \section{Defining functions}
% \label{sec:funcs}
\sectionWithAnswers{Defining functions}{sec:funcs}
So far, we used Cryptol as a calculator: we typed in expressions and
@ -2281,8 +2267,8 @@ empty sequence that can satisfy the predicate.
\end{Answer}
%=====================================================================
\section{Recursion and recurrences}
\label{sec:recandrec}
% \section{Recursion and recurrences}
% \label{sec:recandrec}
\sectionWithAnswers{Recursion and recurrences}{sec:recandrec}
\todo[inline]{This section represents a big opportunity to emphasize sequence
@ -2630,8 +2616,8 @@ arithmetic.\indModular
\end{Answer}
%=====================================================================
\section{Stream equations}
\label{sec:streameq}
% \section{Stream equations}
% \label{sec:streameq}
\sectionWithAnswers{Stream equations}{sec:streameq}
Most cryptographic algorithms are described in terms of operations on
@ -2682,16 +2668,17 @@ The Cryptol code corresponding to this stream equation is:
\begin{Answer}\ansref{ex:streamEq}
\begin{code}
xs input = [0x89, 0xAB, 0xCD, 0xEF] # new
where new = [ a ^ b ^ c | a <- as
| b <- drop`{2} as
| c <- input ]
xs input = as where
as = [0x89, 0xAB, 0xCD, 0xEF] # new
new = [ a ^ b ^ c | a <- as
| b <- drop`{2} as
| c <- input ]
\end{code}
\end{Answer}
%=====================================================================
\section{Type synonyms}
\label{sec:tsyn}
% \section{Type synonyms}
% \label{sec:tsyn}
\sectionWithAnswers{Type synonyms}{sec:tsyn}\indTypSynonym
\todo[inline]{Motivate type synonyms better; NQueens with nice
@ -3031,6 +3018,95 @@ Here is a more interesting example:
\todo[inline]{Why is this more interesting? What are the reflections the
reader should have?}
%=====================================================================
\section{Program structure with modules}
When a cryptographic specification gets very large it can make sense
to decompose its functions into modules.\indModuleSystem\indImport
Doing this well encourages
code re-use, so it's a generally good thing to do. Cryptol's module
system is simple and easy to use. Here's a quick overview:
A module's name should be the same as the filename the module is
defined in. For example, the \verb+utilities+ module should be
defined in a file called \verb+utilities.cry+. To specify that a file
defines a module, its first non-commented line should be:
\begin{verbatim}
module utilities where
\end{verbatim}
After that the variables and functions you define will be contained
(in this example) in the {\it utilities} module.
In the code where you want to use a module, you \verb+import+ it like this:
\begin{verbatim}
import utilities
\end{verbatim}
Cryptol will look for the file \verb+utilities.cry+ in the current directory. Once you've imported a module, all of its variables and functions are available to use in your code.
If you're writing a module that has both {\it private} and {\it public}
definitions, you can hide the ones that shouldn't be exported to modules
that include it by using the \verb+private+ keyword, like this:\indPrivate
\begin{verbatim}
private internalDouble x = x + x
exportedDouble = x * 2
\end{verbatim}
As you can tell, by default definitions are exported to including modules.
For large project it can be convenient to place modules in a directory
structure. In this case, the directory structure becomes part of the modules'
names. For example, when placing \verb+SHA3.cry+ in the \verb+Hash+ directory and
accessing it from \verb+HMAC.cry+ you would need to name the modules
accordingly:
\begin{verbatim}
sha3 : {n} (fin n) => [n] -> [512]
sha3 = error "Stubbed, for demonstration only: sha3-512"
blocksize : {n} (fin n, n >= 10) => [n]
blocksize = 576
\end{verbatim}
\begin{verbatim}
module Hash::SHA3 where
import Hash::SHA3
import Cryptol::Extras
hmac : {keySize, msgSize} (fin keySize, fin msgSize) => [keySize] -> [msgSize]
-> [512]
hmac k m = sha3 (ko # sha3 (ki # m))
where ko = zipWith (^) kFull (join (repeat 0x5c))
ki = zipWith (^) kFull (join (repeat 0x36))
kFull = if `keySize == blocksize
then take (k#zero)
else sha3 k
\end{verbatim}
Finally, if you're importing a module that defines something with
a name that you would like to define in your code, you can do a
{\it qualified} import of that module like this:
\begin{verbatim}
import utilities as util
\end{verbatim}
Now, instead of all the definitions being available in your module,
they are qualified with the name you provided, in this case \verb+util+.
This means you will prefix those names with \verb+util::+ when you call them,
and the unqualified names are able to be defined in your own code.
\begin{verbatim}
import utilities as util
// let's say utililities.cry defines "all", and we want to use
// it in our refined definition of all:
all xs = util::all xs && (width xs) > 0
\end{verbatim}
%=====================================================================
\section{The road ahead}
\label{sec:road-ahead}

16
docs/ProgrammingCryptol/enigma/Enigma.cry
View File

@ -27,13 +27,14 @@ elem (x, xs) = matches ! 0
| m <- matches
]
// Inverting a permutation lookup:
invSubst : (Permutation, Char) -> Char
invSubst (key, c) = candidates ! 0
where candidates = [0] # [ if c == k then a else p
| k <- key
| a <- ['A' .. 'Z']
| p <- candidates
]
private
invSubst : (Permutation, Char) -> Char
invSubst (key, c) = candidates ! 0
where candidates = [0] # [ if c == k then a else p
| k <- key
| a <- ['A' .. 'Z']
| p <- candidates
]
// Constructing a rotor
mkRotor : {n} (fin n) => (Permutation, String n) -> Rotor
@ -68,6 +69,7 @@ joinRotors (rotors, inputChar) = (rotors', outputChar)
substFwd, substBwd : (Permutation, Char) -> Char
substFwd (perm, c) = perm @ (c - 'A')
substBwd (perm, c) = invSubst (perm, c)
// Route the signal back from the reflector, chase through rotors
backSignal : {n} (fin n) => ([n]Rotor, Char) -> Char
backSignal (rotors, inputChar) = cs ! 0

24
docs/ProgrammingCryptol/enigma/Enigma.tex
View File

@ -33,8 +33,8 @@ interchangeable scramblers, and a fixed reflector.
vs.~the actual machine.}
%=====================================================================
\section{The plugboard}
\label{sec:enigma:plugboard}
% \section{The plugboard}
% \label{sec:enigma:plugboard}
\sectionWithAnswers{The plugboard}{sec:enigma:plugboard}
Enigma essentially implements a polyalphabetic substitution cipher
@ -83,8 +83,8 @@ Why do we subtract the {\tt 'A'} when indexing?
to {\tt H}, then {\tt H} must map to {\tt A}.}
%=====================================================================
\section{Scrambler rotors}
\label{sec:enigma:scramblerrotors}
% \section{Scrambler rotors}
% \label{sec:enigma:scramblerrotors}
\sectionWithAnswers{Scrambler rotors}{sec:enigma:scramblerrotors}
The next component of the Enigma are the rotors that scramble the
@ -161,8 +161,8 @@ making it a polyalphabetic substitution cipher.\indPolyAlphSubst
\end{Answer}
%=====================================================================
\section{Connecting the rotors: notches in action}
\label{sec:enigma:notches}
% \section{Connecting the rotors: notches in action}
% \label{sec:enigma:notches}
\sectionWithAnswers{Connecting the rotors: notches in action}{sec:enigma:notches}
\todo[inline]{A diagram here depicting rotor interchangeability and
@ -412,8 +412,8 @@ well, which we have glossed over in this discussion.
\end{Answer}
%=====================================================================
\section{The reflector}
\label{sec:enigma:reflector}
% \section{The reflector}
% \label{sec:enigma:reflector}
\sectionWithAnswers{The reflector}{sec:enigma:reflector}
The final piece of the Enigma machine is the
@ -479,8 +479,8 @@ all the elements of the alphabet.
\end{Answer}
%=====================================================================
\section{Putting the pieces together}
\label{sec:enigma:puttingittogether}
% \section{Putting the pieces together}
% \label{sec:enigma:puttingittogether}
\sectionWithAnswers{Putting the pieces together}{sec:enigma:puttingittogether}
We now have all the components of the Enigma: the plugboard, rotors,
@ -648,8 +648,8 @@ components we have created so far, using the starting positions {\tt
We now have an operational Enigma machine coded up in Cryptol!
%=====================================================================
\section{Encryption and decryption}
\label{enigma:encdec}
% \section{Encryption and decryption}
% \label{enigma:encdec}
\sectionWithAnswers{Encryption and decryption}{enigma:encdec}
Equipped with all the machinery we now have, coding Enigma encryption

32
docs/ProgrammingCryptol/highAssurance/HighAssurance.tex
View File

@ -2,8 +2,8 @@
\begin{code}
module HighAssurance where
import Enigma
import Classic
import Enigma
\end{code}
}
@ -26,8 +26,8 @@ these tools, and to the notion of high-assurance programming in
Cryptol via examples.
%=====================================================================
\section{Writing properties}
\label{sec:writingproperties}
% \section{Writing properties}
% \label{sec:writingproperties}
\sectionWithAnswers{Writing properties}{sec:writingproperties}
Consider the equality:
@ -117,7 +117,7 @@ What do you see?\indCmdInfo
\end{Exercise}
\begin{Answer}\ansref{ex:thm:2}\indReverse\indAppend
\begin{code}
property revApp (xs, ys) = reverse (xs # ys)
property revApp (xs, ys) = reverse (xs # ys)
== reverse ys # reverse xs
\end{code}
\end{Answer}
@ -132,7 +132,7 @@ What do you see?\indCmdInfo
\end{code}
\end{Answer}
\nb{A {\tt property} declaration simply introduces a property about
\note{A {\tt property} declaration simply introduces a property about
your program, which may or may {\em not} actually hold. It is an
assertion about your program, without any claim of correctness. In
particular, you can clearly write properties that simply do not
@ -259,7 +259,7 @@ certain monomorphic types, but not at all types.\indMonomorphism
\end{Verbatim}
\end{Answer}
\nb{The moral of this discussion is that the notion of polymorphic
\note{The moral of this discussion is that the notion of polymorphic
validity\indThmPolyvalid (i.e., that a given polymorphic property
will either hold at all of its monomorphic instances or none) does
not hold in Cryptol. A polymorphic property can be valid at some,
@ -313,8 +313,8 @@ remembering that the 0'th bit of an even number is always {\tt
\end{Answer}
%=====================================================================
\section{Establishing correctness}
\label{sec:establishcorrectness}
% \section{Establishing correctness}
% \label{sec:establishcorrectness}
\sectionWithAnswers{Establishing correctness}{sec:establishcorrectness}
Our focus so far has been using Cryptol to {\em state} properties of
@ -346,7 +346,7 @@ is being produced behind the scenes. Once Cryptol formally
establishes the property holds, it prints ``{\tt Q.E.D.}'' to tell the
user the proof is complete.\indQED\indProve
\nb{Cryptol uses off-the-shelf SAT\glosSAT and SMT\glosSMT solvers to
\note{Cryptol uses off-the-shelf SAT\glosSAT and SMT\glosSMT solvers to
perform these formal
proofs~\cite{erkok-matthews-cryptolEqChecking-09}. By default,
Cryptol will use Microsoft Research's Z3 SMT solver under the hood,
@ -568,7 +568,7 @@ We have:
\end{Answer}
%% TODO: Pedagogy here without exceptions
%% \nb{It is tempting to write a function:}
%% \note{It is tempting to write a function:}
%% \begin{code}
%% implies (a, b) = if a then b else True
%%\end{code}
@ -673,8 +673,8 @@ This may take a long time to prove, depending on the speed of your
machine, and the prover you choose.
%=====================================================================
\section{Automated random testing}
\label{sec:quickcheck}
% \section{Automated random testing}
% \label{sec:quickcheck}
\sectionWithAnswers{Automated random testing}{sec:quickcheck}
Cryptol's {\tt :prove} command\indCmdProve constructs rigorous formal
@ -799,8 +799,8 @@ simple means of exercising all your properties automatically.
%% Ctrl-C}.\indCmdAutoCheck
%=====================================================================
\section{Checking satisfiability}
\label{sec:sat}
% \section{Checking satisfiability}
% \label{sec:sat}
\sectionWithAnswers{Checking satisfiability}{sec:sat}
Closely related to proving properties is the notion of checking
@ -861,7 +861,7 @@ solution. When we change it to {\tt 4}, the satisfiability checker
will try to find {\em up to} 4 solutions. We can also set it to {\tt
all}, which will try to find as many solutions as possible.
\begin{Verbatim}
Cryptol> :set satNum = 4
Cryptol> :set satNum = all
Cryptol> :sat isSqrtOf9
isSqrtOf9 3 = True
isSqrtOf9 131 = True
@ -873,7 +873,7 @@ of 9; namely 3, 131, 125, and 253. (Note that Cryptol can return the
satisfying solutions in any order depending on the backend-solver and
other configurations. What is guaranteed is that you will get
precisely the same set of solutions at the end.)
The whole point of the satisfiability checker is to be able to quickly
search for particular values that are solutions to potentially
complicated bit-valued functions. In this sense, satisfiability

10
docs/ProgrammingCryptol/highAssurance/Makefile
View File

@ -1,8 +1,2 @@
Classic.cry:
ln -s ../classic/Classic.cry .
Enigma.cry:
ln -s ../enigma/Enigma.cry .
test: Enigma.cry Classic.cry
cryptol-2 -b sanity.icry
test:
CRYPTOLPATH=../classic:../enigma cryptol -b sanity.icry

18
docs/ProgrammingCryptol/highAssurance/sanity.icry
View File

@ -1,4 +1,18 @@
:set warnDefaulting=off
:set prover=yices
:l HighAssurance.tex
:prove caesarCorrect : ([8], String(8)) -> Bit
:prove caesarCorrect : ([8], String 12) -> Bit
:prove sqDiffsCorrect
:prove revRev : ([16] -> Bit)
:prove appAssoc : ([16], [12], [28]) -> Bit
:prove revApp : ([10][8], [5][8]) -> Bit
:prove lshMul : ([32], [32]) -> Bit
:prove inctest
:prove multShift : ([32] -> Bit)
:prove flipNeverIdentity : ([32] -> Bit)
:prove widthPoly : ([15] -> Bit)
:prove widthPoly : ([16] -> Bit)
:prove evenWidth : ([16] -> Bit)
:prove evenWidth : ([15] -> Bit)
:prove divModMul : ([12], [12]) -> Bit
:prove modelEnigmaCorrect : (String 12 -> Bit)
:prove easyBug

307
docs/ProgrammingCryptol/main/Cryptol-fullpage.tex
View File

@ -1,307 +0,0 @@
\documentclass[twoside]{book}
% \usepackage{layout}
\usepackage{amsfonts}
\usepackage{xspace}
\usepackage{url}
\usepackage{subfigure}
\usepackage{graphicx}
\usepackage{lastpage}
\usepackage{makeidx}
\usepackage[myheadings]{fullpage}
\usepackage{verbatim}
\usepackage{fancyvrb}
\usepackage{amsmath, amsthm, amssymb}
\usepackage{fancyhdr}
\usepackage{xcolor}
\usepackage{pdfpages}
\usepackage[answerdelayed,lastexercise]{utils/exercise}
\usepackage[xetex,bookmarks=true,pagebackref=true,linktocpage=true]{hyperref}
\usepackage[style=list]{utils/glossary}
\usepackage{adjustbox}
\usepackage[paperwidth=5.5in,paperheight=8.5in]{geometry}
\setlength{\textwidth}{350pt}
\setlength{\textheight}{502pt}
\advance\voffset by -72pt
\setlength{\hoffset}{-36pt}
% \setlength{\oddsidemargin}{36pt}
% \setlength{\evensidemargin}{-36pt}
\newcommand{\titleline}{Programming in Cryptol}
\hypersetup{%
pdftitle = \titleline,
pdfkeywords = {Cryptol, Cryptography, Programming},
pdfauthor = {Levent Erk\"{o}k},
pdfpagemode = UseOutlines
}
\input{utils/Indexes.tex}
\input{utils/GlossaryItems.tex}
\input{utils/trickery.tex}
% fonts
\usepackage{fontspec}
\usepackage{xunicode}
\usepackage{xltxtra}
\defaultfontfeatures{Mapping=tex-text}
\setmainfont[]{Times}
\setsansfont[]{Helvetica}
%% \setmonofont[Scale=0.85]{Courier}
\usepackage{sectsty}
\allsectionsfont{\sffamily}
\newcommand{\todo}[1]{\begin{center}\framebox{\begin{minipage}{0.8\textwidth}{{\bf TODO:} #1}\end{minipage}}\end{center}}
\newcommand{\lamex}{\ensuremath{\lambda}-expression\indLamExp}
\newcommand{\lamexs}{\ensuremath{\lambda}-expressions\indLamExp}
\makeatletter
\def\imod#1{\allowbreak\mkern10mu({\operator@font mod}\,\,#1)}
\makeatother
\newcommand{\advanced}{\begin{center}\framebox{\begin{minipage}{0.95\textwidth}{{\bf Note:} The material in this section
is aimed for the more advanced reader. It can be skipped on a first reading without loss of continuity.}\end{minipage}}\end{center}}
\newcommand{\sectionWithAnswers}[2]{%
\section{#1}\label{#2}%
\AnswerBoxSectionMark{Section \arabic{chapter}.\arabic{section} #1 (p.\pageref{#2})}%
\AnswerBoxExecute{\addcontentsline{toc}{section}{\texorpdfstring{\parbox{2.3em}{\arabic{chapter}.\arabic{section}\ }}{(\arabic{chapter}.\arabic{section})\ }#1}}%
}
\theoremstyle{definition}
\newcommand{\commentout}[1]{}
\DefineVerbatimEnvironment{code}{Verbatim}{}
\renewcommand{\ExerciseHeaderTitle}{\ExerciseTitle}
\renewcommand{\ExerciseHeader}{\textbf{\hspace*{-\parindent}\ExerciseName\ \theExercise.\ }}
\renewcommand{\AnswerHeader}{\textbf{\hspace*{-\parindent}\ExerciseName\ \theExercise.\ }}
\renewcounter{Exercise}[section]
\newcommand{\unparagraph}{\paragraph{$\,\,\,$\hspace*{-\parindent}}}
% various little text sections:
\newtheorem*{tip}{Tip}
\newtheorem*{hint}{Hint}
\newtheorem*{nb}{NB}
\newtheorem*{notesThm}{Note}
\newcommand{\note}[1]{\begin{notesThm}{#1}\end{notesThm}}
\newcommand{\lhint}[1]{({\bf Hint.}\ #1)}
\newcommand{\ansref}[1]{{\bf (p.~\pageref{#1})}}
%% \newcommand{\draftdate}{DRAFT of \today}
\setlength{\voffset}{-1cm}
\setlength{\headsep}{2cm}
\setlength{\headheight}{15.2pt}
\renewcommand{\headrulewidth}{0pt} % no line on top
\renewcommand{\footrulewidth}{.5pt} % line on bottom
\renewcommand{\chaptermark}[1]{\markboth{#1}{}}
\renewcommand{\sectionmark}[1]{\markright{#1}{}}
\cfoot{}
\fancyfoot[LE,RO]{\fancyplain{}{\textsf{\thepage}}}
\fancyfoot[LO,RE]{\fancyplain{}{\textsf{\copyright\ 2010--2016, Galois, Inc.}}}
%% \fancyhead[LE]{\fancyplain{}{\textsf{\draftdate}}}
%% \fancyhead[RO]{\fancyplain{}{\textsf{DO NOT DISTRIBUTE!}}}
\fancyhead[RO,LE]{\fancyplain{}{}} %% outer
%\fancyhead[LO,RE]{\fancyplain{}{\textsf{\nouppercase{\rightmark}}}}
\fancyhead[LO,RE]{\fancyplain{}{\textsf{\nouppercase{\rightmark}}}} %% inner
\pagestyle{fancyplain}
\makeglossary
\makeindex
\begin{document}
\title{\Huge{\bf \titleline}}
\author{\\$ $\\$ $\\
Levent Erk\"{o}k\\
%\url{levent.erkok@galois.com}
\\$ $\\
Galois, Inc.\\
421 SW 6th Ave., Suite 300\\Portland, OR 97204}
\date{
\vspace*{2cm}$ $\\
\includegraphics{utils/galois.jpg}
}
\pagenumbering{roman}
\includepdf[pages={1},scale=0.8]{cover/Cover.pdf}
% \maketitle
%%
\index{inference|see{type, inference}}
\index{signature|see{type, signature}}
\index{polymorphism|see{type, polymorphism}}
\index{monomorphism|see{type, monomorphism}}
\index{overloading|see{type, overloading}}
\index{undecidable|see{type, undecidable}}
\index{predicates|see{type, predicates}}
\index{defaulting|see{type, defaulting}}
\index{fin@\texttt{fin}|see{type, fin}}
\index{ambiguous constraints|see{type, ambiguous}}
\index{wildcard|see{\texttt{\_} (underscore)}}
\index{lambda expression|see{\ensuremath{\lambda}-expression}}
\index{pdiv@\texttt{pdiv}|see{polynomial, division}}
\index{pmod@\texttt{pmod}|see{polynomial, modulus}}
\index{pmult@\texttt{pmult}|see{polynomial, multiplication}}
\index{000GF28@GF($2^8$)|see{galois field}}
\setlength{\headsep}{24pt}
% \layout
%%%%%% PREFACE
%\input{preface/Preface.tex}
\input{preface/Notice.tex}
%%%%%% TOC
\tableofcontents
\includepdf[pages={1}]{cover/Blank.pdf}
\newpage
\setcounter{page}{1}
\pagenumbering{arabic}
%%%%%% Crash Course
\input{crashCourse/CrashCourse.tex}
\commentout{
\begin{code}
include "../crashCourse/CrashCourse.tex";
\end{code}
}
%%%%%% Transposition ciphers
\input{classic/Classic.tex}
\commentout{
\begin{code}
include "../classic/Classic.tex";
\end{code}
}
%%%%%% Enigma
\input{enigma/Enigma.tex}
\commentout{
\begin{code}
include "../enigma/Enigma.tex";
\end{code}
}
%%%%%% High assurance
%% TODO - after ticket 96
%% \input{highAssurance/HighAssurance.tex}
%% \commentout{
%% \begin{code}
%% include "../highAssurance/HighAssurance.tex";
%% \end{code}
%% }
%%%%%% DES
% \chapter{DES: The Data Encryption Standard}
%%%%%% AES
\input{aes/AES.tex}
\commentout{
\begin{code}
include "../aes/AES.tex";
\end{code}
}
%%%%%% SHA
% \chapter{SHA: The Secure Hash Algorithm}
%\chapter{Advanced proof techniques}
%\section{Assumed equality}
%\section{Uninterpreted functions}
%\section{Proving AES correct}\label{sec:proveaes}
%In Section~\ref{sec:aescorrectattempt}, we wrote down the below Cryptol theorem stating that our AES\indAES encryption/decryption functions work correctly:
%\begin{Verbatim}
% theorem AESCorrect: {msg key}. aesDecrypt (aesEncrypt (msg, key), key) == msg;
%\end{Verbatim}
% However, we were not able to do an automated proof of this fact, as it is beyond the scope of what SAT-based equivalence checkers can handle. In this
% section we will use our new tools to attack this problem and actually complete the proof in a reasonable amount of time.
%%%%%% SAT solving
% \chapter{Using satisfiability solvers: Solving Sudoku and N-Queens in Cryptol}\label{chap:usingsat}
%%%%%% Hardware
% \chapter{Generating and proving hardware correct}
%%%%%% Pitfalls
% \chapter{Pitfalls}
% \section{Defaulting}\label{sec:pitfall:defaulting}
% \todo{Talk about defaulting gotchas}
% \section{Evaluation order}\label{sec:pitfall:evorder}
% \todo{Talk about there's no short-circuit except for if-then-else, although models might differ.}
% \section{Theorems and safety checking}\label{sec:pitfall:thmexceptions}
% \todo{Talk about safety failures and theorems}
% \todo{Talk about why {\tt implies (x, y) = if x then y else False} is not a substitute for {\tt if-then-else}}
% \todo{Talk about assumeSafe}
%%%%%% Toolbox
% \chapter{Programmer's toolbox}
% \section{Pretty printing using {\tt format}}
% \section{Debugging code using {\tt trace}}
%%%%%% Miscallaneous
% \input{misc/Misc.tex}
% \commentout{
% \begin{code}
% include "../misc/Misc.tex";
% \end{code}
% }
\appendix
% \fancyhead[LO,RE]{\fancyplain{}{\textsf{\nouppercase{\leftmark}}}}
\fancyhead[LO,RE]{\fancyplain{}{}}
%%%% Solutions
\chapter{Solutions to selected exercises}
As with any language, there are usually multiple ways to write the same
function in Cryptol. We have tried to use the most idiomatic
Cryptol code segments in our solutions. Note that Cryptol prints
numbers out in hexadecimal by default. In most of the answers below, we
have implicitly used the command {\tt :set base=10} to print numbers
out in decimal for readability.\indSettingBase
\shipoutAnswer
%%%% Cryptol primitives
\input{prims/Primitives.tex}
\commentout{
\begin{code}
include "../prims/Primitives.tex";
\end{code}
}
%%%% Enigma code
\input{enigma/EnigmaCode.tex}
\commentout{
\begin{code}
include "../enigma/EnigmaCode.tex";
\end{code}
}
%%%% AES code
\input{aes/AESCode.tex}
\commentout{
\begin{code}
include "../aes/AESCode.tex";
\end{code}
}
%%%% Glossary
\printglossary
\addcontentsline{toc}{chapter}{Glossary}
%%%% Bibliography
\bibliography{bib/cryptol}
\bibliographystyle{plain}
%%%% Index
\printindex
%%%% sanity checks
% \commentout{
% \begin{code}
% isEverythingSane = ~zero == checks
% where checks = [aesEncSanityCheck aesDecSanityCheck];
% \end{code}
% }
\end{document}

212
docs/ProgrammingCryptol/main/Cryptol.tex
View File

@ -5,8 +5,6 @@
%
\documentclass[twoside]{book}
% \usepackage{layout}
% \usepackage{diagrams}
\usepackage{amsfonts}
\usepackage{xspace}
\usepackage{url}
@ -14,102 +12,100 @@
\usepackage{graphicx}
\usepackage{lastpage}
\usepackage{makeidx}
\usepackage{longtable}
\usepackage{booktabs}
\usepackage[disable]{todonotes}
\usepackage[myheadings]{fullpage}
\usepackage{verbatim}
%% \usepackage[lighttt]{lmodern}
%% \usepackage[ttscale=1.15]{lmodern}
\usepackage{fancyvrb}
\usepackage{booktabs}
\usepackage{amsmath, amsthm, amssymb}
\usepackage{fancyhdr}
\usepackage{xcolor}
\usepackage{pdfpages}
\usepackage[answerdelayed,lastexercise]{utils/exercise}
\usepackage[bookmarks=true,pagebackref=true,linktocpage=true]{hyperref}
\usepackage[xetex,bookmarks=true,pagebackref=true,linktocpage=true]{hyperref}
\usepackage[style=list]{utils/glossary}
\usepackage{adjustbox}
%\usepackage[paperwidth=5.5in,paperheight=8.5in]{geometry}
\usepackage{geometry}
% for bound books:
%\setlength{\textwidth}{340pt}
%% choose output pagesize. Here are two options:
%% Half of a US Letter sheet, (or A5 paper)
%% intended to be folded in half and bound in a book
% for half-letter:
%\usepackage[paperwidth=5.5in,paperheight=8.5in,inner=62pt,outer=34pt]{geometry}
%\setlength{\textheight}{502pt}
% for full-letter
\usepackage[paperwidth=8.5in,paperheight=11in,inner=62pt,outer=34pt]{geometry}
\setlength{\textheight}{652pt}
\newcommand{\titleline}{Programming in Cryptol}
\hypersetup{%
pdftitle = \titleline,
pdfkeywords = {Cryptol, Cryptography, Programming},
pdfauthor = {Galois, Inc.},
pdfpagemode = UseOutlines,
pdfborder = 0 0 0
pdftitle = \titleline,
pdfkeywords = {Cryptol, Cryptography, Programming},
pdfauthor = {Levent Erk\"{o}k and others at Galois},
pdfpagemode = UseOutlines
}
\RequirePackage[12tabu,orthodox]{nag}
\input{utils/Indexes.tex}
\input{utils/GlossaryItems.tex}
\input{utils/trickery.tex}
% fonts
\usepackage[TS1,T1]{fontenc}
\usepackage{microtype}
\usepackage[osf]{mathpazo}
\usepackage{fontspec}
\usepackage{xunicode}
\usepackage{xltxtra}
\defaultfontfeatures{Mapping=tex-text}
\setmainfont[]{Times}
\setsansfont[]{Helvetica}
\setmonofont[Scale=0.85]{Courier}
%\setmainfont[]{Times}
%\setsansfont[]{Helvetica}
%\setmonofont[Scale=0.85]{Courier}
\usepackage{sectsty}
\usepackage[disable]{todonotes}
\allsectionsfont{\sffamily}
% \newcommand{\todo}[1]{\begin{center}\framebox{\begin{minipage}{0.8\textwidth}{{\bf TODO:} #1}\end{minipage}}\end{center}}
\newcommand{\lamex}{\ensuremath{\lambda}-expression\indLamExp}
\newcommand{\lamexs}{\ensuremath{\lambda}-expressions\indLamExp}
\makeatletter
\def\imod#1{\allowbreak\mkern3mu({\operator@font mod}\,\,#1)}
\def\imod#1{\allowbreak\mkern10mu({\operator@font mod}\,\,#1)}
\makeatother
\newcommand{\advanced}{\begin{center}\framebox{\begin{minipage}{0.95\textwidth}{{\bf Note:} The material in this section
is aimed for the more advanced reader. It can be skipped on a first reading without loss of continuity.}\end{minipage}}\end{center}}
\newcommand{\ticket}[1]{\href{https://www.galois.com/cryptol/ticket/#1}{ticket \##1}}
\newcommand{\sectionWithAnswers}[2]{%
\section{#1}\label{#2}%
\AnswerBoxSectionMark{Section \arabic{chapter}.\arabic{section} #1 (p.\pageref{#2})}%
\AnswerBoxExecute{\addcontentsline{toc}{section}{\texorpdfstring{\parbox{2.3em}{\arabic{chapter}.\arabic{section}\ }}{(\arabic{chapter}.\arabic{section})\ }#1}}%
}
\newcommand{\advanced}{\begin{center}\framebox{\begin{minipage}{0.95\textwidth}{{\bf
Note:} The material in this section is aimed for the more
advanced reader. It can be skipped on a first reading
without loss of continuity.}\end{minipage}}\end{center}}
\newcommand{\sectionWithAnswers}[2]{%
\AnswerBoxSectionMark{Section \arabic{chapter}.\arabic{section} #1 (p.\pageref{#2})}%
\AnswerBoxExecute{\addcontentsline{toc}{section}{\protect\texorpdfstring{\protect\parbox{2.3em}{\protect\arabic{chapter}.\arabic{section}\ }}{(\arabic{chapter}.\arabic{section})\ }#1}}%
}
\theoremstyle{definition}
\newcommand{\commentout}[1]{}
\DefineVerbatimEnvironment{code}{Verbatim}{}
\renewcommand{\ExerciseHeaderTitle}{\ExerciseTitle}
\renewcommand{\ExerciseHeader}{\textbf{\hspace*{-\parindent}\ExerciseName\ \theExercise.\ }}
\renewcommand{\AnswerHeader}{\textbf{\hspace*{-\parindent}\ExerciseName\ \theExercise.\ }}
\renewcounter{Exercise}[chapter]
% \renewcounter{Exercise}[section]
\newcommand{\unparagraph}{\paragraph{$\,\,\,$\hspace*{-\parindent}}}
% various little text sections:
\newtheorem*{tip}{Tip}
\newtheorem*{hint}{Hint}
\newtheorem*{nb}{NB}
\newtheorem*{notesThm}{Note}
\newcommand{\note}[1]{\begin{notesThm}{#1}\end{notesThm}}
\newcommand{\lhint}[1]{({\bf Hint:}\ #1)}
\newcommand{\note}[1]{\vspace{5mm}{\setlength{\parindent}{0pt}{\bf Note:~}{#1}}}
\newcommand{\tip}[1]{\vspace{5mm}{\setlength{\parindent}{0pt}{\bf Tip:~}{#1}}}
\newcommand{\lhint}[1]{({\bf Hint}\ #1)}
\newcommand{\ansref}[1]{{\bf (p.~\pageref{#1})}}
%% \newcommand{\draftdate}{DRAFT of \today}
%% not needed:?
\setlength{\voffset}{-1cm}
\setlength{\headsep}{2cm}
\setlength{\headheight}{15.2pt}
\renewcommand{\headrulewidth}{0pt} % no line on top
\renewcommand{\footrulewidth}{.5pt} % line on bottom
\renewcommand{\chaptermark}[1]{\markboth{#1}{}}
\renewcommand{\sectionmark}[1]{\markright{#1}{}}
\newcommand{\changefont}{%
\fontsize{9}{10}\selectfont
}
\cfoot{}
\fancyfoot[LE,RO]{\changefont{\textsf{\thepage}}}
\fancyfoot[LO,RE]{\changefont{\textsf{\copyright\ 2010--2016, Galois, Inc.}}}
\fancyfoot[LE,RO]{\fancyplain{}{\textsf{\thepage}}}
\fancyfoot[LO,RE]{\fancyplain{}{\textsf{\copyright\ 2010--2016, Galois, Inc.}}}
%% \fancyhead[LE]{\fancyplain{}{\textsf{\draftdate}}}
%% \fancyhead[RO]{\fancyplain{}{\textsf{DO NOT DISTRIBUTE!}}}
\fancyhead[RO,LE]{\fancyplain{}{}} %% outer
@ -124,27 +120,27 @@ without loss of continuity.}\end{minipage}}\end{center}}
\title{\Huge{\bf \titleline}}
\author{\\$ $\\$ $\\
Levent Erk\"{o}k\\
%\url{levent.erkok@galois.com}
\\$ $\\
Galois, Inc.\\
421 SW 6th Ave., Suite 300\\Portland, OR 97204}
\date{
\vspace*{2cm}$ $\\
\includegraphics{utils/galois.jpg}
}
\date{
\vspace*{2cm}$ $\\
\includegraphics{utils/galois.jpg}
}
\pagenumbering{roman}
%% \includepdf[pages={1},scale=1.0]{cover/CryptolSmallCover.pdf}
\includepdf[pages={1},scale=1.0]{cover/ProgrammingCryptolCover.pdf}
%% for full-size papersize:
\includepdf[offset=0 -28]{cover/CryptolCover.pdf}
%\advance\voffset by -26pt
%\setlength{\hoffset}{-26pt}
%% for A5 / half-letter papersize:
% \includepdf[offset=0 -28]{cover/CryptolSmallCover.pdf}
% for bound-books
% \setlength{\oddsidemargin}{36pt}
% \setlength{\evensidemargin}{-36pt}
% \maketitle
%%
\index{inference|see{type, inference}}
\index{signature|see{type, signature}}
\index{polymorphism|see{type, polymorphism}}
@ -165,38 +161,18 @@ without loss of continuity.}\end{minipage}}\end{center}}
\setlength{\headsep}{24pt}
% \layout
\input{title/Title.tex}
\newpage
%%%%%% PREFACE
%\input{preface/Preface.tex}
\input{preface/Notice.tex}
\newpage
%%%%%% TOC
\tableofcontents
% \includepdf[pages={1}]{cover/Blank.pdf}
\vfill
\eject
\listoftodos
\includepdf[pages={1}]{cover/Blank.pdf}
\newpage
%%%%%% Preface
\input{preface/Preface.tex}
\setcounter{page}{1}
\pagenumbering{arabic}
\input{main/todo.tex}
%%%%%% Installation and Tool Use
\input{installation/Install.tex}
\commentout{
\begin{code}
include "../installation/Install.tex";
\end{code}
}
%%%%%% Crash Course
\input{crashCourse/CrashCourse.tex}
\commentout{
@ -205,14 +181,6 @@ include "../crashCourse/CrashCourse.tex";
\end{code}
}
%%%%%% Basic programming (milestone 2.1)
% \input{basic/Basic.tex}
% \commentout{
% \begin{code}
% include "../basic/Basic.tex";
% \end{code}
% }
%%%%%% Transposition ciphers
\input{classic/Classic.tex}
\commentout{
@ -229,7 +197,7 @@ include "../enigma/Enigma.tex";
\end{code}
}
%%%%%% High-assurance
%%%%%% High assurance
\input{highAssurance/HighAssurance.tex}
\commentout{
\begin{code}
@ -237,13 +205,8 @@ include "../highAssurance/HighAssurance.tex";
\end{code}
}
%%%%%% DES (milestone 2.1)
% \input{des/DES.tex}
% \commentout{
% \begin{code}
% include "../des/DES.tex";
% \end{code}
% }
%%%%%% DES
% \chapter{DES: The Data Encryption Standard}
%%%%%% AES
\input{aes/AES.tex}
@ -253,35 +216,23 @@ include "../aes/AES.tex";
\end{code}
}
%%%%%% SHA (milestone 2.1)
% \input{sha/SHA.tex}
% \commentout{
% \begin{code}
% include "../sha/SHA.tex";
% \end{code}
% }
%%%%%% SHA
% \chapter{SHA: The Secure Hash Algorithm}
%%%%%% Advanced Verification Techniques
%\chapter{Advanced proof techniques}
%\section{Assumed equality}
%\section{Uninterpreted functions}
%\section{Proving AES correct}\label{sec:proveaes}
%In Section~\ref{sec:aescorrectattempt}, we wrote down the below
% Cryptol theorem stating that our AES\indAES encryption/decryption
% functions work correctly:
%In Section~\ref{sec:aescorrectattempt}, we wrote down the below Cryptol theorem stating that our AES\indAES encryption/decryption functions work correctly:
%\begin{Verbatim}
% theorem AESCorrect: {msg key}. aesDecrypt (aesEncrypt (msg, key), key) == msg;
%\end{Verbatim}
% However, we were not able to do an automated proof of this fact, as
% it is beyond the scope of what SAT-based equivalence checkers can
% handle. In this section we will use our new tools to attack this
% problem and actually complete the proof in a reasonable amount of
% time.
% However, we were not able to do an automated proof of this fact, as it is beyond the scope of what SAT-based equivalence checkers can handle. In this
% section we will use our new tools to attack this problem and actually complete the proof in a reasonable amount of time.
%%%%%% SAT solving
% \chapter{Using satisfiability solvers: Solving Sudoku and N-Queens
% in Cryptol}\label{chap:usingsat}
% \chapter{Using satisfiability solvers: Solving Sudoku and N-Queens in Cryptol}\label{chap:usingsat}
%%%%%% Hardware
% \chapter{Generating and proving hardware correct}
@ -291,12 +242,10 @@ include "../aes/AES.tex";
% \section{Defaulting}\label{sec:pitfall:defaulting}
% \todo{Talk about defaulting gotchas}
% \section{Evaluation order}\label{sec:pitfall:evorder}
% \todo{Talk about there's no short-circuit except for if-then-else,
% although models might differ.}
% \todo{Talk about there's no short-circuit except for if-then-else, although models might differ.}
% \section{Theorems and safety checking}\label{sec:pitfall:thmexceptions}
% \todo{Talk about safety failures and theorems}
% \todo{Talk about why {\tt implies (x, y) = if x then y else False}
% is not a substitute for {\tt if-then-else}}
% \todo{Talk about why {\tt implies (x, y) = if x then y else False} is not a substitute for {\tt if-then-else}}
% \todo{Talk about assumeSafe}
%%%%%% Toolbox
@ -312,28 +261,19 @@ include "../aes/AES.tex";
% \end{code}
% }
%%%%%% Conclusion (milestone 2.1)
% \input{conclusion/Conclusion.tex}
% \commentout{
% \begin{code}
% include "../conclusion/Conclusion.tex";
% \end{code}
% }
\appendix
% \fancyhead[LO,RE]{\fancyplain{}{\textsf{\nouppercase{\leftmark}}}}
\fancyhead[LO,RE]{\fancyplain{}{}}
%%%% Solutions
\chapter{Solutions to selected exercises}
\label{cha:solut-select-exerc}
As with any language, there are usually multiple ways to write the
same function in Cryptol. We have tried to use the most idiomatic
As with any language, there are usually multiple ways to write the same
function in Cryptol. We have tried to use the most idiomatic
Cryptol code segments in our solutions. Note that Cryptol prints
numbers out in hexadecimal by default. In most of the answers below,
we have implicitly used the command {\tt :set base=10} to print
numbers out in decimal for readability.\indSettingBase \shipoutAnswer
numbers out in hexadecimal by default. In most of the answers below, we
have implicitly used the command {\tt :set base=10} to print numbers
out in decimal for readability.\indSettingBase
\shipoutAnswer
%%%% Cryptol primitives
\input{prims/Primitives.tex}
@ -359,8 +299,10 @@ include "../aes/AESCode.tex";
\end{code}
}
%%%% Grammar
%% TODO: make this not empty
%%%% Language description & REPL commands
\input{technicalities/TechAppendix.tex}
%%%% Syntax (& Grammar someday)
\input{appendices/grammar.tex}
%%%% Glossary

5
docs/ProgrammingCryptol/main/todo.tex
View File

@ -24,6 +24,11 @@
\todo[inline]{Take a final pass to find orphans and widows.}
\todo[inline]{Grammar and syntax summary appendices}
\todo[inline]{Proper definition of where clauses, particulary wrt
inline function declarations.}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "Cryptol"

4
docs/ProgrammingCryptol/misc/Misc.tex
View File

@ -2,8 +2,8 @@
\chapter{Miscellaneous problems}
%=====================================================================
\section{Fun problems}
\label{sec:funproblems}
% \section{Fun problems}
% \label{sec:funproblems}
\sectionWithAnswers{Fun problems}{sec:funproblems}
In this section we present a number of problems for the interested

24
docs/ProgrammingCryptol/prims/Primitives.tex
View File

@ -24,25 +24,25 @@ primsPlaceHolder=1;
% negate : {a b} (a >= 1) => [a]b -> [a]b
\paragraph*{Polynomial arithmetic}
\begin{Verbatim}
pdiv : {a, b} (fin a, fin b) => [a] -> [b] -> [a]
pmod : {a, b} (fin a, fin b) => [a] -> [1 + b] -> [b]
pdiv : {a, b} (fin a, fin b) => [a] -> [b] -> [a]
pmod : {a, b} (fin a, fin b) => [a] -> [1 + b] -> [b]
pmult : {a, b} (fin a, fin b) => [a] -> [b] -> [max 1 (a + b) - 1]
\end{Verbatim}
\paragraph*{Sequences}
\begin{Verbatim}
take : {front, back, elem} (fin front)
=> [front + back]elem -> [front]elem
drop : {front, back, elem} (fin front)
=> [front + back]elem -> [front]elem
tail : {a, b} [a+1]b -> [a]b
# : {a, b, c} (fin a) => ([a]b,[c]b) -> [a+c]b
join : {parts, each, a} (fin each)
=> [parts][each]a -> [parts * each]a
take : {front, back, elem} (fin front)
=> [front + back]elem -> [front]elem
drop : {front, back, elem} (fin front)
=> [front + back]elem -> [front]elem
tail : {a, b} [a+1]b -> [a]b
# : {a, b, c} (fin a) => ([a]b,[c]b) -> [a+c]b
join : {parts, each, a} (fin each)
=> [parts][each]a -> [parts * each]a
split : {parts, each, a} (fin a)
=> [parts * each]a -> [parts][each]a
groupBy : {each, parts, elem} (fin each)
=> [parts * each]elem -> [parts][each]elem
splitBy : {parts, each, elem}
=> [parts * each]elem -> [parts][each]elem
reverse : {a, b} (fin a) => [a]b -> [a]b
@ : {a, b, c} ([a]b,[c]) -> b
! : {a, b, c} (fin a) => ([a]b,[c]) -> b

0
docs/ProgrammingCryptol/installation/Install.tex → docs/ProgrammingCryptol/technicalities/Install.tex
View File

251
docs/ProgrammingCryptol/technicalities/TechAppendix.tex Normal file
View File

@ -0,0 +1,251 @@
%=====================================================================
\chapter{Technicalities}
\label{sec:technicalities}
The summary below describes language
features, as well as commands that are available at the {\tt Cryptol>}
prompt. Commands all begin with the {\tt :} character.
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\section{Language features}
\label{sec:language-features}
The Cryptol language is a size-polymorphic dependently-typed
programming language with support for polymorphic recursive functions.
It has a small syntax tuned for applied cryptography, a lightweight
module system, a pseudo-Real/Eval/Print/Loop (REPL) top-level, and a
rich set of built-in tools for performing high-assurance (literate)
programming. Cryptol performs fairly advanced type inference, though
as with most mainstream strongly typed functional languages, types can
be manually specified as well. What follows is a brief tour of
Cryptol's most salient language features.
\paragraph*{Case sensitivity}
Cryptol identifiers are case sensitive. {\tt A} and {\tt a} are two
different things.\indCaseSensitive
\paragraph*{Indentation and whitespace}
Cryptol uses indentation-level (instead of \{\}'s) to denote blocks.
Whitespace within a line is immaterial, as is the specific amount of
indentation. However, consistent indentation will save you tons of
trouble down the road! Do not mix tabs and spaces for your
indentation. Spaces are generally preferred.
\paragraph*{Escape characters}
Long lines can be continued with the end-of-line escape character
\texttt{$\backslash$}, as in many programming languages.\indLineCont
There are no built-in character escape characters, as Cryptol performs
no interpretation on bytes beyond printing byte streams out in ASCII,
as discussed above.
\paragraph*{Comments}\indComments
Block comments are enclosed in {\tt /*} and {\tt */}, and they can be
nested. Line comments start with {\tt //} and run to the end of the
line.
\paragraph*{Order of definitions}
The order of definitions is immaterial. You can write your definitions
in any order, and earlier entries can refer to latter ones.
\paragraph*{Typing}
Cryptol is strongly typed. This means that the interpreter will catch
most common mistakes in programming during the type-checking phase,
before runtime.
\paragraph*{Type inference}
Cryptol has type inference. This means that the user can omit type
signatures because the inference engine will supply
them.\indTypeInference
\paragraph*{Type signatures}
While writing type signatures are optional, writing them down is
considered good practice.\indSignature
\paragraph*{Polymorphism}
Cryptol functions can be polymorphic, which means they can operate on
many different types. Beware that the type which Cryptol infers might
be too polymorphic, so it is good practice to write your signatures,
or at least check what Cryptol inferred is what you had in
mind.\indPolymorphism\indSignature
\paragraph*{Module system}
Each Cryptol file defines a {\it module}. Modules allow Cryptol
developers to manage which definitions are exported (the default
behavior) and which definitions are internal-only ({\it private}). At
the beginning of each Cryptol file, you specify its name and use {\tt
import}\indImport to specify the modules on which it
relies.\indModuleSystem Definitions are {\tt public} by default, but
you can hide them from modules that import your code via the {\tt
private} keyword at the start of each private definition,\indPrivate
like this:
\begin{Verbatim}
module test where
private
hiddenConst = 0x5 // hidden from importing modules
// end of indented block indicates symbols are available to importing modules
revealedConst = 0x15
\end{Verbatim}
Note that the filename should correspond to the module name, so {\tt
module test} must be defined in a file called {\tt test.cry}.
\todo[inline]{Say what happens if you try to put multiple modules into a
single file.}
\todo[inline]{Check with Trevor about module hierarchy and module visibility;
lambda or default modules; what modules are visible in the top level
- talk about Cryptol prelude here?}
\paragraph*{Literate programming}
You can feed \LaTeX~files to Cryptol (i.e., files with extension {\tt
.tex}). Cryptol will look for \verb|\begin{code}| and
\verb|\end{code}| marks to extract Cryptol code. Everything else
will be comments as far as Cryptol is concerned. In fact, the book
you are reading is a Literate Cryptol program.\indLiterateProgramming
\todo[inline]{Discuss Cryptol support for literate Markdown. Use ticks to
delimit code blocks in Markdown layout. Talk with Trevor.}
\paragraph*{Completion}
On UNIX-based machines, you can press tab at any time and Cryptol will
suggests completions based on the context. You can retrieve your
prior commands using the usual means (arrow keys or Emacs
keybindings).\indCompletion
\todo[inline]{Ask Adam F about the best way to describe what can be tab-completed.}
\todo[inline]{Is readline on windows still broken / worse than Unix?}
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\section{Commands}
\label{sec:commands}
\paragraph*{Querying types}
You can ask Cryptol to tell you the type of an expression by typing
{\tt :type <expr>} (or {\tt :t} for short). If {\tt foo} is the name
of a definition (function or otherwise), you can ask its type by
issuing {\tt :type foo}.\indCmdType It is common practice to define a
function, ask Cryptol its type, and copy the response back to your
source code. While this is somewhat contrived, it is usually better
than not writing signatures at all.\indSignature In order to query the
type of an infix operator (e.g., {\tt +}, {\tt ==}, etc.) you will need
to surround the operator with {\tt ()}'s, like this:
\begin{Verbatim}
Cryptol> :t (+)
+ : {a} (Arith a) => a -> a -> a
\end{Verbatim}
\paragraph*{Browsing definitions}
The command {\tt :browse} (or {\tt :b} for short) will display all the
names you have defined, along with their types.\indCmdBrowse
\paragraph*{Getting help}
The command {\tt :help} will show you all the available
commands.\indCmdHelp Other useful implicit help invocations are:
(a)~to type tab at the {\tt Cryptol>} prompt, which will list all of
the operators available in Cryptol code, (b)~typing {\tt :set} with no
argument, which shows you the parameters that can be set, and (c), as
noted elsewhere, {\tt :browse} to see the names of functions and type
aliases you have defined, along with their types.
\todo[inline]{What should \texttt{:help symbolname} do, especially for
prelude functions and types? How about for commands?}
\begin{center}
\begin{tabular*}{0.75\textwidth}[h]{c|c|l}
\hline
\textbf{Option} & \textbf{Default value} & \textbf{Meaning} \\
\hline
\texttt{ascii} & \texttt{off} & print sequences of bytes as a string \\
\texttt{base} & \texttt{10} & numeric base for printing words \\
\texttt{debug} & \texttt{off} & whether to print verbose debugging information \\
\texttt{infLength} & \texttt{5} & number of elements to show from an infinite sequence \\
\texttt{prover} & \texttt{z3} & which SMT solver to use for \texttt{:prove} \\
\texttt{tests} & \texttt{100} & number of tests to run for \texttt{:check} \\
\texttt{warnDefaulting} & \texttt{on} & \todo[inline]{talk to Iavor} \\
\hline
\end{tabular*}
\label{tab:set_options}
\end{center}
\paragraph*{Environment options}
A variety of environment options are set through the use of the
\texttt{:set} command. These options may change over time and some
options may be available only on specific platforms. The current
options are summarized in~\autoref{tab:set_options}.
\todo[inline]{Ensure index references exist for all commands.}
\paragraph*{Quitting}
You can quit Cryptol by using the command {\tt :quit} (aka
\texttt{:q}). On Mac/Linux you can press Ctrl-D, and on Windows use
Ctrl-Z, for the same effect.\indCmdQuit
\paragraph*{Loading and reloading files}
You load your program in Cryptol using {\tt :load <filename>} (or
\texttt{:l} for short). However, it is customary to use the extension
{\tt .cry} for Cryptol programs.\indCmdLoad If you edit the source
file loaded into Cryptol from a separate context, you can reload it
into Cryptol using the command {\tt :reload} (abbreviated {\tt
:r}).\indCmdReload
\paragraph*{Invoking your editor}
You can invoke your editor using the command {\tt :edit} (abbreviated
\texttt{:e}).\indCmdEdit The default editor invoked is
\texttt{vi}. You override the default using the standard
\texttt{EDITOR} environmental variable in your shell.\indSettingEditor
\todo[inline]{I have filed a feature enhancement for missing \texttt{editor}
environment variable as
\href{https://www.galois.com/cryptol/ticket/273}{ticket \#273}.
We want to write: ``You set your favorite editor by :set
editor=/path/to/editor.''}
\paragraph*{Running shell commands}
You can run Unix shell commands from within Cryptol like this: {\tt :!
cat test.cry}.\indCmdShell
\paragraph*{Changing working directory}
You can change the current working directory of Cryptol like this:
\texttt{:cd some/path}. Note that the path syntax is
platform-dependent.
% indeed it is, but both \'s and /'s are supported on windows.
% currently directories with spaces break things...issue 291 has been filed
% dylan - 2014-03-27
\paragraph*{Loading a module}
At the Cryptol prompt you can load a module by name with the {\tt
:module} command.\indCmdLoadModule
The next three commands all operate on \emph{properties}. All take
either one or zero arguments. If one argument is provided, then that
property is the focus of the command; otherwise all properties in the
current context are checked. All three commands are covered in detail
in~\autoref{cha:high-assur-progr}.
\paragraph*{Checking a property through random testing}
The \texttt{:check} command performs random value testing on a
property to increase one's confidence that the property is valid.
See~\autoref{sec:quickcheck} for more detailed information.
\paragraph*{Verifying a property through automated theorem proving}
The \texttt{:prove} command uses an external SMT solver to attempt to
automatically formally prove that a given property is valid.
See~\autoref{sec:formal-proofs} for more detailed information.
\paragraph*{Finding a satisfying assignment for a property}
The \texttt{:sat} command uses an external SAT solver to attempt to
find a satisfying assignment to a property. See~\autoref{sec:sat} for
more detailed information.
\paragraph*{Type specialization}
Discuss \texttt{:debug\_specialize}. \todo[inline]{Dylan?}
%=====================================================================
%\section{Using Cryptol: The Big Picture}
%\label{sec:using-cryptol}
\todo[inline]{2.1: Add some big picture on process and use of the tools.
Put it on the website now and then migrate it to the book later.}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "../main/Cryptol"
%%% End:

1
docs/ProgrammingCryptol/utils/Indexes.tex
View File

@ -126,7 +126,6 @@
\newcommand{\indDrop}{\index{drop@\texttt{drop}}\xspace}
\newcommand{\indJoin}{\index{join@\texttt{join}}\xspace}
\newcommand{\indSplit}{\index{split@\texttt{split}}\xspace}
\newcommand{\indSplitBy}{\index{splitBy@\texttt{splitBy}}\xspace}
\newcommand{\indGroup}{\index{group@\texttt{group}}\xspace}
\newcommand{\indTranspose}{\index{transpose@\texttt{transpose}}\xspace}
\newcommand{\indTupleProj}{\index{project@\texttt{project}}\xspace}

4
docs/Syntax.md
View File

@ -222,7 +222,7 @@ Explicit record selectors may be used only if the program contains
sufficient type information to determine the shape of the tuple or
record. For example:
type T = { sign :: Bit, number :: [15] }
type T = { sign : Bit, number : [15] }
// Valid definition:
// the type of the record is known.
@ -326,7 +326,7 @@ Here `t` should be a type expression with numeric kind. The resulting
expression is a finite word, which is sufficiently large to accommodate
the value of the type:
`{t} :: {w >= width t}. [w]
`{t} : {w >= width t}. [w]
Explicit Type Annotations
=========================

BIN
docs/Syntax.pdf
View File

Binary file not shown.

12
docs/Version2Changes.md
View File

@ -97,7 +97,8 @@ modules like this:
anotherInternalConstant = 0x66
externalConstant=0x77
Whenever names might be ambiguous, they can be disambiguated with the `::` syntax (using a qualified import using "as"):
Whenever names might be ambiguous, they can be disambiguated with the
`::` syntax (using a qualified import using "as"):
import ExternalModule as eModule
...
@ -172,6 +173,13 @@ This can help break the Catch-22 situation that sometimes arises when you're
writing a function that needs access to type variables, but you're not yet sure
about the whole function's type signature.
Type Aliases
------------
Type aliases are only permitted to be defined on curried primitive
types in Cryptol version 2. In Cryptol version 1, for example, tuples
were permitted in type declaration contexts.
Type Classes
------------
@ -286,3 +294,5 @@ within version 1 lets you use the `:prove` and `:check` operations to verify
the correctness of your logic, then it becomes a simple syntax modernization
task. Doing both at once has proven to be very difficult, and leaves you
without tool support.
% creation of function bindings in where clauses

BIN
docs/Version2Changes.pdf
View File

Binary file not shown.

114
examples/ChaChaPolyCryptolIETF.md
View File

@ -1,4 +1,4 @@
% ChaCha20 and Poly1305 for IETF protocols
% ChaCha20 and Poly1305 for IETF protocols
% Y. Nir (Check Point), A. Langley (Google Inc), D. McNamee (Galois, Inc)
% July 28, 2014
@ -178,7 +178,7 @@ leaving the others alone:
```
Note that this run of quarter round is part of what is called a
"column round".
"column round".
### Test Vector for the Quarter Round on the ChaCha state
@ -208,8 +208,8 @@ After applying QUARTERROUND(2,7,8,13)
Note that only the numbers in positions 2, 7, 8, and 13 changed.
In the Cryptol implementation of ChaCha20, the ChaChaQuarterround is called on four elements at a time,
and there is no destructive state modification, so it would be artificial to reproduce the
In the Cryptol implementation of ChaCha20, the ChaChaQuarterround is called on four elements at a time,
and there is no destructive state modification, so it would be artificial to reproduce the
above example of the partially-destructively modified matrix. Instead, we show the output of
calling ChaChaQuarterround on the diagonal elements identified above:
@ -726,7 +726,7 @@ Next, divide the message into 16-byte blocks. The last block might be shorter:
* Add the current block to the accumulator.
* Multiply by "r"
* Set the accumulator to the result modulo p. To summarize:
* Set the accumulator to the result modulo p. To summarize:
``accum[i+1] = ((accum[i]+block)*r) % p``.
```cryptol
@ -773,7 +773,7 @@ using AES, and assume that we got the following keying material:
03:80:8a:fb:0d:b2:fd:4a:bf:f6:af:41:49:f5:1b
```cryptol
Poly1305TestKey = join (parseHexString
Poly1305TestKey = join (parseHexString
( "85:d6:be:78:57:55:6d:33:7f:44:52:fe:42:d5:06:a8:01:"
# "03:80:8a:fb:0d:b2:fd:4a:bf:f6:af:41:49:f5:1b."
) )
@ -808,7 +808,7 @@ values of the accumulator:
```cryptol
// TODO: refactor the Poly function in terms of this AccumBlocks
// challenge: doing so while maintaining the clean literate correspondence with the spec
AccumBlocks : {m, floorBlocks, rem} (fin m, floorBlocks == m/16, rem == m - floorBlocks*16)
AccumBlocks : {m, floorBlocks, rem} (fin m, floorBlocks == m/16, rem == m - floorBlocks*16)
=> [256] -> [m][8] -> ([_][136], [136])
AccumBlocks key msg = (accum, lastAccum) where
@ -864,7 +864,7 @@ Acc + block = 2d8adaf23b0337fa7cccfb4ea344ca153
```
```cryptol
property polyBlocksOK =
property polyBlocksOK =
(blocks @ 1 == 0x02c88c77849d64ae9147ddeb88e69c83fc) &&
(blocks @ 2 == 0x02d8adaf23b0337fa7cccfb4ea344b30de) &&
(lastBlock == 0x028d31b7caff946c77c8844335369d03a7) where
@ -876,7 +876,7 @@ Adding s we get this number, and serialize if to get the tag:
Acc + s = 2a927010caf8b2bc2c6365130c11d06a8
Tag: a8:06:1d:c1:30:51:36:c6:c2:2b:8b:af:0c:01:27:a9
```cryptol
// Putting it all together and testing:
@ -904,7 +904,7 @@ SK_a* or *_write_MAC_key is only for stand-alone Poly1305.
The method is to call the block function with the following
parameters:
* The 256-bit session integrity key is used as the ChaCha20 key.
* The block counter is set to zero.
* The protocol will specify a 96-bit or 64-bit nonce. This MUST be
@ -929,7 +929,7 @@ encryption algorithms (often called Initialization Vectors, or IVs),
they usually don't have such a provision for the MAC function. In
that case the per-invocation nonce will have to come from somewhere
else, such as a message counter.
### Poly1305 Key Generation Test Vector
For this example, we'll set:
@ -966,7 +966,7 @@ PolyChaChaState_testVector = [
0x37b633a8, 0xa50dfde3, 0xe2b8db08, 0x46a6d1fd,
0x7da03782, 0x9183a233, 0x148ad271, 0xb46773d1,
0x3cc1875a, 0x8607def1, 0xca5c3086, 0x7085eb87 ]
property PolyChaCha_correct = ChaCha20Block PolyKeyTest PolyNonceTest 0 ==
PolyChaChaState_testVector
```
@ -978,7 +978,7 @@ PolyOutput = join (parseHexString (
"8a d5 a0 8b 90 5f 81 cc 81 50 40 27 4a b2 94 71 " #
"a8 33 b6 37 e3 fd 0d a5 08 db b8 e2 fd d1 a6 46 "))
GeneratePolyKeyUsingChaCha k n i = join [littleendian (groupBy`{8}b)
GeneratePolyKeyUsingChaCha k n i = join [littleendian (groupBy`{8}b)
| b <- take `{8}(ChaCha20Block k n i) ]
property Poly_passes_test = GeneratePolyKeyUsingChaCha PolyKeyTest PolyNonceTest 0 == PolyOutput
@ -1048,7 +1048,7 @@ takes a 256-bit key and 96-bit nonce as follows:
counter set to 1.
```cryptol
ct = ChaCha20EncryptBytes p k nonce 1
ct = ChaCha20EncryptBytes p k nonce 1
```
* Finally, the Poly1305 function is called with the Poly1305 key
@ -1071,12 +1071,12 @@ takes a 256-bit key and 96-bit nonce as follows:
```cryptol
ptlen : [8][8]
ptlen = groupBy`{8}(littleendian (groupBy`{8}(`m:[64])))
ptlen = groupBy`{8}(littleendian (groupBy`{8}(`m:[64])))
adlen : [8][8]
adlen = groupBy`{8}(littleendian (groupBy`{8}(`n:[64])))
// compute padding
tag = Poly1305 PolyKey (AeadConstruction aad ct)
//ct in this function has tag removed
AeadConstruction (AAD : [n][8]) (CT : [m][8]) = (AAD # padding1 # CT # padding2 # adlen # ptlen) where
padding1 = (zero:[(16-n%16)%16][8])
@ -1100,7 +1100,7 @@ AEAD_CHACHA20_POLY1305_DECRYPT : {m, n} (fin m, fin n
,64 >= width m, 64 >= width n)
=> [256] -> [96]
-> [m+16][8] -> [n][8]
-> ([m][8], Bit)
-> ([m][8], Bit)
AEAD_CHACHA20_POLY1305_DECRYPT k nonce ct ad = (pt, valid) where
inTag = drop`{m}ct
inCt = take`{m}ct
@ -1185,7 +1185,7 @@ AeadPolyOneTimeKey_testVector = [
0x93929190, 0x97969594, 0x9b9a9998, 0x9f9e9d9c,
0x00000000, 0x00000007, 0x43424140, 0x47464544 ]
property AeadPolyKeyBuildState_correct =
property AeadPolyKeyBuildState_correct =
BuildState AeadKey AeadNonce 0 == AeadPolyOneTimeKey_testVector
```
@ -1198,7 +1198,7 @@ AeadPolyOneTimeKeyState = [
0xdecc7ea2, 0xb44ddbad, 0xe49c17d1, 0xd8430bc9,
0x8c94b7bc, 0x8b7d4b4b, 0x3927f67d, 0x1669a432]
property AeadPolyChaCha_correct =
property AeadPolyChaCha_correct =
ChaCha20Block AeadKey AeadNonce 0 == AeadPolyOneTimeKeyState
```
@ -1262,7 +1262,7 @@ AeadTagTestVector = parseHexString "1a:e1:0b:59:4f:09:e2:6a:7e:90:2e:cb:d0:60:06
```
```cryptol
property AeadTag_correct = AeadTag == AeadTagTestVector
property AeadTag_correct = AeadTag == AeadTagTestVector
property AeadConstruction_correct = (AeadConstruction AeadAAD AeadCT) == AeadConstructionTestVector
@ -1458,12 +1458,12 @@ Email: dylan@galois.com
```cryptol
// helper macros for higher-up properties
TV_block_correct key nonce blockcounter result = ChaCha20Block key nonce blockcounter == result
TV_block_Keystream_correct key nonce blockcounter keystream =
take`{0x40} (groupBy`{8} (join (join (ChaCha20ExpandKey key nonce blockcounter)))) == keystream
ChaCha20_block_correct key nonce blockcounter result keystream =
TV_block_correct key nonce blockcounter result &&
ChaCha20_block_correct key nonce blockcounter result keystream =
TV_block_correct key nonce blockcounter result &&
TV_block_Keystream_correct key nonce blockcounter keystream
```
@ -1489,7 +1489,7 @@ TV1_block_KeyStream = [
property TV1_block_correct = ChaCha20_block_correct TV1_block_Key TV1_block_Nonce TV1_block_BlockCounter TV1_block_After20 TV1_block_KeyStream
```
### Test Vector #2
```cryptol
@ -1511,7 +1511,7 @@ TV2_block_KeyStream = [
property TV2_block_correct = ChaCha20_block_correct TV2_block_Key TV2_block_Nonce TV2_block_BlockCounter TV2_block_After20 TV2_block_KeyStream
```
### Test Vector #3
@ -1526,11 +1526,11 @@ TV3_block_After20 = [
0xe8252083, 0x60818b01, 0xf38422b8, 0x5aaa49c9,
0xbb00ca8e, 0xda3ba7b4, 0xc4b592d1, 0xfdf2732f,
0x4436274e, 0x2561b3c8, 0xebdd4aa6, 0xa0136c00]
TV3_block_KeyStream = [
0x3a, 0xeb, 0x52, 0x24, 0xec, 0xf8, 0x49, 0x92, 0x9b, 0x9d, 0x82, 0x8d, 0xb1, 0xce, 0xd4, 0xdd,
0x83, 0x20, 0x25, 0xe8, 0x01, 0x8b, 0x81, 0x60, 0xb8, 0x22, 0x84, 0xf3, 0xc9, 0x49, 0xaa, 0x5a,
0x8e, 0xca, 0x00, 0xbb, 0xb4, 0xa7, 0x3b, 0xda, 0xd1, 0x92, 0xb5, 0xc4, 0x2f, 0x73, 0xf2, 0xfd,
0x3a, 0xeb, 0x52, 0x24, 0xec, 0xf8, 0x49, 0x92, 0x9b, 0x9d, 0x82, 0x8d, 0xb1, 0xce, 0xd4, 0xdd,
0x83, 0x20, 0x25, 0xe8, 0x01, 0x8b, 0x81, 0x60, 0xb8, 0x22, 0x84, 0xf3, 0xc9, 0x49, 0xaa, 0x5a,
0x8e, 0xca, 0x00, 0xbb, 0xb4, 0xa7, 0x3b, 0xda, 0xd1, 0x92, 0xb5, 0xc4, 0x2f, 0x73, 0xf2, 0xfd,
0x4e, 0x27, 0x36, 0x44, 0xc8, 0xb3, 0x61, 0x25, 0xa6, 0x4a, 0xdd, 0xeb, 0x00, 0x6c, 0x13, 0xa0]
property TV3_block_correct = ChaCha20_block_correct TV3_block_Key TV3_block_Nonce TV3_block_BlockCounter TV3_block_After20 TV3_block_KeyStream
@ -1549,11 +1549,11 @@ TV4_block_After20 = [
0xa78dea8f, 0x5e269039, 0xa1bebbc1, 0xcaf09aae,
0xa25ab213, 0x48a6b46c, 0x1b9d9bcb, 0x092c5be6,
0x546ca624, 0x1bec45d5, 0x87f47473, 0x96f0992e]
TV4_block_KeyStream = [
0x72, 0xd5, 0x4d, 0xfb, 0xf1, 0x2e, 0xc4, 0x4b, 0x36, 0x26, 0x92, 0xdf, 0x94, 0x13, 0x7f, 0x32,
0x8f, 0xea, 0x8d, 0xa7, 0x39, 0x90, 0x26, 0x5e, 0xc1, 0xbb, 0xbe, 0xa1, 0xae, 0x9a, 0xf0, 0xca,
0x13, 0xb2, 0x5a, 0xa2, 0x6c, 0xb4, 0xa6, 0x48, 0xcb, 0x9b, 0x9d, 0x1b, 0xe6, 0x5b, 0x2c, 0x09,
0x72, 0xd5, 0x4d, 0xfb, 0xf1, 0x2e, 0xc4, 0x4b, 0x36, 0x26, 0x92, 0xdf, 0x94, 0x13, 0x7f, 0x32,
0x8f, 0xea, 0x8d, 0xa7, 0x39, 0x90, 0x26, 0x5e, 0xc1, 0xbb, 0xbe, 0xa1, 0xae, 0x9a, 0xf0, 0xca,
0x13, 0xb2, 0x5a, 0xa2, 0x6c, 0xb4, 0xa6, 0x48, 0xcb, 0x9b, 0x9d, 0x1b, 0xe6, 0x5b, 0x2c, 0x09,
0x24, 0xa6, 0x6c, 0x54, 0xd5, 0x45, 0xec, 0x1b, 0x73, 0x74, 0xf4, 0x87, 0x2e, 0x99, 0xf0, 0x96]
property TV4_block_correct = ChaCha20_block_correct TV4_block_Key TV4_block_Nonce TV4_block_BlockCounter TV4_block_After20 TV4_block_KeyStream
@ -1572,7 +1572,7 @@ TV5_block_After20 = [
0x88228b1a, 0x96a4dfb3, 0x5b76ab72, 0xc727ee54,
0x0e0e978a, 0xf3145c95, 0x1b748ea8, 0xf786c297,
0x99c28f5f, 0x628314e8, 0x398a19fa, 0x6ded1b53]
TV5_block_KeyStream = [
0xc2, 0xc6, 0x4d, 0x37, 0x8c, 0xd5, 0x36, 0x37, 0x4a, 0xe2, 0x04, 0xb9, 0xef, 0x93, 0x3f, 0xcd,
0x1a, 0x8b, 0x22, 0x88, 0xb3, 0xdf, 0xa4, 0x96, 0x72, 0xab, 0x76, 0x5b, 0x54, 0xee, 0x27, 0xc7,
@ -1586,8 +1586,8 @@ property all_block_tests_correct =
TV2_block_correct &&
TV3_block_correct &&
TV4_block_correct &&
TV5_block_correct
TV5_block_correct
```
## ChaCha20 Encryption
@ -1610,7 +1610,7 @@ TV1_enc_cyphertext = [
0xbd, 0xd2, 0x19, 0xb8, 0xa0, 0x8d, 0xed, 0x1a, 0xa8, 0x36, 0xef, 0xcc, 0x8b, 0x77, 0x0d, 0xc7,
0xda, 0x41, 0x59, 0x7c, 0x51, 0x57, 0x48, 0x8d, 0x77, 0x24, 0xe0, 0x3f, 0xb8, 0xd8, 0x4a, 0x37,
0x6a, 0x43, 0xb8, 0xf4, 0x15, 0x18, 0xa1, 0x1c, 0xc3, 0x87, 0xb6, 0x69, 0xb2, 0xee, 0x65, 0x86]
property TV1_enc_correct = ChaCha20_enc_correct TV1_enc_Key TV1_enc_Nonce TV1_enc_BlockCounter TV1_enc_plaintext TV1_enc_cyphertext
```
@ -1647,7 +1647,7 @@ IETF_submission_text = [
0x79, 0x20, 0x74, 0x69, 0x6d, 0x65, 0x20, 0x6f, 0x72, 0x20, 0x70, 0x6c, 0x61, 0x63, 0x65, 0x2c,
0x20, 0x77, 0x68, 0x69, 0x63, 0x68, 0x20, 0x61, 0x72, 0x65, 0x20, 0x61, 0x64, 0x64, 0x72, 0x65,
0x73, 0x73, 0x65, 0x64, 0x20, 0x74, 0x6f ]
TV2_enc_plaintext = IETF_submission_text
@ -1676,7 +1676,7 @@ TV2_enc_cyphertext = [
0x14, 0xea, 0x99, 0x82, 0xcc, 0xaf, 0xb3, 0x41, 0xb2, 0x38, 0x4d, 0xd9, 0x02, 0xf3, 0xd1, 0xab,
0x7a, 0xc6, 0x1d, 0xd2, 0x9c, 0x6f, 0x21, 0xba, 0x5b, 0x86, 0x2f, 0x37, 0x30, 0xe3, 0x7c, 0xfd,
0xc4, 0xfd, 0x80, 0x6c, 0x22, 0xf2, 0x21]
property TV2_enc_correct = ChaCha20_enc_correct TV2_enc_Key TV2_enc_Nonce TV2_enc_BlockCounter TV2_enc_plaintext TV2_enc_cyphertext
```
@ -1699,7 +1699,7 @@ jabberwock_text = [
0x65, 0x72, 0x65, 0x20, 0x74, 0x68, 0x65, 0x20, 0x62, 0x6f, 0x72, 0x6f, 0x67, 0x6f, 0x76, 0x65,
0x73, 0x2c, 0x0a, 0x41, 0x6e, 0x64, 0x20, 0x74, 0x68, 0x65, 0x20, 0x6d, 0x6f, 0x6d, 0x65, 0x20,
0x72, 0x61, 0x74, 0x68, 0x73, 0x20, 0x6f, 0x75, 0x74, 0x67, 0x72, 0x61, 0x62, 0x65, 0x2e]
TV3_enc_plaintext = jabberwock_text
@ -1712,13 +1712,13 @@ TV3_enc_cyphertext = [
0x1a, 0x55, 0x32, 0x05, 0x57, 0x16, 0xea, 0xd6, 0x96, 0x25, 0x68, 0xf8, 0x7d, 0x3f, 0x3f, 0x77,
0x04, 0xc6, 0xa8, 0xd1, 0xbc, 0xd1, 0xbf, 0x4d, 0x50, 0xd6, 0x15, 0x4b, 0x6d, 0xa7, 0x31, 0xb1,
0x87, 0xb5, 0x8d, 0xfd, 0x72, 0x8a, 0xfa, 0x36, 0x75, 0x7a, 0x79, 0x7a, 0xc1, 0x88, 0xd1]
property TV3_enc_correct = ChaCha20_enc_correct TV3_enc_Key TV3_enc_Nonce TV3_enc_BlockCounter TV3_enc_plaintext TV3_enc_cyphertext
property all_enc_tests_correct =
TV1_enc_correct &&
TV2_enc_correct &&
TV3_enc_correct
TV3_enc_correct
```
## Poly1305 Message Authentication Code
@ -1857,7 +1857,7 @@ exactly 2^130-6?
TV9_MAC_Key = 0x02 # zero:[256]
TV9_MAC_text =
TV9_MAC_text =
[0xFD, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF]
TV9_MAC_tag = [0xFA, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF]: [16][8]
@ -1898,7 +1898,7 @@ TV11_MAC_text = [
0xE3, 0x35, 0x94, 0xD7, 0x50, 0x5E, 0x43, 0xB9, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x33, 0x94, 0xD7, 0x50, 0x5E, 0x43, 0x79, 0xCD, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]
TV11_MAC_tag = split(0x13 # 0): [16][8]
property TV11_MAC_correct = poly1305_MAC_correct TV11_MAC_Key TV11_MAC_text TV11_MAC_tag
@ -1914,7 +1914,7 @@ property all_MAC_tests_correct =
TV8_MAC_correct &&
TV9_MAC_correct &&
TV10_MAC_correct &&
TV11_MAC_correct
TV11_MAC_correct
```
@ -1967,7 +1967,7 @@ property TV3_key_correct = Poly1305_key_correct TV3_key_Key TV3_key_Nonce TV3_ke
property all_key_tests_correct =
TV1_key_correct &&
TV2_key_correct &&
TV3_key_correct
TV3_key_correct
```
## ChaCha20-Poly1305 AEAD Decryption
@ -2004,7 +2004,7 @@ TV1_AEAD_known_otk = join([
//sent
TV1_AEAD_tag = [0xee, 0xad, 0x9d, 0x67, 0x89, 0x0c, 0xbb, 0x22, 0x39, 0x23, 0x36, 0xfe, 0xa1, 0x85, 0x1f, 0x38]
TV1_AEAD_cypherText = [
0x64, 0xa0, 0x86, 0x15, 0x75, 0x86, 0x1a, 0xf4, 0x60, 0xf0, 0x62, 0xc7, 0x9b, 0xe6, 0x43, 0xbd,
0x5e, 0x80, 0x5c, 0xfd, 0x34, 0x5c, 0xf3, 0x89, 0xf1, 0x08, 0x67, 0x0a, 0xc7, 0x6c, 0x8c, 0xb2,
@ -2049,7 +2049,7 @@ TV1_AEAD_Poly_input = [
First, we calculate the one-time Poly1305 key
```cryptol
//generate and check the one time key (leaving out the given states from the document, they will be correct if this is correct)
property TV1_otk_correct = Poly1305_key_correct TV1_AEAD_key TV1_AEAD_nonce TV1_AEAD_known_otk
@ -2069,7 +2069,7 @@ We calculate the Poly1305 tag and find that it matches
```cryptol
property TV1_tag_correct = poly1305_MAC_correct TV1_AEAD_known_otk (AeadConstruction TV1_AEAD_AAD TV1_AEAD_cypherText) TV1_AEAD_tag
```
```cryptol
TV1_plaintext = [
0x49, 0x6e, 0x74, 0x65, 0x72, 0x6e, 0x65, 0x74, 0x2d, 0x44, 0x72, 0x61, 0x66, 0x74, 0x73, 0x20,
@ -2089,14 +2089,14 @@ TV1_plaintext = [
0x6d, 0x20, 0x6f, 0x74, 0x68, 0x65, 0x72, 0x20, 0x74, 0x68, 0x61, 0x6e, 0x20, 0x61, 0x73, 0x20,
0x2f, 0xe2, 0x80, 0x9c, 0x77, 0x6f, 0x72, 0x6b, 0x20, 0x69, 0x6e, 0x20, 0x70, 0x72, 0x6f, 0x67,
0x72, 0x65, 0x73, 0x73, 0x2e, 0x2f, 0xe2, 0x80, 0x9d]
TV1_calculate_plaintext = AEAD_CHACHA20_POLY1305_DECRYPT TV1_AEAD_key TV1_AEAD_nonce (TV1_AEAD_cypherText # TV1_AEAD_tag) TV1_AEAD_AAD
property TV1_plaintext_correct = isValid && pt == TV1_plaintext where
(pt,isValid) = TV1_calculate_plaintext
property decryption_vector_correct =
property decryption_vector_correct =
TV1_plaintext_correct &&
TV1_tag_correct &&
TV1_otk_correct
@ -2146,7 +2146,7 @@ property parseHexString_check =
"14:15:16:17:18:19:1a:1b:1c:1d:1e:1f.")) ==
0x000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f
property AllPropertiesPass =
property AllPropertiesPass =
ChaChaQuarterround_passes_test &&
ChaChaQuarterround_passes_column_test &&
FirstRow_correct &&
@ -2182,7 +2182,7 @@ by loading it into a Cryptol interpreter, and running the AllPropertiesPass
function, like this:
```example
$ cryptol ChaChaPolyCryptolIETF.md
$ cryptol ChaChaPolyCryptolIETF.md
_ _
___ _ __ _ _ _ __ | |_ ___ | |
/ __| '__| | | | '_ \| __/ _ \| |
@ -2193,10 +2193,8 @@ $ cryptol ChaChaPolyCryptolIETF.md
Loading module Cryptol
Loading module ChaCha20
... a bunch of warnings about the use of ambiguous-width constants
ChaCha20> AllPropertiesPass
ChaCha20> AllPropertiesPass
True
```
This check verifies the implementation of `ChaCha`, `Poly1305` and the `AEAD`
construction all work with the provided test vectors.

5
examples/DES.cry
View File

@ -9,12 +9,12 @@ import Cipher
// DES API
DES : Cipher 64 64
DES =
DES =
{ encrypt key pt = des pt (expandKey key)
, decrypt key ct = des ct (reverse (expandKey key))
}
// Encryption
// Encryption
des pt keys = (swap (split last)) @@ FPz
where
@ -169,4 +169,3 @@ sbox8 = [[13, 2, 8, 4, 6, 15, 11, 1, 10, 9, 3, 14, 5, 0, 12, 7],
[7, 11, 4, 1, 9, 12, 14, 2, 0, 6, 10, 13, 15, 3, 5, 8],
[2, 1, 14, 7, 4, 10, 8, 13, 15, 12, 9, 0, 3, 5, 6, 11]
]

2
examples/MiniLock/prim/Base58.cry
View File

@ -4,6 +4,8 @@
*/
module Base58 where
import Cryptol::Extras
// Base 58 is a dependent format - the length of the encoded value depends on
// the value being encoded This does not play well with Cryptol, which expects
// a static type. Thus we must consume the worst-case number of bytes and

4
examples/MiniLock/prim/Base64.cry
View File

@ -4,7 +4,9 @@
*/
module Base64 where
type Enc64 n = 4*(((3-(n%3))%3) + n)/3
import Cryptol::Extras
type Enc64 n = 4*(((3-(n%3))%3) + n)/3
base64enc : {n,m,padZ} (4*(padZ + n)/3 == m, fin n, fin m, padZ == (3-(n%3))%3, 2>=padZ)
=> [n][8] -> [Enc64 n][8]

5
examples/MiniLock/prim/Blake2s.cry
View File

@ -4,6 +4,8 @@
*/
module Blake2s where
import Cryptol::Extras
type Block = [16][32]
type State = [8][32]
type LocalState = [16][32]
@ -160,7 +162,7 @@ updateVector orig idxNew = vs
vs = [if i == idx then new else orig@i | i <- [0..a-1]]
property katsPass = ~zero ==
property katsPass = ~zero ==
[ nthKat `{0}
, nthKat `{1}
, nthKat `{2}
@ -683,4 +685,3 @@ kats = [ 0x69217a3079908094e11121d042354a7c1f55b6482ca1a51e1b250dfd1ed0eef9
, 0xc08aa1c286d709fdc7473744977188c895ba011014247e4efa8d07e78fec695c
, 0xf03f5789d3336b80d002d59fdf918bdb775b00956ed5528e86aa994acb38fe2d
]

15
examples/MiniLock/prim/HMAC.cry
View File

@ -10,14 +10,6 @@ hmacSHA256 : {pwBytes, msgBytes}
(fin pwBytes, fin msgBytes
, 32 >= width msgBytes
, 64 >= width (8*pwBytes)
, 64 >= width (8 * (64 + msgBytes))
// Keeping cryptol <2.3 happy
, max 6 (width pwBytes) >= 6
, max 6 (width pwBytes) >= width pwBytes
, max 7 (width pwBytes) >= 7
, max 7 (width pwBytes) >= width pwBytes
, max (width pwBytes) 7 >= 7
, max (width pwBytes) 7 >= width pwBytes
) => [pwBytes][8] -> [msgBytes][8] -> [256]
hmacSHA256 = hmac `{blockLength=64} SHA256 SHA256 SHA256
@ -26,13 +18,6 @@ hmacSHA256 = hmac `{blockLength=64} SHA256 SHA256 SHA256
// separate length inputs.
hmac : { msgBytes, pwBytes, digest, blockLength }
( fin pwBytes, fin digest, fin blockLength
// Keeping cryptol <2.3 happy
, max (width digest) (width pwBytes) >= width pwBytes // XXX cryptol! width digest == width pwBytes
, max (width digest) (width pwBytes) >= width digest
, max (width blockLength) (width pwBytes) >= width blockLength
, max (width blockLength) (width pwBytes) >= width pwBytes
, max (width pwBytes) (width blockLength) >= width blockLength
, max (width pwBytes) (width blockLength) >= width pwBytes
)
=> ([blockLength + msgBytes][8] -> [8*digest])
-> ([blockLength + digest][8] -> [8*digest])

49
examples/MiniLock/prim/PBKDF2.cry
View File

@ -8,23 +8,13 @@ import SHA256
import HMAC
// PBKDF2 specialized to HMAC_SHA256 to avoid monomorphic type issues.
pbkdf2 : {pwBytes, saltBytes, dkLenBits, len, C}
( 32 >= width (pwBytes*8), len == (dkLenBits + 255)/256
, len >= 1, 32 >= width len, fin saltBytes, fin dkLenBits, fin pwBytes
, 64 >= width (8 * (pwBytes + (4 + saltBytes)))
, 64 >= width (8 * (pwBytes + 32))
, C >= 1, fin C, 64 >= width (8*(pwBytes + (2 + saltBytes))), 16 >= width C
, 16 >= width len
// cryptol < 2.3 can't math!
, dkLenBits == 256 * len // Cryptol 2.3 doesn't understand 'take'?
, max 6 (width pwBytes) >= width pwBytes
, max 6 (width pwBytes) >= 6
, max 7 (width pwBytes) >= 7
, max 7 (width pwBytes) >= width pwBytes
, max (width pwBytes) 7 >= 7
, max (width pwBytes) 7 >= width pwBytes
, 64 >= width (8 * pwBytes)
, 64 >= width (8 * (68 + saltBytes))
pbkdf2 : {pwBytes, saltBytes, dkLenBits, C}
( 32 >= width (pwBytes*8)
, dkLenBits >= 1
, fin dkLenBits
, 32 >= width (dkLenBits - 1)
, C >= 1
, 16 >= width C
, 32 >= width (4 + saltBytes)
)
=> [pwBytes][8] -> [saltBytes][8] -> [dkLenBits]
@ -32,19 +22,11 @@ pbkdf2 P S = take `{dkLenBits} (join Ts)
where
Ts : [_][256]
Ts = [ inner `{C=C} P (split (hmacSHA256 P (S # split i))) | i <- [1..len] : [_][32] ]
type len = (dkLenBits + 255)/256
inner : {pwBytes, C}
( fin pwBytes
, 64 >= width (8 * (pwBytes + 32))
, fin C, C >= 1, 16 >= width C
// Cryptol < 2.3 can't math
, 64 >= width (8 * pwBytes)
, max 7 (width pwBytes) >= width pwBytes
, max 7 (width pwBytes) >= 7
, max (width pwBytes) 7 >= width pwBytes
, max (width pwBytes) 7 >= 7
, max 6 (width pwBytes) >= width pwBytes
, max 6 (width pwBytes) >= 6
( 64 >= width (8 * (pwBytes + 32))
, C >= 1, 16 >= width C
)
=> [pwBytes][8] -> [32][8] -> [256]
inner P U0 = (Ts @ 0).0 // XXX should be ! 0
@ -52,16 +34,7 @@ inner P U0 = (Ts @ 0).0 // XXX should be ! 0
// Ts : [_][([256],[32][8])]
Ts = [(join U0, U0)] # [ F P t u | _ <- [1..C] : [_][16] | (t,u) <- Ts ]
F : {pwBytes} (fin pwBytes
, 64 >= width (8*(32+pwBytes))
// cryptol < 2.3 can't math
, 64 >= width (8 * pwBytes)
, max 7 (width pwBytes) >= width pwBytes
, max 7 (width pwBytes) >= 7
, max (width pwBytes) 7 >= width pwBytes
, max (width pwBytes) 7 >= 7
, max 6 (width pwBytes) >= width pwBytes
, max 6 (width pwBytes) >= 6
F : {pwBytes} ( 64 >= width (8*(32+pwBytes))
) => [pwBytes][8] -> [256] -> [32][8] -> ([256],[32][8])
F P Tprev Uprev = (Tnext,Unext)
where

18
examples/MiniLock/prim/Poly1305.md
View File

@ -1,4 +1,4 @@
% Poly1305 for IETF protocols
% Poly1305 for IETF protocols
% Y. Nir (Check Point), A. Langley (Google Inc), D. McNamee (Galois, Inc)
% July 28, 2014
%
@ -70,7 +70,7 @@ The inputs to Poly1305 are:
The output is a 128-bit tag.
```cryptol
Poly1305 : {m, floorBlocks, rem} (fin m, floorBlocks == m/16, rem == m - floorBlocks*16)
Poly1305 : {m, floorBlocks, rem} (fin m, floorBlocks == m/16, rem == m - floorBlocks*16)
=> [256] -> [m][8] -> [16][8]
```
@ -114,7 +114,7 @@ Next, divide the message into 16-byte blocks. The last block might be shorter:
* Add the current block to the accumulator.
* Multiply by "r"
* Set the accumulator to the result modulo p. To summarize:
* Set the accumulator to the result modulo p. To summarize:
``accum[i+1] = ((accum[i]+block)*r) % p``.
```cryptol
@ -161,7 +161,7 @@ using AES, and assume that we got the following keying material:
03:80:8a:fb:0d:b2:fd:4a:bf:f6:af:41:49:f5:1b
```cryptol
Poly1305TestKey = join (parseHexString
Poly1305TestKey = join (parseHexString
( "85:d6:be:78:57:55:6d:33:7f:44:52:fe:42:d5:06:a8:01:"
# "03:80:8a:fb:0d:b2:fd:4a:bf:f6:af:41:49:f5:1b."
) )
@ -196,7 +196,7 @@ values of the accumulator:
```cryptol
// TODO: refactor the Poly function in terms of this AccumBlocks
// challenge: doing so while maintaining the clean literate correspondence with the spec
AccumBlocks : {m, floorBlocks, rem} (fin m, floorBlocks == m/16, rem == m - floorBlocks*16)
AccumBlocks : {m, floorBlocks, rem} (fin m, floorBlocks == m/16, rem == m - floorBlocks*16)
=> [256] -> [m][8] -> ([_][136], [136])
AccumBlocks key msg = (accum, lastAccum) where
@ -252,7 +252,7 @@ Acc + block = 2d8adaf23b0337fa7cccfb4ea344ca153
```
```cryptol
property polyBlocksOK =
property polyBlocksOK =
(blocks @ 1 == 0x02c88c77849d64ae9147ddeb88e69c83fc) &&
(blocks @ 2 == 0x02d8adaf23b0337fa7cccfb4ea344b30de) &&
(lastBlock == 0x028d31b7caff946c77c8844335369d03a7) where
@ -264,7 +264,7 @@ Adding s we get this number, and serialize if to get the tag:
Acc + s = 2a927010caf8b2bc2c6365130c11d06a8
Tag: a8:06:1d:c1:30:51:36:c6:c2:2b:8b:af:0c:01:27:a9
```cryptol
// Putting it all together and testing:
@ -292,7 +292,7 @@ SK_a* or *_write_MAC_key is only for stand-alone Poly1305.
The method is to call the block function with the following
parameters:
* The 256-bit session integrity key is used as the ChaCha20 key.
* The block counter is set to zero.
* The protocol will specify a 96-bit or 64-bit nonce. This MUST be
@ -317,7 +317,7 @@ encryption algorithms (often called Initialization Vectors, or IVs),
they usually don't have such a provision for the MAC function. In
that case the per-invocation nonce will have to come from somewhere
else, such as a message counter.
### Poly1305 Key Generation Test Vector
For this example, we'll set:

21
examples/MiniLock/prim/SCrypt.cry
View File

@ -16,7 +16,12 @@ BlockMix B = ys @@ ([0,2..2*r-2] # [1,3..2*r-1])
// SMix with the ROMix algorithm (section 5) inlined (specialized to BlockMix)
// N = 2^^17
SMix : {N,r} (fin N, fin r, r >= 1, N >= 1, 512 >= width N, 1 + width N >= width (N-1)) => [128 * 8 * r] -> [128 * 8 * r]
SMix : {N,r} ( fin r
, r >= 1
, N >= 1
, 512 >= width N
, 1 + width N >= width (N-1)
) => [128 * 8 * r] -> [128 * 8 * r]
SMix B = join (Xs ! 0)
where
Vs = [split B] # [ BlockMix x | x <- Vs | _ <- [0..N-1] : [_][width N + 1]]
@ -34,31 +39,29 @@ SMix B = join (Xs ! 0)
// SCrypt paper, page 11: MFCrypt specialized to sha256 (see the 'pbkdf2' function)
// p = 1
MFcrypt : { pwBytes, saltBytes, dkLen, r, N }
( fin pwBytes, fin saltBytes, fin r
, 4*r >= 1, 16 >= width (4*r)
( 4*r >= 1
, 16 >= width (4*r)
, ((dkLen*8 + 255) / 256) >= 1
, 32 >= width (8*pwBytes)
, 32 >= width (4 + saltBytes)
, 16 >= width ((255 + 8 * dkLen) / 256)
, 8 * dkLen == 256 * ((255 + 8 * dkLen) / 256) // seriously cryptol?
, fin N, N >= 1, 512 >= width N, 1+width N >= width (N-1)
, N >= 1, 512 >= width N, 1+width N >= width (N-1)
)
=> [pwBytes][8] -> [saltBytes][8] -> [dkLen][8]
MFcrypt P S = split DK
where
B = pbkdf2 `{C=1} P S
B' = SMix `{N=N,r=r} B
DK = pbkdf2 `{len=((dkLen*8)+255)/256,C=1} P (split B')
DK = pbkdf2 `{dkLenBits=dkLen*8, C=1} P (split B')
SCrypt : {pwBytes, saltBytes, dkBytes, r, N}
( fin pwBytes, fin saltBytes, fin r
, 4*r >= 1, 16 >= width (4*r)
( 4*r >= 1, 16 >= width (4*r)
, (dkBytes * 8 + 255) / 256 >= 1
, 16 >= width ((255 + 8 * dkBytes) / 256)
, 8 * dkBytes == 256 * ((255 + 8 * dkBytes) / 256)
, 32 >= width (8 * pwBytes)
, 32 >= width (4 * saltBytes)
, fin N, N >= 1, 512 >= width N, 1+width N >= width (N-1)
, N >= 1, 512 >= width N, 1+width N >= width (N-1)
)
=> [pwBytes][8] -> [saltBytes][8] -> [dkBytes][8]
SCrypt P S = MFcrypt `{r=r,N=N} P S

5
examples/MiniLock/prim/SHA256.cry
View File

@ -82,7 +82,6 @@ SHA256MessageSchedule : [16][32] -> [64][32]
SHA256MessageSchedule M = W where
W = M # [ s1 (W@(j-2)) + (W@(j-7)) + s0 (W@(j-15)) + (W@(j-16)) | j <- [16 .. 63]:[_][8] ]
SHA256Compress : [8][32] -> [64][32] -> [8][32]
SHA256Compress H W = [as!0 + H@0, bs!0 + H@1, cs!0 + H@2, ds!0 + H@3, es!0 + H@4, fs!0 + H@5, gs!0 + H@6, hs!0 + H@7] where
T1 = [h + S1 e + Ch e f g + k + w | h <- hs | e <- es | f <- fs | g <- gs | k <- K | w <- W]
@ -99,7 +98,7 @@ SHA256Compress H W = [as!0 + H@0, bs!0 + H@1, cs!0 + H@2, ds!0 + H@3, es!0 + H@4
/*
* The SHA256' function hashes a preprocessed sequence of blocks with the
* compression function. The SHA256 function hashes a sequence of bytes, and
* is more likely the function that will be similar to those seein in an
* is more likely the function that will be similar to those see in in an
* implementation to be verified.
*/
@ -108,7 +107,7 @@ SHA256' blocks = hash!0 where
hash = [H0] # [SHA256Compress h (SHA256MessageSchedule b) | h <- hash | b <- blocks]
SHA256 : {a} (fin a, 64 >= width (8*a)) => [a][8] -> [256]
SHA256 msg = join (SHA256' [ split x | x <- preprocess(join msg)])
SHA256 msg = join (SHA256' [ split x | x <- preprocess(join msg)])
property katsPass = ~zero == [test == kat | (test,kat) <- kats ]

2
examples/MiniLock/prim/mod_arith.cry
View File

@ -45,7 +45,7 @@ mod_div(p,x,y) = egcd(p,0,y,x)
egcd(a, ra, b >> 1, mod_half(p, rb))
else if a < b then
egcd(a, ra, (b - a) >> 1, mod_half(p, mod_sub(p, rb, ra)))
else
else
egcd(b, rb, (a - b) >> 1, mod_half(p, mod_sub(p, ra, rb)))
mod_pow : {a} (fin a, a >= 1) => ([a] , [a] , [a]) -> [a]

6
examples/SHA1.cry
View File

@ -12,7 +12,7 @@ sha1 msg = sha1' pmsg
sha1' : {chunks} (fin chunks) => [chunks][512] -> [160]
sha1' pmsg = join (Hs!0)
where
where
Hs = [[0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476, 0xc3d2e1f0]] #
[ block(H, split(M))
| H <- Hs
@ -38,7 +38,7 @@ pad msg = split (msg # [True] # (zero:[padding]) # (`msgLen:[64]))
type padding = (512 - contentLen % 512) % 512 // prettier if type #'s could be < 0
f : ([8], [32], [32], [32]) -> [32]
f (t, x, y, z) =
f (t, x, y, z) =
if (0 <= t) && (t <= 19) then (x && y) ^ (~x && z)
| (20 <= t) && (t <= 39) then x ^ y ^ z
| (40 <= t) && (t <= 59) then (x && y) ^ (x && z) ^ (y && z)
@ -54,7 +54,7 @@ Ks = [ 0x5a827999 | t <- [0..19] ]
block : ([5][32], [16][32]) -> [5][32]
block ([H0, H1, H2, H3, H4], M) =
[(H0+As@80), (H1+Bs@80), (H2+Cs@80), (H3+Ds@80), (H4+Es@80)]
where
where
Ws : [80][32]
Ws = M # [ (W3 ^ W8 ^ W14 ^ W16) <<< 1
| W16 <- drop`{16 - 16} Ws

4
examples/SIV-rfc5297.md
View File

@ -321,7 +321,7 @@ E(K,X) = aesEncrypt (X,K)
// 8. Return T.
aesCMAC : {m} (fin m) => Key -> [m] -> [128]
aesCMAC K m =
aesCMAC K m =
cmacBlocks K ((`m%128) == 0 && `m > 0) (split `{each=128,parts=blocks} full)
where
pd = [True] # zero : [128]
@ -501,7 +501,7 @@ S2V K S1 S2 = res
else aesCMAC K (dbl D1 ^ pad S2)
private
// The length of 'p' is >= 128, but Cryptol lacks
// The length of 'p' is >= 128, but Cryptol lacks
// dependent types and can not infer this fact. We
// Provide a no-op computation that results in a
// new type for 'p' that is at least 128 bits

4
examples/TripleDES.cry
View File

@ -8,7 +8,7 @@ module TripleDES where
import DES
blockEncrypt : ([64],[64],[64],[64]) -> [64]
blockEncrypt (k1,k2,k3,data) = result where
blockEncrypt (k1,k2,k3,data) = result where
ex = DES.encrypt k1 data
dx = DES.decrypt k2 ex
result = DES.encrypt k3 dx
@ -25,7 +25,7 @@ PlainText = "The qufck brown fox jump"
// Yes, that's the correct phrase.. (see the 7th letter of the phrase).
// It's supposed to be "the quick..." but they made a mistake in transcribing
// the ASCII into hex.
[P1, P2, P3] = splitBy`{3} (join PlainText)
[P1, P2, P3] = split`{3} (join PlainText)
// B.1

53
examples/contrib/A51.cry Normal file
View File

@ -0,0 +1,53 @@
/* Source:
Alexander Semenov
Institute for System Dynamics and Control Theory
Russian Academy of Sciences
*/
A51_stream : [19] -> [22] -> [23] -> [inf]
A51_stream R1 R2 R3 = R1s ^ R2s ^ R3s
where
(R1s, R1f) = lfsrki <| x^^19 + x^^18 + x^^17 + x^^14 + 1 |> R1c R1
(R2s, R2f) = lfsrki <| x^^22 + x^^21 + 1 |> R2c R2
(R3s, R3f) = lfsrki <| x^^23 + x^^22 + x^^21 + x^^8 + 1 |> R3c R3
majvs = [ majv (r1@8) (r2@10) (r3@10) | r1 <- R1f | r2 <- R2f | r3 <- R3f ]
R1c = [ r1@8 == m | r1 <- R1f | m <- majvs ]
R2c = [ r2@10 == m | r2 <- R2f | m <- majvs ]
R3c = [ r3@10 == m | r3 <- R3f | m <- majvs ]
type N = 128
A51 : ([19], [22], [23]) -> [N]Bit
A51(reg1, reg2, reg3) = keystream
where
keystream = take`{N} (A51_stream reg1 reg2 reg3)
lfsrki_step : {d} (fin d, d >=1) => [d+1] -> Bit -> [d] -> [d]
lfsrki_step poly cond fill = fill'
where
feedback_bit = if(poly@0) then prefix (^) (reverse([False]#fill) && poly)
else error "polynomial does not have high-bit set."
fill' = if cond then [feedback_bit]#(take fill) else fill
lfsrki : {d} (fin d, d >=1) => [d+1] -> [inf] -> [d] -> ([inf], [inf][d])
lfsrki poly conds init = (stream, fills)
where
lfsrki' = lfsrki_step poly
fills = [init] # [ lfsrki' c f | c <- conds | f <- fills]
stream = [ f!0 | f <- fills ]
prefix f xs = ys!0
where ys = [xs@0] # [ f y x | y <- ys | x <- tail xs ]
majv a b c = (a && b) || (a && c) || (b && c)
/***********************************************************************/
iv1 = 0b1010111011101011101
iv2 = 0b1010111011101010101110
iv3 = 0b10100000111100110011011
test_keystream = 0b00100100111010001110101110101100010100110111110101000101110000011101000111110101010000010011001111110101110001011010100000010001
property A51_correct = (A51(iv1, iv2, iv3)) == test_keystream
property A51_search x y z = A51(x,y,z) == test_keystream

75
examples/contrib/bivium.cry Normal file
View File

@ -0,0 +1,75 @@
/* Source:
Alexander Semenov
Institute for System Dynamics and Control Theory
Russian Academy of Sciences
*/
Bivium_stream : [93] -> [84] -> [inf]
Bivium_stream R1 R2 = stream
where
(stream, ra, rb) = shift_regs R1 R2
type N = 200
Bivium : ([93], [84]) -> [N]Bit
Bivium (reg1, reg2) = keystream
where
keystream = take`{N} (Bivium_stream reg1 reg2)
shift : {d} (fin d, d >=1) => [d] -> Bit -> [d]
shift fill bit = fills
where
fills = [bit]#(drop`{1} (fill >> 1))
shift_regs : {d,e} (fin d, fin e, d >=1, e >=1) => [d] -> [e] -> ([inf],[inf][d],[inf][e])
shift_regs r1 r2 = (stream, regA, regB)
where
s1 = [(f1 @ 65) ^ (f1 @ 92) | f1 <- regA]
s2 = [(f2 @ 68) ^ (f2 @ 83) | f2 <- regB]
stream = s1 ^ s2
t1 = [(f1 @ 65) ^ ((f1 @ 90) && (f1 @ 91)) ^ (f1 @ 92) ^ (f2 @ 77) |
f2 <- regB |
f1 <- regA ]
t2 = [(f2 @ 68) ^ ((f2 @ 81) && (f2 @ 82)) ^ (f2 @ 83) ^ (f1 @ 68) |
f1 <- regA |
f2 <- regB ]
regA = [r1] # [shift f b| f <- regA | b <- t2]
regB = [r2] # [shift f b| f <- regB | b <- t1]
Bivium_alt : ([93], [84]) -> [N]Bit
Bivium_alt (r1, r2) = take`{N} (s1 ^ s2)
where
a_65 = drop`{27} a_92
a_68 = drop`{24} a_92
a_90 = drop`{2} a_92
a_91 = drop`{1} a_92
a_92 = reverse r1 # t2
b_68 = drop`{15} b_83
b_77 = drop`{6} b_83
b_81 = drop`{2} b_83
b_82 = drop`{1} b_83
b_83 = reverse r2 # t1
s1 = a_65 ^ a_92
s2 = b_68 ^ b_83
t1 = s1 ^ (a_90 && a_91) ^ b_77
t2 = s2 ^ (b_81 && b_82) ^ a_68
/*************************************************************/
iv1 = 0b111110000000101010100100010001000000101010100001011111111111111100100100111111111011111111111
iv2 = 0b000000000000000000001000000000000000000001000000000000000000001000000000000000000001
test_keystream = 0b01000010000100000101110001100011111101110101110111111110100001111111100110101001000010101100100010000100001100011100000010001001100101101001011101110100000001011010001101000011001000110011111010100110
suffix = 0b000000001000000000000000000001
property Bivium_correct = (Bivium(iv1, iv2)) == test_keystream
property Bivium_search (x, y) = (Bivium(x, y)) == test_keystream
property Bivium_search_with_suffix (x, y) = (Bivium(x, y#suffix)) == test_keystream
property Bivium_alt_equivalent r = Bivium_alt r == Bivium r

87
examples/contrib/trivium.cry Normal file
View File

@ -0,0 +1,87 @@
/* Source:
Alexander Semenov
Institute for System Dynamics and Control Theory
Russian Academy of Sciences
*/
Trivium_stream : [93] -> [84] -> [111] -> [inf]
Trivium_stream R1 R2 R3 = stream
where
(stream, ra, rb, rc) = shift_regs R1 R2 R3
type N = 300
Trivium : ([93], [84], [111]) -> [N]Bit
Trivium (reg1, reg2, reg3) = keystream
where
keystream = take`{N} (Trivium_stream reg1 reg2 reg3)
shift : {d} (fin d, d >=1) => [d] -> Bit -> [d]
shift fill bit = fills
where
fills = [bit]#(drop`{1} (fill >> 1))
shift_regs : {d,e,f} (fin d, fin e, fin f, d >=1, e >=1, f>=1) => [d] -> [e] -> [f] -> ([inf],[inf][d],[inf][e],[inf][f])
shift_regs r1 r2 r3 = (stream, regA, regB, regC)
where
s1 = [(f1 @ 65) ^ (f1 @ 92) | f1 <- regA]
s2 = [(f2 @ 68) ^ (f2 @ 83) | f2 <- regB]
s3 = [(f3 @ 65) ^ (f3 @ 110) | f3 <- regC]
stream = s1 ^ s2 ^ s3
t1 = [(f1 @ 65) ^ ((f1 @ 90) && (f1 @ 91)) ^ (f1 @ 92) ^ (f2 @ 77) |
f2 <- regB |
f1 <- regA ]
t2 = [(f2 @ 68) ^ ((f2 @ 81) && (f2 @ 82)) ^ (f2 @ 83) ^ (f3 @ 86) |
f2 <- regB |
f3 <- regC ]
t3 = [(f3 @ 65) ^ ((f3 @ 108) && (f3 @ 109)) ^ (f3 @ 110) ^ (f1 @ 68)|
f1 <- regA |
f3 <- regC ]
regA = [r1] # [shift f b| f <- regA | b <- t3]
regB = [r2] # [shift f b| f <- regB | b <- t1]
regC = [r3] # [shift f b| f <- regC | b <- t2]
Trivium_alt : ([93], [84], [111]) -> [N]Bit
Trivium_alt (r1, r2, r3) = take`{N} (s1 ^ s2 ^ s3)
where
a_65 = drop`{27} a_92
a_68 = drop`{24} a_92
a_90 = drop`{2} a_92
a_91 = drop`{1} a_92
a_92 = reverse r1 # t3
b_68 = drop`{15} b_83
b_77 = drop`{6} b_83
b_81 = drop`{2} b_83
b_82 = drop`{1} b_83
b_83 = reverse r2 # t1
c_65 = drop`{45} c_110
c_86 = drop`{24} c_110
c_108 = drop`{2} c_110
c_109 = drop`{1} c_110
c_110 = reverse r3 # t2
s1 = a_65 ^ a_92
s2 = b_68 ^ b_83
s3 = c_65 ^ c_110
t1 = s1 ^ (a_90 && a_91) ^ b_77
t2 = s2 ^ (b_81 && b_82) ^ c_86
t3 = s3 ^ (c_108 && c_109) ^ a_68
/*********************************************************/
iv1 = 0b111111111111111111101111111111111111111011111111111111111110111111111111111111101111111111111
iv2 = 0b000000000000000000001000000000000000000001000000000000000000001000000000000000000001
iv3 = 0b111111111111111110111111111111111111101111111111111111111011111111111111111110111111111111100000000000000000000
test_keystream = 0b011111110111101111110100001110000000000000100010000000000000000100011000101100001110001011011010101010000100101110001111100011000110000101001011001111011101110110111010011011010110001000111101101111101100101001000111010001010011111110011100100011101010011110101001001000011100001111111100000001110001
property Trivium_correct = (Trivium(iv1, iv2, iv3)) == test_keystream
property Trivium_search (x, y, z) = (Trivium(x, y, z)) == test_keystream
property Trivium_alt_correct = (Trivium_alt(iv1, iv2, iv3)) == test_keystream
property Trivium_alt_equivalent x = take`{200}(Trivium_alt x) == take (Trivium x)

3
examples/funstuff/NQueens.cry
View File

@ -9,7 +9,7 @@
where n is the board-size
You may find that cvc4 takes a long time for solutions bigger than 5.
For those sizes, we have had good luck with both Yices and Z3.
For those sizes, we have had good luck with both Yices and Z3.
To do that,
@ -54,4 +54,3 @@ inRange : {n} (fin n, n >= 1) => Board n -> Position n -> Bit
inRange qs x = x <= `(n - 1)
property nQueensProve x = (nQueens x) == False

7
examples/funstuff/marble.cry
View File

@ -66,8 +66,8 @@ validBoard : Board -> Bit
validBoard b = join (b && ~posns) == zero
validRowJump : Board -> Board -> Bit
validRowJump a a' = validBoard a
&& validBoard a'
validRowJump a a' = validBoard a
&& validBoard a'
&& validRowMove (differentRow a a')
differentRow : Board -> Board -> ([7], [7])
@ -83,7 +83,7 @@ validRowMove (r, r') = (xors == 0b0000111 ||
xors == 0b0001110 ||
xors == 0b0011100 ||
xors == 0b0111000 ||
xors == 0b1110000)
xors == 0b1110000)
&& (
rxors == 0b0000011 ||
rxors == 0b0000110 ||
@ -105,4 +105,3 @@ validMoveSequence moves = all [validMove a b | a <- moves | b <- drop`{1} moves]
solutionInNmoves : {n} (fin n) => [n] Board -> Bit
property solutionInNmoves ms = validMoveSequence ([start] # ms # [second])

15
examples/maliciousSHA/malicious_SHA1.cry
View File

@ -24,7 +24,7 @@ malicious_sha1 msg k = malicious_sha1' rmsg k
malicious_sha1' : {chunks} (fin chunks) => [chunks][512] -> [4][32] -> [160]
malicious_sha1' pmsg k = join (Hs!0)
where
where
Hs = [[0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476, 0xc3d2e1f0]] #
[ malicious_block (H, split(M)) k
| H <- Hs
@ -53,7 +53,7 @@ eve1 = [
//hexdump of file available at http://malicioussha1.github.io/pocs/eve2.sh
//when executed will print "hello world"
//The ascii cow and hello world can be switched out in both files
//The ascii cow and hello world can be switched out in both files
//and the hashes will still collide. The next example shows this
eve2 = [
0x1d23, 0x921b, 0x4014, 0xac09, 0x4d98, 0xd3a6, 0xe1bc, 0x4910,
@ -94,7 +94,7 @@ eve1_galois = [
0x6365, 0x6f68, 0x2220, 0x6147, 0x6f6c, 0x7369, 0x3b22, 0x660a,
0x0a69]
//hexdump malicious/eve1.sh
//hexdump malicious/eve1.sh
eve2_galois = [
0x1d23, 0x921b, 0x4014, 0xac09, 0x4d98, 0xd3a6, 0xe1bc, 0x4910,
0x8570, 0x1812, 0x786f, 0xb926, 0x37bd, 0xac2b, 0x50ae, 0x6a08,
@ -135,15 +135,15 @@ pad : {msgLen,contentLen,chunks,padding}
pad msg = split (msg # [True] # (zero:[padding]) # (`msgLen:[64]))
f : ([8], [32], [32], [32]) -> [32]
f (t, x, y, z) =
f (t, x, y, z) =
if (0 <= t) && (t <= 19) then (x && y) ^ (~x && z)
| (20 <= t) && (t <= 39) then x ^ y ^ z
| (40 <= t) && (t <= 59) then (x && y) ^ (x && z) ^ (y && z)
| (60 <= t) && (t <= 79) then x ^ y ^ z
else error "f: t out of range"
Ks : [4][32] -> [80][32]
Ks : [4][32] -> [80][32]
Ks k = [ k@0 | t <- [0..19] ]
# [ k@1 | t <- [20..39] ]
# [ k@2 | t <- [40..59] ]
@ -152,7 +152,7 @@ Ks k = [ k@0 | t <- [0..19] ]
malicious_block : ([5][32], [16][32]) -> [4][32]-> [5][32]
malicious_block ([H0, H1, H2, H3, H4], M) k =
[(H0+As@80), (H1+Bs@80), (H2+Cs@80), (H3+Ds@80), (H4+Es@80)]
where
where
Ws : [80][32]
Ws = M # [ (W3 ^ W8 ^ W14 ^ W16) <<< 1
| W16 <- drop`{16 - 16} Ws
@ -172,4 +172,3 @@ malicious_block ([H0, H1, H2, H3, H4], M) k =
| W <- Ws | K <- (Ks k)
| t <- [0..79]
]

20
lib/Cryptol.cry
View File

@ -94,10 +94,16 @@ primitive False : Bit
primitive negate : {a} (Arith a) => a -> a
/**
* Binary complement
* Binary complement.
*/
primitive complement : {a} a -> a
/**
* Operator form of binary complement.
*/
(~) : {a} a -> a
(~) = complement
/**
* Less-than. Only works on comparable arguments.
*/
@ -251,7 +257,7 @@ primitive (!) : {a, b, c} (fin a, fin c) => [a]b -> [c] -> b
/**
* Bulk reverse index operator. The first argument is a finite sequence. The
* second argument is a sequence of the zero-based indices of the elements to
* select, starting from the end of the sequence.
z select, starting from the end of the sequence.
*/
primitive (!!) : {a, b, c, d} (fin a, fin d) => [a]b -> [c][d] -> [c]b
@ -274,6 +280,7 @@ primitive infFromThen : {bits} (fin bits) => [bits] -> [bits] -> [inf][bits]
primitive error : {at, len} (fin len) => [len][8] -> at
/**
* Performs multiplication of polynomials over GF(2).
*/
@ -314,10 +321,11 @@ width _ = `len
undefined : {a} a
undefined = error "undefined"
splitBy : {parts,each,elem} (fin each) =>
[parts * each] elem -> [parts][each]elem
splitBy = split
groupBy : {each,parts,elem} (fin each) =>
[parts * each] elem -> [parts][each]elem
groupBy = split`{parts=parts}
/**
* Define the base 2 logarithm function in terms of width
*/
type lg2 n = width (max n 1 - 1)

32
src/Cryptol/Eval.hs
View File

@ -25,6 +25,7 @@ import Cryptol.Eval.Type
import Cryptol.Eval.Value
import Cryptol.ModuleSystem.Name
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat (Nat')
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.PP
import Cryptol.Prims.Eval
@ -42,7 +43,7 @@ moduleEnv m env = evalDecls (mDecls m) (evalNewtypes (mNewtypes m) env)
evalExpr :: EvalEnv -> Expr -> Value
evalExpr env expr = case expr of
EList es ty -> VSeq (isTBit (evalType env ty)) (map (evalExpr env) es)
EList es ty -> VSeq (isTBit (evalValType env ty)) (map (evalExpr env) es)
ETuple es -> VTuple (map eval es)
@ -53,7 +54,7 @@ evalExpr env expr = case expr of
EIf c t f | fromVBit (eval c) -> eval t
| otherwise -> eval f
EComp l h gs -> evalComp env (evalType env l) h gs
EComp l h gs -> evalComp env (evalValType env l) h gs
EVar n -> case lookupVar n env of
Just val -> val
@ -62,14 +63,18 @@ evalExpr env expr = case expr of
, pretty (WithBase defaultPPOpts env)
]
ETAbs tv b -> VPoly $ \ty -> evalExpr (bindType (tpVar tv) ty env) b
ETAbs tv b -> case tpKind tv of
KType -> VPoly $ \ty -> evalExpr (bindType (tpVar tv) (Right ty) env) b
KNum -> VNumPoly $ \n -> evalExpr (bindType (tpVar tv) (Left n) env) b
k -> panic "[Eval] evalExpr" ["invalid kind on type abstraction", show k]
ETApp e ty -> case eval e of
VPoly f -> f (evalType env ty)
val -> panic "[Eval] evalExpr"
["expected a polymorphic value"
, show (ppV val), show e, show ty
]
VPoly f -> f (evalValType env ty)
VNumPoly f -> f (evalNumType env ty)
val -> panic "[Eval] evalExpr"
["expected a polymorphic value"
, show (ppV val), show e, show ty
]
EApp f x -> case eval f of
VFun f' -> f' (eval x)
@ -195,7 +200,7 @@ instance Applicative ZList where
-- comprehension.
data ListEnv = ListEnv
{ leVars :: Map.Map Name (ZList Value)
, leTypes :: Map.Map TVar TValue
, leTypes :: Map.Map TVar (Either Nat' TValue)
}
instance Monoid ListEnv where
@ -233,11 +238,10 @@ bindVarList n vs lenv = lenv { leVars = Map.insert n (Zip vs) (leVars lenv) }
-- | Evaluate a comprehension.
evalComp :: ReadEnv -> TValue -> Expr -> [[Match]] -> Value
evalComp env seqty body ms
| Just (len,el) <- isTSeq seqty = toSeq len el [ evalExpr e body | e <- envs ]
| otherwise = evalPanic "Cryptol.Eval" [ "evalComp given a non sequence"
, show seqty
]
evalComp env seqty body ms =
case isTSeq seqty of
Just (len, el) -> toSeq len el [ evalExpr e body | e <- envs ]
_ -> evalPanic "Cryptol.Eval" ["evalComp given a non sequence", show seqty]
-- XXX we could potentially print this as a number if the type was available.
where

21
src/Cryptol/Eval/Env.hs
View File

@ -6,21 +6,24 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.Eval.Env where
import Cryptol.Eval.Value
import Cryptol.ModuleSystem.Name
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..))
import Cryptol.Utils.PP
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
@ -31,10 +34,8 @@ type ReadEnv = EvalEnv
data EvalEnv = EvalEnv
{ envVars :: Map.Map Name Value
, envTypes :: Map.Map TVar TValue
} deriving (Generic)
instance NFData EvalEnv where rnf = genericRnf
, envTypes :: Map.Map TVar (Either Nat' TValue)
} deriving (Generic, NFData)
instance Monoid EvalEnv where
mempty = EvalEnv
@ -63,10 +64,10 @@ bindVar n val env = env { envVars = Map.insert n val (envVars env) }
lookupVar :: Name -> EvalEnv -> Maybe Value
lookupVar n env = Map.lookup n (envVars env)
-- | Bind a type variable of kind *.
bindType :: TVar -> TValue -> EvalEnv -> EvalEnv
-- | Bind a type variable of kind # or *.
bindType :: TVar -> Either Nat' TValue -> EvalEnv -> EvalEnv
bindType p ty env = env { envTypes = Map.insert p ty (envTypes env) }
-- | Lookup a type variable.
lookupType :: TVar -> EvalEnv -> Maybe TValue
lookupType :: TVar -> EvalEnv -> Maybe (Either Nat' TValue)
lookupType p env = Map.lookup p (envTypes env)

73
src/Cryptol/Eval/Type.hs
View File

@ -8,11 +8,11 @@
{-# LANGUAGE Safe, PatternGuards #-}
module Cryptol.Eval.Type (evalType, evalTF) where
module Cryptol.Eval.Type (evalType, evalValType, evalNumType, evalTF) where
import Cryptol.Eval.Env
import Cryptol.Eval.Error
import Cryptol.Eval.Value(TValue(..),numTValue)
import Cryptol.Eval.Value (TValue(..), tvSeq)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat
@ -21,29 +21,49 @@ import Data.Maybe(fromMaybe)
-- Type Evaluation -------------------------------------------------------------
-- | Evaluation for types.
evalType :: EvalEnv -> Type -> TValue
evalType env = TValue . go
-- | Evaluation for types (kind * or #).
evalType :: EvalEnv -> Type -> Either Nat' TValue
evalType env ty =
case ty of
TVar tv ->
case lookupType tv env of
Just v -> v
Nothing -> evalPanic "evalType" ["type variable not bound", show tv]
TUser _ _ ty' -> evalType env ty'
TRec fields -> Right $ TVRec [ (f, val t) | (f, t) <- fields ]
TCon (TC c) ts ->
case (c, ts) of
(TCBit, []) -> Right $ TVBit
(TCSeq, [n, t]) -> Right $ tvSeq (num n) (val t)
(TCFun, [a, b]) -> Right $ TVFun (val a) (val b)
(TCTuple _, _) -> Right $ TVTuple (map val ts)
(TCNum n, []) -> Left $ Nat n
(TCInf, []) -> Left $ Inf
-- FIXME: What about TCNewtype?
_ -> evalPanic "evalType" ["not a value type", show ty]
TCon (TF f) ts -> Left $ evalTF f (map num ts)
TCon (PC p) _ -> evalPanic "evalType" ["invalid predicate symbol", show p]
where
go ty =
case ty of
TVar tv ->
case lookupType tv env of
Just (TValue v) -> v
Nothing -> evalPanic "evalType" ["type variable not bound", show tv]
val = evalValType env
num = evalNumType env
TCon (TF f) ts -> tValTy $ evalTF f $ map (evalType env) ts
TCon tc ts -> TCon tc (map go ts)
TUser _ _ ty' -> go ty'
TRec fields -> TRec [ (f,go t) | (f,t) <- fields ]
-- | Evaluation for value types (kind *).
evalValType :: EvalEnv -> Type -> TValue
evalValType env ty =
case evalType env ty of
Left _ -> evalPanic "evalValType" ["expected value type, found numeric type"]
Right t -> t
-- | Reduce type functions, rising an exception for undefined values.
evalTF :: TFun -> [TValue] -> TValue
evalTF tf vs = TValue $ cvt $ evalTF' tf $ map numTValue vs
evalNumType :: EvalEnv -> Type -> Nat'
evalNumType env ty =
case evalType env ty of
Left n -> n
Right _ -> evalPanic "evalValType" ["expected numeric type, found value type"]
-- | Reduce type functions, rising an exception for undefined values.
evalTF' :: TFun -> [Nat'] -> Nat'
evalTF' f vs
-- | Reduce type functions, raising an exception for undefined values.
evalTF :: TFun -> [Nat'] -> Nat'
evalTF f vs
| TCAdd <- f, [x,y] <- vs = nAdd x y
| TCSub <- f, [x,y] <- vs = mb $ nSub x y
| TCMul <- f, [x,y] <- vs = nMul x y
@ -59,13 +79,4 @@ evalTF' f vs
["Unexpected type function:", show ty]
where mb = fromMaybe (typeCannotBeDemoted ty)
ty = TCon (TF f) (map cvt vs)
cvt :: Nat' -> Type
cvt (Nat n) = tNum n
cvt Inf = tInf
ty = TCon (TF f) (map tNat' vs)

108
src/Cryptol/Eval/Value.hs
View File

@ -6,12 +6,14 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
module Cryptol.Eval.Value where
import qualified Cryptol.Eval.Arch as Arch
@ -29,61 +31,46 @@ import qualified Data.Text as T
import Numeric (showIntAtBase)
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
-- Utilities -------------------------------------------------------------------
isTBit :: TValue -> Bool
isTBit (TValue ty) = case ty of
TCon (TC TCBit) [] -> True
_ -> False
isTBit TVBit = True
isTBit _ = False
isTSeq :: TValue -> Maybe (TValue, TValue)
isTSeq (TValue (TCon (TC TCSeq) [t1,t2])) = Just (TValue t1, TValue t2)
isTSeq :: TValue -> Maybe (Nat', TValue)
isTSeq (TVSeq n t) = Just (Nat n, t)
isTSeq (TVStream t) = Just (Inf, t)
isTSeq _ = Nothing
isTFun :: TValue -> Maybe (TValue, TValue)
isTFun (TValue (TCon (TC TCFun) [t1,t2])) = Just (TValue t1, TValue t2)
isTFun (TVFun t1 t2) = Just (t1, t2)
isTFun _ = Nothing
isTTuple :: TValue -> Maybe (Int,[TValue])
isTTuple (TValue (TCon (TC (TCTuple n)) ts)) = Just (n, map TValue ts)
isTTuple (TVTuple ts) = Just (length ts, ts)
isTTuple _ = Nothing
isTRec :: TValue -> Maybe [(Ident, TValue)]
isTRec (TValue (TRec fs)) = Just [ (x, TValue t) | (x,t) <- fs ]
isTRec (TVRec fs) = Just fs
isTRec _ = Nothing
tvSeq :: TValue -> TValue -> TValue
tvSeq (TValue x) (TValue y) = TValue (tSeq x y)
tvSeq :: Nat' -> TValue -> TValue
tvSeq (Nat n) t = TVSeq n t
tvSeq Inf t = TVStream t
numTValue :: TValue -> Nat'
numTValue (TValue ty) =
case ty of
TCon (TC (TCNum x)) _ -> Nat x
TCon (TC TCInf) _ -> Inf
_ -> panic "Cryptol.Eval.Value.numTValue" [ "Not a numeric type:", show ty ]
toNumTValue :: Nat' -> TValue
toNumTValue (Nat n) = TValue (TCon (TC (TCNum n)) [])
toNumTValue Inf = TValue (TCon (TC TCInf) [])
finTValue :: TValue -> Integer
finTValue tval =
case numTValue tval of
finNat' :: Nat' -> Integer
finNat' n' =
case n' of
Nat x -> x
Inf -> panic "Cryptol.Eval.Value.finTValue" [ "Unexpected `inf`" ]
Inf -> panic "Cryptol.Eval.Value.finNat'" [ "Unexpected `inf`" ]
-- Values ----------------------------------------------------------------------
-- | width, value
-- Invariant: The value must be within the range 0 .. 2^width-1
data BV = BV !Integer !Integer deriving (Generic)
instance NFData BV where rnf = genericRnf
data BV = BV !Integer !Integer deriving (Generic, NFData)
-- | Smart constructor for 'BV's that checks for the width limit
mkBv :: Integer -> Integer -> BV
@ -101,20 +88,34 @@ data GenValue b w
| VStream [GenValue b w] -- @ [inf]a @
| VFun (GenValue b w -> GenValue b w) -- functions
| VPoly (TValue -> GenValue b w) -- polymorphic values (kind *)
deriving (Generic)
instance (NFData b, NFData w) => NFData (GenValue b w) where rnf = genericRnf
| VNumPoly (Nat' -> GenValue b w) -- polymorphic values (kind #)
deriving (Generic, NFData)
type Value = GenValue Bool BV
-- | An evaluated type.
-- | An evaluated type of kind *.
-- These types do not contain type variables, type synonyms, or type functions.
newtype TValue = TValue { tValTy :: Type } deriving (Generic)
data TValue
= TVBit
| TVSeq Integer TValue
| TVStream TValue -- ^ [inf]t
| TVTuple [TValue]
| TVRec [(Ident, TValue)]
| TVFun TValue TValue
deriving (Generic, NFData)
instance NFData TValue where rnf = genericRnf
tValTy :: TValue -> Type
tValTy tv =
case tv of
TVBit -> tBit
TVSeq n t -> tSeq (tNum n) (tValTy t)
TVStream t -> tSeq tInf (tValTy t)
TVTuple ts -> tTuple (map tValTy ts)
TVRec fs -> tRec [ (f, tValTy t) | (f, t) <- fs ]
TVFun t1 t2 -> tFun (tValTy t1) (tValTy t2)
instance Show TValue where
showsPrec p (TValue v) = showsPrec p v
showsPrec p v = showsPrec p (tValTy v)
-- Pretty Printing -------------------------------------------------------------
@ -149,6 +150,7 @@ ppValue opts = loop
)
VFun _ -> text "<function>"
VPoly _ -> text "<polymorphic value>"
VNumPoly _ -> text "<polymorphic value>"
ppWordSeq ws =
case ws of
@ -242,9 +244,13 @@ word n i = VWord (mkBv n i)
lam :: (GenValue b w -> GenValue b w) -> GenValue b w
lam = VFun
-- | A type lambda that expects a @Type@.
-- | A type lambda that expects a @Type@ of kind *.
tlam :: (TValue -> GenValue b w) -> GenValue b w
tlam = VPoly
tlam = VPoly
-- | A type lambda that expects a @Type@ of kind #.
nlam :: (Nat' -> GenValue b w) -> GenValue b w
nlam = VNumPoly
-- | Generate a stream.
toStream :: [GenValue b w] -> GenValue b w
@ -259,8 +265,8 @@ boolToWord = VWord . packWord
-- | Construct either a finite sequence, or a stream. In the finite case,
-- record whether or not the elements were bits, to aid pretty-printing.
toSeq :: TValue -> TValue -> [GenValue b w] -> GenValue b w
toSeq len elty vals = case numTValue len of
toSeq :: Nat' -> TValue -> [GenValue b w] -> GenValue b w
toSeq len elty vals = case len of
Nat n -> toFinSeq elty (genericTake n vals)
Inf -> toStream vals
@ -271,8 +277,8 @@ toSeq len elty vals = case numTValue len of
--
-- NOTE: do not use this constructor in the case where the thing may be a
-- finite, but recursive, sequence.
toPackedSeq :: TValue -> TValue -> [Value] -> Value
toPackedSeq len elty vals = case numTValue len of
toPackedSeq :: Nat' -> TValue -> [Value] -> Value
toPackedSeq len elty vals = case len of
-- finite sequence, pack a word if the elements are bits.
Nat _ | isTBit elty -> boolToWord (map fromVBit vals)
@ -332,6 +338,12 @@ fromVPoly val = case val of
VPoly f -> f
_ -> evalPanic "fromVPoly" ["not a polymorphic value"]
-- | Extract a polymorphic function from a value.
fromVNumPoly :: GenValue b w -> (Nat' -> GenValue b w)
fromVNumPoly val = case val of
VNumPoly f -> f
_ -> evalPanic "fromVNumPoly" ["not a polymorphic value"]
-- | Extract a tuple from a value.
fromVTuple :: GenValue b w -> [GenValue b w]
fromVTuple val = case val of

5
src/Cryptol/ModuleSystem/Base.hs
View File

@ -82,11 +82,6 @@ renameModule :: P.Module PName
-> ModuleM (IfaceDecls,R.NamingEnv,P.Module Name)
renameModule m = do
(decls,menv) <- importIfaces (map thing (P.mImports m))
let (es,ws) = R.checkNamingEnv menv
renamerWarnings ws
unless (null es) (renamerErrors es)
(declsEnv,rm) <- rename (thing (mName m)) menv (R.renameModule m)
return (decls,declsEnv,rm)

26
src/Cryptol/ModuleSystem/Env.hs
View File

@ -7,10 +7,10 @@
-- Portability : portable
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.ModuleSystem.Env where
#ifndef RELOCATABLE
@ -38,7 +38,7 @@ import System.FilePath ((</>), normalise, joinPath, splitPath, takeDirectory)
import qualified Data.List as List
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
@ -56,15 +56,11 @@ data ModuleEnv = ModuleEnv
, meSolverConfig :: T.SolverConfig
, meCoreLint :: CoreLint
, meSupply :: !Supply
} deriving (Generic)
instance NFData ModuleEnv where rnf = genericRnf
} deriving (Generic, NFData)
data CoreLint = NoCoreLint -- ^ Don't run core lint
| CoreLint -- ^ Run core lint
deriving (Generic)
instance NFData CoreLint where rnf = genericRnf
deriving (Generic, NFData)
resetModuleEnv :: ModuleEnv -> ModuleEnv
resetModuleEnv env = env
@ -186,11 +182,9 @@ qualifiedEnv me = fold $
newtype LoadedModules = LoadedModules
{ getLoadedModules :: [LoadedModule]
} deriving (Show, Generic)
} deriving (Show, Generic, NFData)
-- ^ Invariant: All the dependencies of any module `m` must precede `m` in the list.
instance NFData LoadedModules where rnf = genericRnf
instance Monoid LoadedModules where
mempty = LoadedModules []
mappend l r = LoadedModules
@ -201,9 +195,7 @@ data LoadedModule = LoadedModule
, lmFilePath :: FilePath
, lmInterface :: Iface
, lmModule :: T.Module
} deriving (Show, Generic)
instance NFData LoadedModule where rnf = genericRnf
} deriving (Show, Generic, NFData)
isLoaded :: ModName -> LoadedModules -> Bool
isLoaded mn lm = any ((mn ==) . lmName) (getLoadedModules lm)
@ -244,9 +236,7 @@ data DynamicEnv = DEnv
{ deNames :: R.NamingEnv
, deDecls :: [T.DeclGroup]
, deEnv :: EvalEnv
} deriving (Generic)
instance NFData DynamicEnv where rnf = genericRnf
} deriving (Generic, NFData)
instance Monoid DynamicEnv where
mempty = DEnv

19
src/Cryptol/ModuleSystem/Interface.hs
View File

@ -6,9 +6,10 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.ModuleSystem.Interface (
Iface(..)
@ -28,7 +29,7 @@ import Cryptol.Utils.Ident (ModName)
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
@ -39,17 +40,13 @@ data Iface = Iface
{ ifModName :: !ModName
, ifPublic :: IfaceDecls
, ifPrivate :: IfaceDecls
} deriving (Show, Generic)
instance NFData Iface where rnf = genericRnf
} deriving (Show, Generic, NFData)
data IfaceDecls = IfaceDecls
{ ifTySyns :: Map.Map Name IfaceTySyn
, ifNewtypes :: Map.Map Name IfaceNewtype
, ifDecls :: Map.Map Name IfaceDecl
} deriving (Show, Generic)
instance NFData IfaceDecls where rnf = genericRnf
} deriving (Show, Generic, NFData)
instance Monoid IfaceDecls where
mempty = IfaceDecls Map.empty Map.empty Map.empty
@ -78,9 +75,7 @@ data IfaceDecl = IfaceDecl
, ifDeclInfix :: Bool
, ifDeclFixity :: Maybe Fixity
, ifDeclDoc :: Maybe String
} deriving (Show, Generic)
instance NFData IfaceDecl where rnf = genericRnf
} deriving (Show, Generic, NFData)
mkIfaceDecl :: Decl -> IfaceDecl
mkIfaceDecl d = IfaceDecl

15
src/Cryptol/ModuleSystem/Monad.hs
View File

@ -7,6 +7,7 @@
-- Portability : portable
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.ModuleSystem.Monad where
@ -34,7 +35,7 @@ import Data.Maybe (isJust)
import MonadLib
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
@ -44,9 +45,7 @@ import Prelude.Compat
data ImportSource
= FromModule P.ModName
| FromImport (Located P.Import)
deriving (Show,Generic)
instance NFData ImportSource where rnf = genericRnf
deriving (Show, Generic, NFData)
instance Eq ImportSource where
(==) = (==) `on` importedModule
@ -208,9 +207,7 @@ duplicateModuleName name path1 path2 =
data ModuleWarning
= TypeCheckWarnings [(Range,T.Warning)]
| RenamerWarnings [RenamerWarning]
deriving (Show,Generic)
instance NFData ModuleWarning where rnf = genericRnf
deriving (Show, Generic, NFData)
instance PP ModuleWarning where
ppPrec _ w = case w of
@ -280,7 +277,7 @@ runModuleT :: Monad m
=> ModuleEnv
-> ModuleT m a
-> m (Either ModuleError (a, ModuleEnv), [ModuleWarning])
runModuleT env m =
runModuleT env m =
runWriterT
$ runExceptionT
$ runStateT env
@ -444,5 +441,3 @@ getSolverConfig :: ModuleM T.SolverConfig
getSolverConfig = ModuleT $ do
me <- get
return (meSolverConfig me)

65
src/Cryptol/ModuleSystem/Name.hs
View File

@ -7,11 +7,13 @@
-- Portability : portable
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
-- for the instances of RunM and BaseM
{-# LANGUAGE UndecidableInstances #-}
@ -22,6 +24,7 @@ module Cryptol.ModuleSystem.Name (
, nameIdent
, nameInfo
, nameLoc
, nameFixity
, asPrim
, cmpNameLexical
, cmpNameDisplay
@ -34,7 +37,6 @@ module Cryptol.ModuleSystem.Name (
-- ** Unique Supply
, FreshM(..), nextUniqueM
, SupplyT(), runSupplyT
, SupplyM(), runSupplyM
, Supply(), emptySupply, nextUnique
-- ** PrimMap
@ -43,12 +45,13 @@ module Cryptol.ModuleSystem.Name (
, lookupPrimType
) where
import Cryptol.Parser.AST( Fixity(..) )
import Cryptol.Parser.Position (Range,Located(..))
import Cryptol.Utils.Ident
import Cryptol.Utils.Panic
import Cryptol.Utils.PP
import Control.DeepSeq.Generics
import Control.DeepSeq
import Control.Monad.Fix (MonadFix(mfix))
import qualified Data.Map as Map
import qualified Data.Monoid as M
@ -65,7 +68,7 @@ data NameInfo = Declared !ModName
-- ^ This name refers to a declaration from this module
| Parameter
-- ^ This name is a parameter (function or type)
deriving (Eq,Show,Generic)
deriving (Eq, Show, Generic, NFData)
data Name = Name { nUnique :: {-# UNPACK #-} !Int
-- ^ INVARIANT: this field uniquely identifies a name for one
@ -78,9 +81,14 @@ data Name = Name { nUnique :: {-# UNPACK #-} !Int
, nIdent :: !Ident
-- ^ The name of the identifier
, nFixity :: !(Maybe Fixity)
-- ^ The associativity and precedence level of
-- infix operators. 'Nothing' indicates an
-- ordinary prefix operator.
, nLoc :: !Range
-- ^ Where this name was defined
} deriving (Show,Generic)
} deriving (Show, Generic, NFData)
instance Eq Name where
a == b = compare a b == EQ
@ -89,9 +97,6 @@ instance Eq Name where
instance Ord Name where
compare a b = compare (nUnique a) (nUnique b)
instance NFData NameInfo where rnf = genericRnf
instance NFData Name where rnf = genericRnf
-- | Compare two names lexically.
cmpNameLexical :: Name -> Name -> Ordering
cmpNameLexical l r =
@ -155,6 +160,8 @@ instance PP Name where
ppPrec _ = ppPrefixName
instance PPName Name where
ppNameFixity n = fmap (\(Fixity a i) -> (a,i)) $ nameFixity n
ppInfixName n @ Name { .. }
| isInfixIdent nIdent = ppName n
| otherwise = panic "Name" [ "Non-infix name used infix"
@ -178,6 +185,9 @@ nameInfo = nInfo
nameLoc :: Name -> Range
nameLoc = nLoc
nameFixity :: Name -> Maybe Fixity
nameFixity = nFixity
asPrim :: Name -> Maybe Ident
asPrim Name { .. }
| nInfo == Declared preludeName = Just nIdent
@ -201,9 +211,6 @@ instance FreshM m => FreshM (ReaderT i m) where
instance FreshM m => FreshM (StateT i m) where
liftSupply f = lift (liftSupply f)
instance FreshM SupplyM where
liftSupply f = SupplyM (liftSupply f)
instance Monad m => FreshM (SupplyT m) where
liftSupply f = SupplyT $
do s <- get
@ -249,36 +256,13 @@ instance RunM m (a,Supply) r => RunM (SupplyT m) a (Supply -> r) where
instance MonadFix m => MonadFix (SupplyT m) where
mfix f = SupplyT (mfix (unSupply . f))
newtype SupplyM a = SupplyM (SupplyT Id a)
deriving (Functor,Applicative,Monad,MonadFix)
runSupplyM :: Supply -> SupplyM a -> (a,Supply)
runSupplyM s m = runM m s
instance RunM SupplyM a (Supply -> (a,Supply)) where
runM (SupplyM m) s = runM m s
{-# INLINE runM #-}
instance BaseM SupplyM SupplyM where
inBase = id
{-# INLINE inBase #-}
instance M.Monoid a => M.Monoid (SupplyM a) where
mempty = return mempty
mappend a b = do x <- a
y <- b
return (mappend x y)
-- | Retrieve the next unique from the supply.
nextUniqueM :: FreshM m => m Int
nextUniqueM = liftSupply nextUnique
data Supply = Supply !Int
deriving (Show,Generic)
instance NFData Supply where rnf = genericRnf
deriving (Show, Generic, NFData)
-- | This should only be used once at library initialization, and threaded
-- through the rest of the session. The supply is started at 0x1000 to leave us
@ -296,8 +280,8 @@ nextUnique (Supply n) = s' `seq` (n,s')
-- Name Construction -----------------------------------------------------------
-- | Make a new name for a declaration.
mkDeclared :: ModName -> Ident -> Range -> Supply -> (Name,Supply)
mkDeclared m nIdent nLoc s =
mkDeclared :: ModName -> Ident -> Maybe Fixity -> Range -> Supply -> (Name,Supply)
mkDeclared m nIdent nFixity nLoc s =
let (nUnique,s') = nextUnique s
nInfo = Declared m
in (Name { .. }, s')
@ -306,6 +290,7 @@ mkDeclared m nIdent nLoc s =
mkParameter :: Ident -> Range -> Supply -> (Name,Supply)
mkParameter nIdent nLoc s =
let (nUnique,s') = nextUnique s
nFixity = Nothing
in (Name { nInfo = Parameter, .. }, s')
@ -314,9 +299,7 @@ mkParameter nIdent nLoc s =
-- | A mapping from an identifier defined in some module to its real name.
data PrimMap = PrimMap { primDecls :: Map.Map Ident Name
, primTypes :: Map.Map Ident Name
} deriving (Show, Generic)
instance NFData PrimMap where rnf = genericRnf
} deriving (Show, Generic, NFData)
lookupPrimDecl, lookupPrimType :: Ident -> PrimMap -> Name

92
src/Cryptol/ModuleSystem/NamingEnv.hs
View File

@ -6,15 +6,15 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.ModuleSystem.NamingEnv where
import Cryptol.ModuleSystem.Interface
@ -26,11 +26,12 @@ import Cryptol.Utils.Panic (panic)
import Data.List (nub)
import Data.Maybe (catMaybes,fromMaybe)
import qualified Data.Map as Map
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import MonadLib (runId,Id)
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
@ -40,15 +41,13 @@ import Prelude.Compat
-- XXX The fixity environment should be removed, and Name should include fixity
-- information.
data NamingEnv = NamingEnv { neExprs :: Map.Map PName [Name]
data NamingEnv = NamingEnv { neExprs :: !(Map.Map PName [Name])
-- ^ Expr renaming environment
, neTypes :: Map.Map PName [Name]
, neTypes :: !(Map.Map PName [Name])
-- ^ Type renaming environment
, neFixity:: Map.Map Name Fixity
, neFixity:: !(Map.Map Name Fixity)
-- ^ Expression-level fixity environment
} deriving (Show, Generic)
instance NFData NamingEnv where rnf = genericRnf
} deriving (Show, Generic, NFData)
instance Monoid NamingEnv where
mempty =
@ -68,6 +67,11 @@ instance Monoid NamingEnv where
, neTypes = Map.unionsWith merge (map neTypes envs)
, neFixity = Map.unions (map neFixity envs) }
{-# INLINE mempty #-}
{-# INLINE mappend #-}
{-# INLINE mconcat #-}
-- | Merge two name maps, collapsing cases where the entries are the same, and
-- producing conflicts otherwise.
merge :: [Name] -> [Name] -> [Name]
@ -170,25 +174,44 @@ data InModule a = InModule !ModName a
-- | Generate a 'NamingEnv' using an explicit supply.
namingEnv' :: BindsNames a => a -> Supply -> (NamingEnv,Supply)
namingEnv' a supply = runSupplyM supply (namingEnv a)
namingEnv' a supply = runId (runSupplyT supply (runBuild (namingEnv a)))
newtype BuildNamingEnv = BuildNamingEnv { runBuild :: SupplyT Id NamingEnv }
instance Monoid BuildNamingEnv where
mempty = BuildNamingEnv (pure mempty)
mappend (BuildNamingEnv a) (BuildNamingEnv b) = BuildNamingEnv $
do x <- a
y <- b
return (mappend x y)
mconcat bs = BuildNamingEnv $
do ns <- sequence (map runBuild bs)
return (mconcat ns)
-- | Things that define exported names.
class BindsNames a where
namingEnv :: a -> SupplyM NamingEnv
namingEnv :: a -> BuildNamingEnv
instance BindsNames NamingEnv where
namingEnv = return
namingEnv env = BuildNamingEnv (return env)
{-# INLINE namingEnv #-}
instance BindsNames a => BindsNames (Maybe a) where
namingEnv = foldMap namingEnv
{-# INLINE namingEnv #-}
instance BindsNames a => BindsNames [a] where
namingEnv = foldMap namingEnv
{-# INLINE namingEnv #-}
-- | Generate a type renaming environment from the parameters that are bound by
-- this schema.
instance BindsNames (Schema PName) where
namingEnv (Forall ps _ _ _) = foldMap namingEnv ps
{-# INLINE namingEnv #-}
-- | Interpret an import in the context of an interface, to produce a name
@ -240,14 +263,15 @@ 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 { .. }) =
namingEnv (ImportIface imp Iface { .. }) = BuildNamingEnv $
return (interpImport imp ifPublic)
{-# INLINE namingEnv #-}
-- | Introduce the name
-- | Introduce the name
instance BindsNames (InModule (Bind PName)) where
namingEnv (InModule ns b) =
namingEnv (InModule ns b) = BuildNamingEnv $
do let Located { .. } = bName b
n <- liftSupply (mkDeclared ns (getIdent thing) srcRange)
n <- liftSupply (mkDeclared ns (getIdent thing) (bFixity b) srcRange)
let fixity = case bFixity b of
Just f -> mempty { neFixity = Map.singleton n f }
@ -257,7 +281,7 @@ instance BindsNames (InModule (Bind PName)) where
-- | Generate the naming environment for a type parameter.
instance BindsNames (TParam PName) where
namingEnv TParam { .. } =
namingEnv TParam { .. } = BuildNamingEnv $
do let range = fromMaybe emptyRange tpRange
n <- liftSupply (mkParameter (getIdent tpName) range)
return (singletonT tpName n)
@ -274,20 +298,20 @@ instance BindsNames (InModule (TopDecl PName)) where
case td of
Decl d -> namingEnv (InModule ns (tlValue d))
TDNewtype d -> namingEnv (InModule ns (tlValue d))
Include _ -> return mempty
Include _ -> mempty
instance BindsNames (InModule (Newtype PName)) where
namingEnv (InModule ns Newtype { .. }) =
namingEnv (InModule ns Newtype { .. }) = BuildNamingEnv $
do let Located { .. } = nName
tyName <- liftSupply (mkDeclared ns (getIdent thing) srcRange)
eName <- liftSupply (mkDeclared ns (getIdent thing) srcRange)
tyName <- liftSupply (mkDeclared ns (getIdent thing) Nothing srcRange)
eName <- liftSupply (mkDeclared ns (getIdent thing) Nothing srcRange)
return (singletonT thing tyName `mappend` singletonE thing eName)
-- | The naming environment for a single declaration.
instance BindsNames (InModule (Decl PName)) where
namingEnv (InModule pfx d) = case d of
DBind b ->
do n <- mkName (bName b)
DBind b -> BuildNamingEnv $
do n <- mkName (bName b) (bFixity b)
return (singletonE (thing (bName b)) n `mappend` fixity n b)
DSignature ns _sig -> foldMap qualBind ns
@ -299,15 +323,15 @@ instance BindsNames (InModule (Decl PName)) where
where
mkName ln =
liftSupply (mkDeclared pfx (getIdent (thing ln)) (srcRange ln))
mkName ln fx =
liftSupply (mkDeclared pfx (getIdent (thing ln)) fx (srcRange ln))
qualBind ln =
do n <- mkName ln
qualBind ln = BuildNamingEnv $
do n <- mkName ln Nothing
return (singletonE (thing ln) n)
qualType ln =
do n <- mkName ln
qualType ln = BuildNamingEnv $
do n <- mkName ln Nothing
return (singletonT (thing ln) n)
fixity n b =

259
src/Cryptol/ModuleSystem/Renamer.hs
View File

@ -6,14 +6,13 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.ModuleSystem.Renamer (
NamingEnv(), shadowing
, BindsNames(..), InModule(..), namingEnv'
@ -36,11 +35,13 @@ import Cryptol.Utils.Ident (packIdent,packInfix)
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.PP
import MonadLib hiding (mapM)
import qualified Data.Map as Map
import qualified Data.Foldable as F
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import MonadLib hiding (mapM, mapM_)
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
@ -74,11 +75,12 @@ data RenamerError
| InvalidConstraint (Type PName) NameDisp
-- ^ When it's not possible to produce a Prop from a Type.
| MalformedConstraint (Located (Type PName)) NameDisp
-- ^ When a constraint appears within another constraint
deriving (Show,Generic)
| MalformedBuiltin (Type PName) PName NameDisp
-- ^ When a builtin type/type-function is used incorrectly.
instance NFData RenamerError where rnf = genericRnf
| BoundReservedType PName (Maybe Range) Doc NameDisp
-- ^ When a builtin type is named in a binder.
deriving (Show, Generic, NFData)
instance PP RenamerError where
ppPrec _ e = case e of
@ -122,18 +124,21 @@ instance PP RenamerError where
hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) (getLoc ty))
4 (fsep [ pp ty, text "is not a valid constraint" ])
MalformedConstraint t disp -> fixNameDisp disp $
hang (text "[error] at" <+> pp (srcRange t))
4 (sep [ quotes (pp (thing t))
, text "is not a valid argument to a constraint" ])
MalformedBuiltin ty pn disp -> fixNameDisp disp $
hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) (getLoc ty))
4 (fsep [ text "invalid use of built-in type", pp pn
, text "in type", pp ty ])
BoundReservedType n loc src disp -> fixNameDisp disp $
hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) loc)
4 (fsep [ text "built-in type", quotes (pp n), text "shadowed in", src ])
-- Warnings --------------------------------------------------------------------
data RenamerWarning
= SymbolShadowed Name [Name] NameDisp
deriving (Show,Generic)
instance NFData RenamerWarning where rnf = genericRnf
deriving (Show, Generic, NFData)
instance PP RenamerWarning where
ppPrec _ (SymbolShadowed new originals disp) = fixNameDisp disp $
@ -159,18 +164,14 @@ data RO = RO
, roDisp :: !NameDisp
}
data Out = Out
{ oWarnings :: [RenamerWarning]
, oErrors :: [RenamerError]
} deriving (Show)
instance Monoid Out where
mempty = Out [] []
mappend l r = Out (oWarnings l `mappend` oWarnings r)
(oErrors l `mappend` oErrors r)
data RW = RW
{ rwWarnings :: !(Seq.Seq RenamerWarning)
, rwErrors :: !(Seq.Seq RenamerError)
, rwSupply :: !Supply
}
newtype RenameM a = RenameM
{ unRenameM :: ReaderT RO (WriterT Out SupplyM) a }
{ unRenameM :: ReaderT RO (StateT RW Lift) a }
instance Monoid a => Monoid (RenameM a) where
{-# INLINE mempty #-}
@ -200,25 +201,36 @@ instance Monad RenameM where
{-# INLINE (>>=) #-}
m >>= k = RenameM (unRenameM m >>= unRenameM . k)
instance FreshM RenameM where
liftSupply f = RenameM $ sets $ \ RW { .. } ->
let (a,s') = f rwSupply
rw' = RW { rwSupply = s', .. }
in a `seq` rw' `seq` (a, rw')
runRenamer :: Supply -> ModName -> NamingEnv -> RenameM a
-> (Either [RenamerError] (a,Supply),[RenamerWarning])
runRenamer s ns env m = (res,oWarnings out)
runRenamer s ns env m = (res,F.toList (rwWarnings rw))
where
((a,out),s') = runM (unRenameM m) RO { roLoc = emptyRange
, roNames = env
, roMod = ns
, roDisp = neverQualifyMod ns
`mappend` toNameDisp env
} s
(a,rw) = runM (unRenameM m) RO { roLoc = emptyRange
, roNames = env
, roMod = ns
, roDisp = neverQualifyMod ns
`mappend` toNameDisp env
}
RW { rwErrors = Seq.empty
, rwWarnings = Seq.empty
, rwSupply = s
}
res | null (oErrors out) = Right (a,s')
| otherwise = Left (oErrors out)
res | Seq.null (rwErrors rw) = Right (a,rwSupply rw)
| otherwise = Left (F.toList (rwErrors rw))
record :: (NameDisp -> RenamerError) -> RenameM ()
record f = RenameM $
do RO { .. } <- ask
put mempty { oErrors = [f roDisp] }
RW { .. } <- get
set RW { rwErrors = rwErrors Seq.|> f roDisp, .. }
curLoc :: RenameM Range
curLoc = RenameM (roLoc `fmap` ask)
@ -253,12 +265,13 @@ data EnvCheck = CheckAll -- ^ Check for overlap and shadowing
-- | Shadow the current naming environment with some more names. The boolean
-- parameter indicates whether or not to check for shadowing.
shadowNames' :: BindsNames env => EnvCheck -> env -> RenameM a -> RenameM a
shadowNames' check names m = RenameM $ do
env <- inBase (namingEnv names)
ro <- ask
put (checkEnv (roDisp ro) check env (roNames ro))
let ro' = ro { roNames = env `shadowing` roNames ro }
local ro' (unRenameM m)
shadowNames' check names m = do
do env <- liftSupply (namingEnv' names)
RenameM $
do ro <- ask
env' <- sets (checkEnv (roDisp ro) check env (roNames ro))
let ro' = ro { roNames = env' `shadowing` roNames ro }
local ro' (unRenameM m)
shadowNamesNS :: BindsNames (InModule env) => env -> RenameM a -> RenameM a
shadowNamesNS names m =
@ -269,43 +282,47 @@ shadowNamesNS names m =
-- | Generate warnings when the left environment shadows things defined in
-- the right. Additionally, generate errors when two names overlap in the
-- left environment.
checkEnv :: NameDisp -> EnvCheck -> NamingEnv -> NamingEnv -> Out
checkEnv _ CheckNone _ _ = mempty
checkEnv disp check l r = Map.foldlWithKey (step neExprs) mempty (neExprs l)
`mappend` Map.foldlWithKey (step neTypes) mempty (neTypes l)
checkEnv :: NameDisp -> EnvCheck -> NamingEnv -> NamingEnv -> RW -> (NamingEnv,RW)
checkEnv disp check l r rw
| check == CheckNone = (l',rw)
| otherwise = (l',rw'')
where
step prj acc k ns = acc `mappend` mempty
{ oWarnings =
if check == CheckAll
then case Map.lookup k (prj r) of
Nothing -> []
Just os -> [SymbolShadowed (head ns) os disp]
l' = l { neExprs = es, neTypes = ts }
else []
, oErrors = containsOverlap disp ns
}
(rw',es) = Map.mapAccumWithKey (step neExprs) rw (neExprs l)
(rw'',ts) = Map.mapAccumWithKey (step neTypes) rw' (neTypes l)
step prj acc k ns = (acc', [head ns])
where
acc' = acc
{ rwWarnings =
if check == CheckAll
then case Map.lookup k (prj r) of
Nothing -> rwWarnings acc
Just os -> rwWarnings acc Seq.|> SymbolShadowed (head ns) os disp
else rwWarnings acc
, rwErrors = rwErrors acc Seq.>< containsOverlap disp ns
}
-- | Check the RHS of a single name rewrite for conflicting sources.
containsOverlap :: NameDisp -> [Name] -> [RenamerError]
containsOverlap _ [_] = []
containsOverlap :: NameDisp -> [Name] -> Seq.Seq RenamerError
containsOverlap _ [_] = Seq.empty
containsOverlap _ [] = panic "Renamer" ["Invalid naming environment"]
containsOverlap disp ns = [OverlappingSyms ns disp]
containsOverlap disp ns = Seq.singleton (OverlappingSyms ns disp)
-- | Throw errors for any names that overlap in a rewrite environment.
checkNamingEnv :: NamingEnv -> ([RenamerError],[RenamerWarning])
checkNamingEnv env = (out, [])
checkNamingEnv env = (F.toList out, [])
where
out = Map.foldr check outTys (neExprs env)
outTys = Map.foldr check mempty (neTypes env)
disp = toNameDisp env
check ns acc = containsOverlap disp ns ++ acc
supply :: SupplyM a -> RenameM a
supply m = RenameM (inBase m)
check ns acc = containsOverlap disp ns Seq.>< acc
-- Renaming --------------------------------------------------------------------
@ -315,7 +332,7 @@ class Rename f where
renameModule :: Module PName -> RenameM (NamingEnv,Module Name)
renameModule m =
do env <- supply (namingEnv m)
do env <- liftSupply (namingEnv' m)
-- NOTE: we explicitly hide shadowing errors here, by using shadowNames'
decls' <- shadowNames' CheckOverlap env (traverse rename (mDecls m))
return (env,m { mDecls = decls' })
@ -423,9 +440,9 @@ renameType pn =
-- | Assuming an error has been recorded already, construct a fake name that's
-- not expected to make it out of the renamer.
mkFakeName :: PName -> RenameM Name
mkFakeName pn = RenameM $
do ro <- ask
inBase (liftSupply (mkParameter (getIdent pn) (roLoc ro)))
mkFakeName pn =
do ro <- RenameM ask
liftSupply (mkParameter (getIdent pn) (roLoc ro))
-- | Rename a schema, assuming that none of its type variables are already in
-- scope.
@ -436,7 +453,12 @@ instance Rename Schema where
-- into scope.
renameSchema :: Schema PName -> RenameM (NamingEnv,Schema Name)
renameSchema (Forall ps p ty loc) =
do env <- supply (namingEnv ps)
do -- check that the parameters don't shadow any built-in types
let reserved = filter (isReserved . tpName) ps
mkErr tp = BoundReservedType (tpName tp) (tpRange tp) (text "schema")
unless (null reserved) (mapM_ (record . mkErr) reserved)
env <- liftSupply (namingEnv' ps)
s' <- shadowNames env $ Forall <$> traverse rename ps
<*> traverse rename p
<*> rename ty
@ -484,6 +506,13 @@ translateProp ty = go ty
CType <$> rename t
-- | Check to see if this identifier is a reserved type/type-function.
isReserved :: PName -> Bool
isReserved pn = Map.member pn tfunNames || isReservedTyCon pn
isReservedTyCon :: PName -> Bool
isReservedTyCon pn = Map.member pn tconNames
-- | Resolve fixity, then rename the resulting type.
instance Rename Type where
rename ty0 = go =<< resolveTypeFixity ty0
@ -497,17 +526,16 @@ instance Rename Type where
go TInf = return TInf
go (TUser pn ps)
| i == packIdent "inf", null ps = return TInf
| i == packIdent "Bit", null ps = return TBit
| i == packIdent "min" = TApp TCMin <$> traverse go ps
| i == packIdent "max" = TApp TCMax <$> traverse go ps
| i == packIdent "lengthFromThen" = TApp TCLenFromThen <$> traverse go ps
| i == packIdent "lengthFromThenTo" = TApp TCLenFromThenTo <$> traverse go ps
| i == packIdent "width" = TApp TCWidth <$> traverse go ps
-- all type functions
| Just (arity,fun) <- Map.lookup pn tfunNames =
do when (arity /= length ps) (record (MalformedBuiltin ty0 pn))
ps' <- traverse go ps
return (TApp fun ps')
where
i = getIdent pn
-- built-in types like Bit and inf
| Just ty <- Map.lookup pn tconNames =
rename ty
go (TUser qn ps) = TUser <$> renameType qn <*> traverse go ps
go (TApp f xs) = TApp f <$> traverse go xs
@ -608,7 +636,7 @@ lookupFixity op =
where
sym = thing op
lkp = do n <- Map.lookup (thing op) tfunNames
lkp = do (_,n) <- Map.lookup (thing op) tfunNames
(fAssoc,fLevel) <- Map.lookup n tBinOpPrec
return (n,Fixity { .. })
@ -660,7 +688,9 @@ instance Rename Expr where
EInfFrom a b -> EInfFrom<$> rename a <*> traverse rename b
EComp e' bs -> do arms' <- traverse renameArm bs
let (envs,bs') = unzip arms'
shadowNames envs (EComp <$> rename e' <*> pure bs')
-- NOTE: renameArm will generate shadowing warnings; we only
-- need to check for repeated names across multiple arms
shadowNames' CheckOverlap envs (EComp <$> rename e' <*> pure bs')
EApp f x -> EApp <$> rename f <*> rename x
EAppT f ti -> EAppT <$> rename f <*> traverse rename ti
EIf b t f -> EIf <$> rename b <*> rename t <*> rename f
@ -722,7 +752,9 @@ renameArm :: [Match PName] -> RenameM (NamingEnv,[Match Name])
renameArm (m:ms) =
do (me,m') <- renameMatch m
shadowNames me $
-- NOTE: renameMatch will generate warnings, so we don't
-- need to duplicate them here
shadowNames' CheckNone me $
do (env,rest) <- renameArm ms
-- NOTE: the inner environment shadows the outer one, for examples
@ -744,7 +776,7 @@ renameMatch (Match p e) =
renameMatch (MatchLet b) =
do ns <- getNS
be <- supply (namingEnv (InModule ns b))
be <- liftSupply (namingEnv' (InModule ns b))
b' <- shadowNames be (rename b)
return (be,MatchLet b')
@ -764,22 +796,30 @@ renamePats = loop
[] -> return (mempty, [])
patternEnv :: Pattern PName -> RenameM NamingEnv
patternEnv p0 = go p0
patternEnv = go
where
go (PVar Located { .. }) =
do n <- supply (liftSupply (mkParameter (getIdent thing) srcRange))
do n <- liftSupply (mkParameter (getIdent thing) srcRange)
return (singletonE thing n)
go PWild = return mempty
go (PTuple ps) = foldMap go ps
go (PRecord fs) = foldMap (foldMap go) fs
go (PTuple ps) = bindVars ps
go (PRecord fs) = bindVars (map value fs)
go (PList ps) = foldMap go ps
go (PTyped p ty) = go p `mappend` typeEnv ty
go (PSplit a b) = go a `mappend` go b
go (PLocated p loc) = withLoc loc (go p)
typeEnv (TFun a b) = typeEnv a `mappend` typeEnv b
typeEnv (TSeq a b) = typeEnv a `mappend` typeEnv b
bindVars [] = return mempty
bindVars (p:ps) =
do env <- go p
shadowNames env $
do rest <- bindVars ps
return (env `mappend` rest)
typeEnv (TFun a b) = bindTypes [a,b]
typeEnv (TSeq a b) = bindTypes [a,b]
typeEnv TBit = return mempty
typeEnv TNum{} = return mempty
@ -791,14 +831,18 @@ patternEnv p0 = go p0
case mb of
-- The type is already bound, don't introduce anything.
Just _ -> foldMap typeEnv ps
Just _ -> bindTypes ps
Nothing
-- Just ignore reserved names, as they'll be resolved when renaming.
| isReserved pn ->
bindTypes ps
-- The type isn't bound, and has no parameters, so it names a portion
-- of the type of the pattern.
| null ps ->
do loc <- curLoc
n <- supply (liftSupply (mkParameter (getIdent pn) loc))
n <- liftSupply (mkParameter (getIdent pn) loc)
return (singletonT pn n)
-- This references a type synonym that's not in scope. Record an
@ -806,16 +850,24 @@ patternEnv p0 = go p0
| otherwise ->
do loc <- curLoc
record (UnboundType (Located loc pn))
n <- supply (liftSupply (mkParameter (getIdent pn) loc))
n <- liftSupply (mkParameter (getIdent pn) loc)
return (singletonT pn n)
typeEnv (TApp _ ts) = foldMap typeEnv ts
typeEnv (TRecord fs) = foldMap (foldMap typeEnv) fs
typeEnv (TTuple ts) = foldMap typeEnv ts
typeEnv (TApp _ ts) = bindTypes ts
typeEnv (TRecord fs) = bindTypes (map value fs)
typeEnv (TTuple ts) = bindTypes ts
typeEnv TWild = return mempty
typeEnv (TLocated ty loc) = withLoc loc (typeEnv ty)
typeEnv (TParens ty) = typeEnv ty
typeEnv (TInfix a _ _ b) = typeEnv a `mappend` typeEnv b
typeEnv (TInfix a _ _ b) = bindTypes [a,b]
bindTypes [] = return mempty
bindTypes (t:ts) =
do env' <- typeEnv t
shadowNames env' $
do res <- bindTypes ts
return (env' `mappend` res)
instance Rename Match where
rename m = case m of
@ -824,9 +876,12 @@ instance Rename Match where
instance Rename TySyn where
rename (TySyn n ps ty) =
shadowNames ps $ TySyn <$> rnLocated renameType n
<*> traverse rename ps
<*> rename ty
do when (isReserved (thing n))
(record (BoundReservedType (thing n) (getLoc n) (text "type synonym")))
shadowNames ps $ TySyn <$> rnLocated renameType n
<*> traverse rename ps
<*> rename ty
-- Utilities -------------------------------------------------------------------

63
src/Cryptol/Parser.y
View File

@ -7,6 +7,7 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Trustworthy #-}
module Cryptol.Parser
( parseModule
@ -34,10 +35,9 @@ import Control.Monad(liftM2,msum)
import Cryptol.Prims.Syntax
import Cryptol.Parser.AST
import Cryptol.Parser.Position
import Cryptol.Parser.LexerUtils
import Cryptol.Parser.LexerUtils hiding (mkIdent)
import Cryptol.Parser.ParserUtils
import Cryptol.Parser.Unlit(PreProc(..), guessPreProc)
import Cryptol.Utils.Ident (packIdent,packInfix)
import Paths_cryptol
}
@ -266,8 +266,9 @@ mbDoc :: { Maybe (Located String) }
decl :: { Decl PName }
: vars_comma ':' schema { at (head $1,$3) $ DSignature (reverse $1) $3 }
| apat '=' expr { at ($1,$3) $ DPatBind $1 $3 }
| name apats '=' expr { at ($1,$4) $
| ipat '=' expr { at ($1,$3) $ DPatBind $1 $3 }
| '(' op ')' '=' expr { at ($1,$5) $ DPatBind (PVar $2) $5 }
| var apats '=' expr { at ($1,$4) $
DBind $ Bind { bName = $1
, bParams = reverse $2
, bDef = at $4 (Located emptyRange (DExpr $4))
@ -279,7 +280,8 @@ decl :: { Decl PName }
, bDoc = Nothing
} }
| apat op apat '=' expr { at ($1,$5) $
| apat other_op apat '=' expr
{ at ($1,$5) $
DBind $ Bind { bName = $2
, bParams = [$1,$3]
, bDef = at $5 (Located emptyRange (DExpr $5))
@ -300,7 +302,7 @@ decl :: { Decl PName }
| 'infix' NUM ops {% mkFixity NonAssoc $2 (reverse $3) }
let_decl :: { Decl PName }
: 'let' apat '=' expr { at ($2,$4) $ DPatBind $2 $4 }
: 'let' ipat '=' expr { at ($2,$4) $ DPatBind $2 $4 }
| 'let' name apats '=' expr { at ($2,$5) $
DBind $ Bind { bName = $2
, bParams = reverse $3
@ -331,9 +333,13 @@ var :: { LPName }
: name { $1 }
| '(' op ')' { $2 }
apats :: { [Pattern PName] }
: apat { [$1] }
| apats apat { $2 : $1 }
apats :: { [Pattern PName] }
: apat { [$1] }
| apats1 apat { $2 : $1 }
apats1 :: { [Pattern PName] }
: apat { [$1] }
| apats1 apat { $2 : $1 }
decls :: { [Decl PName] }
: decl ';' { [$1] }
@ -386,25 +392,30 @@ iexpr :: { Expr PName }
expr10 :: { Expr PName }
: aexprs { mkEApp $1 }
| '-' expr10 %prec NEG { at ($1,$2) $ EApp (at $1 (EVar (mkUnqual (packIdent "negate")))) $2 }
| '~' expr10 { at ($1,$2) $ EApp (at $1 (EVar (mkUnqual (packIdent "complement")))) $2 }
| '-' expr10 %prec NEG { at ($1,$2) $ EApp (at $1 (EVar (mkUnqual "negate"))) $2 }
| '~' expr10 { at ($1,$2) $ EApp (at $1 (EVar (mkUnqual "complement"))) $2 }
qop :: { LPName }
: op { $1 }
| QOP { let Token (Op (Other ns i)) _ = thing $1
in mkQual (mkModName ns) (packInfix i) A.<$ $1 }
in mkQual (mkModName ns) (mkInfix (T.toStrict i)) A.<$ $1 }
op :: { LPName }
: OP { let Token (Op (Other [] str)) _ = thing $1
in mkUnqual (packInfix str) A.<$ $1 }
: other_op { $1 }
-- special cases for operators that are re-used elsewhere
| '*' { Located $1 $ mkUnqual $ packInfix "*" }
| '+' { Located $1 $ mkUnqual $ packInfix "+" }
| '-' { Located $1 $ mkUnqual $ packInfix "-" }
| '~' { Located $1 $ mkUnqual $ packInfix "~" }
| '^^' { Located $1 $ mkUnqual $ packInfix "^^" }
| '#' { Located $1 $ mkUnqual $ packInfix "#" }
| '*' { Located $1 $ mkUnqual $ mkInfix "*" }
| '+' { Located $1 $ mkUnqual $ mkInfix "+" }
| '-' { Located $1 $ mkUnqual $ mkInfix "-" }
| '~' { Located $1 $ mkUnqual $ mkInfix "~" }
| '^^' { Located $1 $ mkUnqual $ mkInfix "^^" }
| '#' { Located $1 $ mkUnqual $ mkInfix "#" }
other_op :: { LPName }
: OP { let Token (Op (Other [] str)) _ = thing $1
in mkUnqual (mkInfix (T.toStrict str)) A.<$ $1 }
ops :: { [LPName] }
: op { [$1] }
@ -618,11 +629,11 @@ field_types :: { [Named (Type PName)] }
ident :: { Located Ident }
: IDENT { let Token (Ident _ str) _ = thing $1
in $1 { thing = packIdent str } }
| 'x' { Located { srcRange = $1, thing = packIdent "x" }}
| 'private' { Located { srcRange = $1, thing = packIdent "private" } }
| 'as' { Located { srcRange = $1, thing = packIdent "as" } }
| 'hiding' { Located { srcRange = $1, thing = packIdent "hiding" } }
in $1 { thing = mkIdent (T.toStrict str) } }
| 'x' { Located { srcRange = $1, thing = mkIdent "x" }}
| 'private' { Located { srcRange = $1, thing = mkIdent "private" } }
| 'as' { Located { srcRange = $1, thing = mkIdent "as" } }
| 'hiding' { Located { srcRange = $1, thing = mkIdent "hiding" } }
name :: { LPName }
@ -638,7 +649,7 @@ modName :: { Located ModName }
qname :: { Located PName }
: name { $1 }
| QIDENT { let Token (Ident ns i) _ = thing $1
in mkQual (mkModName ns) (packIdent i) A.<$ $1 }
in mkQual (mkModName ns) (mkIdent (T.toStrict i)) A.<$ $1 }
help_name :: { Located PName }
: qname { $1 }

189
src/Cryptol/Parser/AST.hs
View File

@ -7,12 +7,14 @@
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.Parser.AST
( -- * Names
Ident, mkIdent, mkInfix, isInfixIdent, nullIdent, identText
@ -26,7 +28,7 @@ module Cryptol.Parser.AST
, Schema(..)
, TParam(..)
, Kind(..)
, Type(..)
, Type(..), tconNames
, Prop(..)
-- * Declarations
@ -78,10 +80,11 @@ import qualified Data.Set as Set
import Data.List(intersperse)
import Data.Bits(shiftR)
import Data.Maybe (catMaybes)
import qualified Data.Map as Map
import Numeric(showIntAtBase)
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
@ -104,9 +107,8 @@ newtype Program name = Program [TopDecl name]
data Module name = Module { mName :: Located ModName
, mImports :: [Located Import]
, mDecls :: [TopDecl name]
} deriving (Show, Generic)
} deriving (Show, Generic, NFData)
instance NFData name => NFData (Module name) where rnf = genericRnf
modRange :: Module name -> Range
modRange m = rCombs $ catMaybes
@ -120,9 +122,7 @@ modRange m = rCombs $ catMaybes
data TopDecl name = Decl (TopLevel (Decl name))
| TDNewtype (TopLevel (Newtype name))
| Include (Located FilePath)
deriving (Show,Generic)
instance NFData name => NFData (TopDecl name) where rnf = genericRnf
deriving (Show, Generic, NFData)
data Decl name = DSignature [Located name] (Schema name)
| DFixity !Fixity [Located name]
@ -131,17 +131,13 @@ data Decl name = DSignature [Located name] (Schema name)
| DPatBind (Pattern name) (Expr name)
| DType (TySyn name)
| DLocated (Decl name) Range
deriving (Eq,Show,Generic)
instance NFData name => NFData (Decl name) where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
-- | An import declaration.
data Import = Import { iModule :: !ModName
, iAs :: Maybe ModName
, iSpec :: Maybe ImportSpec
} deriving (Eq,Show,Generic)
instance NFData Import where rnf = genericRnf
} deriving (Eq, Show, Generic, NFData)
-- | The list of names following an import.
--
@ -150,14 +146,10 @@ instance NFData Import where rnf = genericRnf
-- present.
data ImportSpec = Hiding [Ident]
| Only [Ident]
deriving (Eq,Show,Generic)
instance NFData ImportSpec where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
data TySyn n = TySyn (Located n) [TParam n] (Type n)
deriving (Eq,Show,Generic)
instance NFData name => NFData (TySyn name) where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
{- | Bindings. Notes:
@ -180,23 +172,17 @@ data Bind name = Bind { bName :: Located name -- ^ Defined thing
, bPragmas :: [Pragma] -- ^ Optional pragmas
, bMono :: Bool -- ^ Is this a monomorphic binding
, bDoc :: Maybe String -- ^ Optional doc string
} deriving (Eq,Show,Generic)
instance NFData name => NFData (Bind name) where rnf = genericRnf
} deriving (Eq, Show, Generic, NFData)
type LBindDef = Located (BindDef PName)
data BindDef name = DPrim
| DExpr (Expr name)
deriving (Eq,Show,Generic)
instance NFData name => NFData (BindDef name) where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
data Fixity = Fixity { fAssoc :: !Assoc
, fLevel :: !Int
} deriving (Eq,Show,Generic)
instance NFData Fixity where rnf = genericRnf
} deriving (Eq, Show, Generic, NFData)
data FixityCmp = FCError
| FCLeft
@ -219,16 +205,12 @@ defaultFixity = Fixity LeftAssoc 100
data Pragma = PragmaNote String
| PragmaProperty
deriving (Eq,Show,Generic)
instance NFData Pragma where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
data Newtype name = Newtype { nName :: Located name -- ^ Type name
, nParams :: [TParam name] -- ^ Type params
, nBody :: [Named (Type name)] -- ^ Constructor
} deriving (Eq,Show,Generic)
instance NFData name => NFData (Newtype name) where rnf = genericRnf
} deriving (Eq, Show, Generic, NFData)
-- | Input at the REPL, which can either be an expression or a @let@
-- statement.
@ -239,22 +221,17 @@ data ReplInput name = ExprInput (Expr name)
-- | Export information for a declaration.
data ExportType = Public
| Private
deriving (Eq,Show,Ord,Generic)
instance NFData ExportType where rnf = genericRnf
deriving (Eq, Show, Ord, Generic, NFData)
data TopLevel a = TopLevel { tlExport :: ExportType
, tlDoc :: Maybe (Located String)
, tlValue :: a
} deriving (Show,Generic,Functor,Foldable,Traversable)
instance NFData a => NFData (TopLevel a) where rnf = genericRnf
}
deriving (Show, Generic, NFData, Functor, Foldable, Traversable)
data ExportSpec name = ExportSpec { eTypes :: Set.Set name
, eBinds :: Set.Set name
} deriving (Show,Generic)
instance NFData name => NFData (ExportSpec name) where rnf = genericRnf
} deriving (Show, Generic, NFData)
instance Ord name => Monoid (ExportSpec name) where
mempty = ExportSpec { eTypes = mempty, eBinds = mempty }
@ -289,16 +266,12 @@ data NumInfo = BinLit Int -- ^ n-digit binary literal
| HexLit Int -- ^ n-digit hex literal
| CharLit -- ^ character literal
| PolyLit Int -- ^ polynomial literal
deriving (Eq,Show,Generic)
instance NFData NumInfo where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
-- | Literals.
data Literal = ECNum Integer NumInfo -- ^ @0x10@ (HexLit 2)
| ECString String -- ^ @\"hello\"@
deriving (Eq,Show,Generic)
instance NFData Literal where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
data Expr n = EVar n -- ^ @ x @
| ELit Literal -- ^ @ 0x10 @
@ -320,15 +293,11 @@ data Expr n = EVar n -- ^ @ x @
| EParens (Expr n) -- ^ @ (e) @ (Removed by Fixity)
| EInfix (Expr n) (Located n) Fixity (Expr n)-- ^ @ a + b @ (Removed by Fixity)
deriving (Eq,Show,Generic)
instance NFData name => NFData (Expr name) where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
data TypeInst name = NamedInst (Named (Type name))
| PosInst (Type name)
deriving (Eq,Show,Generic)
instance NFData name => NFData (TypeInst name) where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
{- | Selectors are used for projecting from various components.
Each selector has an option spec to specify the shape of the thing
@ -347,15 +316,11 @@ data Selector = TupleSel Int (Maybe Int)
| ListSel Int (Maybe Int)
-- ^ List selection.
-- Optionally specifies the length of the list.
deriving (Eq,Show,Ord,Generic)
instance NFData Selector where rnf = genericRnf
deriving (Eq, Show, Ord, Generic, NFData)
data Match name = Match (Pattern name) (Expr name) -- ^ p <- e
| MatchLet (Bind name)
deriving (Eq,Show,Generic)
instance NFData name => NFData (Match name) where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
data Pattern n = PVar (Located n) -- ^ @ x @
| PWild -- ^ @ _ @
@ -365,50 +330,44 @@ data Pattern n = PVar (Located n) -- ^ @ x @
| PTyped (Pattern n) (Type n) -- ^ @ x : [8] @
| PSplit (Pattern n) (Pattern n)-- ^ @ (x # y) @
| PLocated (Pattern n) Range -- ^ Location information
deriving (Eq,Show,Generic)
instance NFData name => NFData (Pattern name) where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
data Named a = Named { name :: Located Ident, value :: a }
deriving (Eq,Show,Foldable,Traversable,Generic,Functor)
instance NFData a => NFData (Named a) where rnf = genericRnf
deriving (Eq, Show, Foldable, Traversable, Generic, NFData, Functor)
data Schema n = Forall [TParam n] [Prop n] (Type n) (Maybe Range)
deriving (Eq,Show,Generic)
deriving (Eq, Show, Generic, NFData)
instance NFData name => NFData (Schema name) where rnf = genericRnf
data Kind = KNum | KType
deriving (Eq,Show,Generic)
instance NFData Kind where rnf = genericRnf
data Kind = KNum | KType
deriving (Eq, Show, Generic, NFData)
data TParam n = TParam { tpName :: n
, tpKind :: Maybe Kind
, tpRange :: Maybe Range
}
deriving (Eq,Show,Generic)
deriving (Eq, Show, Generic, NFData)
instance NFData name => NFData (TParam name) where rnf = genericRnf
data Type n = TFun (Type n) (Type n) -- ^ @[8] -> [8]@
| TSeq (Type n) (Type n) -- ^ @[8] a@
| TBit -- ^ @Bit@
| TNum Integer -- ^ @10@
| TChar Char -- ^ @'a'@
| TInf -- ^ @inf@
| TUser n [Type n] -- ^ A type variable or synonym
| TApp TFun [Type n] -- ^ @2 + x@
| TRecord [Named (Type n)]-- ^ @{ x : [8], y : [32] }@
| TTuple [Type n] -- ^ @([8], [32])@
| TWild -- ^ @_@, just some type.
| TLocated (Type n) Range -- ^ Location information
| TParens (Type n) -- ^ @ (ty) @
| TInfix (Type n) (Located n) Fixity (Type n) -- ^ @ ty + ty @
deriving (Eq, Show, Generic, NFData)
data Type n = TFun (Type n) (Type n) -- ^ @[8] -> [8]@
| TSeq (Type n) (Type n) -- ^ @[8] a@
| TBit -- ^ @Bit@
| TNum Integer -- ^ @10@
| TChar Char -- ^ @'a'@
| TInf -- ^ @inf@
| TUser n [Type n] -- ^ A type variable or synonym
| TApp TFun [Type n] -- ^ @2 + x@
| TRecord [Named (Type n)]-- ^ @{ x : [8], y : [32] }@
| TTuple [Type n] -- ^ @([8], [32])@
| TWild -- ^ @_@, just some type.
| TLocated (Type n) Range -- ^ Location information
| TParens (Type n) -- ^ @ (ty) @
| TInfix (Type n) (Located n) Fixity (Type n) -- ^ @ ty + ty @
deriving (Eq,Show,Generic)
instance NFData name => NFData (Type name) where rnf = genericRnf
tconNames :: Map.Map PName (Type PName)
tconNames = Map.fromList
[ (mkUnqual (packIdent "Bit"), TBit)
, (mkUnqual (packIdent "inf"), TInf)
]
data Prop n = CFin (Type n) -- ^ @ fin x @
| CEqual (Type n) (Type n) -- ^ @ x == 10 @
@ -416,11 +375,8 @@ data Prop n = CFin (Type n) -- ^ @ fin x @
| CArith (Type n) -- ^ @ Arith a @
| CCmp (Type n) -- ^ @ Cmp a @
| CLocated (Prop n) Range -- ^ Location information
| CType (Type n) -- ^ After parsing
deriving (Eq,Show,Generic)
instance NFData name => NFData (Prop name) where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
--------------------------------------------------------------------------------
-- Note: When an explicit location is missing, we could use the sub-components
@ -472,6 +428,8 @@ instance AddLoc (Pattern name) where
instance HasLoc (Pattern name) where
getLoc (PLocated _ r) = Just r
getLoc (PTyped r _) = getLoc r
getLoc (PVar x) = getLoc x
getLoc _ = Nothing
instance HasLoc (Bind name) where
@ -732,12 +690,9 @@ instance (Show name, PPName name) => PP (Expr name) where
$$ text "")
-- infix applications
-- XXX why did we need this case?
-- EApp (EApp (EVar f) x) y ->
-- wrap n 3 $ withNameEnv $ \ env ->
-- let NameInfo qn isInfix = getNameInfo f env
-- in if isInfix then ppPrec 3 x <+> ppQName qn <+> ppPrec 3 y
-- else ppQName qn <+> ppPrec 3 x <+> ppPrec 3 y
_ | Just ifix <- isInfix expr ->
optParens (n > 2)
$ ppInfix 2 isInfix ifix
EApp _ _ -> let (e, es) = asEApps expr in
wrap n 3 (ppPrec 3 e <+> fsep (map (ppPrec 4) es))
@ -747,6 +702,11 @@ instance (Show name, PPName name) => PP (Expr name) where
EParens e -> parens (pp e)
EInfix e1 op _ e2 -> wrap n 0 (pp e1 <+> ppInfixName (thing op) <+> pp e2)
where
isInfix (EApp (EApp (EVar ieOp) ieLeft) ieRight) = do
(ieAssoc,iePrec) <- ppNameFixity ieOp
return Infix { .. }
isInfix _ = Nothing
instance PP Selector where
ppPrec _ sel =
@ -830,18 +790,17 @@ instance PPName name => PP (Type name) where
TSeq t1 t2 -> optParens (n > 3)
$ brackets (pp t1) <> ppPrec 3 t2
-- TApp _ [_,_]
-- | Just tinf <- isTInfix ty
-- -> optParens (n > 2)
-- $ ppInfix 2 isTInfix tinf
_ | Just tinf <- isInfix ty ->
optParens (n > 2)
$ ppInfix 2 isInfix tinf
TApp f ts -> optParens (n > 2)
$ pp f <+> fsep (map (ppPrec 4) ts)
TUser f [] -> pp f
TUser f [] -> ppPrefixName f
TUser f ts -> optParens (n > 2)
$ pp f <+> fsep (map (ppPrec 4) ts)
$ ppPrefixName f <+> fsep (map (ppPrec 4) ts)
TFun t1 t2 -> optParens (n > 1)
$ sep [ppPrec 2 t1 <+> text "->", ppPrec 1 t2]
@ -851,7 +810,13 @@ instance PPName name => PP (Type name) where
TParens t -> parens (pp t)
TInfix t1 o _ t2 -> optParens (n > 0)
$ sep [ppPrec 2 t1 <+> pp o, ppPrec 1 t2]
$ sep [ppPrec 2 t1 <+> ppInfixName o, ppPrec 1 t2]
where
isInfix (TApp ieOp [ieLeft, ieRight]) = do
(ieAssoc,iePrec) <- ppNameFixity ieOp
return Infix { .. }
isInfix _ = Nothing
instance PPName name => PP (Prop name) where
ppPrec n prop =

16
src/Cryptol/Parser/Lexer.x
View File

@ -6,7 +6,7 @@
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
--
-- At present Alex generates code with too many warnings.
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE OverloadedStrings #-}
@ -63,8 +63,9 @@ $unitick = \x7
<comment> {
\*+\/ { endComent }
[^\*]+ { addToComment }
[^\*\/]+ { addToComment }
\* { addToComment }
\/ { addToComment }
\n { addToComment }
}
@ -117,10 +118,10 @@ $white+ { emit $ White Space }
"primitive" { emit $ KW KW_primitive }
@num2 { emitS (numToken 2 . drop 2) }
@num8 { emitS (numToken 8 . drop 2) }
@num10 { emitS (numToken 10 . drop 0) }
@num16 { emitS (numToken 16 . drop 2) }
@num2 { emitS (numToken 2 . Text.drop 2) }
@num8 { emitS (numToken 8 . Text.drop 2) }
@num10 { emitS (numToken 10 . Text.drop 0) }
@num16 { emitS (numToken 16 . Text.drop 2) }
"_" { emit $ Sym Underscore }
@id { mkIdent }
@ -245,6 +246,3 @@ primLexer cfg cs = run inp Normal
-- vim: ft=haskell
}

59
src/Cryptol/Parser/LexerUtils.hs
View File

@ -6,9 +6,10 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.Parser.LexerUtils where
import Cryptol.Parser.Position
@ -18,13 +19,12 @@ import Cryptol.Utils.Panic
import Data.Char(toLower,generalCategory,isAscii,ord,isSpace)
import qualified Data.Char as Char
import Data.List(foldl')
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import Data.Word(Word8)
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
data Config = Config
{ cfgSource :: !FilePath -- ^ File that we are working on
@ -169,20 +169,20 @@ mkIdent :: Action
mkIdent cfg p s z = (Just Located { srcRange = r, thing = Token t s }, z)
where
r = Range { from = p, to = moves p s, source = cfgSource cfg }
t = Ident [] (T.unpack s)
t = Ident [] s
mkQualIdent :: Action
mkQualIdent cfg p s z = (Just Located { srcRange = r, thing = Token t s}, z)
where
r = Range { from = p, to = moves p s, source = cfgSource cfg }
t = Ident (map T.unpack ns) (T.unpack i)
t = Ident ns i
(ns,i) = splitQual s
mkQualOp :: Action
mkQualOp cfg p s z = (Just Located { srcRange = r, thing = Token t s}, z)
where
r = Range { from = p, to = moves p s, source = cfgSource cfg }
t = Op (Other (map T.unpack ns) (T.unpack i))
t = Op (Other ns i)
(ns,i) = splitQual s
emit :: TokenT -> Action
@ -190,8 +190,8 @@ emit t cfg p s z = (Just Located { srcRange = r, thing = Token t s }, z)
where r = Range { from = p, to = moves p s, source = cfgSource cfg }
emitS :: (String -> TokenT) -> Action
emitS t cfg p s z = emit (t (T.unpack s)) cfg p s z
emitS :: (Text -> TokenT) -> Action
emitS t cfg p s z = emit (t s) cfg p s z
-- | Split out the prefix and name part of an identifier/operator.
@ -213,10 +213,10 @@ splitQual t =
--------------------------------------------------------------------------------
numToken :: Integer -> String -> TokenT
numToken rad ds = Num (toVal ds) (fromInteger rad) (length ds)
numToken :: Integer -> Text -> TokenT
numToken rad ds = Num (toVal ds) (fromInteger rad) (fromIntegral (T.length ds))
where
toVal = foldl' (\x c -> rad * x + toDig c) 0
toVal = T.foldl' (\x c -> rad * x + toDig c) 0
toDig = if rad == 16 then fromHexDigit else fromDecDigit
fromDecDigit :: Char -> Integer
@ -355,20 +355,14 @@ virt cfg pos x = Located { srcRange = Range
--------------------------------------------------------------------------------
data Token = Token { tokenType :: TokenT, tokenText :: Text }
deriving (Show, Generic)
instance NFData Token where rnf = genericRnf
deriving (Show, Generic, NFData)
-- | Virtual tokens, inserted by layout processing.
data TokenV = VCurlyL| VCurlyR | VSemi
deriving (Eq,Show,Generic)
instance NFData TokenV where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
data TokenW = BlockComment | LineComment | Space | DocStr
deriving (Eq,Show,Generic)
instance NFData TokenW where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
data TokenKW = KW_Arith
| KW_Bit
@ -402,19 +396,15 @@ data TokenKW = KW_Arith
| KW_infixr
| KW_infix
| KW_primitive
deriving (Eq,Show,Generic)
instance NFData TokenKW where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
-- | The named operators are a special case for parsing types, and 'Other' is
-- used for all other cases that lexed as an operator.
data TokenOp = Plus | Minus | Mul | Div | Exp | Mod
| Equal | LEQ | GEQ
| Complement | Hash
| Other [String] String
deriving (Eq,Show,Generic)
instance NFData TokenOp where rnf = genericRnf
| Other [T.Text] T.Text
deriving (Eq, Show, Generic, NFData)
data TokenSym = Bar
| ArrL | ArrR | FatArrR
@ -432,9 +422,7 @@ data TokenSym = Bar
| CurlyL | CurlyR
| TriL | TriR
| Underscore
deriving (Eq,Show,Generic)
instance NFData TokenSym where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
data TokenErr = UnterminatedComment
| UnterminatedString
@ -442,13 +430,11 @@ data TokenErr = UnterminatedComment
| InvalidString
| InvalidChar
| LexicalError
deriving (Eq,Show,Generic)
instance NFData TokenErr where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
data TokenT = Num Integer Int Int -- ^ value, base, number of digits
| ChrLit Char -- ^ character literal
| Ident [String] String -- ^ (qualified) identifier
| Ident [T.Text] T.Text -- ^ (qualified) identifier
| StrLit String -- ^ string literal
| KW TokenKW -- ^ keyword
| Op TokenOp -- ^ operator
@ -457,14 +443,11 @@ data TokenT = Num Integer Int Int -- ^ value, base, number of digits
| White TokenW -- ^ white space token
| Err TokenErr -- ^ error token
| EOF
deriving (Eq,Show,Generic)
instance NFData TokenT where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
instance PP Token where
ppPrec _ (Token _ s) = text (T.unpack s)
-- | Collapse characters into a single Word8, identifying ASCII, and classes of
-- unicode. This came from:
--

6
src/Cryptol/Parser/Name.hs
View File

@ -61,6 +61,12 @@ instance PP PName where
ppPrec _ = ppPrefixName
instance PPName PName where
ppNameFixity n
| isInfixIdent i = Just (NonAssoc, 0) -- FIXME?
| otherwise = Nothing
where
i = getIdent n
ppPrefixName n = optParens (isInfixIdent i) (pfx <> pp i)
where
i = getIdent n

49
src/Cryptol/Parser/NoInclude.hs
View File

@ -6,59 +6,40 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP #-}
#ifndef MIN_VERSION_directory
#define MIN_VERSION_directory(a,b,c) 0
#endif
{-# LANGUAGE RecordWildCards #-}
module Cryptol.Parser.NoInclude
( removeIncludesModule
, IncludeError(..), ppIncludeError
) where
import qualified Control.Applicative as A
import Control.DeepSeq
import qualified Control.Exception as X
import Data.Either (partitionEithers)
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.IO as T
import GHC.Generics (Generic)
import MonadLib
import System.Directory (makeAbsolute)
import System.FilePath (takeDirectory,(</>),isAbsolute)
import Cryptol.Parser (parseProgramWith)
import Cryptol.Parser.AST
import Cryptol.Parser.LexerUtils (Config(..),defaultConfig)
import Cryptol.Parser.ParserUtils
import Cryptol.Utils.PP
import Cryptol.Parser.Unlit (guessPreProc)
import qualified Control.Applicative as A
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.IO as T
import Data.Either (partitionEithers)
import MonadLib
import qualified Control.Exception as X
import System.FilePath (takeDirectory,(</>),isAbsolute)
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import System.Directory (getCurrentDirectory)
import System.FilePath (isRelative, normalise)
-- from the source of directory-1.2.2.1; included to maintain
-- backwards compatibility
makeAbsolute :: FilePath -> IO FilePath
makeAbsolute = fmap normalise . absolutize
where absolutize path
| isRelative path = fmap (</> path) getCurrentDirectory
| otherwise = return path
import Cryptol.Utils.PP
removeIncludesModule :: FilePath -> Module PName -> IO (Either [IncludeError] (Module PName))
removeIncludesModule modPath m = runNoIncM modPath (noIncludeModule m)
data IncludeError
= IncludeFailed (Located FilePath)
| IncludeParseError ParseError
| IncludeCycle [Located FilePath]
deriving (Show,Generic)
instance NFData IncludeError where rnf = genericRnf
deriving (Show, Generic, NFData)
ppIncludeError :: IncludeError -> Doc
ppIncludeError ie = case ie of

16
src/Cryptol/Parser/NoPat.hs
View File

@ -10,12 +10,13 @@
-- patterns. It also eliminates pattern bindings by de-sugaring them
-- into `Bind`. Furthermore, here we associate signatures and pragmas
-- with the names to which they belong.
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.Parser.NoPat (RemovePatterns(..),Error(..)) where
import Cryptol.Parser.AST
@ -30,7 +31,7 @@ import Data.Either(partitionEithers)
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
@ -445,9 +446,7 @@ data Error = MultipleSignatures PName [Located (Schema PName)]
| MultipleFixities PName [Range]
| FixityNoBind (Located PName)
| MultipleDocs PName [Range]
deriving (Show,Generic)
instance NFData Error where rnf = genericRnf
deriving (Show,Generic, NFData)
instance Functor NoPatM where fmap = liftM
instance Applicative NoPatM where pure = return; (<*>) = ap
@ -513,4 +512,3 @@ instance PP Error where
MultipleDocs n locs ->
text "Multiple documentation blocks given for:" <+> pp n
$$ nest 2 (vcat (map pp locs))

20
src/Cryptol/Parser/ParserUtils.hs
View File

@ -6,9 +6,12 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe, PatternGuards #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
module Cryptol.Parser.ParserUtils where
import Cryptol.Parser.AST
@ -20,7 +23,6 @@ import Cryptol.Utils.Panic
import Data.Maybe(listToMaybe,fromMaybe)
import Data.Bits(testBit,setBit)
import Data.List (intercalate)
import Control.Monad(liftM,ap,unless)
import qualified Data.Text as S
import Data.Text.Lazy (Text)
@ -28,7 +30,7 @@ import qualified Data.Text.Lazy as T
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
@ -66,9 +68,7 @@ lexerP k = P $ \cfg p (S ts) ->
data ParseError = HappyError FilePath Position (Maybe Token)
| HappyErrorMsg Range String
deriving (Show, Generic)
instance NFData ParseError where rnf = genericRnf
deriving (Show, Generic, NFData)
newtype S = S [Located Token]
@ -115,8 +115,8 @@ errorMessage r x = P $ \_ _ _ -> Left (HappyErrorMsg r x)
customError :: String -> Located Token -> ParseM a
customError x t = P $ \_ _ _ -> Left (HappyErrorMsg (srcRange t) x)
mkModName :: [String] -> ModName
mkModName strs = S.pack (intercalate "::" strs)
mkModName :: [T.Text] -> ModName
mkModName strs = T.toStrict (T.intercalate (T.pack "::") strs)
-- Note that type variables are not resolved at this point: they are tcons.
mkSchema :: [TParam PName] -> [Prop PName] -> Type PName -> Schema PName
@ -124,7 +124,7 @@ mkSchema xs ps t = Forall xs ps t Nothing
getName :: Located Token -> PName
getName l = case thing l of
Token (Ident [] x) _ -> mkUnqual (mkIdent (S.pack x))
Token (Ident [] x) _ -> mkUnqual (mkIdent (T.toStrict x))
_ -> panic "[Parser] getName" ["not an Ident:", show l]
getNum :: Located Token -> Integer

24
src/Cryptol/Parser/Position.hs
View File

@ -7,35 +7,30 @@
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.Parser.Position where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
import Cryptol.Utils.PP
data Located a = Located { srcRange :: !Range, thing :: a }
deriving (Eq,Show,Generic)
instance NFData a => NFData (Located a) where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
data Position = Position { line :: !Int, col :: !Int }
deriving (Eq,Ord,Show,Generic)
instance NFData Position where rnf = genericRnf
deriving (Eq, Ord, Show, Generic, NFData)
data Range = Range { from :: !Position
, to :: !Position
, source :: FilePath }
deriving (Eq,Show,Generic)
instance NFData Range where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
-- | An empty range.
--
@ -80,10 +75,9 @@ instance PP a => PP (Located a) where
ppPrec _ l = parens (text "at" <+> pp (srcRange l) <> comma <+> pp (thing l))
instance PPName a => PPName (Located a) where
ppPrefixName Located { .. } = ppPrefixName thing
ppInfixName Located { .. } = ppInfixName thing
ppNameFixity Located { .. } = ppNameFixity thing
ppPrefixName Located { .. } = ppPrefixName thing
ppInfixName Located { .. } = ppInfixName thing
--------------------------------------------------------------------------------

343
src/Cryptol/Prims/Eval.hs
View File

@ -26,7 +26,8 @@ import Cryptol.Utils.Panic (panic)
import Cryptol.ModuleSystem.Name (asPrim)
import Cryptol.Utils.Ident (Ident,mkIdent)
import Data.List (sortBy,transpose,genericTake,genericReplicate,genericSplitAt,genericIndex)
import Data.List (sortBy, transpose, genericTake, genericDrop,
genericReplicate, genericSplitAt, genericIndex)
import Data.Ord (comparing)
import Data.Bits (Bits(..))
@ -73,8 +74,8 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
, ("demote" , ecDemoteV)
, ("#" , tlam $ \ front ->
tlam $ \ back ->
, ("#" , nlam $ \ front ->
nlam $ \ back ->
tlam $ \ elty ->
lam $ \ l ->
lam $ \ r -> ccatV front back elty l r)
@ -86,45 +87,45 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
, ("zero" , tlam zeroV)
, ("join" , tlam $ \ parts ->
tlam $ \ each ->
, ("join" , nlam $ \ parts ->
nlam $ \ each ->
tlam $ \ a -> lam (joinV parts each a))
, ("split" , ecSplitV)
, ("splitAt" , tlam $ \ front ->
tlam $ \ back ->
, ("splitAt" , nlam $ \ front ->
nlam $ \ back ->
tlam $ \ a -> lam (splitAtV front back a))
, ("fromThen" , fromThenV)
, ("fromTo" , fromToV)
, ("fromThenTo" , fromThenToV)
, ("infFrom" , tlam $ \(finTValue -> bits) ->
lam $ \(fromWord -> first) ->
, ("infFrom" , nlam $ \(finNat' -> bits) ->
lam $ \(fromWord -> first) ->
toStream (map (word bits) [ first .. ]))
, ("infFromThen", tlam $ \(finTValue -> bits) ->
lam $ \(fromWord -> first) ->
lam $ \(fromWord -> next) ->
, ("infFromThen", nlam $ \(finNat' -> bits) ->
lam $ \(fromWord -> first) ->
lam $ \(fromWord -> next) ->
toStream [ word bits n | n <- [ first, next .. ] ])
, ("error" , tlam $ \_ ->
tlam $ \_ ->
lam $ \(fromStr -> s) -> cryUserError s)
, ("reverse" , tlam $ \a ->
, ("reverse" , nlam $ \a ->
tlam $ \b ->
lam $ \(fromSeq -> xs) -> toSeq a b (reverse xs))
, ("transpose" , tlam $ \a ->
tlam $ \b ->
, ("transpose" , nlam $ \a ->
nlam $ \b ->
tlam $ \c ->
lam $ \((map fromSeq . fromSeq) -> xs) ->
case numTValue a of
case a of
Nat 0 ->
let val = toSeq a c []
in case numTValue b of
in case b of
Nat n -> toSeq b (tvSeq a c) $ genericReplicate n val
Inf -> VStream $ repeat val
_ -> toSeq b (tvSeq a c) $ map (toSeq a c) $ transpose xs)
@ -133,19 +134,19 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
let mul !res !_ !_ 0 = res
mul res bs as n = mul (if even as then res else xor res bs)
(bs `shiftL` 1) (as `shiftR` 1) (n-1)
in tlam $ \(finTValue -> a) ->
tlam $ \(finTValue -> b) ->
lam $ \(fromWord -> x) ->
lam $ \(fromWord -> y) -> word (max 1 (a + b) - 1) (mul 0 x y b))
in nlam $ \(finNat' -> a) ->
nlam $ \(finNat' -> b) ->
lam $ \(fromWord -> x) ->
lam $ \(fromWord -> y) -> word (max 1 (a + b) - 1) (mul 0 x y b))
, ("pdiv" , tlam $ \(fromInteger . finTValue -> a) ->
tlam $ \(fromInteger . finTValue -> b) ->
, ("pdiv" , nlam $ \(fromInteger . finNat' -> a) ->
nlam $ \(fromInteger . finNat' -> b) ->
lam $ \(fromWord -> x) ->
lam $ \(fromWord -> y) -> word (toInteger a)
(fst (divModPoly x a y b)))
, ("pmod" , tlam $ \(fromInteger . finTValue -> a) ->
tlam $ \(fromInteger . finTValue -> b) ->
, ("pmod" , nlam $ \(fromInteger . finNat' -> a) ->
nlam $ \(fromInteger . finNat' -> b) ->
lam $ \(fromWord -> x) ->
lam $ \(fromWord -> y) -> word (toInteger b)
(snd (divModPoly x a y (b+1))))
@ -156,9 +157,9 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
-- | Make a numeric constant.
ecDemoteV :: Value
ecDemoteV = tlam $ \valT ->
tlam $ \bitT ->
case (numTValue valT, numTValue bitT) of
ecDemoteV = nlam $ \valT ->
nlam $ \bitT ->
case (valT, bitT) of
(Nat v, Nat bs) -> VWord (mkBv bs v)
_ -> evalPanic "Cryptol.Eval.Prim.evalConst"
["Unexpected Inf in constant."
@ -191,7 +192,7 @@ divModPoly xs xsLen ys ysLen
todoBits = map (testBit xs) (downIxes (xsLen - degree))
-- | Create a packed word
-- | Create a packed word
modExp :: Integer -- ^ bit size of the resulting word
-> Integer -- ^ base
-> Integer -- ^ exponent
@ -256,61 +257,60 @@ type BinArith = Integer -> Integer -> Integer -> Integer
arithBinary :: BinArith -> Binary
arithBinary op = loop
where
loop ty l r
loop ty l r = case ty of
| Just (len,a) <- isTSeq ty = case numTValue len of
-- words and finite sequences
TVSeq w a
| isTBit a -> VWord (mkBv w (op w (fromWord l) (fromWord r)))
| otherwise -> VSeq False (zipWith (loop a) (fromSeq l) (fromSeq r))
-- words and finite sequences
Nat w | isTBit a -> VWord (mkBv w (op w (fromWord l) (fromWord r)))
| otherwise -> VSeq False (zipWith (loop a) (fromSeq l) (fromSeq r))
-- streams
Inf -> toStream (zipWith (loop a) (fromSeq l) (fromSeq r))
-- streams
TVStream a -> toStream (zipWith (loop a) (fromSeq l) (fromSeq r))
-- functions
| Just (_,ety) <- isTFun ty =
TVFun _ ety ->
lam $ \ x -> loop ety (fromVFun l x) (fromVFun r x)
-- tuples
| Just (_,tys) <- isTTuple ty =
TVTuple tys ->
let ls = fromVTuple l
rs = fromVTuple r
in VTuple (zipWith3 loop tys ls rs)
-- records
| Just fs <- isTRec ty =
TVRec fs ->
VRecord [ (f, loop fty (lookupRecord f l) (lookupRecord f r))
| (f,fty) <- fs ]
| otherwise = evalPanic "arithBinop" ["Invalid arguments"]
_ -> evalPanic "arithBinop" ["Invalid arguments"]
arithUnary :: (Integer -> Integer) -> Unary
arithUnary op = loop
where
loop ty x
loop ty x = case ty of
| Just (len,a) <- isTSeq ty = case numTValue len of
-- words and finite sequences
TVSeq w a
| isTBit a -> VWord (mkBv w (op (fromWord x)))
| otherwise -> VSeq False (map (loop a) (fromSeq x))
-- words and finite sequences
Nat w | isTBit a -> VWord (mkBv w (op (fromWord x)))
| otherwise -> VSeq False (map (loop a) (fromSeq x))
Inf -> toStream (map (loop a) (fromSeq x))
-- infinite sequences
TVStream a -> toStream (map (loop a) (fromSeq x))
-- functions
| Just (_,ety) <- isTFun ty =
TVFun _ ety ->
lam $ \ y -> loop ety (fromVFun x y)
-- tuples
| Just (_,tys) <- isTTuple ty =
TVTuple tys ->
let as = fromVTuple x
in VTuple (zipWith loop tys as)
-- records
| Just fs <- isTRec ty =
TVRec fs ->
VRecord [ (f, loop fty (lookupRecord f x)) | (f,fty) <- fs ]
| otherwise = evalPanic "arithUnary" ["Invalid arguments"]
_ -> evalPanic "arithUnary" ["Invalid arguments"]
lg2 :: Integer -> Integer
lg2 i = case genLog i 2 of
@ -330,29 +330,18 @@ modWrap x y = x `mod` y
-- | Lexicographic ordering on two values.
lexCompare :: TValue -> Value -> Value -> Ordering
lexCompare ty l r
| isTBit ty =
compare (fromVBit l) (fromVBit r)
| Just (_,b) <- isTSeq ty, isTBit b =
compare (fromWord l) (fromWord r)
| Just (_,e) <- isTSeq ty =
zipLexCompare (repeat e) (fromSeq l) (fromSeq r)
-- tuples
| Just (_,etys) <- isTTuple ty =
zipLexCompare etys (fromVTuple l) (fromVTuple r)
-- records
| Just fields <- isTRec ty =
let tys = map snd (sortBy (comparing fst) fields)
ls = map snd (sortBy (comparing fst) (fromVRecord l))
rs = map snd (sortBy (comparing fst) (fromVRecord r))
in zipLexCompare tys ls rs
| otherwise = evalPanic "lexCompare" ["invalid type"]
lexCompare ty l r =
case ty of
TVBit -> compare (fromVBit l) (fromVBit r)
TVSeq _ TVBit -> compare (fromWord l) (fromWord r)
TVSeq _ e -> zipLexCompare (repeat e) (fromSeq l) (fromSeq r)
TVTuple etys -> zipLexCompare etys (fromVTuple l) (fromVTuple r)
TVRec fields ->
let tys = map snd (sortBy (comparing fst) fields)
ls = map snd (sortBy (comparing fst) (fromVRecord l))
rs = map snd (sortBy (comparing fst) (fromVRecord r))
in zipLexCompare tys ls rs
_ -> evalPanic "lexCompare" ["invalid type"]
-- XXX the lists are expected to be of the same length, as this should only be
@ -394,42 +383,42 @@ funCmp op =
-- Logic -----------------------------------------------------------------------
zeroV :: TValue -> Value
zeroV ty
zeroV ty = case ty of
-- bits
| isTBit ty =
TVBit ->
VBit False
-- sequences
| Just (n,ety) <- isTSeq ty =
case numTValue n of
Nat w | isTBit ety -> word w 0
| otherwise -> toSeq n ety (replicate (fromInteger w) (zeroV ety))
Inf -> toSeq n ety (repeat (zeroV ety))
-- finite sequences
TVSeq w ety
| isTBit ety -> word w 0
| otherwise -> toFinSeq ety (replicate (fromInteger w) (zeroV ety))
-- infinite sequences
TVStream ety -> toStream (repeat (zeroV ety))
-- functions
| Just (_,bty) <- isTFun ty =
TVFun _ bty ->
lam (\ _ -> zeroV bty)
-- tuples
| Just (_,tys) <- isTTuple ty =
TVTuple tys ->
VTuple (map zeroV tys)
-- records
| Just fields <- isTRec ty =
TVRec fields ->
VRecord [ (f,zeroV fty) | (f,fty) <- fields ]
| otherwise = evalPanic "zeroV" ["invalid type for zero"]
-- | Join a sequence of sequences into a single sequence.
joinV :: TValue -> TValue -> TValue -> Value -> Value
joinV :: Nat' -> Nat' -> TValue -> Value -> Value
joinV parts each a val =
let len = toNumTValue (numTValue parts `nMul` numTValue each)
let len = parts `nMul` each
in toSeq len a (concatMap fromSeq (fromSeq val))
splitAtV :: TValue -> TValue -> TValue -> Value -> Value
splitAtV :: Nat' -> Nat' -> TValue -> Value -> Value
splitAtV front back a val =
case numTValue back of
case back of
-- Remember that words are big-endian in cryptol, so the first component
-- needs to be shifted, and the second component just needs to be masked.
@ -445,7 +434,7 @@ splitAtV front back a val =
aBit = isTBit a
leftWidth = case numTValue front of
leftWidth = case front of
Nat n -> n
_ -> evalPanic "splitAtV" ["invalid `front` len"]
@ -453,12 +442,12 @@ splitAtV front back a val =
-- | Split implementation.
ecSplitV :: Value
ecSplitV =
tlam $ \ parts ->
tlam $ \ each ->
nlam $ \ parts ->
nlam $ \ each ->
tlam $ \ a ->
lam $ \ val ->
let mkChunks f = map (toFinSeq a) $ f $ fromSeq val
in case (numTValue parts, numTValue each) of
in case (parts, each) of
(Nat p, Nat e) -> VSeq False $ mkChunks (finChunksOf p e)
(Inf , Nat e) -> toStream $ mkChunks (infChunksOf e)
_ -> evalPanic "splitV" ["invalid type arguments to split"]
@ -475,7 +464,7 @@ finChunksOf parts each xs = let (as,bs) = genericSplitAt each xs
in as : finChunksOf (parts - 1) each bs
ccatV :: TValue -> TValue -> TValue -> Value -> Value -> Value
ccatV :: Nat' -> Nat' -> TValue -> Value -> Value -> Value
ccatV _front _back (isTBit -> True) (VWord (BV i x)) (VWord (BV j y)) =
VWord (BV (i + j) (shiftL x (fromInteger j) + y))
ccatV front back elty l r =
@ -485,74 +474,64 @@ ccatV front back elty l r =
logicBinary :: (forall a. Bits a => a -> a -> a) -> Binary
logicBinary op = loop
where
loop ty l r
| isTBit ty = VBit (op (fromVBit l) (fromVBit r))
| Just (len,aty) <- isTSeq ty =
loop ty l r = case ty of
TVBit -> VBit (op (fromVBit l) (fromVBit r))
-- words or finite sequences
TVSeq w aty
| isTBit aty -> VWord (BV w (op (fromWord l) (fromWord r)))
-- We assume that bitwise ops do not need re-masking
| otherwise -> VSeq False (zipWith (loop aty) (fromSeq l)
(fromSeq r))
case numTValue len of
-- streams
TVStream aty -> toStream (zipWith (loop aty) (fromSeq l) (fromSeq r))
-- words or finite sequences
Nat w | isTBit aty -> VWord (BV w (op (fromWord l) (fromWord r)))
-- We assume that bitwise ops do not need re-masking
| otherwise -> VSeq False (zipWith (loop aty) (fromSeq l)
(fromSeq r))
-- streams
Inf -> toStream (zipWith (loop aty) (fromSeq l) (fromSeq r))
| Just (_,etys) <- isTTuple ty =
TVTuple etys ->
let ls = fromVTuple l
rs = fromVTuple r
in VTuple (zipWith3 loop etys ls rs)
| Just (_,bty) <- isTFun ty =
TVFun _ bty ->
lam $ \ a -> loop bty (fromVFun l a) (fromVFun r a)
| Just fields <- isTRec ty =
TVRec fields ->
VRecord [ (f,loop fty a b) | (f,fty) <- fields
, let a = lookupRecord f l
b = lookupRecord f r
]
| otherwise = evalPanic "logicBinary" ["invalid logic type"]
logicUnary :: (forall a. Bits a => a -> a) -> Unary
logicUnary op = loop
where
loop ty val
| isTBit ty = VBit (op (fromVBit val))
loop ty val = case ty of
TVBit -> VBit (op (fromVBit val))
| Just (len,ety) <- isTSeq ty =
-- words or finite sequences
TVSeq w ety
| isTBit ety -> VWord (mkBv w (op (fromWord val)))
| otherwise -> VSeq False (map (loop ety) (fromSeq val))
case numTValue len of
-- streams
TVStream ety -> toStream (map (loop ety) (fromSeq val))
-- words or finite sequences
Nat w | isTBit ety -> VWord (mkBv w (op (fromWord val)))
| otherwise -> VSeq False (map (loop ety) (fromSeq val))
-- streams
Inf -> toStream (map (loop ety) (fromSeq val))
| Just (_,etys) <- isTTuple ty =
TVTuple etys ->
let as = fromVTuple val
in VTuple (zipWith loop etys as)
| Just (_,bty) <- isTFun ty =
TVFun _ bty ->
lam $ \ a -> loop bty (fromVFun val a)
| Just fields <- isTRec ty =
TVRec fields ->
VRecord [ (f,loop fty a) | (f,fty) <- fields, let a = lookupRecord f val ]
| otherwise = evalPanic "logicUnary" ["invalid logic type"]
logicShift :: (Integer -> Integer -> Int -> Integer)
logicShift :: (Integer -> Integer -> Integer -> Integer)
-- ^ The function may assume its arguments are masked.
-- It is responsible for masking its result if needed.
-> (TValue -> TValue -> [Value] -> Int -> [Value])
-> (Nat' -> TValue -> [Value] -> Integer -> [Value])
-> Value
logicShift opW opS
= tlam $ \ a ->
= nlam $ \ a ->
tlam $ \ _ ->
tlam $ \ c ->
lam $ \ l ->
@ -560,62 +539,61 @@ logicShift opW opS
if isTBit c
then -- words
let BV w i = fromVWord l
in VWord (BV w (opW w i (fromInteger (fromWord r))))
in VWord (BV w (opW w i (fromWord r)))
else toSeq a c (opS a c (fromSeq l) (fromInteger (fromWord r)))
else toSeq a c (opS a c (fromSeq l) (fromWord r))
-- Left shift for words.
shiftLW :: Integer -> Integer -> Int -> Integer
shiftLW :: Integer -> Integer -> Integer -> Integer
shiftLW w ival by
| toInteger by >= w = 0
| otherwise = mask w (shiftL ival by)
| by >= w = 0
| otherwise = mask w (shiftL ival (fromInteger by))
shiftLS :: TValue -> TValue -> [Value] -> Int -> [Value]
shiftLS :: Nat' -> TValue -> [Value] -> Integer -> [Value]
shiftLS w ety vs by =
case numTValue w of
case w of
Nat len
| toInteger by < len -> genericTake len (drop by vs ++ repeat (zeroV ety))
| otherwise -> genericReplicate len (zeroV ety)
Inf -> drop by vs
| by < len -> genericTake len (genericDrop by vs ++ repeat (zeroV ety))
| otherwise -> genericReplicate len (zeroV ety)
Inf -> genericDrop by vs
shiftRW :: Integer -> Integer -> Int -> Integer
shiftRW :: Integer -> Integer -> Integer -> Integer
shiftRW w i by
| toInteger by >= w = 0
| otherwise = shiftR i by
| by >= w = 0
| otherwise = shiftR i (fromInteger by)
shiftRS :: TValue -> TValue -> [Value] -> Int -> [Value]
shiftRS :: Nat' -> TValue -> [Value] -> Integer -> [Value]
shiftRS w ety vs by =
case numTValue w of
case w of
Nat len
| toInteger by < len -> genericTake len (replicate by (zeroV ety) ++ vs)
| otherwise -> genericReplicate len (zeroV ety)
Inf -> replicate by (zeroV ety) ++ vs
| by < len -> genericTake len (genericReplicate by (zeroV ety) ++ vs)
| otherwise -> genericReplicate len (zeroV ety)
Inf -> genericReplicate by (zeroV ety) ++ vs
-- XXX integer doesn't implement rotateL, as there's no bit bound
rotateLW :: Integer -> Integer -> Int -> Integer
rotateLW :: Integer -> Integer -> Integer -> Integer
rotateLW 0 i _ = i
rotateLW w i by = mask w $ (i `shiftL` b) .|. (i `shiftR` (fromInteger w - b))
where b = by `mod` fromInteger w
where b = fromInteger (by `mod` w)
rotateLS :: TValue -> TValue -> [Value] -> Int -> [Value]
rotateLS :: Nat' -> TValue -> [Value] -> Integer -> [Value]
rotateLS w _ vs at =
case numTValue w of
Nat len -> let at' = toInteger at `mod` len
case w of
Nat len -> let at' = at `mod` len
(ls,rs) = genericSplitAt at' vs
in rs ++ ls
_ -> panic "Cryptol.Eval.Prim.rotateLS" [ "unexpected infinite sequence" ]
-- XXX integer doesn't implement rotateR, as there's no bit bound
rotateRW :: Integer -> Integer -> Int -> Integer
rotateRW :: Integer -> Integer -> Integer -> Integer
rotateRW 0 i _ = i
rotateRW w i by = mask w $ (i `shiftR` b) .|. (i `shiftL` (fromInteger w - b))
where b = by `mod` fromInteger w
where b = fromInteger (by `mod` w)
rotateRS :: TValue -> TValue -> [Value] -> Int -> [Value]
rotateRS :: Nat' -> TValue -> [Value] -> Integer -> [Value]
rotateRS w _ vs at =
case numTValue w of
Nat len -> let at' = toInteger at `mod` len
case w of
Nat len -> let at' = at `mod` len
(ls,rs) = genericSplitAt (len - at') vs
in rs ++ ls
_ -> panic "Cryptol.Eval.Prim.rotateRS" [ "unexpected infinite sequence" ]
@ -626,14 +604,14 @@ rotateRS w _ vs at =
-- | Indexing operations that return one element.
indexPrimOne :: (Maybe Integer -> [Value] -> Integer -> Value) -> Value
indexPrimOne op =
tlam $ \ n ->
nlam $ \ n ->
tlam $ \ _a ->
tlam $ \ _i ->
nlam $ \ _i ->
lam $ \ l ->
lam $ \ r ->
let vs = fromSeq l
ix = fromWord r
in op (fromNat (numTValue n)) vs ix
in op (fromNat n) vs ix
indexFront :: Maybe Integer -> [Value] -> Integer -> Value
indexFront mblen vs ix =
@ -652,15 +630,15 @@ indexBack mblen vs ix =
-- | Indexing operations that return many elements.
indexPrimMany :: (Maybe Integer -> [Value] -> [Integer] -> [Value]) -> Value
indexPrimMany op =
tlam $ \ n ->
nlam $ \ n ->
tlam $ \ a ->
tlam $ \ m ->
nlam $ \ m ->
tlam $ \ _i ->
lam $ \ l ->
lam $ \ r ->
let vs = fromSeq l
ixs = map fromWord (fromSeq r)
in toSeq m a (op (fromNat (numTValue n)) vs ixs)
in toSeq m a (op (fromNat (n)) vs ixs)
indexFrontRange :: Maybe Integer -> [Value] -> [Integer] -> [Value]
indexFrontRange mblen vs = map (indexFront mblen vs)
@ -671,10 +649,10 @@ indexBackRange mblen vs = map (indexBack mblen vs)
-- @[ 0, 1 .. ]@
fromThenV :: Value
fromThenV =
tlamN $ \ first ->
tlamN $ \ next ->
tlamN $ \ bits ->
tlamN $ \ len ->
nlam $ \ first ->
nlam $ \ next ->
nlam $ \ bits ->
nlam $ \ len ->
case (first, next, len, bits) of
(_ , _ , _ , Nat bits')
| bits' >= Arch.maxBigIntWidth -> wordTooWide bits'
@ -686,9 +664,9 @@ fromThenV =
-- @[ 0 .. 10 ]@
fromToV :: Value
fromToV =
tlamN $ \ first ->
tlamN $ \ lst ->
tlamN $ \ bits ->
nlam $ \ first ->
nlam $ \ lst ->
nlam $ \ bits ->
case (first, lst, bits) of
(_ , _ , Nat bits')
| bits' >= Arch.maxBigIntWidth -> wordTooWide bits'
@ -702,11 +680,11 @@ fromToV =
-- @[ 0, 1 .. 10 ]@
fromThenToV :: Value
fromThenToV =
tlamN $ \ first ->
tlamN $ \ next ->
tlamN $ \ lst ->
tlamN $ \ bits ->
tlamN $ \ len ->
nlam $ \ first ->
nlam $ \ next ->
nlam $ \ lst ->
nlam $ \ bits ->
nlam $ \ len ->
case (first, next, lst, len, bits) of
(_ , _ , _ , _ , Nat bits')
| bits' >= Arch.maxBigIntWidth -> wordTooWide bits'
@ -731,8 +709,3 @@ randomV ty seed =
unpack s = fromIntegral (s .&. mask64) : unpack (s `shiftR` 64)
[a, b, c, d] = take 4 (unpack seed)
in fst $ gen 100 $ seedTFGen (a, b, c, d)
-- Miscellaneous ---------------------------------------------------------------
tlamN :: (Nat' -> GenValue b w) -> GenValue b w
tlamN f = VPoly (\x -> f (numTValue x))

56
src/Cryptol/Prims/Syntax.hs
View File

@ -6,8 +6,8 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.Prims.Syntax
( TFun(..), tBinOpPrec, tfunNames
) where
@ -18,7 +18,7 @@ import Cryptol.Utils.PP
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
-- | Built-in types.
data TFun
@ -40,9 +40,7 @@ data TFun
| TCLenFromThenTo -- ^ @ : Num -> Num -> Num -> Num@
-- Example: @[ 1, 5 .. 9 ] :: [lengthFromThenTo 1 5 9][b]@
deriving (Show, Eq, Ord, Bounded, Enum, Generic)
instance NFData TFun where rnf = genericRnf
deriving (Show, Eq, Ord, Bounded, Enum, Generic, NFData)
tBinOpPrec :: Map.Map TFun (Assoc,Int)
tBinOpPrec = mkMap t_table
@ -56,24 +54,44 @@ tBinOpPrec = mkMap t_table
, (RightAssoc, [ TCExp ])
]
tfunNames :: Map.Map PName TFun
-- | Type functions, with their arity and function constructor.
tfunNames :: Map.Map PName (Int,TFun)
tfunNames = Map.fromList
[ tinfix "+" TCAdd
, tinfix "-" TCSub
, tinfix "*" TCMul
, tinfix "/" TCDiv
, tinfix "%" TCMod
, tinfix "^^" TCExp
, tprefix "width" TCWidth
, tprefix "min" TCMin
, tprefix "max" TCMax
, tprefix "lengthFromThen" TCLenFromThen
, tprefix "lengthFromThenTo" TCLenFromThenTo
[ tinfix "+" 2 TCAdd
, tinfix "-" 2 TCSub
, tinfix "*" 2 TCMul
, tinfix "/" 2 TCDiv
, tinfix "%" 2 TCMod
, tinfix "^^" 2 TCExp
, tprefix "width" 1 TCWidth
, tprefix "min" 2 TCMin
, tprefix "max" 2 TCMax
, tprefix "lengthFromThen" 3 TCLenFromThen
, tprefix "lengthFromThenTo" 3 TCLenFromThenTo
]
where
tprefix n p = (mkUnqual (packIdent n), p)
tinfix n p = (mkUnqual (packInfix n), p)
tprefix n a p = (mkUnqual (packIdent n), (a,p))
tinfix n a p = (mkUnqual (packInfix n), (a,p))
instance PPName TFun where
ppNameFixity f = Map.lookup f tBinOpPrec
ppPrefixName TCAdd = text "(+)"
ppPrefixName TCSub = text "(-)"
ppPrefixName TCMul = text "(*)"
ppPrefixName TCDiv = text "(/)"
ppPrefixName TCMod = text "(%)"
ppPrefixName TCExp = text "(^^)"
ppPrefixName f = pp f
ppInfixName TCAdd = text "+"
ppInfixName TCSub = text "-"
ppInfixName TCMul = text "*"
ppInfixName TCDiv = text "/"
ppInfixName TCMod = text "%"
ppInfixName TCExp = text "^^"
ppInfixName f = error $ "Not a prefix type function: " ++ show (pp f)
instance PP TFun where
ppPrec _ tcon =

17
src/Cryptol/REPL/Command.hs
View File

@ -397,7 +397,7 @@ cmdProveSat isSat "" =
then rPutStr $ ":sat " ++ str ++ "\n\t"
else rPutStr $ ":prove " ++ str ++ "\n\t"
cmdProveSat isSat str
cmdProveSat isSat expr = do
cmdProveSat isSat str = do
let cexStr | isSat = "satisfying assignment"
| otherwise = "counterexample"
EnvString proverName <- getUser "prover"
@ -405,7 +405,7 @@ cmdProveSat isSat expr = do
let mfile = if fileName == "-" then Nothing else Just fileName
case proverName of
"offline" -> do
result <- offlineProveSat isSat expr mfile
result <- offlineProveSat isSat str mfile
case result of
Left msg -> rPutStrLn msg
Right smtlib -> do
@ -421,7 +421,7 @@ cmdProveSat isSat expr = do
Just path -> io $ writeFile path smtlib
Nothing -> rPutStr smtlib
_ -> do
result <- onlineProveSat isSat expr mfile
result <- onlineProveSat isSat str mfile
ppOpts <- getPPValOpts
case result of
Symbolic.EmptyResult ->
@ -435,11 +435,11 @@ cmdProveSat isSat expr = do
let tess = map (map $ \(t,e,_) -> (t,e)) tevss
vss = map (map $ \(_,_,v) -> v) tevss
ppvs vs = do
parseExpr <- replParseExpr expr
parseExpr <- replParseExpr str
let docs = map (pp . E.WithBase ppOpts) vs
-- function application has precedence 3
doc = ppPrec 3 parseExpr
rPrint $ hsep (doc : docs) <+>
rPrint $ hang doc 2 (sep docs) <+>
text (if isSat then "= True" else "= False")
resultRecs <- mapM (mkSolverResult cexStr isSat . Right) tess
let collectTes tes = (t, es)
@ -545,13 +545,14 @@ typeOfCmd :: String -> REPL ()
typeOfCmd str = do
expr <- replParseExpr str
(re,def,sig) <- replCheckExpr expr
(_re,def,sig) <- replCheckExpr expr
-- XXX need more warnings from the module system
--io (mapM_ printWarning ws)
whenDebug (rPutStrLn (dump def))
(_,_,names) <- getFocusedEnv
rPrint $ runDoc names $ pp re <+> text ":" <+> pp sig
-- type annotation ':' has precedence 2
rPrint $ runDoc names $ ppPrec 2 expr <+> text ":" <+> pp sig
readFileCmd :: FilePath -> REPL ()
readFileCmd fp = do
@ -844,7 +845,7 @@ moduleCmdResult (res,ws0) = do
ys -> Just (M.TypeCheckWarnings ys)
filterDefaults w = Just w
isShadowWarn (M.SymbolShadowed _ _ _) = True
isShadowWarn (M.SymbolShadowed {}) = True
filterShadowing w | warnShadowing = Just w
filterShadowing (M.RenamerWarnings xs) =

31
src/Cryptol/REPL/Monad.hs
View File

@ -78,7 +78,7 @@ import qualified Cryptol.ModuleSystem.NamingEnv as M
import Cryptol.Parser (ParseError,ppError)
import Cryptol.Parser.NoInclude (IncludeError,ppIncludeError)
import Cryptol.Parser.NoPat (Error)
import Cryptol.Parser.Position (emptyRange)
import Cryptol.Parser.Position (emptyRange, Range(from))
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.TypeCheck as T
import qualified Cryptol.Utils.Ident as I
@ -96,6 +96,7 @@ import Data.IORef
(IORef,newIORef,readIORef,modifyIORef,atomicModifyIORef)
import Data.List (intercalate, isPrefixOf, unfoldr, sortBy)
import Data.Maybe (catMaybes)
import Data.Ord (comparing)
import Data.Typeable (Typeable)
import System.Directory (findExecutable)
import qualified Control.Exception as X
@ -343,7 +344,7 @@ getPutStr = fmap ePutStr getRW
rPutStr :: String -> REPL ()
rPutStr str = do
rw <- getRW
io $ ePutStr rw str
io $ ePutStr rw str
-- | Use the configured output action to print a string with a trailing newline
rPutStrLn :: String -> REPL ()
@ -402,31 +403,26 @@ getNewtypes = do
-- | Get visible variable names.
getExprNames :: REPL [String]
getExprNames = (map getName . Map.keys) `fmap` getVars
getExprNames =
do (_, fNames, _) <- getFocusedEnv
return (map (show . pp) (Map.keys (M.neExprs fNames)))
-- | Get visible type signature names.
getTypeNames :: REPL [String]
getTypeNames =
do tss <- getTSyns
nts <- getNewtypes
return $ map getName $ Map.keys tss ++ Map.keys nts
do (_, fNames, _) <- getFocusedEnv
return (map (show . pp) (Map.keys (M.neTypes fNames)))
-- | Return a list of property names.
--
-- NOTE: we sort by displayed name here, but it would be just as easy to sort by
-- the position in the file, using nameLoc.
-- | Return a list of property names, sorted by position in the file.
getPropertyNames :: REPL ([M.Name],NameDisp)
getPropertyNames =
do (decls,_,names) <- getFocusedEnv
let xs = M.ifDecls decls
ps = sortBy (M.cmpNameDisplay names)
ps = sortBy (comparing (from . M.nameLoc))
$ [ x | (x,d) <- Map.toList xs, T.PragmaProperty `elem` M.ifDeclPragmas d ]
return (ps, names)
getName :: M.Name -> String
getName = show . pp
getModuleEnv :: REPL M.ModuleEnv
getModuleEnv = eModuleEnv `fmap` getRW
@ -449,7 +445,7 @@ uniqify :: M.Name -> REPL M.Name
uniqify name =
case M.nameInfo name of
M.Declared ns ->
M.liftSupply (M.mkDeclared ns (M.nameIdent name) (M.nameLoc name))
M.liftSupply (M.mkDeclared ns (M.nameIdent name) (M.nameFixity name) (M.nameLoc name))
M.Parameter ->
panic "[REPL] uniqify" ["tried to uniqify a parameter: " ++ pretty name]
@ -468,7 +464,7 @@ uniqify name =
-- | Generate a fresh name using the given index. The name will reside within
-- the "<interactive>" namespace.
freshName :: I.Ident -> REPL M.Name
freshName i = M.liftSupply (M.mkDeclared I.interactiveName i emptyRange)
freshName i = M.liftSupply (M.mkDeclared I.interactiveName i Nothing emptyRange)
-- User Environment Interaction ------------------------------------------------
@ -729,6 +725,3 @@ z3exists = do
case mPath of
Nothing -> return (Just Z3NotFound)
Just _ -> return Nothing

96
src/Cryptol/Symbolic.hs
View File

@ -12,6 +12,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module Cryptol.Symbolic where
@ -31,7 +32,7 @@ import Cryptol.Symbolic.Prims
import Cryptol.Symbolic.Value
import qualified Cryptol.Eval.Value as Eval
import qualified Cryptol.Eval.Type (evalType)
import qualified Cryptol.Eval.Type (evalValType, evalNumType)
import qualified Cryptol.Eval.Env (EvalEnv(..))
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..))
@ -257,21 +258,19 @@ data FinType
| FTTuple [FinType]
| FTRecord [(Ident, FinType)]
numType :: Type -> Maybe Int
numType (TCon (TC (TCNum n)) [])
numType :: Integer -> Maybe Int
numType n
| 0 <= n && n <= toInteger (maxBound :: Int) = Just (fromInteger n)
numType (TUser _ _ t) = numType t
numType _ = Nothing
| otherwise = Nothing
finType :: Type -> Maybe FinType
finType :: TValue -> Maybe FinType
finType ty =
case ty of
TCon (TC TCBit) [] -> Just FTBit
TCon (TC TCSeq) [n, t] -> FTSeq <$> numType n <*> finType t
TCon (TC (TCTuple _)) ts -> FTTuple <$> traverse finType ts
TRec fields -> FTRecord <$> traverse (traverseSnd finType) fields
TUser _ _ t -> finType t
_ -> Nothing
TVBit -> Just FTBit
TVSeq n t -> FTSeq <$> numType n <*> finType t
TVTuple ts -> FTTuple <$> traverse finType ts
TVRec fields -> FTRecord <$> traverse (traverseSnd finType) fields
_ -> Nothing
unFinType :: FinType -> Type
unFinType fty =
@ -287,15 +286,15 @@ unFinType fty =
predArgTypes :: Schema -> Either String [FinType]
predArgTypes schema@(Forall ts ps ty)
| null ts && null ps =
case go ty of
case go (Cryptol.Eval.Type.evalValType mempty ty) of
Just fts -> Right fts
Nothing -> Left $ "Not a valid predicate type:\n" ++ show (pp schema)
| otherwise = Left $ "Not a monomorphic type:\n" ++ show (pp schema)
where
go (TCon (TC TCBit) []) = Just []
go (TCon (TC TCFun) [ty1, ty2]) = (:) <$> finType ty1 <*> go ty2
go (TUser _ _ t) = go t
go _ = Nothing
go :: TValue -> Maybe [FinType]
go TVBit = Just []
go (TVFun ty1 ty2) = (:) <$> finType ty1 <*> go ty2
go _ = Nothing
forallFinType :: FinType -> SBV.Symbolic Value
forallFinType ty =
@ -321,7 +320,7 @@ existsFinType ty =
data Env = Env
{ envVars :: Map.Map Name Value
, envTypes :: Map.Map TVar TValue
, envTypes :: Map.Map TVar (Either Nat' TValue)
}
instance Monoid Env where
@ -344,11 +343,11 @@ lookupVar :: Name -> Env -> Maybe Value
lookupVar n env = Map.lookup n (envVars env)
-- | Bind a type variable of kind *.
bindType :: TVar -> TValue -> Env -> Env
bindType :: TVar -> (Either Nat' TValue) -> Env -> Env
bindType p ty env = env { envTypes = Map.insert p ty (envTypes env) }
-- | Lookup a type variable.
lookupType :: TVar -> Env -> Maybe TValue
lookupType :: TVar -> Env -> Maybe (Either Nat' TValue)
lookupType p env = Map.lookup p (envTypes env)
-- Expressions -----------------------------------------------------------------
@ -361,13 +360,22 @@ evalExpr env expr =
ERec fields -> VRecord [ (f, eval e) | (f, e) <- fields ]
ESel e sel -> evalSel sel (eval e)
EIf b e1 e2 -> iteValue (fromVBit (eval b)) (eval e1) (eval e2)
EComp ty e mss -> evalComp env (evalType env ty) e mss
EComp ty e mss -> evalComp env (evalValType env ty) e mss
EVar n -> case lookupVar n env of
Just x -> x
_ -> panic "Cryptol.Symbolic.evalExpr" [ "Variable " ++ show n ++ " not found" ]
-- TODO: how to deal with uninterpreted functions?
ETAbs tv e -> VPoly $ \ty -> evalExpr (bindType (tpVar tv) ty env) e
ETApp e ty -> fromVPoly (eval e) (evalType env ty)
ETAbs tv e -> case tpKind tv of
KType -> VPoly $ \ty -> evalExpr (bindType (tpVar tv) (Right ty) env) e
KNum -> VNumPoly $ \n -> evalExpr (bindType (tpVar tv) (Left n) env) e
k -> panic "[Symbolic] evalExpr" ["invalid kind on type abstraction", show k]
ETApp e ty -> case eval e of
VPoly f -> f (evalValType env ty)
VNumPoly f -> f (evalNumType env ty)
_ -> panic "[Symbolic] evalExpr"
[ "expected a polymorphic value"
, show e, show ty
]
EApp e1 e2 -> fromVFun (eval e1) (eval e2)
EAbs n _ty e -> VFun $ \x -> evalExpr (bindVar (n, x) env) e
EProofAbs _prop e -> eval e
@ -377,10 +385,13 @@ evalExpr env expr =
where
eval e = evalExpr env e
evalType :: Env -> Type -> TValue
evalType env ty = Cryptol.Eval.Type.evalType env' ty
evalValType :: Env -> Type -> TValue
evalValType env ty = Cryptol.Eval.Type.evalValType env' ty
where env' = Cryptol.Eval.Env.EvalEnv Map.empty (envTypes env)
evalNumType :: Env -> Type -> Nat'
evalNumType env ty = Cryptol.Eval.Type.evalNumType env' ty
where env' = Cryptol.Eval.Env.EvalEnv Map.empty (envTypes env)
evalSel :: Selector -> Value -> Value
evalSel sel v =
@ -436,31 +447,32 @@ evalDecl env d = (dName d, body)
copyBySchema :: Env -> Schema -> Value -> Value
copyBySchema env0 (Forall params _props ty) = go params env0
where
go [] env v = copyByType env (evalType env ty) v
go [] env v = copyByType env (evalValType env ty) v
go (p : ps) env v =
VPoly (\t -> go ps (bindType (tpVar p) t env) (fromVPoly v t))
case tpKind p of
KType -> VPoly (\t -> go ps (bindType (tpVar p) (Right t) env) (fromVPoly v t))
KNum -> VNumPoly (\t -> go ps (bindType (tpVar p) (Left t) env) (fromVNumPoly v t))
k -> panic "[Eval] copyBySchema" ["invalid kind on type abstraction", show k]
copyByType :: Env -> TValue -> Value -> Value
copyByType env ty v
| isTBit ty = VBit (fromVBit v)
| Just (n, ety) <- isTSeq ty = case numTValue n of
Nat _ -> VSeq (isTBit ety) (fromSeq v)
Inf -> VStream (fromSeq v)
| Just (_, bty) <- isTFun ty = VFun (\x -> copyByType env bty (fromVFun v x))
| Just (_, tys) <- isTTuple ty = VTuple (zipWith (copyByType env) tys (fromVTuple v))
| Just fs <- isTRec ty = VRecord [ (f, copyByType env t (lookupRecord f v)) | (f, t) <- fs ]
| otherwise = v
-- copyByType env ty v = logicUnary id id (evalType env ty) v
copyByType env ty v =
case ty of
TVBit -> VBit (fromVBit v)
TVSeq _ ety -> VSeq (isTBit ety) (fromSeq v)
TVStream _ -> VStream (fromSeq v)
TVFun _ bty -> VFun (\x -> copyByType env bty (fromVFun v x))
TVTuple tys -> VTuple (zipWith (copyByType env) tys (fromVTuple v))
TVRec fs -> VRecord [ (f, copyByType env t (lookupRecord f v)) | (f, t) <- fs ]
-- copyByType env ty v = logicUnary id id (evalValType env ty) v
-- List Comprehensions ---------------------------------------------------------
-- | Evaluate a comprehension.
evalComp :: Env -> TValue -> Expr -> [[Match]] -> Value
evalComp env seqty body ms
| Just (len,el) <- isTSeq seqty = toSeq len el [ evalExpr e body | e <- envs ]
| otherwise = evalPanic "Cryptol.Eval" [ "evalComp given a non sequence"
, show seqty
]
evalComp env seqty body ms =
case Eval.isTSeq seqty of
Just (len, el) -> toSeq len el [ evalExpr e body | e <- envs ]
Nothing -> evalPanic "Cryptol.Eval" ["evalComp given a non sequence", show seqty]
-- XXX we could potentially print this as a number if the type was available.
where

225
src/Cryptol/Symbolic/Prims.hs
View File

@ -16,7 +16,7 @@ import Data.List (genericDrop, genericReplicate, genericSplitAt, genericTake, so
import Data.Ord (comparing)
import Cryptol.Eval.Value (BitWord(..))
import Cryptol.Prims.Eval (binary, unary, tlamN)
import Cryptol.Prims.Eval (binary, unary)
import Cryptol.Symbolic.Value
import Cryptol.TypeCheck.AST (Decl(..))
import Cryptol.TypeCheck.Solver.InfNat(Nat'(..), nMul)
@ -74,7 +74,7 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
, ("zero" , VPoly zeroV)
, ("<<" , -- {m,n,a} (fin n) => [m] a -> [n] -> [m] a
tlam $ \m ->
nlam $ \m ->
tlam $ \_ ->
tlam $ \a ->
VFun $ \xs ->
@ -84,7 +84,7 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
_ ->
let shl :: Integer -> Value
shl i =
case numTValue m of
case m of
Inf -> dropV i xs
Nat j | i >= j -> replicateV j a (zeroV a)
| otherwise -> catV (dropV i xs) (replicateV i a (zeroV a))
@ -92,7 +92,7 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
in selectV shl y)
, (">>" , -- {m,n,a} (fin n) => [m] a -> [n] -> [m] a
tlam $ \m ->
nlam $ \m ->
tlam $ \_ ->
tlam $ \a ->
VFun $ \xs ->
@ -102,14 +102,14 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
_ ->
let shr :: Integer -> Value
shr i =
case numTValue m of
case m of
Inf -> catV (replicateV i a (zeroV a)) xs
Nat j | i >= j -> replicateV j a (zeroV a)
| otherwise -> catV (replicateV i a (zeroV a)) (takeV (j - i) xs)
in selectV shr y)
, ("<<<" , -- {m,n,a} (fin m, fin n) => [m] a -> [n] -> [m] a
tlam $ \m ->
nlam $ \m ->
tlam $ \_ ->
tlam $ \_ ->
VFun $ \xs ->
@ -118,11 +118,11 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
VWord x -> VWord (SBV.svRotateLeft x (fromVWord y))
_ -> let rol :: Integer -> Value
rol i = catV (dropV k xs) (takeV k xs)
where k = i `mod` finTValue m
where k = i `mod` finNat' m
in selectV rol y)
, (">>>" , -- {m,n,a} (fin m, fin n) => [m] a -> [n] -> [m] a
tlam $ \m ->
nlam $ \m ->
tlam $ \_ ->
tlam $ \_ ->
VFun $ \xs ->
@ -132,7 +132,7 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
_ ->
let ror :: Integer -> Value
ror i = catV (dropV k xs) (takeV k xs)
where k = (- i) `mod` finTValue m
where k = (- i) `mod` finNat' m
in selectV ror y)
, ("#" , -- {a,b,d} (fin a) => [a] d -> [b] d -> [a + b] d
@ -143,31 +143,31 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
VFun $ \v2 -> catV v1 v2)
, ("splitAt" , -- {a,b,c} (fin a) => [a+b] c -> ([a]c,[b]c)
tlam $ \(finTValue -> a) ->
tlam $ \_ ->
nlam $ \(finNat' -> a) ->
nlam $ \_ ->
tlam $ \_ ->
VFun $ \v -> VTuple [takeV a v, dropV a v])
, ("join" , tlam $ \ parts ->
tlam $ \ each ->
, ("join" , nlam $ \ parts ->
nlam $ \ each ->
tlam $ \ a -> lam (joinV parts each a))
, ("split" , ecSplitV)
, ("reverse" ,
tlam $ \a ->
nlam $ \a ->
tlam $ \b ->
lam $ \(fromSeq -> xs) -> toSeq a b (reverse xs))
, ("transpose" ,
tlam $ \a ->
tlam $ \b ->
nlam $ \a ->
nlam $ \b ->
tlam $ \c ->
lam $ \((map fromSeq . fromSeq) -> xs) ->
case numTValue a of
case a of
Nat 0 ->
let v = toSeq a c []
in case numTValue b of
in case b of
Nat n -> toSeq b (tvSeq a c) $ genericReplicate n v
Inf -> VStream $ repeat v
_ -> toSeq b (tvSeq a c) $ map (toSeq a c) $ transpose xs)
@ -176,46 +176,50 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
tlam $ \_ ->
tlam $ \a ->
tlam $ \_ ->
VFun $ \(fromSeq -> xs) ->
VFun $ \xs ->
VFun $ \y ->
let err = zeroV a -- default for out-of-bounds accesses
in atV err xs y)
let isInf = case xs of VStream _ -> True; _ -> False
err = zeroV a -- default for out-of-bounds accesses
in atV isInf err (fromSeq xs) y)
, ("@@" , -- {n,a,m,i} (fin i) => [n]a -> [m][i] -> [m]a
tlam $ \_ ->
tlam $ \a ->
tlam $ \_ ->
tlam $ \_ ->
VFun $ \(fromSeq -> xs) ->
VFun $ \xs ->
VFun $ \ys ->
let err = zeroV a -- default for out-of-bounds accesses
in mapV (isTBit a) (atV err xs) ys)
let isInf = case xs of VStream _ -> True; _ -> False
err = zeroV a -- default for out-of-bounds accesses
in atV_list (isTBit a) isInf err (fromSeq xs) ys)
, ("!" , -- {n,a,i} (fin n, fin i) => [n]a -> [i] -> a
tlam $ \_ ->
tlam $ \a ->
tlam $ \_ ->
VFun $ \(fromSeq -> xs) ->
VFun $ \xs ->
VFun $ \y ->
let err = zeroV a -- default for out-of-bounds accesses
in atV err (reverse xs) y)
isInf = False -- type of (!) guarantess finite sequences
in atV isInf err (reverse $ fromSeq xs) y)
, ("!!" , -- {n,a,m,i} (fin n, fin i) => [n]a -> [m][i] -> [m]a
tlam $ \_ ->
tlam $ \a ->
tlam $ \_ ->
tlam $ \_ ->
VFun $ \(fromSeq -> xs) ->
VFun $ \xs ->
VFun $ \ys ->
let err = zeroV a -- default for out-of-bounds accesses
in mapV (isTBit a) (atV err (reverse xs)) ys)
isInf = False -- type of (!!) guarantess finite sequences
in atV_list (isTBit a) isInf err (reverse $ fromSeq xs) ys)
, ("fromThen" , fromThenV)
, ("fromTo" , fromToV)
, ("fromThenTo" , fromThenToV)
, ("infFrom" ,
tlam $ \(finTValue -> bits) ->
nlam $ \(finNat' -> bits) ->
lam $ \(fromVWord -> first) ->
toStream [ VWord (SBV.svPlus first (literalSWord (fromInteger bits) i)) | i <- [0 ..] ])
@ -228,12 +232,12 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
-- {at,len} (fin len) => [len][8] -> at
, ("error" ,
tlam $ \at ->
tlam $ \(finTValue -> _len) ->
nlam $ \(finNat' -> _len) ->
VFun $ \_msg -> zeroV at) -- error/undefined, is arbitrarily translated to 0
, ("pmult" , -- {a,b} (fin a, fin b) => [a] -> [b] -> [max 1 (a + b) - 1]
tlam $ \(finTValue -> i) ->
tlam $ \(finTValue -> j) ->
nlam $ \(finNat' -> i) ->
nlam $ \(finNat' -> j) ->
VFun $ \v1 ->
VFun $ \v2 ->
let k = max 1 (i + j) - 1
@ -245,7 +249,7 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
in VSeq True (map VBit zs))
, ("pdiv" , -- {a,b} (fin a, fin b) => [a] -> [b] -> [a]
tlam $ \(finTValue -> i) ->
nlam $ \(finNat' -> i) ->
tlam $ \_ ->
VFun $ \v1 ->
VFun $ \v2 ->
@ -255,8 +259,8 @@ primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
in VSeq True (map VBit (reverse zs)))
, ("pmod" , -- {a,b} (fin a, fin b) => [a] -> [b+1] -> [b]
tlam $ \_ ->
tlam $ \(finTValue -> j) ->
nlam $ \_ ->
nlam $ \(finNat' -> j) ->
VFun $ \v1 ->
VFun $ \v2 ->
let xs = map fromVBit (fromSeq v1)
@ -280,8 +284,58 @@ selectV f v = sel 0 bits
where m1 = sel (offset + 2 ^ length bs) bs
m2 = sel offset bs
atV :: Value -> [Value] -> Value -> Value
atV def vs i =
asWordList :: [Value] -> Maybe [SWord]
asWordList = go id
where go :: ([SWord] -> [SWord]) -> [Value] -> Maybe [SWord]
go f [] = Just (f [])
go f (VWord x:vs) = go (f . (x:)) vs
go f (VSeq True bs:vs) = go (f . (x:)) vs
where x = packWord $ map fromVBit bs
go _ _ = Nothing
atV_list :: Bool -- Are the elements of the resulting sequence bits?
-> Bool -- Is this an infinite sequence?
-> Value -- default value
-> [Value] -- values to select
-> Value -- index
-> Value
-- Use SBV selection primitives if possible
-- NB: only examine the list if it is finite
atV_list isBit False def (asWordList -> Just ws) v =
case v of
VSeq _ ys ->
VSeq isBit $ map (VWord . SBV.svSelect ws (fromVWord def) . fromVWord) ys
VStream ys ->
VStream $ map (VWord . SBV.svSelect ws (fromVWord def) . fromVWord) ys
_ -> panic "Cryptol.Symbolic.Prims.atV_list" [ "non-mappable value" ]
atV_list isBit _ def xs v =
case v of
VSeq _ ys ->
VSeq isBit $ map (iteAtV def xs) ys
VStream ys ->
VStream $ map (iteAtV def xs) ys
_ -> panic "Cryptol.Symbolic.Prims.atV_list" [ "non-mappable value" ]
atV :: Bool -- Is this an infinite sequence?
-> Value -- default value
-> [Value] -- values to select
-> Value -- index
-> Value
-- When applicable, use the SBV selection operation
-- NB: only examine the list if it is finite
atV False def (asWordList -> Just ws) i =
VWord $ SBV.svSelect ws (fromVWord def) (fromVWord i)
-- Otherwise, decompose into a sequence of if/then/else operations
atV _ def vs i = iteAtV def vs i
-- Select a value at an index by building a sequence of if/then/else operations
iteAtV :: Value -> [Value] -> Value -> Value
iteAtV def vs i =
case i of
VSeq True (map fromVBit -> bits) -> -- index bits in big-endian order
case foldr weave vs bits of
@ -298,12 +352,14 @@ atV def vs i =
weave b [x1] = [iteValue b def x1]
weave b (x1 : x2 : xs) = iteValue b x2 x1 : weave b xs
replicateV :: Integer -- ^ number of elements
-> TValue -- ^ type of element
-> Value -- ^ element
-> Value
replicateV n (toTypeVal -> TVBit) x = VSeq True (genericReplicate n x)
replicateV n _ x = VSeq False (genericReplicate n x)
replicateV n TVBit x = VSeq True (genericReplicate n x)
replicateV n _ x = VSeq False (genericReplicate n x)
nth :: a -> [a] -> Int -> a
nth def [] _ = def
@ -357,9 +413,9 @@ takeV n xs =
-- | Make a numeric constant.
-- { val, bits } (fin val, fin bits, bits >= width val) => [bits]
ecDemoteV :: Value
ecDemoteV = tlam $ \valT ->
tlam $ \bitT ->
case (numTValue valT, numTValue bitT) of
ecDemoteV = nlam $ \valT ->
nlam $ \bitT ->
case (valT, bitT) of
(Nat v, Nat bs) -> VWord (literalSWord (fromInteger bs) v)
_ -> evalPanic "Cryptol.Prove.evalECon"
["Unexpected Inf in constant."
@ -367,27 +423,6 @@ ecDemoteV = tlam $ \valT ->
, show bitT
]
-- Type Values -----------------------------------------------------------------
-- | An easy-to-use alternative representation for type `TValue`.
data TypeVal
= TVBit
| TVSeq Int TypeVal
| TVStream TypeVal
| TVTuple [TypeVal]
| TVRecord [(Ident, TypeVal)]
| TVFun TypeVal TypeVal
toTypeVal :: TValue -> TypeVal
toTypeVal ty
| isTBit ty = TVBit
| Just (n, ety) <- isTSeq ty = case numTValue n of
Nat w -> TVSeq (fromInteger w) (toTypeVal ety)
Inf -> TVStream (toTypeVal ety)
| Just (aty, bty) <- isTFun ty = TVFun (toTypeVal aty) (toTypeVal bty)
| Just (_, tys) <- isTTuple ty = TVTuple (map toTypeVal tys)
| Just fields <- isTRec ty = TVRecord [ (n, toTypeVal aty) | (n, aty) <- fields ]
| otherwise = panic "Cryptol.Symbolic.Prims.toTypeVal" [ "bad TValue" ]
-- Arith -----------------------------------------------------------------------
@ -396,7 +431,7 @@ type Unary = TValue -> Value -> Value
-- | Models functions of type `{a} (Arith a) => a -> a -> a`
arithBinary :: (SWord -> SWord -> SWord) -> Binary
arithBinary op = loop . toTypeVal
arithBinary op = loop
where
loop ty l r =
case ty of
@ -405,12 +440,12 @@ arithBinary op = loop . toTypeVal
TVSeq _ t -> VSeq False (zipWith (loop t) (fromSeq l) (fromSeq r))
TVStream t -> VStream (zipWith (loop t) (fromSeq l) (fromSeq r))
TVTuple ts -> VTuple (zipWith3 loop ts (fromVTuple l) (fromVTuple r))
TVRecord fs -> VRecord [ (f, loop t (lookupRecord f l) (lookupRecord f r)) | (f, t) <- fs ]
TVRec fs -> VRecord [ (f, loop t (lookupRecord f l) (lookupRecord f r)) | (f, t) <- fs ]
TVFun _ t -> VFun (\x -> loop t (fromVFun l x) (fromVFun r x))
-- | Models functions of type `{a} (Arith a) => a -> a`
arithUnary :: (SWord -> SWord) -> Unary
arithUnary op = loop . toTypeVal
arithUnary op = loop
where
loop ty v =
case ty of
@ -419,7 +454,7 @@ arithUnary op = loop . toTypeVal
TVSeq _ t -> VSeq False (map (loop t) (fromSeq v))
TVStream t -> VStream (map (loop t) (fromSeq v))
TVTuple ts -> VTuple (zipWith loop ts (fromVTuple v))
TVRecord fs -> VRecord [ (f, loop t (lookupRecord f v)) | (f, t) <- fs ]
TVRec fs -> VRecord [ (f, loop t (lookupRecord f v)) | (f, t) <- fs ]
TVFun _ t -> VFun (\x -> loop t (fromVFun v x))
sExp :: SWord -> SWord -> SWord
@ -489,45 +524,45 @@ cmpBinary fb fw b _ty v1 v2 = VBit (cmpValue fb fw v1 v2 b)
-- Logic -----------------------------------------------------------------------
errorV :: String -> TValue -> Value
errorV msg = go . toTypeVal
errorV msg = go
where
go ty =
case ty of
TVBit -> VBit (error msg)
TVSeq n t -> VSeq False (replicate n (go t))
TVSeq n t -> VSeq False (replicate (fromInteger n) (go t))
TVStream t -> VStream (repeat (go t))
TVTuple ts -> VTuple [ go t | t <- ts ]
TVRecord fs -> VRecord [ (n, go t) | (n, t) <- fs ]
TVRec fs -> VRecord [ (n, go t) | (n, t) <- fs ]
TVFun _ t -> VFun (const (go t))
zeroV :: TValue -> Value
zeroV = go . toTypeVal
zeroV = go
where
go ty =
case ty of
TVBit -> VBit SBV.svFalse
TVSeq n TVBit -> VWord (literalSWord n 0)
TVSeq n t -> VSeq False (replicate n (go t))
TVSeq n TVBit -> VWord (literalSWord (fromInteger n) 0)
TVSeq n t -> VSeq False (replicate (fromInteger n) (go t))
TVStream t -> VStream (repeat (go t))
TVTuple ts -> VTuple [ go t | t <- ts ]
TVRecord fs -> VRecord [ (n, go t) | (n, t) <- fs ]
TVRec fs -> VRecord [ (n, go t) | (n, t) <- fs ]
TVFun _ t -> VFun (const (go t))
-- | Join a sequence of sequences into a single sequence.
joinV :: TValue -> TValue -> TValue -> Value -> Value
joinV :: Nat' -> Nat' -> TValue -> Value -> Value
joinV parts each a v =
let len = toNumTValue (numTValue parts `nMul` numTValue each)
let len = parts `nMul` each
in toSeq len a (concatMap fromSeq (fromSeq v))
-- | Split implementation.
ecSplitV :: Value
ecSplitV =
tlam $ \ parts ->
tlam $ \ each ->
nlam $ \ parts ->
nlam $ \ each ->
tlam $ \ a ->
lam $ \ v ->
let mkChunks f = map (toFinSeq a) $ f $ fromSeq v
in case (numTValue parts, numTValue each) of
in case (parts, each) of
(Nat p, Nat e) -> VSeq False $ mkChunks (finChunksOf p e)
(Inf , Nat e) -> toStream $ mkChunks (infChunksOf e)
_ -> evalPanic "splitV" ["invalid type arguments to split"]
@ -545,7 +580,7 @@ finChunksOf parts each xs = let (as,bs) = genericSplitAt each xs
-- | Merge two values given a binop. This is used for and, or and xor.
logicBinary :: (SBool -> SBool -> SBool) -> (SWord -> SWord -> SWord) -> Binary
logicBinary bop op = loop . toTypeVal
logicBinary bop op = loop
where
loop ty l r =
case ty of
@ -554,11 +589,11 @@ logicBinary bop op = loop . toTypeVal
TVSeq _ t -> VSeq False (zipWith (loop t) (fromSeq l) (fromSeq r))
TVStream t -> VStream (zipWith (loop t) (fromSeq l) (fromSeq r))
TVTuple ts -> VTuple (zipWith3 loop ts (fromVTuple l) (fromVTuple r))
TVRecord fs -> VRecord [ (f, loop t (lookupRecord f l) (lookupRecord f r)) | (f, t) <- fs ]
TVRec fs -> VRecord [ (f, loop t (lookupRecord f l) (lookupRecord f r)) | (f, t) <- fs ]
TVFun _ t -> VFun (\x -> loop t (fromVFun l x) (fromVFun r x))
logicUnary :: (SBool -> SBool) -> (SWord -> SWord) -> Unary
logicUnary bop op = loop . toTypeVal
logicUnary bop op = loop
where
loop ty v =
case ty of
@ -567,16 +602,16 @@ logicUnary bop op = loop . toTypeVal
TVSeq _ t -> VSeq False (map (loop t) (fromSeq v))
TVStream t -> VStream (map (loop t) (fromSeq v))
TVTuple ts -> VTuple (zipWith loop ts (fromVTuple v))
TVRecord fs -> VRecord [ (f, loop t (lookupRecord f v)) | (f, t) <- fs ]
TVRec fs -> VRecord [ (f, loop t (lookupRecord f v)) | (f, t) <- fs ]
TVFun _ t -> VFun (\x -> loop t (fromVFun v x))
-- @[ 0, 1 .. ]@
fromThenV :: Value
fromThenV =
tlamN $ \ first ->
tlamN $ \ next ->
tlamN $ \ bits ->
tlamN $ \ len ->
nlam $ \ first ->
nlam $ \ next ->
nlam $ \ bits ->
nlam $ \ len ->
case (first, next, len, bits) of
(Nat first', Nat next', Nat len', Nat bits') ->
let nums = enumFromThen first' next'
@ -587,9 +622,9 @@ fromThenV =
-- @[ 0 .. 10 ]@
fromToV :: Value
fromToV =
tlamN $ \ first ->
tlamN $ \ lst ->
tlamN $ \ bits ->
nlam $ \ first ->
nlam $ \ lst ->
nlam $ \ bits ->
case (first, lst, bits) of
(Nat first', Nat lst', Nat bits') ->
@ -603,11 +638,11 @@ fromToV =
-- @[ 0, 1 .. 10 ]@
fromThenToV :: Value
fromThenToV =
tlamN $ \ first ->
tlamN $ \ next ->
tlamN $ \ lst ->
tlamN $ \ bits ->
tlamN $ \ len ->
nlam $ \ first ->
nlam $ \ next ->
nlam $ \ lst ->
nlam $ \ bits ->
nlam $ \ len ->
case (first, next, lst, len, bits) of
(Nat first', Nat next', Nat lst', Nat len', Nat bits') ->

14
src/Cryptol/Symbolic/Value.hs
View File

@ -18,9 +18,10 @@ module Cryptol.Symbolic.Value
, forallBV_, existsBV_
, forallSBool_, existsSBool_
, Value
, TValue, numTValue, toNumTValue, finTValue, isTBit, isTFun, isTSeq, isTTuple, isTRec, tvSeq
, GenValue(..), lam, tlam, toStream, toFinSeq, toSeq
, fromVBit, fromVFun, fromVPoly, fromVTuple, fromVRecord, lookupRecord
, TValue(..), isTBit, tvSeq
, GenValue(..), lam, tlam, nlam, toStream, toFinSeq, toSeq, finNat'
, fromVBit, fromVFun, fromVPoly, fromVNumPoly, fromVTuple, fromVRecord
, lookupRecord
, fromSeq, fromVWord
, evalPanic
, iteValue, mergeValue
@ -31,11 +32,10 @@ import Data.List (foldl')
import Data.SBV.Dynamic
import Cryptol.Eval.Value (TValue, numTValue, toNumTValue, finTValue, isTBit,
isTFun, isTSeq, isTTuple, isTRec, tvSeq, GenValue(..),
BitWord(..), lam, tlam, toStream, toFinSeq, toSeq,
import Cryptol.Eval.Value (TValue(..), isTBit, tvSeq, finNat', GenValue(..),
BitWord(..), lam, tlam, nlam, toStream, toFinSeq, toSeq,
fromSeq, fromVBit, fromVWord, fromVFun, fromVPoly,
fromVTuple, fromVRecord, lookupRecord)
fromVNumPoly, fromVTuple, fromVRecord, lookupRecord)
import Cryptol.Utils.Panic (panic)
-- SBool and SWord -------------------------------------------------------------

4
src/Cryptol/Testing/Random.hs
View File

@ -14,6 +14,8 @@ module Cryptol.Testing.Random where
import Cryptol.Eval.Value (BV(..),Value,GenValue(..))
import qualified Cryptol.Testing.Concrete as Conc
import Cryptol.TypeCheck.AST (Type(..),TCon(..),TC(..),tNoUser)
import Cryptol.TypeCheck.Solve(simpType)
import Cryptol.Utils.Ident (Ident)
import Control.Monad (forM)
@ -62,7 +64,7 @@ randomValue :: RandomGen g => Type -> Maybe (Gen g)
randomValue ty =
case ty of
TCon tc ts ->
case (tc, map tNoUser ts) of
case (tc, map (simpType . tNoUser) ts) of
(TC TCBit, []) -> Just randomBit
(TC TCSeq, [TCon (TC TCInf) [], el]) ->

6
src/Cryptol/Transform/MonoValues.hs
View File

@ -78,7 +78,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Transform.MonoValues (rewModule) where
import Cryptol.ModuleSystem.Name (SupplyM,liftSupply,Supply,mkDeclared)
import Cryptol.ModuleSystem.Name (SupplyT,liftSupply,Supply,mkDeclared)
import Cryptol.Parser.Position (emptyRange)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.TypeMap
@ -138,14 +138,14 @@ rewModule s m = runM body (mName m) s
--------------------------------------------------------------------------------
type M = ReaderT RO SupplyM
type M = ReaderT RO (SupplyT Id)
type RO = ModName
-- | Produce a fresh top-level name.
newName :: M Name
newName =
do ns <- ask
liftSupply (mkDeclared ns "$mono" emptyRange)
liftSupply (mkDeclared ns "$mono" Nothing emptyRange)
newTopOrLocalName :: M Name
newTopOrLocalName = newName

3
src/Cryptol/Transform/Specialize.hs
View File

@ -245,9 +245,10 @@ destETAbs = go []
freshName :: Name -> [Type] -> SpecM Name
freshName n _ =
case nameInfo n of
Declared ns -> liftSupply (mkDeclared ns ident loc)
Declared ns -> liftSupply (mkDeclared ns ident fx loc)
Parameter -> liftSupply (mkParameter ident loc)
where
fx = nameFixity n
ident = nameIdent n
loc = nameLoc n

2
src/Cryptol/TypeCheck.hs
View File

@ -67,7 +67,7 @@ tcExpr e0 inp = runInferM inp
, show e'
, show t
]
_ -> do fresh <- liftSupply (mkDeclared (packModName ["<expr>"]) (packIdent "(expression)") loc)
_ -> do fresh <- liftSupply (mkDeclared (packModName ["<expr>"]) (packIdent "(expression)") Nothing loc)
res <- inferBinds True False
[ P.Bind
{ P.bName = P.Located { P.srcRange = loc, P.thing = fresh }

73
src/Cryptol/TypeCheck/AST.hs
View File

@ -7,10 +7,11 @@
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
module Cryptol.TypeCheck.AST
( module Cryptol.TypeCheck.AST
, Name()
@ -37,7 +38,7 @@ import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.Solver.InfNat
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
import Data.Map (Map)
import qualified Data.Map as Map
@ -52,26 +53,20 @@ data Module = Module { mName :: !ModName
, mTySyns :: Map Name TySyn
, mNewtypes :: Map Name Newtype
, mDecls :: [DeclGroup]
} deriving (Show, Generic)
instance NFData Module where rnf = genericRnf
} deriving (Show, Generic, NFData)
-- | Kinds, classify types.
data Kind = KType
| KNum
| KProp
| Kind :-> Kind
deriving (Eq, Show, Generic)
deriving (Eq, Show, Generic, NFData)
infixr 5 :->
instance NFData Kind where rnf = genericRnf
-- | The types of polymorphic values.
data Schema = Forall { sVars :: [TParam], sProps :: [Prop], sType :: Type }
deriving (Eq, Show, Generic)
instance NFData Schema where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
-- | Type synonym.
data TySyn = TySyn { tsName :: Name -- ^ Name
@ -79,27 +74,21 @@ data TySyn = TySyn { tsName :: Name -- ^ Name
, tsConstraints :: [Prop] -- ^ Ensure body is OK
, tsDef :: Type -- ^ Definition
}
deriving (Eq, Show, Generic)
instance NFData TySyn where rnf = genericRnf
deriving (Eq, Show, Generic, NFData)
-- | Named records
data Newtype = Newtype { ntName :: Name
, ntParams :: [TParam]
, ntConstraints :: [Prop]
, ntFields :: [(Ident,Type)]
} deriving (Show, Generic)
instance NFData Newtype where rnf = genericRnf
} deriving (Show, Generic, NFData)
-- | Type parameters.
data TParam = TParam { tpUnique :: !Int -- ^ Parameter identifier
, tpKind :: Kind -- ^ Kind of parameter
, tpName :: Maybe Name -- ^ Name from source, if any.
}
deriving (Show, Generic)
instance NFData TParam where rnf = genericRnf
deriving (Show, Generic, NFData)
instance Eq TParam where
x == y = tpUnique x == tpUnique y
@ -128,9 +117,7 @@ data Type = TCon TCon [Type]
| TRec [(Ident,Type)]
-- ^ Record type
deriving (Show,Eq,Ord,Generic)
instance NFData Type where rnf = genericRnf
deriving (Show, Eq, Ord, Generic, NFData)
-- | The type is supposed to be of kind `KProp`
type Prop = Type
@ -146,15 +133,11 @@ data TVar = TVFree !Int Kind (Set TVar) Doc
| TVBound !Int Kind
deriving (Show,Generic)
instance NFData TVar where rnf = genericRnf
deriving (Show, Generic, NFData)
-- | Type constants.
data TCon = TC TC | PC PC | TF TFun
deriving (Show,Eq,Ord,Generic)
instance NFData TCon where rnf = genericRnf
deriving (Show, Eq, Ord, Generic, NFData)
-- | Built-in type constants.
@ -168,9 +151,7 @@ data PC = PEqual -- ^ @_ == _@
| PHas Selector -- ^ @Has sel type field@ does not appear in schemas
| PArith -- ^ @Arith _@
| PCmp -- ^ @Cmp _@
deriving (Show,Eq,Ord,Generic)
instance NFData PC where rnf = genericRnf
deriving (Show, Eq, Ord, Generic, NFData)
-- | 1-1 constants.
data TC = TCNum Integer -- ^ Numbers
@ -180,14 +161,10 @@ data TC = TCNum Integer -- ^ Numbers
| TCFun -- ^ @_ -> _@
| TCTuple Int -- ^ @(_, _, _)@
| TCNewtype UserTC -- ^ user-defined, @T@
deriving (Show,Eq,Ord,Generic)
instance NFData TC where rnf = genericRnf
deriving (Show, Eq, Ord, Generic, NFData)
data UserTC = UserTC Name Kind
deriving (Show,Generic)
instance NFData UserTC where rnf = genericRnf
deriving (Show, Generic, NFData)
instance Eq UserTC where
UserTC x _ == UserTC y _ = x == y
@ -264,23 +241,17 @@ data Expr = EList [Expr] Type -- ^ List value (with type of elements)
| EWhere Expr [DeclGroup]
deriving (Show, Generic)
instance NFData Expr where rnf = genericRnf
deriving (Show, Generic, NFData)
data Match = From Name Type Expr -- ^ do we need this type? it seems like it
-- can be computed from the expr
| Let Decl
deriving (Show, Generic)
instance NFData Match where rnf = genericRnf
deriving (Show, Generic, NFData)
data DeclGroup = Recursive [Decl] -- ^ Mutually recursive declarations
| NonRecursive Decl -- ^ Non-recursive declaration
deriving (Show,Generic)
instance NFData DeclGroup where rnf = genericRnf
deriving (Show, Generic, NFData)
groupDecls :: DeclGroup -> [Decl]
groupDecls dg = case dg of
@ -294,15 +265,11 @@ data Decl = Decl { dName :: !Name
, dInfix :: !Bool
, dFixity :: Maybe Fixity
, dDoc :: Maybe String
} deriving (Show,Generic)
instance NFData Decl where rnf = genericRnf
} deriving (Show, Generic, NFData)
data DeclDef = DPrim
| DExpr Expr
deriving (Show,Generic)
instance NFData DeclDef where rnf = genericRnf
deriving (Show, Generic, NFData)
--------------------------------------------------------------------------------

2
src/Cryptol/TypeCheck/Depends.hs
View File

@ -29,7 +29,7 @@ import qualified Data.Set as Set
data TyDecl = TS (P.TySyn Name) | NT (P.Newtype Name)
-- | Check for duplicate and recursive type synonyms.
-- Returns the type-synonyms in dependecy order.
-- Returns the type-synonyms in dependency order.
orderTyDecls :: [TyDecl] -> InferM [TyDecl]
orderTyDecls ts =
do vs <- getTVars

24
src/Cryptol/TypeCheck/Infer.hs
View File

@ -36,14 +36,12 @@ import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Either(partitionEithers)
import Data.Maybe(mapMaybe,isJust)
import Data.Maybe(mapMaybe,isJust, fromMaybe)
import Data.List(partition,find)
import Data.Graph(SCC(..))
import Data.Traversable(forM)
import Control.Monad(when,zipWithM)
-- import Cryptol.Utils.Debug
inferModule :: P.Module Name -> InferM Module
inferModule m =
inferDs (P.mDecls m) $ \ds1 ->
@ -140,8 +138,9 @@ appTys expr ts tGoal =
P.ETyped {} -> mono
P.ETypeVal {} -> mono
P.EFun {} -> mono
P.EParens {} -> tcPanic "appTys" [ "Unexpected EParens" ]
P.EInfix {} -> tcPanic "appTys" [ "Unexpected EInfix" ]
P.EParens e -> appTys e ts tGoal
P.EInfix a op _ b -> appTys (P.EVar (thing op) `P.EApp` a `P.EApp` b) ts tGoal
where mono = do e' <- checkE expr tGoal
(ie,t) <- instantiateWith e' (Forall [] [] tGoal) ts
@ -422,11 +421,8 @@ expectFin n ty =
TCon (TC (TCNum n')) [] | toInteger n == n' ->
return ()
TVar TVFree{} ->
do newGoals CtExactType =<< unify (tNum n) ty
_ ->
recordError (TypeMismatch (tNum n) ty)
do newGoals CtExactType =<< unify (tNum n) ty
expectFun :: Int -> Type -> InferM ([Type],Type)
expectFun = go []
@ -490,14 +486,14 @@ smallest ts = do a <- newType (text "length of list comprehension") KNum
newGoals CtComprehension [ a =#= foldr1 tMin ts ]
return a
checkP :: Doc -> P.Pattern Name -> Type -> InferM (Located Name)
checkP desc p tGoal =
do (x, t) <- inferP desc p
ps <- unify tGoal (thing t)
case ps of
[] -> return (Located (srcRange t) x)
_ -> tcPanic "checkP" [ "Unexpected constraints:", show ps ]
let rng = fromMaybe emptyRange $ getLoc p
let mkErr = recordError . UnsolvedGoal False . Goal (CtPattern desc) rng
mapM_ mkErr ps
return (Located (srcRange t) x)
{-| Infer the type of a pattern. Assumes that the pattern will be just
a variable. -}
@ -569,7 +565,7 @@ inferBinds :: Bool -> Bool -> [P.Bind Name] -> InferM [Decl]
inferBinds isTopLevel isRec binds =
mdo let dExpr (DExpr e) = e
dExpr DPrim = panic "[TypeCheck]" [ "primitive in a recursive group" ]
exprMap = Map.fromList [ (x,inst (EVar x) (dExpr (dDefinition b)))
| b <- genBs, let x = dName b ] -- REC.

61
src/Cryptol/TypeCheck/InferTypes.hs
View File

@ -9,10 +9,13 @@
-- This module contains types used during type inference.
{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Cryptol.TypeCheck.InferTypes where
import Cryptol.TypeCheck.AST
@ -31,15 +34,13 @@ import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
data SolverConfig = SolverConfig
{ solverPath :: FilePath -- ^ The SMT solver to invoke
, solverArgs :: [String] -- ^ Additional arguments to pass to the solver
, solverVerbose :: Int -- ^ How verbose to be when type-checking
} deriving (Show, Generic)
instance NFData SolverConfig where rnf = genericRnf
} deriving (Show, Generic, NFData)
-- | The types of variables in the environment.
data VarType = ExtVar Schema -- ^ Known type
@ -62,12 +63,10 @@ insertGoal g (Goals tm) = Goals (insertTM (goal g) g tm)
-- | Something that we need to find evidence for.
data Goal = Goal
{ goalSource :: ConstraintSource -- ^ With it is about
{ goalSource :: ConstraintSource -- ^ What it is about
, goalRange :: Range -- ^ Part of source code that caused goal
, goal :: Prop -- ^ What needs to be proved
} deriving (Show,Generic)
instance NFData Goal where rnf = genericRnf
} deriving (Show, Generic, NFData)
data HasGoal = HasGoal
{ hasName :: !Int
@ -80,21 +79,17 @@ data DelayedCt = DelayedCt
, dctForall :: [TParam]
, dctAsmps :: [Prop]
, dctGoals :: [Goal]
} deriving (Show,Generic)
instance NFData DelayedCt where rnf = genericRnf
} deriving (Show, Generic, NFData)
data Solved = Solved (Maybe Subst) [Goal] -- ^ Solved, assuming the sub-goals.
| Unsolved -- ^ We could not solved the goal.
| Unsolvable -- ^ The goal can never be solved
| Unsolved -- ^ We could not solve the goal.
| Unsolvable -- ^ The goal can never be solved.
deriving (Show)
data Warning = DefaultingKind (P.TParam Name) P.Kind
| DefaultingWildType P.Kind
| DefaultingTo Doc Type
deriving (Show,Generic)
instance NFData Warning where rnf = genericRnf
deriving (Show, Generic, NFData)
-- | Various errors that might happen during type checking/inference
data Error = ErrorMsg Doc
@ -104,7 +99,7 @@ data Error = ErrorMsg Doc
-- ^ Expected kind, inferred kind
| TooManyTypeParams Int Kind
-- ^ Number of extra parameters, kind of resut
-- ^ Number of extra parameters, kind of result
-- (which should not be of the form @_ -> _@)
| TooManyTySynParams Name Int
@ -145,7 +140,7 @@ data Error = ErrorMsg Doc
-- The boolean indicates if we know that this constraint
-- is impossible.
| UnsolvedDelcayedCt DelayedCt
| UnsolvedDelayedCt DelayedCt
-- ^ A constraint (with context) that we could not solve
| UnexpectedTypeWildCard
@ -157,7 +152,7 @@ data Error = ErrorMsg Doc
-- that are not in scope.
| NotForAll TVar Type
-- ^ Quantified type variables (of kind *) needs to
-- ^ Quantified type variables (of kind *) need to
-- match the given type, so it does not work for all types.
| UnusableFunction Name [Prop]
@ -173,9 +168,7 @@ data Error = ErrorMsg Doc
| AmbiguousType [Name]
deriving (Show,Generic)
instance NFData Error where rnf = genericRnf
deriving (Show, Generic, NFData)
-- | Information about how a constraint came to be, used in error reporting.
data ConstraintSource
@ -189,14 +182,11 @@ data ConstraintSource
| CtDefaulting -- ^ Just defaulting on the command line
| CtPartialTypeFun TyFunName -- ^ Use of a partial type function.
| CtImprovement
deriving (Show,Generic)
instance NFData ConstraintSource where rnf = genericRnf
| CtPattern Doc -- ^ Constraints arising from type-checking patterns
deriving (Show, Generic, NFData)
data TyFunName = UserTyFun Name | BuiltInTyFun TFun
deriving (Show,Generic)
instance NFData TyFunName where rnf = genericRnf
deriving (Show, Generic, NFData)
instance PP TyFunName where
ppPrec c (UserTyFun x) = ppPrec c x
@ -215,6 +205,7 @@ instance TVars ConstraintSource where
CtDefaulting -> src
CtPartialTypeFun _ -> src
CtImprovement -> src
CtPattern _ -> src
instance TVars Warning where
apSubst su warn =
@ -250,7 +241,7 @@ instance TVars Error where
TypeMismatch t1 t2 -> TypeMismatch (apSubst su t1) (apSubst su t2)
RecursiveType t1 t2 -> RecursiveType (apSubst su t1) (apSubst su t2)
UnsolvedGoal x g -> UnsolvedGoal x (apSubst su g)
UnsolvedDelcayedCt g -> UnsolvedDelcayedCt (apSubst su g)
UnsolvedDelayedCt g -> UnsolvedDelayedCt (apSubst su g)
UnexpectedTypeWildCard -> err
TypeVariableEscaped t xs -> TypeVariableEscaped (apSubst su t) xs
NotForAll x t -> NotForAll x (apSubst su t)
@ -277,7 +268,7 @@ instance FVS Error where
TypeMismatch t1 t2 -> fvs (t1,t2)
RecursiveType t1 t2 -> fvs (t1,t2)
UnsolvedGoal _ g -> fvs g
UnsolvedDelcayedCt g -> fvs g
UnsolvedDelayedCt g -> fvs g
UnexpectedTypeWildCard -> Set.empty
TypeVariableEscaped t _ -> fvs t
NotForAll _ t -> fvs t
@ -457,7 +448,7 @@ instance PP (WithNames Error) where
nested (word <+> text "constraint:") (ppWithNames names g)
where word = if imp then text "Unsolvable" else text "Unsolved"
UnsolvedDelcayedCt g ->
UnsolvedDelayedCt g ->
nested (text "Failed to validate user-specified signature.")
(ppWithNames names g)
@ -486,7 +477,7 @@ instance PP (WithNames Error) where
AmbiguousType xs ->
text "The inferred type for" <+> commaSep (map pp xs)
<+> text "is ambiguous."
<+> text "is ambiguous."
where
nested x y = x $$ nest 2 y
@ -518,6 +509,7 @@ instance PP ConstraintSource where
CtDefaulting -> text "defaulting"
CtPartialTypeFun f -> text "use of partial type function" <+> pp f
CtImprovement -> text "examination of collected goals"
CtPattern desc -> text "checking a pattern:" <+> desc
ppUse :: Expr -> Doc
ppUse expr =
@ -564,4 +556,3 @@ instance PP Solved where
where suDoc = maybe empty pp mb
Unsolved -> text "unsolved"
Unsolvable -> text "unsolvable"

4
src/Cryptol/TypeCheck/Kind.hs
View File

@ -91,7 +91,7 @@ checkType t k =
do (_, t1) <- withTParams True [] $ doCheckType t k
return t1
{- | Check someting with type parameters.
{- | Check something with type parameters.
When we check things with type parameters (i.e., type schemas, and type
synonym declarations) we do kind inference based only on the immediately
@ -113,7 +113,7 @@ To use such a function, we'd have to provide an explicit type application:
There are two reasons for this choice:
1. It makes it possible to figure if something is correct without
having to look trough arbitrary amounts of code.
having to look through arbitrary amounts of code.
2. It is a bit easier to implement, and it covers the large majority
of use cases, with a very small inconvenience (an explicit kind

34
src/Cryptol/TypeCheck/Monad.hs
View File

@ -5,15 +5,18 @@
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE RecordWildCards, Safe #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
module Cryptol.TypeCheck.Monad
( module Cryptol.TypeCheck.Monad
, module Cryptol.TypeCheck.InferTypes
) where
import Cryptol.ModuleSystem.Name (SupplyT,runSupplyT,FreshM(..),Supply)
import Cryptol.ModuleSystem.Name (FreshM(..),Supply)
import Cryptol.Parser.Position
import qualified Cryptol.Parser.AST as P
import Cryptol.TypeCheck.AST
@ -36,7 +39,7 @@ import Data.Function(on)
import MonadLib hiding (mapM)
import GHC.Generics (Generic)
import Control.DeepSeq.Generics
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
@ -66,9 +69,7 @@ data InferInput = InferInput
data NameSeeds = NameSeeds
{ seedTVar :: !Int
, seedGoal :: !Int
} deriving (Show, Generic)
instance NFData NameSeeds where rnf = genericRnf
} deriving (Show, Generic, NFData)
-- | The initial seeds, used when checking a fresh program.
nameSeeds :: NameSeeds
@ -99,9 +100,8 @@ runInferM info (IM m) = CrySAT.withSolver (inpSolverConfig info) $ \solver ->
, iPrimNames = inpPrimNames info
}
((result, finalRW),supply') <-
runSupplyT (inpSupply info) $ runStateT rw
$ runReaderT ro m -- RECURSION
(result, finalRW) <- runStateT rw
$ runReaderT ro m -- RECURSION
let theSu = iSubst finalRW
defSu = defaultingSubst theSu
@ -114,7 +114,7 @@ runInferM info (IM m) = CrySAT.withSolver (inpSolverConfig info) $ \solver ->
| nullGoals cts
-> return $ InferOK warns
(iNameSeeds finalRW)
supply'
(iSupply finalRW)
(apSubst defSu result)
(cts,has) -> return $ InferFailed warns
$ dropErrorsFromSameLoc
@ -138,6 +138,8 @@ runInferM info (IM m) = CrySAT.withSolver (inpSolverConfig info) $ \solver ->
, iCts = emptyGoals
, iHasCts = []
, iSolvedHas = Map.empty
, iSupply = inpSupply info
}
dropErrorsFromSameLoc = map chooseBestError . groupBy ((==) `on` fst)
@ -152,7 +154,7 @@ runInferM info (IM m) = CrySAT.withSolver (inpSolverConfig info) $ \solver ->
newtype InferM a = IM { unIM :: ReaderT RO (StateT RW (SupplyT IO)) a }
newtype InferM a = IM { unIM :: ReaderT RO (StateT RW IO) a }
data DefLoc = IsLocal | IsExternal
@ -223,6 +225,8 @@ data RW = RW
, iHasCts :: ![HasGoal]
{- ^ Tuple/record projection constraints. The `Int` is the "name"
of the constraint, used so that we can name it solution properly. -}
, iSupply :: !Supply
}
instance Functor InferM where
@ -241,7 +245,11 @@ instance MonadFix InferM where
mfix f = IM (mfix (unIM . f))
instance FreshM InferM where
liftSupply f = IM (liftSupply f)
liftSupply f = IM $
do rw <- get
let (a,s') = f (iSupply rw)
set rw { iSupply = s' }
return a
io :: IO a -> InferM a

4
src/Cryptol/TypeCheck/Sanity.hs
View File

@ -326,7 +326,7 @@ convertible t1 t2
convertible t1 t2 = go t1 t2
where
go ty1 ty2 =
let err = reportError $ TypeMismatch (tMono ty1) (tMono ty2)
let err = reportError $ TypeMismatch (tMono ty1) (tMono ty2)
other = tNoUser ty2
goMany [] [] = return ()
@ -533,5 +533,3 @@ lookupVar x =
case Map.lookup x (roVars ro) of
Just s -> return s
Nothing -> reportError $ UndefinedVariable x

Some files were not shown because too many files have changed in this diff Show More