add NFData instances for many cryptol types

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

View File

@ -5,9 +5,9 @@
-- Maintainer : cryptol@galois.com -- Maintainer : cryptol@galois.com
-- Stability : provisional -- Stability : provisional
-- Portability : portable -- 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 as T
import qualified Data.Text.Lazy.IO 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.AST as P
import qualified Cryptol.Parser.NoInclude 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 import Criterion.Main
@ -30,11 +33,26 @@ main = defaultMain [
parser "Prelude" "lib/Cryptol.cry" parser "Prelude" "lib/Cryptol.cry"
, parser "BigSequence" "bench/data/BigSequence.cry" , parser "BigSequence" "bench/data/BigSequence.cry"
, parser "BigSequenceHex" "bench/data/BigSequenceHex.cry" , parser "BigSequenceHex" "bench/data/BigSequenceHex.cry"
, parser "AES" "bench/data/AES.cry"
] ]
, bgroup "typechecker" [ , bgroup "typechecker" [
tc "Prelude" "lib/Cryptol.cry" tc "Prelude" "lib/Cryptol.cry"
, tc "BigSequence" "bench/data/BigSequence.cry" , tc "BigSequence" "bench/data/BigSequence.cry"
, tc "BigSequenceHex" "bench/data/BigSequenceHex.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 :: String -> FilePath -> Benchmark
parser name path = parser name path =
env (T.readFile path) $ \(~bytes) -> env (T.readFile path) $ \(~bytes) ->
bench name $ whnfIO $ do bench name $ nfIO $ do
let cfg = P.defaultConfig let cfg = P.defaultConfig
{ P.cfgSource = path { P.cfgSource = path
, P.cfgPreProc = P.guessPreProc path , P.cfgPreProc = P.guessPreProc path
@ -73,15 +91,37 @@ tc name path =
M.renameModule npm M.renameModule npm
return (scm, menv') return (scm, menv')
in env setup $ \ ~(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 let act = M.TCAction { M.tcAction = T.tcModule
, M.tcLinter = M.moduleLinter (P.thing (P.mName scm)) } , M.tcLinter = M.moduleLinter (P.thing (P.mName scm)) }
M.typecheck act scm =<< M.importIfacesTc (map P.thing (P.mImports 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... ceval :: String -> FilePath -> T.Text -> Benchmark
instance NFData P.Module where ceval name path expr =
rnf _ = () 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... seval :: Bool-> String -> FilePath -> T.Text -> Benchmark
instance NFData M.ModuleEnv where seval useIte name path expr =
rnf _ = () 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'

View File

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

View File

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

View File

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

View File

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

View File

@ -7,7 +7,7 @@
-- Portability : portable -- Portability : portable
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.ModuleSystem.Monad where module Cryptol.ModuleSystem.Monad where
import Cryptol.Eval.Env (EvalEnv) import Cryptol.Eval.Env (EvalEnv)
@ -30,6 +30,9 @@ import Data.Function (on)
import Data.Maybe (isJust) import Data.Maybe (isJust)
import MonadLib import MonadLib
import GHC.Generics (Generic)
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..)) import Control.Applicative (Applicative(..))
#endif #endif
@ -39,7 +42,7 @@ import Control.Applicative (Applicative(..))
data ImportSource data ImportSource
= FromModule P.ModName = FromModule P.ModName
| FromImport (Located P.Import) | FromImport (Located P.Import)
deriving (Show) deriving (Show,Generic,NFData)
instance Eq ImportSource where instance Eq ImportSource where
(==) = (==) `on` importedModule (==) = (==) `on` importedModule
@ -82,6 +85,23 @@ data ModuleError
-- ^ Two modules loaded from different files have the same module name -- ^ Two modules loaded from different files have the same module name
deriving (Show) 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 instance PP ModuleError where
ppPrec _ e = case e of ppPrec _ e = case e of
@ -184,7 +204,7 @@ duplicateModuleName name path1 path2 =
data ModuleWarning data ModuleWarning
= TypeCheckWarnings [(Range,T.Warning)] = TypeCheckWarnings [(Range,T.Warning)]
| RenamerWarnings [RenamerWarning] | RenamerWarnings [RenamerWarning]
deriving (Show) deriving (Show,Generic,NFData)
instance PP ModuleWarning where instance PP ModuleWarning where
ppPrec _ w = case w of ppPrec _ w = case w of

View File

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

View File

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

View File

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

View File

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

View File

@ -8,6 +8,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternGuards #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Cryptol.Parser.LexerUtils where module Cryptol.Parser.LexerUtils where
import Cryptol.Parser.Position import Cryptol.Parser.Position
@ -22,6 +23,8 @@ import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy as T
import Data.Word(Word8) import Data.Word(Word8)
import GHC.Generics (Generic)
import Control.DeepSeq
data Config = Config data Config = Config
{ cfgSource :: !FilePath -- ^ File that we are working on { 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 } data Token = Token { tokenType :: TokenT, tokenText :: Text }
deriving Show deriving (Show, Generic, NFData)
-- | Virtual tokens, inserted by layout processing. -- | Virtual tokens, inserted by layout processing.
data TokenV = VCurlyL| VCurlyR | VSemi data TokenV = VCurlyL| VCurlyR | VSemi
deriving (Eq,Show) deriving (Eq,Show,Generic,NFData)
data TokenW = BlockComment | LineComment | Space | DocStr data TokenW = BlockComment | LineComment | Space | DocStr
deriving (Eq,Show) deriving (Eq,Show,Generic,NFData)
data TokenKW = KW_Arith data TokenKW = KW_Arith
| KW_Bit | KW_Bit
@ -393,7 +396,7 @@ data TokenKW = KW_Arith
| KW_infixr | KW_infixr
| KW_infix | KW_infix
| KW_primitive | KW_primitive
deriving (Eq,Show) deriving (Eq,Show,Generic,NFData)
-- | The named operators are a special case for parsing types, and 'Other' is -- | The named operators are a special case for parsing types, and 'Other' is
-- used for all other cases that lexed as an operator. -- 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 | Equal | LEQ | GEQ
| Complement | Hash | Complement | Hash
| Other [String] String | Other [String] String
deriving (Eq,Show) deriving (Eq,Show,Generic,NFData)
data TokenSym = Bar data TokenSym = Bar
| ArrL | ArrR | FatArrR | ArrL | ArrR | FatArrR
@ -419,7 +422,7 @@ data TokenSym = Bar
| CurlyL | CurlyR | CurlyL | CurlyR
| TriL | TriR | TriL | TriR
| Underscore | Underscore
deriving (Eq,Show) deriving (Eq,Show,Generic,NFData)
data TokenErr = UnterminatedComment data TokenErr = UnterminatedComment
| UnterminatedString | UnterminatedString
@ -427,7 +430,7 @@ data TokenErr = UnterminatedComment
| InvalidString | InvalidString
| InvalidChar | InvalidChar
| LexicalError | LexicalError
deriving (Eq,Show) deriving (Eq,Show,Generic,NFData)
data TokenT = Num Integer Int Int -- ^ value, base, number of digits data TokenT = Num Integer Int Int -- ^ value, base, number of digits
| ChrLit Char -- ^ character literal | ChrLit Char -- ^ character literal
@ -440,7 +443,7 @@ data TokenT = Num Integer Int Int -- ^ value, base, number of digits
| White TokenW -- ^ white space token | White TokenW -- ^ white space token
| Err TokenErr -- ^ error token | Err TokenErr -- ^ error token
| EOF | EOF
deriving (Eq,Show) deriving (Eq,Show,Generic,NFData)
instance PP Token where instance PP Token where
ppPrec _ (Token _ s) = text (T.unpack s) ppPrec _ (Token _ s) = text (T.unpack s)

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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