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

add NFData instances for many cryptol types

Browse Source 
add more benchmarks as well
This commit is contained in:
Adam C. Foltzer 2015-08-12 14:29:30 -07:00
parent e9c85a3925
commit 4e6dcaa026
20 changed files with 233 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
bench/Main.hs
View File

@ -5,9 +5,9 @@
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
module Main where
import Control.DeepSeq
{-# LANGUAGE OverloadedStrings #-}
module Main where
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as T
@ -20,7 +20,10 @@ import qualified Cryptol.Parser as P
import qualified Cryptol.Parser.AST as P
import qualified Cryptol.Parser.NoInclude as P
import qualified Cryptol.TypeCheck as T
import qualified Cryptol.Symbolic as S
import qualified Cryptol.TypeCheck as T
import qualified Cryptol.TypeCheck.AST as T
import Criterion.Main
@ -30,11 +33,26 @@ main = defaultMain [
parser "Prelude" "lib/Cryptol.cry"
, parser "BigSequence" "bench/data/BigSequence.cry"
, parser "BigSequenceHex" "bench/data/BigSequenceHex.cry"
, parser "AES" "bench/data/AES.cry"
]
, bgroup "typechecker" [
tc "Prelude" "lib/Cryptol.cry"
, tc "BigSequence" "bench/data/BigSequence.cry"
, tc "BigSequenceHex" "bench/data/BigSequenceHex.cry"
, tc "AES" "bench/data/AES.cry"
]
, bgroup "conc_eval" [
ceval "AES" "bench/data/AES.cry" "bench bench_data"
]
, bgroup "sym_eval" [
seval False "AES" "bench/data/AES.cry" "aesEncrypt (zero, zero)"
, seval False "ZUC"
"bench/data/ZUC.cry" "ZUC_isResistantToCollisionAttack"
]
, bgroup "sym_eval_ite" [
seval True "aesEncrypt" "bench/data/AES.cry" "aesEncrypt (zero, zero)"
, seval True "ZUC"
"bench/data/ZUC.cry" "ZUC_isResistantToCollisionAttack"
]
]
@ -42,7 +60,7 @@ main = defaultMain [
parser :: String -> FilePath -> Benchmark
parser name path =
env (T.readFile path) $ \(~bytes) ->
bench name $ whnfIO $ do
bench name $ nfIO $ do
let cfg = P.defaultConfig
{ P.cfgSource = path
, P.cfgPreProc = P.guessPreProc path
@ -73,15 +91,37 @@ tc name path =
M.renameModule npm
return (scm, menv')
in env setup $ \ ~(scm, menv) ->
bench name $ whnfIO $ M.runModuleM menv $ do
bench name $ nfIO $ M.runModuleM menv $ do
let act = M.TCAction { M.tcAction = T.tcModule
, M.tcLinter = M.moduleLinter (P.thing (P.mName scm)) }
M.typecheck act scm =<< M.importIfacesTc (map P.thing (P.mImports scm))
-- FIXME: this should only throw off the first benchmark run, but still...
instance NFData P.Module where
rnf _ = ()
ceval :: String -> FilePath -> T.Text -> Benchmark
ceval name path expr =
let setup = do
menv <- M.initialModuleEnv
(Right (texpr, menv'), _) <- M.runModuleM menv $ do
m <- M.loadModuleByPath path
M.setFocusedModule (T.mName m)
let Right pexpr = P.parseExpr expr
(_, texpr, _) <- M.checkExpr pexpr
return texpr
return (texpr, menv')
in env setup $ \ ~(texpr, menv) ->
bench name $ nfIO $ M.runModuleM menv $ M.evalExpr texpr
-- FIXME: this should only throw off the first benchmark run, but still...
instance NFData M.ModuleEnv where
rnf _ = ()
seval :: Bool-> String -> FilePath -> T.Text -> Benchmark
seval useIte name path expr =
let setup = do
menv <- M.initialModuleEnv
(Right (texpr, menv'), _) <- M.runModuleM menv $ do
m <- M.loadModuleByPath path
M.setFocusedModule (T.mName m)
let Right pexpr = P.parseExpr expr
(_, texpr, _) <- M.checkExpr pexpr
return texpr
return (texpr, menv')
in env setup $ \ ~(texpr, menv) ->
bench name $ flip nf texpr $ \texpr' ->
let senv = S.evalDecls (S.emptyEnv useIte) (S.allDeclGroups menv)
in S.evalExpr senv texpr'

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

@ -8,7 +8,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.Eval.Env where
import Cryptol.Eval.Value
@ -17,6 +17,9 @@ import Cryptol.Utils.PP
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid(..))
#endif
@ -28,7 +31,7 @@ type ReadEnv = EvalEnv
data EvalEnv = EvalEnv
{ envVars :: Map.Map QName Value
, envTypes :: Map.Map TVar TValue
}
} deriving (Generic, NFData)
instance Monoid EvalEnv where
mempty = EvalEnv

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

@ -11,7 +11,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.Eval.Value where
import qualified Cryptol.Eval.Arch as Arch
@ -26,6 +26,8 @@ import Data.List(genericTake)
import Data.Bits (setBit,testBit,(.&.),shiftL)
import Numeric (showIntAtBase)
import GHC.Generics (Generic)
import Control.DeepSeq
-- Utilities -------------------------------------------------------------------
@ -75,8 +77,9 @@ finTValue tval =
-- Values ----------------------------------------------------------------------
data BV = BV !Integer !Integer -- ^ width, value
-- The value may contain junk bits
-- | width, value
-- The value may contain junk bits
data BV = BV !Integer !Integer deriving (Generic, NFData)
-- | Smart constructor for 'BV's that checks for the width limit
mkBv :: Integer -> Integer -> BV
@ -95,12 +98,13 @@ 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, NFData)
type Value = GenValue Bool BV
-- | An evaluated type.
-- These types do not contain type variables, type synonyms, or type functions.
newtype TValue = TValue { tValTy :: Type }
newtype TValue = TValue { tValTy :: Type } deriving (Generic, NFData)
instance Show TValue where
showsPrec p (TValue v) = showsPrec p v

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

@ -8,7 +8,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.ModuleSystem.Env where
#ifndef RELOCATABLE
@ -33,6 +33,9 @@ import System.Environment(getExecutablePath)
import System.FilePath ((</>), normalise, joinPath, splitPath, takeDirectory)
import qualified Data.List as List
import GHC.Generics (Generic)
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid(..))
#endif
@ -49,10 +52,11 @@ data ModuleEnv = ModuleEnv
, meMonoBinds :: !Bool
, meSolverConfig :: T.SolverConfig
, meCoreLint :: CoreLint
}
} deriving (Generic, NFData)
data CoreLint = NoCoreLint -- ^ Don't run core lint
| CoreLint -- ^ Run core lint
deriving (Generic, NFData)
resetModuleEnv :: ModuleEnv -> ModuleEnv
resetModuleEnv env = env
@ -159,7 +163,7 @@ loadModuleEnv processIface me = do
newtype LoadedModules = LoadedModules
{ getLoadedModules :: [LoadedModule]
} deriving (Show)
} deriving (Show, Generic, NFData)
-- ^ Invariant: All the dependencies of any module `m` must precede `m` in the list.
instance Monoid LoadedModules where
@ -172,7 +176,7 @@ data LoadedModule = LoadedModule
, lmFilePath :: FilePath
, lmInterface :: Iface
, lmModule :: T.Module
} deriving (Show)
} deriving (Show, Generic, NFData)
isLoaded :: ModName -> LoadedModules -> Bool
isLoaded mn lm = any ((mn ==) . lmName) (getLoadedModules lm)
@ -213,7 +217,7 @@ data DynamicEnv = DEnv
{ deNames :: R.NamingEnv
, deDecls :: [T.DeclGroup]
, deEnv :: EvalEnv
}
} deriving (Generic, NFData)
instance Monoid DynamicEnv where
mempty = DEnv

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

