Skip to content

Commit

Permalink
fix CEK app position
Browse files Browse the repository at this point in the history
  • Loading branch information
@jmcardon
jmcardon committed Jan 13, 2025
1 parent ca77755 commit 8edb523
Show file tree
Hide file tree
Showing 4 changed files with 54 additions and 53 deletions.
10 changes: 5 additions & 5 deletions pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -95,9 +95,9 @@ coreExpect info b cont handler _env = \case
[VLiteral (LString testName), VClosure expected, VClosure provided] -> do
-- Get the state of execution before running the test
es <- get
tryError (applyLamUnsafe provided [] Mt CEKNoHandler) >>= \case
tryError (applyLamUnsafe info provided [] Mt CEKNoHandler) >>= \case
Right (EvalValue (VPactValue v2)) -> do
applyLamUnsafe expected [] Mt CEKNoHandler >>= \case
applyLamUnsafe info expected [] Mt CEKNoHandler >>= \case
EvalValue (VPactValue v1) -> do
-- If v1 /= v2, the test has failed
if v1 /= v2 then do
Expand Down Expand Up @@ -126,7 +126,7 @@ coreExpect info b cont handler _env = \case
coreExpectThat :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo
coreExpectThat info b cont handler _env = \case
[VLiteral (LString testName), VClosure vclo, v] -> do
applyLamUnsafe vclo [v] Mt CEKNoHandler >>= \case
applyLamUnsafe info vclo [v] Mt CEKNoHandler >>= \case
EvalValue (VBool c) ->
if c then do
let successMsg = "Expect-that: success " <> testName
Expand All @@ -147,7 +147,7 @@ coreExpectFailure :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo
coreExpectFailure info b cont handler _env = \case
[VString testName, VClosure vclo] -> do
es <- get
tryError (applyLamUnsafe vclo [] Mt CEKNoHandler) >>= \case
tryError (applyLamUnsafe info vclo [] Mt CEKNoHandler) >>= \case
Right (VError _ _ _) -> do
put es
returnTestSuccess info testName cont handler $ "Expect failure: Success: " <> testName
Expand All @@ -158,7 +158,7 @@ coreExpectFailure info b cont handler _env = \case
returnTestFailure info testName cont handler $ "FAILURE: " <> testName <> ": expected failure, got result"
[VString testName, VString toMatch, VClosure vclo] -> do
es <- get
tryError (applyLamUnsafe vclo [] Mt CEKNoHandler) >>= \case
tryError (applyLamUnsafe info vclo [] Mt CEKNoHandler) >>= \case
Right (VError _ errMsg _) -> do
put es
let err = renderCompactText errMsg
Expand Down
38 changes: 19 additions & 19 deletions pact/Pact/Core/IR/Eval/CEK/CoreBuiltin.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -626,7 +626,7 @@ zipList info b cont handler _env = \case
(x:xs, y:ys) -> do
chargeUnconsWork info
let cont' = BuiltinC _env info (ZipC clo (xs, ys) []) cont
applyLam clo [VPactValue x, VPactValue y] cont' handler
applyLam info clo [VPactValue x, VPactValue y] cont' handler
(_, _) -> returnCEKValue cont handler (VList mempty)
args -> argsError info b args

Expand All @@ -636,7 +636,7 @@ coreMap info b cont handler env = \case
x:xs -> do
let cont' = BuiltinC env info (MapC clo xs []) cont
chargeUnconsWork info
applyLam clo [VPactValue x] cont' handler
applyLam info clo [VPactValue x] cont' handler
[] -> returnCEKValue cont handler (VList mempty)
args -> argsError info b args

Expand All @@ -646,7 +646,7 @@ coreFilter info b cont handler _env = \case
x:xs -> do
chargeUnconsWork info
let cont' = CondC _env info (FilterC clo x xs []) cont
applyLam clo [VPactValue x] cont' handler
applyLam info clo [VPactValue x] cont' handler
[] -> returnCEKValue cont handler (VList mempty)
args -> argsError info b args

Expand All @@ -657,7 +657,7 @@ coreFold info b cont handler _env = \case
x:xs -> do
chargeUnconsWork info
let cont' = BuiltinC _env info (FoldC clo xs) cont
applyLam clo [VPactValue initElem, VPactValue x] cont' handler
applyLam info clo [VPactValue initElem, VPactValue x] cont' handler
[] -> returnCEKValue cont handler (VPactValue initElem)
args -> argsError info b args

Expand Down Expand Up @@ -764,7 +764,7 @@ coreResume info b cont handler env = \case
Nothing -> throwExecutionError info (NoYieldInDefPactStep pactStep)
Just y@(Yield resumeObj _ _) -> do
enforceYield info y
applyLam clo [VObject resumeObj] cont handler
applyLam info clo [VObject resumeObj] cont handler
args -> argsError info b args

-----------------------------------
Expand Down Expand Up @@ -989,7 +989,7 @@ coreReadKeyset info b cont handler _env = \case
coreBind :: (IsBuiltin b) => NativeFunction e b i
coreBind info b cont handler _env = \case
[v@VObject{}, VClosure clo] ->
applyLam clo [v] cont handler
applyLam info clo [v] cont handler
args -> argsError info b args


