JuvixTree tests

app/Commands/Dev/Tree.hs

@@ -1,9 +1,11 @@
 module Commands.Dev.Tree where
 
 import Commands.Base
+import Commands.Dev.Tree.FromAsm as FromAsm
 import Commands.Dev.Tree.Options
 import Commands.Dev.Tree.Read as Read
 
 runCommand :: forall r. (Members '[Embed IO, App, TaggedLock] r) => TreeCommand -> Sem r ()
 runCommand = \case
   Read opts -> Read.runCommand opts
+  FromAsm opts -> FromAsm.runCommand opts

app/Commands/Dev/Tree/FromAsm.hs

@@ -0,0 +1,23 @@
+module Commands.Dev.Tree.FromAsm where
+
+import Commands.Base
+import Commands.Dev.Tree.FromAsm.Options
+import Juvix.Compiler.Asm.Translation.FromSource qualified as Asm
+import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree
+import Juvix.Compiler.Tree.Error (TreeError)
+import Juvix.Compiler.Tree.Pretty qualified as Tree
+import Juvix.Compiler.Tree.Translation.FromAsm qualified as Tree
+
+runCommand :: forall r. (Members '[Embed IO, App] r) => TreeFromAsmOptions -> Sem r ()
+runCommand opts = do
+  afile :: Path Abs File <- fromAppPathFile file
+  s <- readFile (toFilePath afile)
+  case Asm.runParser (toFilePath afile) s of
+    Left err -> exitJuvixError (JuvixError err)
+    Right tab -> do
+      r :: Either JuvixError Tree.InfoTable <- runError $ mapError (JuvixError @TreeError) $ Tree.fromAsm tab
+      tab' <- getRight r
+      renderStdOut (Tree.ppOutDefault tab' tab')
+  where
+    file :: AppPath File
+    file = opts ^. treeFromAsmInputFile

app/Commands/Dev/Tree/FromAsm/Options.hs

@@ -0,0 +1,15 @@
+module Commands.Dev.Tree.FromAsm.Options where
+
+import CommonOptions
+
+newtype TreeFromAsmOptions = TreeFromAsmOptions
+  { _treeFromAsmInputFile :: AppPath File
+  }
+  deriving stock (Data)
+
+makeLenses ''TreeFromAsmOptions
+
+parseTreeFromAsmOptions :: Parser TreeFromAsmOptions
+parseTreeFromAsmOptions = do
+  _treeFromAsmInputFile <- parseInputFile FileExtJuvixAsm
+  pure TreeFromAsmOptions {..}

app/Commands/Dev/Tree/Options.hs

@@ -1,24 +1,36 @@
 module Commands.Dev.Tree.Options where
 
+import Commands.Dev.Tree.FromAsm.Options
 import Commands.Dev.Tree.Read.Options
 import CommonOptions
 
-newtype TreeCommand
+data TreeCommand
   = Read TreeReadOptions
+  | FromAsm TreeFromAsmOptions
   deriving stock (Data)
 
 parseTreeCommand :: Parser TreeCommand
 parseTreeCommand =
   hsubparser $
     mconcat
-      [ commandRead
+      [ commandRead,
+        commandFromAsm
       ]
   where
     commandRead :: Mod CommandFields TreeCommand
     commandRead = command "read" readInfo
 
+    commandFromAsm :: Mod CommandFields TreeCommand
+    commandFromAsm = command "from-asm" fromAsmInfo
+
     readInfo :: ParserInfo TreeCommand
     readInfo =
       info
         (Read <$> parseTreeReadOptions)
         (progDesc "Parse a JuvixTree file and pretty print it")
+
+    fromAsmInfo :: ParserInfo TreeCommand
+    fromAsmInfo =
+      info
+        (FromAsm <$> parseTreeFromAsmOptions)
+        (progDesc "Convert a JuvixAsm file to JuvixTree and pretty print it")

src/Juvix/Compiler/Asm/Extra/Base.hs

@@ -30,3 +30,13 @@ getConstrSize rep argsNum = case rep of
   MemRepTuple -> argsNum
   MemRepUnit -> 0
   MemRepUnpacked {} -> 0
+
+getCommandInfo :: Command -> CommandInfo
+getCommandInfo = \case
+  Instr CmdInstr {..} -> _cmdInstrInfo
+  Branch CmdBranch {..} -> _cmdBranchInfo
+  Case CmdCase {..} -> _cmdCaseInfo
+  Save CmdSave {..} -> _cmdSaveInfo
+
+getCommandLocation :: Command -> Maybe Location
+getCommandLocation = (^. commandInfoLocation) . getCommandInfo

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

@@ -107,13 +107,16 @@ genCode fi =
     goExtendClosure :: Bool -> Tree.NodeExtendClosure -> Code'
     goExtendClosure isTail Tree.NodeExtendClosure {..} =
       snocReturn isTail $
-        DL.snoc
+        DL.append
           (goArgs (toList _nodeExtendClosureArgs))
-          ( mkInstr $
-              ExtendClosure $
-                InstrExtendClosure
-                  { _extendClosureArgsNum = length _nodeExtendClosureArgs
-                  }
+          ( DL.snoc
+              (go False _nodeExtendClosureFun)
+              ( mkInstr $
+                  ExtendClosure $
+                    InstrExtendClosure
+                      { _extendClosureArgsNum = length _nodeExtendClosureArgs
+                      }
+              )
           )
 
     goCall :: Bool -> Tree.NodeCall -> Code'
@@ -131,13 +134,15 @@ genCode fi =
       Tree.CallClosure arg ->
         DL.append
           (goArgs _nodeCallArgs)
-          ( DL.snoc (go False arg) $
-              mkInstr $
-                (if isTail then TailCall else Call) $
-                  InstrCall
-                    { _callType = CallClosure,
-                      _callArgsNum = length _nodeCallArgs
-                    }
+          ( DL.snoc
+              (go False arg)
+              ( mkInstr $
+                  (if isTail then TailCall else Call) $
+                    InstrCall
+                      { _callType = CallClosure,
+                        _callArgsNum = length _nodeCallArgs
+                      }
+              )
           )
 
     goCallClosures :: Bool -> Tree.NodeCallClosures -> Code'

src/Juvix/Compiler/Tree/Error.hs

@@ -0,0 +1,43 @@
+module Juvix.Compiler.Tree.Error where
+
+import Juvix.Compiler.Tree.Language.Base
+import Juvix.Data.PPOutput
+import Text.Show
+
+data TreeError = TreeError
+  { _treeErrorLoc :: Maybe Location,
+    _treeErrorMsg :: Text
+  }
+
+makeLenses ''TreeError
+
+instance ToGenericError TreeError where
+  genericError :: (Member (Reader GenericOptions) r) => TreeError -> Sem r GenericError
+  genericError e = ask >>= generr
+    where
+      generr :: GenericOptions -> Sem r GenericError
+      generr _ =
+        return
+          GenericError
+            { _genericErrorLoc = i,
+              _genericErrorMessage = ppOutput msg,
+              _genericErrorIntervals = [i]
+            }
+        where
+          i = getLoc e
+          msg = pretty (e ^. treeErrorMsg)
+
+instance Pretty TreeError where
+  pretty (TreeError {..}) = pretty _treeErrorMsg
+
+instance Show TreeError where
+  show (TreeError {..}) = fromText _treeErrorMsg
+
+instance HasLoc TreeError where
+  getLoc (TreeError {..}) = fromMaybe defaultLoc _treeErrorLoc
+    where
+      defaultLoc :: Interval
+      defaultLoc = singletonInterval (mkInitialLoc sourcePath)
+
+      sourcePath :: Path Abs File
+      sourcePath = $(mkAbsFile "/<tree>")

src/Juvix/Compiler/Tree/Keywords.hs

@@ -27,7 +27,7 @@ import Juvix.Data.Keyword.All
     kwSave,
     kwSeq_,
     kwShow,
-    kwStrConcat,
+    kwStrcat,
     kwSub_,
     kwTrace,
   )
@@ -47,7 +47,7 @@ allKeywords =
          kwLe_,
          kwSeq_,
          kwEq_,
-         kwStrConcat,
+         kwStrcat,
          kwShow,
          kwAtoi,
          kwTrace,

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

@@ -103,7 +103,7 @@ instance PrettyCode TypeConstr where
     let ctrname = fromJust (HashMap.lookup _typeConstrTag tagNames)
     let cname = annotate (AnnKind KNameConstructor) (pretty ctrname)
     args <- mapM ppCode _typeConstrFields
-    return $ iname <> kwColon <> cname <> encloseSep "(" ")" ", " args
+    return $ iname <> kwColon <> cname <> parens (hsep (punctuate comma args))
 
 instance PrettyCode TypeFun where
   ppCode :: (Member (Reader Options) r) => TypeFun -> Sem r (Doc Ann)
@@ -114,7 +114,7 @@ instance PrettyCode TypeFun where
               ppLeftExpression funFixity (head _typeFunArgs)
           | otherwise -> do
               args <- mapM ppCode _typeFunArgs
-              return $ encloseSep "(" ")" ", " (toList args)
+              return $ parens $ hsep $ punctuate comma (toList args)
     r <- ppRightExpression funFixity _typeFunTarget
     return $ l <+> kwArrow <+> r
 
@@ -326,7 +326,7 @@ ppFunInfo ppCode' FunctionInfo {..} = do
   return $
     keyword Str.function
       <+> annotate (AnnKind KNameFunction) (pretty (quoteFunName $ quoteName _functionName))
-        <> encloseSep lparen rparen ", " args
+        <> parens (hsep (punctuate comma args))
       <+> colon
       <+> targetty
       <+> braces' c
@@ -338,7 +338,7 @@ ppFunSig FunctionInfo {..} = do
   return $
     keyword Str.function
       <+> annotate (AnnKind KNameFunction) (pretty (quoteFunName $ quoteName _functionName))
-        <> encloseSep lparen rparen ", " argtys
+        <> parens (hsep (punctuate comma argtys))
       <+> colon
       <+> targetty
         <> semi