testcap, fix name reso

kadena-io · Oct 12, 2023 · 956698f · 956698f
1 parent ec0d94e
commit 956698f
Show file tree

Hide file tree

Showing 7 changed files with 329 additions and 115 deletions.
diff --git a/pact-core/Pact/Core/Builtin.hs b/pact-core/Pact/Core/Builtin.hs
@@ -208,6 +208,7 @@ data RawBuiltin
   | RawStrToIntBase
   | RawFold
   | RawDistinct
+  | RawFormat
   -- | RawEnforce
   -- | RawEnforceOne
   | RawEnumerate
@@ -221,6 +222,7 @@ data RawBuiltin
   | RawReadString
   | RawReadKeyset
   | RawEnforceGuard
+  | RawEnforceKeyset
   | RawKeysetRefGuard
   | RawAt
   | RawMakeList
@@ -324,6 +326,7 @@ rawBuiltinToText = \case
   RawFold -> "fold"
   RawZip -> "zip"
   RawDistinct -> "distinct"
+  RawFormat -> "format"
   -- RawEnforce -> "enforce"
   -- RawEnforceOne -> "enforce-one"
   RawEnumerate -> "enumerate"
@@ -336,6 +339,7 @@ rawBuiltinToText = \case
   RawReadString -> "read-string"
   RawReadKeyset -> "read-keyset"
   RawEnforceGuard -> "enforce-guard"
+  RawEnforceKeyset -> "enforce-keyset"
   RawKeysetRefGuard -> "keyset-ref-guard"
   RawCreateCapabilityGuard -> "create-capability-guard"
   RawCreateModuleGuard -> "create-module-guard"
@@ -433,6 +437,7 @@ instance IsBuiltin RawBuiltin where
     RawStrToIntBase -> 2
     RawFold -> 3
     RawDistinct -> 1
+    RawFormat -> 2
     -- RawEnforce -> 2
     -- RawEnforceOne -> 2
     RawEnumerate -> 2
@@ -445,6 +450,7 @@ instance IsBuiltin RawBuiltin where
     RawReadDecimal -> 1
     RawReadString -> 1
     RawReadKeyset -> 1
+    RawEnforceKeyset -> 1
     RawEnforceGuard -> 1
     RawKeysetRefGuard -> 1
     RawCreateCapabilityGuard -> 1
@@ -511,6 +517,7 @@ data ReplBuiltins
   | RCommitTx
   | RRollbackTx
   | RSigKeyset
+  | RTestCapability
   -- | RLoad
   -- | RLoadWithEnv
   -- | RExpect
@@ -558,6 +565,7 @@ instance IsBuiltin ReplBuiltins where
     RCommitTx -> 0
     RRollbackTx -> 0
     RSigKeyset -> 1
+    RTestCapability -> 1
     -- RLoad -> 1
     -- RLoadWithEnv -> 2
 -- Note: commented out natives are
@@ -618,6 +626,7 @@ replBuiltinsToText = \case
   RCommitTx -> "commit-tx"
   RRollbackTx -> "rollback-tx"
   RSigKeyset -> "sig-keyset"
+  RTestCapability -> "test-capability"
   -- RLoad -> "load"
   -- RLoadWithEnv -> "load-with-env"
 

diff --git a/pact-core/Pact/Core/Compile.hs b/pact-core/Pact/Core/Compile.hs
@@ -49,6 +49,7 @@ type HasCompileEnv b s m
     , DesugarBuiltin b
     , Pretty b
     , MonadIO m
+    , Show b
     , PhaseDebug m)
 
 _parseOnly
@@ -120,12 +121,14 @@ interpretTopLevel
   -> Interpreter b m
   -> DesugarOutput b SpanInfo (TopLevel Name Type b SpanInfo)
   -> m (CompileValue b)
-interpretTopLevel pdb interp (DesugarOutput ds lo0 deps) = do
+interpretTopLevel pdb interp (DesugarOutput ds lo0 _deps) = do
   debugPrint DebugDesugar ds
   evalState . loaded .= lo0
   case ds of
     TLModule m -> do
