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

Allow cryptol implementation of foreign functions

Browse Source
This commit is contained in:
Bretton 2023-08-21 10:46:49 -07:00
parent cd5d006277
commit 58a3b06796
20 changed files with 302 additions and 199 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cryptol-remote-api/src/CryptolServer/Data/Expression.hs
View File

@ -518,7 +518,7 @@ getCryptolExpr (Let binds body) =
, CP.bExport = CP.Public , CP.bExport = CP.Public
}) . }) .
fakeLoc . fakeLoc .
CP.DExpr <$> CP.exprDef <$>
getCryptolExpr rhs getCryptolExpr rhs
fakeLoc = Located emptyRange fakeLoc = Located emptyRange

14
src/Cryptol/Eval.hs
View File

@ -432,11 +432,11 @@ declHole ::
sym -> Decl -> SEval sym (Name, Schema, SEval sym (GenValue sym), SEval sym (GenValue sym) -> SEval sym ()) sym -> Decl -> SEval sym (Name, Schema, SEval sym (GenValue sym), SEval sym (GenValue sym) -> SEval sym ())
declHole sym d = declHole sym d =
case dDefinition d of case dDefinition d of
DPrim -> evalPanic "Unexpected primitive declaration in recursive group" DPrim -> evalPanic "Unexpected primitive declaration in recursive group"
[show (ppLocName nm)] [show (ppLocName nm)]
DForeign _ -> evalPanic "Unexpected foreign declaration in recursive group" DForeign _ _ -> evalPanic "Unexpected foreign declaration in recursive group"
[show (ppLocName nm)] [show (ppLocName nm)]
DExpr _ -> do DExpr _ -> do
(hole, fill) <- sDeclareHole sym msg (hole, fill) <- sDeclareHole sym msg
return (nm, sch, hole, fill) return (nm, sch, hole, fill)
where where
@ -470,7 +470,7 @@ evalDecl sym renv env d = do
Just (Left ex) -> bindVar sym (dName d) (evalExpr sym renv ex) env Just (Left ex) -> bindVar sym (dName d) (evalExpr sym renv ex) env
Nothing -> bindVar sym (dName d) (cryNoPrimError sym (dName d)) env Nothing -> bindVar sym (dName d) (cryNoPrimError sym (dName d)) env
DForeign _ -> do DForeign _ _ -> do
-- Foreign declarations should have been handled by the previous -- Foreign declarations should have been handled by the previous
-- Cryptol.Eval.FFI.evalForeignDecls pass already, so they should already -- Cryptol.Eval.FFI.evalForeignDecls pass already, so they should already
-- be in the environment. If not, then either Cryptol was not compiled -- be in the environment. If not, then either Cryptol was not compiled
@ -755,6 +755,6 @@ evalMatch sym (lsz, lenv) m = seq lsz $ case m of
where where
f env = f env =
case dDefinition d of case dDefinition d of
DPrim -> evalPanic "evalMatch" ["Unexpected local primitive"] DPrim -> evalPanic "evalMatch" ["Unexpected local primitive"]
DForeign _ -> evalPanic "evalMatch" ["Unexpected local foreign"] DForeign _ _ -> evalPanic "evalMatch" ["Unexpected local foreign"]
DExpr e -> evalExpr sym env e DExpr e -> evalExpr sym env e

6
src/Cryptol/Eval/Reference.lhs
View File

@ -531,9 +531,9 @@ the new bindings.
> evalDecl :: Env -> Decl -> (Name, E Value) > evalDecl :: Env -> Decl -> (Name, E Value)
> evalDecl env d = > evalDecl env d =
> case dDefinition d of > case dDefinition d of
> DPrim -> (dName d, pure (evalPrim (dName d))) > DPrim -> (dName d, pure (evalPrim (dName d)))
> DForeign _ -> (dName d, cryError $ FFINotSupported $ dName d) > DForeign _ _ -> (dName d, cryError $ FFINotSupported $ dName d)
> DExpr e -> (dName d, evalExpr env e) > DExpr e -> (dName d, evalExpr env e)
> >
Newtypes Newtypes

2
src/Cryptol/IR/FreeVars.hs
View File

@ -93,7 +93,7 @@ instance FreeVars Decl where
instance FreeVars DeclDef where instance FreeVars DeclDef where
freeVars d = case d of freeVars d = case d of
DPrim -> mempty DPrim -> mempty
DForeign _ -> mempty DForeign _ me -> foldMap freeVars me
DExpr e -> freeVars e DExpr e -> freeVars e

2
src/Cryptol/IR/TraverseNames.hs
View File

@ -110,7 +110,7 @@ instance TraverseNames DeclDef where
traverseNamesIP d = traverseNamesIP d =
case d of case d of
DPrim -> pure d DPrim -> pure d
DForeign t -> DForeign <$> traverseNamesIP t DForeign t me -> DForeign <$> traverseNamesIP t <*> traverseNamesIP me
DExpr e -> DExpr <$> traverseNamesIP e DExpr e -> DExpr <$> traverseNamesIP e
instance TraverseNames Schema where instance TraverseNames Schema where

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

@ -1046,8 +1046,11 @@ instance Rename Bind where
} }
instance Rename BindDef where instance Rename BindDef where
rename DPrim = return DPrim rename DPrim = return DPrim
rename DForeign = return DForeign rename (DForeign i) = DForeign <$> traverse rename i
rename (DImpl i) = DImpl <$> rename i
instance Rename BindImpl where
rename (DExpr e) = DExpr <$> rename e rename (DExpr e) = DExpr <$> rename e
rename (DPropGuards cases) = DPropGuards <$> traverse rename cases rename (DPropGuards cases) = DPropGuards <$> traverse rename cases

4
src/Cryptol/Parser.y
View File

