Effectful Juvix tree evaluator

app/Commands/Dev/Tree/Eval.hs

@@ -11,7 +11,7 @@ runCommand opts = do
   s <- readFile (toFilePath afile)
   case Tree.runParser (toFilePath afile) s of
     Left err -> exitJuvixError (JuvixError err)
-    Right tab -> evalTree tab
+    Right tab -> evalTree (opts ^. treeEvalEvaluator) tab
   where
     file :: AppPath File
     file = opts ^. treeEvalInputFile

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

@@ -1,9 +1,57 @@
 module Commands.Dev.Tree.Eval.Options where
 
 import CommonOptions
+import Juvix.Prelude.Pretty
+import Prelude (show)
 
-newtype TreeEvalOptions = TreeEvalOptions
-  { _treeEvalInputFile :: AppPath File
+data Evaluator
+  = EvalEffectful
+  | EvalSem
+  | EvalRaw
+  deriving stock (Eq, Bounded, Enum, Data)
+
+defaultEvaluator :: Evaluator
+defaultEvaluator = EvalEffectful
+
+instance Show Evaluator where
+  show = \case
+    EvalEffectful -> "effectful"
+    EvalSem -> "polysemy"
+    EvalRaw -> "raw"
+
+instance Pretty Evaluator where
+  pretty = CommonOptions.show
+
+optEvaluator :: Parser Evaluator
+optEvaluator =
+  option
+    (eitherReader parseEvaluator)
+    ( long "evaluator"
+        <> value defaultEvaluator
+        <> metavar "EVALUATOR_NAME"
+        <> completer (mkCompleter (return . compl))
+        <> help "hint: use autocomplete"
+    )
+  where
+    compl :: String -> [String]
+    compl s = filter (isPrefixOf s) (map Prelude.show (allElements @Evaluator))
+
+    parseEvaluator :: String -> Either String Evaluator
+    parseEvaluator s =
+      maybe
+        (Left err)
+        Right
+        ( lookup
+            s
+            [(Prelude.show e, e) | e :: Evaluator <- allElements]
+        )
+      where
+        err :: String
+        err = "Invalid evaluator name. The available names are: " <> Prelude.show (allElements @Evaluator)
+
+data TreeEvalOptions = TreeEvalOptions
+  { _treeEvalInputFile :: AppPath File,
+    _treeEvalEvaluator :: Evaluator
   }
   deriving stock (Data)
 
@@ -12,4 +60,5 @@ makeLenses ''TreeEvalOptions
 parseTreeEvalOptions :: Parser TreeEvalOptions
 parseTreeEvalOptions = do
   _treeEvalInputFile <- parseInputFile FileExtJuvixTree
+  _treeEvalEvaluator <- optEvaluator
   pure TreeEvalOptions {..}

app/Commands/Dev/Tree/Read.hs

@@ -32,5 +32,5 @@ runCommand opts = do
           putStrLn "--------------------------------"
           putStrLn "|            Eval              |"
           putStrLn "--------------------------------"
-          Eval.evalTree tab'
+          Eval.evalTree Eval.defaultEvaluator tab'
       | otherwise = return ()

app/Commands/Dev/Tree/Repl.hs

@@ -102,7 +102,7 @@ evalNode node = do
             _functionArgNames = [],
             _functionType = TyDynamic
           }
-  et <- Eval.doEval tab fi
+  et <- Eval.doEvalDefault tab fi
   case et of
     Left e -> error (show e)
     Right v ->

app/TreeEvaluator.hs

@@ -1,18 +1,25 @@
-module TreeEvaluator where
+module TreeEvaluator
+  ( module TreeEvaluator,
+    module Commands.Dev.Tree.Eval.Options,
+  )
+where
 
 import App
+import Commands.Dev.Tree.Eval.Options
 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.EvaluatorEff qualified as Eff
+import Juvix.Compiler.Tree.EvaluatorSem qualified as TreeSem
 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 =