-      let deps' = M.filterWithKey (\k _ -> Set.member (_fqModule k) deps) (_loAllLoaded lo0)
+      -- let deps' = M.filterWithKey (\k _ -> Set.member (_fqModule k) deps) (_loAllLoaded lo0)
+      -- Todo: deps are not being calculated properly by the renamer
+      let deps' = _loAllLoaded lo0
           mdata = ModuleData m deps'
       liftDbFunction (_mInfo m) (writeModule pdb Write (view mName m) mdata)
       let newLoaded = M.fromList $ toFqDep (_mName m) (_mHash m) <$> _mDefs m
@@ -136,7 +139,9 @@ interpretTopLevel pdb interp (DesugarOutput ds lo0 deps) = do
       evalState . esCaps . csModuleAdmin %= Set.union (Set.singleton (_mName m))
       pure (LoadedModule (_mName m))
     TLInterface iface -> do
-      let deps' = M.filterWithKey (\k _ -> Set.member (_fqModule k) deps) (_loAllLoaded lo0)
+      -- Todo: deps are not being calculated properly by the renamer
+      -- let deps' = M.filterWithKey (\k _ -> Set.member (_fqModule k) deps) (_loAllLoaded lo0)
+      let deps' = _loAllLoaded lo0
           mdata = InterfaceData iface deps'
       liftDbFunction (_ifInfo iface) (writeModule pdb Write (view ifName iface) mdata)
       let newLoaded = M.fromList $ toFqDep (_ifName iface) (_ifHash iface)

diff --git a/pact-core/Pact/Core/Environment.hs b/pact-core/Pact/Core/Environment.hs
@@ -37,6 +37,7 @@ module Pact.Core.Environment
 --  , esCaps, esEvents, esInCap
 --  , esStack, esLoaded
  , StackFrame(..)
+ , StackFunctionType(..)
  ) where
 
 import Data.Int(Int64)
@@ -147,10 +148,16 @@ newtype PactState b i
 
 makeLenses ''PactState
 
+data StackFunctionType
+  = SFDefun
+  | SFDefcap
+  deriving (Eq, Show, Enum, Bounded)
+
 data StackFrame
   = StackFrame
   { _sfFunction :: Text
-  , _sfModule :: ModuleName }
+  , _sfModule :: ModuleName
+  , _sfFnType :: StackFunctionType }
   deriving Show
 
 data EvalState b i

diff --git a/pact-core/Pact/Core/IR/Desugar.hs b/pact-core/Pact/Core/IR/Desugar.hs
@@ -150,12 +150,16 @@ type MonadDesugar raw reso i m =
   , MonadError (PactError i) m
   , MonadState (RenamerState reso i) m
   , MonadReader (RenamerEnv reso i) m
