add cli option to select evaluator

anoma · Feb 7, 2024 · bcf822b · bcf822b
1 parent 6edac5a
commit bcf822b
Show file tree

Hide file tree

Showing 5 changed files with 82 additions and 11 deletions.
diff --git a/app/Commands/Dev/Tree/Eval.hs b/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
diff --git a/app/Commands/Dev/Tree/Eval/Options.hs b/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 {..}
diff --git a/app/Commands/Dev/Tree/Read.hs b/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 ()
diff --git a/app/Commands/Dev/Tree/Repl.hs b/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 ->

diff --git a/app/TreeEvaluator.hs b/app/TreeEvaluator.hs
@@ -1,6 +1,11 @@
-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
@@ -10,11 +15,11 @@ import Juvix.Compiler.Tree.Language.Value qualified as Tree
 import Juvix.Compiler.Tree.Pretty qualified as Tree
 import Juvix.Compiler.Tree.SemEvaluator qualified as TreeSem
 
-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 <- doEvalEff tab (Tree.lookupFunInfo tab sym)
+      r <- doEval ev tab (Tree.lookupFunInfo tab sym)
       case r of
         Left err ->
           exitJuvixError (JuvixError err)
@@ -26,13 +31,30 @@ 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)
-doEval tab' funInfo =
-  liftIO $ Tree.catchEvalErrorIO (liftIO $ Tree.hEvalIO stdin stdout tab' funInfo)
+doEvalRaw tab' = liftIO . Tree.catchEvalErrorIO . liftIO . Tree.hEvalIO stdin stdout tab'
 
 doEvalEff ::
   (MonadIO m) =>