+evalTree :: forall r. (Members '[Embed IO, App] r) => Evaluator -> Tree.InfoTable -> Sem r ()
+evalTree ev tab =
   case tab ^. Tree.infoMainFunction of
     Just sym -> do
-      r <- liftIO $ doEval tab (Tree.lookupFunInfo tab sym)
+      r <- doEval ev tab (Tree.lookupFunInfo tab sym)
       case r of
         Left err ->
           exitJuvixError (JuvixError err)
@@ -24,10 +31,41 @@ evalTree tab =
     Nothing ->
       exitMsg (ExitFailure 1) "no 'main' function"
 
+doEvalDefault ::
+  (MonadIO m) =>
+  Tree.InfoTable ->
+  Tree.FunctionInfo ->
+  m (Either Tree.TreeError Tree.Value)
+doEvalDefault = doEval defaultEvaluator
+
 doEval ::
+  (MonadIO m) =>
+  Evaluator ->
+  Tree.InfoTable ->
+  Tree.FunctionInfo ->
+  m (Either Tree.TreeError Tree.Value)
+doEval = \case
+  EvalEffectful -> doEvalEff
+  EvalRaw -> doEvalRaw
+  EvalSem -> doEvalSem
+
+doEvalRaw ::
+  (MonadIO m) =>
+  Tree.InfoTable ->
+  Tree.FunctionInfo ->
+  m (Either Tree.TreeError Tree.Value)
+doEvalRaw tab' = liftIO . Tree.catchEvalErrorIO . liftIO . Tree.hEvalIO stdin stdout tab'
+
+doEvalEff ::
+  (MonadIO m) =>
+  Tree.InfoTable ->
+  Tree.FunctionInfo ->
+  m (Either Tree.TreeError Tree.Value)
+doEvalEff tab' funInfo = Eff.hEvalIOEither stdin stdout tab' funInfo
+
+doEvalSem ::
   (MonadIO m) =>
   Tree.InfoTable ->
   Tree.FunctionInfo ->
   m (Either Tree.TreeError Tree.Value)
-doEval tab' funInfo =
-  liftIO $ Tree.catchEvalErrorIO (liftIO $ Tree.hEvalIO stdin stdout tab' funInfo)
+doEvalSem tab' funInfo = TreeSem.hEvalIOEither stdin stdout tab' funInfo

package.yaml

@@ -54,6 +54,9 @@ dependencies:
   - directory == 1.3.*
   - dlist == 1.0.*
   - edit-distance == 0.2.*
+  - effectful == 2.3.*
+  - effectful-core == 2.3.*
+  - effectful-th == 1.0.*
   - exceptions == 0.10.*
   - extra == 1.7.*
   - file-embed == 0.0.*

src/Juvix/Compiler/Tree/Evaluator.hs

@@ -94,7 +94,7 @@ hEval hout tab = eval' [] mempty
         goUnop NodeUnop {..} =
           let !v = eval' args temps _nodeUnopArg
            in case _nodeUnopOpcode of
-                OpShow -> ValString (printValue v)
+                OpShow -> ValString (printValue tab v)
                 OpStrToInt -> goStringUnop strToInt v
                 OpTrace -> goTrace v
                 OpFail -> goFail v
@@ -113,7 +113,7 @@ hEval hout tab = eval' [] mempty
           _ -> evalError "expected a string argument"
 
         goFail :: Value -> Value
-        goFail v = evalError ("failure: " <> printValue v)
+        goFail v = evalError ("failure: " <> printValue tab v)
 
         goArgsNum :: Value -> Value
         goArgsNum = \case
@@ -126,7 +126,7 @@ hEval hout tab = eval' [] mempty
             evalError "expected a closure"
 
         goTrace :: Value -> Value
-        goTrace v = unsafePerformIO (hPutStrLn hout (printValue v) >> return v)
+        goTrace v = unsafePerformIO (hPutStrLn hout (printValue tab v) >> return v)
 
         goConstant :: NodeConstant -> Value
         goConstant NodeConstant {..} = case _nodeConstant of
@@ -260,10 +260,10 @@ hEval hout tab = eval' [] mempty
           let !v = eval' args temps _nodeSaveArg
            in eval' args (BL.cons v temps) _nodeSaveBody
 
-        printValue :: Value -> Text
-        printValue = \case
-          ValString s -> s
-          v -> ppPrint tab v
+printValue :: InfoTable -> Value -> Text
+printValue tab = \case
+  ValString s -> s
+  v -> ppPrint tab v
 
 valueToNode :: Value -> Node
 valueToNode = \case