[Jan] serialize nock output (#3114)

app/Commands/Compile/Anoma.hs

@@ -29,6 +29,6 @@ runCommand opts = do
 outputAnomaResult :: (Members '[EmbedIO, App, Files] r) => Bool -> Path Abs File -> Nockma.AnomaResult -> Sem r ()
 outputAnomaResult debugOutput nockmaFile Nockma.AnomaResult {..} = do
   let code = Encoding.jamToByteString _anomaClosure
-      prettyNockmaFile = replaceExtensions' [".debug", ".nockma"] nockmaFile
+      prettyNockmaFile = replaceExtensions' nockmaDebugFileExts nockmaFile
   writeFileBS nockmaFile code
   when debugOutput (writeFileEnsureLn prettyNockmaFile (Nockma.ppPrint _anomaClosure))

app/Commands/Dev/Nockma/Eval.hs

@@ -10,10 +10,9 @@ import Juvix.Compiler.Nockma.Translation.FromSource qualified as Nockma
 runCommand :: forall r. (Members AppEffects r) => NockmaEvalOptions -> Sem r ()
 runCommand opts = do
   afile <- fromAppPathFile file
-  parsedTerm <- Nockma.parseTermFile afile
+  parsedTerm <- runAppError @JuvixError (Nockma.cueJammedFileOrPretty afile)
   case parsedTerm of
-    Left err -> exitJuvixError (JuvixError err)
-    Right (TermCell c) -> do
+    TermCell c -> do
       (counts, res) <-
         runOpCounts
           . runReader defaultEvalOptions
@@ -22,7 +21,7 @@ runCommand opts = do
       putStrLn (ppPrint res)
       let statsFile = replaceExtension' ".profile" afile
       writeFileEnsureLn statsFile (prettyText counts)
-    Right TermAtom {} -> exitFailMsg "Expected nockma input to be a cell"
+    TermAtom {} -> exitFailMsg "Expected nockma input to be a cell"
   where
     file :: AppPath File
     file = opts ^. nockmaEvalFile

app/Commands/Dev/Nockma/Format.hs

@@ -5,13 +5,11 @@ import Commands.Dev.Nockma.Format.Options
 import Juvix.Compiler.Nockma.Pretty
 import Juvix.Compiler.Nockma.Translation.FromSource qualified as Nockma
 
-runCommand :: forall r. (Members '[EmbedIO, App] r) => NockmaFormatOptions -> Sem r ()
+runCommand :: forall r. (Members AppEffects r) => NockmaFormatOptions -> Sem r ()
 runCommand opts = do
   afile <- fromAppPathFile file
-  parsedTerm <- Nockma.parseTermFile afile
-  case parsedTerm of
-    Left err -> exitJuvixError (JuvixError err)
-    Right t -> putStrLn (ppPrint t)
+  parsedTerm <- runAppError @JuvixError (Nockma.parseTermFile afile)
+  putStrLn (ppPrint parsedTerm)
   where
     file :: AppPath File
     file = opts ^. nockmaFormatFile

app/Commands/Dev/Nockma/Repl.hs

@@ -10,7 +10,7 @@ import Juvix.Compiler.Nockma.Evaluator.Options
 import Juvix.Compiler.Nockma.Language
 import Juvix.Compiler.Nockma.Pretty
 import Juvix.Compiler.Nockma.Pretty qualified as Nockma
-import Juvix.Compiler.Nockma.Translation.FromSource (parseProgramFile, parseReplStatement, parseReplText, parseText)
+import Juvix.Compiler.Nockma.Translation.FromSource (cueJammedFileOrPrettyProgram, parseReplStatement, parseReplText, parseText)
 import Juvix.Compiler.Nockma.Translation.FromSource qualified as Nockma
 import Juvix.Parser.Error
 import Juvix.Prelude qualified as Prelude
@@ -111,7 +111,8 @@ getProgram :: Repl (Maybe (Program Natural))
 getProgram = State.gets (^. replStateProgram)
 
 readProgram :: Prelude.Path Abs File -> Repl (Program Natural)
-readProgram s = fromMegaParsecError <$> parseProgramFile s
+readProgram s = runM . runFilesIO $ do
+  runErrorIO' @JuvixError (cueJammedFileOrPrettyProgram s)
 
 direction' :: String -> Repl ()
 direction' s = Repline.dontCrash $ do

app/Commands/Dev/Nockma/Run.hs

@@ -7,13 +7,12 @@ import Juvix.Compiler.Nockma.EvalCompiled
 import Juvix.Compiler.Nockma.Evaluator
 import Juvix.Compiler.Nockma.Pretty
 import Juvix.Compiler.Nockma.Translation.FromSource qualified as Nockma
-import Juvix.Parser.Error
 
 runCommand :: forall r. (Members AppEffects r) => NockmaRunOptions -> Sem r ()
 runCommand opts = do
   afile <- fromAppPathFile inputFile
   argsFile <- mapM fromAppPathFile (opts ^. nockmaRunArgs)
-  parsedArgs <- mapM (Nockma.parseTermFile >=> checkParsed) argsFile
+  parsedArgs <- runAppError @JuvixError (mapM Nockma.cueJammedFileOrPretty argsFile)
   parsedTerm <- checkCued (Nockma.cueJammedFile afile)
   case parsedTerm of
     t@(TermCell {}) -> do
@@ -31,10 +30,5 @@ runCommand opts = do
     inputFile :: AppPath File
     inputFile = opts ^. nockmaRunFile
 
-    checkParsed :: Either MegaparsecError (Term Natural) -> Sem r (Term Natural)
-    checkParsed = \case
-      Left err -> exitJuvixError (JuvixError err)
-      Right tm -> return tm
-
     checkCued :: Sem (Error JuvixError ': r) a -> Sem r a
     checkCued = runErrorNoCallStackWith exitJuvixError

src/Juvix/Compiler/Nockma/Encoding/Cue.hs

@@ -10,7 +10,7 @@ import Juvix.Prelude.Base
 import VectorBuilder.Builder as Builder
 import VectorBuilder.Vector
 
-data CueState a = CueState
+newtype CueState a = CueState
   { _cueStateCache :: HashMap Int (Term a)
   }
 
@@ -20,7 +20,7 @@ initCueState =
     { _cueStateCache = mempty
     }
 
-data CueEnv = CueEnv
+newtype CueEnv = CueEnv
   {_cueEnvStartPos :: Int}
 
 initCueEnv :: CueEnv
@@ -38,14 +38,20 @@ data DecodingError
   | DecodingErrorInvalidBackref
   deriving stock (Show)
 
+instance Pretty DecodingError where
+  pretty = unAnnotate . ppCodeAnn
+
+instance PrettyCodeAnn DecodingError where
+  ppCodeAnn = \case
+    DecodingErrorInvalidTag -> "Invalid tag"
+    DecodingErrorCacheMiss -> "Cache miss"
+    DecodingErrorInvalidLength -> "Invalid length"
+    DecodingErrorExpectedAtom -> "Expected atom"
+    DecodingErrorInvalidAtom -> "Invalid atom"
+    DecodingErrorInvalidBackref -> "Invalid backref"
+
 instance PrettyCode DecodingError where
-  ppCode = \case
-    DecodingErrorInvalidTag -> return "Invalid tag"
-    DecodingErrorCacheMiss -> return "Cache miss"
-    DecodingErrorInvalidLength -> return "Invalid length"
-    DecodingErrorExpectedAtom -> return "Expected atom"
-    DecodingErrorInvalidAtom -> return "Invalid atom"
-    DecodingErrorInvalidBackref -> return "Invalid backref"
+  ppCode = return . ppCodeAnn
 
 -- | Register the start of processing a new entity
 registerElementStart ::

src/Juvix/Compiler/Nockma/Language.hs

@@ -11,8 +11,8 @@ import GHC.Base (Type)
 import Juvix.Compiler.Core.Language.Base (Symbol)
 import Juvix.Compiler.Nockma.Language.Path
 import Juvix.Compiler.Nockma.StdlibFunction.Base
+import Juvix.Data.CodeAnn
 import Juvix.Prelude hiding (Atom, Path)
-import Juvix.Prelude.Pretty
 
 data ReplStatement a
   = ReplStatementExpression (ReplExpression a)
@@ -221,6 +221,9 @@ makeLenses ''WithStack
 makeLenses ''AtomInfo
 makeLenses ''CellInfo
 
+singletonProgram :: Term a -> Program a
+singletonProgram t = Program [StatementStandalone t]
+
 isCell :: Term a -> Bool
 isCell = \case
   TermCell {} -> True

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

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Juvix.Compiler.Nockma.Pretty.Base
   ( module Juvix.Compiler.Nockma.Pretty.Base,
     module Juvix.Data.CodeAnn,
@@ -12,6 +14,9 @@ import Juvix.Data.CodeAnn
 import Juvix.Extra.Strings qualified as Str
 import Juvix.Prelude hiding (Atom, Path)
 
+docDefault :: (PrettyCode c) => c -> Doc Ann
+docDefault = doc defaultOptions
+
 doc :: (PrettyCode c) => Options -> c -> Doc Ann
 doc opts =
   run
@@ -24,6 +29,11 @@ class PrettyCode c where
 runPrettyCode :: (PrettyCode c) => Options -> c -> Doc Ann
 runPrettyCode opts = run . runReader opts . ppCode
 
+instance PrettyCodeAnn NockNaturalNaturalError where
+  ppCodeAnn = \case
+    NaturalInvalidPath a -> "Invalid path" <+> docDefault a
+    NaturalInvalidOp a -> "Invalid operator code" <+> docDefault a
+
 instance forall a. (PrettyCode a, NockNatural a) => PrettyCode (Atom a) where
   ppCode atm = do
     t <- runFail $ do

src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs

@@ -6,6 +6,7 @@ import Data.Text qualified as Text
 import Juvix.Compiler.Nockma.Encoding.ByteString (textToNatural)
 import Juvix.Compiler.Nockma.Encoding.Cue qualified as Cue
 import Juvix.Compiler.Nockma.Language
+import Juvix.Data.CodeAnn
 import Juvix.Extra.Paths
 import Juvix.Extra.Strings qualified as Str
 import Juvix.Parser.Error
@@ -24,23 +25,67 @@ parseText = runParser noFile
 parseReplText :: Text -> Either MegaparsecError (ReplTerm Natural)
 parseReplText = runParserFor replTerm noFile
 
-cueJammedFile :: (Members '[Files, Error JuvixError] r) => Prelude.Path Abs File -> Sem r (Term Natural)
+-- | If the file ends in .debug.nockma it parses an annotated unjammed term. Otherwise
+-- it is equivalent to cueJammedFile
+cueJammedFileOrPretty ::
+  forall r.
+  (Members '[Files, Error JuvixError] r) =>
+  Prelude.Path Abs File ->
+  Sem r (Term Natural)
+cueJammedFileOrPretty f
+  | f `hasExtensions` nockmaDebugFileExts = parseTermFile f
+  | otherwise = cueJammedFile f
+
+-- | If the file ends in .debug.nockma it parses an annotated unjammed program. Otherwise
+-- it parses program with a single jammed term
+cueJammedFileOrPrettyProgram ::
+  forall r.
+  (Members '[Files, Error JuvixError] r) =>
+  Prelude.Path Abs File ->
+  Sem r (Program Natural)
+cueJammedFileOrPrettyProgram f
+  | f `hasExtensions` nockmaDebugFileExts = parseProgramFile f
+  | otherwise = singletonProgram <$> cueJammedFile f
+
+cueJammedFile :: forall r. (Members '[Files, Error JuvixError] r) => Prelude.Path Abs File -> Sem r (Term Natural)
 cueJammedFile fp = do
   bs <- readFileBS' fp
   case Cue.cueFromByteString'' @Natural bs of
-    Left _ -> error "nock natural error"
-    Right (Left _) -> error "cue decoding error"
+    Left e -> natErr e
+    Right (Left e) -> decodingErr e
     Right (Right t) -> return t
-
-parseTermFile :: (MonadIO m) => Prelude.Path Abs File -> m (Either MegaparsecError (Term Natural))
+  where
+    err :: AnsiText -> Sem r x
+    err msg =
+      throw $
+        JuvixError
+          GenericError
+            { _genericErrorLoc = i,
+              _genericErrorIntervals = [i],
+              _genericErrorMessage = msg
+            }
+
+    decodingErr :: Cue.DecodingError -> Sem r x
+    decodingErr e = err (mkAnsiText (ppCodeAnn e))
+
+    natErr :: NockNaturalNaturalError -> Sem r x
+    natErr e = err (mkAnsiText (ppCodeAnn e))
+
+    i :: Interval
+    i = mkInterval loc loc
+      where
+        loc :: Loc
+        loc = mkInitialLoc fp
+
+parseTermFile :: (Members '[Files, Error JuvixError] r) => Prelude.Path Abs File -> Sem r (Term Natural)
 parseTermFile fp = do
-  txt <- readFile fp
-  return (runParser fp txt)
+  txt <- readFile' fp
+  either (throw . JuvixError) return (runParser fp txt)
 
-parseProgramFile :: (MonadIO m) => Prelude.Path Abs File -> m (Either MegaparsecError (Program Natural))
+parseProgramFile :: (Members '[Files, Error JuvixError] r) => Prelude.Path Abs File -> Sem r (Program Natural)
 parseProgramFile fp = do
-  txt <- readFile fp
-  return (runParserProgram fp txt)
+  txt <- readFile' fp
+  either (throw . JuvixError) return (runParserProgram fp txt)
 
 parseReplStatement :: Text -> Either MegaparsecError (ReplStatement Natural)
 parseReplStatement = runParserFor replStatement noFile

src/Juvix/Data/FileExt.hs

@@ -32,9 +32,29 @@ data FileExt
 
 $(genSingletons [''FileExt])
 
+splitExtensions :: Path b File -> (Path b File, [String])
+splitExtensions =
+  swap
+    . run
+    . runAccumListReverse
+    . go
+  where
+    go :: (Members '[Accum String] r) => Path b File -> Sem r (Path b File)
+    go f = case splitExtension f of
+      Nothing -> return f
+      Just (f', ext) -> do
+        accum ext
+        go f'
+
+hasExtensions :: (Foldable l) => Path b File -> l String -> Bool
+hasExtensions f exts = toList exts == snd (splitExtensions f)
+
 juvixFileExt :: (IsString a) => a
 juvixFileExt = ".juvix"
 
+nockmaDebugFileExts :: (IsString a) => NonEmpty a
+nockmaDebugFileExts = ".debug" :| [".nockma"]
+
 juvixMarkdownFileExt :: (IsString a) => a
 juvixMarkdownFileExt = ".juvix.md"
 

src/Juvix/Prelude/Effects/Accum.hs

@@ -22,6 +22,7 @@ newtype instance StaticRep (Accum o) = Accum
 accum :: (Member (Accum o) r) => o -> Sem r ()
 accum o = overStaticRep (\(Accum l) -> Accum (o : l))
 
+-- | Accumulates in LIFO order
 runAccumListReverse :: Sem (Accum o ': r) a -> Sem r ([o], a)
 runAccumListReverse m = do
   (a, Accum s) <- runStaticRep (Accum mempty) m

src/Juvix/Prelude/Path.hs

@@ -88,18 +88,16 @@ removeExtension = fmap fst . splitExtension
 removeExtension' :: Path b File -> Path b File
 removeExtension' = fst . fromJust . splitExtension
 
-addExtensions :: (MonadThrow m) => [String] -> Path b File -> m (Path b File)
-addExtensions ext p = case ext of
-  [] -> return p
-  e : es -> addExtension e p >>= addExtensions es
+addExtensions :: forall m l b. (MonadThrow m, Foldable l) => l String -> Path b File -> m (Path b File)
+addExtensions exts p = foldM (flip addExtension) p exts
 
-replaceExtensions :: (MonadThrow m) => [String] -> Path b File -> m (Path b File)
+replaceExtensions :: (MonadThrow m, Foldable l) => l String -> Path b File -> m (Path b File)
 replaceExtensions ext = addExtensions ext . removeExtensions
 
-replaceExtensions' :: [String] -> Path b File -> Path b File
+replaceExtensions' :: (Foldable l) => l String -> Path b File -> Path b File
 replaceExtensions' ext = fromJust . replaceExtensions ext
 
-addExtensions' :: [String] -> Path b File -> Path b File
+addExtensions' :: (Foldable l) => l String -> Path b File -> Path b File
 addExtensions' ext = fromJust . addExtensions ext
 
 -- | TODO this is ugly. Please, fix it. FileExtJuvixMarkdown needs special