@ -7,6 +7,7 @@
-- Portability : portable
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.ModuleSystem.Interface (
Iface(..)
, IfaceDecls(..)
@ -26,6 +27,9 @@ import Cryptol.Utils.PP
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid(..))
#endif
@ -35,13 +39,13 @@ data Iface = Iface
{ ifModName :: ModName
, ifPublic :: IfaceDecls
, ifPrivate :: IfaceDecls
} deriving (Show)
} deriving (Show, Generic, NFData)
data IfaceDecls = IfaceDecls
{ ifTySyns :: Map.Map QName [IfaceTySyn]
, ifNewtypes :: Map.Map QName [IfaceNewtype]
, ifDecls :: Map.Map QName [IfaceDecl]
} deriving (Show)
} deriving (Show, Generic, NFData)
instance Monoid IfaceDecls where
mempty = IfaceDecls Map.empty Map.empty Map.empty
@ -84,7 +88,7 @@ data IfaceDecl = IfaceDecl
, ifDeclInfix :: Bool
, ifDeclFixity :: Maybe Fixity
, ifDeclDoc :: Maybe String
} deriving (Show)
} deriving (Show, Generic, NFData)
mkIfaceDecl :: Decl -> IfaceDecl
mkIfaceDecl d = IfaceDecl

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

