caps full semantics + db

pact-core/Pact/Core/Builtin.hs

@@ -262,6 +262,7 @@ data RawBuiltin
   | RawWhere
   | RawNotQ
   | RawHash
+  | RawCompose
   deriving (Eq, Show, Ord, Bounded, Enum)
 
 instance HasObjectOps RawBuiltin where
@@ -377,6 +378,7 @@ rawBuiltinToText = \case
   RawWhere -> "where?"
   RawNotQ -> "not?"
   RawHash -> "hash"
+  RawCompose -> "compose"
 
 instance IsBuiltin RawBuiltin where
   builtinName = NativeName . rawBuiltinToText
@@ -489,6 +491,7 @@ instance IsBuiltin RawBuiltin where
     RawWhere -> 3
     RawNotQ -> 2
     RawHash -> 1
+    RawCompose -> 3
 
 
 rawBuiltinNames :: [Text]
@@ -556,7 +559,7 @@ instance IsBuiltin ReplBuiltins where
     REnvStackFrame -> 0
     REnvChainData -> 1
     REnvData -> 1
-    REnvEvents -> 0
+    REnvEvents -> 1
     REnvHash -> 1
     REnvKeys -> 1
     REnvSigs -> 1

pact-core/Pact/Core/Capabilities.hs

@@ -22,6 +22,7 @@ module Pact.Core.Capabilities
  ) where
 
 import Control.Lens
+import Data.Text(Text)
 import Data.Set(Set)
 import Data.Default
 
@@ -31,14 +32,16 @@ import Pact.Core.Names
 import Pact.Core.Hash
 
 data DefManagedMeta name
