From ef9f77b6a44a1f424dde3002f98cd9b865ba7a97 Mon Sep 17 00:00:00 2001 From: Paul Cadman Date: Sun, 3 Mar 2024 16:49:32 +0100 Subject: [PATCH] Evaluate Nockma scry/op12 and add a test --- src/Juvix/Compiler/Nockma/EvalCompiled.hs | 1 + src/Juvix/Compiler/Nockma/Evaluator.hs | 17 ++++++++++++++--- src/Juvix/Compiler/Nockma/Evaluator/Storage.hs | 12 ++++++++++++ test/Anoma/Compilation/Positive.hs | 1 + test/Nockma/Eval/Positive.hs | 13 +++++++++++-- 5 files changed, 39 insertions(+), 5 deletions(-) create mode 100644 src/Juvix/Compiler/Nockma/Evaluator/Storage.hs diff --git a/src/Juvix/Compiler/Nockma/EvalCompiled.hs b/src/Juvix/Compiler/Nockma/EvalCompiled.hs index e802712d52..52272ae7ae 100644 --- a/src/Juvix/Compiler/Nockma/EvalCompiled.hs +++ b/src/Juvix/Compiler/Nockma/EvalCompiled.hs @@ -10,6 +10,7 @@ evalCompiledNock' stack mainTerm = do evalT <- runError @(ErrNockNatural Natural) . runError @(NockEvalError Natural) + . runReader @(Storage Natural) emptyStorage $ eval stack mainTerm case evalT of Left e -> error (show e) diff --git a/src/Juvix/Compiler/Nockma/Evaluator.hs b/src/Juvix/Compiler/Nockma/Evaluator.hs index bd523c9820..8aebca6f95 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator.hs +++ b/src/Juvix/Compiler/Nockma/Evaluator.hs @@ -2,11 +2,14 @@ module Juvix.Compiler.Nockma.Evaluator ( module Juvix.Compiler.Nockma.Evaluator, module Juvix.Compiler.Nockma.Evaluator.Error, module Juvix.Compiler.Nockma.Evaluator.Options, + module Juvix.Compiler.Nockma.Evaluator.Storage, ) where +import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Nockma.Evaluator.Error import Juvix.Compiler.Nockma.Evaluator.Options +import Juvix.Compiler.Nockma.Evaluator.Storage import Juvix.Compiler.Nockma.Language import Juvix.Prelude hiding (Atom, Path) @@ -102,7 +105,7 @@ programAssignments mprog = -- | The stack provided in the replExpression has priority evalRepl :: forall r a. - (Integral a, Members '[Reader EvalOptions, Error (NockEvalError a), Error (ErrNockNatural a)] r, NockNatural a) => + (Hashable a, Integral a, Members '[Reader EvalOptions, Error (NockEvalError a), Error (ErrNockNatural a)] r, NockNatural a) => (Term a -> Sem r ()) -> Maybe (Program a) -> Maybe (Term a) -> @@ -115,7 +118,7 @@ evalRepl handleTrace mprog defaultStack expr = do t' <- fromReplTerm namedTerms (w ^. withStackStack) return (Just t', w ^. withStackTerm) stack <- maybe errNoStack return mstack - fromReplTerm namedTerms t >>= runOutputSem @(Term a) handleTrace . eval stack + fromReplTerm namedTerms t >>= runOutputSem @(Term a) handleTrace . runReader @(Storage a) emptyStorage . eval stack where errNoStack :: Sem r x errNoStack = throw @(NockEvalError a) (ErrNoStack NoStack) @@ -125,7 +128,7 @@ evalRepl handleTrace mprog defaultStack expr = do eval :: forall s a. - (Integral a, Members '[Reader EvalOptions, Output (Term a), Error (NockEvalError a), Error (ErrNockNatural a)] s, NockNatural a) => + (Hashable a, Integral a, Members '[Reader (Storage a), Reader EvalOptions, Output (Term a), Error (NockEvalError a), Error (ErrNockNatural a)] s, NockNatural a) => Term a -> Term a -> Sem s (Term a) @@ -210,6 +213,7 @@ eval inistack initerm = OpCall -> goOpCall OpReplace -> goOpReplace OpHint -> goOpHint + OpScry -> goOpScry OpTrace -> goOpTrace where crumb crumbTag = @@ -317,3 +321,10 @@ eval inistack initerm = cellTerm <- withCrumb (crumb crumbDecodeFirst) (asCell (c ^. operatorCellTerm)) t1' <- evalArg crumbEvalFirst stack (cellTerm ^. cellLeft) evalArg crumbEvalSecond t1' (cellTerm ^. cellRight) + + goOpScry :: Sem r (Term a) + goOpScry = do + Cell' typeFormula subFormula _ <- withCrumb (crumb crumbDecodeFirst) (asCell (c ^. operatorCellTerm)) + void (evalArg crumbEvalFirst stack typeFormula) + subResult <- evalArg crumbEvalSecond stack subFormula + HashMap.lookupDefault impossible subResult <$> asks (^. storageKeyValueData) diff --git a/src/Juvix/Compiler/Nockma/Evaluator/Storage.hs b/src/Juvix/Compiler/Nockma/Evaluator/Storage.hs new file mode 100644 index 0000000000..57b5505205 --- /dev/null +++ b/src/Juvix/Compiler/Nockma/Evaluator/Storage.hs @@ -0,0 +1,12 @@ +module Juvix.Compiler.Nockma.Evaluator.Storage where + +import Juvix.Compiler.Nockma.Language +import Juvix.Prelude.Base + +newtype Storage a = Storage + {_storageKeyValueData :: HashMap (Term a) (Term a)} + +emptyStorage :: (Hashable a) => Storage a +emptyStorage = Storage {_storageKeyValueData = mempty} + +makeLenses ''Storage diff --git a/test/Anoma/Compilation/Positive.hs b/test/Anoma/Compilation/Positive.hs index b27f42717f..59c4e34500 100644 --- a/test/Anoma/Compilation/Positive.hs +++ b/test/Anoma/Compilation/Positive.hs @@ -27,6 +27,7 @@ mkAnomaCallTest' enableDebug _testName relRoot mainFile args _testCheck = return compiledMain let _testProgramFormula = anomaCall args _testEvalOptions = defaultEvalOptions + _testProgramStorage :: Storage Natural = emptyStorage return Test {..} withRootCopy :: (Prelude.Path Abs Dir -> IO a) -> IO a diff --git a/test/Nockma/Eval/Positive.hs b/test/Nockma/Eval/Positive.hs index a493af0e1d..4fdb07bc33 100644 --- a/test/Nockma/Eval/Positive.hs +++ b/test/Nockma/Eval/Positive.hs @@ -1,6 +1,7 @@ module Nockma.Eval.Positive where import Base hiding (Path, testName) +import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Core.Language.Base (defaultSymbol) import Juvix.Compiler.Nockma.Evaluator import Juvix.Compiler.Nockma.Language @@ -13,6 +14,7 @@ type Check = Sem '[Reader [Term Natural], Reader (Term Natural), EmbedIO] data Test = Test { _testEvalOptions :: EvalOptions, + _testProgramStorage :: Storage Natural, _testName :: Text, _testProgramSubject :: Term Natural, _testProgramFormula :: Term Natural, @@ -29,6 +31,7 @@ mkNockmaAssertion Test {..} = do . runOutputList @(Term Natural) . runError @(ErrNockNatural Natural) . runError @(NockEvalError Natural) + . runReader @(Storage Natural) _testProgramStorage $ eval _testProgramSubject _testProgramFormula case evalResult of @@ -91,6 +94,7 @@ compilerTest n mainFun _testCheck _evalInterceptStdlibCalls = opts = CompilerOptions {_compilerOptionsEnableTrace = False} Cell _testProgramSubject _testProgramFormula = runCompilerWithJuvix opts mempty [] f _testEvalOptions = EvalOptions {..} + _testProgramStorage :: Storage Natural = emptyStorage in Test {..} anomaTest :: Text -> Term Natural -> [Term Natural] -> Check () -> Bool -> Test @@ -110,11 +114,15 @@ anomaTest n mainFun args _testCheck _evalInterceptStdlibCalls = _testProgramSubject = TermCell (runCompilerWithAnoma opts mempty [] f) _testProgramFormula = anomaCall args + _testProgramStorage :: Storage Natural = emptyStorage _testEvalOptions = EvalOptions {..} in Test {..} +testWithStorage :: [(Term Natural, Term Natural)] -> Text -> Term Natural -> Term Natural -> Check () -> Test +testWithStorage s = Test defaultEvalOptions (Storage (HashMap.fromList s)) + test :: Text -> Term Natural -> Term Natural -> Check () -> Test -test = Test defaultEvalOptions +test = testWithStorage [] anomaCallingConventionTests :: [Test] anomaCallingConventionTests = @@ -158,5 +166,6 @@ unitTests = test "push" [nock| [0 1] |] [nock| [push [[suc [@ L]] [@ S]]] |] (eqNock [nock| [1 0 1] |]), test "call" [nock| [quote 1] |] [nock| [call [S [@ S]]] |] (eqNock [nock| 1 |]), test "replace" [nock| [0 1] |] [nock| [replace [[L [quote 1]] [@ S]]] |] (eqNock [nock| [1 1] |]), - test "hint" [nock| [0 1] |] [nock| [hint [nil [trace [quote 2] [quote 3]]] [quote 1]] |] (eqTraces [[nock| 2 |]] >> eqNock [nock| 1 |]) + test "hint" [nock| [0 1] |] [nock| [hint [nil [trace [quote 2] [quote 3]]] [quote 1]] |] (eqTraces [[nock| 2 |]] >> eqNock [nock| 1 |]), + testWithStorage [([nock| 111 |], [nock| 222 |])] "scry" [nock| nil |] [nock| [scry [quote nil] [quote 111]] |] (eqNock [nock| 222 |]) ]