@ -7,7 +7,7 @@
-- Portability : portable
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.ModuleSystem.Monad where
import Cryptol.Eval.Env (EvalEnv)
@ -30,6 +30,9 @@ import Data.Function (on)
import Data.Maybe (isJust)
import MonadLib
import GHC.Generics (Generic)
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..))
#endif
@ -39,7 +42,7 @@ import Control.Applicative (Applicative(..))
data ImportSource
= FromModule P.ModName
| FromImport (Located P.Import)
deriving (Show)
deriving (Show,Generic,NFData)
instance Eq ImportSource where
(==) = (==) `on` importedModule
@ -82,6 +85,23 @@ data ModuleError
-- ^ Two modules loaded from different files have the same module name
deriving (Show)
instance NFData ModuleError where
rnf e = case e of
ModuleNotFound src path -> src `deepseq` path `deepseq` ()
CantFindFile path -> path `deepseq` ()
OtherIOError path exn -> path `deepseq` exn `seq` ()
ModuleParseError source err -> source `deepseq` err `deepseq` ()
RecursiveModules mods -> mods `deepseq` ()
RenamerErrors src errs -> src `deepseq` errs `deepseq` ()
NoPatErrors src errs -> src `deepseq` errs `deepseq` ()
NoIncludeErrors src errs -> src `deepseq` errs `deepseq` ()
TypeCheckingFailed src errs -> src `deepseq` errs `deepseq` ()
ModuleNameMismatch expected found ->
expected `deepseq` found `deepseq` ()
DuplicateModuleName name path1 path2 ->
name `deepseq` path1 `deepseq` path2 `deepseq` ()
OtherFailure x -> x `deepseq` ()
instance PP ModuleError where
ppPrec _ e = case e of
@ -184,7 +204,7 @@ duplicateModuleName name path1 path2 =
data ModuleWarning
= TypeCheckWarnings [(Range,T.Warning)]
| RenamerWarnings [RenamerWarning]
deriving (Show)
deriving (Show,Generic,NFData)
instance PP ModuleWarning where
ppPrec _ w = case w of

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

@ -1,18 +1,21 @@
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.ModuleSystem.Name where
import GHC.Generics (Generic)
import Control.DeepSeq
-- | Module names are just namespaces.
--
-- INVARIANT: the list of strings should never be empty in a valid module name.
newtype ModName = ModName [String]
deriving (Eq,Ord,Show)
deriving (Eq,Ord,Show,Generic,NFData)
data Name = Name String
| NewName Pass Int
deriving (Eq,Ord,Show)
deriving (Eq,Ord,Show,Generic,NFData)
data QName = QName (Maybe ModName) Name
deriving (Eq,Ord,Show)
deriving (Eq,Ord,Show,Generic,NFData)
-- XXX It would be nice to also mark this as a name that doesn't need to be
-- resolved, if it's going to be created before renaming.
@ -30,4 +33,4 @@ unqual (QName _ n) = n
data Pass = NoPat | MonoValues
deriving (Eq,Ord,Show)
deriving (Eq,Ord,Show,Generic,NFData)

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

@ -6,6 +6,7 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.ModuleSystem.NamingEnv where
import Cryptol.ModuleSystem.Interface
@ -19,6 +20,9 @@ import Cryptol.Utils.Panic (panic)
import Data.Maybe (catMaybes)
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative, (<$>), (<*>), pure)
import Data.Monoid (Monoid(..))
@ -30,7 +34,7 @@ import Data.Traversable (traverse)
data NameOrigin = Local (Located QName)
| Imported QName
deriving (Show)
deriving (Show,Generic,NFData)
instance PP NameOrigin where
ppPrec _ o = case o of
@ -47,13 +51,13 @@ instance PP NameOrigin where
data EName = EFromBind (Located QName)
| EFromNewtype (Located QName)
| EFromMod QName
deriving (Show)
deriving (Show, Generic, NFData)
data TName = TFromParam QName
| TFromSyn (Located QName)
| TFromNewtype (Located QName)
| TFromMod QName
deriving (Show)
deriving (Show, Generic, NFData)
class HasQName a where
qname :: a -> QName
@ -93,7 +97,7 @@ data NamingEnv = NamingEnv { neExprs :: Map.Map QName [EName]
, neTypes :: Map.Map QName [TName]
-- ^ Type renaming environment
, neFixity:: Map.Map QName [Fixity]
} deriving (Show)
} deriving (Show, Generic, NFData)
instance Monoid NamingEnv where
mempty =

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