-  = DefManagedMeta
-  { _dmManagedArgIx :: Int
-  , _dmManagerFn :: FQNameRef name
-  } deriving (Show)
+  = DefManagedMeta Int (FQNameRef name)
+  | AutoManagedMeta
+  -- { _dmManagedArgIx :: Int
+  -- , _dmManagerFn :: FQNameRef name
+  deriving (Show)
 
 data DefCapMeta name
   = DefEvent
-  | DefManaged (Maybe (DefManagedMeta name))
+  | DefManaged (DefManagedMeta name)
+  | Unmanaged
   deriving (Show)
 
 data CapForm name e
@@ -104,9 +107,12 @@ data CapState name v
 instance (Ord name, Ord v) => Default (CapState name v) where
   def = CapState mempty mempty mempty mempty
 
-data PactEvent name v
+-- Todo: Is there a reason why module + name is
+-- an unqualified
+data PactEvent v
   = PactEvent
-  { _peToken :: CapToken name v
+  { _peName :: Text
+  , _peArgs :: [v]
   , _peModule :: ModuleName
   , _peModuleHash :: ModuleHash
   } deriving (Show, Eq)

pact-core/Pact/Core/Compile.hs

@@ -14,6 +14,7 @@ import Control.Monad.State.Strict ( MonadIO(..), MonadState )
 import Control.Monad.Except ( MonadError(throwError), liftEither )
 import Control.Monad
 import Data.Maybe(mapMaybe)
+import Data.Foldable(find)
 import Data.Proxy
 import Data.ByteString(ByteString)
 import qualified Data.Map.Strict as M
@@ -105,11 +106,12 @@ evalModuleGovernance pdb interp = \case
               term = App (Builtin (liftRaw RawEnforceGuard) info) (pure ksrg) info
           _interpret interp term *> pure tl
         CapGov (ResolvedGov fqn) ->
-          use (evalState . loaded . loAllLoaded . at fqn) >>= \case
+          -- Todo: this does not allow us to delegate governance, which is an issue.
+          case find (\d -> defName d == _fqName fqn) (_mDefs md) of
             Just (DCap d) ->
               _interpret interp (_dcapTerm d) *> pure tl
-            -- Todo: Definitely fixable with a GADT
-            _ -> throwError (PEExecutionError (ModuleGovernanceFailure (Lisp._mName m)) (Lisp._mInfo m))
+            _ ->
+              throwError (PEExecutionError (ModuleGovernanceFailure (Lisp._mName m)) (Lisp._mInfo m))
     Just (InterfaceData iface _) ->
       throwError (PEExecutionError (CannotUpgradeInterface (_ifName iface)) (_ifInfo iface))
     Nothing -> pure tl
@@ -145,7 +147,7 @@ interpretTopLevel pdb interp (DesugarOutput ds lo0 _deps) = do
           mdata = InterfaceData iface deps'
       liftDbFunction (_ifInfo iface) (writeModule pdb Write (view ifName iface) mdata)
       let newLoaded = M.fromList $ toFqDep (_ifName iface) (_ifHash iface)
-                      <$> mapMaybe (fmap DConst . preview _IfDConst) (_ifDefns iface)
+                      <$> mapMaybe ifDefToDef (_ifDefns iface)
           loadNewModule =
             over loModules (M.insert (_ifName iface) mdata) .
             over loAllLoaded (M.union newLoaded)

pact-core/Pact/Core/Environment.hs

@@ -164,7 +164,7 @@ data EvalState b i
   = EvalState
   { _esCaps :: CapState QualifiedName PactValue
   , _esStack :: [StackFrame]
-  , _esEvents :: [PactEvent FullyQualifiedName PactValue]
+  , _esEvents :: [PactEvent PactValue]
   , _esLoaded :: Loaded b i
   } deriving Show
 

pact-core/Pact/Core/Errors.hs

@@ -269,6 +269,8 @@ data EvalError
   | FormIllegalWithinDefcap Text
   | RunTimeTypecheckFailure ArgTypeError Type
   | NativeIsTopLevelOnly NativeName
+  | EventDoesNotMatchModule ModuleName
+  | InvalidEventCap FullyQualifiedName
   deriving Show
 
 instance Pretty EvalError where

pact-core/Pact/Core/Guards.hs

@@ -18,15 +18,22 @@ where
 
 import Data.Text(Text)
 import qualified Data.Set as S
+import Pact.Core.Pretty
 
 import Pact.Core.Names
 
 newtype PublicKeyText = PublicKeyText { _pubKey :: Text }
   deriving (Eq,Ord,Show)
 
+instance Pretty PublicKeyText where
+  pretty (PublicKeyText t) = pretty t
+
 newtype KeySetName = KeySetName { _keysetName :: Text }
     deriving (Eq,Ord,Show)
 
+instance Pretty KeySetName where
+  pretty (KeySetName ks) = "'" <> pretty ks
+
 data Governance name
   = KeyGov KeySetName
   | CapGov (CapGovRef name)
@@ -51,18 +58,36 @@ data KSPredicate name
   -- | CustomPredicate name
   deriving (Eq, Show, Ord)
 
+instance Pretty (KSPredicate name) where
+  pretty = \case
+    KeysAll -> "keys-all"
+    Keys2 -> "keys2"
+    KeysAny -> "keys-any"
+
 data KeySet name
   = KeySet
   { _ksKeys :: !(S.Set PublicKeyText)
   , _ksPredFun :: KSPredicate name
   } deriving (Eq, Show, Ord)
 
+instance Pretty name => Pretty (KeySet name) where
+  pretty (KeySet ks f) = "KeySet" <+> commaBraces
+    [ "keys: " <> prettyList (S.toList ks)
+    , "pred: " <> pretty f
+    ]
+
 data UserGuard name term
   = UserGuard
   { _ugFunction :: name
   , _ugArgs :: [term] }
   deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
 
+instance (Pretty name, Pretty term) => Pretty (UserGuard name term) where
+  pretty (UserGuard fn args) = "UserGuard" <+> commaBraces
+    [ "fun: " <> pretty fn
+    , "args: " <> prettyList args
+    ]
+
 data ModuleGuard
   = ModuleGuard
   { _mgModule :: ModuleName
@@ -75,6 +100,12 @@ instance Eq ModuleGuard where
 instance Ord ModuleGuard where
   mg `compare` mg' = _mgModule mg `compare` _mgModule mg'
 
+instance Pretty ModuleGuard where
+  pretty (ModuleGuard mg name) = "ModuleGuard" <+> commaBraces
+    [ "module: " <> pretty mg
+    , "name: " <> pretty name
+    ]
+
 data CapabilityGuard name term
   = CapabilityGuard
   { _cgName :: !name
@@ -90,9 +121,26 @@ data Guard name term
   | GModuleGuard ModuleGuard
   deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
 
+instance (Pretty name, Pretty term) => Pretty (Guard name term) where
+  pretty = \case
+    GKeyset ks -> pretty ks
+    GKeySetRef ks -> pretty ks
+    GUserGuard ug -> pretty ug
+    GCapabilityGuard cg -> pretty cg
+    GModuleGuard g -> pretty g
+
+
 data Namespace name term
   = Namespace
   { _nsName :: !NamespaceName
   , _nsUser :: !(Guard name term)
   , _nsAdmin :: !(Guard name term)
   } deriving (Eq, Show)
+
+instance (Pretty name, Pretty term) => Pretty (CapabilityGuard name term) where
+  pretty (CapabilityGuard cg args) = "CapabilityGuard" <+> commaBraces
+    [ "name: " <> pretty cg
+    , "args: " <> pretty args
+    -- todo: pactId when I merge defpcats
+    -- , "pactId: " <> pretty _cgPactId
+    ]