Expand Down Expand Up @@ -1023,7 +1023,7 @@ dbSelect info b cont handler env = \case
Just (RowData r) -> do
let bf = SelectC tv clo (ObjectData r) ks [] mfields
cont' = BuiltinC env info bf cont
applyLam clo [VObject r] cont' handler
applyLam info clo [VObject r] cont' handler
Nothing ->
failInvariant info (InvariantNoSuchKeyInTable (_tvName tv) k)
[] -> returnCEKValue cont handler (VList mempty)
Expand All @@ -1041,7 +1041,7 @@ foldDb info b cont handler env = \case
Just (RowData row) -> do
let rdf = FoldDbFilterC tv queryClo consumerClo (rk, ObjectData row) remaining' []
cont' = BuiltinC env info rdf cont
applyLam queryClo [VString raw, VObject row] cont' handler
applyLam info queryClo [VString raw, VObject row] cont' handler
Nothing ->
failInvariant info (InvariantNoSuchKeyInTable (_tvName tv) rk)
[] -> returnCEKValue cont handler (VList mempty)
Expand Down Expand Up @@ -1079,7 +1079,7 @@ dbRead info b cont handler env = \case
dbWithRead :: (IsBuiltin b) => NativeFunction e b i
dbWithRead info b cont handler env = \case
[VTable tv, VString k, VClosure clo] -> do
let cont' = Fn clo env [] [] cont
let cont' = Fn clo info env [] [] cont
dbRead info b cont' handler env [VTable tv, VString k]
args -> argsError info b args

Expand All @@ -1091,9 +1091,9 @@ dbWithDefaultRead info b cont handler env = \case
Just (RowData rdata) -> do
bytes <- sizeOf info SizeOfV0 rdata
chargeGasArgs info (GRead bytes)
applyLam clo [VObject rdata] cont handler
applyLam info clo [VObject rdata] cont handler
Nothing -> do
applyLam clo [VObject defaultObj] cont handler
applyLam info clo [VObject defaultObj] cont handler
args -> argsError info b args

-- | Todo: schema checking here? Or only on writes?
Expand Down Expand Up @@ -1412,21 +1412,21 @@ coreAndQ :: (IsBuiltin b) => NativeFunction e b i
coreAndQ info b cont handler env = \case
[VClosure l, VClosure r, VPactValue v] -> do
let cont' = CondC env info (AndQC r v) cont
applyLam l [VPactValue v] cont' handler
applyLam info l [VPactValue v] cont' handler
args -> argsError info b args

coreOrQ :: (IsBuiltin b) => NativeFunction e b i
coreOrQ info b cont handler env = \case
[VClosure l, VClosure r, VPactValue v] -> do
let cont' = CondC env info (OrQC r v) cont
applyLam l [VPactValue v] cont' handler
applyLam info l [VPactValue v] cont' handler
args -> argsError info b args

coreNotQ :: (IsBuiltin b) => NativeFunction e b i
coreNotQ info b cont handler env = \case
[VClosure clo, VPactValue v] -> do
let cont' = CondC env info NotQC cont
applyLam clo [VPactValue v] cont' handler
applyLam info clo [VPactValue v] cont' handler
args -> argsError info b args

coreWhere :: (IsBuiltin b) => NativeFunction e b i
Expand All @@ -1436,7 +1436,7 @@ coreWhere info b cont handler _env = \case
case M.lookup (Field field) o of
Just v -> do
let cont' = EnforceBoolC info cont
applyLam app [VPactValue v] cont' handler
applyLam info app [VPactValue v] cont' handler
Nothing ->
throwExecutionError info (ObjectIsMissingField (Field field) (ObjectData o))
args -> argsError info b args
Expand Down Expand Up @@ -1615,8 +1615,8 @@ dbDescribeKeySet info b cont handler env = \case
coreCompose :: (IsBuiltin b) => NativeFunction e b i
coreCompose info b cont handler env = \case
[VClosure clo1, VClosure clo2, v] -> do
let cont' = Fn clo2 env [] [] cont
applyLam clo1 [v] cont' handler
let cont' = Fn clo2 info env [] [] cont
applyLam info clo1 [v] cont' handler
args -> argsError info b args

coreCreatePrincipal :: (IsBuiltin b) => NativeFunction e b i
Expand Down Expand Up @@ -1654,7 +1654,7 @@ coreValidatePrincipal info b cont handler _env = \case

coreCond :: (IsBuiltin b) => NativeFunction e b i
coreCond info b cont handler _env = \case
[VClosure clo] -> applyLam clo [] cont handler
[VClosure clo] -> applyLam info clo [] cont handler
args -> argsError info b args


Expand Down Expand Up @@ -1717,7 +1717,7 @@ coreDefineNamespace info b cont handler env = \case
(Dfun d, mh) -> do
clo <- mkDefunClosure d (qualNameToFqn fun mh) env
let cont' = BuiltinC env info (DefineNamespaceC ns) cont
applyLam (C clo) [VString n, VGuard adminG] cont' handler
applyLam info (C clo) [VString n, VGuard adminG] cont' handler
_ -> throwNativeExecutionError info b $ "Fatal error: namespace manager function is not a defun"
args -> argsError info b args
where
Expand Down
Loading

0 comments on commit 8edb523

Please sign in to comment.