@ -10,7 +10,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.ModuleSystem.Renamer (
NamingEnv(), shadowing
, BindsNames(..)
@ -31,6 +31,9 @@ import Cryptol.Utils.PP
import MonadLib
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative(Applicative(..),(<$>))
import Data.Foldable (foldMap)
@ -67,7 +70,7 @@ data RenamerError
| InvalidConstraint Type
-- ^ When it's not possible to produce a Prop from a Type.
deriving (Show)
deriving (Show,Generic,NFData)
instance PP RenamerError where
ppPrec _ e = case e of
@ -115,7 +118,7 @@ instance PP RenamerError where
data RenamerWarning
= SymbolShadowed NameOrigin [NameOrigin]
deriving (Show)
deriving (Show,Generic,NFData)
instance PP RenamerWarning where
ppPrec _ (SymbolShadowed new originals) =

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

@ -11,6 +11,7 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.Parser.AST
( -- * Names
ModName(..), {-splitNamespace, parseModName, nsChar,-} modRange
@ -78,6 +79,9 @@ import Data.Bits(shiftR)
import Data.Maybe (catMaybes)
import Numeric(showIntAtBase)
import GHC.Generics (Generic)
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 710
import Data.Foldable (Foldable(..))
import Data.Monoid (Monoid(..))
@ -101,7 +105,7 @@ newtype Program = Program [TopDecl]
data Module = Module { mName :: Located ModName
, mImports :: [Located Import]
, mDecls :: [TopDecl]
} deriving (Show)
} deriving (Show, Generic, NFData)
modRange :: Module -> Range
modRange m = rCombs $ catMaybes
@ -115,7 +119,7 @@ modRange m = rCombs $ catMaybes
data TopDecl = Decl (TopLevel Decl)
| TDNewtype (TopLevel Newtype)
| Include (Located FilePath)
deriving (Show)
deriving (Show,Generic,NFData)
data Decl = DSignature [LQName] Schema
| DFixity !Fixity [LQName]
@ -124,13 +128,13 @@ data Decl = DSignature [LQName] Schema
| DPatBind Pattern Expr
| DType TySyn
| DLocated Decl Range
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
-- | An import declaration.
data Import = Import { iModule :: ModName
, iAs :: Maybe ModName
, iSpec :: Maybe ImportSpec
} deriving (Eq,Show)
} deriving (Eq,Show,Generic,NFData)
-- | The list of names following an import.
--
@ -139,10 +143,10 @@ data Import = Import { iModule :: ModName
-- present.
data ImportSpec = Hiding [Name]
| Only [Name]
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data TySyn = TySyn LQName [TParam] Type
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
{- | Bindings. Notes:
@ -165,17 +169,17 @@ data Bind = Bind { bName :: LQName -- ^ Defined thing
, bPragmas :: [Pragma] -- ^ Optional pragmas
, bMono :: Bool -- ^ Is this a monomorphic binding
, bDoc :: Maybe String -- ^ Optional doc string
} deriving (Eq,Show)
} deriving (Eq,Show,Generic,NFData)
type LBindDef = Located BindDef
data BindDef = DPrim
| DExpr Expr
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data Fixity = Fixity { fAssoc :: !Assoc
, fLevel :: !Int
} deriving (Eq,Show)
} deriving (Eq,Show,Generic,NFData)
data FixityCmp = FCError
| FCLeft
@ -198,12 +202,12 @@ defaultFixity = Fixity LeftAssoc 100
data Pragma = PragmaNote String
| PragmaProperty
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data Newtype = Newtype { nName :: LQName -- ^ Type name
, nParams :: [TParam] -- ^ Type params
, nBody :: [Named Type] -- ^ Constructor
} deriving (Eq,Show)
} deriving (Eq,Show,Generic,NFData)
-- | Input at the REPL, which can either be an expression or a @let@
-- statement.
@ -214,19 +218,19 @@ data ReplInput = ExprInput Expr
-- | Export information for a declaration.
data ExportType = Public
| Private
deriving (Eq,Show,Ord)
deriving (Eq,Show,Ord,Generic,NFData)
data TopLevel a = TopLevel { tlExport :: ExportType
, tlDoc :: Maybe (Located String)
, tlValue :: a
} deriving (Show)
} deriving (Show,Generic,NFData)
instance Functor TopLevel where
fmap f tl = tl { tlValue = f (tlValue tl) }
data ExportSpec = ExportSpec { eTypes :: Set.Set QName
, eBinds :: Set.Set QName
} deriving (Show)
} deriving (Show,Generic,NFData)
instance Monoid ExportSpec where
mempty = ExportSpec { eTypes = mempty, eBinds = mempty }
@ -261,12 +265,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)
deriving (Eq,Show,Generic,NFData)
-- | Literals.
data Literal = ECNum Integer NumInfo -- ^ @0x10@ (HexLit 2)
| ECString String -- ^ @\"hello\"@
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data Expr = EVar QName -- ^ @ x @
| ELit Literal -- ^ @ 0x10 @
@ -288,11 +292,11 @@ data Expr = EVar QName -- ^ @ x @
| EParens Expr -- ^ @ (e) @ (Removed by Fixity)
| EInfix Expr (LQName) Fixity Expr-- ^ @ a + b @ (Removed by Fixity)
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data TypeInst = NamedInst (Named Type)
| PosInst Type
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
{- | Selectors are used for projecting from various components.
@ -312,11 +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)
deriving (Eq,Show,Ord,Generic,NFData)
data Match = Match Pattern Expr -- ^ p <- e
| MatchLet Bind
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data Pattern = PVar LName -- ^ @ x @
| PWild -- ^ @ _ @
@ -326,27 +330,27 @@ data Pattern = PVar LName -- ^ @ x @
| PTyped Pattern Type -- ^ @ x : [8] @
| PSplit Pattern Pattern -- ^ @ (x # y) @
| PLocated Pattern Range -- ^ Location information
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data Named a = Named { name :: Located Name, value :: a }
deriving (Eq,Show,Foldable,Traversable)
deriving (Eq,Show,Foldable,Traversable,Generic,NFData)
instance Functor Named where
fmap f x = x { value = f (value x) }
data Schema = Forall [TParam] [Prop] Type (Maybe Range)
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data Kind = KNum | KType
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data TParam = TParam { tpName :: Name
, tpKind :: Maybe Kind
, tpRange :: Maybe Range
}
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
tpQName :: TParam -> QName
tpQName = mkUnqual . tpName
@ -366,7 +370,7 @@ data Type = TFun Type Type -- ^ @[8] -> [8]@
| TLocated Type Range -- ^ Location information
| TParens Type -- ^ @ (ty) @
| TInfix Type LQName Fixity Type -- ^ @ ty + ty @
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data Prop = CFin Type -- ^ @ fin x @
| CEqual Type Type -- ^ @ x == 10 @
@ -376,7 +380,7 @@ data Prop = CFin Type -- ^ @ fin x @
| CLocated Prop Range -- ^ Location information
| CType Type -- ^ After parsing
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
--------------------------------------------------------------------------------

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

@ -8,6 +8,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.Parser.LexerUtils where
import Cryptol.Parser.Position
@ -22,6 +23,8 @@ import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import Data.Word(Word8)
import GHC.Generics (Generic)
import Control.DeepSeq
data Config = Config
{ cfgSource :: !FilePath -- ^ File that we are working on
@ -352,14 +355,14 @@ virt cfg pos x = Located { srcRange = Range
--------------------------------------------------------------------------------
data Token = Token { tokenType :: TokenT, tokenText :: Text }
deriving Show
deriving (Show, Generic, NFData)
-- | Virtual tokens, inserted by layout processing.
data TokenV = VCurlyL| VCurlyR | VSemi
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data TokenW = BlockComment | LineComment | Space | DocStr
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data TokenKW = KW_Arith
| KW_Bit
@ -393,7 +396,7 @@ data TokenKW = KW_Arith
| KW_infixr
| KW_infix
| KW_primitive
deriving (Eq,Show)
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.
@ -401,7 +404,7 @@ data TokenOp = Plus | Minus | Mul | Div | Exp | Mod
| Equal | LEQ | GEQ
| Complement | Hash
| Other [String] String
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data TokenSym = Bar
| ArrL | ArrR | FatArrR
@ -419,7 +422,7 @@ data TokenSym = Bar
| CurlyL | CurlyR
| TriL | TriR
| Underscore
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data TokenErr = UnterminatedComment
| UnterminatedString
@ -427,7 +430,7 @@ data TokenErr = UnterminatedComment
| InvalidString
| InvalidChar
| LexicalError
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data TokenT = Num Integer Int Int -- ^ value, base, number of digits
| ChrLit Char -- ^ character literal
@ -440,7 +443,7 @@ data TokenT = Num Integer Int Int -- ^ value, base, number of digits
| White TokenW -- ^ white space token
| Err TokenErr -- ^ error token
| EOF
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
instance PP Token where
ppPrec _ (Token _ s) = text (T.unpack s)

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

@ -7,7 +7,7 @@
-- Portability : portable
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.Parser.NoInclude
( removeIncludesModule
, IncludeError(..), ppIncludeError
@ -28,6 +28,9 @@ import MonadLib
import qualified Control.Exception as X
import System.FilePath (takeDirectory,(</>),isAbsolute)
import GHC.Generics (Generic)
import Control.DeepSeq
#if MIN_VERSION_directory(1,2,2)
import System.Directory (makeAbsolute)
#else
@ -50,7 +53,7 @@ data IncludeError
= IncludeFailed (Located FilePath)
| IncludeParseError ParseError
| IncludeCycle [Located FilePath]
deriving (Show)
deriving (Show,Generic,NFData)
ppIncludeError :: IncludeError -> Doc
ppIncludeError ie = case ie of

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

@ -13,6 +13,7 @@
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.Parser.NoPat (RemovePatterns(..),Error(..)) where
import Cryptol.Parser.AST
@ -26,6 +27,9 @@ import Data.Maybe(maybeToList)
import Data.Either(partitionEithers)
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative(Applicative(..),(<$>),(<$))
import Data.Traversable(traverse)
@ -445,7 +449,7 @@ data Error = MultipleSignatures QName [Located Schema]
| MultipleFixities QName [Range]
| FixityNoBind (Located QName)
| MultipleDocs QName [Range]
deriving (Show)
deriving (Show,Generic,NFData)
instance Functor NoPatM where fmap = liftM
instance Applicative NoPatM where pure = return; (<*>) = ap

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

@ -7,6 +7,7 @@
-- Portability : portable
{-# LANGUAGE Safe, PatternGuards #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.Parser.ParserUtils where
import Cryptol.Parser.AST
@ -22,6 +23,9 @@ import Control.Monad(liftM,ap,unless)
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import GHC.Generics (Generic)
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>),Applicative(..))
import Data.Traversable (mapM)
@ -61,7 +65,7 @@ lexerP k = P $ \cfg p (S ts) ->
data ParseError = HappyError FilePath Position (Maybe Token)
| HappyErrorMsg Range String
deriving Show
deriving (Show, Generic, NFData)
newtype S = S [Located Token]

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

@ -7,23 +7,27 @@
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.Parser.Position where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import GHC.Generics (Generic)
import Control.DeepSeq
import Cryptol.Utils.PP
data Located a = Located { srcRange :: !Range, thing :: a }
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
data Position = Position { line :: !Int, col :: !Int }
deriving (Eq,Ord,Show)
deriving (Eq,Ord,Show,Generic,NFData)
data Range = Range { from :: !Position
, to :: !Position
, source :: FilePath }
deriving (Eq,Show)
deriving (Eq,Show,Generic,NFData)
-- | An empty range.
--

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

@ -6,6 +6,7 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.Prims.Syntax
( TFun(..), tBinOpPrec, tfunNames
) where
@ -14,6 +15,8 @@ import Cryptol.ModuleSystem.Name (QName,Name(Name),mkUnqual)
import Cryptol.Utils.PP
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq
-- | Built-in types.
data TFun
@ -35,7 +38,7 @@ data TFun
| TCLenFromThenTo -- ^ @ : Num -> Num -> Num -> Num@
-- Example: @[ 1, 5 .. 9 ] :: [lengthFromThenTo 1 5 9][b]@
deriving (Show, Eq, Ord, Bounded, Enum)
deriving (Show, Eq, Ord, Bounded, Enum, Generic, NFData)
tBinOpPrec :: Map.Map TFun (Assoc,Int)

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

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

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

@ -10,7 +10,7 @@
{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.TypeCheck.InferTypes where
import Cryptol.TypeCheck.AST
@ -27,13 +27,14 @@ import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import GHC.Generics (Generic)
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
} deriving (Show, Generic, NFData)
-- | The types of variables in the environment.
@ -60,7 +61,7 @@ data Goal = Goal
{ goalSource :: ConstraintSource -- ^ With it is about
, goalRange :: Range -- ^ Part of source code that caused goal
, goal :: Prop -- ^ What needs to be proved
} deriving Show
} deriving (Show,Generic,NFData)
data HasGoal = HasGoal
{ hasName :: !Int
@ -73,7 +74,7 @@ data DelayedCt = DelayedCt
, dctForall :: [TParam]
, dctAsmps :: [Prop]
, dctGoals :: [Goal]
} deriving Show
} deriving (Show,Generic,NFData)
data Solved = Solved (Maybe Subst) [Goal] -- ^ Solved, assuming the sub-goals.
| Unsolved -- ^ We could not solved the goal.
@ -83,7 +84,7 @@ data Solved = Solved (Maybe Subst) [Goal] -- ^ Solved, assuming the sub-goals.
data Warning = DefaultingKind P.TParam P.Kind
| DefaultingWildType P.Kind
| DefaultingTo Doc Type
deriving Show
deriving (Show,Generic,NFData)
-- | Various errors that might happen during type checking/inference
data Error = ErrorMsg Doc
@ -162,7 +163,7 @@ data Error = ErrorMsg Doc
| AmbiguousType [QName]
deriving Show
deriving (Show,Generic,NFData)
-- | Information about how a constraint came to be, used in error reporting.
data ConstraintSource
@ -176,10 +177,10 @@ data ConstraintSource
| CtDefaulting -- ^ Just defaulting on the command line
| CtPartialTypeFun TyFunName -- ^ Use of a partial type function.
| CtImprovement
deriving Show
deriving (Show,Generic,NFData)
data TyFunName = UserTyFun QName | BuiltInTyFun TFun
deriving Show
deriving (Show,Generic,NFData)
instance PP TyFunName where
ppPrec c (UserTyFun x) = ppPrec c x

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

@ -12,6 +12,7 @@
#else
{-# LANGUAGE DoRec #-}
#endif
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.TypeCheck.Monad
( module Cryptol.TypeCheck.Monad
, module Cryptol.TypeCheck.InferTypes
@ -37,6 +38,9 @@ import MonadLib
import qualified Control.Applicative as A
import Control.Monad.Fix(MonadFix(..))
import GHC.Generics (Generic)
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 710
import Data.Functor
#endif
@ -59,7 +63,7 @@ data InferInput = InferInput
data NameSeeds = NameSeeds
{ seedTVar :: !Int
, seedGoal :: !Int
} deriving Show
} deriving (Show, Generic, NFData)
-- | The initial seeds, used when checking a fresh program.
nameSeeds :: NameSeeds

7
src/Cryptol/Utils/PP.hs
View File

@ -8,6 +8,7 @@
{-# LANGUAGE Safe #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.Utils.PP where
import Cryptol.ModuleSystem.Name
@ -18,6 +19,8 @@ import qualified Data.Monoid as M
import Data.String (IsString(..))
import qualified Text.PrettyPrint as PJ
import GHC.Generics (Generic)
import Control.DeepSeq
-- | How to display names.
newtype NameEnv = NameEnv (Map QName NameInfo)
@ -43,7 +46,7 @@ instance M.Monoid NameEnv where
mempty = NameEnv Map.empty
mappend (NameEnv a) (NameEnv b) = NameEnv (Map.union a b)
newtype Doc = Doc (NameEnv -> PJ.Doc)
newtype Doc = Doc (NameEnv -> PJ.Doc) deriving (Generic, NFData)
runDoc :: NameEnv -> Doc -> PJ.Doc
runDoc names (Doc f) = f names
@ -73,7 +76,7 @@ optParens b body | b = parens body
-- | Information about associativity.
data Assoc = LeftAssoc | RightAssoc | NonAssoc
deriving (Show,Eq)
deriving (Show,Eq,Generic,NFData)
-- | Information about an infix expression of some sort.
data Infix op thing = Infix