From 7141f3bbea782f2434a252fcd3b3e915b04899d8 Mon Sep 17 00:00:00 2001 From: rsoeldner Date: Mon, 25 Sep 2023 21:42:14 +0200 Subject: [PATCH] wip --- pact-core/Pact/Core/Errors.hs | 4 ++++ pact-core/Pact/Core/IR/Desugar.hs | 10 ++++++++-- pact-core/Pact/Core/IR/Eval/CEK.hs | 7 +++++++ pact-core/Pact/Core/IR/Eval/Runtime/Types.hs | 1 + pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs | 2 +- pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs | 2 +- pact-core/Pact/Core/Syntax/Parser.y | 2 +- 7 files changed, 23 insertions(+), 5 deletions(-) diff --git a/pact-core/Pact/Core/Errors.hs b/pact-core/Pact/Core/Errors.hs index 529c67fb2..0388b2dfc 100644 --- a/pact-core/Pact/Core/Errors.hs +++ b/pact-core/Pact/Core/Errors.hs @@ -130,6 +130,8 @@ data DesugarError -- | EmptyDefPact Text -- ^ Defpact without steps + | LastStepWithRollback QualifiedName + -- ^ Last Step has Rollback error deriving Show instance Exception DesugarError @@ -183,6 +185,8 @@ instance Pretty DesugarError where Pretty.hsep ["Invalid Interface attempted to be used as module reference:", pretty mn] EmptyBindingBody -> "Bind expression lacks an accompanying body" EmptyDefPact dp -> Pretty.hsep ["Defpact has no steps:", pretty dp] + LastStepWithRollback mn -> + Pretty.hsep ["rollbacks aren't allowed on the last step in:", pretty mn] -- data TypecheckError -- = UnificationError (Type Text) (Type Text) diff --git a/pact-core/Pact/Core/IR/Desugar.hs b/pact-core/Pact/Core/IR/Desugar.hs index 3bbf36f99..45f196928 100644 --- a/pact-core/Pact/Core/IR/Desugar.hs +++ b/pact-core/Pact/Core/IR/Desugar.hs @@ -363,7 +363,8 @@ desugarDefPact :: forall i m raw reso. MonadDesugar raw reso i m => Lisp.DefPact i -> m (DefPact ParsedName DesugarType raw i) -desugarDefPact (Lisp.DefPact dpname _ _ [] _ _ i) = throwDesugarError (EmptyDefPact dpname) i +desugarDefPact (Lisp.DefPact dpname _ _ [] _ _ i) = + throwDesugarError (EmptyDefPact dpname) i desugarDefPact (Lisp.DefPact dpname margs rt (step:steps) _ _ i) = view reCurrModule >>= \case Just mn -> do @@ -383,7 +384,12 @@ desugarDefPact (Lisp.DefPact dpname margs rt (step:steps) _ _ i) = <$> desugarStep s <*> desugarStep rb <*> desugarMSteps ms - pure $ DefPact dpname args' rt (NE.reverse steps') i + + -- In Pact, last steps are not allowed to roll back. + when (hasRollback $ NE.last steps') $ + throwDesugarError (LastStepWithRollback (QualifiedName dpname mn)) i + + pure $ DefPact dpname args' rt steps' i Nothing -> error "Defpact is module-less" desugarDefConst diff --git a/pact-core/Pact/Core/IR/Eval/CEK.hs b/pact-core/Pact/Core/IR/Eval/CEK.hs index 8d2bb1f5b..48e143222 100644 --- a/pact-core/Pact/Core/IR/Eval/CEK.hs +++ b/pact-core/Pact/Core/IR/Eval/CEK.hs @@ -539,6 +539,13 @@ returnCEKValue (StackPopC mty cont) handler v = do v' <- (`maybeTCType` mty) =<< enforcePactValue v -- Todo: unsafe use of tail here. need `tailMay` (esStack %%= tail) *> returnCEKValue cont handler (VPactValue v') +returnCEKValue (PactStepC cont) handler v = do + -- We need to reset the `yield` value of the current pact exection + -- environment to match pact semantics. This `PactStepC` frame is + -- only used as a continuation which resets the `yield`. + setEvalState (esPactExec . _Just . peYield) Nothing + returnCEKValue cont handler v + applyLam diff --git a/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs b/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs index c0e6084fe..99875c17f 100644 --- a/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs +++ b/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs @@ -442,6 +442,7 @@ data Cont b i m | CapBodyC (CEKEnv b i m) (EvalTerm b i) (Cont b i m) | CapPopC CapPopState (Cont b i m) | StackPopC (Maybe Type) (Cont b i m) + | PactStepC (Cont b i m) | Mt deriving Show diff --git a/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs b/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs index cf31ccf42..8f53b00ee 100644 --- a/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs +++ b/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs @@ -118,7 +118,7 @@ enforcePactValue = \case -- viewsCEKEnv :: (MonadEval b i m) => Lens' (EvalEnv b i m) s -> (s -> a) -> m a -- viewsCEKEnv l f = views f l <$> cekReadEnv f -setEvalState :: (MonadEval b i m) => Lens' (EvalState b i) s -> s -> m () +setEvalState :: (MonadEval b i m) => Traversal' (EvalState b i) s -> s -> m () setEvalState l s = modifyEvalState (set l s) -- overEvalState :: (MonadEval b i m) => Lens' (EvalState b i) s -> (s -> s) -> m () diff --git a/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs b/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs index 619ef1d64..650f08b69 100644 --- a/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs +++ b/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs @@ -119,7 +119,7 @@ continuePact info b = mkReplBuiltinFn info b \cont handler -> \case Step s' _ -> toClosure s' StepWithRollback s' _rb _ -> toClosure s' setEvalState esPactExec (Just $ over peStep (+1) pe) - returnCEK cont handler v + returnCEK (PactStepC cont) handler v | otherwise -> throwExecutionError info (ContinuePactInvalidContext s (toInteger (_peStep pe)) (toInteger (_peStepCount pe))) _ -> pure (VError "continuation is not a defpact") diff --git a/pact-core/Pact/Core/Syntax/Parser.y b/pact-core/Pact/Core/Syntax/Parser.y index 7527ac4f7..1732fd77d 100644 --- a/pact-core/Pact/Core/Syntax/Parser.y +++ b/pact-core/Pact/Core/Syntax/Parser.y @@ -262,7 +262,7 @@ Defcap :: { SpanInfo -> DefCap SpanInfo } DefPact :: { SpanInfo -> DefPact SpanInfo } : defpact IDENT MTypeAnn '(' MArgs ')' MDocOrModel Steps - { DefPact (getIdent $2) $5 $3 $8 (fst $7) (snd $7) } + { DefPact (getIdent $2) $5 $3 (reverse $8) (fst $7) (snd $7) } Steps :: { [PactStep SpanInfo] } : Steps Step { $2:$1 }