JuvixTree evaluator (#2589)

* Implements JuvixTree evaluator
* Adds JuvixTree evaluation tests
* Adds the `juvix dev tree eval` command
* Depends on #2587 
* Depends on #2583

app/Commands/Dev/Tree.hs

@@ -1,11 +1,13 @@
 module Commands.Dev.Tree where
 
 import Commands.Base
+import Commands.Dev.Tree.Eval as Eval
 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
+  Eval opts -> Eval.runCommand opts
   Read opts -> Read.runCommand opts
   FromAsm opts -> FromAsm.runCommand opts

app/Commands/Dev/Tree/Eval.hs

@@ -0,0 +1,17 @@
+module Commands.Dev.Tree.Eval where
+
+import Commands.Base
+import Commands.Dev.Tree.Eval.Options
+import Juvix.Compiler.Tree.Translation.FromSource qualified as Tree
+import TreeEvaluator
+
+runCommand :: forall r. (Members '[Embed IO, App] r) => TreeEvalOptions -> Sem r ()
+runCommand opts = do
+  afile :: Path Abs File <- fromAppPathFile file
+  s <- readFile (toFilePath afile)
+  case Tree.runParser (toFilePath afile) s of
+    Left err -> exitJuvixError (JuvixError err)
+    Right tab -> evalTree tab
+  where
+    file :: AppPath File
+    file = opts ^. treeEvalInputFile

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

@@ -0,0 +1,15 @@
+module Commands.Dev.Tree.Eval.Options where
+
+import CommonOptions
+
+newtype TreeEvalOptions = TreeEvalOptions
+  { _treeEvalInputFile :: AppPath File
+  }
+  deriving stock (Data)
+
+makeLenses ''TreeEvalOptions
+
+parseTreeEvalOptions :: Parser TreeEvalOptions
+parseTreeEvalOptions = do
+  _treeEvalInputFile <- parseInputFile FileExtJuvixTree
+  pure TreeEvalOptions {..}

app/Commands/Dev/Tree/Options.hs

@@ -1,28 +1,40 @@
 module Commands.Dev.Tree.Options where
 
+import Commands.Dev.Tree.Eval.Options
 import Commands.Dev.Tree.FromAsm.Options
 import Commands.Dev.Tree.Read.Options
 import CommonOptions
 
 data TreeCommand
-  = Read TreeReadOptions
+  = Eval TreeEvalOptions
+  | Read TreeReadOptions
   | FromAsm TreeFromAsmOptions
   deriving stock (Data)
 
 parseTreeCommand :: Parser TreeCommand
 parseTreeCommand =
   hsubparser $
     mconcat
-      [ commandRead,
+      [ commandEval,
+        commandRead,
         commandFromAsm
       ]
   where
+    commandEval :: Mod CommandFields TreeCommand
+    commandEval = command "eval" evalInfo
+
     commandRead :: Mod CommandFields TreeCommand
     commandRead = command "read" readInfo
 
     commandFromAsm :: Mod CommandFields TreeCommand
     commandFromAsm = command "from-asm" fromAsmInfo
 
+    evalInfo :: ParserInfo TreeCommand
+    evalInfo =
+      info
+        (Eval <$> parseTreeEvalOptions)
+        (progDesc "Evaluate a JuvixTree file")
+
     readInfo :: ParserInfo TreeCommand
     readInfo =
       info

app/TreeEvaluator.hs

@@ -0,0 +1,32 @@
+module TreeEvaluator where
+
+import App
+import CommonOptions
+import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree
+import Juvix.Compiler.Tree.Error qualified as Tree
+import Juvix.Compiler.Tree.Evaluator qualified as Tree
+import Juvix.Compiler.Tree.Language.Value qualified as Tree
+import Juvix.Compiler.Tree.Pretty qualified as Tree
+
+evalTree :: forall r. (Members '[Embed IO, App] r) => Tree.InfoTable -> Sem r ()
+evalTree tab =
+  case tab ^. Tree.infoMainFunction of
+    Just sym -> do
+      r <- doEval tab (Tree.lookupFunInfo tab sym)
+      case r of
+        Left err ->
+          exitJuvixError (JuvixError err)
+        Right Tree.ValVoid ->
+          return ()
+        Right val -> do
+          renderStdOut (Tree.ppOutDefault tab val)
+          putStrLn ""
+    Nothing ->
+      exitMsg (ExitFailure 1) "no 'main' function"
+  where
+    doEval ::
+      Tree.InfoTable ->
+      Tree.FunctionInfo ->
+      Sem r (Either Tree.TreeError Tree.Value)
+    doEval tab' funInfo =
+      embed $ Tree.catchEvalErrorIO (Tree.hEvalIO stdin stdout tab' funInfo)

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

@@ -1,63 +1,12 @@
 module Juvix.Compiler.Asm.Interpreter.Base
-  ( module Juvix.Compiler.Asm.Interpreter.Base,
+  ( module Juvix.Compiler.Tree.Language.Value,
     module Juvix.Compiler.Asm.Language,
+    Val,
   )
 where
 
 import Juvix.Compiler.Asm.Language
+import Juvix.Compiler.Tree.Language.Value hiding (Value)
+import Juvix.Compiler.Tree.Language.Value qualified as Tree
 
-{-
-  The following types of values may be stored in the heap or an activation
-  frame.
-
-  - Integer (arbitrary precision)
-  - Boolean
-  - String
-  - Constructor data
-  - Closure
--}
-
-data Val
-  = ValInteger Integer
-  | ValBool Bool
-  | ValString Text
-  | ValUnit
-  | ValVoid
-  | ValConstr Constr
-  | ValClosure Closure
-  deriving stock (Eq)
-
-data Constr = Constr
-  { _constrTag :: Tag,
-    _constrArgs :: [Val]
-  }
-  deriving stock (Eq)
-
-data Closure = Closure
-  { _closureSymbol :: Symbol,
-    _closureArgs :: [Val]
-  }
-  deriving stock (Eq)
-
-makeLenses ''Constr
-makeLenses ''Closure
-
-instance HasAtomicity Constr where
-  atomicity Constr {..}
-    | null _constrArgs = Atom
-    | otherwise = Aggregate appFixity
-
-instance HasAtomicity Closure where
-  atomicity Closure {..}
-    | null _closureArgs = Atom
-    | otherwise = Aggregate appFixity
-
-instance HasAtomicity Val where
-  atomicity = \case
-    ValInteger {} -> Atom
-    ValBool {} -> Atom
-    ValString {} -> Atom
-    ValUnit -> Atom
-    ValVoid -> Atom
-    ValConstr c -> atomicity c
-    ValClosure cl -> atomicity cl
+type Val = Tree.Value

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

@@ -7,7 +7,6 @@ where
 import Data.Foldable
 import Data.HashMap.Strict qualified as HashMap
 import Juvix.Compiler.Asm.Data.InfoTable
-import Juvix.Compiler.Asm.Interpreter.Base
 import Juvix.Compiler.Asm.Interpreter.RuntimeState
 import Juvix.Compiler.Asm.Pretty.Options
 import Juvix.Compiler.Internal.Data.Name
@@ -25,35 +24,13 @@ class PrettyCode c where
   ppCode :: (Member (Reader Options) r) => c -> Sem r (Doc Ann)
 
 instance PrettyCode Constr where
-  ppCode (Constr tag args) = do
-    n' <- Tree.ppConstrName tag
-    args' <- mapM (ppRightExpression appFixity) args
-    return $ foldl' (<+>) n' args'
+  ppCode = Tree.ppCode
 
 instance PrettyCode Closure where
-  ppCode (Closure sym args) = do
-    n' <- Tree.ppFunName sym
-    args' <- mapM (ppRightExpression appFixity) args
-    return $ foldl' (<+>) n' args'
+  ppCode = Tree.ppCode
 
 instance PrettyCode Val where
-  ppCode = \case
-    ValInteger i ->
-      return $ integer i
-    ValBool True ->
-      return $ annotate (AnnKind KNameConstructor) (pretty (Str.true_ :: String))
-    ValBool False ->
-      return $ annotate (AnnKind KNameConstructor) (pretty (Str.false_ :: String))
-    ValString txt ->
-      return $ annotate AnnLiteralString (pretty (show txt :: String))
-    ValUnit ->
-      return $ annotate (AnnKind KNameConstructor) (pretty (Str.unit :: String))
-    ValVoid ->
-      return $ annotate (AnnKind KNameConstructor) (pretty (Str.void :: String))
-    ValConstr c ->
-      ppCode c
-    ValClosure cl ->
-      ppCode cl
+  ppCode = Tree.ppCode
 
 instance PrettyCode ArgumentArea where
   ppCode ArgumentArea {..} =