remove emit-event shim

src-tool/Pact/Analyze/Check.hs

@@ -82,7 +82,7 @@ import           Pact.Types.Runtime         (ModuleData (..), ModuleName,
 import qualified Pact.Types.Runtime         as Pact
 import           Pact.Types.Term            (DefName (..),
                                              dDefType, moduleDefMeta,
-                                             moduleDefName, _Ref, _gGovernance)
+                                             moduleDefName, _Ref, _gGovernance, dDefMeta)
 import           Pact.Types.Type            (ftArgs, _ftArgs)
 import           Pact.Types.Typecheck       (AST, Fun (FDefun, _fArgs, _fBody, _fInfo),
                                              Named, Node,
@@ -627,29 +627,34 @@ moduleCapabilities
   :: DynEnv -> [ModuleData Ref] -> ExceptT VerificationFailure IO [Capability]
 moduleCapabilities de mds = fmap concat $ forM mds $ \md -> do
     toplevels <- withExceptT ModuleCheckFailure $
-                   traverse (ExceptT . typecheck de) (defcapRefs md)
+                   traverse (ExceptT . typecheck') (defcapRefs md)
     hoist generalize $ traverse mkCap toplevels
 
   where
+    typecheck' tl = do
+          tc <- typecheck de tl
+          pure $ (join $ tl ^? _Ref.tDef.dDefMeta, ) <$> tc
+
     defcapRefs md = toListOf
       (mdRefMap.traverse.filtered
         (\ref -> ref ^? _Ref.tDef.dDefType == Just Defcap))
       md
 
-    mkCap :: TopLevel Node -> Except VerificationFailure Capability
-    mkCap toplevel = do
+    mkCap :: forall a. (Maybe (Pact.DefMeta a), TopLevel Node) -> Except VerificationFailure Capability
+    mkCap (c, toplevel) = do
         eSchema <- mkESchema <$> traverse (translateArgTy "argument") pactArgs
         pure $ case eSchema of
-          ESchema schema -> Capability schema capName
+          ESchema schema -> Capability schema capName (evOrMgt <$> c)
 
       where
         (capName, pactArgs) = case toplevel of
           TopFun FDefun{_fName,_fType,_fModule} _ ->
             (mkCapName _fModule _fName, _ftArgs _fType)
           _ ->
             error "invariant violation: defcap toplevel must be a defun"
-
-
+        evOrMgt = \case
+          Pact.DMDefcap Pact.DefcapEvent -> CapEvent
+          _ -> CapManaged
 translateArgTy
   :: Text
   -> Pact.Arg UserType

src-tool/Pact/Analyze/Eval/Term.hs

@@ -404,7 +404,7 @@ accumulatingPendingGrants act = do
       pure prev
 
 capabilityAppToken :: Capability -> [VarId] -> Analyze Token
-capabilityAppToken (Capability schema capName) vids = do
+capabilityAppToken (Capability schema capName _) vids = do
     mAVals <- sequence <$> traverse getVar vids
     case mAVals of
       Nothing    ->

src-tool/Pact/Analyze/Patterns.hs

@@ -254,6 +254,10 @@ pattern AST_ComposeCapability :: AST Node -> AST Node
 pattern AST_ComposeCapability app <-
   App _node (NativeFunc "compose-capability") [app]
 
+pattern AST_EmitEvent :: Node -> AST Node -> AST Node
+pattern AST_EmitEvent node cap <-
+  App node (NativeFunc "emit-event") [cap]
+
 pattern AST_Continue :: Node -> AST Node -> AST Node
 pattern AST_Continue node body <- App node (NativeFunc "continue") [body]
 

src-tool/Pact/Analyze/Translate.hs

@@ -107,6 +107,7 @@ data TranslateFailureNoLoc
   | UnexpectedDefaultReadType EType EType
   | UnsupportedNonFatal Text
   | UnscopedCapability CapName
+  | CapabilityNotManagedOrEvent CapName
   deriving (Eq, Show)
 
 describeTranslateFailureNoLoc :: TranslateFailureNoLoc -> RenderedOutput
@@ -171,6 +172,8 @@ describeTranslateFailureNoLoc = \case
     renderWarn $ "Unsupported operation: " <> msg
   UnscopedCapability (CapName cap) ->
     renderWarn $ "Direct execution restricted by capability " <> T.pack cap
+  CapabilityNotManagedOrEvent (CapName cap) ->
+    renderFatal $ "Capability " <> T.pack cap <> " " <> "not managed or event"
 
 
 data TranslateEnv
@@ -200,7 +203,7 @@ mkTranslateEnv info caps args
       Map.empty
       args
 
-    caps' = Map.fromList $ caps <&> \c@(Capability _ capName) -> (capName, c)
+    caps' = Map.fromList $ caps <&> \c@(Capability _ capName _) -> (capName, c)
 
     coerceUnmungedToMunged :: Unmunged -> Munged
     coerceUnmungedToMunged (Unmunged nm) = Munged nm
@@ -1383,7 +1386,7 @@ translateNode astNode = withAstContext astNode $ case astNode of
 
   AST_RequireCapability node (AST_InlinedApp modName funName _ bindings _) ->
     withTranslatedBindings bindings $ \bindingTs -> do
-      (cap@(Capability _ capName), vars) <- translateCapRef modName funName bindingTs
+      (cap@(Capability _ capName _), vars) <- translateCapRef modName funName bindingTs
       recov <- view teRecoverability
       tid <- genTagId
       inScope <- Set.member capName <$> use tsStaticCapsInScope
@@ -1706,9 +1709,13 @@ translateNode astNode = withAstContext astNode $ case astNode of
     -- not translating argument
     shimNative astNode node fn []
 
-  AST_NFun node fn@"emit-event" [_] ->
-    -- elide translation of event capability
-    shimNative astNode node fn []
+  AST_EmitEvent _node (AST_InlinedApp modName funName _ bindings _) ->
+    withTranslatedBindings bindings $ \bindingTs -> do
+      (Capability _ capName evOrMgt, _) <- translateCapRef modName funName bindingTs
+      case evOrMgt of
+        Nothing -> throwError' (CapabilityNotManagedOrEvent capName)
+        -- RS: If a cap is managed or an event, we always succeed (by emitting `true`).
+        Just _ -> pure (Some SBool $ Lit' True)
 
   AST_NFun _ "distinct" [xs] -> translateNode xs >>= \xs' -> case xs' of
     Some ty@(SList elemTy) l -> pure $ Some ty $ CoreTerm $ ListDistinct elemTy l

src-tool/Pact/Analyze/Types/Capability.hs

@@ -19,19 +19,27 @@ import           Pact.Analyze.PactSFunArray (eitherArray, mkPactSFunArray)
 import           Pact.Analyze.Types.Shared
 import           Pact.Analyze.Types.Types
 
+
+data CapabilityAnnot
+  = CapManaged
+  | CapEvent
+  deriving Show
+
 -- | The "signature" for a capability in Pact -- a family of tokens.
 data Capability where
-  Capability :: SingList schema -> CapName -> Capability
+  Capability :: SingList schema -> CapName -> Maybe CapabilityAnnot -> Capability
 
 instance Show Capability where
-  showsPrec p (Capability sch capName) = showParen (p > 10) $
+  showsPrec p (Capability sch capName capAnnot) = showParen (p > 10) $
       showString "Capability "
     . showsPrec 11 sch
     . showChar ' '
     . showsPrec 11 capName
+    . showChar ' '
+    . showsPrec 11 capAnnot
 
 instance Pretty Capability where
-  pretty (Capability _ (CapName cn)) = prettyString cn
+  pretty (Capability _ (CapName cn) _) = prettyString cn
 
 -- | The index into the family that is a 'Capability'. Think of this of the
 -- arguments to a particular call of a capability.
@@ -47,7 +55,7 @@ newtype TokenGrants
 
 mkTokenGrants :: [Capability] -> TokenGrants
 mkTokenGrants caps = TokenGrants $ Map.fromList $
-  caps <&> \(Capability schema name) ->
+  caps <&> \(Capability schema name _) ->
     ( name
     , EKeySFunArray (SObjectUnsafe schema) (mkPactSFunArray $ const sFalse)
     )

src-tool/Pact/Analyze/Types/Languages.hs

@@ -263,7 +263,7 @@ data Core (t :: Ty -> K.Type) (a :: Ty) where
   ListEqNeq    :: SingTy a -> EqNeq -> t ('TyList a) -> t ('TyList a) -> Core t 'TyBool
   ListAt       :: SingTy a -> t 'TyInteger -> t ('TyList a) -> Core t a
   ListContains :: SingTy a -> t a      -> t ('TyList a) -> Core t 'TyBool
-  
+
   ListDistinct :: SingTy a -> t ('TyList a) -> Core t ('TyList a)
 
   ListLength   :: SingTy a -> t ('TyList a) -> Core t 'TyInteger
@@ -1654,7 +1654,7 @@ prettyTerm ty = \case
   MkPactGuard name -> parensSep ["create-pact-guard", pretty name]
   MkUserGuard g t -> parensSep ["create-user-guard", pretty g, pretty t]
   MkModuleGuard name -> parensSep ["create-module-guard", pretty name]
-  MkCapabilityGuard (Capability _ n) as isPact -> parensSep
+  MkCapabilityGuard (Capability _ n _) as isPact -> parensSep
     [ if isPact then "create-capability-pact-guard" else "create-capability-guard"
     , parensSep (pretty n:map (pretty.fst) as)]
   Pact steps -> vsep (pretty <$> steps)

tests/AnalyzeSpec.hs

@@ -987,6 +987,27 @@ spec = describe "analyze" $ do
               (enforce-guard (keyset-ref-guard "foo")))
           |]
     expectVerified code
+  describe "emit-event" $ do
+    let code =
+          [text|
+             (defcap CAP ()
+               @event
+               true)
+
+             (defun test ()
+               (emit-event (CAP)))
+               |]
+    expectVerified code
+
+  describe "emit-event (fail as not @event or @managed)" $ do
+    let code =
+          [text|
+             (defcap CAP () true)
+
+             (defun test ()
+               (emit-event (CAP)))
+               |]
+    expectFail code $ Valid Abort'
 
   describe "create-pact-guard" $ do
     let code =