+  , Show reso
+  , Show i
   , MonadIO m)
 
 type MonadRenamer reso i m =
   ( MonadError (PactError i) m
   , MonadState (RenamerState reso i) m
   , MonadReader (RenamerEnv reso i) m
+  , Show reso
+  , Show i
   , MonadIO m)
 
 dsOut :: Lens (DesugarOutput b i a) (DesugarOutput b i a') a a'
@@ -221,6 +225,8 @@ desugarAppArityRaw f i RawSort [e1, e2] =
   App (Builtin (f RawSortObject) i) [e1, e2] i
 desugarAppArityRaw f i RawReadMsg [] =
   App (Builtin (f RawReadMsgDefault) i) [] i
+desugarAppArityRaw f i RawDefineKeySet [e1] =
+  App (Builtin (f RawDefineKeysetData) i) [e1] i
 desugarAppArityRaw f i b args =
     App (Builtin (f b) i) args i
 
@@ -636,8 +642,18 @@ defTableSCC mn cd dt =
   let (DesugaredTable t) = (_dtSchema dt)
   in parsedNameSCC mn cd t
 
--- defCapSCC :: ModuleName -> DefCap Name b i -> Set Text
--- defCapSCC mn = termSCC mn . _dcapTerm
+defCapSCC
+  :: ModuleName
+  -> Set Text
+  -> DefCap ParsedName DesugarType b i1
+  -> Set Text
+defCapSCC mn cd dc =
+  case _dcapMeta dc of
+    Just (DefManaged (Just dmeta)) ->
+      let (FQParsed pn) = _dmManagerFn dmeta
+      in termSCC mn cd (_dcapTerm dc) <> parsedNameSCC mn cd pn
+    _ -> termSCC mn cd (_dcapTerm dc)
+
 
 defSCC
   :: ModuleName
@@ -647,7 +663,7 @@ defSCC
 defSCC mn cd = \case
   Dfun d -> defunSCC mn cd d
   DConst d -> defConstSCC mn cd d
-  DCap dc -> termSCC mn cd (_dcapTerm dc)
+  DCap dc -> defCapSCC mn cd dc
   DSchema ds -> foldMap (typeSCC mn cd) ( _dsSchema ds)
   DTable dt -> defTableSCC mn cd dt
 
@@ -709,7 +725,7 @@ resolveModuleName mn i =
       view rePactDb >>= liftIO . (`readModule` mn) >>= \case
       Nothing -> throwDesugarError (NoSuchModule mn) i
       Just md -> case md of
-        ModuleData module_ depmap ->
+        ModuleData module_ depmap -> do
           md <$ loadModule' module_ depmap
         InterfaceData in' depmap ->
           md <$ loadInterface' in' depmap
@@ -964,10 +980,10 @@ renameTerm (CapabilityForm cf i) =
       CreateUserGuard{} -> False
       _ -> True
 
-    checkCapFormNonModule = \case
-      WithCapability{} ->
-        throwDesugarError (NotAllowedOutsideModule "with-capability") i
-      CreateUserGuard{} -> pure ()
+    checkCapFormNonModule = const (pure ())
+      -- WithCapability{} ->
+      --   throwDesugarError (NotAllowedOutsideModule "with-capability") i
+      -- CreateUserGuard{} -> pure ()
 
     checkCapForm = \case
       WithCapability{} -> enforceNotWithinDefcap i "with-capability"
@@ -1191,10 +1207,7 @@ renameModule
   => Module ParsedName DesugarType raw i
   -> m (Module Name Type raw i)
 renameModule (Module mname mgov defs blessed imp implements mhash i) = local (set reCurrModule (Just mname)) $ do
-  -- let defMap = M.fromList $ (\d -> (defName d, (NTopLevel mname mhash, defKind d))) <$> defs
-  -- let fqns = M.fromList $ (\d -> (defName d, (FullyQualifiedName mname (defName d) mhash, defKind d))) <$> defs
-  -- `maybe all of this next section should be in a block laid out by the
-  -- `locally reBinds`
+  rsDependencies .= mempty
   mgov' <- resolveGov mgov
   let defNames = S.fromList $ fmap defName defs
   let scc = mkScc defNames <$> defs
@@ -1368,7 +1381,7 @@ runDesugar' pdb loaded act = do
   pure (DesugarOutput renamed loaded' deps)
 
 runDesugarTerm
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i
@@ -1377,7 +1390,7 @@ runDesugarTerm
 runDesugarTerm _ pdb loaded = runDesugar' pdb loaded  . RenamerT . (desugarLispTerm >=> renameTerm)
 
 runDesugarModule'
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i
@@ -1386,7 +1399,7 @@ runDesugarModule'
 runDesugarModule' _ pdb loaded = runDesugar' pdb loaded . RenamerT . (desugarModule >=> renameModule)
 
 runDesugarInterface
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i
@@ -1395,7 +1408,7 @@ runDesugarInterface
 runDesugarInterface _ pdb loaded  = runDesugar' pdb loaded . RenamerT . (desugarInterface >=> renameInterface)
 
 runDesugarReplDefun
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i
@@ -1408,7 +1421,7 @@ runDesugarReplDefun _ pdb loaded =
   . (desugarDefun >=> renameReplDefun)
 
 runDesugarReplDefConst
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i
@@ -1428,7 +1441,7 @@ runDesugarReplDefConst _ pdb loaded =
 -- runDesugarModule loaded = runDesugarModule' loaded 0
 
 runDesugarTopLevel
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i
@@ -1443,7 +1456,7 @@ runDesugarTopLevel proxy pdb loaded = \case
 
 
 runDesugarReplTopLevel
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i