From 66f9801fb3da7d3ca152e85a16e2b1daa3e529df Mon Sep 17 00:00:00 2001 From: jmcardon Date: Tue, 22 Aug 2023 15:35:08 -0400 Subject: [PATCH 01/66] typed-core types --- pact-core.cabal | 10 +- pact-core/Pact/Core/Errors.hs | 12 +- typed-core/Pact/Core/IR/Typecheck.hs | 63 +- typed-core/Pact/Core/Typed/Overload.hs | 17 +- typed-core/Pact/Core/Typed/Term.hs | 32 +- typed-core/Pact/Core/Typed/Typecheck.hs | 4 +- typed-core/Pact/Core/Untyped/Eval/CEK.hs | 423 ------ typed-core/Pact/Core/Untyped/Eval/Runtime.hs | 400 ------ .../Core/Untyped/Eval/Runtime/CoreBuiltin.hs | 1180 ----------------- .../Core/Untyped/Eval/Runtime/RawBuiltin.hs | 1002 -------------- typed-core/Pact/Core/Untyped/Term.hs | 396 ------ typed-core/Pact/Core/Untyped/Utils.hs | 130 -- 12 files changed, 73 insertions(+), 3596 deletions(-) delete mode 100644 typed-core/Pact/Core/Untyped/Eval/CEK.hs delete mode 100644 typed-core/Pact/Core/Untyped/Eval/Runtime.hs delete mode 100644 typed-core/Pact/Core/Untyped/Eval/Runtime/CoreBuiltin.hs delete mode 100644 typed-core/Pact/Core/Untyped/Eval/Runtime/RawBuiltin.hs delete mode 100644 typed-core/Pact/Core/Untyped/Term.hs delete mode 100644 typed-core/Pact/Core/Untyped/Utils.hs diff --git a/pact-core.cabal b/pact-core.cabal index b001fd0ee..8ae2487b3 100644 --- a/pact-core.cabal +++ b/pact-core.cabal @@ -143,19 +143,11 @@ library typed-core Pact.Core.IR.Typecheck -- Typed core modules + Pact.Core.Typed.Type Pact.Core.Typed.Typecheck Pact.Core.Typed.Term Pact.Core.Typed.Overload - -- Untyped core - Pact.Core.Untyped.Term - Pact.Core.Untyped.Eval.Runtime - Pact.Core.Untyped.Eval.CEK - Pact.Core.Untyped.Eval.Runtime.CoreBuiltin - Pact.Core.Untyped.Eval.Runtime.RawBuiltin - Pact.Core.Untyped.Utils - - executable repl main-is: pact-core/Pact/Core/Repl.hs diff --git a/pact-core/Pact/Core/Errors.hs b/pact-core/Pact/Core/Errors.hs index 51e478a9b..33f2ab062 100644 --- a/pact-core/Pact/Core/Errors.hs +++ b/pact-core/Pact/Core/Errors.hs @@ -177,17 +177,7 @@ instance Pretty DesugarError where InvalidModuleReference mn -> Pretty.hsep ["Invalid Interface attempted to be used as module reference:", pretty mn] --- data TypecheckError --- = UnificationError (Type Text) (Type Text) --- | ContextReductionError (Pred Text) --- | UnsupportedTypeclassGeneralization [Pred Text] --- | UnsupportedImpredicativity --- | OccursCheckFailure (Type Text) --- | TCInvariantFailure Text --- | TCUnboundTermVariable Text --- | TCUnboundFreeVariable ModuleName Text --- | DisabledGeneralization Text --- deriving Show + -- instance RenderError TypecheckError where -- renderError = \case diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 1e716ae52..3fd34e5d0 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -57,14 +57,14 @@ import qualified Data.RAList as RAList import qualified Data.Set as Set import Pact.Core.Builtin -import Pact.Core.Type +import Pact.Core.Type(PrimType(..), Arg(..), TypedArg(..)) +import Pact.Core.Typed.Type import Pact.Core.Names import Pact.Core.Errors import Pact.Core.Persistence import Pact.Core.Capabilities import qualified Pact.Core.IR.Term as IR import qualified Pact.Core.Typed.Term as Typed -import qualified Pact.Core.Untyped.Term as U -- inference based on https://okmij.org/ftp/ML/generalization.html -- Note: Type inference levels in the types @@ -76,6 +76,18 @@ import qualified Pact.Core.Untyped.Term as U type UniqueSupply s = STRef s Unique type Level = Int +data TypecheckError + = UnificationError (Type Text) (Type Text) + | ContextReductionError (Pred Text) + | UnsupportedTypeclassGeneralization [Pred Text] + | UnsupportedImpredicativity + | OccursCheckFailure (Type Text) + | TCInvariantFailure Text + | TCUnboundTermVariable Text + | TCUnboundFreeVariable ModuleName Text + | DisabledGeneralization Text + deriving Show + data Tv s = Unbound !Text !Unique !Level | Bound !Text !Unique @@ -95,7 +107,7 @@ data TCEnv s b i , _tcVarEnv :: RAList (Type (TvRef s)) -- ^ Builtins map, that uses the enum instance -- , _tcFree :: Map ModuleName (Map Text (Type Void)) - , _tcFree :: Map FullyQualifiedName (Def Name) + , _tcLoaded :: Loaded b i -- ^ Free variables , _tcLevel :: STRef s Level -- ^ Type Variable "Region" @@ -142,7 +154,7 @@ type TypedInterface b i = Typed.OverloadedInterface NamedDeBruijn b i -- | Our inference monad, where we can plumb through generalization "regions", -- our variable environment and our "supply" of unique names newtype InferM s b i a = - InferT (ExceptT (PactError i) (ReaderT (TCEnv s b i) (ST s)) a) + InferT (ExceptT TypecheckError (ReaderT (TCEnv s b i) (ST s)) a) deriving ( Functor, Applicative, Monad , MonadReader (TCEnv s b i) @@ -323,7 +335,7 @@ instance TypeOfBuiltin RawBuiltin where -- RawCreateUserGuard -> let -- a = nd "a" 0 -- in TypeScheme [a] [] ((TyUnit :~> TyVar a) :~> TyGuard) - RawListAccess -> let + RawAt -> let a = nd "a" 0 in TypeScheme [a] [] (TyInt :~> TyList (TyVar a) :~> TyVar a) RawMakeList -> let @@ -400,7 +412,7 @@ liftST :: ST s a -> InferM s b i a liftST action = InferT (ExceptT (Right <$> ReaderT (const action))) throwTypecheckError :: TypecheckError -> i -> InferM s b i a -throwTypecheckError te = throwError . PETypecheckError te +throwTypecheckError te i = throwError te _dbgTypedTerm :: TCTerm s b i @@ -961,6 +973,8 @@ generalizeWithTerm' ty pp term = do liftType :: Type Void -> Type a liftType = fmap absurd +toTypedArg (Arg n (Just ty)) = TypedArg n ty + checkTermType :: (TypeOfBuiltin b) => TCType s @@ -977,10 +991,12 @@ checkTermType checkty = \case Nothing -> throwTypecheckError (TCUnboundTermVariable n) i NTopLevel mn _mh -> - view (tcFree . at (FullyQualifiedName mn n _mh)) >>= \case - Just (DefunType nty) -> do + view (tcLoaded . loAllLoaded . at (FullyQualifiedName mn n _mh)) >>= \case + Just (IR.DCapDfun d) -> do + let funArgs = fmap liftCoreType . toTypedArg <$> IR._dfunArgs d + funRet = maybe (error "boom") id (_dfunRType d) + rty = foldr (\arg ty -> TyFun (_targType arg) ty) funRet funArgs let newVar = Typed.Var irn i - rty = liftType nty unify rty checkty i pure (rty, newVar, []) _ -> @@ -1128,9 +1144,9 @@ checkTermType checkty = \case (tmref, mref', preds) <- inferTerm mref case tmref of TyModRef m -> view (tcModules . at m) >>= \case - Just (InterfaceData iface _) -> case U.findIfDef fn iface of - Just (U.IfDfun df) -> do - unify (liftType (U._ifdType df)) checkty i + Just (InterfaceData iface _) -> case IR.findIfDef fn iface of + Just (IR.IfDfun df) -> do + unify (liftType (IR._ifdType df)) checkty i pure (checkty, Typed.DynInvoke mref' fn i, preds) _ -> error "boom" _ -> error "boom" @@ -1294,9 +1310,9 @@ inferTerm = \case (tmref, mref', preds) <- inferTerm mref case tmref of TyModRef m -> view (tcModules . at m) >>= \case - Just (InterfaceData iface _) -> case U.findIfDef fn iface of - Just (U.IfDfun df) -> do - pure (liftType (U._ifdType df), Typed.DynInvoke mref' fn i, preds) + Just (InterfaceData iface _) -> case IR.findIfDef fn iface of + Just (IR.IfDfun df) -> do + pure (liftType (IR._ifdType df), Typed.DynInvoke mref' fn i, preds) _ -> error "boom" _ -> error "boom" _ -> error "boom" @@ -1448,33 +1464,30 @@ inferReplTopLevel :: TypeOfBuiltin b => Loaded reso i -> IR.ReplTopLevel Name b i - -> InferM s reso i (TypedReplTopLevel b i, Loaded reso i) + -> InferM s reso i (TypedReplTopLevel b i) inferReplTopLevel loaded = \case IR.RTLModule m -> do tcm <- inferModule m let toFqn df = FullyQualifiedName (Typed._mName tcm) (Typed.defName df) (Typed._mHash tcm) newTLs = Map.fromList $ (\df -> (toFqn df, Typed.defType df)) <$> Typed._mDefs tcm loaded' = over loAllTyped (Map.union newTLs) loaded - pure (Typed.RTLModule tcm, loaded') - IR.RTLTerm m -> (, loaded) . Typed.RTLTerm . snd <$> inferTermNonGen m + pure (Typed.RTLModule tcm) + IR.RTLTerm m -> Typed.RTLTerm . snd <$> inferTermNonGen m -- Todo: if we don't update the module hash to update linking, -- repl defuns and defconsts will break invariants about IR.RTLDefun dfn -> do dfn' <- inferDefun dfn let newFqn = FullyQualifiedName replModuleName (Typed._dfunName dfn') replModuleHash - let loaded' = over loAllTyped (Map.insert newFqn (DefunType (Typed._dfunType dfn'))) loaded - pure (Typed.RTLDefun dfn', loaded') + pure (Typed.RTLDefun dfn') IR.RTLDefConst dconst -> do dc <- inferDefConst dconst let newFqn = FullyQualifiedName replModuleName (Typed._dcName dc) replModuleHash - let loaded' = over loAllTyped (Map.insert newFqn (DefunType (Typed._dcType dc))) loaded - pure (Typed.RTLDefConst dc, loaded') + pure (Typed.RTLDefConst dc) IR.RTLInterface i -> do tci <- inferInterface i let toFqn dc = FullyQualifiedName (Typed._ifName tci) (Typed._dcName dc) (Typed._ifHash tci) newTLs = Map.fromList $ fmap (\df -> (toFqn df, DefunType (Typed._dcType df))) $ mapMaybe (preview Typed._IfDConst) (Typed._ifDefns tci) - loaded' = over loAllTyped (Map.union newTLs) loaded - pure (Typed.RTLInterface tci, loaded') + pure (Typed.RTLInterface tci) -- | Transform types into their debruijn-indexed version @@ -1704,7 +1717,7 @@ runInfer runInfer loaded (InferT act) = do uref <- newSTRef 0 lref <- newSTRef 1 - let tcs = TCState uref mempty (_loAllTyped loaded) lref (_loModules loaded) + let tcs = TCState uref mempty loaded lref (_loModules loaded) runReaderT (runExceptT act) tcs runInferTerm diff --git a/typed-core/Pact/Core/Typed/Overload.hs b/typed-core/Pact/Core/Typed/Overload.hs index 83eccdc0c..7174014eb 100644 --- a/typed-core/Pact/Core/Typed/Overload.hs +++ b/typed-core/Pact/Core/Typed/Overload.hs @@ -23,9 +23,9 @@ import Control.Monad.Except import Data.Text(Text) import Data.List.NonEmpty(NonEmpty(..)) -import qualified Data.Text as T +-- import qualified Data.Text as T -import Pact.Core.Type +import Pact.Core.Typed.Type import Pact.Core.Names import Pact.Core.Builtin import Pact.Core.Typed.Term @@ -40,8 +40,9 @@ newtype OverloadM info a = , MonadError (PactError info)) via (Either (PactError info)) +-- Todo: proper overload error throwOverloadError :: String -> i -> OverloadM i a -throwOverloadError e = throwError . PEOverloadError (OverloadError (T.pack e)) +throwOverloadError e _ = error e class SolveOverload raw resolved | raw -> resolved where solveOverload @@ -350,7 +351,7 @@ solveCoreOverload i b tys preds = case b of pure (Builtin ReadDecimal i) RawReadString -> pure (Builtin ReadString i) - RawListAccess -> + RawAt -> pure (Builtin ListAccess i) RawMakeList -> pure (Builtin MakeList i) @@ -363,6 +364,10 @@ solveCoreOverload i b tys preds = case b of RawReadKeyset -> pure (Builtin ReadKeyset i) RawEnforceGuard -> pure (Builtin EnforceGuard i) RawKeysetRefGuard -> pure (Builtin KeysetRefGuard i) + RawContains -> error "contains" + RawSort -> error "sort" + RawSortObject -> error "sortObject" + RawRemove -> error "remove" singlePred :: [t] -> i -> (t -> OverloadM i a) -> String -> OverloadM i a singlePred preds i f msg = case preds of @@ -373,9 +378,9 @@ resolveDefun :: SolveOverload raw reso => OverloadedDefun tyname raw info -> OverloadM info (Defun Name tyname reso info) -resolveDefun (Defun dname ty term info) = do +resolveDefun (Defun dname args rty term info) = do term' <- resolveTerm term - pure (Defun dname ty term' info) + pure (Defun dname args rty term' info) resolveDefConst :: SolveOverload raw reso diff --git a/typed-core/Pact/Core/Typed/Term.hs b/typed-core/Pact/Core/Typed/Term.hs index e0c09d624..8a629001d 100644 --- a/typed-core/Pact/Core/Typed/Term.hs +++ b/typed-core/Pact/Core/Typed/Term.hs @@ -40,7 +40,6 @@ module Pact.Core.Typed.Term , CoreEvalTopLevel , CoreEvalReplTopLevel , defName - , defType , defTerm -- Prisms and lenses , _IfDfun @@ -57,7 +56,8 @@ import qualified Data.List.NonEmpty as NE import Pact.Core.Builtin import Pact.Core.Literal import Pact.Core.Names -import Pact.Core.Type +import Pact.Core.Type hiding (Type) +import Pact.Core.Typed.Type import Pact.Core.Imports import Pact.Core.Hash import Pact.Core.Guards @@ -66,13 +66,21 @@ import Pact.Core.Pretty(Pretty(..), pretty, (<+>)) import qualified Pact.Core.Pretty as Pretty +-- data Defun name tyname builtin info +-- = Defun +-- { _dfunName :: Text +-- , _dfunType :: Type Void +-- , _dfunTerm :: Term name tyname builtin info +-- , _dfunInfo :: info +-- } deriving Show data Defun name tyname builtin info = Defun { _dfunName :: Text - , _dfunType :: Type Void + , _dfunArgs :: [TypedArg (Type tyname)] + , _dfunRType :: Type tyname , _dfunTerm :: Term name tyname builtin info , _dfunInfo :: info - } deriving Show + } deriving (Show, Functor) data DefConst name tyname builtin info = DefConst @@ -86,12 +94,12 @@ data DefCap name tyname builtin info = DefCap { _dcapName :: Text , _dcapAppArity :: Int - , _dcapArgTypes :: [Type Void] - , _dcapRType :: Type Void + , _dcapArgs :: [TypedArg (Type tyname)] + , _dcapRType :: Type tyname , _dcapTerm :: Term name tyname builtin info , _dcapMeta :: Maybe (DefCapMeta name) , _dcapInfo :: info - } deriving Show + } deriving (Show, Functor) data Def name tyname builtin info @@ -105,11 +113,11 @@ data Def name tyname builtin info -- DPact (DefPact name builtin info) -- DSchema (DefSchema name info) -- DTable (DefTable name info) -defType :: Def name tyname builtin info -> TypeOfDef Void -defType = \case - Dfun d -> DefunType (_dfunType d) - DConst d -> DefunType (_dcType d) - DCap d -> DefcapType (_dcapArgTypes d) (_dcapRType d) +-- defType :: Def name tyname builtin info -> TypeOfDef Void +-- defType = \case +-- Dfun d -> DefunType (_dfunType d) +-- DConst d -> DefunType (_dcType d) +-- DCap d -> DefcapType (_dcapArgTypes d) (_dcapRType d) defName :: Def name tyname builtin i -> Text defName = \case diff --git a/typed-core/Pact/Core/Typed/Typecheck.hs b/typed-core/Pact/Core/Typed/Typecheck.hs index e6637ad83..64916de5d 100644 --- a/typed-core/Pact/Core/Typed/Typecheck.hs +++ b/typed-core/Pact/Core/Typed/Typecheck.hs @@ -10,7 +10,7 @@ module Pact.Core.Typed.Typecheck where import Control.Monad import Control.Lens import Control.Monad.Reader -import Control.Monad.Except +import Control.Monad.Except ( MonadError(throwError) ) import Data.Foldable(foldlM) import Data.List.NonEmpty(NonEmpty(..)) import Data.Map.Strict(Map) @@ -22,7 +22,7 @@ import qualified Data.RAList as RAList import Pact.Core.Builtin import Pact.Core.Typed.Term import Pact.Core.Names -import Pact.Core.Type +import Pact.Core.Typed.Type data TCEnv tyname builtin = TCEnv diff --git a/typed-core/Pact/Core/Untyped/Eval/CEK.hs b/typed-core/Pact/Core/Untyped/Eval/CEK.hs deleted file mode 100644 index a6b9b992e..000000000 --- a/typed-core/Pact/Core/Untyped/Eval/CEK.hs +++ /dev/null @@ -1,423 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ConstraintKinds #-} - --- | --- Module : Pact.Core.IR.Typecheck --- Copyright : (C) 2022 Kadena --- License : BSD-style (see the file LICENSE) --- Maintainer : Jose Cardona --- --- CEK Evaluator for untyped core. --- - -module Pact.Core.Untyped.Eval.CEK - ( eval - , evalCEK - , returnCEK - , returnCEKValue - , failInvariant - , throwExecutionError' - , unsafeApplyOne - , unsafeApplyTwo - ) where - -import Control.Lens -import Control.Monad.Except -import Data.Default -import Data.Text(Text) -import qualified Data.Map.Strict as Map -import qualified Data.RAList as RAList -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Data.Set as S - -import Pact.Core.Builtin -import Pact.Core.Names -import Pact.Core.Errors -import Pact.Core.Gas -import Pact.Core.Literal -import Pact.Core.PactValue -import Pact.Core.Capabilities - -import Pact.Core.Untyped.Term -import Pact.Core.Untyped.Eval.Runtime - --- chargeGas :: MonadEval b i m => Gas -> m () --- chargeGas g = do - -- ref <- view cekGas - -- gCurr <- liftIO (readIORef ref) - -- gLimit <- view (cekGasModel . geGasLimit) - -- let gUsed = g + gCurr - -- msg = "Gas Limit (" <> T.pack (show gLimit) <> ") exceeeded: " <> T.pack (show gUsed) - -- when (gUsed > gLimit) $ throwM (GasExceeded msg) - -chargeNodeGas :: MonadEval b i m => NodeType -> m () -chargeNodeGas nt = do - gm <- view (cekGasModel . geGasModel . gmNodes) <$> cekReadEnv - cekChargeGas (gm nt) - -- gm <- view (cekGasModel . geGasModel . gmNodes) - -- chargeGas (gm nt) - -chargeNative :: MonadEval b i m => b -> m () -chargeNative native = do - gm <- view (cekGasModel . geGasModel . gmNatives) <$> cekReadEnv - cekChargeGas (gm native) - -- gm <- view (cekGasModel . geGasModel . gmNatives) - -- chargeGas (gm native) - --- Todo: exception handling? do we want labels --- Todo: `traverse` usage should be perf tested. --- It might be worth making `Arg` frames incremental, as opposed to a traverse call -eval - :: forall b i m. (MonadEval b i m) - => CEKEnv b i m - -> EvalTerm b i - -> m (EvalResult b i m) -eval = evalCEK Mt CEKNoHandler - -evalCEK - :: (MonadEval b i m) - => Cont b i m - -> CEKErrorHandler b i m - -> CEKEnv b i m - -> EvalTerm b i - -> m (EvalResult b i m) -evalCEK cont handler env (Var n info) = do - chargeNodeGas VarNode - case _nKind n of - NBound i -> case RAList.lookup env i of - Just v -> returnCEKValue cont handler v - Nothing -> failInvariant' ("unbound identifier" <> T.pack (show n)) info - -- Top level names are not closures, so we wipe the env - NTopLevel mname mh -> do - let fqn = FullyQualifiedName mname (_nName n) mh - cekReadEnv >>= \renv -> case Map.lookup fqn (view cekLoaded renv) of - Just (Dfun d) -> evalCEK cont handler RAList.Nil (_dfunTerm d) - Just _ -> failInvariant' "invalid call" info - Nothing -> failInvariant' ("top level name " <> T.pack (show fqn) <> " not in scope") info - NModRef m ifs -> - returnCEKValue cont handler (VModRef m ifs) -evalCEK cont handler _env (Constant l _) = do - chargeNodeGas ConstantNode - returnCEKValue cont handler (VLiteral l) -evalCEK cont handler env (App fn arg _) = do - chargeNodeGas AppNode - evalCEK (Arg env arg cont) handler env fn -evalCEK cont handler env (Lam body _) = do - chargeNodeGas LamNode - returnCEKValue cont handler (VClosure body env) -evalCEK cont handler _env (Builtin b _) = do - chargeNodeGas BuiltinNode - builtins <- view cekBuiltins <$> cekReadEnv - returnCEKValue cont handler (VNative (builtins b)) -evalCEK cont handler env (Sequence e1 e2 _) = do - chargeNodeGas SeqNode - evalCEK (SeqC env e2 cont) handler env e1 -evalCEK cont handler env (Conditional c _) = case c of - CAnd te te' -> - evalCEK (CondC env (AndFrame te') cont) handler env te - COr te te' -> - evalCEK (CondC env (OrFrame te') cont) handler env te - CIf cond e1 e2 -> - evalCEK (CondC env (IfFrame e1 e2) cont) handler env cond -evalCEK cont handler env (CapabilityForm cf _) = do - fqn <- nameToFQN (view capFormName cf) - case cf of - WithCapability _ args body -> case args of - x:xs -> let - capFrame = WithCapFrame fqn body - cont' = CapInvokeC env xs [] capFrame cont - in evalCEK cont' handler env x - [] -> evalCap cont handler env (CapToken fqn []) body - RequireCapability _ args -> case args of - [] -> requireCap cont handler (CapToken fqn []) - x:xs -> let - capFrame = RequireCapFrame fqn - cont' = CapInvokeC env xs [] capFrame cont - in evalCEK cont' handler env x - ComposeCapability _ args -> case args of - [] -> composeCap cont handler (CapToken fqn []) - x:xs -> let - capFrame = ComposeCapFrame fqn - cont' = CapInvokeC env xs [] capFrame cont - in evalCEK cont' handler env x - InstallCapability _ args -> case args of - [] -> installCap cont handler env (CapToken fqn []) - x : xs -> let - capFrame = InstallCapFrame fqn - cont' = CapInvokeC env xs [] capFrame cont - in evalCEK cont' handler env x - EmitEvent _ args -> case args of - [] -> emitEvent cont handler (CapToken fqn []) - x : xs -> let - capFrame = EmitEventFrame fqn - cont' = CapInvokeC env xs [] capFrame cont - in evalCEK cont' handler env x - CreateUserGuard{} -> error "implement" -evalCEK cont handler env (ListLit ts _) = do - chargeNodeGas ListNode - case ts of - [] -> returnCEKValue cont handler (VList mempty) - x:xs -> evalCEK (ListC env xs [] cont) handler env x -evalCEK cont handler env (Try e1 rest _) = do - caps <- useCekState (esCaps . csSlots) - let handler' = CEKHandler env e1 cont caps handler - evalCEK Mt handler' env rest -evalCEK cont handler env (DynInvoke n fn _) = - evalCEK (DynInvokeC env fn cont) handler env n --- Error terms ignore the current cont -evalCEK _ handler _ (Error e _) = - returnCEK Mt handler (VError e) - --- Todo: fail invariant -nameToFQN :: Applicative f => Name -> f FullyQualifiedName -nameToFQN (Name n nk) = case nk of - NTopLevel mn mh -> pure (FullyQualifiedName mn n mh) - NBound{} -> error "expected fully resolve FQ name" - NModRef{} -> error "expected non-modref" - --- Todo: fail invariants -cekToPactValue :: Applicative f => CEKValue b i m -> f PactValue -cekToPactValue = \case - VLiteral lit -> pure (PLiteral lit) - VList vec -> PList <$> traverse cekToPactValue vec - VClosure{} -> error "closure is not a pact value" - VNative{} -> error "Native is not a pact value" - VModRef mn mns -> pure (PModRef mn mns) - VGuard gu -> pure (PGuard gu) - --- Todo: managed -evalCap - :: MonadEval b i m - => Cont b i m - -> CEKErrorHandler b i m - -> CEKEnv b i m - -> CapToken - -> EvalTerm b i - -> m (EvalResult b i m) -evalCap cont handler env ct@(CapToken fqn args) contbody = do - cekReadEnv >>= \renv -> case Map.lookup fqn (view cekLoaded renv) of - Just (DCap d) -> do - modifyCEKState (esCaps . csSlots) (CapSlot ct []:) - let (env', capBody) = applyCapBody mempty args (_dcapTerm d) - cont' = CapBodyC env contbody cont - evalCEK cont' handler env' capBody - Just {} -> error "was not defcap, invariant violated" - Nothing -> error "No such def" - where - applyCapBody e (x:xs) (Lam b _) = - applyCapBody (RAList.cons (pactToCEKValue x) e) xs b - applyCapBody e _ b = (e, b) - - -requireCap - :: MonadEval b i m - => Cont b i m - -> CEKErrorHandler b i m - -> CapToken - -> m (EvalResult b i m) -requireCap cont handler ct = do - caps <- useCekState (esCaps.csSlots) - let csToSet cs = S.insert (_csCap cs) (S.fromList (_csComposed cs)) - capSet = foldMap csToSet caps - if S.member ct capSet then returnCEKValue cont handler VUnit - else throwExecutionError' (CapNotInScope "ovuvue") - -composeCap - :: (MonadEval b i m) - => Cont b i m - -> CEKErrorHandler b i m - -> CapToken - -> m (EvalResult b i m) -composeCap cont handler ct@(CapToken fqn args) = do - cekReadEnv >>= \renv -> case Map.lookup fqn (view cekLoaded renv) of - Just (DCap d) -> do - modifyCEKState (esCaps . csSlots) (CapSlot ct []:) - let (env', capBody) = applyCapBody mempty args (_dcapTerm d) - cont' = CapPopC PopCapComposed cont - evalCEK cont' handler env' capBody - Just {} -> error "was not defcap, invariant violated" - Nothing -> error "No such def" - where - applyCapBody e (x:xs) (Lam b _) = - applyCapBody (RAList.cons (pactToCEKValue x) e) xs b - applyCapBody e _ b = (e, b) - -installCap :: a -installCap = undefined - -emitEvent - :: MonadEval b i m - => Cont b i m - -> CEKErrorHandler b i m - -> CapToken - -> m (EvalResult b i m) -emitEvent cont handler ct@(CapToken fqn _) = do - let pactEvent = PactEvent ct (_fqModule fqn) (_fqHash fqn) - modifyCEKState esEvents (pactEvent:) - returnCEKValue cont handler VUnit - - -returnCEK :: (MonadEval b i m) - => Cont b i m - -> CEKErrorHandler b i m - -> EvalResult b i m - -> m (EvalResult b i m) -returnCEK Mt handler v = - case handler of - CEKNoHandler -> return v - CEKHandler env term cont' caps handler' -> case v of - VError{} -> do - setCekState (esCaps . csSlots) caps - evalCEK cont' handler' env term - EvalValue v' -> - returnCEKValue cont' handler' v' -returnCEK cont handler v = case v of - VError{} -> returnCEK Mt handler v - EvalValue v' -> returnCEKValue cont handler v' - -returnCEKValue - :: (MonadEval b i m) - => Cont b i m - -> CEKErrorHandler b i m - -> CEKValue b i m - -> m (EvalResult b i m) -returnCEKValue Mt handler v = - case handler of - CEKNoHandler -> return (EvalValue v) - -- Assuming no error, the caps will have been popped naturally - CEKHandler _env _term cont' _ handler' -> returnCEKValue cont' handler' v --- Error terms that don't simply returnt the empty continuation --- "Zero out" the continuation up to the latest handler --- returnCEKValue _cont handler v@VError{} = --- returnCEK Mt handler v -returnCEKValue (Arg env arg cont) handler fn = - evalCEK (Fn fn cont) handler env arg -returnCEKValue (Fn fn cont) handler arg = - applyLam fn arg cont handler -returnCEKValue (SeqC env e cont) handler _ = - evalCEK cont handler env e -returnCEKValue (CondC env frame cont) handler v = case v of - (VLiteral (LBool b)) -> case frame of - AndFrame te -> - if b then evalCEK cont handler env te - else returnCEKValue cont handler v - OrFrame te -> - if b then returnCEKValue cont handler v - else evalCEK cont handler env te - IfFrame ifExpr elseExpr -> - if b then evalCEK cont handler env ifExpr - else evalCEK cont handler env elseExpr - _ -> failInvariant "Evaluation of conditional expression yielded non-boolean value" -returnCEKValue (CapInvokeC env terms pvs cf cont) handler v = case terms of - x:xs -> do - pv <- cekToPactValue v - let cont' = CapInvokeC env xs (pv:pvs) cf cont - evalCEK cont' handler env x - [] -> case cf of - WithCapFrame fqn wcbody -> - evalCap cont handler env (CapToken fqn (reverse pvs)) wcbody - RequireCapFrame fqn -> - requireCap cont handler (CapToken fqn (reverse pvs)) - ComposeCapFrame fqn -> - composeCap cont handler (CapToken fqn (reverse pvs)) - InstallCapFrame{} -> error "todo" - EmitEventFrame fqn -> - emitEvent cont handler (CapToken fqn (reverse pvs)) -returnCEKValue (CapBodyC env term cont) handler _ = do - let cont' = CapPopC PopCapInvoke cont - evalCEK cont' handler env term -returnCEKValue (CapPopC st cont) handler v = case st of - PopCapInvoke -> do - -- todo: need safe tail here, but this should be fine given the invariant that `CapPopC` - -- will never show up otherwise - modifyCEKState (esCaps . csSlots) tail - returnCEKValue cont handler v - PopCapComposed -> do - caps <- useCekState (esCaps . csSlots) - let cs = head caps - csList = _csCap cs : _csComposed cs - caps' = over (_head . csComposed) (++ csList) (tail caps) - setCekState (esCaps . csSlots) caps' - returnCEKValue cont handler VUnit -returnCEKValue (ListC env args vals cont) handler v = do - case args of - [] -> - returnCEKValue cont handler (VList (V.fromList (reverse (v:vals)))) - e:es -> - evalCEK (ListC env es (v:vals) cont) handler env e --- Todo: note over here we might want to typecheck --- Todo: inline the variable lookup instead of calling EvalCEK directly, --- as we can provide a better error message this way. -returnCEKValue (DynInvokeC env fn cont) handler v = case v of - VModRef mn _ -> do - -- Todo: for when persistence is implemented - -- here is where we would incur module loading - cekReadEnv >>= \e -> case view (cekMHashes . at mn) e of - Just mh -> - evalCEK cont handler env (Var (Name fn (NTopLevel mn mh)) def) - Nothing -> failInvariant "No such module" - _ -> failInvariant "Not a modref" - -applyLam - :: (MonadEval b i m) - => CEKValue b i m - -> CEKValue b i m - -> Cont b i m - -> CEKErrorHandler b i m - -> m (EvalResult b i m) -applyLam (VClosure body env) arg cont handler = - evalCEK cont handler (RAList.cons arg env) body -applyLam (VNative (NativeFn b fn arity args)) arg cont handler - | arity - 1 == 0 = do - chargeNative b - fn cont handler (reverse (arg:args)) - | otherwise = returnCEKValue cont handler (VNative (NativeFn b fn (arity - 1) (arg:args))) -applyLam _ _ _ _ = failInvariant' "Applying value to non-function" def - -failInvariant :: MonadEval b i m => Text -> m a -failInvariant b = - let e = PEExecutionError (InvariantFailure b) def - in throwError e - -failInvariant' :: MonadEval b i m => Text -> i -> m a -failInvariant' b i = - let e = PEExecutionError (InvariantFailure b) i - in throwError e - -throwExecutionError' :: (MonadEval b i m) => EvalError -> m a -throwExecutionError' e = throwError (PEExecutionError e def) - -unsafeApplyOne - :: MonadEval b i m - => CEKValue b i m - -> CEKValue b i m - -> m (EvalResult b i m) -unsafeApplyOne (VClosure body env) arg = eval (RAList.cons arg env) body -unsafeApplyOne (VNative (NativeFn b fn arity args)) arg = - if arity - 1 <= 0 then fn Mt CEKNoHandler (reverse (arg:args)) - else pure (EvalValue (VNative (NativeFn b fn (arity - 1) (arg:args)))) -unsafeApplyOne _ _ = failInvariant "Applied argument to non-closure in native" - -unsafeApplyTwo - :: MonadEval b i m - => CEKValue b i m - -> CEKValue b i m - -> CEKValue b i m - -> m (EvalResult b i m) -unsafeApplyTwo (VClosure (Lam body _) env) arg1 arg2 = - eval (RAList.cons arg2 (RAList.cons arg1 env)) body -unsafeApplyTwo (VNative (NativeFn b fn arity args)) arg1 arg2 = - if arity - 2 <= 0 then fn Mt CEKNoHandler (reverse (arg1:arg2:args)) - else pure $ EvalValue $ VNative $ NativeFn b fn (arity - 2) (arg1:arg2:args) -unsafeApplyTwo _ _ _ = failInvariant "Applied argument to non-closure in native" diff --git a/typed-core/Pact/Core/Untyped/Eval/Runtime.hs b/typed-core/Pact/Core/Untyped/Eval/Runtime.hs deleted file mode 100644 index 6af7ab0e6..000000000 --- a/typed-core/Pact/Core/Untyped/Eval/Runtime.hs +++ /dev/null @@ -1,400 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE InstanceSigs #-} - - -module Pact.Core.Untyped.Eval.Runtime - ( CEKTLEnv - , CEKEnv - , EvalEnv(..) - , NativeFn(..) - , EvalT(..) - , runEvalT - , CEKValue(..) - , Cont(..) - , mkBuiltinFn - , cekBuiltins - , cekLoaded - , cekGasModel - , cekMHashes, cekMsgSigs - , fromPactValue - , checkPactValueType - , pactToCEKValue - , cfFQN - , CEKErrorHandler(..) - , MonadEvalEnv(..) - , MonadEvalState(..) - , CondFrame(..) - , MonadEval - , Closure(..) - , EvalResult(..) - , EvalEnv(..) - , EvalState(..) - , esCaps, esEvents, esInCap - , pattern VString - , pattern VInteger - , pattern VDecimal - , pattern VUnit - , pattern VBool - -- Capabilities - , CapToken(..) - , ctName, ctArgs - , CapSlot(..) - , csCap, csComposed - , CapFrame(..) - , CapState(..) - , csSlots, csManaged - , ManagedCap(..) - , mcCap, mcManaged - , ManagedCapType(..) - , PactEvent(..) - , CapPopState(..) - ) where - - -import Control.Lens -import Control.Monad.Catch -import Control.Monad.Reader -import Control.Monad.Except -import Control.Monad.State.Strict -import Data.Void -import Data.Text(Text) -import Data.Map.Strict(Map) -import Data.Default -import Data.Decimal(Decimal) --- import Data.Set(Set) -import Data.Vector(Vector) -import Data.RAList(RAList) -import Data.Set(Set) -import Data.IORef -import qualified Data.Vector as V - -import Pact.Core.Names -import Pact.Core.Guards -import Pact.Core.Pretty(Pretty(..), (<+>)) -import Pact.Core.Gas -import Pact.Core.PactValue -import Pact.Core.Errors -import Pact.Core.Builtin -import Pact.Core.Hash -import Pact.Core.Untyped.Term -import Pact.Core.Literal --- import Pact.Core.Persistence -import Pact.Core.Type -import qualified Pact.Core.Pretty as P - --- | The top level env map -type CEKTLEnv b i = Map FullyQualifiedName (EvalDef b i) - --- | Locally bound variables -type CEKEnv b i m = RAList (CEKValue b i m) - --- | List of builtins -type BuiltinEnv b i m = b -> NativeFn b i m - -data Closure b i m = - Closure !(EvalTerm b i) !(CEKEnv b i m) - deriving Show - --- | The type of our semantic runtime values -data CEKValue b i m - = VLiteral !Literal - | VList !(Vector (CEKValue b i m)) - | VClosure !(EvalTerm b i) !(CEKEnv b i m) - | VNative !(NativeFn b i m) - | VModRef ModuleName [ModuleName] - | VGuard !(Guard FullyQualifiedName PactValue) - -- deriving Show - -instance Show (CEKValue b i m) where - show = \case - VLiteral lit -> show lit - VList vec -> show vec - VClosure _ _ -> "closure<>" - VNative _ -> "native<>" - VModRef mn mns -> "modRef" <> show mn <> show mns - VGuard _ -> "guard<>" - -pactToCEKValue :: PactValue -> CEKValue b i m -pactToCEKValue = \case - PLiteral lit -> VLiteral lit - PList vec -> VList (pactToCEKValue <$> vec) - PGuard gu -> VGuard gu - PModRef mn ifs -> VModRef mn ifs - -pattern VString :: Text -> CEKValue b i m -pattern VString txt = VLiteral (LString txt) - -pattern VInteger :: Integer -> CEKValue b i m -pattern VInteger txt = VLiteral (LInteger txt) - -pattern VUnit :: CEKValue b i m -pattern VUnit = VLiteral LUnit - -pattern VBool :: Bool -> CEKValue b i m -pattern VBool b = VLiteral (LBool b) - -pattern VDecimal :: Decimal -> CEKValue b i m -pattern VDecimal d = VLiteral (LDecimal d) - --- | Result of an evaluation step, either a CEK value or an error. -data EvalResult b i m - = EvalValue (CEKValue b i m) - | VError Text - deriving Show - -data EvalState b i - = EvalState - { _esCaps :: CapState - , _esEvents :: [PactEvent b i] - , _esInCap :: Bool - } deriving Show - -type MonadEval b i m = (MonadEvalEnv b i m, MonadEvalState b i m, MonadError (PactError i) m, Default i) - -class (Monad m) => MonadEvalEnv b i m | m -> b, m -> i where - cekReadEnv :: m (EvalEnv b i m) - cekLogGas :: Text -> Gas -> m () - cekChargeGas :: Gas -> m () - -class Monad m => (MonadEvalState b i m) | m -> b, m -> i where - setCekState :: Lens' (EvalState b i) s -> s -> m () - modifyCEKState :: Lens' (EvalState b i) s -> (s -> s) -> m () - useCekState :: Lens' (EvalState b i) s -> m s - usesCekState :: Lens' (EvalState b i) s -> (s -> s') -> m s' - -data EvalEnv b i m - = EvalEnv - { _emRuntimeEnv :: EvalEnv b i (EvalT b i m) - , _emGas :: IORef Gas - , _emGasLog :: IORef (Maybe [(Text, Gas)]) - } - --- Todo: are we going to inject state as the reader monad here? -newtype EvalT b i m a = - EvalT (ReaderT (EvalEnv b i m) (StateT (EvalState b i) m) a) - deriving - ( Functor, Applicative, Monad - , MonadIO - , MonadThrow - , MonadCatch) - via (ReaderT (EvalEnv b i m) (StateT (EvalState b i) m)) - -runEvalT - :: EvalEnv b i m - -> EvalState b i - -> EvalT b i m a - -> m (a, EvalState b i) -runEvalT env st (EvalT action) = runStateT (runReaderT action env) st - -data NativeFn b i m - = NativeFn - { _native :: b - , _nativeFn :: Cont b i m -> CEKErrorHandler b i m -> [CEKValue b i m] -> m (EvalResult b i m) - , _nativeArity :: {-# UNPACK #-} !Int - , _nativeAppliedArgs :: [CEKValue b i m] - } - -mkBuiltinFn - :: (BuiltinArity b) - => (Cont b i m -> CEKErrorHandler b i m -> [CEKValue b i m] -> m (EvalResult b i m)) - -> b - -> NativeFn b i m -mkBuiltinFn fn b = - NativeFn b fn (builtinArity b) [] -{-# INLINE mkBuiltinFn #-} - -data ExecutionMode - = Transactional - | Local - deriving (Eq, Show, Bounded, Enum) - -data CondFrame b i - = AndFrame (EvalTerm b i) - | OrFrame (EvalTerm b i) - | IfFrame (EvalTerm b i) (EvalTerm b i) - deriving Show - -data CapToken - = CapToken - { _ctName :: FullyQualifiedName - , _ctArgs :: [PactValue] - } deriving (Show, Eq, Ord) - -data CapSlot - = CapSlot - { _csCap :: CapToken - , _csComposed :: [CapToken] - } deriving (Show, Eq) - -data PactEvent b i - = PactEvent - { _peToken :: CapToken - , _peModule :: ModuleName - , _peModuleHash :: ModuleHash - } deriving (Show, Eq) - -data ManagedCapType - = AutoManaged Bool - | ManagedParam FullyQualifiedName PactValue Int - -- ^ managed cap, with manager function, managed value - deriving Show - -data ManagedCap - = ManagedCap - { _mcCap :: CapToken - , _mcManaged :: ManagedCapType - } deriving (Show) - -instance Eq ManagedCap where - l == r = _mcCap l == _mcCap r - -instance Ord ManagedCap where - l `compare` r = _mcCap l `compare` _mcCap r - --- | The overall capability state -data CapState - = CapState - { _csSlots :: [CapSlot] - , _csManaged :: Set ManagedCap - } - deriving Show - -data CapFrame b i - = WithCapFrame FullyQualifiedName (EvalTerm b i) - | RequireCapFrame FullyQualifiedName - | ComposeCapFrame FullyQualifiedName - | InstallCapFrame FullyQualifiedName - | EmitEventFrame FullyQualifiedName - deriving Show - -cfFQN :: Lens' (CapFrame b i) FullyQualifiedName -cfFQN f = \case - WithCapFrame fqn b -> (`WithCapFrame` b) <$> f fqn - RequireCapFrame fqn -> RequireCapFrame <$> f fqn - ComposeCapFrame fqn -> ComposeCapFrame <$> f fqn - InstallCapFrame fqn -> InstallCapFrame <$> f fqn - EmitEventFrame fqn -> EmitEventFrame <$> f fqn - -data CapPopState - = PopCapComposed - | PopCapInvoke - deriving (Eq, Show) - -data Cont b i m - = Fn (CEKValue b i m) (Cont b i m) - | Arg (CEKEnv b i m) (EvalTerm b i) (Cont b i m) - | SeqC (CEKEnv b i m) (EvalTerm b i) (Cont b i m) - | ListC (CEKEnv b i m) [EvalTerm b i] [CEKValue b i m] (Cont b i m) - | CondC (CEKEnv b i m) (CondFrame b i) (Cont b i m) - | DynInvokeC (CEKEnv b i m) Text (Cont b i m) - | CapInvokeC (CEKEnv b i m) [EvalTerm b i] [PactValue] (CapFrame b i) (Cont b i m) - | CapBodyC (CEKEnv b i m) (EvalTerm b i) (Cont b i m) - | CapPopC CapPopState (Cont b i m) - | Mt - deriving Show - - -data CEKErrorHandler b i m - = CEKNoHandler - | CEKHandler (CEKEnv b i m) (EvalTerm b i) (Cont b i m) [CapSlot] (CEKErrorHandler b i m) - deriving Show - -data EvalEnv b i m - = EvalEnv - { _cekBuiltins :: BuiltinEnv b i m - , _cekGasModel :: GasEnv b - , _cekLoaded :: CEKTLEnv b i - , _cekMHashes :: Map ModuleName ModuleHash - , _cekMsgSigs :: Map PublicKeyText (Set CapToken) - -- _cekGas :: IORef Gas - -- , _cekEvalLog :: IORef (Maybe [(Text, Gas)]) - -- , _ckeData :: EnvData PactValue - -- , _ckeTxHash :: Hash - -- , _ckeResolveName :: QualifiedName -> Maybe FullyQualifiedName - -- , _ckeSigs :: Set PublicKey - -- , _ckePactDb :: PactDb b i - } - -instance (Show i, Show b) => Show (NativeFn b i m) where - show (NativeFn b _ arity args) = unwords - ["(NativeFn" - , show b - , "#fn" - , show arity - , show args - , ")" - ] - -instance (Pretty b, Show i, Show b) => Pretty (NativeFn b i m) where - pretty = pretty . show - -instance (Show i, Show b, Pretty b) => Pretty (CEKValue b i m) where - pretty = \case - VLiteral i -> - pretty i - VList v -> - P.brackets $ P.hsep (P.punctuate P.comma (V.toList (pretty <$> v))) - VClosure{} -> - P.angles "closure#" - VNative b -> - P.angles $ "native" <+> pretty b - VGuard _ -> P.angles "guard#" - VModRef mn _ -> - "modref" <> P.braces (pretty mn) - -- VError e -> - -- ("error " <> pretty e) - -makeLenses ''EvalEnv - -fromPactValue :: PactValue -> CEKValue b i m -fromPactValue = \case - PLiteral lit -> VLiteral lit - PList vec -> VList (fromPactValue <$> vec) - PGuard gu -> - VGuard gu - PModRef mn ifs -> VModRef mn ifs - -checkPactValueType :: Type Void -> PactValue -> Bool -checkPactValueType ty = \case - PLiteral lit -> typeOfLit lit == ty - PList vec -> case ty of - TyList t -> V.null vec || all (checkPactValueType t) vec - _ -> False - PGuard _ -> ty == TyGuard - PModRef _ ifs -> case ty of - TyModRef m -> m `elem` ifs - _ -> False - -makeLenses ''EvalEnv -makeLenses ''EvalState -makeLenses ''CapState -makeLenses ''CapToken -makeLenses ''CapSlot -makeLenses ''ManagedCap - -instance (MonadIO m) => MonadEvalEnv b i (EvalT b i m) where - cekReadEnv = EvalT $ view emRuntimeEnv - cekLogGas msg g = do - r <- EvalT $ view emGasLog - liftIO $ modifyIORef' r (fmap ((msg, g):)) - cekChargeGas g = do - r <- EvalT $ view emGas - liftIO (modifyIORef' r (<> g)) - -instance Monad m => MonadEvalState b i (EvalT b i m) where - setCekState l s = EvalT $ l .= s - modifyCEKState l f = EvalT (l %= f) - useCekState l = EvalT (use l) - usesCekState l f = EvalT (uses l f) diff --git a/typed-core/Pact/Core/Untyped/Eval/Runtime/CoreBuiltin.hs b/typed-core/Pact/Core/Untyped/Eval/Runtime/CoreBuiltin.hs deleted file mode 100644 index 0aed8ea37..000000000 --- a/typed-core/Pact/Core/Untyped/Eval/Runtime/CoreBuiltin.hs +++ /dev/null @@ -1,1180 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ConstraintKinds #-} - --- | --- Module : Pact.Core.IR.Typecheck --- Copyright : (C) 2022 Kadena --- License : BSD-style (see the file LICENSE) --- Maintainer : Jose Cardona --- --- CEK Evaluator for untyped core using our RawBuiltins (aka untyped, no typechecking) --- - -module Pact.Core.Untyped.Eval.Runtime.CoreBuiltin - ( coreBuiltinRuntime - , coreBuiltinLiftedRuntime ) where - -import Control.Monad(when) - -import Data.Bits -import Data.Decimal(roundTo', Decimal) -import Data.Text(Text) -import Data.Vector(Vector) -import qualified Data.Vector as V --- import qualified Data.Primitive.Array as Array -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -import Pact.Core.Builtin -import Pact.Core.Literal -import Pact.Core.Errors -import Pact.Core.Hash - -import Pact.Core.Untyped.Eval.Runtime -import Pact.Core.Untyped.Eval.CEK - --- | Run our CEK interpreter --- for only our core builtins --- monomorphized version --- runCoreCEK - -- :: EvalEnv CoreBuiltin i - -- ^ Runtime environment - -- -> EvalTerm CoreBuiltin i - -- ^ Term to evaluate --- -> IO (CEKValue CoreBuiltin i) --- runCoreCEK = runCEK ----------------------------------------------------------------------- --- Our builtin definitions start here ----------------------------------------------------------------------- - --- -- Todo: runtime error -unaryIntFn :: (BuiltinArity b, MonadEval b i m) => (Integer -> Integer) -> b -> NativeFn b i m -unaryIntFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> returnCEKValue cont handler (VLiteral (LInteger (op i))) - _ -> failInvariant "unary int function" -{-# INLINE unaryIntFn #-} - -unaryDecFn :: (BuiltinArity b, MonadEval b i m) => (Decimal -> Decimal) -> b -> NativeFn b i m -unaryDecFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i)] -> returnCEKValue cont handler (VLiteral (LDecimal (op i))) - _ -> failInvariant "unary decimal function" -{-# INLINE unaryDecFn #-} - -binaryIntFn - :: (BuiltinArity b, MonadEval b i m) - => (Integer -> Integer -> Integer) - -> b - -> NativeFn b i m -binaryIntFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (op i i'))) - _ -> failInvariant "binary int function" -{-# INLINE binaryIntFn #-} - -binaryDecFn :: (BuiltinArity b, MonadEval b i m) => (Decimal -> Decimal -> Decimal) -> b -> NativeFn b i m -binaryDecFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (op i i'))) - _ -> failInvariant "binary decimal function" -{-# INLINE binaryDecFn #-} - -binaryBoolFn :: (BuiltinArity b, MonadEval b i m) => (Bool -> Bool -> Bool) -> b -> NativeFn b i m -binaryBoolFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool l), VLiteral (LBool r)] -> returnCEKValue cont handler (VLiteral (LBool (op l r))) - _ -> failInvariant "binary bool function" -{-# INLINE binaryBoolFn #-} - -compareIntFn :: (BuiltinArity b, MonadEval b i m) => (Integer -> Integer -> Bool) -> b -> NativeFn b i m -compareIntFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (op i i'))) - _ -> failInvariant "int cmp function" -{-# INLINE compareIntFn #-} - -compareDecFn :: (BuiltinArity b, MonadEval b i m) => (Decimal -> Decimal -> Bool) -> b -> NativeFn b i m -compareDecFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (op i i'))) - _ -> failInvariant "dec cmp function" -{-# INLINE compareDecFn #-} - -compareStrFn :: (BuiltinArity b, MonadEval b i m) => (Text -> Text -> Bool) -> b -> NativeFn b i m -compareStrFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (op i i'))) - _ -> failInvariant "str cmp function" -{-# INLINE compareStrFn #-} - -roundingFn :: (BuiltinArity b, MonadEval b i m) => (Rational -> Integer) -> b -> NativeFn b i m -roundingFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i)] -> returnCEKValue cont handler (VLiteral (LInteger (truncate (roundTo' op 0 i)))) - _ -> failInvariant "rounding function" -{-# INLINE roundingFn #-} - ---------------------------------- --- integer ops ------------------------------- -addInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -addInt = binaryIntFn (+) - -subInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -subInt = binaryIntFn (-) - -mulInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -mulInt = binaryIntFn (*) - -powInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -powInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> do - when (i' < 0) $ throwExecutionError' (ArithmeticException "negative exponent in integer power") - returnCEKValue cont handler (VLiteral (LInteger (i ^ i'))) - _ -> failInvariant "binary int function" - -logBaseInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -logBaseInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger base), VLiteral (LInteger n)] -> do - when (base < 0 || n <= 0) $ throwExecutionError' (ArithmeticException "Illegal log base") - let base' = fromIntegral base :: Double - n' = fromIntegral n - out = round (logBase base' n') - returnCEKValue cont handler (VLiteral (LInteger out)) - -- if i' == 0 then throwExecutionError' (ArithmeticException "div by zero") - -- else returnCEKValue cont handler (VLiteral (LInteger (div i i'))) - _ -> failInvariant "binary int function" - -divInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -divInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> - if i' == 0 then throwExecutionError' (ArithmeticException "div by zero") - else returnCEKValue cont handler (VLiteral (LInteger (div i i'))) - _ -> failInvariant "binary int function" - -negateInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -negateInt = unaryIntFn negate - -modInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -modInt = binaryIntFn mod - -eqInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqInt = compareIntFn (==) - -neqInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqInt = compareIntFn (/=) - -gtInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -gtInt = compareIntFn (>) - -ltInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -ltInt = compareIntFn (<) - -geqInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -geqInt = compareIntFn (>=) - -leqInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -leqInt = compareIntFn (<=) - -bitAndInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitAndInt = binaryIntFn (.&.) - -bitOrInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitOrInt = binaryIntFn (.|.) - -bitComplementInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitComplementInt = unaryIntFn complement - -bitXorInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitXorInt = binaryIntFn xor - -bitShiftInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitShiftInt = binaryIntFn (\i s -> shift i (fromIntegral s)) - -absInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -absInt = unaryIntFn abs - -expInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -expInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> do - let result = exp (fromIntegral i) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "expInt" - -lnInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -lnInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> do - let result = log (fromIntegral i) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "lnInt" - -sqrtInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -sqrtInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> do - when (i < 0) $ throwExecutionError' (ArithmeticException "Square root must be non-negative") - let result = sqrt (fromIntegral i) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "sqrtInt" - -showInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -showInt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> - returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) - _ -> failInvariant "showInt" - --- ------------------------- --- double ops --- ------------------------- - -addDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -addDec = binaryDecFn (+) - -subDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -subDec = binaryDecFn (-) - -mulDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -mulDec = binaryDecFn (*) - -guardNanOrInf :: MonadEval b i m => Double -> m () -guardNanOrInf a = - when (isNaN a || isInfinite a) $ throwExecutionError' (FloatingPointError "Floating operation resulted in Infinity or NaN") - -powDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -powDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal a), VLiteral (LDecimal b)] -> do - let result = dec2F a ** dec2F b - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "binary decimal function" - -divDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -divDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> - if i' == 0 then throwExecutionError' (ArithmeticException "div by zero, decimal") - else returnCEKValue cont handler (VLiteral (LDecimal (i / i'))) - _ -> failInvariant "binary decimal function" - -negateDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -negateDec = unaryDecFn negate - -absDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -absDec = unaryDecFn abs - -eqDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqDec = compareDecFn (==) - -neqDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqDec = compareDecFn (/=) - -gtDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -gtDec = compareDecFn (>) - -geqDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -geqDec = compareDecFn (>=) - -ltDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -ltDec = compareDecFn (<) - -leqDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -leqDec = compareDecFn (<=) - -showDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -showDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i)] -> - returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) - _ -> failInvariant "showDec" - -dec2F :: Decimal -> Double -dec2F = fromRational . toRational - -f2Dec :: Double -> Decimal -f2Dec = fromRational . toRational - -roundDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -roundDec = roundingFn round -floorDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -floorDec = roundingFn floor -ceilingDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -ceilingDec = roundingFn ceiling - --- Todo: exp and ln, sqrt have similar failure conditions -expDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -expDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal e)] -> do - let result = exp (dec2F e) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "binary decimal function" - -- unaryDecFn (f2Dec . exp . dec2F) - -lnDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -lnDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal e)] -> do - let result = log (dec2F e) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "binary decimal function" - -logBaseDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -logBaseDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal base), VLiteral (LDecimal arg)] -> do - when (base < 0 || arg <= 0) $ throwExecutionError' (ArithmeticException "Invalid base or argument in log") - let result = logBase (dec2F base) (dec2F arg) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "binary decimal function" - - -sqrtDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -sqrtDec = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal e)] -> do - when (e < 0) $ throwExecutionError' (ArithmeticException "Square root must be non-negative") - let result = sqrt (dec2F e) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "binary decimal function" - - ---------------------------- --- bool ops ---------------------------- --- andBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- andBool = binaryBoolFn (&&) - --- orBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- orBool = binaryBoolFn (||) - -notBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -notBool = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool i)] -> returnCEKValue cont handler (VLiteral (LBool (not i))) - _ -> failInvariant "notBool" - -eqBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqBool = binaryBoolFn (==) - -neqBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqBool = binaryBoolFn (/=) - -showBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -showBool = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool i)] -> do - let out = if i then "true" else "false" - returnCEKValue cont handler (VLiteral (LString out)) - _ -> failInvariant "showBool" - ---------------------------- --- string ops ---------------------------- -eqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqStr = compareStrFn (==) - -neqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqStr = compareStrFn (/=) - -gtStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -gtStr = compareStrFn (>) - -geqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -geqStr = compareStrFn (>=) - -ltStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -ltStr = compareStrFn (<) - -leqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -leqStr = compareStrFn (<=) - -addStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -addStr = mkBuiltinFn \cont handler -> \case - [VLiteral (LString i), VLiteral (LString i')] -> - returnCEKValue cont handler (VLiteral (LString (i <> i'))) - _ -> failInvariant "addStr" - -takeStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -takeStr = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LString t)] - | i >= 0 -> do - let clamp = min (fromIntegral i) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.take clamp t))) - | otherwise -> do - let clamp = min (abs (T.length t + fromIntegral i)) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.drop clamp t))) - _ -> failInvariant "takeStr" - -dropStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -dropStr = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LString t)] - | i >= 0 -> do - let clamp = min (fromIntegral i) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.drop clamp t))) - | otherwise -> do - let clamp = min (abs (T.length t + fromIntegral i)) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.take clamp t))) - _ -> failInvariant "dropStr" - -lengthStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -lengthStr = mkBuiltinFn \cont handler -> \case - [VLiteral (LString t)] -> do - returnCEKValue cont handler (VLiteral (LInteger (fromIntegral (T.length t)))) - _ -> failInvariant "lengthStr" - -reverseStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -reverseStr = mkBuiltinFn \cont handler -> \case - [VLiteral (LString t)] -> do - returnCEKValue cont handler (VLiteral (LString (T.reverse t))) - _ -> failInvariant "reverseStr" - -showStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -showStr = mkBuiltinFn \cont handler -> \case - [VLiteral (LString t)] -> do - let out = "\"" <> t <> "\"" - returnCEKValue cont handler (VLiteral (LString out)) - _ -> failInvariant "showStr" - -concatStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -concatStr = mkBuiltinFn \cont handler -> \case - [VList li] -> do - li' <- traverse asString li - returnCEKValue cont handler (VLiteral (LString (T.concat (V.toList li')))) - _ -> failInvariant "concatStr" - -strToList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -strToList = mkBuiltinFn \cont handler -> \case - [VLiteral (LString s)] -> do - let v = (VList (V.fromList ((VLiteral . LString . T.singleton <$> T.unpack s)))) - returnCEKValue cont handler v - _ -> failInvariant "concatStr" - ---------------------------- --- Unit ops ---------------------------- - -eqUnit :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqUnit = mkBuiltinFn \cont handler -> \case - [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool True)) - _ -> failInvariant "eqUnit" - -neqUnit :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqUnit = mkBuiltinFn \cont handler -> \case - [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool False)) - _ -> failInvariant "neqUnit" - -showUnit :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -showUnit = mkBuiltinFn \cont handler -> \case - [VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LString "()")) - _ -> failInvariant "showUnit" - ---------------------------- --- Object ops ---------------------------- - --- eqObj :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- eqObj = mkBuiltinFn \case --- [l@VObject{}, r@VObject{}] -> pure (VLiteral (LBool (unsafeEqCEKValue l r))) --- _ -> failInvariant "eqObj" - --- neqObj :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- neqObj = mkBuiltinFn \case --- [l@VObject{}, r@VObject{}] -> pure (VLiteral (LBool (unsafeNeqCEKValue l r))) --- _ -> failInvariant "neqObj" - - ------------------------------- ---- conversions + unsafe ops ------------------------------- --- asBool :: MonadEval b i m => CEKValue b i m -> m Bool --- asBool (VLiteral (LBool b)) = pure b --- asBool _ = failInvariant "asBool" - -asString :: MonadEval b i m => CEKValue b i m -> m Text -asString (VLiteral (LString b)) = pure b -asString _ = failInvariant "asString" - -asList :: MonadEval b i m => CEKValue b i m -> m (Vector (CEKValue b i m)) -asList (VList l) = pure l -asList _ = failInvariant "asList" - --- unsafeEqLiteral :: Literal -> Literal -> Bool --- unsafeEqLiteral (LString i) (LString i') = i == i' --- unsafeEqLiteral (LInteger i) (LInteger i') = i == i' --- unsafeEqLiteral (LDecimal i) (LDecimal i') = i == i' --- unsafeEqLiteral LUnit LUnit = True --- unsafeEqLiteral (LBool i) (LBool i') = i == i' --- unsafeEqLiteral (LTime i) (LTime i') = i == i' --- unsafeEqLiteral _ _ = --- throw (InvariantFailure "invariant failed in literal EQ") - --- unsafeNeqLiteral :: Literal -> Literal -> Bool --- unsafeNeqLiteral a b = not (unsafeEqLiteral a b) - --- unsafeEqCEKValue :: CEKValue b i m -> CEKValue b i m -> Bool --- unsafeEqCEKValue (VLiteral l) (VLiteral l') = unsafeEqLiteral l l' --- unsafeEqCEKValue (VObject o) (VObject o') = and (Map.intersectionWith unsafeEqCEKValue o o') --- unsafeEqCEKValue (VList l) (VList l') = V.length l == V.length l' && and (V.zipWith unsafeEqCEKValue l l') --- unsafeEqCEKValue _ _ = throw (InvariantFailure "invariant failed in value Eq") - --- unsafeNeqCEKValue :: CEKValue b i m -> CEKValue b i m -> Bool --- unsafeNeqCEKValue a b = not (unsafeEqCEKValue a b) - ---------------------------- --- list ops ---------------------------- -eqList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqList = mkBuiltinFn \cont handler -> \case - [eqClo, VList l, VList r] -> - if V.length l /= V.length r then - returnCEKValue cont handler (VLiteral (LBool False)) - else zip' (V.toList l) (V.toList r) [] - where - zip' [] _ acc = returnCEKValue cont handler (VLiteral (LBool (and acc))) - zip' _ [] acc = returnCEKValue cont handler (VLiteral (LBool (and acc))) - zip' (x:xs) (y:ys) acc = unsafeApplyTwo eqClo x y >>= \case - EvalValue (VLiteral (LBool b)) -> zip' xs ys (b:acc) - v@VError{} -> returnCEK cont handler v - _ -> failInvariant "applying closure in list eq yielded incorrect type" - _ -> failInvariant "eqList" - -neqList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqList = mkBuiltinFn \cont handler -> \case - [neqClo, VList l, VList r] -> - if V.length l /= V.length r then - returnCEKValue cont handler (VLiteral (LBool True)) - else zip' (V.toList l) (V.toList r) [] - where - zip' (x:xs) (y:ys) acc = unsafeApplyTwo neqClo x y >>= \case - EvalValue (VLiteral (LBool b)) -> zip' xs ys (b:acc) - v@VError{} -> returnCEK cont handler v - _ -> failInvariant "applying closure in list eq yielded incorrect type" - zip' _ _ acc = returnCEKValue cont handler (VLiteral (LBool (or acc))) - _ -> failInvariant "neqList" - -zipList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -zipList = mkBuiltinFn \cont handler -> \case - [clo, VList l, VList r] -> zip' (V.toList l) (V.toList r) [] - where - zip' (x:xs) (y:ys) acc = unsafeApplyTwo clo x y >>= \case - EvalValue v -> zip' xs ys (v:acc) - v@VError{} -> returnCEK cont handler v - zip' _ _ acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) - _ -> failInvariant "zipList" - -addList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -addList = mkBuiltinFn \cont handler -> \case - [VList l, VList r] -> returnCEKValue cont handler (VList (l <> r)) - _ -> failInvariant "addList" - -pcShowList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -pcShowList = mkBuiltinFn \cont handler -> \case - [showFn, VList l1] -> show' (V.toList l1) [] - where - show' (x:xs) acc = unsafeApplyOne showFn x >>= \case - EvalValue (VLiteral (LString b)) -> show' xs (b:acc) - v@VError{} -> returnCEK cont handler v - _ -> failInvariant "applying closure in list eq yielded incorrect type" - show' _ acc = do - let out = "[" <> T.intercalate ", " (reverse acc) <> "]" - returnCEKValue cont handler (VLiteral (LString out)) - _ -> failInvariant "showList" - -coreMap :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreMap = mkBuiltinFn \cont handler -> \case - [fn, VList li] -> map' (V.toList li) [] - where - map' (x:xs) acc = unsafeApplyOne fn x >>= \case - EvalValue cv -> map' xs (cv:acc) - v -> returnCEK cont handler v - map' _ acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) - _ -> failInvariant "map" - -coreFilter :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreFilter = mkBuiltinFn \cont handler -> \case - [fn, VList li] -> filter' (V.toList li) [] - where - filter' (x:xs) acc = unsafeApplyOne fn x >>= \case - EvalValue (VLiteral (LBool b)) -> - if b then filter' xs (x:acc) else filter' xs acc - v@VError{} -> - returnCEK cont handler v - _ -> failInvariant "filter" - filter' [] acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) - _ -> failInvariant "filter" - -coreFold :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreFold = mkBuiltinFn \cont handler -> \case - [fn, initElem, VList li] -> - fold' initElem (V.toList li) - where - fold' e (x:xs) = unsafeApplyTwo fn e x >>= \case - EvalValue v -> fold' v xs - v -> returnCEK cont handler v - fold' e [] = returnCEKValue cont handler e - _ -> failInvariant "fold" - -lengthList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -lengthList = mkBuiltinFn \cont handler -> \case - [VList li] -> returnCEKValue cont handler (VLiteral (LInteger (fromIntegral (V.length li)))) - _ -> failInvariant "lengthList" - -takeList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -takeList = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VList li] - | i >= 0 -> do - let clamp = fromIntegral $ min i (fromIntegral (V.length li)) - returnCEKValue cont handler (VList (V.take clamp li)) - | otherwise -> do - let clamp = fromIntegral $ max (fromIntegral (V.length li) + i) 0 - returnCEKValue cont handler (VList (V.drop clamp li)) - _ -> failInvariant "takeList" - -dropList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -dropList = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VList li] - | i >= 0 -> do - let clamp = fromIntegral $ min i (fromIntegral (V.length li)) - returnCEKValue cont handler (VList (V.drop clamp li)) - | otherwise -> do - let clamp = fromIntegral $ max (fromIntegral (V.length li) + i) 0 - returnCEKValue cont handler (VList (V.take clamp li)) - _ -> failInvariant "dropList" - -reverseList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -reverseList = mkBuiltinFn \cont handler -> \case - [VList li] -> - returnCEKValue cont handler (VList (V.reverse li)) - _ -> failInvariant "takeList" - -coreEnumerate :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreEnumerate = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger from), VLiteral (LInteger to)] -> do - v <- createEnumerateList from to (if from > to then -1 else 1) - returnCEKValue cont handler (VList (VLiteral . LInteger <$> v)) - _ -> failInvariant "enumerate" - -createEnumerateList - :: (MonadEval b i m) - => Integer - -- ^ from - -> Integer - -- ^ to - -> Integer - -- ^ Step - -> m (Vector Integer) -createEnumerateList from to inc - | from == to = pure (V.singleton from) - | inc == 0 = pure mempty - | from < to, from + inc < from = - throwExecutionError' (EnumerationError "enumerate: increment diverges below from interval bounds.") - | from > to, from + inc > from = - throwExecutionError' (EnumerationError "enumerate: increment diverges above from interval bounds.") - | otherwise = let - step = succ (abs (from - to) `div` abs inc) - in pure $ V.enumFromStepN from inc (fromIntegral step) - -coreEnumerateStepN :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreEnumerateStepN = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger from), VLiteral (LInteger to), VLiteral (LInteger inc)] -> do - v <- createEnumerateList from to inc - returnCEKValue cont handler (VList (VLiteral . LInteger <$> v)) - _ -> failInvariant "enumerate-step" - -concatList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -concatList = mkBuiltinFn \cont handler -> \case - [VList li] -> do - li' <- traverse asList li - returnCEKValue cont handler (VList (V.concat (V.toList li'))) - _ -> failInvariant "takeList" - -makeList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -makeList = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), v] -> do - returnCEKValue cont handler (VList (V.fromList (replicate (fromIntegral i) v))) - _ -> failInvariant "makeList" - -listAccess :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -listAccess = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VList vec] -> - case vec V.!? fromIntegral i of - Just v -> returnCEKValue cont handler v - _ -> throwExecutionError' (ArrayOutOfBoundsException (V.length vec) (fromIntegral i)) - _ -> failInvariant "list-access" - ------------------------------------ --- try-related ops ------------------------------------ - -coreEnforce :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreEnforce = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool b), VLiteral (LString s)] -> - if b then returnCEKValue cont handler (VLiteral LUnit) - else returnCEK cont handler (VError s) - _ -> failInvariant "enforce" - --- coreEnforceOne :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreEnforceOne = mkBuiltinFn \case --- [VList v, VLiteral (LString msg)] -> --- enforceFail msg (V.toList v) --- _ -> failInvariant "coreEnforceOne" --- where --- handler msg rest = \case --- EnforceException _ -> enforceFail msg rest --- e -> throwM e --- enforceClo _ [] = pure (VLiteral LUnit) --- enforceClo msg (x:xs) = catch (unsafeApplyOne x (VLiteral LUnit)) (handler msg xs) --- enforceFail msg [] = throwM (EnforceException msg) --- enforceFail msg as = enforceClo msg as ------------------------------------ --- Guards and reads ------------------------------------ - --- readError :: Text -> Text -> Text --- readError field expected = --- "invalid value at field " <> field <> " expected: " <> expected - --- coreReadInteger :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadInteger = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- PLiteral l@LInteger{} -> pure (VLiteral l) --- _ -> throwM (ReadException (readError s "integer")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-integer" - --- coreReadString :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadString = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv-> case pv of --- PLiteral l@LString{} -> pure (VLiteral l) --- _ -> throwM (ReadException (readError s "string")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-string" - --- coreReadDecimal :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadDecimal = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- PLiteral l@LDecimal{} -> pure (VLiteral l) --- _ -> throwM (ReadException (readError s "decimal")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-decimal" - --- coreReadObject :: CEKRuntime b i => Row Void -> CEKValue b i m -> EvalT b i (CEKValue b i m) --- coreReadObject ty = \case --- VLiteral (LString s) -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- t@PObject{} | checkPactValueType (TyRow ty) t -> pure (fromPactValue t) --- _ -> throwM (ReadException (readError s "object")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "readObject" - --- coreReadKeyset :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadKeyset = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- PObject m -> case lookupKs m of --- Just ks -> pure (VGuard (GKeyset ks)) --- _ -> throwM (ReadException "Invalid keyset format") --- _ -> throwM (ReadException (readError s "decimal")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-keyset" --- where --- -- Todo: public key parsing. --- -- This is most certainly wrong, it needs more checks. --- lookupKs m = do --- ks <- Map.lookup (Field "keys") m >>= \case --- PList v -> do --- o <- traverse (preview (_PLiteral . _LString)) v --- guard (all (T.all isHexDigit) o) --- pure $ Set.fromList $ V.toList (PublicKey . T.encodeUtf8 <$> o) --- _ -> Nothing --- kspred <- case Map.lookup (Field "pred") m of --- (Just (PLiteral LString{})) -> pure KeysAll --- Just _ -> Nothing --- Nothing -> pure KeysAll --- pure (KeySet ks kspred) - - --- coreKeysetRefGuard :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreKeysetRefGuard = mkBuiltinFn \case --- [VLiteral (LString s)] -> pure (VGuard (GKeySetRef (KeySetName s))) --- _ -> failInvariant "keyset-ref-guard" - --- coreEnforceGuard :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreEnforceGuard = mkBuiltinFn \case --- [VGuard v] -> case v of --- GKeyset ks -> enforceKeySet ks --- GKeySetRef ksr -> enforceKeySetRef ksr --- GUserGuard ug -> enforceUserGuard ug --- _ -> failInvariant "enforceGuard" - --- enforceKeySet :: CEKRuntime b i => KeySet name -> EvalT b i (CEKValue b i m) --- enforceKeySet (KeySet keys p) = do --- let sigs = _ckeSigs ?cekRuntimeEnv --- matched = Set.size $ Set.filter (`Set.member` keys) sigs --- count = Set.size keys --- case p of --- KeysAll | matched == count -> pure (VLiteral LUnit) --- Keys2 | matched >= 2 -> pure (VLiteral LUnit) --- KeysAny | matched > 0 -> pure (VLiteral LUnit) --- _ -> throwM (EnforceException "cannot match keyset predicate") - --- enforceKeySetRef :: CEKRuntime b i => KeySetName -> EvalT b i (CEKValue b i m) --- enforceKeySetRef ksr = do --- let pactDb = _ckePactDb ?cekRuntimeEnv --- liftIO (_readKeyset pactDb ksr) >>= \case --- Just ks -> enforceKeySet ks --- Nothing -> throwM (EnforceException "no such keyset") - --- enforceUserGuard :: CEKRuntime b i => CEKValue b i m -> EvalT b i (CEKValue b i m) --- enforceUserGuard = \case --- v@VClosure{} -> unsafeApplyOne v (VLiteral LUnit) >>= \case --- VLiteral LUnit -> pure (VLiteral LUnit) --- _ -> failInvariant "expected a function returning unit" --- _ -> failInvariant "invalid type for user closure" - --- createUserGuard :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- createUserGuard = mkBuiltinFn \case --- [v@VClosure{}] -> pure (VGuard (GUserGuard v)) --- _ -> failInvariant "create-user-guard" - ------------------------------------ --- Module references ------------------------------------ -eqModRef :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -eqModRef = mkBuiltinFn \cont handler -> \case - [VModRef m1 _, VModRef m2 _] -> - returnCEKValue cont handler $ VBool (m1 == m2) - vals -> failInvariant $ "base64-encode" <> T.pack (show vals) - -neqModRef :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -neqModRef = mkBuiltinFn \cont handler -> \case - [VModRef m1 _, VModRef m2 _] -> - returnCEKValue cont handler $ VBool (m1 /= m2) - _ -> failInvariant "base64-encode" - - ------------------------------------ --- Other Core forms ------------------------------------ - --- coreIf :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreIf = mkBuiltinFn \case --- [VLiteral (LBool b), VClosure tbody tenv, VClosure fbody fenv] -> --- if b then eval tenv tbody else eval fenv fbody --- _ -> failInvariant "if" - -coreB64Encode :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreB64Encode = mkBuiltinFn \cont handler -> \case - [VLiteral (LString l)] -> - returnCEKValue cont handler $ VLiteral $ LString $ toB64UrlUnpaddedText $ T.encodeUtf8 l - _ -> failInvariant "base64-encode" - - -coreB64Decode :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreB64Decode = mkBuiltinFn \cont handler -> \case - [VLiteral (LString s)] -> case fromB64UrlUnpaddedText $ T.encodeUtf8 s of - Left{} -> throwExecutionError' (DecodeError "invalid b64 encoding") - Right txt -> returnCEKValue cont handler (VLiteral (LString txt)) - _ -> failInvariant "base64-encode" - - - ------------------------------------ --- Core definitions ------------------------------------ - -unimplemented :: NativeFn b i m -unimplemented = error "unimplemented" - -coreBuiltinRuntime :: MonadEval CoreBuiltin i m => CoreBuiltin -> NativeFn CoreBuiltin i m -coreBuiltinRuntime = \case - -- Int Add + num ops - AddInt -> addInt AddInt - SubInt -> subInt SubInt - DivInt -> divInt DivInt - MulInt -> mulInt MulInt - NegateInt -> negateInt NegateInt - AbsInt -> absInt AbsInt - PowInt -> powInt PowInt - -- Int fractional - ExpInt -> expInt ExpInt - LnInt -> lnInt LnInt - SqrtInt -> sqrtInt SqrtInt - LogBaseInt -> logBaseInt LogBaseInt - -- Geenral int ops - ModInt -> modInt ModInt - BitAndInt -> bitAndInt BitAndInt - BitOrInt -> bitOrInt BitOrInt - BitXorInt -> bitXorInt BitXorInt - BitShiftInt -> bitShiftInt BitShiftInt - BitComplementInt -> bitComplementInt BitComplementInt - -- Int Equality + Ord - EqInt -> eqInt EqInt - NeqInt -> neqInt NeqInt - GTInt -> gtInt GTInt - GEQInt -> geqInt GEQInt - LTInt -> ltInt LTInt - LEQInt -> leqInt LEQInt - -- IntShow inst - ShowInt -> showInt ShowInt - -- If - -- IfElse -> coreIf IfElse - -- Decimal ops - -- Add + Num - AddDec -> addDec AddDec - SubDec -> subDec SubDec - DivDec -> divDec DivDec - MulDec -> mulDec MulDec - PowDec -> powDec PowDec - NegateDec -> negateDec NegateDec - AbsDec -> absDec AbsDec - -- Decimal rounding ops - RoundDec -> roundDec RoundDec - CeilingDec -> ceilingDec CeilingDec - FloorDec -> floorDec FloorDec - -- Decimal fractional - ExpDec -> expDec ExpDec - LnDec -> lnDec LnDec - LogBaseDec -> logBaseDec LogBaseDec - SqrtDec -> sqrtDec SqrtDec - -- Decimal show - ShowDec -> showDec ShowDec - -- Decimal Equality + Ord - EqDec -> eqDec EqDec - NeqDec -> neqDec NeqDec - GTDec -> gtDec GTDec - GEQDec -> geqDec GEQDec - LTDec -> ltDec LTDec - LEQDec -> leqDec LEQDec - -- Bool Ops - -- AndBool -> andBool AndBool - -- OrBool -> orBool OrBool - NotBool -> notBool NotBool - -- Bool Equality - EqBool -> eqBool EqBool - NeqBool -> neqBool NeqBool - ShowBool -> showBool ShowBool - -- String Equality + Ord - EqStr -> eqStr EqStr - NeqStr -> neqStr NeqStr - GTStr -> gtStr GTStr - GEQStr -> geqStr GEQStr - LTStr -> ltStr LTStr - LEQStr -> leqStr LEQStr - -- String Ops - AddStr -> addStr AddStr - -- String listlike - ConcatStr -> concatStr ConcatStr - DropStr -> dropStr DropStr - TakeStr -> takeStr TakeStr - LengthStr -> lengthStr LengthStr - ReverseStr -> reverseStr ReverseStr - -- String show - ShowStr -> showStr ShowStr - -- Object equality - -- EqObj -> eqObj EqObj - -- NeqObj -> neqObj NeqObj - -- List Equality + Ord - EqList -> eqList EqList - NeqList -> neqList NeqList - GTList -> unimplemented - GEQList -> unimplemented - LTList -> unimplemented - LEQList -> unimplemented - -- List Show - ShowList -> pcShowList ShowList - -- ListAdd - AddList -> addList AddList - -- List ListlLike - TakeList -> takeList TakeList - DropList -> dropList DropList - LengthList -> lengthList LengthList - ConcatList -> concatList ConcatList - ReverseList -> reverseList ReverseList - -- misc list ops - FilterList -> coreFilter FilterList - DistinctList -> unimplemented - ZipList -> zipList ZipList - MapList -> coreMap MapList - FoldList -> coreFold FoldList - -- Unit ops - EqUnit -> eqUnit EqUnit - NeqUnit -> neqUnit NeqUnit - ShowUnit -> showUnit ShowUnit - EqModRef -> eqModRef EqModRef - NeqModRef -> neqModRef NeqModRef - Enforce -> coreEnforce Enforce - EnforceOne -> unimplemented - -- coreEnforceOne EnforceOne - Enumerate -> coreEnumerate Enumerate - EnumerateStepN -> coreEnumerateStepN EnumerateStepN - ReadInteger -> unimplemented - ReadDecimal -> unimplemented - ReadString -> unimplemented - -- ReadInteger -> coreReadInteger ReadInteger - -- ReadDecimal -> coreReadDecimal ReadDecimal - -- ReadString -> coreReadString ReadString - -- ReadKeyset -> coreReadKeyset ReadKeyset - -- EnforceGuard -> coreEnforceGuard EnforceGuard - -- KeysetRefGuard -> coreKeysetRefGuard KeysetRefGuard - ReadKeyset -> unimplemented - EnforceGuard -> unimplemented - KeysetRefGuard -> unimplemented - -- CreateUserGuard -> createUserGuard CreateUserGuard - ListAccess -> listAccess ListAccess - MakeList -> makeList MakeList - B64Encode -> coreB64Encode B64Encode - B64Decode -> coreB64Decode B64Decode - StrToList -> strToList StrToList - -coreBuiltinLiftedRuntime - :: (MonadEval b i m, BuiltinArity b) - => (CoreBuiltin -> b) - -> CoreBuiltin - -> NativeFn b i m -coreBuiltinLiftedRuntime f = \case - -- Int Add + num ops - AddInt -> addInt (f AddInt) - SubInt -> subInt (f SubInt) - DivInt -> divInt (f DivInt) - MulInt -> mulInt (f MulInt) - PowInt -> powInt (f PowInt) - NegateInt -> negateInt (f NegateInt) - AbsInt -> absInt (f AbsInt) - -- Int fractional - ExpInt -> expInt (f ExpInt) - LnInt -> lnInt (f LnInt) - SqrtInt -> sqrtInt (f SqrtInt) - LogBaseInt -> logBaseInt (f LogBaseInt) - -- Geenral int ops - ModInt -> modInt (f ModInt) - BitAndInt -> bitAndInt (f BitAndInt) - BitOrInt -> bitOrInt (f BitOrInt) - BitXorInt -> bitXorInt (f BitXorInt) - BitShiftInt -> bitShiftInt (f BitShiftInt) - BitComplementInt -> bitComplementInt (f BitComplementInt) - -- Int Equality + Ord - EqInt -> eqInt (f EqInt) - NeqInt -> neqInt (f NeqInt) - GTInt -> gtInt (f GTInt) - GEQInt -> geqInt (f GEQInt) - LTInt -> ltInt (f LTInt) - LEQInt -> leqInt (f LEQInt) - -- IntShow inst - ShowInt -> showInt (f ShowInt) - -- If - -- IfElse -> coreIf (f IfElse) - -- Decimal ops - -- Add + Num - AddDec -> addDec (f AddDec) - SubDec -> subDec (f SubDec) - DivDec -> divDec (f DivDec) - MulDec -> mulDec (f MulDec) - PowDec -> powDec (f PowDec) - NegateDec -> negateDec (f NegateDec) - AbsDec -> absDec (f AbsDec) - -- Decimal rounding ops - RoundDec -> roundDec (f RoundDec) - CeilingDec -> ceilingDec (f CeilingDec) - FloorDec -> floorDec (f FloorDec) - -- Decimal fractional - ExpDec -> expDec (f ExpDec) - LnDec -> lnDec (f LnDec) - LogBaseDec -> logBaseDec (f LogBaseDec) - SqrtDec -> sqrtDec (f SqrtDec) - -- Decimal show - ShowDec -> showDec (f ShowDec) - -- Decimal Equality + Ord - EqDec -> eqDec (f EqDec) - NeqDec -> neqDec (f NeqDec) - GTDec -> gtDec (f GTDec) - GEQDec -> geqDec (f GEQDec) - LTDec -> ltDec (f LTDec) - LEQDec -> leqDec (f LEQDec) - -- Bool Ops - -- AndBool -> andBool (f AndBool) - -- OrBool -> orBool (f OrBool) - NotBool -> notBool (f NotBool) - -- Bool Equality - EqBool -> eqBool (f EqBool) - NeqBool -> neqBool (f NeqBool) - ShowBool -> showBool (f ShowBool) - -- String Equality + Ord - EqStr -> eqStr (f EqStr) - NeqStr -> neqStr (f NeqStr) - GTStr -> gtStr (f GTStr) - GEQStr -> geqStr (f GEQStr) - LTStr -> ltStr (f LTStr) - LEQStr -> leqStr (f LEQStr) - -- String Ops - AddStr -> addStr (f AddStr) - -- String listlike - ConcatStr -> concatStr (f ConcatStr) - DropStr -> dropStr (f DropStr) - TakeStr -> takeStr (f TakeStr) - LengthStr -> lengthStr (f LengthStr) - ReverseStr -> reverseStr (f ReverseStr) - -- String show - ShowStr -> showStr (f ShowStr) - -- Object equality - -- EqObj -> eqObj EqObj - -- NeqObj -> neqObj NeqObj - -- List Equality + Ord - EqList -> eqList (f EqList) - NeqList -> neqList (f NeqList) - GTList -> unimplemented - GEQList -> unimplemented - LTList -> unimplemented - LEQList -> unimplemented - -- List Show - ShowList -> pcShowList (f ShowList) - -- ListAdd - AddList -> addList (f AddList) - -- List ListlLike - TakeList -> takeList (f TakeList) - DropList -> dropList (f DropList) - LengthList -> lengthList (f LengthList) - ConcatList -> concatList (f ConcatList) - ReverseList -> reverseList (f ReverseList) - -- misc list ops - FilterList -> coreFilter (f FilterList) - DistinctList -> unimplemented - ZipList -> zipList (f ZipList) - MapList -> coreMap (f MapList) - FoldList -> coreFold (f FoldList) - -- Unit ops - EqUnit -> eqUnit (f EqUnit) - NeqUnit -> neqUnit (f NeqUnit) - ShowUnit -> showUnit (f ShowUnit) - EqModRef -> eqModRef (f EqModRef) - NeqModRef -> neqModRef (f NeqModRef) - Enforce -> coreEnforce (f Enforce) - EnforceOne -> unimplemented - -- coreEnforceOne EnforceOne - Enumerate -> coreEnumerate (f Enumerate) - EnumerateStepN -> coreEnumerateStepN (f EnumerateStepN) - ReadInteger -> unimplemented - ReadDecimal -> unimplemented - ReadString -> unimplemented - -- ReadInteger -> coreReadInteger ReadInteger - -- ReadDecimal -> coreReadDecimal ReadDecimal - -- ReadString -> coreReadString ReadString - -- ReadKeyset -> coreReadKeyset ReadKeyset - -- EnforceGuard -> coreEnforceGuard EnforceGuard - -- KeysetRefGuard -> coreKeysetRefGuard KeysetRefGuard - ReadKeyset -> unimplemented - EnforceGuard -> unimplemented - KeysetRefGuard -> unimplemented - ListAccess -> listAccess (f ListAccess) - MakeList -> makeList (f MakeList) - B64Encode -> coreB64Encode (f B64Encode) - B64Decode -> coreB64Decode (f B64Decode) - StrToList -> strToList (f StrToList) diff --git a/typed-core/Pact/Core/Untyped/Eval/Runtime/RawBuiltin.hs b/typed-core/Pact/Core/Untyped/Eval/Runtime/RawBuiltin.hs deleted file mode 100644 index 364299de6..000000000 --- a/typed-core/Pact/Core/Untyped/Eval/Runtime/RawBuiltin.hs +++ /dev/null @@ -1,1002 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ConstraintKinds #-} - --- | --- Module : Pact.Core.IR.Typecheck --- Copyright : (C) 2022 Kadena --- License : BSD-style (see the file LICENSE) --- Maintainer : Jose Cardona --- --- CEK Evaluator for untyped core using our RawBuiltins (aka untyped, no typechecking) --- - -module Pact.Core.Untyped.Eval.Runtime.RawBuiltin where - -import Control.Monad(when) - -import Data.Bits -import Data.Decimal(roundTo', Decimal) -import Data.Text(Text) -import Data.Vector(Vector) -import Data.List(intersperse) -import qualified Data.Vector as V -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -import Pact.Core.Builtin -import Pact.Core.Literal -import Pact.Core.Errors -import Pact.Core.Hash -import Pact.Core.Names -import Pact.Core.Pretty(pretty) - -import Pact.Core.Untyped.Eval.Runtime -import Pact.Core.Untyped.Eval.CEK - - ----------------------------------------------------------------------- --- Our builtin definitions start here ----------------------------------------------------------------------- - --- -- Todo: runtime error -unaryIntFn :: (BuiltinArity b, MonadEval b i m) => (Integer -> Integer) -> b -> NativeFn b i m -unaryIntFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> returnCEKValue cont handler (VLiteral (LInteger (op i))) - _ -> failInvariant "unary int function" -{-# INLINE unaryIntFn #-} - -unaryDecFn :: (BuiltinArity b, MonadEval b i m) => (Decimal -> Decimal) -> b -> NativeFn b i m -unaryDecFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i)] -> returnCEKValue cont handler (VLiteral (LDecimal (op i))) - _ -> failInvariant "unary decimal function" -{-# INLINE unaryDecFn #-} - -binaryIntFn - :: (BuiltinArity b, MonadEval b i m) - => (Integer -> Integer -> Integer) - -> b - -> NativeFn b i m -binaryIntFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (op i i'))) - _ -> failInvariant "binary int function" -{-# INLINE binaryIntFn #-} - -binaryDecFn :: (BuiltinArity b, MonadEval b i m) => (Decimal -> Decimal -> Decimal) -> b -> NativeFn b i m -binaryDecFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (op i i'))) - _ -> failInvariant "binary decimal function" -{-# INLINE binaryDecFn #-} - -binaryBoolFn :: (BuiltinArity b, MonadEval b i m) => (Bool -> Bool -> Bool) -> b -> NativeFn b i m -binaryBoolFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool l), VLiteral (LBool r)] -> returnCEKValue cont handler (VLiteral (LBool (op l r))) - _ -> failInvariant "binary bool function" -{-# INLINE binaryBoolFn #-} - -compareIntFn :: (BuiltinArity b, MonadEval b i m) => (Integer -> Integer -> Bool) -> b -> NativeFn b i m -compareIntFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (op i i'))) - _ -> failInvariant "int cmp function" -{-# INLINE compareIntFn #-} - -compareDecFn :: (BuiltinArity b, MonadEval b i m) => (Decimal -> Decimal -> Bool) -> b -> NativeFn b i m -compareDecFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (op i i'))) - _ -> failInvariant "dec cmp function" -{-# INLINE compareDecFn #-} - -compareStrFn :: (BuiltinArity b, MonadEval b i m) => (Text -> Text -> Bool) -> b -> NativeFn b i m -compareStrFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (op i i'))) - _ -> failInvariant "str cmp function" -{-# INLINE compareStrFn #-} - -roundingFn :: (BuiltinArity b, MonadEval b i m) => (Rational -> Integer) -> b -> NativeFn b i m -roundingFn op = mkBuiltinFn \cont handler -> \case - [VLiteral (LDecimal i)] -> returnCEKValue cont handler (VLiteral (LInteger (truncate (roundTo' op 0 i)))) - _ -> failInvariant "rounding function" -{-# INLINE roundingFn #-} - ---------------------------------- --- Arithmetic Ops ------------------------------- -rawAdd :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawAdd = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (i + i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (i + i'))) - [VLiteral (LString i), VLiteral (LString i')] -> - returnCEKValue cont handler (VLiteral (LString (i <> i'))) - [VList l, VList r] -> returnCEKValue cont handler (VList (l <> r)) - _ -> failInvariant "add" - -rawSub :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawSub = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (i - i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (i - i'))) - _ -> failInvariant "subtract" - -rawMul :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawMul = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (i * i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (i * i'))) - _ -> failInvariant "multiply" - -rawPow :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawPow = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> do - when (i' < 0) $ throwExecutionError' (ArithmeticException "negative exponent in integer power") - returnCEKValue cont handler (VLiteral (LInteger (i ^ i'))) - [VLiteral (LDecimal a), VLiteral (LDecimal b)] -> do - let result = dec2F a ** dec2F b - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "pow" - -rawLogBase :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawLogBase = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger base), VLiteral (LInteger n)] -> do - when (base < 0 || n <= 0) $ throwExecutionError' (ArithmeticException "Illegal log base") - let base' = fromIntegral base :: Double - n' = fromIntegral n - out = round (logBase base' n') - returnCEKValue cont handler (VLiteral (LInteger out)) - -- if i' == 0 then throwExecutionError' (ArithmeticException "div by zero") - -- else returnCEKValue cont handler (VLiteral (LInteger (div i i'))) - [VLiteral (LDecimal base), VLiteral (LDecimal arg)] -> do - when (base < 0 || arg <= 0) $ throwExecutionError' (ArithmeticException "Invalid base or argument in log") - let result = logBase (dec2F base) (dec2F arg) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "logBase" - -rawDiv :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawDiv = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> - if i' == 0 then throwExecutionError' (ArithmeticException "div by zero") - else returnCEKValue cont handler (VLiteral (LInteger (div i i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> - if i' == 0 then throwExecutionError' (ArithmeticException "div by zero, decimal") - else returnCEKValue cont handler (VLiteral (LDecimal (i / i'))) - _ -> failInvariant "div" - -rawNegate :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawNegate = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> - returnCEKValue cont handler (VLiteral (LInteger (negate i))) - [VLiteral (LDecimal i)] -> - returnCEKValue cont handler (VLiteral (LDecimal (negate i))) - _ -> failInvariant "negate" - -rawMod :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawMod = binaryIntFn mod - -rawEq :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawEq = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i == i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i == i'))) - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i == i'))) - [VLiteral (LBool i), VLiteral (LBool i')] -> returnCEKValue cont handler (VLiteral (LBool (i == i'))) - [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool True)) - [VList l, VList r] -> - if V.length l /= V.length r then - returnCEKValue cont handler (VLiteral (LBool False)) - else returnCEKValue cont handler (VBool (valueEq (VList l) (VList r))) - _ -> failInvariant "eq" - -modInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -modInt = binaryIntFn mod - -valueEq :: CEKValue b i m -> CEKValue b i m -> Bool -valueEq (VInteger i) (VInteger r) = i == r -valueEq (VDecimal l) (VDecimal r) = l == r -valueEq (VString l) (VString r) = l == r -valueEq VUnit VUnit = True -valueEq (VBool l) (VBool r) = l == r -valueEq (VList l) (VList r) = - V.length l == V.length r && all (uncurry valueEq) (V.zip l r) -valueEq _ _ = False - -prettyShowValue :: CEKValue b i m -> Text -prettyShowValue = \case - VLiteral lit -> T.pack (show (pretty lit)) - VList vec -> - "[" <> T.concat (intersperse ", " (prettyShowValue <$> V.toList vec)) <> "]" - VClosure _ _ -> "<#closure>" - VNative _ -> "<#nativefn>" - VGuard _ -> "<#guard>" - VModRef mn _ -> "modRef{" <> (_mnName mn) <> "}" - -rawNeq :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawNeq = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i /= i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i /= i'))) - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i /= i'))) - [VLiteral (LBool i), VLiteral (LBool i')] -> returnCEKValue cont handler (VLiteral (LBool (i /= i'))) - [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool False)) - [VList l, VList r] -> - if V.length l /= V.length r then - returnCEKValue cont handler (VLiteral (LBool True)) - else returnCEKValue cont handler (VBool (not (valueEq (VList l) (VList r)))) - _ -> failInvariant "neq" - -rawGt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawGt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i > i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i > i'))) - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i > i'))) - _ -> failInvariant "int cmp function" - -rawLt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawLt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i < i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i < i'))) - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i < i'))) - _ -> failInvariant "int cmp function" - -rawGeq :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawGeq = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i >= i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i >= i'))) - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i >= i'))) - _ -> failInvariant "int cmp function" - -rawLeq :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawLeq = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i <= i'))) - [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i <= i'))) - [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i <= i'))) - _ -> failInvariant "int cmp function" - -bitAndInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitAndInt = binaryIntFn (.&.) - -bitOrInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitOrInt = binaryIntFn (.|.) - -bitComplementInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitComplementInt = unaryIntFn complement - -bitXorInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitXorInt = binaryIntFn xor - -bitShiftInt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -bitShiftInt = binaryIntFn (\i s -> shift i (fromIntegral s)) - -rawAbs :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawAbs = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> - returnCEKValue cont handler (VLiteral (LInteger (abs i))) - [VLiteral (LDecimal e)] -> do - returnCEKValue cont handler (VLiteral (LDecimal (abs e))) - _ -> failInvariant "abs" - -rawExp :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawExp = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> do - let result = exp (fromIntegral i) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - [VLiteral (LDecimal e)] -> do - let result = exp (dec2F e) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "exe" - -rawLn :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawLn = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> do - let result = log (fromIntegral i) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - [VLiteral (LDecimal e)] -> do - let result = log (dec2F e) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "lnInt" - -rawSqrt :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawSqrt = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> do - when (i < 0) $ throwExecutionError' (ArithmeticException "Square root must be non-negative") - let result = sqrt (fromIntegral i) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - [VLiteral (LDecimal e)] -> do - when (e < 0) $ throwExecutionError' (ArithmeticException "Square root must be non-negative") - let result = sqrt (dec2F e) - guardNanOrInf result - returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) - _ -> failInvariant "sqrtInt" - --- Todo: fix all show instances -rawShow :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawShow = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i)] -> - returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) - [VLiteral (LDecimal i)] -> - returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) - [VLiteral (LString i)] -> - returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) - [VLiteral (LBool i)] -> - returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) - [VLiteral LUnit] -> - returnCEKValue cont handler (VLiteral (LString "()")) - _ -> failInvariant "showInt" - --- ------------------------- --- double ops --- ------------------------- - -guardNanOrInf :: MonadEval b i m => Double -> m () -guardNanOrInf a = - when (isNaN a || isInfinite a) $ throwExecutionError' (FloatingPointError "Floating operation resulted in Infinity or NaN") - -dec2F :: Decimal -> Double -dec2F = fromRational . toRational - -f2Dec :: Double -> Decimal -f2Dec = fromRational . toRational - -roundDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -roundDec = roundingFn round - -floorDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -floorDec = roundingFn floor - -ceilingDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -ceilingDec = roundingFn ceiling - --- Todo: exp and ln, sqrt have similar failure conditions --- expDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- expDec = mkBuiltinFn \cont handler -> \case --- [VLiteral (LDecimal e)] -> do --- let result = exp (dec2F e) --- guardNanOrInf result --- returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) --- _ -> failInvariant "binary decimal function" --- -- unaryDecFn (f2Dec . exp . dec2F) - --- lnDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- lnDec = mkBuiltinFn \cont handler -> \case --- [VLiteral (LDecimal e)] -> do --- let result = log (dec2F e) --- guardNanOrInf result --- returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) --- _ -> failInvariant "binary decimal function" - --- logBaseDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- logBaseDec = mkBuiltinFn \cont handler -> \case --- [VLiteral (LDecimal base), VLiteral (LDecimal arg)] -> do --- when (base < 0 || arg <= 0) $ throwExecutionError' (ArithmeticException "Invalid base or argument in log") --- let result = logBase (dec2F base) (dec2F arg) --- guardNanOrInf result --- returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) --- _ -> failInvariant "binary decimal function" - - --- sqrtDec :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- sqrtDec = mkBuiltinFn \cont handler -> \case --- [VLiteral (LDecimal e)] -> do --- when (e < 0) $ throwExecutionError' (ArithmeticException "Square root must be non-negative") --- let result = sqrt (dec2F e) --- guardNanOrInf result --- returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) --- _ -> failInvariant "binary decimal function" - - ---------------------------- --- bool ops ---------------------------- -andBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -andBool = binaryBoolFn (&&) - -orBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -orBool = binaryBoolFn (||) - -notBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -notBool = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool i)] -> returnCEKValue cont handler (VLiteral (LBool (not i))) - _ -> failInvariant "notBool" - --- eqBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- eqBool = binaryBoolFn (==) - --- neqBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- neqBool = binaryBoolFn (/=) - --- showBool :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- showBool = mkBuiltinFn \cont handler -> \case --- [VLiteral (LBool i)] -> do --- let out = if i then "true" else "false" --- returnCEKValue cont handler (VLiteral (LString out)) --- _ -> failInvariant "showBool" - ---------------------------- --- string ops ---------------------------- --- eqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- eqStr = compareStrFn (==) - --- neqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- neqStr = compareStrFn (/=) - --- gtStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- gtStr = compareStrFn (>) - --- geqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- geqStr = compareStrFn (>=) - --- ltStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- ltStr = compareStrFn (<) - --- leqStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- leqStr = compareStrFn (<=) - --- addStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- addStr = mkBuiltinFn \cont handler -> \case --- [VLiteral (LString i), VLiteral (LString i')] -> --- returnCEKValue cont handler (VLiteral (LString (i <> i'))) --- _ -> failInvariant "addStr" - -rawTake :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawTake = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LString t)] - | i >= 0 -> do - let clamp = min (fromIntegral i) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.take clamp t))) - | otherwise -> do - let clamp = min (abs (T.length t + fromIntegral i)) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.drop clamp t))) - [VLiteral (LInteger i), VList li] - | i >= 0 -> do - let clamp = fromIntegral $ min i (fromIntegral (V.length li)) - returnCEKValue cont handler (VList (V.take clamp li)) - | otherwise -> do - let clamp = fromIntegral $ max (fromIntegral (V.length li) + i) 0 - returnCEKValue cont handler (VList (V.drop clamp li)) - _ -> failInvariant "takeStr" - -rawDrop :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawDrop = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VLiteral (LString t)] - | i >= 0 -> do - let clamp = min (fromIntegral i) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.drop clamp t))) - | otherwise -> do - let clamp = min (abs (T.length t + fromIntegral i)) (T.length t) - returnCEKValue cont handler (VLiteral (LString (T.take clamp t))) - [VLiteral (LInteger i), VList li] - | i >= 0 -> do - let clamp = fromIntegral $ min i (fromIntegral (V.length li)) - returnCEKValue cont handler (VList (V.drop clamp li)) - | otherwise -> do - let clamp = fromIntegral $ max (fromIntegral (V.length li) + i) 0 - returnCEKValue cont handler (VList (V.take clamp li)) - _ -> failInvariant "dropStr" - -rawLength :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawLength = mkBuiltinFn \cont handler -> \case - [VLiteral (LString t)] -> do - returnCEKValue cont handler (VLiteral (LInteger (fromIntegral (T.length t)))) - [VList li] -> returnCEKValue cont handler (VLiteral (LInteger (fromIntegral (V.length li)))) - _ -> failInvariant "lengthStr" - -rawReverse :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -rawReverse = mkBuiltinFn \cont handler -> \case - [VList li] -> - returnCEKValue cont handler (VList (V.reverse li)) - [VLiteral (LString t)] -> do - returnCEKValue cont handler (VLiteral (LString (T.reverse t))) - _ -> failInvariant "reverseStr" - --- showStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- showStr = mkBuiltinFn \cont handler -> \case --- [VLiteral (LString t)] -> do --- let out = "\"" <> t <> "\"" --- returnCEKValue cont handler (VLiteral (LString out)) --- _ -> failInvariant "showStr" - -concatStr :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -concatStr = mkBuiltinFn \cont handler -> \case - [VList li] -> do - li' <- traverse asString li - returnCEKValue cont handler (VLiteral (LString (T.concat (V.toList li')))) - _ -> failInvariant "concatStr" - -strToList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -strToList = mkBuiltinFn \cont handler -> \case - [VLiteral (LString s)] -> do - let v = VList (V.fromList (VLiteral . LString . T.singleton <$> T.unpack s)) - returnCEKValue cont handler v - _ -> failInvariant "concatStr" - ---------------------------- --- Unit ops ---------------------------- - --- eqUnit :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- eqUnit = mkBuiltinFn \cont handler -> \case --- [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool True)) --- _ -> failInvariant "eqUnit" - --- neqUnit :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- neqUnit = mkBuiltinFn \cont handler -> \case --- [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool False)) --- _ -> failInvariant "neqUnit" - --- showUnit :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- showUnit = mkBuiltinFn \cont handler -> \case --- [VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LString "()")) --- _ -> failInvariant "showUnit" - ---------------------------- --- Object ops ---------------------------- - --- eqObj :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- eqObj = mkBuiltinFn \case --- [l@VObject{}, r@VObject{}] -> pure (VLiteral (LBool (unsafeEqCEKValue l r))) --- _ -> failInvariant "eqObj" - --- neqObj :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- neqObj = mkBuiltinFn \case --- [l@VObject{}, r@VObject{}] -> pure (VLiteral (LBool (unsafeNeqCEKValue l r))) --- _ -> failInvariant "neqObj" - - ------------------------------- ---- conversions + unsafe ops ------------------------------- --- asBool :: MonadEval b i m => CEKValue b i m -> m Bool --- asBool (VLiteral (LBool b)) = pure b --- asBool _ = failInvariant "asBool" - -asString :: MonadEval b i m => CEKValue b i m -> m Text -asString (VLiteral (LString b)) = pure b -asString _ = failInvariant "asString" - -asList :: MonadEval b i m => CEKValue b i m -> m (Vector (CEKValue b i m)) -asList (VList l) = pure l -asList _ = failInvariant "asList" - --- unsafeEqLiteral :: Literal -> Literal -> Bool --- unsafeEqLiteral (LString i) (LString i') = i == i' --- unsafeEqLiteral (LInteger i) (LInteger i') = i == i' --- unsafeEqLiteral (LDecimal i) (LDecimal i') = i == i' --- unsafeEqLiteral LUnit LUnit = True --- unsafeEqLiteral (LBool i) (LBool i') = i == i' --- unsafeEqLiteral (LTime i) (LTime i') = i == i' --- unsafeEqLiteral _ _ = --- throw (InvariantFailure "invariant failed in literal EQ") - --- unsafeNeqLiteral :: Literal -> Literal -> Bool --- unsafeNeqLiteral a b = not (unsafeEqLiteral a b) - --- unsafeEqCEKValue :: CEKValue b i m -> CEKValue b i m -> Bool --- unsafeEqCEKValue (VLiteral l) (VLiteral l') = unsafeEqLiteral l l' --- unsafeEqCEKValue (VObject o) (VObject o') = and (Map.intersectionWith unsafeEqCEKValue o o') --- unsafeEqCEKValue (VList l) (VList l') = V.length l == V.length l' && and (V.zipWith unsafeEqCEKValue l l') --- unsafeEqCEKValue _ _ = throw (InvariantFailure "invariant failed in value Eq") - --- unsafeNeqCEKValue :: CEKValue b i m -> CEKValue b i m -> Bool --- unsafeNeqCEKValue a b = not (unsafeEqCEKValue a b) - ---------------------------- --- list ops ---------------------------- - - --- neqList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- neqList = mkBuiltinFn \cont handler -> \case --- [neqClo, VList l, VList r] -> --- if V.length l /= V.length r then --- returnCEKValue cont handler (VLiteral (LBool True)) --- else zip' (V.toList l) (V.toList r) [] --- where --- zip' (x:xs) (y:ys) acc = unsafeApplyTwo neqClo x y >>= \case --- EvalValue (VLiteral (LBool b)) -> zip' xs ys (b:acc) --- v@VError{} -> returnCEK cont handler v --- _ -> failInvariant "applying closure in list eq yielded incorrect type" --- zip' _ _ acc = returnCEKValue cont handler (VLiteral (LBool (or acc))) --- _ -> failInvariant "neqList" - -zipList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -zipList = mkBuiltinFn \cont handler -> \case - [clo, VList l, VList r] -> zip' (V.toList l) (V.toList r) [] - where - zip' (x:xs) (y:ys) acc = unsafeApplyTwo clo x y >>= \case - EvalValue v -> zip' xs ys (v:acc) - v@VError{} -> returnCEK cont handler v - zip' _ _ acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) - _ -> failInvariant "zipList" - --- addList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- addList = mkBuiltinFn \cont handler -> \case --- [VList l, VList r] -> returnCEKValue cont handler (VList (l <> r)) --- _ -> failInvariant "addList" - --- pcShowList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- pcShowList = mkBuiltinFn \cont handler -> \case --- [showFn, VList l1] -> show' (V.toList l1) [] --- where --- show' (x:xs) acc = unsafeApplyOne showFn x >>= \case --- EvalValue (VLiteral (LString b)) -> show' xs (b:acc) --- v@VError{} -> returnCEK cont handler v --- _ -> failInvariant "applying closure in list eq yielded incorrect type" --- show' _ acc = do --- let out = "[" <> T.intercalate ", " (reverse acc) <> "]" --- returnCEKValue cont handler (VLiteral (LString out)) --- _ -> failInvariant "showList" - -coreMap :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreMap = mkBuiltinFn \cont handler -> \case - [fn, VList li] -> map' (V.toList li) [] - where - map' (x:xs) acc = unsafeApplyOne fn x >>= \case - EvalValue cv -> map' xs (cv:acc) - v -> returnCEK cont handler v - map' _ acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) - _ -> failInvariant "map" - -coreFilter :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreFilter = mkBuiltinFn \cont handler -> \case - [fn, VList li] -> filter' (V.toList li) [] - where - filter' (x:xs) acc = unsafeApplyOne fn x >>= \case - EvalValue (VLiteral (LBool b)) -> - if b then filter' xs (x:acc) else filter' xs acc - v@VError{} -> - returnCEK cont handler v - _ -> failInvariant "filter" - filter' [] acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) - _ -> failInvariant "filter" - -coreFold :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreFold = mkBuiltinFn \cont handler -> \case - [fn, initElem, VList li] -> - fold' initElem (V.toList li) - where - fold' e (x:xs) = unsafeApplyTwo fn e x >>= \case - EvalValue v -> fold' v xs - v -> returnCEK cont handler v - fold' e [] = returnCEKValue cont handler e - _ -> failInvariant "fold" - -lengthList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -lengthList = mkBuiltinFn \cont handler -> \case - [VList li] -> returnCEKValue cont handler (VLiteral (LInteger (fromIntegral (V.length li)))) - _ -> failInvariant "lengthList" - --- takeList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- takeList = mkBuiltinFn \cont handler -> \case --- [VLiteral (LInteger i), VList li] --- | i >= 0 -> do --- let clamp = fromIntegral $ min i (fromIntegral (V.length li)) --- returnCEKValue cont handler (VList (V.take clamp li)) --- | otherwise -> do --- let clamp = fromIntegral $ max (fromIntegral (V.length li) + i) 0 --- returnCEKValue cont handler (VList (V.drop clamp li)) --- _ -> failInvariant "takeList" - --- dropList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- dropList = mkBuiltinFn \cont handler -> \case --- [VLiteral (LInteger i), VList li] --- | i >= 0 -> do --- let clamp = fromIntegral $ min i (fromIntegral (V.length li)) --- returnCEKValue cont handler (VList (V.drop clamp li)) --- | otherwise -> do --- let clamp = fromIntegral $ max (fromIntegral (V.length li) + i) 0 --- returnCEKValue cont handler (VList (V.take clamp li)) --- _ -> failInvariant "dropList" - --- reverseList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- reverseList = mkBuiltinFn \cont handler -> \case --- [VList li] -> --- returnCEKValue cont handler (VList (V.reverse li)) --- _ -> failInvariant "takeList" - -coreEnumerate :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreEnumerate = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger from), VLiteral (LInteger to)] -> do - v <- createEnumerateList from to (if from > to then -1 else 1) - returnCEKValue cont handler (VList (VLiteral . LInteger <$> v)) - _ -> failInvariant "enumerate" - -createEnumerateList - :: (MonadEval b i m) - => Integer - -- ^ from - -> Integer - -- ^ to - -> Integer - -- ^ Step - -> m (Vector Integer) -createEnumerateList from to inc - | from == to = pure (V.singleton from) - | inc == 0 = pure mempty - | from < to, from + inc < from = - throwExecutionError' (EnumerationError "enumerate: increment diverges below from interval bounds.") - | from > to, from + inc > from = - throwExecutionError' (EnumerationError "enumerate: increment diverges above from interval bounds.") - | otherwise = let - step = succ (abs (from - to) `div` abs inc) - in pure $ V.enumFromStepN from inc (fromIntegral step) - -coreEnumerateStepN :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreEnumerateStepN = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger from), VLiteral (LInteger to), VLiteral (LInteger inc)] -> do - v <- createEnumerateList from to inc - returnCEKValue cont handler (VList (VLiteral . LInteger <$> v)) - _ -> failInvariant "enumerate-step" - --- concatList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- concatList = mkBuiltinFn \cont handler -> \case --- [VList li] -> do --- li' <- traverse asList li --- returnCEKValue cont handler (VList (V.concat (V.toList li'))) --- _ -> failInvariant "takeList" - -makeList :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -makeList = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), v] -> do - returnCEKValue cont handler (VList (V.fromList (replicate (fromIntegral i) v))) - _ -> failInvariant "makeList" - -listAccess :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -listAccess = mkBuiltinFn \cont handler -> \case - [VLiteral (LInteger i), VList vec] -> - case vec V.!? fromIntegral i of - Just v -> returnCEKValue cont handler v - _ -> throwExecutionError' (ArrayOutOfBoundsException (V.length vec) (fromIntegral i)) - _ -> failInvariant "list-access" - ------------------------------------ --- try-related ops ------------------------------------ - -coreEnforce :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreEnforce = mkBuiltinFn \cont handler -> \case - [VLiteral (LBool b), VLiteral (LString s)] -> - if b then returnCEKValue cont handler (VLiteral LUnit) - else returnCEK cont handler (VError s) - _ -> failInvariant "enforce" - --- coreEnforceOne :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreEnforceOne = mkBuiltinFn \case --- [VList v, VLiteral (LString msg)] -> --- enforceFail msg (V.toList v) --- _ -> failInvariant "coreEnforceOne" --- where --- handler msg rest = \case --- EnforceException _ -> enforceFail msg rest --- e -> throwM e --- enforceClo _ [] = pure (VLiteral LUnit) --- enforceClo msg (x:xs) = catch (unsafeApplyOne x (VLiteral LUnit)) (handler msg xs) --- enforceFail msg [] = throwM (EnforceException msg) --- enforceFail msg as = enforceClo msg as ------------------------------------ --- Guards and reads ------------------------------------ - --- readError :: Text -> Text -> Text --- readError field expected = --- "invalid value at field " <> field <> " expected: " <> expected - --- coreReadInteger :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadInteger = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- PLiteral l@LInteger{} -> pure (VLiteral l) --- _ -> throwM (ReadException (readError s "integer")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-integer" - --- coreReadString :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadString = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv-> case pv of --- PLiteral l@LString{} -> pure (VLiteral l) --- _ -> throwM (ReadException (readError s "string")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-string" - --- coreReadDecimal :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadDecimal = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- PLiteral l@LDecimal{} -> pure (VLiteral l) --- _ -> throwM (ReadException (readError s "decimal")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-decimal" - --- coreReadObject :: CEKRuntime b i => Row Void -> CEKValue b i m -> EvalT b i (CEKValue b i m) --- coreReadObject ty = \case --- VLiteral (LString s) -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- t@PObject{} | checkPactValueType (TyRow ty) t -> pure (fromPactValue t) --- _ -> throwM (ReadException (readError s "object")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "readObject" - --- coreReadKeyset :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreReadKeyset = mkBuiltinFn \case --- [VLiteral (LString s)] -> --- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of --- Just pv -> case pv of --- PObject m -> case lookupKs m of --- Just ks -> pure (VGuard (GKeyset ks)) --- _ -> throwM (ReadException "Invalid keyset format") --- _ -> throwM (ReadException (readError s "decimal")) --- _ -> throwM (ReadException ("no field at key " <> s)) --- _ -> failInvariant "read-keyset" --- where --- -- Todo: public key parsing. --- -- This is most certainly wrong, it needs more checks. --- lookupKs m = do --- ks <- Map.lookup (Field "keys") m >>= \case --- PList v -> do --- o <- traverse (preview (_PLiteral . _LString)) v --- guard (all (T.all isHexDigit) o) --- pure $ Set.fromList $ V.toList (PublicKey . T.encodeUtf8 <$> o) --- _ -> Nothing --- kspred <- case Map.lookup (Field "pred") m of --- (Just (PLiteral LString{})) -> pure KeysAll --- Just _ -> Nothing --- Nothing -> pure KeysAll --- pure (KeySet ks kspred) - - --- coreKeysetRefGuard :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreKeysetRefGuard = mkBuiltinFn \case --- [VLiteral (LString s)] -> pure (VGuard (GKeySetRef (KeySetName s))) --- _ -> failInvariant "keyset-ref-guard" - --- coreEnforceGuard :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreEnforceGuard = mkBuiltinFn \case --- [VGuard v] -> case v of --- GKeyset ks -> enforceKeySet ks --- GKeySetRef ksr -> enforceKeySetRef ksr --- GUserGuard ug -> enforceUserGuard ug --- _ -> failInvariant "enforceGuard" - --- enforceKeySet :: CEKRuntime b i => KeySet name -> EvalT b i (CEKValue b i m) --- enforceKeySet (KeySet keys p) = do --- let sigs = _ckeSigs ?cekRuntimeEnv --- matched = Set.size $ Set.filter (`Set.member` keys) sigs --- count = Set.size keys --- case p of --- KeysAll | matched == count -> pure (VLiteral LUnit) --- Keys2 | matched >= 2 -> pure (VLiteral LUnit) --- KeysAny | matched > 0 -> pure (VLiteral LUnit) --- _ -> throwM (EnforceException "cannot match keyset predicate") - --- enforceKeySetRef :: CEKRuntime b i => KeySetName -> EvalT b i (CEKValue b i m) --- enforceKeySetRef ksr = do --- let pactDb = _ckePactDb ?cekRuntimeEnv --- liftIO (_readKeyset pactDb ksr) >>= \case --- Just ks -> enforceKeySet ks --- Nothing -> throwM (EnforceException "no such keyset") - --- enforceUserGuard :: CEKRuntime b i => CEKValue b i m -> EvalT b i (CEKValue b i m) --- enforceUserGuard = \case --- v@VClosure{} -> unsafeApplyOne v (VLiteral LUnit) >>= \case --- VLiteral LUnit -> pure (VLiteral LUnit) --- _ -> failInvariant "expected a function returning unit" --- _ -> failInvariant "invalid type for user closure" - --- createUserGuard :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- createUserGuard = mkBuiltinFn \case --- [v@VClosure{}] -> pure (VGuard (GUserGuard v)) --- _ -> failInvariant "create-user-guard" - ------------------------------------ --- Other Core forms ------------------------------------ - --- coreIf :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m --- coreIf = mkBuiltinFn \case --- [VLiteral (LBool b), VClosure tbody tenv, VClosure fbody fenv] -> --- if b then eval tenv tbody else eval fenv fbody --- _ -> failInvariant "if" - -coreB64Encode :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreB64Encode = mkBuiltinFn \cont handler -> \case - [VLiteral (LString l)] -> - returnCEKValue cont handler $ VLiteral $ LString $ toB64UrlUnpaddedText $ T.encodeUtf8 l - _ -> failInvariant "base64-encode" - - -coreB64Decode :: (BuiltinArity b, MonadEval b i m) => b -> NativeFn b i m -coreB64Decode = mkBuiltinFn \cont handler -> \case - [VLiteral (LString s)] -> case fromB64UrlUnpaddedText $ T.encodeUtf8 s of - Left{} -> throwExecutionError' (DecodeError "invalid b64 encoding") - Right txt -> returnCEKValue cont handler (VLiteral (LString txt)) - _ -> failInvariant "base64-encode" - - - ------------------------------------ --- Core definitions ------------------------------------ - -unimplemented :: NativeFn b i m -unimplemented = error "unimplemented" - -rawBuiltinRuntime - :: (MonadEval RawBuiltin i m) - => RawBuiltin - -> NativeFn RawBuiltin i m -rawBuiltinRuntime = rawBuiltinLiftedRuntime id - -rawBuiltinLiftedRuntime - :: (MonadEval b i m, BuiltinArity b) - => (RawBuiltin -> b) - -> RawBuiltin - -> NativeFn b i m -rawBuiltinLiftedRuntime f = \case - RawAdd -> rawAdd (f RawAdd) - RawSub -> rawSub (f RawSub) - RawMultiply -> rawMul (f RawMultiply) - RawDivide -> rawDiv (f RawDivide) - RawNegate -> rawNegate (f RawNegate) - RawAbs -> rawAbs (f RawAbs) - RawPow -> rawPow (f RawPow) - RawNot -> notBool (f RawNot) - RawEq -> rawEq (f RawEq) - RawNeq -> rawNeq (f RawNeq) - RawGT -> rawGt (f RawGT) - RawGEQ -> rawGeq (f RawGEQ) - RawLT -> rawLt (f RawLT) - RawLEQ -> rawLeq (f RawLEQ) - RawBitwiseAnd -> bitAndInt (f RawBitwiseAnd) - RawBitwiseOr -> bitOrInt (f RawBitwiseOr) - RawBitwiseXor -> bitXorInt (f RawBitwiseXor) - RawBitwiseFlip -> bitComplementInt (f RawBitwiseFlip) - RawBitShift -> bitShiftInt (f RawBitShift) - RawRound -> roundDec (f RawRound) - RawCeiling -> ceilingDec (f RawCeiling) - RawFloor -> floorDec (f RawFloor) - RawExp -> rawExp (f RawExp) - RawLn -> rawLn (f RawLn) - RawSqrt -> rawSqrt (f RawSqrt) - RawLogBase -> rawLogBase (f RawLogBase) - RawLength -> rawLength (f RawLength) - RawTake -> rawTake (f RawTake) - RawDrop -> rawDrop (f RawDrop) - RawConcat -> concatStr (f RawConcat) - RawReverse -> rawReverse (f RawReverse) - RawMod -> modInt (f RawMod) - RawMap -> coreMap (f RawMap) - RawFilter -> coreFilter (f RawFilter) - RawZip -> zipList (f RawZip) - RawIntToStr -> unimplemented - RawStrToInt -> unimplemented - RawFold -> coreFold (f RawFold) - RawDistinct -> unimplemented - RawEnforce -> coreEnforce (f RawEnforce) - RawEnforceOne -> unimplemented - RawEnumerate -> coreEnumerate (f RawEnumerate) - RawEnumerateStepN -> coreEnumerateStepN (f RawEnumerateStepN) - RawShow -> rawShow (f RawShow) - RawReadInteger -> unimplemented - RawReadDecimal -> unimplemented - RawReadString -> unimplemented - RawReadKeyset -> unimplemented - RawEnforceGuard -> unimplemented - RawKeysetRefGuard -> unimplemented - RawListAccess -> listAccess (f RawListAccess) - RawMakeList -> makeList (f RawMakeList) - RawB64Encode -> coreB64Encode (f RawB64Encode) - RawB64Decode -> coreB64Decode (f RawB64Decode) - RawStrToList -> strToList (f RawStrToList) diff --git a/typed-core/Pact/Core/Untyped/Term.hs b/typed-core/Pact/Core/Untyped/Term.hs deleted file mode 100644 index d1d979596..000000000 --- a/typed-core/Pact/Core/Untyped/Term.hs +++ /dev/null @@ -1,396 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TemplateHaskell #-} - -module Pact.Core.Untyped.Term - ( Defun(..) - , DefConst(..) - , DefCap(..) - , Def(..) - , defType - , defName - , defTerm - , defKind - , ifDefName - , Module(..) - , Interface(..) - , IfDefun(..) - , IfDefCap(..) - , IfDef(..) - , TopLevel(..) - , ReplTopLevel(..) - , Term(..) - , EvalTerm - , EvalModule - , EvalInterface - , EvalDef - , EvalDefConst - , fromIRTerm - , fromIRDef - , fromIRModule - , fromIRTopLevel - , fromIRReplTopLevel - , termInfo - -- Module Lenses - , mName - , mDefs - , mBlessed - , mImports - , mImplements - , mHash - , mGovernance - , mInfo - -- Interface lenses - , ifName - , ifDefns - , ifHash - , ifInfo - , findIfDef - , _IfDfun - , _IfDConst - ) where - -import Control.Lens -import Data.Text(Text) -import Data.Void -import Data.Foldable(foldl', find) -import qualified Data.Set as Set - -import Pact.Core.Builtin -import Pact.Core.Literal -import Pact.Core.Names -import Pact.Core.Type -import Pact.Core.Imports -import Pact.Core.Hash -import Pact.Core.Guards -import Pact.Core.Capabilities -import Pact.Core.Pretty(Pretty(..), pretty, (<+>)) - -import qualified Pact.Core.Pretty as Pretty -import qualified Pact.Core.IR.Term as IR - -data Defun name builtin info - = Defun - { _dfunName :: Text - , _dfunType :: Type Void - , _dfunTerm :: Term name builtin info - , _dfunInfo :: info - } deriving Show - -data DefConst name builtin info - = DefConst - { _dcName :: Text - , _dcType :: Type Void - , _dcTerm :: Term name builtin info - , _dcInfo :: info - } deriving Show - -data DefCap name builtin info - = DefCap - { _dcapName :: Text - , _dcapAppArity :: Int - , _dcapArgTypes :: [Type Void] - , _dcapRType :: Type Void - , _dcapTerm :: Term name builtin info - , _dcapMeta :: Maybe (DefCapMeta name) - , _dcapInfo :: info - } deriving Show - -data Def name builtin info - = Dfun (Defun name builtin info) - | DConst (DefConst name builtin info) - | DCap (DefCap name builtin info) - deriving Show - --- DCap (DefCap name builtin info) --- DPact (DefPact name builtin info) --- DSchema (DefSchema name info) --- DTable (DefTable name info) - --- Todo: Remove this, not all top level defs have a proper --- associated type, and DCap types are w holly irrelevant, we cannot simply --- call them, they can only be evaluated within `with-capability`. -defType :: Def name builtin info -> TypeOfDef Void -defType = \case - Dfun d -> DefunType (_dfunType d) - DConst d -> DefunType $ _dcType d - DCap d -> DefcapType (_dcapArgTypes d) (_dcapRType d) - -defName :: Def name builtin i -> Text -defName = \case - Dfun d -> _dfunName d - DConst d -> _dcName d - DCap d -> _dcapName d - -defKind :: Def name builtin i -> DefKind -defKind = \case - Dfun _ -> DKDefun - DConst _ -> DKDefConst - DCap _ -> DKDefCap - -ifDefName :: IfDef name builtin i -> Text -ifDefName = \case - IfDfun ifd -> _ifdName ifd - IfDConst dc -> _dcName dc - IfDCap d -> _ifdcName d - -defTerm :: Def name builtin info -> Term name builtin info -defTerm = \case - Dfun d -> _dfunTerm d - DConst d -> _dcTerm d - DCap d -> _dcapTerm d - -data Module name builtin info - = Module - { _mName :: ModuleName - , _mGovernance :: Governance name - , _mDefs :: [Def name builtin info] - , _mBlessed :: !(Set.Set ModuleHash) - , _mImports :: [Import] - , _mImplements :: [ModuleName] - , _mHash :: ModuleHash - , _mInfo :: info - } deriving Show - -data Interface name builtin info - = Interface - { _ifName :: ModuleName - , _ifDefns :: [IfDef name builtin info] - , _ifHash :: ModuleHash - , _ifInfo :: info - } deriving Show - -data IfDefun info - = IfDefun - { _ifdName :: Text - , _ifdType :: Type Void - , _ifdInfo :: info - } deriving Show - -data IfDefCap info - = IfDefCap - { _ifdcName :: Text - , _ifdcArgTys :: [Type Void] - , _ifdcRType :: Type Void - , _ifdcInfo :: info - } deriving (Show, Functor) - -data IfDef name builtin info - = IfDfun (IfDefun info) - | IfDConst (DefConst name builtin info) - | IfDCap (IfDefCap info) - deriving Show - -data TopLevel name builtin info - = TLModule (Module name builtin info) - | TLInterface (Interface name builtin info) - | TLTerm (Term name builtin info) - deriving Show - -data ReplTopLevel name builtin info - = RTLModule (Module name builtin info) - | RTLInterface (Interface name builtin info) - | RTLDefun (Defun name builtin info) - | RTLDefConst (DefConst name builtin info) - | RTLTerm (Term name builtin info) - deriving Show - --- | Untyped pact core terms -data Term name builtin info - = Var name info - -- ^ single variables, e.g the term `x` - | Lam (Term name builtin info) info - -- ^ f = \a b c -> e - -- All lambdas, even anonymous ones, are named, for the sake of them adding a stack frame - | App (Term name builtin info) (Term name builtin info) info - -- ^ Constant/Literal values - | Sequence (Term name builtin info) (Term name builtin info) info - -- ^ (e_1 e_2 .. e_n) - | Conditional (BuiltinForm (Term name builtin info)) info - -- ^ Special nodes for If, And and Or. - | Builtin builtin info - -- ^ Built-in functions (or natives) - | Constant Literal info - -- ^ ΛX.e - | ListLit [Term name builtin info] info - -- ^ [e_1, e_2, .., e_n] - | Try (Term name builtin info) (Term name builtin info) info - -- ^ try (catch expr) (try-expr) - | DynInvoke (Term name builtin info) Text info - -- ^ dynamic module reference invocation m::f - | CapabilityForm (CapForm name (Term name builtin info)) info - -- ^ Capability - | Error Text info - -- ^ Error catching - deriving (Show, Functor, Foldable, Traversable) - --- Post Typecheck terms + modules -type EvalTerm b i = Term Name b i -type EvalDefConst b i = DefConst Name b i -type EvalDef b i = Def Name b i -type EvalModule b i = Module Name b i -type EvalInterface b i = Interface Name b i - -fromIRTerm :: IR.Term n b i -> Term n b i -fromIRTerm = \case - IR.Var n i -> Var n i - IR.Lam nsts body i -> - foldr (\_ t -> Lam t i) (fromIRTerm body) nsts - IR.Let _ _ e1 e2 i -> - App (Lam (fromIRTerm e2) i) (fromIRTerm e1) i - IR.App fn apps i -> - foldl' (\f arg -> App f (fromIRTerm arg) i) (fromIRTerm fn) apps - IR.Builtin b i -> - Builtin b i - IR.Constant lit i -> - Constant lit i - IR.Sequence e1 e2 i -> - Sequence (fromIRTerm e1) (fromIRTerm e2) i - IR.Conditional c i -> - Conditional (fromIRTerm <$> c) i - IR.ListLit v i -> - ListLit (fromIRTerm <$> v) i - IR.Try e1 e2 i -> - Try (fromIRTerm e1) (fromIRTerm e2) i - IR.DynInvoke n t i -> - DynInvoke (fromIRTerm n) t i - IR.CapabilityForm cf i -> - CapabilityForm (fmap fromIRTerm cf) i - IR.Error e i -> - Error e i - -fromIRDefun - :: IR.Defun name builtin info - -> Defun name builtin info -fromIRDefun (IR.Defun n ty term i) = - Defun n (fmap absurd ty) (fromIRTerm term) i - -fromIRIfDefun :: IR.IfDefun info -> IfDefun info -fromIRIfDefun (IR.IfDefun dfn ty i) = - IfDefun dfn ty i - -fromIRIfDefCap :: IR.IfDefCap info -> IfDefCap info -fromIRIfDefCap (IR.IfDefCap dfn argtys rty i) = - IfDefCap dfn argtys rty i - -fromIRDConst - :: IR.DefConst name builtin info - -> DefConst name builtin info -fromIRDConst (IR.DefConst n ty term i) = - DefConst n (maybe TyUnit (fmap absurd) ty) (fromIRTerm term) i - -fromIRDCap :: IR.DefCap name builtin info -> DefCap name builtin info -fromIRDCap (IR.DefCap name arity argtys rtype body meta i) = - DefCap name arity argtys rtype (fromIRTerm body) meta i - -fromIRDef - :: IR.Def name builtin info - -> Def name builtin info -fromIRDef = \case - IR.Dfun d -> Dfun (fromIRDefun d) - IR.DConst d -> DConst (fromIRDConst d) - IR.DCap d -> DCap (fromIRDCap d) - -fromIRIfDef - :: IR.IfDef name builtin info - -> IfDef name builtin info -fromIRIfDef = \case - IR.IfDfun d -> IfDfun (fromIRIfDefun d) - IR.IfDConst d -> IfDConst (fromIRDConst d) - IR.IfDCap d -> IfDCap (fromIRIfDefCap d) - -fromIRModule - :: IR.Module name builtin info - -> Module name builtin info -fromIRModule (IR.Module mn gov defs blessed imports implements hs i) = - Module mn gov (fromIRDef <$> defs) blessed imports implements hs i - -fromIRInterface - :: IR.Interface name builtin info - -> Interface name builtin info -fromIRInterface (IR.Interface ifn ifdefs ifhash i) = - Interface ifn (fromIRIfDef <$> ifdefs) ifhash i - -fromIRTopLevel - :: IR.TopLevel name builtin info - -> TopLevel name builtin info -fromIRTopLevel = \case - IR.TLModule m -> TLModule (fromIRModule m) - IR.TLInterface iface -> - TLInterface (fromIRInterface iface) - IR.TLTerm e -> TLTerm (fromIRTerm e) - -fromIRReplTopLevel - :: IR.ReplTopLevel name builtin info - -> ReplTopLevel name builtin info -fromIRReplTopLevel = \case - IR.RTLModule m -> RTLModule (fromIRModule m) - IR.RTLInterface iface -> RTLInterface (fromIRInterface iface) - IR.RTLTerm e -> RTLTerm (fromIRTerm e) - IR.RTLDefun df -> RTLDefun (fromIRDefun df) - IR.RTLDefConst dc -> RTLDefConst (fromIRDConst dc) - -findIfDef :: Text -> Interface name builtin info -> Maybe (IfDef name builtin info) -findIfDef f iface = - find ((== f) . ifDefName) (_ifDefns iface) - -instance (Pretty name, Pretty builtin) => Pretty (Term name builtin info) where - pretty = \case - Var n _ -> - pretty n - Lam term _ -> - Pretty.parens ("λ." <> pretty term) - App t1 t2 _ -> - Pretty.parens (Pretty.hsep [pretty t1, pretty t2]) - Builtin b _ -> pretty b - Constant l _ -> pretty l - Sequence e1 e2 _ -> Pretty.parens ("seq" <+> pretty e1 <+> pretty e2) - Conditional c _ -> pretty c - ListLit li _ -> - Pretty.brackets $ - Pretty.hsep $ - Pretty.punctuate Pretty.comma (pretty <$> li) - Try e1 e2 _ -> - Pretty.parens ("try" <+> pretty e1 <+> pretty e2) - DynInvoke n t _ -> - pretty n <> "::" <> pretty t - CapabilityForm _ _ -> error "pretty capform" - Error e _ -> - Pretty.parens ("error \"" <> pretty e <> "\"") - -- ObjectLit (Map.toList -> obj) _ -> - -- Pretty.braces $ - -- Pretty.hsep $ - -- Pretty.punctuate Pretty.comma $ - -- fmap (\(f, o) -> pretty f <> ":" <+> pretty o) obj - -- ObjectOp oop _ -> case oop of - -- ObjectAccess fi te -> - -- Pretty.parens $ Pretty.hsep ["@" <> pretty fi, pretty te] - -- ObjectRemove fi te -> - -- Pretty.parens $ Pretty.hsep ["#" <> pretty fi, pretty te] - -- ObjectExtend fi v o -> - -- Pretty.braces $ Pretty.hsep [pretty fi <> ":" <> pretty v, "|", pretty o] - -termInfo :: Lens' (Term name builtin info) info -termInfo f = \case - Var n i -> Var n <$> f i - Lam term i -> Lam term <$> f i - App t1 t2 i -> App t1 t2 <$> f i - Sequence e1 e2 i -> Sequence e1 e2 <$> f i - Conditional c i -> Conditional c <$> f i - ListLit v i -> ListLit v <$> f i - Builtin b i -> Builtin b <$> f i - Constant l i -> Constant l <$> f i - Try e1 e2 i -> - Try e1 e2 <$> f i - DynInvoke n t i -> DynInvoke n t <$> f i - CapabilityForm cf i -> - CapabilityForm cf <$> f i - Error e i -> - Error e <$> f i - -makeLenses ''Module -makeLenses ''Interface -makePrisms ''IfDef diff --git a/typed-core/Pact/Core/Untyped/Utils.hs b/typed-core/Pact/Core/Untyped/Utils.hs deleted file mode 100644 index dd0b0305c..000000000 --- a/typed-core/Pact/Core/Untyped/Utils.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Pact.Core.Untyped.Utils where - -import Data.Foldable(foldl') - -import Pact.Core.Untyped.Term -import qualified Pact.Core.Typed.Term as Typed - -fromTypedTerm :: Typed.Term name tyname b i -> Term name b i -fromTypedTerm = \case - Typed.Var n i -> Var n i - Typed.Lam args body i -> - foldr (\_ t -> Lam t i) (fromTypedTerm body) args - Typed.App fn apps i -> - foldl' (\f arg -> App f (fromTypedTerm arg) i) (fromTypedTerm fn) apps - Typed.Let _ e1 e2 i -> - App (Lam (fromTypedTerm e2) i) (fromTypedTerm e1) i - Typed.Builtin b i -> - Builtin b i - Typed.Constant lit i -> - Constant lit i - Typed.TyApp te _ _ -> - fromTypedTerm te - Typed.TyAbs _ term _ -> - fromTypedTerm term - Typed.Sequence e1 e2 i -> - Sequence (fromTypedTerm e1) (fromTypedTerm e2) i - Typed.Conditional c i -> - Conditional (fromTypedTerm <$> c) i - Typed.ListLit _ vec i -> - ListLit (fromTypedTerm <$> vec) i - Typed.Try e1 e2 i -> - Try (fromTypedTerm e1) (fromTypedTerm e2) i - Typed.DynInvoke term t i -> - DynInvoke (fromTypedTerm term) t i - Typed.CapabilityForm cf i -> - CapabilityForm (fromTypedTerm <$> cf) i - Typed.Error _ e i -> Error e i - -- Typed.ObjectLit m i -> - -- ObjectLit (fromTypedTerm <$> m) i - -- Typed.ObjectOp oo i -> - -- ObjectOp (fromTypedTerm <$> oo) i - - -fromTypedDefun - :: Typed.Defun name tyname builtin info - -> Defun name builtin info -fromTypedDefun (Typed.Defun n ty term i) = - Defun n ty (fromTypedTerm term) i - -fromTypedIfDefun - :: Typed.IfDefun info - -> IfDefun info -fromTypedIfDefun (Typed.IfDefun n ty i) = - IfDefun n ty i - -fromTypedIfDefCap - :: Typed.IfDefCap info - -> IfDefCap info -fromTypedIfDefCap (Typed.IfDefCap n argtys ty i) = - IfDefCap n argtys ty i - -fromTypedDConst - :: Typed.DefConst name tyname builtin info - -> DefConst name builtin info -fromTypedDConst (Typed.DefConst n ty term i) = - DefConst n ty (fromTypedTerm term) i - -fromTypedDCap - :: Typed.DefCap name tyname builtin info - -> DefCap name builtin info -fromTypedDCap (Typed.DefCap name appArity argTys rty term meta i) = - DefCap name appArity argTys rty (fromTypedTerm term) meta i - -fromTypedDef - :: Typed.Def name tyname builtin info - -> Def name builtin info -fromTypedDef = \case - Typed.Dfun d -> Dfun (fromTypedDefun d) - Typed.DConst d -> DConst (fromTypedDConst d) - Typed.DCap d -> DCap (fromTypedDCap d) - -fromTypedIfDef - :: Typed.IfDef name tyname builtin info - -> IfDef name builtin info -fromTypedIfDef = \case - Typed.IfDfun d -> IfDfun (fromTypedIfDefun d) - Typed.IfDConst d -> - IfDConst (fromTypedDConst d) - Typed.IfDCap d -> - IfDCap (fromTypedIfDefCap d) - -fromTypedModule - :: Typed.Module name tyname builtin info - -> Module name builtin info -fromTypedModule (Typed.Module mn mgov defs blessed imports implements hs i) = - Module mn mgov (fromTypedDef <$> defs) blessed imports implements hs i - -fromTypedInterface - :: Typed.Interface name tyname builtin info - -> Interface name builtin info -fromTypedInterface (Typed.Interface ifname ifdefs ifh i) = - Interface ifname (fromTypedIfDef <$> ifdefs) ifh i - -fromTypedTopLevel - :: Typed.TopLevel name tyname builtin info - -> TopLevel name builtin info -fromTypedTopLevel = \case - Typed.TLModule m -> - TLModule (fromTypedModule m) - Typed.TLInterface iface -> - TLInterface (fromTypedInterface iface) - Typed.TLTerm e -> - TLTerm (fromTypedTerm e) - -fromTypedReplTopLevel - :: Typed.ReplTopLevel name tyname builtin info - -> ReplTopLevel name builtin info -fromTypedReplTopLevel = \case - Typed.RTLModule m -> - RTLModule (fromTypedModule m) - Typed.RTLDefun de -> - RTLDefun (fromTypedDefun de) - Typed.RTLDefConst dc -> - RTLDefConst (fromTypedDConst dc) - Typed.RTLTerm te -> - RTLTerm (fromTypedTerm te) - Typed.RTLInterface i -> - RTLInterface (fromTypedInterface i) From 2d8964fb39902c02e879a6cec92543f8923f2192 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Tue, 22 Aug 2023 15:35:21 -0400 Subject: [PATCH 02/66] typed core type --- typed-core/Pact/Core/Typed/Type.hs | 113 +++++++++++++++++++++++++++++ 1 file changed, 113 insertions(+) create mode 100644 typed-core/Pact/Core/Typed/Type.hs diff --git a/typed-core/Pact/Core/Typed/Type.hs b/typed-core/Pact/Core/Typed/Type.hs new file mode 100644 index 000000000..c0568cf69 --- /dev/null +++ b/typed-core/Pact/Core/Typed/Type.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveTraversable #-} + + +module Pact.Core.Typed.Type where + +import Data.List.NonEmpty(NonEmpty) +import Data.Map.Strict(Map) + +import Pact.Core.Literal +import Pact.Core.Type(PrimType(..)) +import Pact.Core.Names +import Pact.Core.Pretty + +import qualified Pact.Core.Type as CoreType + +data Type n + = TyVar n + -- ^ type variables + | TyPrim PrimType + -- ^ Built-in types + | TyFun (Type n) (Type n) + -- ^ Type n + | TyList (Type n) + -- ^ List aka [a] + | TyModRef ModuleName + -- ^ Module references + -- | TyObject Schema + -- ^ Objects + | TyForall (NonEmpty n) (Type n) + -- | TyTable Schema + -- ^ Tables + deriving (Eq, Show, Functor, Foldable, Traversable) + +liftCoreType :: CoreType.Type -> Type n +liftCoreType = \case + CoreType.TyPrim p -> TyPrim p + CoreType.TyList t -> TyList (liftCoreType t) + CoreType.TyModRef m -> TyModRef m + CoreType.TyTable{} -> error "tytable" + CoreType.TyObject{} -> error "tyobject" + +pattern TyInt :: Type n +pattern TyInt = TyPrim PrimInt + +pattern TyDecimal :: Type n +pattern TyDecimal = TyPrim PrimDecimal + +-- pattern TyTime :: Type n +-- pattern TyTime = TyPrim PrimTime + +pattern TyBool :: Type n +pattern TyBool = TyPrim PrimBool + +pattern TyString :: Type n +pattern TyString = TyPrim PrimString + +pattern TyUnit :: Type n +pattern TyUnit = TyPrim PrimUnit + +pattern TyGuard :: Type n +pattern TyGuard = TyPrim PrimGuard + +pattern (:~>) :: Type n -> Type n -> Type n +pattern (:~>) l r = TyFun l r + +typeOfLit :: Literal -> Type n +typeOfLit = \case + LString{} -> TyString + LInteger{} -> TyDecimal + LUnit -> TyUnit + LDecimal{} -> TyDecimal + LBool{} -> TyBool + +instance Pretty (Type n) where + pretty _ty = error "todo" + +data BuiltinTC + = Eq + | Ord + | Show + | Add + | Num + | ListLike + | Fractional + deriving (Show, Eq, Ord) + +instance Pretty BuiltinTC where + pretty = \case + Eq -> "Eq" + Ord -> "Ord" + Show -> "Show" + Add -> "Add" + Num -> "Num" + ListLike -> "ListLike" + Fractional -> "Fractional" + +-- Note, no superclasses, for now +data Pred tv + = Pred BuiltinTC (Type tv) + deriving (Show, Eq, Functor, Foldable, Traversable) + +data TypeScheme tv = + TypeScheme [tv] [Pred tv] (Type tv) + deriving Show + + +newtype Schema tv + = Schema { _schema :: Map Field (Type tv) } + deriving (Eq, Show) From e1a8ce756d4f6ea0772cdc7949198c23a8409236 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 23 Aug 2023 11:10:49 -0500 Subject: [PATCH 03/66] Fix deriving --- typed-core/Pact/Core/IR/Typecheck.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 3fd34e5d0..279be2e55 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -159,7 +159,7 @@ newtype InferM s b i a = ( Functor, Applicative, Monad , MonadReader (TCEnv s b i) , MonadError (PactError i)) - via (ExceptT (PactError i) (ReaderT (TCEnv s b i) (ST s))) + via (ExceptT TypecheckError (ReaderT (TCEnv s b i) (ST s))) class TypeOfBuiltin b where typeOfBuiltin :: b -> TypeScheme NamedDeBruijn From b217909f628e6c17516e341faeaaf72070282651 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 23 Aug 2023 11:14:28 -0500 Subject: [PATCH 04/66] Make my linter shut up mostly --- typed-core/Pact/Core/IR/Typecheck.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 279be2e55..e7e21c307 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -45,7 +45,7 @@ import Data.RAList(RAList) import Data.Foldable(traverse_, foldlM) import Data.Functor(($>)) import Data.STRef -import Data.Maybe(mapMaybe) +import Data.Maybe(mapMaybe, fromMaybe) import Data.Map(Map) import Data.Text(Text) import Data.List.NonEmpty(NonEmpty(..)) @@ -939,7 +939,7 @@ generalizeWithTerm' ty pp term = do TyVar rv -> readTvRef rv >>= \case Link tl -> nubPreds' (Pred tc tl :xs) elems _ -> - if elem p elems + if p `elem` elems then nubPreds' xs elems else nubPreds' xs (Pred tc x:elems) _ -> nubPreds' xs elems @@ -1129,7 +1129,7 @@ checkTermType checkty = \case IR.ListLit tes i -> case checkty of TyList ty -> do liTup <- traverse (checkTermType ty) tes - let preds = concat (view _3 <$> liTup) + let preds = concatMap (view _3) liTup term' = Typed.ListLit ty (view _2 <$> liTup) i pure (TyList ty, term', preds) _ -> do @@ -1298,7 +1298,7 @@ inferTerm = \case IR.ListLit li i -> do tv <- TyVar <$> newTvRef liTup <- traverse inferTerm li - let preds = concat (view _3 <$> liTup) + let preds = concatMap (view _3) liTup traverse_ (\(t,_, _) -> unify tv t i) liTup pure (TyList tv, Typed.ListLit tv (view _2 <$> liTup) i, preds) IR.Try e1 e2 i -> do @@ -1350,7 +1350,7 @@ inferDefConst (IR.DefConst name dcTy term info) = do fterm <- noTyVarsinTerm info term' let dcTy' = liftType <$> dcTy _ <- maybe (pure ()) (\dct -> unify dct termTy info) dcTy' - rty' <- ensureNoTyVars info (maybe termTy id dcTy') + rty' <- ensureNoTyVars info (fromMaybe termTy dcTy') pure (Typed.DefConst name rty' fterm info) inferDefCap @@ -1361,7 +1361,7 @@ inferDefCap (IR.DefCap name arity argtys rty term meta i) = do let ty = foldr TyFun rty argtys (termTy, term', preds) <- checkTermType (liftType ty) term checkReducible preds i - unify (liftType ty) (termTy) i + unify (liftType ty) termTy i fterm <- noTyVarsinTerm i term' pure (Typed.DefCap name arity argtys rty fterm meta i) From fffc581b487ac3e390fd0c37362823bb00001709 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 23 Aug 2023 15:50:51 -0500 Subject: [PATCH 05/66] =?UTF-8?q?PactError=20=E2=86=92=20TypecheckError?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- typed-core/Pact/Core/IR/Typecheck.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index e7e21c307..4478b1cfd 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -158,7 +158,7 @@ newtype InferM s b i a = deriving ( Functor, Applicative, Monad , MonadReader (TCEnv s b i) - , MonadError (PactError i)) + , MonadError TypecheckError) via (ExceptT TypecheckError (ReaderT (TCEnv s b i) (ST s))) class TypeOfBuiltin b where @@ -1713,7 +1713,7 @@ dbjTyp i env depth = \case runInfer :: Loaded b i -> InferM s b i a - -> ST s (Either (PactError i) a) + -> ST s (Either TypecheckError a) runInfer loaded (InferT act) = do uref <- newSTRef 0 lref <- newSTRef 1 @@ -1724,7 +1724,7 @@ runInferTerm :: TypeOfBuiltin b => Loaded b' i -> IRTerm b i - -> Either (PactError i) (TypeScheme NamedDeBruijn, TypedGenTerm b i) + -> Either TypecheckError (TypeScheme NamedDeBruijn, TypedGenTerm b i) runInferTerm loaded term0 = runST $ runInfer loaded $ inferTermGen term0 @@ -1732,7 +1732,7 @@ runInferTermNonGen :: TypeOfBuiltin b => Loaded b' i -> IRTerm b i - -> Either (PactError i) (TypeScheme NamedDeBruijn, TypedTerm b i) + -> Either TypecheckError (TypeScheme NamedDeBruijn, TypedTerm b i) runInferTermNonGen loaded term0 = runST $ runInfer loaded $ inferTermNonGen term0 @@ -1740,15 +1740,15 @@ runInferModule :: TypeOfBuiltin b => Loaded b' i -> IRModule b i - -> Either (PactError i) (TypedModule b i) + -> Either TypecheckError (TypedModule b i) runInferModule loaded term0 = runST $ runInfer loaded (inferModule term0) runInferTopLevel :: TypeOfBuiltin b => Loaded reso i - -> IR.TopLevel Name b i - -> Either (PactError i) (TypedTopLevel b i, Loaded reso i) + -> IR.TopLevel Name IRType b i + -> Either TypecheckError (TypedTopLevel b i, Loaded reso i) runInferTopLevel l tl = runST $ runInfer l (inferTopLevel l tl) @@ -1756,7 +1756,7 @@ runInferTopLevel l tl = runInferReplTopLevel :: TypeOfBuiltin b => Loaded reso i - -> IR.ReplTopLevel Name b i - -> Either (PactError i) (TypedReplTopLevel b i, Loaded reso i) + -> IR.ReplTopLevel Name IRType b i + -> Either TypecheckError (TypedReplTopLevel b i, Loaded reso i) runInferReplTopLevel l tl = runST $ runInfer l (inferReplTopLevel l tl) From 54c51a4d8be1cc5e5a802ba5a1e924c3bc60e608 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 24 Aug 2023 12:30:54 -0500 Subject: [PATCH 06/66] BuiltinTC can be just exported from pact-core/P.C.T, I guess --- pact-core/Pact/Core/Type.hs | 40 +++++++++++++++--------------- typed-core/Pact/Core/Typed/Type.hs | 22 +--------------- 2 files changed, 21 insertions(+), 41 deletions(-) diff --git a/pact-core/Pact/Core/Type.hs b/pact-core/Pact/Core/Type.hs index c9732f2e1..6d8f602d9 100644 --- a/pact-core/Pact/Core/Type.hs +++ b/pact-core/Pact/Core/Type.hs @@ -19,7 +19,7 @@ module Pact.Core.Type , pattern TyUnit , pattern TyGuard , typeOfLit --- , BuiltinTC(..) + , BuiltinTC(..) -- , Pred(..) -- , renderType -- , renderPred @@ -117,25 +117,25 @@ pattern TyGuard = TyPrim PrimGuard -- Built in typeclasses --- data BuiltinTC --- = Eq --- | Ord --- | Show --- | Add --- | Num --- | ListLike --- | Fractional --- deriving (Show, Eq, Ord) - --- instance Pretty BuiltinTC where --- pretty = \case --- Eq -> "Eq" --- Ord -> "Ord" --- Show -> "Show" --- Add -> "Add" --- Num -> "Num" --- ListLike -> "ListLike" --- Fractional -> "Fractional" +data BuiltinTC + = Eq + | Ord + | Show + | Add + | Num + | ListLike + | Fractional + deriving (Show, Eq, Ord) + +instance Pretty BuiltinTC where + pretty = \case + Eq -> "Eq" + Ord -> "Ord" + Show -> "Show" + Add -> "Add" + Num -> "Num" + ListLike -> "ListLike" + Fractional -> "Fractional" -- -- Note, no superclasses, for now -- data Pred tv diff --git a/typed-core/Pact/Core/Typed/Type.hs b/typed-core/Pact/Core/Typed/Type.hs index c0568cf69..651c6dca9 100644 --- a/typed-core/Pact/Core/Typed/Type.hs +++ b/typed-core/Pact/Core/Typed/Type.hs @@ -11,7 +11,7 @@ import Data.List.NonEmpty(NonEmpty) import Data.Map.Strict(Map) import Pact.Core.Literal -import Pact.Core.Type(PrimType(..)) +import Pact.Core.Type(PrimType(..), BuiltinTC) import Pact.Core.Names import Pact.Core.Pretty @@ -78,26 +78,6 @@ typeOfLit = \case instance Pretty (Type n) where pretty _ty = error "todo" -data BuiltinTC - = Eq - | Ord - | Show - | Add - | Num - | ListLike - | Fractional - deriving (Show, Eq, Ord) - -instance Pretty BuiltinTC where - pretty = \case - Eq -> "Eq" - Ord -> "Ord" - Show -> "Show" - Add -> "Add" - Num -> "Num" - ListLike -> "ListLike" - Fractional -> "Fractional" - -- Note, no superclasses, for now data Pred tv = Pred BuiltinTC (Type tv) From 1e3d27b633926b9672c584ec79d77415f0ddde66 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 24 Aug 2023 12:42:25 -0500 Subject: [PATCH 07/66] =?UTF-8?q?=E2=80=A6and=20so=20does=20Pred,=20albeit?= =?UTF-8?q?=20without=20a=20type=20variable=20now?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- pact-core/Pact/Core/Type.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/pact-core/Pact/Core/Type.hs b/pact-core/Pact/Core/Type.hs index 6d8f602d9..9544312cf 100644 --- a/pact-core/Pact/Core/Type.hs +++ b/pact-core/Pact/Core/Type.hs @@ -20,7 +20,7 @@ module Pact.Core.Type , pattern TyGuard , typeOfLit , BuiltinTC(..) --- , Pred(..) + , Pred(..) -- , renderType -- , renderPred -- , TypeOfDef(..) @@ -138,9 +138,9 @@ instance Pretty BuiltinTC where Fractional -> "Fractional" -- -- Note, no superclasses, for now --- data Pred tv --- = Pred BuiltinTC (Type tv) --- deriving (Show, Eq, Functor, Foldable, Traversable) +data Pred + = Pred BuiltinTC Type + deriving (Show, Eq) -- data TypeScheme tv = -- TypeScheme [tv] [Pred tv] (Type tv) From ada82a70db2f002ee5fb54b89624b17a2958ad74 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 24 Aug 2023 12:50:01 -0500 Subject: [PATCH 08/66] Add some TODOs for convenience --- typed-core/Pact/Core/Typed/Overload.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/typed-core/Pact/Core/Typed/Overload.hs b/typed-core/Pact/Core/Typed/Overload.hs index 7174014eb..ea520ed2a 100644 --- a/typed-core/Pact/Core/Typed/Overload.hs +++ b/typed-core/Pact/Core/Typed/Overload.hs @@ -364,10 +364,10 @@ solveCoreOverload i b tys preds = case b of RawReadKeyset -> pure (Builtin ReadKeyset i) RawEnforceGuard -> pure (Builtin EnforceGuard i) RawKeysetRefGuard -> pure (Builtin KeysetRefGuard i) - RawContains -> error "contains" - RawSort -> error "sort" - RawSortObject -> error "sortObject" - RawRemove -> error "remove" + RawContains -> error "contains" -- TODO + RawSort -> error "sort" -- TODO + RawSortObject -> error "sortObject" -- TODO + RawRemove -> error "remove" -- TODO singlePred :: [t] -> i -> (t -> OverloadM i a) -> String -> OverloadM i a singlePred preds i f msg = case preds of From b1806f50da2498cafbd790e408367f528140727e Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 24 Aug 2023 12:54:27 -0500 Subject: [PATCH 09/66] Now I need to hide Pred here --- typed-core/Pact/Core/Typed/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/typed-core/Pact/Core/Typed/Term.hs b/typed-core/Pact/Core/Typed/Term.hs index 8a629001d..bb7c0c330 100644 --- a/typed-core/Pact/Core/Typed/Term.hs +++ b/typed-core/Pact/Core/Typed/Term.hs @@ -56,7 +56,7 @@ import qualified Data.List.NonEmpty as NE import Pact.Core.Builtin import Pact.Core.Literal import Pact.Core.Names -import Pact.Core.Type hiding (Type) +import Pact.Core.Type hiding (Pred, Type) import Pact.Core.Typed.Type import Pact.Core.Imports import Pact.Core.Hash From 5683b6508cfcebce6ff1765db183b6b23c483ba0 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 24 Aug 2023 13:33:04 -0500 Subject: [PATCH 10/66] Types are explicit type args now so pass them --- typed-core/Pact/Core/IR/Typecheck.hs | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 4478b1cfd..70387fb44 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -120,9 +120,10 @@ type TCType s = Type (TvRef s) type TCPred s = Pred (TvRef s) -- | Term emitted by desugar -type IRTerm b i = IR.Term Name b i -type IRModule b i = IR.Module Name b i -type IRInterface b i = IR.Interface Name b i +type IRType = IR.Type +type IRTerm b i = IR.Term Name IRType b i +type IRModule b i = IR.Module Name IRType b i +type IRInterface b i = IR.Interface Name IRType b i -- | Term emitted by the typechecker prior to final generalization/unification. type TCTerm s b i = Typed.Term Name (TvRef s) (b, [TCType s], [TCPred s]) i @@ -1325,7 +1326,7 @@ inferTerm = \case -- we're not allowing type schemes just yet. inferDefun :: TypeOfBuiltin b - => IR.Defun Name b i + => IR.Defun Name IRType b i -> InferM s b' i (TypedDefun b i) inferDefun (IR.Defun name dfargs dfRetType term info) = do enterLevel @@ -1340,7 +1341,7 @@ inferDefun (IR.Defun name dfargs dfRetType term info) = do inferDefConst :: TypeOfBuiltin b - => IR.DefConst Name b i + => IR.DefConst Name IRType b i -> InferM s b' i (TypedDefConst b i) inferDefConst (IR.DefConst name dcTy term info) = do enterLevel @@ -1355,7 +1356,7 @@ inferDefConst (IR.DefConst name dcTy term info) = do inferDefCap :: TypeOfBuiltin b - => IR.DefCap Name b i + => IR.DefCap Name IRType b i -> InferM s b' i (TypedDefCap b i) inferDefCap (IR.DefCap name arity argtys rty term meta i) = do let ty = foldr TyFun rty argtys @@ -1367,7 +1368,7 @@ inferDefCap (IR.DefCap name arity argtys rty term meta i) = do inferDef :: TypeOfBuiltin b - => IR.Def Name b i + => IR.Def Name IRType b i -> InferM s b' i (TypedDef b i) inferDef = \case IR.Dfun d -> Typed.Dfun <$> inferDefun d @@ -1376,7 +1377,7 @@ inferDef = \case inferIfDef :: TypeOfBuiltin b - => IR.IfDef Name b i + => IR.IfDef Name IRType b i -> InferM s b' i (TypedIfDef b i) inferIfDef = \case IR.IfDfun ifd -> @@ -1388,7 +1389,7 @@ inferIfDef = \case inferModule :: TypeOfBuiltin b - => IR.Module Name b i + => IR.Module Name IRType b i -> InferM s b' i (TypedModule b i) inferModule (IR.Module mname mgov defs blessed imports impl mh info) = do fv <- view tcFree @@ -1443,7 +1444,7 @@ inferTermGen term = do inferTopLevel :: TypeOfBuiltin b => Loaded reso i - -> IR.TopLevel Name b i + -> IR.TopLevel Name IRType b i -> InferM s reso i (TypedTopLevel b i, Loaded reso i) inferTopLevel loaded = \case IR.TLModule m -> do @@ -1463,7 +1464,7 @@ inferTopLevel loaded = \case inferReplTopLevel :: TypeOfBuiltin b => Loaded reso i - -> IR.ReplTopLevel Name b i + -> IR.ReplTopLevel Name IRType b i -> InferM s reso i (TypedReplTopLevel b i) inferReplTopLevel loaded = \case IR.RTLModule m -> do From 8b137cdd592ca462db12ed8100ecdf1eb6dfa25b Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 24 Aug 2023 15:53:42 -0500 Subject: [PATCH 11/66] I guess I figured out TC definitions --- typed-core/Pact/Core/IR/Typecheck.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 70387fb44..56f262c8b 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -32,7 +32,7 @@ module Pact.Core.IR.Typecheck ) where import Control.Lens hiding (Level) -import Control.Monad ( when, unless, zipWithM ) +import Control.Monad ( when, unless ) import Control.Monad.Reader import Control.Monad.ST -- import Control.Monad.ST.Unsafe(unsafeIOToST, unsafeSTToIO) @@ -57,14 +57,15 @@ import qualified Data.RAList as RAList import qualified Data.Set as Set import Pact.Core.Builtin -import Pact.Core.Type(PrimType(..), Arg(..), TypedArg(..)) +import Pact.Core.Type(PrimType(..), Arg(..), TypedArg(..), BuiltinTC(..)) import Pact.Core.Typed.Type import Pact.Core.Names -import Pact.Core.Errors import Pact.Core.Persistence import Pact.Core.Capabilities +import qualified Pact.Core.Type as IR import qualified Pact.Core.IR.Term as IR import qualified Pact.Core.Typed.Term as Typed +import qualified Pact.Core.Typed.Type as Typed -- inference based on https://okmij.org/ftp/ML/generalization.html -- Note: Type inference levels in the types @@ -116,8 +117,8 @@ data TCEnv s b i makeLenses ''TCEnv -type TCType s = Type (TvRef s) -type TCPred s = Pred (TvRef s) +type TCType s = Typed.Type (TvRef s) +type TCPred s = Typed.Pred (TvRef s) -- | Term emitted by desugar type IRType = IR.Type From c6629f9eb49dfa7210551eb6013df36b8436124b Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 24 Aug 2023 16:42:23 -0500 Subject: [PATCH 12/66] New primitives to t-c's TypeOfBuilting --- typed-core/Pact/Core/IR/Typecheck.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 56f262c8b..99b0bb44a 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -349,6 +349,13 @@ instance TypeOfBuiltin RawBuiltin where TypeScheme [] [] (TyString :~> TyString) RawStrToList -> TypeScheme [] [] (TyString :~> TyList TyString) + RawSort -> let + aVar = nd "a" 0 + a = TyVar aVar + in TypeScheme [aVar] [Pred Ord a] (TyList a :~> TyList a) + RawSortObject -> error "sort object TODO" -- TODO + RawContains -> error "contains TODO" -- TODO + RawRemove -> error "remove TODO" -- TODO where nd b a = NamedDeBruijn a b unaryNumType = From 0407f7477799d237a92086bac4cc55b918f2596f Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 24 Aug 2023 17:01:03 -0500 Subject: [PATCH 13/66] Split _dbg{Pred,Type} to IR and TC versions --- typed-core/Pact/Core/IR/Typecheck.hs | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 99b0bb44a..518115a75 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -437,8 +437,8 @@ _dbgTypedTerm = \case Typed.Let n e1 e2 i -> Typed.Let n <$> _dbgTypedTerm e1 <*> _dbgTypedTerm e2 <*> pure i Typed.Builtin (b, tys, preds) i -> do - tys' <- traverse _dbgType tys - preds' <- traverse _dbgPred preds + tys' <- traverse _dbgTCType tys + preds' <- traverse _dbgTCPred preds pure (Typed.Builtin (b, tys', preds') i) Typed.Constant l i -> pure (Typed.Constant l i) Typed.TyApp t nelty i -> @@ -487,10 +487,25 @@ _dbgTvRef tv = readTvRef tv >>= \case ty' <- _dbgType ty pure $ "linked type<" <> T.pack (show ty') <> ">" -_dbgPred :: TCPred s -> InferM s b i (Pred Text) -_dbgPred (Pred i t) = Pred i <$> _dbgType t +_dbgTCPred :: TCPred s -> InferM s b i (Pred Text) +_dbgTCPred = error "dbgPred" -- TODO predicates -_dbgType :: TCType s -> InferM s b i (Type Text) +_dbgTCType :: TCType s -> InferM s b i (Type Text) +_dbgTCType = \case + TyVar tv -> readTvRef tv >>= \case + Unbound u l _ -> pure (TyVar ("unbound" <> T.pack (show (u, l)))) + Bound u l -> pure (TyVar ("bound" <> T.pack (show (u, l)))) + Link ty -> _dbgType ty + TyFun l r -> TyFun <$> _dbgType l <*> _dbgType r + TyList t -> TyList <$> _dbgType t + TyPrim p -> pure (TyPrim p) + TyModRef mr -> pure (TyModRef mr) + TyForall {} -> error "impredicative" + +_dbgPred :: Pred (TvRef s) -> InferM s b i (Pred Text) +_dbgPred (Pred b t) = Pred b <$> _dbgType t + +_dbgType :: Type (TvRef s) -> InferM s b i (Type Text) _dbgType = \case TyVar tv -> readTvRef tv >>= \case Unbound u l _ -> pure (TyVar ("unbound" <> T.pack (show (u, l)))) From 3a2c6ae856f0ae03348deaee5d6033ba2d06591d Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 24 Aug 2023 17:28:54 -0500 Subject: [PATCH 14/66] tyFunToArgList is useful, add it back to t-c --- typed-core/Pact/Core/Typed/Type.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/typed-core/Pact/Core/Typed/Type.hs b/typed-core/Pact/Core/Typed/Type.hs index 651c6dca9..c9d8bd470 100644 --- a/typed-core/Pact/Core/Typed/Type.hs +++ b/typed-core/Pact/Core/Typed/Type.hs @@ -91,3 +91,11 @@ data TypeScheme tv = newtype Schema tv = Schema { _schema :: Map Field (Type tv) } deriving (Eq, Show) + +tyFunToArgList :: Type n -> ([Type n], Type n) +tyFunToArgList (TyFun l r) = + unFun [l] r + where + unFun args (TyFun l' r') = unFun (l':args) r' + unFun args ret = (reverse args, ret) +tyFunToArgList r = ([], r) From e8c4487ab544e1eb72d3bb4841066a7e97fb82b6 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 24 Aug 2023 17:35:26 -0500 Subject: [PATCH 15/66] Make toTypedArg fail explicitly on Nothing-annotated inputs --- typed-core/Pact/Core/IR/Typecheck.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 518115a75..2a21a259a 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -997,7 +997,9 @@ generalizeWithTerm' ty pp term = do liftType :: Type Void -> Type a liftType = fmap absurd +toTypedArg :: Arg ty -> TypedArg ty toTypedArg (Arg n (Just ty)) = TypedArg n ty +toTypedArg (Arg _ Nothing) = error "toTypedArg TODO must have type" checkTermType :: (TypeOfBuiltin b) From 860e6bec0d0e4f3be2d5b879d848335318074f63 Mon Sep 17 00:00:00 2001 From: rsoeldner Date: Fri, 25 Aug 2023 08:38:01 +0200 Subject: [PATCH 16/66] update flakes --- flake.lock | 530 ++++++----------------------------------------------- flake.nix | 19 +- 2 files changed, 74 insertions(+), 475 deletions(-) diff --git a/flake.lock b/flake.lock index d9d6efd1c..cfa63b023 100644 --- a/flake.lock +++ b/flake.lock @@ -16,21 +16,6 @@ "type": "github" } }, - "blank": { - "locked": { - "lastModified": 1625557891, - "narHash": "sha256-O8/MWsPBGhhyPoPLHZAuoZiiHo9q6FLlEeIDEXuj6T4=", - "owner": "divnix", - "repo": "blank", - "rev": "5a5d2684073d9f563072ed07c871d577a6c614a8", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "blank", - "type": "github" - } - }, "cabal-32": { "flake": false, "locked": { @@ -98,64 +83,6 @@ "type": "github" } }, - "devshell": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1663445644, - "narHash": "sha256-+xVlcK60x7VY1vRJbNUEAHi17ZuoQxAIH4S4iUFUGBA=", - "owner": "numtide", - "repo": "devshell", - "rev": "e3dc3e21594fe07bdb24bdf1c8657acaa4cb8f66", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "devshell", - "type": "github" - } - }, - "dmerge": { - "inputs": { - "nixlib": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ], - "yants": [ - "haskellNix", - "tullia", - "std", - "yants" - ] - }, - "locked": { - "lastModified": 1659548052, - "narHash": "sha256-fzI2gp1skGA8mQo/FBFrUAtY0GQkAIAaV/V127TJPyY=", - "owner": "divnix", - "repo": "data-merge", - "rev": "d160d18ce7b1a45b88344aa3f13ed1163954b497", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "data-merge", - "type": "github" - } - }, "flake-compat": { "flake": false, "locked": { @@ -173,32 +100,16 @@ "type": "github" } }, - "flake-compat_2": { - "flake": false, - "locked": { - "lastModified": 1650374568, - "narHash": "sha256-Z+s0J8/r907g149rllvwhb4pKi8Wam5ij0st8PwAh+E=", - "owner": "edolstra", - "repo": "flake-compat", - "rev": "b4a34015c698c7793d592d66adbab377907a2be8", - "type": "github" - }, - "original": { - "owner": "edolstra", - "repo": "flake-compat", - "type": "github" - } - }, "flake-utils": { "inputs": { "systems": "systems" }, "locked": { - "lastModified": 1681202837, - "narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=", + "lastModified": 1689068808, + "narHash": "sha256-6ixXo3wt24N/melDWjq70UuHQLxGV8jZvooRanIHXw0=", "owner": "numtide", "repo": "flake-utils", - "rev": "cfacdce06f30d2b68473a46042957675eebb3401", + "rev": "919d646de7be200f3bf08cb76ae1f09402b6f9b4", "type": "github" }, "original": { @@ -223,36 +134,6 @@ "type": "github" } }, - "flake-utils_3": { - "locked": { - "lastModified": 1653893745, - "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_4": { - "locked": { - "lastModified": 1659877975, - "narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "c0e246b9b83f637f4681389ecabcb2681b4f3af0", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, "ghc-8.6.5-iohk": { "flake": false, "locked": { @@ -270,33 +151,14 @@ "type": "github" } }, - "gomod2nix": { - "inputs": { - "nixpkgs": "nixpkgs_2", - "utils": "utils" - }, - "locked": { - "lastModified": 1655245309, - "narHash": "sha256-d/YPoQ/vFn1+GTmSdvbSBSTOai61FONxB4+Lt6w/IVI=", - "owner": "tweag", - "repo": "gomod2nix", - "rev": "40d32f82fc60d66402eb0972e6e368aeab3faf58", - "type": "github" - }, - "original": { - "owner": "tweag", - "repo": "gomod2nix", - "type": "github" - } - }, "hackage": { "flake": false, "locked": { - "lastModified": 1682555144, - "narHash": "sha256-A64bJ9MZhNplD74OQOOF+JZq4BaV2gAuYuIZC/6WA94=", + "lastModified": 1692318155, + "narHash": "sha256-e4npK3xeIIIzq1MDFYhpT3cR37DtEttOdGE7uFi71PQ=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "1cf7e1a3746cc285aeebb0f87fbed10e23aa6b70", + "rev": "0a259b13134e5ac7f9ca408365fd240bd4b42645", "type": "github" }, "original": { @@ -317,6 +179,7 @@ "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", "hackage": "hackage", "hls-1.10": "hls-1.10", + "hls-2.0": "hls-2.0", "hpc-coveralls": "hpc-coveralls", "hydra": "hydra", "iserv-proxy": "iserv-proxy", @@ -329,17 +192,17 @@ "nixpkgs-2111": "nixpkgs-2111", "nixpkgs-2205": "nixpkgs-2205", "nixpkgs-2211": "nixpkgs-2211", + "nixpkgs-2305": "nixpkgs-2305", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", - "stackage": "stackage", - "tullia": "tullia" + "stackage": "stackage" }, "locked": { - "lastModified": 1682583633, - "narHash": "sha256-ws/1ZuZHboqMGzd2Zdfa7o5Sq1V2AgTUSZQkVY1N8pQ=", + "lastModified": 1692319830, + "narHash": "sha256-KD5SPPtJETa83lWr5WwhWWRbSelGhGSkeZ7cqweJfoc=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "6ab363fc7df582147a0629ba6df064ea96c500b0", + "rev": "90e45988f1ad35d55e890cef16d7b1a5de5e6196", "type": "github" }, "original": { @@ -365,6 +228,23 @@ "type": "github" } }, + "hls-2.0": { + "flake": false, + "locked": { + "lastModified": 1687698105, + "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "783905f211ac63edf982dd1889c671653327e441", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.0.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, "hpc-coveralls": { "flake": false, "locked": { @@ -404,37 +284,14 @@ "type": "indirect" } }, - "incl": { - "inputs": { - "nixlib": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1669263024, - "narHash": "sha256-E/+23NKtxAqYG/0ydYgxlgarKnxmDbg6rCMWnOBqn9Q=", - "owner": "divnix", - "repo": "incl", - "rev": "ce7bebaee048e4cd7ebdb4cee7885e00c4e2abca", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "incl", - "type": "github" - } - }, "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1670983692, - "narHash": "sha256-avLo34JnI9HNyOuauK5R69usJm+GfW3MlyGlYxZhTgY=", + "lastModified": 1688517130, + "narHash": "sha256-hUqfxSlo+ffqVdkSZ1EDoB7/ILCL25eYkcCXW9/P3Wc=", "ref": "hkm/remote-iserv", - "rev": "50d0abb3317ac439a4e7495b185a64af9b7b9300", - "revCount": 10, + "rev": "9151db2a9a61d7f5fe52ff8836f18bbd0fd8933c", + "revCount": 13, "type": "git", "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" }, @@ -460,35 +317,6 @@ "type": "github" } }, - "n2c": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1665039323, - "narHash": "sha256-SAh3ZjFGsaCI8FRzXQyp56qcGdAqgKEfJWPCQ0Sr7tQ=", - "owner": "nlewo", - "repo": "nix2container", - "rev": "b008fe329ffb59b67bf9e7b08ede6ee792f2741a", - "type": "github" - }, - "original": { - "owner": "nlewo", - "repo": "nix2container", - "type": "github" - } - }, "nix": { "inputs": { "lowdown-src": "lowdown-src", @@ -510,95 +338,6 @@ "type": "github" } }, - "nix-nomad": { - "inputs": { - "flake-compat": "flake-compat_2", - "flake-utils": [ - "haskellNix", - "tullia", - "nix2container", - "flake-utils" - ], - "gomod2nix": "gomod2nix", - "nixpkgs": [ - "haskellNix", - "tullia", - "nixpkgs" - ], - "nixpkgs-lib": [ - "haskellNix", - "tullia", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1658277770, - "narHash": "sha256-T/PgG3wUn8Z2rnzfxf2VqlR1CBjInPE0l1yVzXxPnt0=", - "owner": "tristanpemble", - "repo": "nix-nomad", - "rev": "054adcbdd0a836ae1c20951b67ed549131fd2d70", - "type": "github" - }, - "original": { - "owner": "tristanpemble", - "repo": "nix-nomad", - "type": "github" - } - }, - "nix2container": { - "inputs": { - "flake-utils": "flake-utils_3", - "nixpkgs": "nixpkgs_3" - }, - "locked": { - "lastModified": 1658567952, - "narHash": "sha256-XZ4ETYAMU7XcpEeAFP3NOl9yDXNuZAen/aIJ84G+VgA=", - "owner": "nlewo", - "repo": "nix2container", - "rev": "60bb43d405991c1378baf15a40b5811a53e32ffa", - "type": "github" - }, - "original": { - "owner": "nlewo", - "repo": "nix2container", - "type": "github" - } - }, - "nixago": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixago-exts": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1661824785, - "narHash": "sha256-/PnwdWoO/JugJZHtDUioQp3uRiWeXHUdgvoyNbXesz8=", - "owner": "nix-community", - "repo": "nixago", - "rev": "8c1f9e5f1578d4b2ea989f618588d62a335083c3", - "type": "github" - }, - "original": { - "owner": "nix-community", - "repo": "nixago", - "type": "github" - } - }, "nixpkgs": { "locked": { "lastModified": 1657693803, @@ -665,11 +404,11 @@ }, "nixpkgs-2205": { "locked": { - "lastModified": 1672580127, - "narHash": "sha256-3lW3xZslREhJogoOkjeZtlBtvFMyxHku7I/9IVehhT8=", + "lastModified": 1685573264, + "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "0874168639713f547c05947c76124f78441ea46c", + "rev": "380be19fbd2d9079f677978361792cb25e8a3635", "type": "github" }, "original": { @@ -681,11 +420,11 @@ }, "nixpkgs-2211": { "locked": { - "lastModified": 1675730325, - "narHash": "sha256-uNvD7fzO5hNlltNQUAFBPlcEjNG5Gkbhl/ROiX+GZU4=", + "lastModified": 1688392541, + "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "b7ce17b1ebf600a72178f6302c77b6382d09323f", + "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", "type": "github" }, "original": { @@ -695,86 +434,55 @@ "type": "github" } }, - "nixpkgs-regression": { - "locked": { - "lastModified": 1643052045, - "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", - "type": "github" - }, - "original": { - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", - "type": "github" - } - }, - "nixpkgs-unstable": { + "nixpkgs-2305": { "locked": { - "lastModified": 1675758091, - "narHash": "sha256-7gFSQbSVAFUHtGCNHPF7mPc5CcqDk9M2+inlVPZSneg=", + "lastModified": 1690680713, + "narHash": "sha256-NXCWA8N+GfSQyoN7ZNiOgq/nDJKOp5/BHEpiZP8sUZw=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "747927516efcb5e31ba03b7ff32f61f6d47e7d87", + "rev": "b81af66deb21f73a70c67e5ea189568af53b1e8c", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-unstable", + "ref": "nixpkgs-23.05-darwin", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs_2": { + "nixpkgs-regression": { "locked": { - "lastModified": 1653581809, - "narHash": "sha256-Uvka0V5MTGbeOfWte25+tfRL3moECDh1VwokWSZUdoY=", + "lastModified": 1643052045, + "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "83658b28fe638a170a19b8933aa008b30640fbd1", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixos-unstable", "repo": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", "type": "github" } }, - "nixpkgs_3": { + "nixpkgs-unstable": { "locked": { - "lastModified": 1654807842, - "narHash": "sha256-ADymZpr6LuTEBXcy6RtFHcUZdjKTBRTMYwu19WOx17E=", + "lastModified": 1690720142, + "narHash": "sha256-GywuiZjBKfFkntQwpNQfL+Ksa2iGjPprBGL0/psgRZM=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "fc909087cc3386955f21b4665731dbdaceefb1d8", + "rev": "3acb5c4264c490e7714d503c7166a3fde0c51324", "type": "github" }, "original": { "owner": "NixOS", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_4": { - "locked": { - "lastModified": 1665087388, - "narHash": "sha256-FZFPuW9NWHJteATOf79rZfwfRn5fE0wi9kRzvGfDHPA=", - "owner": "nixos", - "repo": "nixpkgs", - "rev": "95fda953f6db2e9496d2682c4fc7b82f959878f7", - "type": "github" - }, - "original": { - "owner": "nixos", "ref": "nixpkgs-unstable", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs_5": { + "nixpkgs_2": { "locked": { "lastModified": 1669833724, "narHash": "sha256-/HEZNyGbnQecrgJnfE8d0WC5c1xuPSD2LUpB6YXlg4c=", @@ -790,21 +498,6 @@ "type": "github" } }, - "nosys": { - "locked": { - "lastModified": 1667881534, - "narHash": "sha256-FhwJ15uPLRsvaxtt/bNuqE/ykMpNAPF0upozFKhTtXM=", - "owner": "divnix", - "repo": "nosys", - "rev": "2d0d5207f6a230e9d0f660903f8db9807b54814f", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "nosys", - "type": "github" - } - }, "old-ghc-nix": { "flake": false, "locked": { @@ -826,17 +519,17 @@ "inputs": { "flake-utils": "flake-utils", "haskellNix": "haskellNix", - "nixpkgs": "nixpkgs_5" + "nixpkgs": "nixpkgs_2" } }, "stackage": { "flake": false, "locked": { - "lastModified": 1682467738, - "narHash": "sha256-zV/OwQDZt2rignAWhEEL3fa3+pMd9q1+2zRoNtDJi4s=", + "lastModified": 1692317324, + "narHash": "sha256-AofEuurJHrfMljrCAkMKTWBC5xGluhBZiAfHQ73224Y=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "fafaa2484ec29531796569f85d20ff30c363e8fc", + "rev": "4812a420235589a74f9278cca81f6dbf74ffb42f", "type": "github" }, "original": { @@ -845,51 +538,6 @@ "type": "github" } }, - "std": { - "inputs": { - "arion": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "blank": "blank", - "devshell": "devshell", - "dmerge": "dmerge", - "flake-utils": "flake-utils_4", - "incl": "incl", - "makes": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "microvm": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "n2c": "n2c", - "nixago": "nixago", - "nixpkgs": "nixpkgs_4", - "nosys": "nosys", - "yants": "yants" - }, - "locked": { - "lastModified": 1674526466, - "narHash": "sha256-tMTaS0bqLx6VJ+K+ZT6xqsXNpzvSXJTmogkraBGzymg=", - "owner": "divnix", - "repo": "std", - "rev": "516387e3d8d059b50e742a2ff1909ed3c8f82826", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "std", - "type": "github" - } - }, "systems": { "locked": { "lastModified": 1681028828, @@ -904,68 +552,6 @@ "repo": "default", "type": "github" } - }, - "tullia": { - "inputs": { - "nix-nomad": "nix-nomad", - "nix2container": "nix2container", - "nixpkgs": [ - "haskellNix", - "nixpkgs" - ], - "std": "std" - }, - "locked": { - "lastModified": 1675695930, - "narHash": "sha256-B7rEZ/DBUMlK1AcJ9ajnAPPxqXY6zW2SBX+51bZV0Ac=", - "owner": "input-output-hk", - "repo": "tullia", - "rev": "621365f2c725608f381b3ad5b57afef389fd4c31", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "tullia", - "type": "github" - } - }, - "utils": { - "locked": { - "lastModified": 1653893745, - "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "yants": { - "inputs": { - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1667096281, - "narHash": "sha256-wRRec6ze0gJHmGn6m57/zhz/Kdvp9HS4Nl5fkQ+uIuA=", - "owner": "divnix", - "repo": "yants", - "rev": "d18f356ec25cb94dc9c275870c3a7927a10f8c3c", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "yants", - "type": "github" - } } }, "root": "root", diff --git a/flake.nix b/flake.nix index ea80a4e13..f2f30690d 100644 --- a/flake.nix +++ b/flake.nix @@ -24,10 +24,10 @@ pact-core = final.haskell-nix.project' { src = ./.; - compiler-nix-name = "ghc8107"; + compiler-nix-name = "ghc962"; shell.tools = { cabal = {}; - # haskell-language-server = {}; + haskell-language-server = {}; }; shell.buildInputs = with pkgs; [ zlib @@ -37,7 +37,14 @@ }; }) ]; - in flake // { + # This package depends on other packages at buildtime, but its output does not + # depend on them. This way, we don't have to download the entire closure to verify + # that those packages build. + mkCheck = name: package: pkgs.runCommand ("check-"+name) {} '' + echo ${name}: ${package} + echo works > $out + ''; + in flake // rec { packages.default = flake.packages."pact-core:exe:repl"; devShell = pkgs.haskellPackages.shellFor { @@ -46,9 +53,15 @@ buildInputs = with pkgs.haskellPackages; [ cabal-install + haskell-language-server ]; withHoogle = true; }; + packages.check = pkgs.runCommand "check" {} '' + echo ${mkCheck "pact-core" packages.default} + echo ${mkCheck "devShell" flake.devShell} + echo works > $out + ''; }); } From 6c2fc565abb417498140f3a0ba019dba09231626 Mon Sep 17 00:00:00 2001 From: rsoeldner Date: Fri, 25 Aug 2023 08:38:22 +0200 Subject: [PATCH 17/66] add nix building + cache action --- .github/workflows/nix.yml | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 .github/workflows/nix.yml diff --git a/.github/workflows/nix.yml b/.github/workflows/nix.yml new file mode 100644 index 000000000..e1b7e475d --- /dev/null +++ b/.github/workflows/nix.yml @@ -0,0 +1,34 @@ +name: Build and cache with Nix + +on: + workflow_dispatch: + push: + +jobs: + build-and-cache: + runs-on: ${{ matrix.os }} + strategy: + matrix: + os: [ubuntu-latest, mac-m1] + steps: + - name: Checkout repository + uses: actions/checkout@v3 + + - name: Set up Nix with caching + uses: kadena-io/setup-nix-with-cache@v1 + with: + cache_url: s3://nixcache.chainweb.com?region=us-east-1 + signing_private_key: ${{ secrets.NIX_CACHE_PRIVATE_KEY }} + + - name: Set up AWS credentials + uses: aws-actions/configure-aws-credentials@v2 + with: + aws-access-key-id: ${{ secrets.NIX_CACHE_AWS_ACCESS_KEY_ID }} + aws-secret-access-key: ${{ secrets.NIX_CACHE_AWS_SECRET_ACCESS_KEY }} + aws-region: us-east-1 + + - name: Build and cache artifacts + timeout-minutes: 740 + run: | + echo Building the default package and its devShell + nix build .#check From 79bd07611818d353cf6319897d26f5c28f0eca83 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Fri, 25 Aug 2023 12:06:54 -0500 Subject: [PATCH 18/66] `let` now always has the type (and the var name is in the arg) --- typed-core/Pact/Core/IR/Typecheck.hs | 21 +++++---------------- 1 file changed, 5 insertions(+), 16 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 2a21a259a..67e89a110 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1053,22 +1053,11 @@ checkTermType checkty = \case where unifyArg (_, Just tl) tr = unify (liftType tl) tr i unifyArg _ _ = pure () - IR.Let txt m_ty e1 e2 i -> - case m_ty of - Just lty -> do - (_, e1', pe1) <- checkTermType (liftType lty) e1 - (_, e2', pe2) <- - locally tcVarEnv (RAList.cons (liftType lty)) $ checkTermType checkty e2 - let term' = Typed.Let txt e1' e2' i - pure (checkty, term', pe1 ++ pe2) - Nothing -> do - enterLevel - (te1, e1', pe1) <- inferTerm e1 - leaveLevel - (_, e2', pe2) <- - locally tcVarEnv (RAList.cons te1) $ checkTermType checkty e2 - let term' = Typed.Let txt e1' e2' i - pure (checkty, term', pe1 ++ pe2) + IR.Let lty e1 e2 i -> do + (_, e1', pe1) <- checkTermType (liftType lty) e1 + (_, e2', pe2) <- locally tcVarEnv (RAList.cons (liftType lty)) $ checkTermType checkty e2 + let term' = Typed.Let (_argName lty) e1' e2' i + pure (checkty, term', pe1 ++ pe2) IR.App te (h :| hs) i -> do (tapp, te', pe1) <- inferTerm te (rty, xs, ps) <- foldlM inferFunctionArgs (tapp, [], []) (h:hs) From 2dbf46329c915cb3f512331f2ee853e84b4715c0 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Fri, 25 Aug 2023 12:18:41 -0500 Subject: [PATCH 19/66] Dummy-add ObjectLit to pattern matches where it's needed --- typed-core/Pact/Core/IR/Typecheck.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 67e89a110..b2eaf1bfe 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1167,6 +1167,7 @@ checkTermType checkty = \case _ -> error "boom" _ -> error "boom" IR.Error txt i -> pure (checkty, Typed.Error checkty txt i, []) + IR.ObjectLit{} -> error "TODO" -- TODO new ctor checkCapArgs @@ -1334,6 +1335,7 @@ inferTerm = \case IR.Error e i -> do ty <- TyVar <$> newTvRef pure (ty, Typed.Error ty e i, []) + IR.ObjectLit{} -> error "inferTerm TODO" -- TODO new ctor -- Todo: generic types? -- We can't generalize yet since From 216ccd2a5d24e71dd3d4b1ae725052adb520d0e3 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Fri, 25 Aug 2023 12:20:31 -0500 Subject: [PATCH 20/66] One more place where the type was expected to be possibly unannotated --- typed-core/Pact/Core/IR/Typecheck.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index b2eaf1bfe..d096f81ad 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1245,11 +1245,9 @@ inferTerm = \case -- preds' = concat (pte : NE.toList (view _3 <$> as)) -- unify te (foldr TyFun tv1 tys) i -- pure (tv1, Typed.App e' args' i, preds') - IR.Let n mty e1 e2 i -> do + IR.Let ty e1 e2 i -> do enterLevel - (te1, e1', pe1) <- case mty of - Nothing -> inferTerm e1 - Just ty -> checkTermType (liftType ty) e1 + (te1, e1', pe1) <- checkTermType (liftType ty) e1 leaveLevel -- Note: generalization is turned off. -- (ts, e1Qual, deferred) <- generalizeWithTerm te1 pe1 e1Unqual From e9c30b76b92247d43e3fe0692ae66a20a5d58676 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Fri, 25 Aug 2023 12:22:04 -0500 Subject: [PATCH 21/66] More extra fields --- typed-core/Pact/Core/IR/Typecheck.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index d096f81ad..0ad674c0d 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1040,7 +1040,7 @@ checkTermType checkty = \case pure (TyModRef iface, Typed.Var irn i, []) _ -> error "incorrect type" _ -> error "checking modref against incorrect type" - IR.Lam ne te i -> + IR.Lam _info ne te i -> case tyFunToArgList checkty of (tl, ret) -> do when (length tl /= NE.length ne) $ error "Arguments mismatch" @@ -1212,7 +1212,7 @@ inferTerm = \case pure (TyModRef iface, v', []) [] -> error "Module reference does not implement any interfaces" _ -> error "Cannot infer module reference " - IR.Lam nts e i -> do + IR.Lam _info nts e i -> do let names = fst <$> nts ntys <- traverse withTypeInfo nts -- Todo: bidirectionality From 9b5b2ff45f7721049f1d74d59513ffa1513182e3 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Mon, 28 Aug 2023 13:29:40 -0500 Subject: [PATCH 22/66] liftType now actually converts the type from IR to TC --- typed-core/Pact/Core/IR/Typecheck.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 0ad674c0d..1f0bdc18f 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -994,8 +994,13 @@ generalizeWithTerm' ty pp term = do gen' (TyModRef mr) = pure ([], TyModRef mr) gen' t@TyForall{} = pure ([], t) -liftType :: Type Void -> Type a -liftType = fmap absurd +liftType :: IR.Type -> Type a +liftType = \case + IR.TyPrim prim -> TyPrim prim + IR.TyList ty -> TyList $ liftType ty + IR.TyModRef modName -> TyModRef modName + IR.TyObject _schema -> error "TODO" -- TyObject schema + IR.TyTable _schema -> error "TODO" -- TyTable schema toTypedArg :: Arg ty -> TypedArg ty toTypedArg (Arg n (Just ty)) = TypedArg n ty From 8c0e0277c815abb631d463000580bf773114de2e Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Mon, 28 Aug 2023 13:45:12 -0500 Subject: [PATCH 23/66] Fix IR.Lam and IR.Let handling in TC --- typed-core/Pact/Core/IR/Typecheck.hs | 44 +++++++++++++++------------- 1 file changed, 24 insertions(+), 20 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 1f0bdc18f..4d8c71384 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1045,24 +1045,26 @@ checkTermType checkty = \case pure (TyModRef iface, Typed.Var irn i, []) _ -> error "incorrect type" _ -> error "checking modref against incorrect type" - IR.Lam _info ne te i -> + IR.Lam _info irArgs te i -> case tyFunToArgList checkty of (tl, ret) -> do - when (length tl /= NE.length ne) $ error "Arguments mismatch" - let zipped = NE.zip ne (NE.fromList tl) + when (length tl /= NE.length irArgs) $ error "Arguments mismatch" + let zipped = NE.zip irArgs (NE.fromList tl) traverse_ (uncurry unifyArg) zipped let args = RAList.fromList $ reverse tl (_, te', preds) <- locally tcVarEnv (args RAList.++) $ checkTermType ret te - let ne' = over _1 fst <$> zipped + let ne' = over _1 _argName <$> zipped pure (checkty, Typed.Lam ne' te' i, preds) where - unifyArg (_, Just tl) tr = unify (liftType tl) tr i + unifyArg (Arg _ (Just tl)) tr = unify (liftType tl) tr i unifyArg _ _ = pure () - IR.Let lty e1 e2 i -> do - (_, e1', pe1) <- checkTermType (liftType lty) e1 - (_, e2', pe2) <- locally tcVarEnv (RAList.cons (liftType lty)) $ checkTermType checkty e2 - let term' = Typed.Let (_argName lty) e1' e2' i - pure (checkty, term', pe1 ++ pe2) + IR.Let (Arg name mlty) e1 e2 i + | Just lty <- mlty -> do + (_, e1', pe1) <- checkTermType (liftType lty) e1 + (_, e2', pe2) <- locally tcVarEnv (RAList.cons (liftType lty)) $ checkTermType checkty e2 + let term' = Typed.Let name e1' e2' i + pure (checkty, term', pe1 ++ pe2) + | otherwise -> error "must have the type" IR.App te (h :| hs) i -> do (tapp, te', pe1) <- inferTerm te (rty, xs, ps) <- foldlM inferFunctionArgs (tapp, [], []) (h:hs) @@ -1218,7 +1220,7 @@ inferTerm = \case [] -> error "Module reference does not implement any interfaces" _ -> error "Cannot infer module reference " IR.Lam _info nts e i -> do - let names = fst <$> nts + let names = _argName <$> nts ntys <- traverse withTypeInfo nts -- Todo: bidirectionality -- let m = IntMap.fromList $ NE.toList $ NE.zipWith (\n t -> (_irUnique n, t)) names ntys @@ -1228,7 +1230,7 @@ inferTerm = \case rty = foldr TyFun ty ntys pure (rty, Typed.Lam nts' e' i, preds) where - withTypeInfo p = case snd p of + withTypeInfo p = case _argType p of Just ty -> pure (liftType ty) Nothing -> TyVar <$> newTvRef IR.App te (h :| hs) i -> do @@ -1250,14 +1252,16 @@ inferTerm = \case -- preds' = concat (pte : NE.toList (view _3 <$> as)) -- unify te (foldr TyFun tv1 tys) i -- pure (tv1, Typed.App e' args' i, preds') - IR.Let ty e1 e2 i -> do - enterLevel - (te1, e1', pe1) <- checkTermType (liftType ty) e1 - leaveLevel - -- Note: generalization is turned off. - -- (ts, e1Qual, deferred) <- generalizeWithTerm te1 pe1 e1Unqual - (te2, e2', pe2) <- locally tcVarEnv (RAList.cons te1) $ inferTerm e2 - pure (te2, Typed.Let n e1' e2' i, pe1 ++ pe2) + IR.Let (Arg name mlty) e1 e2 i + | Just lty <- mlty -> do + enterLevel + (te1, e1', pe1) <- checkTermType (liftType lty) e1 + leaveLevel + -- Note: generalization is turned off. + -- (ts, e1Qual, deferred) <- generalizeWithTerm te1 pe1 e1Unqual + (te2, e2', pe2) <- locally tcVarEnv (RAList.cons te1) $ inferTerm e2 + pure (te2, Typed.Let name e1' e2' i, pe1 ++ pe2) + | otherwise -> error "must have the type annotated here" IR.Sequence e1 e2 i -> do (_, e1', pe1) <- inferTerm e1 (te2, e2', pe2) <- inferTerm e2 From db56cc53f1f3bfea3370653d07a766993ba27b80 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Mon, 28 Aug 2023 17:22:41 -0500 Subject: [PATCH 24/66] Ok, I guess I figured both Control.Lens.At and DefunType --- typed-core/Pact/Core/IR/Typecheck.hs | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 4d8c71384..1fbebcea6 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -32,7 +32,7 @@ module Pact.Core.IR.Typecheck ) where import Control.Lens hiding (Level) -import Control.Monad ( when, unless ) +import Control.Monad ( when, unless, zipWithM ) import Control.Monad.Reader import Control.Monad.ST -- import Control.Monad.ST.Unsafe(unsafeIOToST, unsafeSTToIO) @@ -1129,15 +1129,18 @@ checkTermType checkty = \case -- as a matter of fact, the whole above block needs the same enforcement just -- for dfuns CreateUserGuard na tes -> case _nKind na of - NTopLevel mn mh -> - view (tcFree . at (FullyQualifiedName mn (_nName na) mh)) >>= \case - Just (DefunType fty) -> do - let (args, r) = tyFunToArgList fty - unify (liftType r) TyUnit i - when (length args /= length tes) $ error "invariant broken" - vs <- zipWithM (checkTermType . liftType) args tes - let tes' = view _2 <$> vs - pure (TyGuard, CreateUserGuard na tes', concat (view _3 <$> vs)) + NTopLevel modname modhash -> + view (tcLoaded . loAllLoaded . at (FullyQualifiedName modname (_nName na) modhash)) >>= \case + Just (IR.Dfun (IR.Defun _name mirArgs mrty _term _info)) + | Just rty <- mrty + , Just irArgs <- traverse _argType mirArgs -> do + let args = liftType <$> irArgs + unify (liftType rty) TyUnit i + when (length args /= length tes) $ error "invariant broken" + vs <- zipWithM checkTermType args tes + let tes' = view _2 <$> vs + pure (TyGuard, CreateUserGuard na tes', concatMap (view _3) vs) + | otherwise -> error "unannotated types" _ -> error "boom" _ -> error "invariant broken, must refer to a top level name" From 75a3851ff4b80da4f4d27a9f0c95e3d63fbe137c Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 29 Aug 2023 13:06:14 -0500 Subject: [PATCH 25/66] Bring back findIfDef --- pact-core/Pact/Core/IR/Term.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/pact-core/Pact/Core/IR/Term.hs b/pact-core/Pact/Core/IR/Term.hs index 033da27c1..1a7578991 100644 --- a/pact-core/Pact/Core/IR/Term.hs +++ b/pact-core/Pact/Core/IR/Term.hs @@ -20,7 +20,7 @@ module Pact.Core.IR.Term where import Control.Lens -import Data.Foldable(fold) +import Data.Foldable(fold, find) import Data.Text(Text) import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict(Map) @@ -347,6 +347,10 @@ instance Plated (Term name ty builtin info) where pure (DynInvoke n t i) Error e i -> pure (Error e i) +findIfDef :: Text -> Interface name ty builtin info -> Maybe (IfDef name ty builtin info) +findIfDef f iface = + find ((== f) . ifDefName) (_ifDefns iface) + -- Todo: qualify all of these makeLenses ''Module makeLenses ''Interface From 125289c25c76fec56b6644be4fce26241928e9b0 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 29 Aug 2023 14:22:53 -0500 Subject: [PATCH 26/66] Refactor out unifyFunArgs as it's useful in a couple of places at least --- typed-core/Pact/Core/IR/Typecheck.hs | 35 +++++++++++++++++----------- 1 file changed, 21 insertions(+), 14 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 1fbebcea6..1a38c3ae6 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -42,7 +42,7 @@ import Control.Monad.Except import Data.Void -- import Data.Dynamic (Typeable) import Data.RAList(RAList) -import Data.Foldable(traverse_, foldlM) +import Data.Foldable(traverse_, foldlM, toList) import Data.Functor(($>)) import Data.STRef import Data.Maybe(mapMaybe, fromMaybe) @@ -1006,6 +1006,19 @@ toTypedArg :: Arg ty -> TypedArg ty toTypedArg (Arg n (Just ty)) = TypedArg n ty toTypedArg (Arg _ Nothing) = error "toTypedArg TODO must have type" +unifyFunArgs + :: Traversable f + => [TCType s] + -> f (Arg IR.Type) + -> i + -> InferM s b' i () +unifyFunArgs tys irArgs info + | Just irTys <- traverse _argType irArgs = do + when (length tys /= length irTys) $ error "Arguments mismatch" + let zipped = zip (toList irTys) tys + traverse_ (\(irTy, ty) -> unify (liftType irTy) ty info) zipped + | otherwise = error "unspecified arg types" + checkTermType :: (TypeOfBuiltin b) => TCType s @@ -1045,19 +1058,13 @@ checkTermType checkty = \case pure (TyModRef iface, Typed.Var irn i, []) _ -> error "incorrect type" _ -> error "checking modref against incorrect type" - IR.Lam _info irArgs te i -> - case tyFunToArgList checkty of - (tl, ret) -> do - when (length tl /= NE.length irArgs) $ error "Arguments mismatch" - let zipped = NE.zip irArgs (NE.fromList tl) - traverse_ (uncurry unifyArg) zipped - let args = RAList.fromList $ reverse tl - (_, te', preds) <- locally tcVarEnv (args RAList.++) $ checkTermType ret te - let ne' = over _1 _argName <$> zipped - pure (checkty, Typed.Lam ne' te' i, preds) - where - unifyArg (Arg _ (Just tl)) tr = unify (liftType tl) tr i - unifyArg _ _ = pure () + IR.Lam _info irArgs te i -> do + let (tl, ret) = tyFunToArgList checkty + unifyFunArgs tl irArgs i + let args = RAList.fromList $ reverse tl + (_, te', preds) <- locally tcVarEnv (args RAList.++) $ checkTermType ret te + let ne' = over _1 _argName <$> NE.zip irArgs (NE.fromList tl) + pure (checkty, Typed.Lam ne' te' i, preds) IR.Let (Arg name mlty) e1 e2 i | Just lty <- mlty -> do (_, e1', pe1) <- checkTermType (liftType lty) e1 From 041f7682fff644b55c138ee56476c41e9b950827 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 29 Aug 2023 14:27:29 -0500 Subject: [PATCH 27/66] Fix DynInvoke in checkTermType compilation --- typed-core/Pact/Core/IR/Typecheck.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 1a38c3ae6..54c3075ba 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1177,9 +1177,13 @@ checkTermType checkty = \case case tmref of TyModRef m -> view (tcModules . at m) >>= \case Just (InterfaceData iface _) -> case IR.findIfDef fn iface of - Just (IR.IfDfun df) -> do - unify (liftType (IR._ifdType df)) checkty i - pure (checkty, Typed.DynInvoke mref' fn i, preds) + Just (IR.IfDfun (IR.IfDefun _name irArgs irMRet _info)) + | Just irRet <- irMRet -> do + let (tl, ret) = tyFunToArgList checkty + unifyFunArgs tl irArgs i + unify (liftType irRet) ret i + pure (checkty, Typed.DynInvoke mref' fn i, preds) + | otherwise -> error "unannotated return type" _ -> error "boom" _ -> error "boom" _ -> error "boom" From 8451edfa70f3ade8846b4a597f55defae6c1c6bb Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 29 Aug 2023 14:47:52 -0500 Subject: [PATCH 28/66] Refactor out getTopLevelDef --- typed-core/Pact/Core/IR/Typecheck.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 54c3075ba..4bc6a30f0 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -57,6 +57,7 @@ import qualified Data.RAList as RAList import qualified Data.Set as Set import Pact.Core.Builtin +import Pact.Core.Hash (ModuleHash) import Pact.Core.Type(PrimType(..), Arg(..), TypedArg(..), BuiltinTC(..)) import Pact.Core.Typed.Type import Pact.Core.Names @@ -1019,6 +1020,15 @@ unifyFunArgs tys irArgs info traverse_ (\(irTy, ty) -> unify (liftType irTy) ty info) zipped | otherwise = error "unspecified arg types" +getTopLevelDef + :: MonadReader (TCEnv s b i) m + => Text + -> ModuleName + -> ModuleHash + -> m (Maybe (IR.Def Name IR.Type b i)) +getTopLevelDef name modname modhash = + view (tcLoaded . loAllLoaded . at (FullyQualifiedName modname name modhash)) + checkTermType :: (TypeOfBuiltin b) => TCType s @@ -1137,7 +1147,7 @@ checkTermType checkty = \case -- for dfuns CreateUserGuard na tes -> case _nKind na of NTopLevel modname modhash -> - view (tcLoaded . loAllLoaded . at (FullyQualifiedName modname (_nName na) modhash)) >>= \case + getTopLevelDef (_nName na) modname modhash >>= \case Just (IR.Dfun (IR.Defun _name mirArgs mrty _term _info)) | Just rty <- mrty , Just irArgs <- traverse _argType mirArgs -> do From a90a1101522a1931608f07bc3b4902054c2e0a3f Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 29 Aug 2023 16:02:31 -0500 Subject: [PATCH 29/66] Oops I guess liftCoreType is basically liftType --- typed-core/Pact/Core/IR/Typecheck.hs | 2 +- typed-core/Pact/Core/Typed/Type.hs | 10 ---------- 2 files changed, 1 insertion(+), 11 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 4bc6a30f0..d82e8d58f 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1047,7 +1047,7 @@ checkTermType checkty = \case NTopLevel mn _mh -> view (tcLoaded . loAllLoaded . at (FullyQualifiedName mn n _mh)) >>= \case Just (IR.DCapDfun d) -> do - let funArgs = fmap liftCoreType . toTypedArg <$> IR._dfunArgs d + let funArgs = fmap liftType . toTypedArg <$> IR._dfunArgs d funRet = maybe (error "boom") id (_dfunRType d) rty = foldr (\arg ty -> TyFun (_targType arg) ty) funRet funArgs let newVar = Typed.Var irn i diff --git a/typed-core/Pact/Core/Typed/Type.hs b/typed-core/Pact/Core/Typed/Type.hs index c9d8bd470..1a37a3504 100644 --- a/typed-core/Pact/Core/Typed/Type.hs +++ b/typed-core/Pact/Core/Typed/Type.hs @@ -15,8 +15,6 @@ import Pact.Core.Type(PrimType(..), BuiltinTC) import Pact.Core.Names import Pact.Core.Pretty -import qualified Pact.Core.Type as CoreType - data Type n = TyVar n -- ^ type variables @@ -35,14 +33,6 @@ data Type n -- ^ Tables deriving (Eq, Show, Functor, Foldable, Traversable) -liftCoreType :: CoreType.Type -> Type n -liftCoreType = \case - CoreType.TyPrim p -> TyPrim p - CoreType.TyList t -> TyList (liftCoreType t) - CoreType.TyModRef m -> TyModRef m - CoreType.TyTable{} -> error "tytable" - CoreType.TyObject{} -> error "tyobject" - pattern TyInt :: Type n pattern TyInt = TyPrim PrimInt From 9b863c0183a207255a24542f019e9167fcec82ca Mon Sep 17 00:00:00 2001 From: June <38109440+DevopsGoth@users.noreply.github.com> Date: Tue, 29 Aug 2023 15:55:01 -0600 Subject: [PATCH 30/66] Update applications.yml --- .github/workflows/applications.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.github/workflows/applications.yml b/.github/workflows/applications.yml index f7f14d72b..bd51e3f9a 100644 --- a/.github/workflows/applications.yml +++ b/.github/workflows/applications.yml @@ -3,6 +3,10 @@ name: Build and publish application binaries on: workflow_dispatch: push: + paths: + - '**' + - '!.github/**' + - '.github/workflows/applications.yml' jobs: build: From 1ed1a26bd645851c8cb04e783d6cd28887ff8465 Mon Sep 17 00:00:00 2001 From: June <38109440+DevopsGoth@users.noreply.github.com> Date: Tue, 29 Aug 2023 15:56:29 -0600 Subject: [PATCH 31/66] Proper nix.yml Caching for x86 ubuntu/mac, m1 mac --- .github/workflows/nix.yml | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/.github/workflows/nix.yml b/.github/workflows/nix.yml index e1b7e475d..108af0d7f 100644 --- a/.github/workflows/nix.yml +++ b/.github/workflows/nix.yml @@ -3,19 +3,25 @@ name: Build and cache with Nix on: workflow_dispatch: push: - + paths: + - '**' + - '!.github/**' + - '.github/workflows/nix.yml' + jobs: build-and-cache: runs-on: ${{ matrix.os }} + timeout-minutes: 740 strategy: + fail-fast: false matrix: - os: [ubuntu-latest, mac-m1] + os: [ubuntu-latest, macos-latest, macos-m1] steps: - name: Checkout repository uses: actions/checkout@v3 - name: Set up Nix with caching - uses: kadena-io/setup-nix-with-cache@v1 + uses: kadena-io/setup-nix-with-cache/by-root@v3 with: cache_url: s3://nixcache.chainweb.com?region=us-east-1 signing_private_key: ${{ secrets.NIX_CACHE_PRIVATE_KEY }} @@ -27,8 +33,10 @@ jobs: aws-secret-access-key: ${{ secrets.NIX_CACHE_AWS_SECRET_ACCESS_KEY }} aws-region: us-east-1 + - name: Give root user AWS credentials + uses: kadena-io/setup-nix-with-cache/copy-root-aws-credentials@v3 + - name: Build and cache artifacts - timeout-minutes: 740 run: | - echo Building the default package and its devShell - nix build .#check + echo Building the project and its devShell + nix build .#check --log-lines 500 --show-trace From d5450641717c5d7d5fed4f48470f93920c1fc7ff Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 30 Aug 2023 13:47:43 -0500 Subject: [PATCH 32/66] Refactor out unifyFun, as it'll be used elsewhere as well --- typed-core/Pact/Core/IR/Typecheck.hs | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index d82e8d58f..ce98a200b 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1012,7 +1012,7 @@ unifyFunArgs => [TCType s] -> f (Arg IR.Type) -> i - -> InferM s b' i () + -> InferM s b i () unifyFunArgs tys irArgs info | Just irTys <- traverse _argType irArgs = do when (length tys /= length irTys) $ error "Arguments mismatch" @@ -1020,6 +1020,20 @@ unifyFunArgs tys irArgs info traverse_ (\(irTy, ty) -> unify (liftType irTy) ty info) zipped | otherwise = error "unspecified arg types" +unifyFun + :: Traversable f + => TCType s + -> f (Arg IR.Type) + -> Maybe IR.Type + -> i + -> InferM s b i () +unifyFun funty irArgs (Just irRet) info = do + unifyFunArgs tys irArgs info + unify ret (liftType irRet) info + where + (tys, ret) = tyFunToArgList funty +unifyFun _ _ Nothing _ = error "unannotated return type" + getTopLevelDef :: MonadReader (TCEnv s b i) m => Text @@ -1187,13 +1201,9 @@ checkTermType checkty = \case case tmref of TyModRef m -> view (tcModules . at m) >>= \case Just (InterfaceData iface _) -> case IR.findIfDef fn iface of - Just (IR.IfDfun (IR.IfDefun _name irArgs irMRet _info)) - | Just irRet <- irMRet -> do - let (tl, ret) = tyFunToArgList checkty - unifyFunArgs tl irArgs i - unify (liftType irRet) ret i - pure (checkty, Typed.DynInvoke mref' fn i, preds) - | otherwise -> error "unannotated return type" + Just (IR.IfDfun (IR.IfDefun _name irArgs irMRet _info)) -> do + unifyFun checkty irArgs irMRet i + pure (checkty, Typed.DynInvoke mref' fn i, preds) _ -> error "boom" _ -> error "boom" _ -> error "boom" From 0a8a4fcb70e8b1747e466427b08739a1d4ce5f45 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 30 Aug 2023 14:02:47 -0500 Subject: [PATCH 33/66] Handle Dcap/Dfun in vars in checkTermType --- typed-core/Pact/Core/IR/Typecheck.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index ce98a200b..d49f9c8c4 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1058,17 +1058,17 @@ checkTermType checkty = \case pure (ty, v', []) Nothing -> throwTypecheckError (TCUnboundTermVariable n) i - NTopLevel mn _mh -> - view (tcLoaded . loAllLoaded . at (FullyQualifiedName mn n _mh)) >>= \case - Just (IR.DCapDfun d) -> do - let funArgs = fmap liftType . toTypedArg <$> IR._dfunArgs d - funRet = maybe (error "boom") id (_dfunRType d) - rty = foldr (\arg ty -> TyFun (_targType arg) ty) funRet funArgs - let newVar = Typed.Var irn i - unify rty checkty i - pure (rty, newVar, []) - _ -> - throwTypecheckError (TCUnboundFreeVariable mn n) i + NTopLevel mn mh -> + getTopLevelDef n mn mh >>= \case + Just (IR.Dfun df) -> do + unifyFun checkty (IR._dfunArgs df) (IR._dfunRType df) i + let rty = snd $ tyFunToArgList checkty + pure (rty, Typed.Var irn i, []) + Just (IR.DCap df) -> do + unifyFun checkty (IR._dcapArgs df) (IR._dcapRType df) i + let rty = snd $ tyFunToArgList checkty + pure (rty, Typed.Var irn i, []) + _ -> throwTypecheckError (TCUnboundFreeVariable mn n) i NModRef _ ifs -> case checkty of TyModRef mn -> do let newVar = Typed.Var irn i From 38f3c8c56cb14fef30edfad8b63a62a299395d01 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 30 Aug 2023 14:16:48 -0500 Subject: [PATCH 34/66] checkCapArgs --- typed-core/Pact/Core/IR/Typecheck.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index d49f9c8c4..574285d07 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1218,11 +1218,13 @@ checkCapArgs -> InferM s reso i ([TCTerm s raw i], [TCPred s]) checkCapArgs na tes = case _nKind na of NTopLevel mn mh -> - view (tcFree . at (FullyQualifiedName mn (_nName na) mh)) >>= \case - Just (DefcapType dcargs _) -> do - when (length dcargs /= length tes) $ error "invariant broken dcap args" - vs <- zipWithM (checkTermType . liftType) dcargs tes - pure (view _2 <$> vs, concat (view _3 <$> vs)) + getTopLevelDef (_nName na) mn mh >>= \case + Just (IR.DCap dc) + | Just dcargs <- traverse IR._argType $ IR._dcapArgs dc -> do + when (length dcargs /= length tes) $ error "invariant broken dcap args" + vs <- zipWithM (checkTermType . liftType) dcargs tes + pure (view _2 <$> vs, concat (view _3 <$> vs)) + | otherwise -> error "unannotated types" _ -> error "invariant broken" _ -> error "invariant broken" From 9b462d3a607741918d7495d71078f7094cc39c51 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 30 Aug 2023 14:40:28 -0500 Subject: [PATCH 35/66] argListToTyFun helper --- typed-core/Pact/Core/Typed/Type.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/typed-core/Pact/Core/Typed/Type.hs b/typed-core/Pact/Core/Typed/Type.hs index 1a37a3504..c13fae999 100644 --- a/typed-core/Pact/Core/Typed/Type.hs +++ b/typed-core/Pact/Core/Typed/Type.hs @@ -89,3 +89,6 @@ tyFunToArgList (TyFun l r) = unFun args (TyFun l' r') = unFun (l':args) r' unFun args ret = (reverse args, ret) tyFunToArgList r = ([], r) + +argListToTyFun :: [Type n] -> Type n -> Type n +argListToTyFun args ret = foldr TyFun ret args From 2122cb22387cc17987475e4cd8484b6652224118 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 30 Aug 2023 15:02:02 -0500 Subject: [PATCH 36/66] inferTerm for Dfuns --- typed-core/Pact/Core/IR/Typecheck.hs | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 574285d07..3e7d621a9 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1242,13 +1242,17 @@ inferTerm = \case pure (ty, v', []) Nothing -> throwTypecheckError (TCUnboundTermVariable n) i - NTopLevel mn _mh -> - view (tcFree . at (FullyQualifiedName mn n _mh)) >>= \case - Just (DefunType ty) -> do - let newVar = Typed.Var irn i - pure (liftType ty, newVar, []) - _ -> - throwTypecheckError (TCUnboundFreeVariable mn n) i + NTopLevel mn mh -> + getTopLevelDef n mn mh >>= \case + Just (IR.Dfun df) + | Just irArgs <- traverse IR._argType $ IR._dfunArgs df + , Just irRet <- IR._dfunRType df -> do + let newVar = Typed.Var irn i + args = liftType <$> irArgs + ret = liftType irRet + pure (argListToTyFun args ret, newVar, []) + | otherwise -> error "unannotated types" + _ -> throwTypecheckError (TCUnboundFreeVariable mn n) i NModRef _ ifs -> case ifs of [iface] -> do let v' = Typed.Var irn i From 299b47834204e4394ea0f251ec41e74eec72c2b2 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 30 Aug 2023 21:12:17 -0500 Subject: [PATCH 37/66] Alrighty, apparently Dcap isn't needed here --- typed-core/Pact/Core/IR/Typecheck.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 3e7d621a9..933a3b80c 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1064,10 +1064,6 @@ checkTermType checkty = \case unifyFun checkty (IR._dfunArgs df) (IR._dfunRType df) i let rty = snd $ tyFunToArgList checkty pure (rty, Typed.Var irn i, []) - Just (IR.DCap df) -> do - unifyFun checkty (IR._dcapArgs df) (IR._dcapRType df) i - let rty = snd $ tyFunToArgList checkty - pure (rty, Typed.Var irn i, []) _ -> throwTypecheckError (TCUnboundFreeVariable mn n) i NModRef _ ifs -> case checkty of TyModRef mn -> do From c44ca9a6cf37524e30d1fa907d71f52e2c4dc2a6 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 31 Aug 2023 11:58:02 -0500 Subject: [PATCH 38/66] Refactor out irFunToTc --- typed-core/Pact/Core/IR/Typecheck.hs | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 933a3b80c..38e0796df 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1224,6 +1224,16 @@ checkCapArgs na tes = case _nKind na of _ -> error "invariant broken" _ -> error "invariant broken" +irFunToTc + :: [Arg IR.Type] + -> Maybe IR.Type + -> InferM s b i ([Type a], Type a) +irFunToTc irMArgs (Just irRet) + | Just irArgs <- traverse IR._argType irMArgs = do + pure (liftType <$> irArgs, liftType irRet) + | otherwise = error "unannotated arguments" +irFunToTc _ Nothing = error "unannotated return type" + -- Todo: bidirectionality inferTerm :: (TypeOfBuiltin b) @@ -1240,14 +1250,10 @@ inferTerm = \case throwTypecheckError (TCUnboundTermVariable n) i NTopLevel mn mh -> getTopLevelDef n mn mh >>= \case - Just (IR.Dfun df) - | Just irArgs <- traverse IR._argType $ IR._dfunArgs df - , Just irRet <- IR._dfunRType df -> do - let newVar = Typed.Var irn i - args = liftType <$> irArgs - ret = liftType irRet - pure (argListToTyFun args ret, newVar, []) - | otherwise -> error "unannotated types" + Just (IR.Dfun df) -> do + (args, ret) <- irFunToTc (IR._dfunArgs df) (IR._dfunRType df) + let newVar = Typed.Var irn i + pure (argListToTyFun args ret, newVar, []) _ -> throwTypecheckError (TCUnboundFreeVariable mn n) i NModRef _ ifs -> case ifs of [iface] -> do From 3bea3f0de77b7acde73c87b8a3b6a9afce93e4f2 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 31 Aug 2023 12:04:22 -0500 Subject: [PATCH 39/66] One more _ifdType reference begone --- typed-core/Pact/Core/IR/Typecheck.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 38e0796df..22638d9e6 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1377,7 +1377,8 @@ inferTerm = \case TyModRef m -> view (tcModules . at m) >>= \case Just (InterfaceData iface _) -> case IR.findIfDef fn iface of Just (IR.IfDfun df) -> do - pure (liftType (IR._ifdType df), Typed.DynInvoke mref' fn i, preds) + (args, ret) <- irFunToTc (IR._ifdArgs df) (IR._ifdRType df) + pure (argListToTyFun args ret, Typed.DynInvoke mref' fn i, preds) _ -> error "boom" _ -> error "boom" _ -> error "boom" From d060f39cefeecf582148833308d9969129d47406 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 31 Aug 2023 14:02:34 -0500 Subject: [PATCH 40/66] liftNoFreeVars might also be useful later on --- typed-core/Pact/Core/IR/Typecheck.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 22638d9e6..14eb2ac95 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -995,6 +995,15 @@ generalizeWithTerm' ty pp term = do gen' (TyModRef mr) = pure ([], TyModRef mr) gen' t@TyForall{} = pure ([], t) +liftNoFreeVars :: Type Void -> Type a +liftNoFreeVars = \case + TyVar n -> absurd n + TyPrim prim -> TyPrim prim + TyFun t1 t2 -> TyFun (liftNoFreeVars t1) (liftNoFreeVars t2) + TyList t -> TyList (liftNoFreeVars t) + TyModRef mn -> TyModRef mn + TyForall vars t -> TyForall (absurd <$> vars) (liftNoFreeVars t) + liftType :: IR.Type -> Type a liftType = \case IR.TyPrim prim -> TyPrim prim From af18616307da503219e7c7e3950f1b433256dc2c Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 31 Aug 2023 14:20:44 -0500 Subject: [PATCH 41/66] inferDefun fixed MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is where `Type Void` comes handy — we can leverage that to get both `Type (TvRef s)` and `Type NamedDeBruijn`. --- typed-core/Pact/Core/IR/Typecheck.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 14eb2ac95..d97f19a7f 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1405,14 +1405,15 @@ inferDefun -> InferM s b' i (TypedDefun b i) inferDefun (IR.Defun name dfargs dfRetType term info) = do enterLevel - let dfTy = foldr TyFun retType dfArgs' + (argTys, ret) <- irFunToTc dfargs dfRetType + let args = zipWith (\irArg ty -> TypedArg (IR._argName irArg) (liftNoFreeVars ty)) dfargs argTys (termTy, term', preds) <- inferTerm term leaveLevel checkReducible preds (view IR.termInfo term) -- fail "typeclass constraints not supported in defun" - unify (liftType dfTy) termTy info + unify (liftNoFreeVars $ argListToTyFun argTys ret) termTy info fterm <- noTyVarsinTerm info term' - pure (Typed.Defun name (liftType dfTy) fterm info) + pure (Typed.Defun name args (liftNoFreeVars ret) fterm info) inferDefConst :: TypeOfBuiltin b From d01962b4dd9fb44cd76d4674fe6dd2175ba6171d Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 31 Aug 2023 14:58:13 -0500 Subject: [PATCH 42/66] Note for self --- typed-core/Pact/Core/IR/Typecheck.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index d97f19a7f..601f2a9a5 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1675,6 +1675,8 @@ ensureNoTyVarsPred -> InferM s b i (Pred NamedDeBruijn) ensureNoTyVarsPred i (Pred tc ty) = Pred tc <$> ensureNoTyVars i ty +-- TODO here and in ensure* functions, +-- is it really needed, or can we do the same trick as with `Type Void`? noTyVarsinTerm :: i -> TCTerm s b' i From 899fdf89fd294de4f95f7042af578375826e1ce6 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Fri, 1 Sep 2023 12:25:40 -0500 Subject: [PATCH 43/66] Refactor out toTypedArgs --- typed-core/Pact/Core/IR/Typecheck.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 601f2a9a5..52322ed5a 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1396,6 +1396,9 @@ inferTerm = \case pure (ty, Typed.Error ty e i, []) IR.ObjectLit{} -> error "inferTerm TODO" -- TODO new ctor +toTypedArgs :: [Arg ty] -> [Type Void] -> [TypedArg (Type a)] +toTypedArgs = zipWith (\irArg ty -> TypedArg (IR._argName irArg) (liftNoFreeVars ty)) + -- Todo: generic types? -- We can't generalize yet since -- we're not allowing type schemes just yet. @@ -1406,7 +1409,7 @@ inferDefun inferDefun (IR.Defun name dfargs dfRetType term info) = do enterLevel (argTys, ret) <- irFunToTc dfargs dfRetType - let args = zipWith (\irArg ty -> TypedArg (IR._argName irArg) (liftNoFreeVars ty)) dfargs argTys + let args = toTypedArgs dfargs argTys (termTy, term', preds) <- inferTerm term leaveLevel checkReducible preds (view IR.termInfo term) From 1cb1237f5b29dfc84f52e85e137208da10388a5f Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Fri, 1 Sep 2023 12:47:29 -0500 Subject: [PATCH 44/66] inferDefCap done --- typed-core/Pact/Core/IR/Typecheck.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 52322ed5a..7b0559757 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1437,13 +1437,15 @@ inferDefCap :: TypeOfBuiltin b => IR.DefCap Name IRType b i -> InferM s b' i (TypedDefCap b i) -inferDefCap (IR.DefCap name arity argtys rty term meta i) = do - let ty = foldr TyFun rty argtys - (termTy, term', preds) <- checkTermType (liftType ty) term +inferDefCap (IR.DefCap name arity dcargs dcRetType term meta i) = do + (argtys, rty) <- irFunToTc dcargs dcRetType + let ty = liftNoFreeVars $ argListToTyFun argtys rty + args = toTypedArgs dcargs argtys + (termTy, term', preds) <- checkTermType ty term checkReducible preds i - unify (liftType ty) termTy i + unify ty termTy i fterm <- noTyVarsinTerm i term' - pure (Typed.DefCap name arity argtys rty fterm meta i) + pure (Typed.DefCap name arity args (liftNoFreeVars rty) fterm meta i) inferDef :: TypeOfBuiltin b From fa435bff180d3f49054ff8b70496d43b4713cc59 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 5 Sep 2023 12:18:07 -0500 Subject: [PATCH 45/66] Split Typed.IfDefun's def to keep arg types and ret type separately This mirrors IR.IfDefun. --- typed-core/Pact/Core/Typed/Term.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/typed-core/Pact/Core/Typed/Term.hs b/typed-core/Pact/Core/Typed/Term.hs index bb7c0c330..ae170daa4 100644 --- a/typed-core/Pact/Core/Typed/Term.hs +++ b/typed-core/Pact/Core/Typed/Term.hs @@ -154,7 +154,8 @@ data Interface name tyname builtin info data IfDefun info = IfDefun { _ifdName :: Text - , _ifdType :: Type Void + , _ifdArgs :: [TypedArg (Type Void)] + , _ifdRType :: Type Void , _ifdInfo :: info } deriving Show From 8953505f76abcb1081dde5ab2befae4fc0b8141e Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 5 Sep 2023 12:23:08 -0500 Subject: [PATCH 46/66] inferIfDef done --- typed-core/Pact/Core/IR/Typecheck.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 7b0559757..95bc55d8b 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1461,11 +1461,15 @@ inferIfDef => IR.IfDef Name IRType b i -> InferM s b' i (TypedIfDef b i) inferIfDef = \case - IR.IfDfun ifd -> - pure (Typed.IfDfun (Typed.IfDefun (IR._ifdName ifd) (IR._ifdType ifd) (IR._ifdInfo ifd))) + IR.IfDfun ifd -> do + let irArgs = IR._ifdArgs ifd + (argtys, rty) <- irFunToTc irArgs (IR._ifdRType ifd) + let args = toTypedArgs irArgs argtys + pure (Typed.IfDfun (Typed.IfDefun (IR._ifdName ifd) args rty (IR._ifdInfo ifd))) IR.IfDConst dc -> Typed.IfDConst <$> inferDefConst dc - IR.IfDCap (IR.IfDefCap n argtys rty i) -> + IR.IfDCap (IR.IfDefCap n irArgs irRty i) -> do + (argtys, rty) <- irFunToTc irArgs irRty pure $ Typed.IfDCap (Typed.IfDefCap n argtys rty i) inferModule From 707128e0dbe48fdd8bd16a0bda0c9e1ce89694cc Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 5 Sep 2023 14:06:13 -0500 Subject: [PATCH 47/66] Add a typed version of defType --- typed-core/Pact/Core/Typed/Term.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/typed-core/Pact/Core/Typed/Term.hs b/typed-core/Pact/Core/Typed/Term.hs index ae170daa4..1a0721271 100644 --- a/typed-core/Pact/Core/Typed/Term.hs +++ b/typed-core/Pact/Core/Typed/Term.hs @@ -41,6 +41,7 @@ module Pact.Core.Typed.Term , CoreEvalReplTopLevel , defName , defTerm + , defType -- Prisms and lenses , _IfDfun , _IfDConst @@ -131,6 +132,12 @@ defTerm = \case DConst d -> _dcTerm d DCap d -> _dcapTerm d +defType :: Def name tyname builtin info -> Type tyname +defType = \case + Dfun d -> argListToTyFun (_targType <$> _dfunArgs d) (_dfunRType d) + DConst d -> absurd <$> _dcType d + DCap d -> argListToTyFun (_targType <$> _dcapArgs d) (_dcapRType d) + data Module name tyname builtin info = Module { _mName :: ModuleName From b01ac0eec8548817e87a3d1d2121af45fa790bfe Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 5 Sep 2023 14:08:39 -0500 Subject: [PATCH 48/66] Presumably tcFree |-> tcLoaded . loAllLoaded is a reasonable substitution But that's worth double-checking later on. --- typed-core/Pact/Core/IR/Typecheck.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 95bc55d8b..b4d7785ee 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1477,12 +1477,12 @@ inferModule => IR.Module Name IRType b i -> InferM s b' i (TypedModule b i) inferModule (IR.Module mname mgov defs blessed imports impl mh info) = do - fv <- view tcFree + fv <- view (tcLoaded . loAllLoaded) (defs', _) <- foldlM infer' ([], fv) defs pure (Typed.Module mname mgov (reverse defs') blessed imports impl mh info) where infer' (xs, m) d = do - def' <- local (set tcFree m) (inferDef d) + def' <- local (set (tcLoaded . loAllLoaded) m) (inferDef d) let name' = FullyQualifiedName mname (Typed.defName def') mh dty = fmap absurd (Typed.defType def') m' = Map.insert name' dty m From 4215b3d7556c9b79ff3eb552754fe19d814e5ad3 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 5 Sep 2023 14:07:49 -0500 Subject: [PATCH 49/66] Some more linter happiness --- typed-core/Pact/Core/IR/Typecheck.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index b4d7785ee..6791b774b 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -422,7 +422,7 @@ liftST :: ST s a -> InferM s b i a liftST action = InferT (ExceptT (Right <$> ReaderT (const action))) throwTypecheckError :: TypecheckError -> i -> InferM s b i a -throwTypecheckError te i = throwError te +throwTypecheckError te _i = throwError te _dbgTypedTerm :: TCTerm s b i @@ -1542,7 +1542,7 @@ inferTopLevel loaded = \case IR.TLInterface i -> do tci <- inferInterface i let toFqn dc = FullyQualifiedName (Typed._ifName tci) (Typed._dcName dc) (Typed._ifHash tci) - newTLs = Map.fromList $ fmap (\df -> (toFqn df, DefunType (Typed._dcType df))) $ mapMaybe (preview Typed._IfDConst) (Typed._ifDefns tci) + newTLs = Map.fromList $ (\df -> (toFqn df, DefunType (Typed._dcType df))) <$> mapMaybe (preview Typed._IfDConst) (Typed._ifDefns tci) loaded' = over loAllTyped (Map.union newTLs) loaded pure (Typed.TLInterface tci, loaded') From 8716e2e9549a9c0336bb1acd0e2e3209dec9c372 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 5 Sep 2023 14:15:21 -0500 Subject: [PATCH 50/66] Remove annoying shadowing warnings --- typed-core/Pact/Core/IR/Typecheck.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 6791b774b..ae5f40bc2 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -61,7 +61,7 @@ import Pact.Core.Hash (ModuleHash) import Pact.Core.Type(PrimType(..), Arg(..), TypedArg(..), BuiltinTC(..)) import Pact.Core.Typed.Type import Pact.Core.Names -import Pact.Core.Persistence +import Pact.Core.Persistence hiding (loaded) import Pact.Core.Capabilities import qualified Pact.Core.Type as IR import qualified Pact.Core.IR.Term as IR From 4f5a315b030ed0ed652c0954f2634d54a6dc2bdd Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 12 Sep 2023 14:16:47 -0500 Subject: [PATCH 51/66] Add a missing import --- typed-core/Pact/Core/Typed/Overload.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/typed-core/Pact/Core/Typed/Overload.hs b/typed-core/Pact/Core/Typed/Overload.hs index ea520ed2a..df5ce3825 100644 --- a/typed-core/Pact/Core/Typed/Overload.hs +++ b/typed-core/Pact/Core/Typed/Overload.hs @@ -25,6 +25,7 @@ import Data.List.NonEmpty(NonEmpty(..)) -- import qualified Data.Text as T +import Pact.Core.Type (BuiltinTC(..)) import Pact.Core.Typed.Type import Pact.Core.Names import Pact.Core.Builtin From 7b814d00b74616878fc5e03cfda8565e40b89688 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Mon, 18 Sep 2023 14:23:11 -0500 Subject: [PATCH 52/66] Change Typecheck.inferModule to just `traverse inferDef` the defs Previously, `inferModule` was inferring the types of the definitions in the module sequentially, taking into account the previously inferred types when inferring each next one. Now, 1. All top-level types are supposed to be annotated in IR as well, so there should be no reliance on the inferred types of the other definitions in the module. 2. The types of inferred (`Typed`) and non-inferred (`IR`) defs are different, and it's easy to see from types that the inference engine only depends on the non-inferred `IR` ones anyway, so looks like there's no need (and no easy way!) to keep the inferred ones in context as well. 3. Depending on the order seems funny anyway. --- typed-core/Pact/Core/IR/Typecheck.hs | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index ae5f40bc2..4a69bab30 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1477,16 +1477,8 @@ inferModule => IR.Module Name IRType b i -> InferM s b' i (TypedModule b i) inferModule (IR.Module mname mgov defs blessed imports impl mh info) = do - fv <- view (tcLoaded . loAllLoaded) - (defs', _) <- foldlM infer' ([], fv) defs - pure (Typed.Module mname mgov (reverse defs') blessed imports impl mh info) - where - infer' (xs, m) d = do - def' <- local (set (tcLoaded . loAllLoaded) m) (inferDef d) - let name' = FullyQualifiedName mname (Typed.defName def') mh - dty = fmap absurd (Typed.defType def') - m' = Map.insert name' dty m - pure (def':xs, m') + defs' <- traverse inferDef defs + pure (Typed.Module mname mgov defs' blessed imports impl mh info) inferInterface :: TypeOfBuiltin b From 4efda9c424a7664776065f2031ae26a5fd18fdb3 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 19 Sep 2023 14:11:43 -0500 Subject: [PATCH 53/66] Ditto for other top-level inference stuff Just don't update `Loaded` with the same motivation. --- typed-core/Pact/Core/IR/Typecheck.hs | 47 ++++++++-------------------- 1 file changed, 13 insertions(+), 34 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 4a69bab30..2555bd826 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1520,51 +1520,30 @@ inferTermGen term = do inferTopLevel :: TypeOfBuiltin b - => Loaded reso i - -> IR.TopLevel Name IRType b i - -> InferM s reso i (TypedTopLevel b i, Loaded reso i) -inferTopLevel loaded = \case - IR.TLModule m -> do - tcm <- inferModule m - let toFqn df = FullyQualifiedName (Typed._mName tcm) (Typed.defName df) (Typed._mHash tcm) - newTLs = Map.fromList $ (\df -> (toFqn df, Typed.defType df)) <$> Typed._mDefs tcm - loaded' = over loAllTyped (Map.union newTLs) loaded - pure (Typed.TLModule tcm, loaded') - IR.TLTerm m -> (, loaded) . Typed.TLTerm . snd <$> inferTermNonGen m - IR.TLInterface i -> do - tci <- inferInterface i - let toFqn dc = FullyQualifiedName (Typed._ifName tci) (Typed._dcName dc) (Typed._ifHash tci) - newTLs = Map.fromList $ (\df -> (toFqn df, DefunType (Typed._dcType df))) <$> mapMaybe (preview Typed._IfDConst) (Typed._ifDefns tci) - loaded' = over loAllTyped (Map.union newTLs) loaded - pure (Typed.TLInterface tci, loaded') + => IR.TopLevel Name IRType b i + -> InferM s reso i (TypedTopLevel b i) +inferTopLevel = \case + IR.TLModule m -> Typed.TLModule <$> inferModule m + IR.TLTerm m -> Typed.TLTerm . snd <$> inferTermNonGen m + IR.TLInterface i -> Typed.TLInterface <$> inferInterface i inferReplTopLevel :: TypeOfBuiltin b - => Loaded reso i - -> IR.ReplTopLevel Name IRType b i + => IR.ReplTopLevel Name IRType b i -> InferM s reso i (TypedReplTopLevel b i) -inferReplTopLevel loaded = \case - IR.RTLModule m -> do - tcm <- inferModule m - let toFqn df = FullyQualifiedName (Typed._mName tcm) (Typed.defName df) (Typed._mHash tcm) - newTLs = Map.fromList $ (\df -> (toFqn df, Typed.defType df)) <$> Typed._mDefs tcm - loaded' = over loAllTyped (Map.union newTLs) loaded - pure (Typed.RTLModule tcm) +inferReplTopLevel = \case + IR.RTLModule m -> Typed.RTLModule <$> inferModule m IR.RTLTerm m -> Typed.RTLTerm . snd <$> inferTermNonGen m -- Todo: if we don't update the module hash to update linking, -- repl defuns and defconsts will break invariants about IR.RTLDefun dfn -> do dfn' <- inferDefun dfn - let newFqn = FullyQualifiedName replModuleName (Typed._dfunName dfn') replModuleHash pure (Typed.RTLDefun dfn') IR.RTLDefConst dconst -> do dc <- inferDefConst dconst - let newFqn = FullyQualifiedName replModuleName (Typed._dcName dc) replModuleHash pure (Typed.RTLDefConst dc) IR.RTLInterface i -> do tci <- inferInterface i - let toFqn dc = FullyQualifiedName (Typed._ifName tci) (Typed._dcName dc) (Typed._ifHash tci) - newTLs = Map.fromList $ fmap (\df -> (toFqn df, DefunType (Typed._dcType df))) $ mapMaybe (preview Typed._IfDConst) (Typed._ifDefns tci) pure (Typed.RTLInterface tci) @@ -1828,15 +1807,15 @@ runInferTopLevel :: TypeOfBuiltin b => Loaded reso i -> IR.TopLevel Name IRType b i - -> Either TypecheckError (TypedTopLevel b i, Loaded reso i) + -> Either TypecheckError (TypedTopLevel b i) runInferTopLevel l tl = - runST $ runInfer l (inferTopLevel l tl) + runST $ runInfer l (inferTopLevel tl) runInferReplTopLevel :: TypeOfBuiltin b => Loaded reso i -> IR.ReplTopLevel Name IRType b i - -> Either TypecheckError (TypedReplTopLevel b i, Loaded reso i) + -> Either TypecheckError (TypedReplTopLevel b i) runInferReplTopLevel l tl = - runST $ runInfer l (inferReplTopLevel l tl) + runST $ runInfer l (inferReplTopLevel tl) From 616a81d4ea3948fd2e098ae9cb2f6128f2ede7b5 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 19 Sep 2023 14:15:17 -0500 Subject: [PATCH 54/66] Some more ghc/linter warnings fixed --- typed-core/Pact/Core/IR/Typecheck.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 2555bd826..d9e98373f 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -45,12 +45,11 @@ import Data.RAList(RAList) import Data.Foldable(traverse_, foldlM, toList) import Data.Functor(($>)) import Data.STRef -import Data.Maybe(mapMaybe, fromMaybe) +import Data.Maybe(fromMaybe) import Data.Map(Map) import Data.Text(Text) import Data.List.NonEmpty(NonEmpty(..)) -import qualified Data.Map.Strict as Map import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.RAList as RAList @@ -1228,7 +1227,7 @@ checkCapArgs na tes = case _nKind na of | Just dcargs <- traverse IR._argType $ IR._dcapArgs dc -> do when (length dcargs /= length tes) $ error "invariant broken dcap args" vs <- zipWithM (checkTermType . liftType) dcargs tes - pure (view _2 <$> vs, concat (view _3 <$> vs)) + pure (view _2 <$> vs, concatMap (view _3) vs) | otherwise -> error "unannotated types" _ -> error "invariant broken" _ -> error "invariant broken" From 4e1b08c5f011311efa64769fc6a19239a08743c5 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 19 Sep 2023 15:38:47 -0500 Subject: [PATCH 55/66] Apparently the coverage checker can't figure out the patterns are covering Hence desugar them. --- typed-core/Pact/Core/IR/Typecheck.hs | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index d9e98373f..56f7b7890 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1531,20 +1531,15 @@ inferReplTopLevel => IR.ReplTopLevel Name IRType b i -> InferM s reso i (TypedReplTopLevel b i) inferReplTopLevel = \case - IR.RTLModule m -> Typed.RTLModule <$> inferModule m - IR.RTLTerm m -> Typed.RTLTerm . snd <$> inferTermNonGen m -- Todo: if we don't update the module hash to update linking, -- repl defuns and defconsts will break invariants about - IR.RTLDefun dfn -> do - dfn' <- inferDefun dfn - pure (Typed.RTLDefun dfn') - IR.RTLDefConst dconst -> do - dc <- inferDefConst dconst - pure (Typed.RTLDefConst dc) - IR.RTLInterface i -> do - tci <- inferInterface i - pure (Typed.RTLInterface tci) - + IR.RTLDefun dfn -> Typed.RTLDefun <$> inferDefun dfn + IR.RTLDefConst dconst -> Typed.RTLDefConst <$> inferDefConst dconst + IR.RTLTopLevel tl -> + case tl of + IR.TLModule m -> Typed.RTLModule <$> inferModule m + IR.TLTerm t -> Typed.RTLTerm . snd <$> inferTermNonGen t + IR.TLInterface i -> Typed.RTLInterface <$> inferInterface i -- | Transform types into their debruijn-indexed version -- Essentially: Start at depth 0: From 56de388a0e3e10a0cc7a1f4919875663ba413c19 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Tue, 19 Sep 2023 15:39:36 -0500 Subject: [PATCH 56/66] Add two more missing cases --- typed-core/Pact/Core/IR/Typecheck.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 56f7b7890..1f95111df 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1454,6 +1454,8 @@ inferDef = \case IR.Dfun d -> Typed.Dfun <$> inferDefun d IR.DConst d -> Typed.DConst <$> inferDefConst d IR.DCap dc -> Typed.DCap <$> inferDefCap dc + IR.DSchema {} -> error "TODO infer defs" -- TODO + IR.DTable {} -> error "TODO infer tables" -- TODO inferIfDef :: TypeOfBuiltin b From bf8274c9912eb6a1061ef60604bdfa3c84027f48 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 5 Oct 2023 16:04:07 -0500 Subject: [PATCH 57/66] Just do `fmap absurd` --- typed-core/Pact/Core/IR/Typecheck.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 1f95111df..06465a95e 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -995,13 +995,7 @@ generalizeWithTerm' ty pp term = do gen' t@TyForall{} = pure ([], t) liftNoFreeVars :: Type Void -> Type a -liftNoFreeVars = \case - TyVar n -> absurd n - TyPrim prim -> TyPrim prim - TyFun t1 t2 -> TyFun (liftNoFreeVars t1) (liftNoFreeVars t2) - TyList t -> TyList (liftNoFreeVars t) - TyModRef mn -> TyModRef mn - TyForall vars t -> TyForall (absurd <$> vars) (liftNoFreeVars t) +liftNoFreeVars = fmap absurd liftType :: IR.Type -> Type a liftType = \case From 50431fa5f6c429ae1ce9a9075c0dc860bafa4f0e Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 11 Oct 2023 13:30:54 -0500 Subject: [PATCH 58/66] Fill out a hole in Pact.Core.Persistence that blocks compilation --- pact-core/Pact/Core/Persistence.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pact-core/Pact/Core/Persistence.hs b/pact-core/Pact/Core/Persistence.hs index 1ee569291..d2a06630b 100644 --- a/pact-core/Pact/Core/Persistence.hs +++ b/pact-core/Pact/Core/Persistence.hs @@ -311,7 +311,7 @@ mockPactDb = do createUsrTable :: IORef (Map TableName (Map RowKey RowData)) - -> _ + -> IORef (Map TableName (Map TxId [TxLog RowData])) -> TableName -> ModuleName -> IO () From afa35caf4a929baea8588c8712bc1ee8628838dc Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 11 Oct 2023 13:42:24 -0500 Subject: [PATCH 59/66] A lot more builtins added, wildcard that for now --- typed-core/Pact/Core/Typed/Overload.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/typed-core/Pact/Core/Typed/Overload.hs b/typed-core/Pact/Core/Typed/Overload.hs index 984d736a0..1d4f96f2e 100644 --- a/typed-core/Pact/Core/Typed/Overload.hs +++ b/typed-core/Pact/Core/Typed/Overload.hs @@ -121,6 +121,7 @@ instance (SolveOverload raw resolved) => SolveOverload (ReplBuiltin raw) (ReplBu let bApp = withTyApps (Builtin RPrint i) tys pure (App bApp (pure eqT) i) _ -> throwOverloadError "Print" i + _ -> error "TODO builtin repls" liftRaw r = RBuiltinWrap (liftRaw r) From 3311290661e8cb1be53b7768148d7f7179bb178d Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 11 Oct 2023 13:50:51 -0500 Subject: [PATCH 60/66] Workaround builtins reshuffling --- typed-core/Pact/Core/Typed/Overload.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/typed-core/Pact/Core/Typed/Overload.hs b/typed-core/Pact/Core/Typed/Overload.hs index 1d4f96f2e..253718964 100644 --- a/typed-core/Pact/Core/Typed/Overload.hs +++ b/typed-core/Pact/Core/Typed/Overload.hs @@ -103,25 +103,27 @@ instance SolveOverload RawBuiltin CoreBuiltin where liftRaw = id instance (SolveOverload raw resolved) => SolveOverload (ReplBuiltin raw) (ReplBuiltin resolved) where - solveOverload i b tys preds = case b of - RBuiltinWrap raw -> over termBuiltin RBuiltinWrap <$> solveOverload i raw tys preds + solveOverload i (RBuiltinWrap raw) tys preds = over termBuiltin RBuiltinWrap <$> solveOverload i raw tys preds + solveOverload i (RBuiltinRepl b) tys preds = case b of RExpect -> case preds of [Pred Eq t1, Pred Show t2] -> do pEq <- solveOverload i (liftRaw RawEq :: ReplBuiltin raw) tys [Pred Eq t1] pShow <- solveOverload i (liftRaw RawShow :: ReplBuiltin raw) tys [Pred Show t2] - let bApp = withTyApps (Builtin RExpect i) tys + let bApp = withTyApps (builtin RExpect i) tys pure (App bApp (pEq :| [pShow]) i) _ -> throwOverloadError "Expect" i - RExpectFailure -> pure $ withTyApps (Builtin RExpectFailure i) tys - RExpectThat -> pure $ withTyApps (Builtin RExpectThat i) tys + RExpectFailure -> pure $ withTyApps (builtin RExpectFailure i) tys + RExpectThat -> pure $ withTyApps (builtin RExpectThat i) tys RPrint -> case preds of [Pred Show t1] -> do eqT <- solveOverload i (liftRaw RawShow :: ReplBuiltin raw) tys [Pred Show t1] - let bApp = withTyApps (Builtin RPrint i) tys + let bApp = withTyApps (builtin RPrint i) tys pure (App bApp (pure eqT) i) _ -> throwOverloadError "Print" i _ -> error "TODO builtin repls" + where + builtin = Builtin . RBuiltinRepl liftRaw r = RBuiltinWrap (liftRaw r) From a25dc11ba4582054faa5425b8eb7e620bc6b2e14 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 11 Oct 2023 14:30:17 -0500 Subject: [PATCH 61/66] DynInvoke seems to be removed --- typed-core/Pact/Core/IR/Typecheck.hs | 22 ---------------------- 1 file changed, 22 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index ef56f3f51..2f810b908 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1195,17 +1195,6 @@ checkTermType checkty = \case (_, err', p1) <- checkTermType checkty errcase (_, body', p2) <- checkTermType checkty bodycase pure (checkty, Typed.Try err' body' i, p1 ++ p2) - IR.DynInvoke mref fn i -> do - (tmref, mref', preds) <- inferTerm mref - case tmref of - TyModRef m -> view (tcModules . at m) >>= \case - Just (InterfaceData iface _) -> case IR.findIfDef fn iface of - Just (IR.IfDfun (IR.IfDefun _name irArgs irMRet _info)) -> do - unifyFun checkty irArgs irMRet i - pure (checkty, Typed.DynInvoke mref' fn i, preds) - _ -> error "boom" - _ -> error "boom" - _ -> error "boom" IR.Error txt i -> pure (checkty, Typed.Error checkty txt i, []) IR.ObjectLit{} -> error "TODO" -- TODO new ctor @@ -1374,17 +1363,6 @@ inferTerm = \case (te2, e2', p2)<- inferTerm e2 unify te1 te2 i pure (te1, Typed.Try e1' e2' i, p1 ++ p2) - IR.DynInvoke mref fn i -> do - (tmref, mref', preds) <- inferTerm mref - case tmref of - TyModRef m -> view (tcModules . at m) >>= \case - Just (InterfaceData iface _) -> case IR.findIfDef fn iface of - Just (IR.IfDfun df) -> do - (args, ret) <- irFunToTc (IR._ifdArgs df) (IR._ifdRType df) - pure (argListToTyFun args ret, Typed.DynInvoke mref' fn i, preds) - _ -> error "boom" - _ -> error "boom" - _ -> error "boom" IR.Error e i -> do ty <- TyVar <$> newTvRef pure (ty, Typed.Error ty e i, []) From 226073bf9a3393751b1386c144c2d796371654cc Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 11 Oct 2023 14:50:34 -0500 Subject: [PATCH 62/66] Stubs for new builtins in Overload --- typed-core/Pact/Core/Typed/Overload.hs | 31 ++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/typed-core/Pact/Core/Typed/Overload.hs b/typed-core/Pact/Core/Typed/Overload.hs index 253718964..acef2897b 100644 --- a/typed-core/Pact/Core/Typed/Overload.hs +++ b/typed-core/Pact/Core/Typed/Overload.hs @@ -372,6 +372,37 @@ solveCoreOverload i b tys preds = case b of RawSort -> error "sort" -- TODO RawSortObject -> error "sortObject" -- TODO RawRemove -> error "remove" -- TODO + RawStrToIntBase -> error "strtointbase" -- TODO + RawBind -> error "bind" -- TODO + RawRequireCapability -> error "require cap" + RawComposeCapability -> error "compose cap" + RawInstallCapability -> error "install cap" + RawEmitEvent -> error "emit event" + RawCreateCapabilityGuard -> error "create cap guard" + RawCreateModuleGuard -> error "create mod guard" + RawCreateTable -> error "create table" + RawDescribeKeyset -> error "descr keyset" + RawDescribeModule -> error "descr module" + RawDescribeTable -> error "descr table" + RawDefineKeySet -> error "define keyset" + RawDefineKeysetData -> error "define keyset data" + RawFoldDb -> error "fold db" + RawInsert -> error "insert" + RawKeyLog -> error "keylog" + RawKeys -> error "keys" + RawRead -> error "read" + RawSelect -> error "select" + RawUpdate -> error "update" + RawWithDefaultRead -> error "with default read" + RawWithRead -> error "with read" + RawWrite -> error "write" + RawTxIds -> error "txids" + RawTxLog -> error "txlog" + RawAndQ -> error "andq" + RawOrQ -> error "orq" + RawWhere -> error "where" + RawNotQ -> error "notq" + RawHash -> error "hash" singlePred :: [t] -> i -> (t -> OverloadM i a) -> String -> OverloadM i a singlePred preds i f msg = case preds of From 96eeecf99c17f88cc4fb9713a225fd1d31375346 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 11 Oct 2023 15:12:08 -0500 Subject: [PATCH 63/66] Ok apparently caps stuff is also removed for now, so comment it out --- typed-core/Pact/Core/IR/Typecheck.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 2f810b908..e00e3fd54 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1139,6 +1139,7 @@ checkTermType checkty = \case (tes', p1) <- checkCapArgs na tes (ty', te', p2) <- checkTermType checkty te pure (ty', WithCapability na tes' te', p1 ++ p2) + {- TODO commented out in IR RequireCapability na tes -> do unify checkty TyUnit i (tes', p1) <- checkCapArgs na tes @@ -1155,6 +1156,7 @@ checkTermType checkty = \case unify checkty TyUnit i (tes', p1) <- checkCapArgs na tes pure (TyUnit, EmitEvent na tes', p1) + -} -- TODO: Enforce `na` is a name of a dfun and not a dcap -- as a matter of fact, the whole above block needs the same enforcement just -- for dfuns @@ -1306,6 +1308,7 @@ inferTerm = \case (tes', p1) <- checkCapArgs na tes (ty', te', p2) <- inferTerm te pure (ty', WithCapability na tes' te', p1 ++ p2) + {- TODO commented out in IR RequireCapability na tes -> do (tes', p1) <- checkCapArgs na tes pure (TyUnit, RequireCapability na tes', p1) @@ -1318,6 +1321,7 @@ inferTerm = \case EmitEvent na tes -> do (tes', p1) <- checkCapArgs na tes pure (TyUnit, EmitEvent na tes', p1) + -} CreateUserGuard na tes -> do (tes', p1) <- checkCapArgs na tes pure (TyGuard, CreateUserGuard na tes', p1) From 9f62b8ce3729c9a02adc52716ebe6306e31c3eed Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 11 Oct 2023 16:04:47 -0500 Subject: [PATCH 64/66] More placeholders --- typed-core/Pact/Core/IR/Typecheck.hs | 36 ++++++++++++++++++++++++++-- 1 file changed, 34 insertions(+), 2 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index e00e3fd54..1c4676c58 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -357,6 +357,37 @@ instance TypeOfBuiltin RawBuiltin where RawSortObject -> error "sort object TODO" -- TODO RawContains -> error "contains TODO" -- TODO RawRemove -> error "remove TODO" -- TODO + RawStrToIntBase -> error "strtoint base" + RawBind -> error "bind" + RawRequireCapability -> error "require cap" + RawComposeCapability -> error "compose cap" + RawInstallCapability -> error "install cap" + RawEmitEvent -> error "emit event" + RawCreateCapabilityGuard -> error "create cap guard" + RawCreateModuleGuard -> error "create mod guard" + RawCreateTable -> error "create table" + RawDescribeKeyset -> error "descr keyset" + RawDescribeModule -> error "descr module" + RawDescribeTable -> error "descr table" + RawDefineKeySet -> error "define keyset" + RawDefineKeysetData -> error "define keyset data" + RawFoldDb -> error "fold db" + RawInsert -> error "insert" + RawKeyLog -> error "keylog" + RawKeys -> error "keys" + RawRead -> error "read" + RawSelect -> error "select" + RawUpdate -> error "update" + RawWithDefaultRead -> error "with default read" + RawWithRead -> error "with read" + RawWrite -> error "write" + RawTxIds -> error "txids" + RawTxLog -> error "txlog" + RawAndQ -> error "andq" + RawOrQ -> error "orq" + RawWhere -> error "where" + RawNotQ -> error "notq" + RawHash -> error "hash" where nd b a = NamedDeBruijn a b unaryNumType = @@ -397,8 +428,8 @@ instance TypeOfBuiltin RawBuiltin where in TypeScheme [aVar] [Pred ListLike a] (TyInt :~> a :~> a) instance TypeOfBuiltin b => TypeOfBuiltin (ReplBuiltin b) where - typeOfBuiltin = \case - RBuiltinWrap b -> typeOfBuiltin b + typeOfBuiltin (RBuiltinWrap b) = typeOfBuiltin b + typeOfBuiltin (RBuiltinRepl rb) = case rb of RExpect -> let aVar = nd "a" 0 aTv = TyVar aVar @@ -415,6 +446,7 @@ instance TypeOfBuiltin b => TypeOfBuiltin (ReplBuiltin b) where aVar = nd "a" 0 aTv = TyVar aVar in TypeScheme [aVar] [Pred Show aTv] (aTv :~> TyUnit) + r -> error $ "TODO repl builtin " <> show r where nd b a = NamedDeBruijn a b From 8c63652dc536977e747b4fc390c60dc044d0e4a3 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 11 Oct 2023 16:14:51 -0500 Subject: [PATCH 65/66] Update Typed.ReplTopLevel to match IR structure, reusing the TopLevel type --- typed-core/Pact/Core/IR/Typecheck.hs | 6 +----- typed-core/Pact/Core/Typed/Term.hs | 5 ++--- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index 1c4676c58..a2ea3419c 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1546,11 +1546,7 @@ inferReplTopLevel = \case -- repl defuns and defconsts will break invariants about IR.RTLDefun dfn -> Typed.RTLDefun <$> inferDefun dfn IR.RTLDefConst dconst -> Typed.RTLDefConst <$> inferDefConst dconst - IR.RTLTopLevel tl -> - case tl of - IR.TLModule m -> Typed.RTLModule <$> inferModule m - IR.TLTerm t -> Typed.RTLTerm . snd <$> inferTermNonGen t - IR.TLInterface i -> Typed.RTLInterface <$> inferInterface i + IR.RTLTopLevel tl -> Typed.RTLTopLevel <$> inferTopLevel tl -- | Transform types into their debruijn-indexed version -- Essentially: Start at depth 0: diff --git a/typed-core/Pact/Core/Typed/Term.hs b/typed-core/Pact/Core/Typed/Term.hs index 1a0721271..186eef802 100644 --- a/typed-core/Pact/Core/Typed/Term.hs +++ b/typed-core/Pact/Core/Typed/Term.hs @@ -184,14 +184,13 @@ data TopLevel name tyname builtin info = TLModule (Module name tyname builtin info) | TLInterface (Interface name tyname builtin info) | TLTerm (Term name tyname builtin info) + | TLUse Import deriving Show data ReplTopLevel name tyname builtin info - = RTLModule (Module name tyname builtin info) - | RTLInterface (Interface name tyname builtin info) + = RTLTopLevel (TopLevel name tyname builtin info) | RTLDefun (Defun name tyname builtin info) | RTLDefConst (DefConst name tyname builtin info) - | RTLTerm (Term name tyname builtin info) deriving Show -- | Typed pact core terms From d0ac6d2f40915858a35e9101172c89e575a632a5 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Thu, 12 Oct 2023 11:21:39 -0500 Subject: [PATCH 66/66] TLUse imports need no processing during inference --- typed-core/Pact/Core/IR/Typecheck.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/typed-core/Pact/Core/IR/Typecheck.hs b/typed-core/Pact/Core/IR/Typecheck.hs index a2ea3419c..8457c6fc1 100644 --- a/typed-core/Pact/Core/IR/Typecheck.hs +++ b/typed-core/Pact/Core/IR/Typecheck.hs @@ -1536,6 +1536,7 @@ inferTopLevel = \case IR.TLModule m -> Typed.TLModule <$> inferModule m IR.TLTerm m -> Typed.TLTerm . snd <$> inferTermNonGen m IR.TLInterface i -> Typed.TLInterface <$> inferInterface i + IR.TLUse u -> pure $ Typed.TLUse u inferReplTopLevel :: TypeOfBuiltin b