@ -378,7 +378,7 @@ decl :: { Decl PName }
{ at ($1,$5) $ { at ($1,$5) $
DBind $ Bind { bName = $2 DBind $ Bind { bName = $2
, bParams = [$1,$3] , bParams = [$1,$3]
, bDef = at $5 (Located emptyRange (DExpr $5)) , bDef = at $5 (Located emptyRange (exprDef $5))
, bSignature = Nothing , bSignature = Nothing
, bPragmas = [] , bPragmas = []
, bMono = False , bMono = False
@ -408,7 +408,7 @@ let_decl :: { Decl PName }
{ at ($2,$6) $ { at ($2,$6) $
DBind $ Bind { bName = $3 DBind $ Bind { bName = $3
, bParams = [$2,$4] , bParams = [$2,$4]
, bDef = at $6 (Located emptyRange (DExpr $6)) , bDef = at $6 (Located emptyRange (exprDef $6))
, bSignature = Nothing , bSignature = Nothing
, bPragmas = [] , bPragmas = []
, bMono = False , bMono = False

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

@ -64,6 +64,7 @@ module Cryptol.Parser.AST
, PropSyn(..) , PropSyn(..)
, Bind(..) , Bind(..)
, BindDef(..), LBindDef , BindDef(..), LBindDef
, BindImpl(..), bindImpl, exprDef
, Pragma(..) , Pragma(..)
, ExportType(..) , ExportType(..)
, TopLevel(..) , TopLevel(..)
@ -486,11 +487,26 @@ data Bind name = Bind
type LBindDef = Located (BindDef PName) type LBindDef = Located (BindDef PName)
data BindDef name = DPrim data BindDef name = DPrim
| DForeign -- | Foreign functions can have an optional cryptol
| DExpr (Expr name) -- implementation
| DPropGuards [PropGuardCase name] | DForeign (Maybe (BindImpl name))
| DImpl (BindImpl name)
deriving (Eq, Show, Generic, NFData, Functor) deriving (Eq, Show, Generic, NFData, Functor)
bindImpl :: Bind name -> Maybe (BindImpl name)
bindImpl bind =
case thing (bDef bind) of
DPrim -> Nothing
DForeign mi -> mi
DImpl i -> Just i
data BindImpl name = DExpr (Expr name)
| DPropGuards [PropGuardCase name]
deriving (Eq, Show, Generic, NFData, Functor)
exprDef :: Expr name -> BindDef name
exprDef = DImpl . DExpr
data PropGuardCase name = PropGuardCase data PropGuardCase name = PropGuardCase
{ pgcProps :: [Located (Prop name)] { pgcProps :: [Located (Prop name)]
, pgcExpr :: Expr name , pgcExpr :: Expr name
@ -1063,8 +1079,13 @@ instance (Show name, PPName name) => PP (Bind name) where
instance (Show name, PPName name) => PP (BindDef name) where instance (Show name, PPName name) => PP (BindDef name) where
ppPrec _ DPrim = text "<primitive>" ppPrec _ DPrim = text "<primitive>"
ppPrec _ DForeign = text "<foreign>" ppPrec p (DForeign mi) = case mi of
Just i -> "(foreign)" <+> ppPrec p i
Nothing -> "<foreign>"
ppPrec p (DImpl i) = ppPrec p i
instance (Show name, PPName name) => PP (BindImpl name) where
ppPrec p (DExpr e) = ppPrec p e ppPrec p (DExpr e) = ppPrec p e
ppPrec _p (DPropGuards _guards) = text "propguards" ppPrec _p (DPropGuards _guards) = text "propguards"

74
src/Cryptol/Parser/ExpandPropGuards.hs
View File

@ -76,43 +76,47 @@ expandDecl decl =
expandBind :: Bind PName -> ExpandPropGuardsM [Bind PName] expandBind :: Bind PName -> ExpandPropGuardsM [Bind PName]
expandBind bind = expandBind bind =
case thing (bDef bind) of case thing (bDef bind) of
DPropGuards guards -> do DImpl (DPropGuards guards) -> expand (DImpl . DPropGuards) guards
Forall params props t rng <- DForeign (Just (DPropGuards guards)) -> expand (DForeign . Just . DPropGuards) guards
case bSignature bind of
Just schema -> pure schema
Nothing -> Left . NoSignature $ bName bind
let goGuard ::
PropGuardCase PName ->
ExpandPropGuardsM (PropGuardCase PName, Bind PName)
goGuard (PropGuardCase props' e) = do
bName' <- newName (bName bind) (thing <$> props')
-- call to generated function
tParams <- case bSignature bind of
Just (Forall tps _ _ _) -> pure tps
Nothing -> Left $ NoSignature (bName bind)
typeInsts <-
(\(TParam n _ _) -> Right . PosInst $ TUser n [])
`traverse` tParams
let e' = foldl EApp (EAppT (EVar $ thing bName') typeInsts) (patternToExpr <$> bParams bind)
pure
( PropGuardCase props' e',
bind
{ bName = bName',
-- include guarded props in signature
bSignature = Just (Forall params
(props <> map thing props')
t rng),
-- keeps same location at original bind
-- i.e. "on top of" original bind
bDef = (bDef bind) {thing = DExpr e}
}
)
(guards', binds') <- unzip <$> mapM goGuard guards
pure $
bind {bDef = DPropGuards guards' <$ bDef bind} :
binds'
_ -> pure [bind] _ -> pure [bind]
where
expand def guards = do
Forall params props t rng <-
case bSignature bind of
Just schema -> pure schema
Nothing -> Left . NoSignature $ bName bind
let goGuard ::
PropGuardCase PName ->
ExpandPropGuardsM (PropGuardCase PName, Bind PName)
goGuard (PropGuardCase props' e) = do
bName' <- newName (bName bind) (thing <$> props')
-- call to generated function
tParams <- case bSignature bind of
Just (Forall tps _ _ _) -> pure tps
Nothing -> Left $ NoSignature (bName bind)
typeInsts <-
(\(TParam n _ _) -> Right . PosInst $ TUser n [])
`traverse` tParams
let e' = foldl EApp (EAppT (EVar $ thing bName') typeInsts) (patternToExpr <$> bParams bind)
pure
( PropGuardCase props' e',
bind
{ bName = bName',
-- include guarded props in signature
bSignature = Just (Forall params
(props <> map thing props')
t rng),
-- keeps same location at original bind
-- i.e. "on top of" original bind
bDef = (bDef bind) {thing = exprDef e}
}
)
(guards', binds') <- unzip <$> mapM goGuard guards
pure $
bind {bDef = def guards' <$ bDef bind} :
binds'
patternToExpr :: Pattern PName -> Expr PName patternToExpr :: Pattern PName -> Expr PName
patternToExpr (PVar locName) = EVar (thing locName) patternToExpr (PVar locName) = EVar (thing locName)
patternToExpr _ = patternToExpr _ =

22
src/Cryptol/Parser/Names.hs
View File

@ -68,10 +68,13 @@ namesB b =
namesDef :: Ord name => BindDef name -> Set name namesDef :: Ord name => BindDef name -> Set name
namesDef DPrim = Set.empty namesDef DPrim = Set.empty
namesDef DForeign = Set.empty namesDef (DForeign mi) = foldMap namesImpl mi
namesDef (DExpr e) = namesE e namesDef (DImpl i) = namesImpl i
namesDef (DPropGuards guards) = Set.unions (map (namesE . pgcExpr) guards)
namesImpl :: Ord name => BindImpl name -> Set name
namesImpl (DExpr e) = namesE e
namesImpl (DPropGuards guards) = Set.unions (map (namesE . pgcExpr) guards)
-- | The names used by an expression. -- | The names used by an expression.
@ -190,10 +193,13 @@ tnamesB b = Set.unions [setS, setP, setE]
setE = tnamesDef (thing (bDef b)) setE = tnamesDef (thing (bDef b))
tnamesDef :: Ord name => BindDef name -> Set name tnamesDef :: Ord name => BindDef name -> Set name
tnamesDef DPrim = Set.empty tnamesDef DPrim = Set.empty
tnamesDef DForeign = Set.empty tnamesDef (DForeign mi) = foldMap tnamesImpl mi
tnamesDef (DExpr e) = tnamesE e tnamesDef (DImpl i) = tnamesImpl i
tnamesDef (DPropGuards guards) = Set.unions (map tnamesPropGuardCase guards)
tnamesImpl :: Ord name => BindImpl name -> Set name
tnamesImpl (DExpr e) = tnamesE e
tnamesImpl (DPropGuards guards) = Set.unions (map tnamesPropGuardCase guards)
tnamesPropGuardCase :: Ord name => PropGuardCase name -> Set name tnamesPropGuardCase :: Ord name => PropGuardCase name -> Set name
tnamesPropGuardCase c = tnamesPropGuardCase c =

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

@ -9,7 +9,9 @@
-- The purpose of this module is to convert all patterns to variable -- The purpose of this module is to convert all patterns to variable
-- patterns. It also eliminates pattern bindings by de-sugaring them -- patterns. It also eliminates pattern bindings by de-sugaring them
-- into `Bind`. Furthermore, here we associate signatures, fixities, -- into `Bind`. Furthermore, here we associate signatures, fixities,
-- and pragmas with the names to which they belong. -- and pragmas with the names to which they belong. We also merge
-- empty 'DForeign' binds with their cryptol implementations, if they
-- exist.
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
@ -57,7 +59,7 @@ instance RemovePatterns (NestedModule PName) where
simpleBind :: Located PName -> Expr PName -> Bind PName simpleBind :: Located PName -> Expr PName -> Bind PName
simpleBind x e = Bind { bName = x, bParams = [] simpleBind x e = Bind { bName = x, bParams = []
, bDef = at e (Located emptyRange (DExpr e)) , bDef = at e (Located emptyRange (exprDef e))
, bSignature = Nothing, bPragmas = [] , bSignature = Nothing, bPragmas = []
, bMono = True, bInfix = False, bFixity = Nothing , bMono = True, bInfix = False, bFixity = Nothing
, bDoc = Nothing , bDoc = Nothing
@ -220,20 +222,25 @@ noMatchB b =
| otherwise -> panic "NoPat" [ "noMatchB: primitive with params" | otherwise -> panic "NoPat" [ "noMatchB: primitive with params"
, show b ] , show b ]
DForeign DForeign Nothing
| null (bParams b) -> return b | null (bParams b) -> return b
| otherwise -> panic "NoPat" [ "noMatchB: foreign with params" | otherwise -> panic "NoPat" [ "noMatchB: foreign with params"
, show b ] , show b ]
DExpr e -> DForeign (Just i) -> noMatchI (DForeign . Just) i
do e' <- noPatFun (Just (thing (bName b))) 0 (bParams b) e
return b { bParams = [], bDef = DExpr e' <$ bDef b }
DPropGuards guards -> DImpl i -> noMatchI DImpl i
do let nm = thing (bName b)
ps = bParams b where
gs <- mapM (noPatPropGuardCase nm ps) guards noMatchI def i =
pure b { bParams = [], bDef = DPropGuards gs <$ bDef b } do i' <- case i of
DExpr e ->
DExpr <$> noPatFun (Just (thing (bName b))) 0 (bParams b) e
DPropGuards guards ->
let nm = thing (bName b)
ps = bParams b
in DPropGuards <$> mapM (noPatPropGuardCase nm ps) guards
pure b { bParams = [], bDef = def i' <$ bDef b }
noPatPropGuardCase :: noPatPropGuardCase ::
PName -> PName ->
@ -260,7 +267,7 @@ noMatchD decl =
let e2 = foldl ETyped e1 ts let e2 = foldl ETyped e1 ts
return $ DBind Bind { bName = x return $ DBind Bind { bName = x
, bParams = [] , bParams = []
, bDef = at e (Located emptyRange (DExpr e2)) , bDef = at e (Located emptyRange (exprDef e2))
, bSignature = Nothing , bSignature = Nothing
, bPragmas = [] , bPragmas = []
, bMono = False , bMono = False
@ -280,11 +287,13 @@ noPatDs ds =
do ds1 <- concat <$> mapM noMatchD ds do ds1 <- concat <$> mapM noMatchD ds
let fixes = Map.fromListWith (++) $ concatMap toFixity ds1 let fixes = Map.fromListWith (++) $ concatMap toFixity ds1
amap = AnnotMap amap = AnnotMap
{ annPragmas = Map.fromListWith (++) $ concatMap toPragma ds1 { annPragmas = Map.fromListWith (++) $ concatMap toPragma ds1
, annSigs = Map.fromListWith (++) $ concatMap toSig ds1 , annSigs = Map.fromListWith (++) $ concatMap toSig ds1
, annValueFs = fixes , annValueFs = fixes
, annTypeFs = fixes , annTypeFs = fixes
, annDocs = Map.empty , annDocs = Map.empty
-- There shouldn't be any foreigns at non-top-level
, annForeigns = Map.empty
} }
(ds2, AnnotMap { .. }) <- runStateT amap (annotDs ds1) (ds2, AnnotMap { .. }) <- runStateT amap (annotDs ds1)
@ -314,11 +323,12 @@ noPatTopDs tds =
fixes = Map.fromListWith (++) $ concatMap toFixity allDecls fixes = Map.fromListWith (++) $ concatMap toFixity allDecls
let ann = AnnotMap let ann = AnnotMap
{ annPragmas = Map.fromListWith (++) $ concatMap toPragma allDecls { annPragmas = Map.fromListWith (++) $ concatMap toPragma allDecls
, annSigs = Map.fromListWith (++) $ concatMap toSig allDecls , annSigs = Map.fromListWith (++) $ concatMap toSig allDecls
, annValueFs = fixes , annValueFs = fixes
, annTypeFs = fixes , annTypeFs = fixes
, annDocs = Map.fromListWith (++) $ concatMap toDocs $ decls tds , annDocs = Map.fromListWith (++) $ concatMap toDocs $ decls tds
, annForeigns = Map.fromListWith (<>) $ concatMap toForeigns allDecls
} }
(tds', AnnotMap { .. }) <- runStateT ann (annotTopDs desugared) (tds', AnnotMap { .. }) <- runStateT ann (annotTopDs desugared)
@ -362,12 +372,25 @@ noPatModule m =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | For each binding name, does there exist an empty foreign bind, a normal
-- cryptol bind, or both.
data AnnForeign = OnlyForeign | OnlyImpl | BothForeignImpl
instance Semigroup AnnForeign where
OnlyForeign <> OnlyImpl = BothForeignImpl
OnlyImpl <> OnlyForeign = BothForeignImpl
_ <> BothForeignImpl = BothForeignImpl
BothForeignImpl <> _ = BothForeignImpl
OnlyForeign <> OnlyForeign = OnlyForeign
OnlyImpl <> OnlyImpl = OnlyImpl
data AnnotMap = AnnotMap data AnnotMap = AnnotMap
{ annPragmas :: Map.Map PName [Located Pragma ] { annPragmas :: Map.Map PName [Located Pragma ]
, annSigs :: Map.Map PName [Located (Schema PName)] , annSigs :: Map.Map PName [Located (Schema PName)]
, annValueFs :: Map.Map PName [Located Fixity ] , annValueFs :: Map.Map PName [Located Fixity ]
, annTypeFs :: Map.Map PName [Located Fixity ] , annTypeFs :: Map.Map PName [Located Fixity ]
, annDocs :: Map.Map PName [Located Text ] , annDocs :: Map.Map PName [Located Text ]
, annForeigns :: Map.Map PName AnnForeign
} }
type Annotates a = a -> StateT AnnotMap NoPatM a type Annotates a = a -> StateT AnnotMap NoPatM a
@ -428,7 +451,7 @@ annotDs [] = return []
annotD :: Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName) annotD :: Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
annotD decl = annotD decl =
case decl of case decl of
DBind b -> DBind <$> lift (annotB b) DBind b -> DBind <$> annotB b
DRec {} -> panic "annotD" [ "DRec" ] DRec {} -> panic "annotD" [ "DRec" ]
DSignature {} -> raise () DSignature {} -> raise ()
DFixity{} -> raise () DFixity{} -> raise ()
@ -439,7 +462,10 @@ annotD decl =
DLocated d r -> (`DLocated` r) <$> annotD d DLocated d r -> (`DLocated` r) <$> annotD d
-- | Add pragma/signature annotations to a binding. -- | Add pragma/signature annotations to a binding.
annotB :: Annotates (Bind PName) -- Also perform de-duplication of empty 'DForeign' binds generated by the parser
-- if there exists a cryptol implementation.
-- The exception indicates which declarations are no longer needed.
annotB :: Bind PName -> ExceptionT () (StateT AnnotMap NoPatM) (Bind PName)
annotB Bind { .. } = annotB Bind { .. } =
do AnnotMap { .. } <- get do AnnotMap { .. } <- get
let name = thing bName let name = thing bName
@ -448,9 +474,17 @@ annotB Bind { .. } =
(thisSigs , ss') = Map.updateLookupWithKey remove name annSigs (thisSigs , ss') = Map.updateLookupWithKey remove name annSigs
(thisFixes , fs') = Map.updateLookupWithKey remove name annValueFs (thisFixes , fs') = Map.updateLookupWithKey remove name annValueFs
(thisDocs , ds') = Map.updateLookupWithKey remove name annDocs (thisDocs , ds') = Map.updateLookupWithKey remove name annDocs
s <- lift $ checkSigs name $ jn thisSigs thisForeign = Map.lookup name annForeigns
f <- lift $ checkFixs name $ jn thisFixes -- Compute the new def before updating the state, since we don't want to
d <- lift $ checkDocs name $ jn thisDocs -- consume the annotations if we are throwing away an empty foreign def.
def' <- case thisForeign of
Just BothForeignImpl
| DForeign _ <- thing bDef -> raise ()
| DImpl i <- thing bDef -> pure (DForeign (Just i) <$ bDef)
_ -> pure bDef
s <- lift $ lift $ checkSigs name $ jn thisSigs
f <- lift $ lift $ checkFixs name $ jn thisFixes
d <- lift $ lift $ checkDocs name $ jn thisDocs
set AnnotMap { annPragmas = ps' set AnnotMap { annPragmas = ps'
, annSigs = ss' , annSigs = ss'
, annValueFs = fs' , annValueFs = fs'
@ -458,6 +492,7 @@ annotB Bind { .. } =
, .. , ..
} }
return Bind { bSignature = s return Bind { bSignature = s
, bDef = def'
, bPragmas = map thing (jn thisPs) ++ bPragmas , bPragmas = map thing (jn thisPs) ++ bPragmas
, bFixity = f , bFixity = f
, bDoc = d , bDoc = d
@ -551,6 +586,13 @@ toDocs TopLevel { .. }
DType _ -> [] DType _ -> []
DProp _ -> [] DProp _ -> []
-- | Is this declaration a foreign or regular bind?
toForeigns :: Decl PName -> [(PName, AnnForeign)]
toForeigns (DLocated d _) = toForeigns d
toForeigns (DBind Bind {..})
| DForeign Nothing <- thing bDef = [ (thing bName, OnlyForeign) ]
| DImpl _ <- thing bDef = [ (thing bName, OnlyImpl) ]
toForeigns _ = []
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
newtype NoPatM a = M { unM :: ReaderT Range (StateT RW Id) a } newtype NoPatM a = M { unM :: ReaderT Range (StateT RW Id) a }

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

@ -692,7 +692,7 @@ mkProperty :: LPName -> [Pattern PName] -> Expr PName -> Decl PName
mkProperty f ps e = at (f,e) $ mkProperty f ps e = at (f,e) $
DBind Bind { bName = f DBind Bind { bName = f
, bParams = reverse ps , bParams = reverse ps
, bDef = at e (Located emptyRange (DExpr e)) , bDef = at e (Located emptyRange (exprDef e))
, bSignature = Nothing , bSignature = Nothing
, bPragmas = [PragmaProperty] , bPragmas = [PragmaProperty]
, bMono = False , bMono = False
@ -708,7 +708,7 @@ mkIndexedDecl ::
mkIndexedDecl f (ps, ixs) e = mkIndexedDecl f (ps, ixs) e =
DBind Bind { bName = f DBind Bind { bName = f
, bParams = reverse ps , bParams = reverse ps
, bDef = at e (Located emptyRange (DExpr rhs)) , bDef = at e (Located emptyRange (exprDef rhs))
, bSignature = Nothing , bSignature = Nothing
, bPragmas = [] , bPragmas = []
, bMono = False , bMono = False
@ -735,7 +735,7 @@ mkPropGuardsDecl f (ps, ixs) guards =
pure $ pure $
DBind Bind { bName = f DBind Bind { bName = f
, bParams = reverse ps , bParams = reverse ps
, bDef = Located (srcRange f) (DPropGuards gs) , bDef = Located (srcRange f) (DImpl (DPropGuards gs))
, bSignature = Nothing , bSignature = Nothing
, bPragmas = [] , bPragmas = []
, bMono = False , bMono = False
@ -777,7 +777,11 @@ mkForeignDecl mbDoc nm ty =
[ "`" ++ txt ++ "` is not a valid foreign name." [ "`" ++ txt ++ "` is not a valid foreign name."
, "The name should contain only alpha-numeric characters or '_'." , "The name should contain only alpha-numeric characters or '_'."
]) ])
pure (mkNoImplDecl DForeign mbDoc nm ty) -- We do allow optional cryptol implementations of foreign functions, these
-- will be merged with this binding in the NoPat pass. In the parser they
-- are just treated as a completely separate (non-foreign) binding with the
-- same name.
pure (mkNoImplDecl (DForeign Nothing) mbDoc nm ty)
where where
isOk c = c == '_' || isAlphaNum c isOk c = c == '_' || isAlphaNum c
@ -791,7 +795,7 @@ mkForeignDecl mbDoc nm ty =
mkNoImplDecl :: BindDef PName mkNoImplDecl :: BindDef PName
-> Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName] -> Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName]
mkNoImplDecl def mbDoc ln sig = mkNoImplDecl def mbDoc ln sig =
[ exportDecl mbDoc Public [ exportDecl Nothing Public
$ DBind Bind { bName = ln $ DBind Bind { bName = ln
, bParams = [] , bParams = []
, bDef = at sig (Located emptyRange def) , bDef = at sig (Located emptyRange def)
@ -803,7 +807,7 @@ mkNoImplDecl def mbDoc ln sig =
, bDoc = Nothing , bDoc = Nothing
, bExport = Public , bExport = Public
} }
, exportDecl Nothing Public , exportDecl mbDoc Public
$ DSignature [ln] sig $ DSignature [ln] sig
] ]

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

@ -218,9 +218,9 @@ rewD rews d = do e <- rewDef rews (dDefinition d)
return d { dDefinition = e } return d { dDefinition = e }
rewDef :: RewMap -> DeclDef -> M DeclDef rewDef :: RewMap -> DeclDef -> M DeclDef
rewDef rews (DExpr e) = DExpr <$> rewE rews e rewDef rews (DExpr e) = DExpr <$> rewE rews e
rewDef _ DPrim = return DPrim rewDef _ DPrim = return DPrim
rewDef _ (DForeign t) = return $ DForeign t rewDef rews (DForeign t me) = DForeign t <$> traverse (rewE rews) me
rewDeclGroup :: RewMap -> DeclGroup -> M DeclGroup rewDeclGroup :: RewMap -> DeclGroup -> M DeclGroup
rewDeclGroup rews dg = rewDeclGroup rews dg =
@ -240,12 +240,17 @@ rewDeclGroup rews dg =
consider d = consider d =
case dDefinition d of case dDefinition d of
DPrim -> Left d DPrim -> Left d
DForeign _ -> Left d DForeign _ me -> case me of
DExpr e -> let (tps,props,e') = splitTParams e Nothing -> Left d
in if not (null tps) && notFun e' Just e -> conExpr e
then Right (d, tps, props, e') DExpr e -> conExpr e
else Left d where
conExpr e =
let (tps,props,e') = splitTParams e
in if not (null tps) && notFun e'
then Right (d, tps, props, e')
else Left d
rewSame ds = rewSame ds =
do new <- forM (NE.toList ds) $ \(d,_,_,e) -> do new <- forM (NE.toList ds) $ \(d,_,_,e) ->

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

@ -201,11 +201,11 @@ specializeConst e0 = do
qname' <- freshName qname ts -- New type instance, record new name qname' <- freshName qname ts -- New type instance, record new name
sig' <- instantiateSchema ts n (dSignature decl) sig' <- instantiateSchema ts n (dSignature decl)
modifySpecCache (Map.adjust (fmap (insertTM ts (qname', Nothing))) qname) modifySpecCache (Map.adjust (fmap (insertTM ts (qname', Nothing))) qname)
let spec e = specializeExpr =<< instantiateExpr ts n e
rhs' <- case dDefinition decl of rhs' <- case dDefinition decl of
DExpr e -> do e' <- specializeExpr =<< instantiateExpr ts n e DExpr e -> DExpr <$> spec e
return (DExpr e') DPrim -> return DPrim
DPrim -> return DPrim DForeign t me -> DForeign t <$> traverse spec me
DForeign t -> return $ DForeign t
let decl' = decl { dName = qname', dSignature = sig', dDefinition = rhs' } let decl' = decl { dName = qname', dSignature = sig', dDefinition = rhs' }
modifySpecCache (Map.adjust (fmap (insertTM ts (qname', Just decl'))) qname) modifySpecCache (Map.adjust (fmap (insertTM ts (qname', Just decl'))) qname)
return (EVar qname') return (EVar qname')

2
src/Cryptol/TypeCheck.hs
View File

@ -86,7 +86,7 @@ tcExpr e0 inp = runInferM inp
[ P.Bind [ P.Bind
{ P.bName = P.Located { P.srcRange = loc, P.thing = fresh } { P.bName = P.Located { P.srcRange = loc, P.thing = fresh }
, P.bParams = [] , P.bParams = []
, P.bDef = P.Located (inpRange inp) (P.DExpr expr) , P.bDef = P.Located (inpRange inp) (P.exprDef expr)
, P.bPragmas = [] , P.bPragmas = []
, P.bSignature = Nothing , P.bSignature = Nothing
, P.bMono = False , P.bMono = False

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

@ -146,7 +146,7 @@ emptyModule nm =
-- | Find all the foreign declarations in the module and return their names and FFIFunTypes. -- | Find all the foreign declarations in the module and return their names and FFIFunTypes.
findForeignDecls :: ModuleG mname -> [(Name, FFIFunType)] findForeignDecls :: ModuleG mname -> [(Name, FFIFunType)]
findForeignDecls = mapMaybe getForeign . mDecls findForeignDecls = mapMaybe getForeign . mDecls
where getForeign (NonRecursive Decl { dName, dDefinition = DForeign ffiType }) where getForeign (NonRecursive Decl { dName, dDefinition = DForeign ffiType _ })
= Just (dName, ffiType) = Just (dName, ffiType)
-- Recursive DeclGroups can't have foreign decls -- Recursive DeclGroups can't have foreign decls
getForeign _ = Nothing getForeign _ = Nothing
@ -245,7 +245,9 @@ data Decl = Decl { dName :: !Name
} deriving (Generic, NFData, Show) } deriving (Generic, NFData, Show)
data DeclDef = DPrim data DeclDef = DPrim
| DForeign FFIFunType -- | Foreign functions can have an optional cryptol
-- implementation
| DForeign FFIFunType (Maybe Expr)
| DExpr Expr | DExpr Expr
deriving (Show, Generic, NFData) deriving (Show, Generic, NFData)
@ -463,9 +465,12 @@ instance PP (WithNames Decl) where
++ [ nest 2 (sep [pp dName <+> text "=", ppWithNames nm dDefinition]) ] ++ [ nest 2 (sep [pp dName <+> text "=", ppWithNames nm dDefinition]) ]
instance PP (WithNames DeclDef) where instance PP (WithNames DeclDef) where
ppPrec _ (WithNames DPrim _) = text "<primitive>" ppPrec _ (WithNames DPrim _) = text "<primitive>"
ppPrec _ (WithNames (DForeign _) _) = text "<foreign>" ppPrec _ (WithNames (DForeign _ me) nm) =
ppPrec _ (WithNames (DExpr e) nm) = ppWithNames nm e case me of
Just e -> text "(foreign)" <+> ppWithNames nm e
Nothing -> text "<foreign>"
ppPrec _ (WithNames (DExpr e) nm) = ppWithNames nm e
instance PP Decl where instance PP Decl where
ppPrec = ppWithNamesPrec IntMap.empty ppPrec = ppWithNamesPrec IntMap.empty

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

@ -873,9 +873,9 @@ checkNumericConstraintGuardsOK isTopLevel haveSig noSig =
-- so no need to look at noSig -- so no need to look at noSig
hasConstraintGuards b = hasConstraintGuards b =
case thing (P.bDef b) of case P.bindImpl b of
P.DPropGuards {} -> True Just (P.DPropGuards {}) -> True
_ -> False _ -> False
@ -896,10 +896,11 @@ guessType exprMap b@(P.Bind { .. }) =
Just s -> Just s ->
do let wildOk = case thing bDef of do let wildOk = case thing bDef of
P.DForeign {} -> NoWildCards P.DForeign {} -> NoWildCards
P.DPrim -> NoWildCards P.DPrim -> NoWildCards
P.DExpr {} -> AllowWildCards P.DImpl i -> case i of
P.DPropGuards {} -> NoWildCards P.DExpr {} -> AllowWildCards
P.DPropGuards {} -> NoWildCards
s1 <- checkSchema wildOk s s1 <- checkSchema wildOk s
return ((name, ExtVar (fst s1)), Left (checkSigB b s1)) return ((name, ExtVar (fst s1)), Left (checkSigB b s1))
@ -994,9 +995,9 @@ generalize bs0 gs0 =
genE e = foldr ETAbs (foldr EProofAbs (apSubst su e) qs) asPs genE e = foldr ETAbs (foldr EProofAbs (apSubst su e) qs) asPs
genB d = d { dDefinition = case dDefinition d of genB d = d { dDefinition = case dDefinition d of
DExpr e -> DExpr (genE e) DExpr e -> DExpr (genE e)
DPrim -> DPrim DPrim -> DPrim
DForeign t -> DForeign t DForeign t me -> DForeign t (genE <$> me)
, dSignature = Forall asPs qs , dSignature = Forall asPs qs
$ apSubst su $ sType $ dSignature d $ apSubst su $ sType $ dSignature d
} }
@ -1018,31 +1019,33 @@ checkMonoB b t =
P.DPrim -> panic "checkMonoB" ["Primitive with no signature?"] P.DPrim -> panic "checkMonoB" ["Primitive with no signature?"]
P.DForeign -> panic "checkMonoB" ["Foreign with no signature?"] P.DForeign _ -> panic "checkMonoB" ["Foreign with no signature?"]
P.DExpr e -> P.DImpl i ->
do let nm = thing (P.bName b) case i of
let tGoal = WithSource t (DefinitionOf nm) (getLoc b)
e1 <- checkFun (P.FunDesc (Just nm) 0) (P.bParams b) e tGoal
let f = thing (P.bName b)
return Decl { dName = f
, dSignature = Forall [] [] t
, dDefinition = DExpr e1
, dPragmas = P.bPragmas b
, dInfix = P.bInfix b
, dFixity = P.bFixity b
, dDoc = P.bDoc b
}
P.DPropGuards _ -> P.DExpr e ->
tcPanic "checkMonoB" do let nm = thing (P.bName b)
[ "Used constraint guards without a signature at " let tGoal = WithSource t (DefinitionOf nm) (getLoc b)
, show . pp $ P.bName b ] e1 <- checkFun (P.FunDesc (Just nm) 0) (P.bParams b) e tGoal
let f = thing (P.bName b)
return Decl { dName = f
, dSignature = Forall [] [] t
, dDefinition = DExpr e1
, dPragmas = P.bPragmas b
, dInfix = P.bInfix b
, dFixity = P.bFixity b
, dDoc = P.bDoc b
}
P.DPropGuards _ ->
tcPanic "checkMonoB"
[ "Used constraint guards without a signature at "
, show . pp $ P.bName b ]
-- XXX: Do we really need to do the defaulting business in two different places? -- XXX: Do we really need to do the defaulting business in two different places?
checkSigB :: P.Bind Name -> (Schema,[Goal]) -> InferM Decl checkSigB :: P.Bind Name -> (Schema,[Goal]) -> InferM Decl
checkSigB b (Forall as asmps0 t0, validSchema) = checkSigB b (Forall as asmps0 t0, validSchema) =
let name = thing (P.bName b) in
case thing (P.bDef b) of case thing (P.bDef b) of
-- XXX what should we do with validSchema in this case? -- XXX what should we do with validSchema in this case?
@ -1057,10 +1060,13 @@ checkSigB b (Forall as asmps0 t0, validSchema) =
, dDoc = P.bDoc b , dDoc = P.bDoc b
} }
P.DForeign -> do P.DForeign mi -> do
(asmps, t, me) <-
case mi of
Just i -> fmap Just <$> checkImpl i
Nothing -> pure (asmps0, t0, Nothing)
let loc = getLoc b let loc = getLoc b
name' = thing $ P.bName b src = DefinitionOf name
src = DefinitionOf name'
inRangeMb loc do inRangeMb loc do
-- Ensure all type params are of kind # -- Ensure all type params are of kind #
forM_ as \a -> forM_ as \a ->
@ -1068,10 +1074,10 @@ checkSigB b (Forall as asmps0 t0, validSchema) =
recordErrorLoc loc $ UnsupportedFFIKind src a $ tpKind a recordErrorLoc loc $ UnsupportedFFIKind src a $ tpKind a
withTParams as do withTParams as do
ffiFunType <- ffiFunType <-
case toFFIFunType (Forall as asmps0 t0) of case toFFIFunType (Forall as asmps t) of
Right (props, ffiFunType) -> ffiFunType <$ do Right (props, ffiFunType) -> ffiFunType <$ do
ffiGoals <- traverse (newGoal (CtFFI name')) props ffiGoals <- traverse (newGoal (CtFFI name)) props
proveImplication True (Just name') as asmps0 $ proveImplication True (Just name) as asmps $
validSchema ++ ffiGoals validSchema ++ ffiGoals
Left err -> do Left err -> do
recordErrorLoc loc $ UnsupportedFFIType src err recordErrorLoc loc $ UnsupportedFFIType src err
@ -1080,32 +1086,44 @@ checkSigB b (Forall as asmps0 t0, validSchema) =
{ ffiTParams = as, ffiArgTypes = [] { ffiTParams = as, ffiArgTypes = []
, ffiRetType = FFITuple [] } , ffiRetType = FFITuple [] }
pure Decl { dName = thing (P.bName b) pure Decl { dName = thing (P.bName b)
, dSignature = Forall as asmps0 t0 , dSignature = Forall as asmps t
, dDefinition = DForeign ffiFunType , dDefinition = DForeign ffiFunType me
, dPragmas = P.bPragmas b , dPragmas = P.bPragmas b
, dInfix = P.bInfix b , dInfix = P.bInfix b
, dFixity = P.bFixity b , dFixity = P.bFixity b
, dDoc = P.bDoc b , dDoc = P.bDoc b
} }
P.DExpr e0 -> P.DImpl i -> do
inRangeMb (getLoc b) $ (asmps, t, expr) <- checkImpl i
withTParams as $ do return Decl
(t, asmps, e2) <- checkBindDefExpr [] asmps0 e0 { dName = name
, dSignature = Forall as asmps t
, dDefinition = DExpr expr
, dPragmas = P.bPragmas b
, dInfix = P.bInfix b
, dFixity = P.bFixity b
, dDoc = P.bDoc b
}
return Decl where
{ dName = name
, dSignature = Forall as asmps t
, dDefinition = DExpr (foldr ETAbs (foldr EProofAbs e2 asmps) as)
, dPragmas = P.bPragmas b
, dInfix = P.bInfix b
, dFixity = P.bFixity b
, dDoc = P.bDoc b
}
P.DPropGuards cases0 -> name = thing (P.bName b)
checkImpl :: P.BindImpl Name -> InferM ([Prop], Type, Expr)
checkImpl i =
inRangeMb (getLoc b) $ inRangeMb (getLoc b) $
withTParams as $ do withTParams as $
case i of
P.DExpr e0 -> do
(t, asmps, e2) <- checkBindDefExpr [] asmps0 e0
pure ( asmps
, t
, foldr ETAbs (foldr EProofAbs e2 asmps) as
)
P.DPropGuards cases0 -> do
asmps1 <- applySubstPreds asmps0 asmps1 <- applySubstPreds asmps0
t1 <- applySubst t0 t1 <- applySubst t0
cases1 <- mapM checkPropGuardCase cases0 cases1 <- mapM checkPropGuardCase cases0
@ -1116,25 +1134,14 @@ checkSigB b (Forall as asmps0 t0, validSchema) =
-- necessarily hold -- necessarily hold
recordWarning (NonExhaustivePropGuards name) recordWarning (NonExhaustivePropGuards name)
let schema = Forall as asmps1 t1 pure ( asmps1
, t1
return Decl , foldr ETAbs
{ dName = name (foldr EProofAbs
, dSignature = schema (EPropGuards cases1 t1)
, dDefinition = DExpr asmps1)
(foldr ETAbs as
(foldr EProofAbs )
(EPropGuards cases1 t1)
asmps1)
as)
, dPragmas = P.bPragmas b
, dInfix = P.bInfix b
, dFixity = P.bFixity b
, dDoc = P.bDoc b
}
where
checkBindDefExpr :: checkBindDefExpr ::
[Prop] -> [Prop] -> P.Expr Name -> InferM (Type, [Prop], Expr) [Prop] -> [Prop] -> P.Expr Name -> InferM (Type, [Prop], Expr)

3
src/Cryptol/TypeCheck/Parseable.hs
View File

@ -95,7 +95,8 @@ instance ShowParseable Decl where
instance ShowParseable DeclDef where instance ShowParseable DeclDef where
showParseable DPrim = text (show DPrim) showParseable DPrim = text (show DPrim)
showParseable (DForeign t) = text (show $ DForeign t) showParseable (DForeign t me) =
parens (text "DForeign" $$ parens (text (show t)) $$ showParseable me)
showParseable (DExpr e) = parens (text "DExpr" $$ showParseable e) showParseable (DExpr e) = parens (text "DExpr" $$ showParseable e)
instance ShowParseable DeclGroup where instance ShowParseable DeclGroup where

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

@ -462,21 +462,26 @@ checkDecl checkSig d =
do when checkSig $ checkSchema $ dSignature d do when checkSig $ checkSchema $ dSignature d
return (dName d, dSignature d) return (dName d, dSignature d)
DForeign _ -> DForeign _ me ->
do when checkSig $ checkSchema $ dSignature d do when checkSig $ checkSchema $ dSignature d
mapM_ checkExpr me
return (dName d, dSignature d) return (dName d, dSignature d)
DExpr e -> DExpr e ->
do let s = dSignature d do let s = dSignature d
when checkSig $ checkSchema s when checkSig $ checkSchema s
s1 <- exprSchema e checkExpr e
let nm = dName d
loc = "definition of " ++ show (pp nm) ++
", at " ++ show (pp (nameLoc nm))
sameSchemas loc s s1
return (dName d, s) return (dName d, s)
where
checkExpr e =
do let s = dSignature d
s1 <- exprSchema e
let nm = dName d
loc = "definition of " ++ show (pp nm) ++
", at " ++ show (pp (nameLoc nm))
sameSchemas loc s s1
checkDeclGroup :: DeclGroup -> TcM [(Name, Schema)] checkDeclGroup :: DeclGroup -> TcM [(Name, Schema)]
checkDeclGroup dg = checkDeclGroup dg =
case dg of case dg of

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

@ -452,9 +452,9 @@ instance TVars Decl where
in d { dSignature = sig', dDefinition = def' } in d { dSignature = sig', dDefinition = def' }
instance TVars DeclDef where instance TVars DeclDef where
apSubst su (DExpr e) = DExpr !$ (apSubst su e) apSubst su (DExpr e) = DExpr !$ (apSubst su e)
apSubst _ DPrim = DPrim apSubst _ DPrim = DPrim
apSubst _ (DForeign t) = DForeign t apSubst su (DForeign t me) = DForeign t !$ apSubst su me
-- WARNING: This applies the substitution only to the declarations. -- WARNING: This applies the substitution only to the declarations.
instance TVars (ModuleG names) where instance TVars (ModuleG names) where