Miscellaneous improvements for Nockma debugging (#2714)

Each commit in this PR is a separate improvement.

* Tag any Term with a string instead of just cells using `@`. e.g
`"myTag" @ opCall ...`
* `:dump FILE` in the nockma REPL to dump the last REPL result to a
file.
* More tagging in the pretty nockma output.

app/Commands/Dev/Nockma/Repl.hs

@@ -23,7 +23,8 @@ type ReplS = State.StateT ReplState IO
 data ReplState = ReplState
   { _replStateProgram :: Maybe (Program Natural),
     _replStateStack :: Maybe (Term Natural),
-    _replStateLoadedFile :: Maybe (Prelude.Path Abs File)
+    _replStateLoadedFile :: Maybe (Prelude.Path Abs File),
+    _replStateLastResult :: Term Natural
   }
 
 type Repl a = Repline.HaskelineT ReplS a
@@ -42,6 +43,7 @@ printHelpTxt = liftIO $ putStrLn helpTxt
   :help                           Print help text and describe options
   :set-stack EXPRESSION           Set the current stack
   :get-stack                      Print the current stack
+  :dump FILE                      Write the last result to FILE
   :dir       NATURAL              Convert a natural number representing a position into a sequence of L and Rs. S means the empty sequence
   :quit                           Exit the REPL
           |]
@@ -70,6 +72,12 @@ loadFile s = Repline.dontCrash $ do
   prog <- readProgram s
   State.modify (set replStateProgram (Just prog))
 
+dump :: FilePath -> Repl ()
+dump f = Repline.dontCrash $ do
+  p <- Prelude.resolveFile' f
+  t <- State.gets (^. replStateLastResult)
+  writeFileEnsureLn p (ppPrint t)
+
 reloadFile :: Repl ()
 reloadFile = Repline.dontCrash $ do
   fp <- State.gets (^. replStateLoadedFile)
@@ -87,6 +95,7 @@ options =
     ("load", loadFile . Prelude.absFile),
     ("reload", const reloadFile),
     ("dir", direction'),
+    ("dump", dump),
     ("help", const printHelpTxt)
   ]
 
@@ -150,7 +159,9 @@ evalStatement = \case
       Left e -> error (show e)
       Right ev -> case ev of
         Left e -> error (ppTrace e)
-        Right res -> liftIO (putStrLn (ppPrint res))
+        Right res -> do
+          State.modify (set replStateLastResult res)
+          liftIO (putStrLn (ppPrint res))
 
 replCommand :: String -> Repl ()
 replCommand input_ = Repline.dontCrash $ do
@@ -188,5 +199,6 @@ runCommand opts = do
       ReplState
         { _replStateStack = mt,
           _replStateProgram = Nothing,
-          _replStateLoadedFile = Nothing
+          _replStateLoadedFile = Nothing,
+          _replStateLastResult = nockNilTagged "repl-result"
         }

src/Juvix/Compiler/Nockma/Language.hs

@@ -290,9 +290,6 @@ nockBool = \case
 nockNilTagged :: Text -> Term Natural
 nockNilTagged txt = TermAtom (set atomTag (Just (Tag txt)) nockNil)
 
-nockNilUntagged :: Term Natural
-nockNilUntagged = TermAtom nockNil
-
 data NockNaturalNaturalError
   = NaturalInvalidPath (Atom Natural)
   | NaturalInvalidOp (Atom Natural)
@@ -360,15 +357,37 @@ instance IsNock Path where
 instance IsNock EncodedPath where
   toNock = toNock . decodePath'
 
+class HasTag a where
+  atTag :: Lens' a (Maybe Tag)
+
+instance (HasTag (Term a)) where
+  atTag = lens getTag setTag
+    where
+      getTag :: Term x -> Maybe Tag
+      getTag = \case
+        TermAtom x -> x ^. atomTag
+        TermCell x -> x ^. cellTag
+
+      setTag :: Term a -> Maybe Tag -> Term a
+      setTag t newTag = case t of
+        TermAtom x -> TermAtom (set atomTag newTag x)
+        TermCell x -> TermCell (set cellTag newTag x)
+
+instance (HasTag (Cell a)) where
+  atTag = cellTag
+
+instance (HasTag (Atom a)) where
+  atTag = atomTag
+
 infixr 1 @.
 
 (@.) :: Text -> Cell Natural -> Cell Natural
 tag @. c = set cellTag (Just (Tag tag)) c
 
 infixr 1 @
 
-(@) :: Text -> Cell Natural -> Term Natural
-tag @ c = TermCell (set cellTag (Just (Tag tag)) c)
+(@) :: (HasTag a) => Text -> a -> a
+tagTxt @ c = set atTag (Just (Tag tagTxt)) c
 
 infixr 5 #.
 
