diff --git a/src/Juvix/Compiler/Nockma/Evaluator.hs b/src/Juvix/Compiler/Nockma/Evaluator.hs index 3ca175c09..59b515320 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator.hs +++ b/src/Juvix/Compiler/Nockma/Evaluator.hs @@ -16,8 +16,8 @@ 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.Compiler.Nockma.Pretty import Juvix.Prelude hiding (Atom, Path) -import Juvix.Prelude.Pretty newtype OpCounts = OpCounts { _opCountsMap :: HashMap NockOp Int @@ -358,7 +358,6 @@ evalProfile inistack initerm = OpReplace -> goOpReplace OpHint -> goOpHint OpScry -> goOpScry - OpTrace -> goOpTrace where crumb crumbTag = EvalCrumbOperator $ @@ -388,20 +387,19 @@ evalProfile inistack initerm = TermCell {} -> nockTrue TermAtom {} -> nockFalse - goOpTrace :: Sem r (Term a) - goOpTrace = do - Cell' tr a _ <- withCrumb (crumb crumbDecodeFirst) (asCell (c ^. operatorCellTerm)) - tr' <- evalArg crumbEvalFirst stack tr - output tr' - evalArg crumbEvalSecond stack a - goOpHint :: Sem r (Term a) goOpHint = do Cell' l r _ <- withCrumb (crumb crumbDecodeFirst) (asCell (c ^. operatorCellTerm)) case l of TAtom {} -> evalArg crumbEvalFirst stack r - TCell _t1 t2 -> do - void (evalArg crumbEvalFirst stack t2) + TCell t1 t2 -> do + t2' <- evalArg crumbEvalFirst stack t2 + putsHint <- fromNatural (nockHintValue NockHintPuts) + case t1 of + TAtom a + | a == putsHint -> + output t2' + _ -> return () evalArg crumbEvalSecond stack r goOpPush :: Sem r (Term a) diff --git a/src/Juvix/Compiler/Nockma/Language.hs b/src/Juvix/Compiler/Nockma/Language.hs index 2fadde74b..0c550f1a2 100644 --- a/src/Juvix/Compiler/Nockma/Language.hs +++ b/src/Juvix/Compiler/Nockma/Language.hs @@ -144,7 +144,6 @@ data NockOp | OpReplace | OpHint | OpScry - | OpTrace deriving stock (Bounded, Enum, Eq, Generic) instance Hashable NockOp @@ -164,7 +163,9 @@ instance Pretty NockOp where OpReplace -> "replace" OpHint -> "hint" OpScry -> "scry" - OpTrace -> "trace" + +data NockHint = NockHintPuts + deriving stock (Show, Eq, Enum, Bounded) textToStdlibFunctionMap :: HashMap Text StdlibFunction textToStdlibFunctionMap = @@ -267,7 +268,6 @@ serializeOp = \case OpReplace -> 10 OpHint -> 11 OpScry -> 12 - OpTrace -> 100 class (NockmaEq a) => NockNatural a where type ErrNockNatural a :: Type @@ -325,6 +325,22 @@ nockBoolLiteral b | b = nockTrueLiteral | otherwise = nockFalseLiteral +nockHintName :: NockHint -> Text +nockHintName = \case + NockHintPuts -> "puts" + +nockHintValue :: NockHint -> Natural +nockHintValue = \case + NockHintPuts -> 0x73747570 + +nockHintAtom :: NockHint -> Term Natural +nockHintAtom hint = + TermAtom + Atom + { _atomInfo = emptyAtomInfo, + _atom = nockHintValue hint + } + instance NockNatural Natural where type ErrNockNatural Natural = NockNaturalNaturalError nockNatural a = return (a ^. atom) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs index 478900786..e1d8e44f1 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs @@ -151,10 +151,18 @@ atomStringLiteral = do } return (Atom (textToNatural s) info) +atomNockHint :: Maybe Tag -> Parser (Atom Natural) +atomNockHint mtag = do + symbol Str.percent + let hints :: [NockHint] = enumerate + val <- choice (map (\hnt -> symbol (nockHintName hnt) >> return (nockHintValue hnt)) hints) + return (Atom val emptyAtomInfo {_atomInfoTag = mtag}) + patom :: Parser (Atom Natural) patom = do mtag <- optional pTag atomOp mtag + <|> atomNockHint mtag <|> atomNat mtag <|> atomPath mtag <|> atomBool diff --git a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs index 2a752e58b..7acddf911 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromTree.hs @@ -94,14 +94,11 @@ data BuiltinFunctionId instance Hashable BuiltinFunctionId -newtype CompilerOptions = CompilerOptions - {_compilerOptionsEnableTrace :: Bool} +data CompilerOptions = CompilerOptions fromEntryPoint :: EntryPoint -> CompilerOptions -fromEntryPoint EntryPoint {..} = +fromEntryPoint EntryPoint {} = CompilerOptions - { _compilerOptionsEnableTrace = _entryPointDebug - } data FunctionInfo = FunctionInfo { _functionInfoPath :: Path, @@ -115,8 +112,7 @@ newtype FunctionCtx = FunctionCtx data CompilerCtx = CompilerCtx { _compilerFunctionInfos :: HashMap FunctionId FunctionInfo, - _compilerConstructorInfos :: ConstructorInfos, - _compilerOptions :: CompilerOptions + _compilerConstructorInfos :: ConstructorInfos } data ConstructorInfo = ConstructorInfo @@ -652,12 +648,8 @@ compile = \case goTrace :: Term Natural -> Sem r (Term Natural) goTrace arg = do - enabled <- asks (^. compilerOptions . compilerOptionsEnableTrace) - return $ - if - -- TODO: remove duplication of `arg` here - | enabled -> OpTrace # arg # arg - | otherwise -> arg + -- TODO: remove duplication of `arg` here + return $ OpHint # (nockHintAtom NockHintPuts # arg) # arg goBinop :: Tree.NodeBinop -> Sem r (Term Natural) goBinop Tree.NodeBinop {..} = do @@ -922,7 +914,7 @@ remakeList :: (Foldable l) => l (Term Natural) -> Term Natural remakeList ts = foldTerms (toList ts `prependList` pure (OpQuote # nockNilTagged "remakeList")) runCompilerWith :: CompilerOptions -> ConstructorInfos -> [CompilerFunction] -> CompilerFunction -> AnomaResult -runCompilerWith opts constrs moduleFuns mainFun = makeAnomaFun +runCompilerWith _opts constrs moduleFuns mainFun = makeAnomaFun where libFuns :: [CompilerFunction] libFuns = moduleFuns ++ (builtinFunction <$> allElements) @@ -934,8 +926,7 @@ runCompilerWith opts constrs moduleFuns mainFun = makeAnomaFun compilerCtx = CompilerCtx { _compilerFunctionInfos = functionInfos, - _compilerConstructorInfos = constrs, - _compilerOptions = opts + _compilerConstructorInfos = constrs } mainClosure :: Term Natural diff --git a/src/Juvix/Extra/Strings.hs b/src/Juvix/Extra/Strings.hs index f8626bc5f..c310db1c5 100644 --- a/src/Juvix/Extra/Strings.hs +++ b/src/Juvix/Extra/Strings.hs @@ -803,6 +803,9 @@ tagTag = "tag@" stdlibTag :: (IsString s) => s stdlibTag = "stdlib@" +percent :: (IsString s) => s +percent = "%" + instrSub :: (IsString s) => s instrSub = "sub" diff --git a/test/Anoma/Compilation/Positive.hs b/test/Anoma/Compilation/Positive.hs index 3f53eb01b..dd8c37bb9 100644 --- a/test/Anoma/Compilation/Positive.hs +++ b/test/Anoma/Compilation/Positive.hs @@ -40,8 +40,8 @@ mkAnomaCallTest' enableDebug _testProgramStorage _testName relRoot mainFile args <$> testDefaultEntryPointIO testRootDir (testRootDir mainFile) (^. pipelineResult) . snd <$> testRunIO entryPoint upToAnoma -mkAnomaCallTestNoTrace :: Text -> Prelude.Path Rel Dir -> Prelude.Path Rel File -> [Term Natural] -> Check () -> TestTree -mkAnomaCallTestNoTrace = mkAnomaCallTest' False emptyStorage +mkAnomaCallTestNoDebug :: Text -> Prelude.Path Rel Dir -> Prelude.Path Rel File -> [Term Natural] -> Check () -> TestTree +mkAnomaCallTestNoDebug = mkAnomaCallTest' False emptyStorage mkAnomaCallTest :: Text -> Prelude.Path Rel Dir -> Prelude.Path Rel File -> [Term Natural] -> Check () -> TestTree mkAnomaCallTest = mkAnomaCallTest' True emptyStorage @@ -78,12 +78,12 @@ allTests = $(mkRelFile "test003.juvix") [] (checkNatOutput [1, 4, 2, 4, 0]), - mkAnomaCallTestNoTrace - "Test003: Integer arithmetic - no trace" + mkAnomaCallTestNoDebug + "Test003: Integer arithmetic - no debug" $(mkRelDir ".") $(mkRelFile "test003.juvix") [] - (checkNatOutput [0]), + (checkNatOutput [1, 4, 2, 4, 0]), mkAnomaCallTest "Test005: Higher-order functions" $(mkRelDir ".") diff --git a/test/Nockma/Eval/Positive.hs b/test/Nockma/Eval/Positive.hs index f30402095..106905b5c 100644 --- a/test/Nockma/Eval/Positive.hs +++ b/test/Nockma/Eval/Positive.hs @@ -132,7 +132,7 @@ anomaTest n mainFun args _testCheck _evalInterceptStdlibCalls = | _evalInterceptStdlibCalls = n <> " - intercept stdlib" | otherwise = n - opts = CompilerOptions {_compilerOptionsEnableTrace = False} + opts = CompilerOptions res :: AnomaResult = runCompilerWith opts mempty [] f _testProgramSubject = res ^. anomaClosure @@ -302,7 +302,7 @@ 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 [1937012080 [quote 2]] [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 |]), withAssertErrKeyNotInStorage $ testWithStorage [([nock| 333 |], [nock| 222 |]), ([nock| 3 |], [nock| 222 |])] "scry" [nock| nil |] [nock| [scry [quote nil] [quote 111]] |] (eqNock [nock| 222 |]) ]