mirror of
https://github.com/GaloisInc/cryptol.git
synced 2024-09-11 14:06:13 +03:00
Merge branch 'release/2.4.0' into releases
This commit is contained in:
commit
a904a6726e
6
Makefile
6
Makefile
@ -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,
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
]
|
||||
|
1071
cabal.GHC783.config
1071
cabal.GHC783.config
File diff suppressed because it is too large
Load Diff
1314
cabal.GHC80.config
Normal file
1314
cabal.GHC80.config
Normal file
File diff suppressed because it is too large
Load Diff
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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."
|
||||
|
@ -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` "_\'"
|
||||
|
||||
|
@ -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
|
||||
|
Binary file not shown.
Binary file not shown.
@ -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
|
||||
|
||||
|
@ -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
|
||||
]
|
||||
|
@ -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
2
docs/ProgrammingCryptol/appendices/Makefile
Normal file
@ -0,0 +1,2 @@
|
||||
Syntax.tex : ../../Syntax.md
|
||||
pandoc ../../Syntax.md --to latex > Syntax.tex
|
@ -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}
|
||||
|
@ -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:
|
||||
|
@ -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}
|
||||
|
||||
|
File diff suppressed because one or more lines are too long
BIN
docs/ProgrammingCryptol/cover/CryptolCover.pdf
Normal file
BIN
docs/ProgrammingCryptol/cover/CryptolCover.pdf
Normal file
Binary file not shown.
Binary file not shown.
@ -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}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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}
|
@ -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
|
||||
|
@ -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"
|
||||
|
@ -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,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
|
||||
|
251
docs/ProgrammingCryptol/technicalities/TechAppendix.tex
Normal file
251
docs/ProgrammingCryptol/technicalities/TechAppendix.tex
Normal 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:
|
@ -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}
|
||||
|
@ -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
BIN
docs/Syntax.pdf
Binary file not shown.
@ -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
|
||||
|
Binary file not shown.
@ -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.
|
||||
|
||||
|
||||
|
@ -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]
|
||||
]
|
||||
|
||||
|
@ -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,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]
|
||||
|
@ -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
|
||||
]
|
||||
|
||||
|
@ -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])
|
||||
|
@ -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
|
||||
|
@ -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:
|
||||
|
@ -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
|
||||
|
@ -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 ]
|
||||
|
||||
|
@ -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]
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
53
examples/contrib/A51.cry
Normal 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
75
examples/contrib/bivium.cry
Normal 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
87
examples/contrib/trivium.cry
Normal 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)
|
@ -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
|
||||
|
||||
|
@ -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])
|
||||
|
||||
|
@ -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]
|
||||
]
|
||||
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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 =
|
||||
|
@ -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 -------------------------------------------------------------------
|
||||
|
@ -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 }
|
||||
|
@ -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 =
|
||||
|
@ -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
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
@ -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:
|
||||
--
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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))
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -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))
|
||||
|
@ -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 =
|
||||
|
@ -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) =
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
@ -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') ->
|
||||
|
@ -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 -------------------------------------------------------------
|
||||
|
@ -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]) ->
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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 }
|
||||
|
@ -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)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
||||
|
@ -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"
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
Loading…
Reference in New Issue
Block a user