@@ -391,16 +410,16 @@ infixl 1 >>#
 a >># b = TermCell (a >>#. b)
 
 opCall :: Text -> Path -> Term Natural -> Term Natural
-opCall txt p t = txt @ (OpCall #. (p # t))
+opCall txt p t = TermCell (txt @ (OpCall #. (p # t)))
 
 opReplace :: Text -> Path -> Term Natural -> Term Natural -> Term Natural
-opReplace txt p t1 t2 = txt @ OpReplace #. ((p #. t1) #. t2)
+opReplace txt p t1 t2 = TermCell (txt @ OpReplace #. ((p #. t1) #. t2))
 
 opAddress :: Text -> Path -> Term Natural
-opAddress txt p = txt @ OpAddress #. p
+opAddress txt p = TermCell (txt @ OpAddress #. p)
 
 opQuote :: (IsNock x) => Text -> x -> Term Natural
-opQuote txt p = txt @ OpQuote #. p
+opQuote txt p = TermCell (txt @ OpQuote #. p)
 
 {-# COMPLETE Cell #-}
 

src/Juvix/Compiler/Nockma/Pretty/Base.hs

@@ -101,9 +101,9 @@ unfoldCell c = c ^. cellLeft :| reverse (go [] (c ^. cellRight))
     go :: [Term a] -> Term a -> [Term a]
     go acc t = case t of
       TermAtom {} -> t : acc
-      TermCell (Cell' l r i) -> case i ^. cellInfoCall of
-        Nothing -> go (l : acc) r
-        Just {} -> t : acc
+      TermCell (Cell' l r i)
+        | isNothing (i ^. cellInfoCall) && isNothing (i ^. cellInfoTag) -> go (l : acc) r
+        | otherwise -> t : acc
 
 instance (PrettyCode a, NockNatural a) => PrettyCode (Term a) where
   ppCode = \case

src/Juvix/Compiler/Nockma/Translation/FromTree.hs

@@ -3,6 +3,7 @@ module Juvix.Compiler.Nockma.Translation.FromTree
     fromTreeTable,
     AnomaResult (..),
     anomaClosure,
+    compilerFunctionId,
     compilerFunctionName,
     AnomaCallablePathId (..),
     CompilerOptions (..),
@@ -40,6 +41,7 @@ import Juvix.Compiler.Pipeline.EntryPoint
 import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree
 import Juvix.Compiler.Tree.Language qualified as Tree
 import Juvix.Compiler.Tree.Language.Rep
+import Juvix.Extra.Strings qualified as Str
 import Juvix.Prelude hiding (Atom, Path)
 
 newtype AnomaResult = AnomaResult
@@ -94,7 +96,8 @@ fromEntryPoint EntryPoint {..} =
 
 data FunctionInfo = FunctionInfo
   { _functionInfoPath :: Path,
-    _functionInfoArity :: Natural
+    _functionInfoArity :: Natural,
+    _functionInfoName :: Text
   }
 
 data FunctionCtx = FunctionCtx
@@ -115,7 +118,8 @@ data ConstructorInfo = ConstructorInfo
 type ConstructorInfos = HashMap Tree.Tag ConstructorInfo
 
 data CompilerFunction = CompilerFunction
-  { _compilerFunctionName :: FunctionId,
+  { _compilerFunctionId :: FunctionId,
+    _compilerFunctionName :: Text,
     _compilerFunctionArity :: Natural,
     _compilerFunction :: Sem '[Reader CompilerCtx, Reader FunctionCtx] (Term Natural)
   }
@@ -271,7 +275,8 @@ fromTreeTable t = case t ^. Tree.infoMainFunction of
         compileFunction :: Tree.FunctionInfo -> CompilerFunction
         compileFunction Tree.FunctionInfo {..} =
           CompilerFunction
-            { _compilerFunctionName = UserFunction _functionSymbol,
+            { _compilerFunctionId = UserFunction _functionSymbol,
+              _compilerFunctionName = _functionName,
               _compilerFunctionArity = fromIntegral _functionArgsNum,
               _compilerFunction = compile _functionCode
             }
@@ -292,7 +297,7 @@ anomaCallableClosureWrapper =
   let closureArgsNum :: Term Natural = getClosureFieldInSubject ClosureArgsNum
       closureTotalArgsNum :: Term Natural = getClosureFieldInSubject ClosureTotalArgsNum
       appendAndReplaceArgsTuple =
-        replaceArgsWithTerm $
+        replaceArgsWithTerm "anomaCallableClosureWrapper" $
           appendToTuple
             (getClosureFieldInSubject ClosureArgs)
             closureArgsNum
@@ -477,10 +482,10 @@ compile = \case
       return . makeClosure $ \case
         WrapperCode -> OpQuote # anomaCallableClosureWrapper
         ArgsTuple -> OpQuote # argsTuplePlaceholder "goAllocClosure"
+        FunctionsLibrary -> OpQuote # functionsLibraryPlaceHolder
         RawCode -> opAddress "allocClosureFunPath" (fpath <> closurePath RawCode)
         TempStack -> remakeList []
         StandardLibrary -> OpQuote # stdlib
-        FunctionsLibrary -> OpQuote # functionsLibraryPlaceHolder
         ClosureTotalArgsNum -> nockNatLiteral farity
         ClosureArgsNum -> nockIntegralLiteral (length args)
         ClosureArgs -> remakeList args
@@ -720,27 +725,29 @@ runCompilerWith opts constrs moduleFuns mainFun = makeAnomaFun
     compiledFuns =
       mainClosure
         :| ( makeLibraryFunction
-               <$> ( runCompilerFunction compilerCtx <$> libFuns
-                   )
+               <$> [(f ^. compilerFunctionName, runCompilerFunction compilerCtx f) | f <- libFuns]
            )
 
     exportEnv :: Term Natural
-    exportEnv = makeList compiledFuns
-
-    makeLibraryFunction :: Term Natural -> Term Natural
-    makeLibraryFunction c = makeClosure $ \p ->
-      let nockNilHere = nockNilTagged ("makeLibraryFunction-" <> show p)
-       in case p of
-            WrapperCode -> c
-            ArgsTuple -> argsTuplePlaceholder "libraryFunction"
-            FunctionsLibrary -> functionsLibraryPlaceHolder
-            RawCode -> c
-            TempStack -> nockNilHere
-            StandardLibrary -> stdlib
-            ClosureTotalArgsNum -> nockNilHere
-            ClosureArgsNum -> nockNilHere
-            ClosureArgs -> nockNilHere
-            AnomaGetOrder -> nockNilHere
+    exportEnv = Str.theFunctionsLibrary @ makeList compiledFuns
+
+    makeLibraryFunction :: (Text, Term Natural) -> Term Natural
+    makeLibraryFunction (funName, c) =
+      ("def-" <> funName)
+        @ ( makeClosure $ \p ->
+              let nockNilHere = nockNilTagged ("makeLibraryFunction-" <> show p)
+               in case p of
+                    WrapperCode -> ("wrapperCode-" <> funName) @ c
+                    ArgsTuple -> ("argsTuple-" <> funName) @ argsTuplePlaceholder "libraryFunction"
+                    FunctionsLibrary -> ("functionsLibrary-" <> funName) @ functionsLibraryPlaceHolder
+                    RawCode -> ("rawCode-" <> funName) @ c
+                    TempStack -> ("tempStack-" <> funName) @ nockNilHere
+                    StandardLibrary -> ("stdlib-" <> funName) @ stdlib
+                    ClosureTotalArgsNum -> ("closureTotalArgsNum-" <> funName) @ nockNilHere
+                    ClosureArgsNum -> ("closureArgsNum-" <> funName) @ nockNilHere
+                    ClosureArgs -> ("closureArgs-" <> funName) @ nockNilHere
+                    AnomaGetOrder -> ("anomaGetOrder-" <> funName) @ nockNilHere
+          )
 
     makeMainFunction :: Term Natural -> Term Natural
     makeMainFunction c = makeClosure $ \p ->
@@ -764,10 +771,11 @@ runCompilerWith opts constrs moduleFuns mainFun = makeAnomaFun
     userFunctions = forM allFuns $ \CompilerFunction {..} -> do
       i <- input
       return
-        ( _compilerFunctionName,
+        ( _compilerFunctionId,
           FunctionInfo
             { _functionInfoPath = indexInStack FunctionsLibrary i,
-              _functionInfoArity = _compilerFunctionArity
+              _functionInfoArity = _compilerFunctionArity,
+              _functionInfoName = _compilerFunctionName
             }
         )
 
@@ -807,9 +815,10 @@ builtinFunction :: BuiltinFunctionId -> CompilerFunction
 builtinFunction = \case
   BuiltinPlaceholder ->
     CompilerFunction
-      { _compilerFunctionName = BuiltinFunction BuiltinPlaceholder,
+      { _compilerFunctionId = BuiltinFunction BuiltinPlaceholder,
         _compilerFunctionArity = 0,
-        _compilerFunction = return crash
+        _compilerFunction = return crash,
+        _compilerFunctionName = "builtinPlaceholderName"
       }
 
 closurePath :: AnomaCallablePathId -> Path
@@ -823,8 +832,9 @@ callFun ::
   Sem r (Term Natural)
 callFun fun = do
   fpath <- getFunctionPath fun
+  fname <- getFunctionName fun
   let p' = fpath ++ closurePath WrapperCode
-  return (opCall "callFun" p' (opAddress "callFunSubject" emptyPath))
+  return (opCall ("callFun-" <> fname) p' (opAddress "callFunSubject" emptyPath))
 
 -- | Call a function with the passed arguments
 callFunWithArgs ::
@@ -835,25 +845,34 @@ callFunWithArgs ::
 callFunWithArgs fun args = (replaceArgs args >>#) <$> callFun fun
 
 replaceSubject :: (AnomaCallablePathId -> Maybe (Term Natural)) -> Term Natural
-replaceSubject f =
+replaceSubject = replaceSubject' "replaceSubject"
+
+replaceSubject' :: Text -> (AnomaCallablePathId -> Maybe (Term Natural)) -> Term Natural
+replaceSubject' tag f =
   remakeList
     [ case f s of
-        Nothing -> opAddress "replaceSubject" (closurePath s)
+        Nothing -> opAddress tag (closurePath s)
         Just t' -> t'
       | s <- allElements
     ]
 
-replaceArgsWithTerm :: Term Natural -> Term Natural
-replaceArgsWithTerm term =
-  replaceSubject $ \case
+replaceArgsWithTerm :: Text -> Term Natural -> Term Natural
+replaceArgsWithTerm tag term =
+  replaceSubject' ("replaceArgsWithTerm-" <> tag) $ \case
     ArgsTuple -> Just term
     _ -> Nothing
 
 replaceArgs :: [Term Natural] -> Term Natural
-replaceArgs = replaceArgsWithTerm . foldTermsOrNil
+replaceArgs = replaceArgsWithTerm "replaceArgs" . foldTermsOrNil
+
+getFunctionInfo :: (Members '[Reader CompilerCtx] r) => FunctionId -> Sem r FunctionInfo
+getFunctionInfo funId = asks (^?! compilerFunctionInfos . at funId . _Just)
 
 getFunctionPath :: (Members '[Reader CompilerCtx] r) => FunctionId -> Sem r Path
-getFunctionPath funName = asks (^?! compilerFunctionInfos . at funName . _Just . functionInfoPath)
+getFunctionPath funId = (^. functionInfoPath) <$> getFunctionInfo funId
+
+getFunctionName :: (Members '[Reader CompilerCtx] r) => FunctionId -> Sem r Text
+getFunctionName funId = (^. functionInfoName) <$> getFunctionInfo funId
 
 evaluated :: Term Natural -> Term Natural
 evaluated t = OpApply # (opAddress "evaluated" emptyPath) # t
@@ -983,7 +1002,7 @@ getConstructorMemRep :: (Members '[Reader CompilerCtx] r) => Tree.Tag -> Sem r N
 getConstructorMemRep tag = (^. constructorInfoMemRep) <$> getConstructorInfo tag
 
 crash :: Term Natural
-crash = ("crash" @ OpAddress #. OpAddress # OpAddress)
+crash = ("crash" @ OpAddress # OpAddress # OpAddress)
 
 mul :: Term Natural -> Term Natural -> Term Natural
 mul a b = callStdlib StdlibMul [a, b]

src/Juvix/Extra/Strings.hs

@@ -987,4 +987,7 @@ version :: (IsString s) => s
 version = "version"
 
 functionsPlaceholder :: (IsString s) => s
-functionsPlaceholder = "functions_placeholder"
+functionsPlaceholder = "functionsLibrary_placeholder"
+
+theFunctionsLibrary :: (IsString s) => s
+theFunctionsLibrary = "the_functionsLibrary"

test/Nockma/Eval/Positive.hs

@@ -103,9 +103,10 @@ anomaTest :: Text -> Term Natural -> [Term Natural] -> Check () -> Bool -> Test
 anomaTest n mainFun args _testCheck _evalInterceptStdlibCalls =
   let f =
         CompilerFunction
-          { _compilerFunctionName = UserFunction (defaultSymbol 0),
+          { _compilerFunctionId = UserFunction (defaultSymbol 0),
             _compilerFunctionArity = fromIntegral (length args),
-            _compilerFunction = return mainFun
+            _compilerFunction = return mainFun,
+            _compilerFunctionName = "main"
           }
       _testName :: Text
         | _evalInterceptStdlibCalls = n <> " - intercept stdlib"