JuvixTree REPL (#2608)

* JuvixTree REPL
* Depends on #2601

app/Commands/Dev/Tree.hs

@@ -6,10 +6,12 @@ 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
+import Commands.Dev.Tree.Repl as Repl
 
 runCommand :: forall r. (Members '[Embed IO, App, TaggedLock] r) => TreeCommand -> Sem r ()
 runCommand = \case
   Eval opts -> Eval.runCommand opts
   Compile opts -> Compile.runCommand opts
   Read opts -> Read.runCommand opts
   FromAsm opts -> FromAsm.runCommand opts
+  Repl opts -> Repl.runCommand opts

app/Commands/Dev/Tree/Options.hs

@@ -4,25 +4,31 @@ import Commands.Dev.Tree.Compile.Options
 import Commands.Dev.Tree.Eval.Options
 import Commands.Dev.Tree.FromAsm.Options
 import Commands.Dev.Tree.Read.Options
+import Commands.Dev.Tree.Repl.Options
 import CommonOptions
 
 data TreeCommand
   = Eval TreeEvalOptions
   | Compile CompileOptions
   | Read TreeReadOptions
   | FromAsm TreeFromAsmOptions
+  | Repl TreeReplOptions
   deriving stock (Data)
 
 parseTreeCommand :: Parser TreeCommand
 parseTreeCommand =
   hsubparser $
     mconcat
-      [ commandEval,
+      [ commandRepl,
+        commandEval,
         commandCompile,
         commandRead,
         commandFromAsm
       ]
   where
+    commandRepl :: Mod CommandFields TreeCommand
+    commandRepl = command "repl" replInfo
+
     commandEval :: Mod CommandFields TreeCommand
     commandEval = command "eval" evalInfo
 
@@ -35,6 +41,12 @@ parseTreeCommand =
     commandFromAsm :: Mod CommandFields TreeCommand
     commandFromAsm = command "from-asm" fromAsmInfo
 
+    replInfo :: ParserInfo TreeCommand
+    replInfo =
+      info
+        (Repl <$> parseTreeReplOptions)
+        (progDesc "Launch the JuvixTree REPL")
+
     evalInfo :: ParserInfo TreeCommand
     evalInfo =
       info

app/Commands/Dev/Tree/Repl.hs

@@ -0,0 +1,138 @@
+module Commands.Dev.Tree.Repl where
+
+import Commands.Base hiding (Atom)
+import Commands.Dev.Tree.Repl.Options
+import Control.Exception (throwIO)
+import Control.Monad.State.Strict qualified as State
+import Data.String.Interpolate (__i)
+import Juvix.Compiler.Tree.Data.InfoTable
+import Juvix.Compiler.Tree.Data.InfoTableBuilder qualified as Tree
+import Juvix.Compiler.Tree.Language
+import Juvix.Compiler.Tree.Pretty (ppPrint)
+import Juvix.Compiler.Tree.Translation.FromSource (parseNodeText', parseText')
+import System.Console.Haskeline
+import System.Console.Repline qualified as Repline
+import TreeEvaluator qualified as Eval
+
+type ReplS = State.StateT ReplState IO
+
+data ReplState = ReplState
+  { _replStateBuilderState :: Tree.BuilderState,
+    _replStateLoadedFile :: Maybe FilePath
+  }
+
+type Repl a = Repline.HaskelineT ReplS a
+
+makeLenses ''ReplState
+
+printHelpTxt :: Repl ()
+printHelpTxt = liftIO $ putStrLn helpTxt
+  where
+    helpTxt :: Text =
+      [__i|
+  EXPRESSION                      Evaluate a JuvixTree expression
+  :load FILE                      Load a file containing JuvixTree function and type definitions
+  :reload                         Reload the current file
+  :help                           Print help text and describe options
+  :quit                           Exit the REPL
+          |]
+
+quit :: String -> Repl ()
+quit _ = liftIO (throwIO Interrupt)
+
+loadFile :: String -> Repl ()
+loadFile s = Repline.dontCrash $ do
+  State.modify (set replStateLoadedFile (Just s))
+  readProgram s
+
+reloadFile :: Repl ()
+reloadFile = Repline.dontCrash $ do
+  fp <- State.gets (^. replStateLoadedFile)
+  case fp of
+    Nothing -> error "no file loaded"
+    Just f -> readProgram f
+
+readProgram :: FilePath -> Repl ()
+readProgram f = do
+  bs <- State.gets (^. replStateBuilderState)
+  txt <- readFile f
+  case parseText' bs txt of
+    Left e -> error (show e)
+    Right bs' ->
+      State.modify (set replStateBuilderState bs')
+
+options :: [(String, String -> Repl ())]
+options =
+  [ ("help", Repline.dontCrash . const printHelpTxt),
+    ("quit", quit),
+    ("load", loadFile),
+    ("reload", const reloadFile)
+  ]
+
+banner :: Repline.MultiLine -> Repl String
+banner = \case
+  Repline.MultiLine -> return "... "
+  Repline.SingleLine -> return "tree> "
+
+readNode :: String -> Repl Node
+readNode s = do
+  bs <- State.gets (^. replStateBuilderState)
+  case parseNodeText' bs replFile (strip (pack s)) of
+    Left e -> error (show e)
+    Right (bs', n) -> do
+      State.modify (set replStateBuilderState bs')
+      return n
+  where
+    replFile :: FilePath
+    replFile = "<file>"
+
+evalNode :: Node -> Repl ()
+evalNode node = do
+  sym <- State.gets (^. replStateBuilderState . Tree.stateNextSymbolId)
+  State.modify' (over (replStateBuilderState . Tree.stateNextSymbolId) (+ 1))
+  tab <- State.gets (^. replStateBuilderState . Tree.stateInfoTable)
+  let fi =
+        FunctionInfo
+          { _functionName = "repl:main",
+            _functionLocation = Nothing,
+            _functionSymbol = Symbol defaultModuleId sym,
+            _functionArgsNum = 0,
+            _functionCode = node,
+            _functionExtra = (),
+            _functionArgNames = [],
+            _functionType = TyDynamic
+          }
+  et <- Eval.doEval tab fi
+  case et of
+    Left e -> error (show e)
+    Right v ->
+      liftIO $
+        putStrLn (ppPrint tab v)
+
+replCommand :: String -> Repl ()
+replCommand input_ = Repline.dontCrash $ do
+  readNode input_ >>= evalNode
+
+replAction :: ReplS ()
+replAction =
+  Repline.evalReplOpts
+    Repline.ReplOpts
+      { prefix = Just ':',
+        command = replCommand,
+        initialiser = return (),
+        finaliser = return Repline.Exit,
+        multilineCommand = Just "multiline",
+        tabComplete = Repline.Word (\_ -> return []),
+        options,
+        banner
+      }
+
+runCommand :: forall r. (Members '[Embed IO, App] r) => TreeReplOptions -> Sem r ()
+runCommand _ = embed . (`State.evalStateT` iniState) $ replAction
+  where
+    iniState :: ReplState
+    iniState =
+      ReplState
+        { _replStateBuilderState = Tree.emptyBuilderState,
+          _replStateLoadedFile = Nothing
+        }

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

@@ -0,0 +1,12 @@
+module Commands.Dev.Tree.Repl.Options where
+
+import CommonOptions
+
+data TreeReplOptions = TreeReplOptions
+  deriving stock (Data)
+
+makeLenses ''TreeReplOptions
+
+parseTreeReplOptions :: Parser TreeReplOptions
+parseTreeReplOptions = do
+  pure TreeReplOptions

app/TreeEvaluator.hs

@@ -12,7 +12,7 @@ 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)
+      r <- liftIO $ doEval tab (Tree.lookupFunInfo tab sym)
       case r of
         Left err ->
           exitJuvixError (JuvixError err)
@@ -23,10 +23,11 @@ evalTree tab =
           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)
+
+doEval ::
+  (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)

src/Juvix/Compiler/Tree/Evaluator.hs

@@ -292,13 +292,13 @@ valueToNode = \case
           _nodeAllocClosureArgs = map valueToNode _closureArgs
         }
 
-hEvalIO :: Handle -> Handle -> InfoTable -> FunctionInfo -> IO Value
+hEvalIO :: (MonadIO m) => Handle -> Handle -> InfoTable -> FunctionInfo -> m Value
 hEvalIO hin hout infoTable funInfo = do
   let !v = hEval hout infoTable (funInfo ^. functionCode)
   hRunIO hin hout infoTable v
 
 -- | Interpret IO actions.
-hRunIO :: Handle -> Handle -> InfoTable -> Value -> IO Value
+hRunIO :: (MonadIO m) => Handle -> Handle -> InfoTable -> Value -> m Value
 hRunIO hin hout infoTable = \case
   ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x
   ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do
@@ -313,14 +313,14 @@ hRunIO hin hout infoTable = \case
         !x'' = hEval hout infoTable code
     hRunIO hin hout infoTable x''
   ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do
-    hPutStr hout s
+    liftIO $ hPutStr hout s
     return ValVoid
   ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do
-    hPutStr hout (ppPrint infoTable arg)
+    liftIO $ hPutStr hout (ppPrint infoTable arg)
     return ValVoid
   ValConstr (Constr (BuiltinTag TagReadLn) []) -> do
-    hFlush hout
-    s <- hGetLine hin
+    liftIO $ hFlush hout
+    s <- liftIO $ hGetLine hin
     return (ValString s)
   val ->
     return val
@@ -329,7 +329,7 @@ hRunIO hin hout infoTable = \case
 catchEvalErrorIO :: IO a -> IO (Either TreeError a)
 catchEvalErrorIO ma =
   Exception.catch
-    (Exception.evaluate ma >>= \ma' -> ma' <&> Right)
+    (Exception.evaluate ma >>= \ma' -> Right <$> ma')
     (\(ex :: EvalError) -> return (Left (toTreeError ex)))
 
 toTreeError :: EvalError -> TreeError

src/Juvix/Compiler/Tree/Translation/FromSource.hs

@@ -40,6 +40,9 @@ runParser = runParserS parseTreeSig
 runParser' :: BuilderState -> FilePath -> Text -> Either MegaparsecError BuilderState
 runParser' = runParserS' parseTreeSig
 
+parseNodeText' :: BuilderState -> FilePath -> Text -> Either MegaparsecError (BuilderState, Node)
+parseNodeText' bs file txt = runParserS'' parseNode parseTreeSig bs file txt
+
 parseNode ::
   (Members '[Reader ParserSig, InfoTableBuilder, State LocalParams] r) =>
   ParsecS r Node

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

@@ -41,15 +41,27 @@ runParserS :: ParserSig t e -> FilePath -> Text -> Either MegaparsecError (InfoT
 runParserS sig fileName input_ = (^. stateInfoTable) <$> runParserS' sig emptyBuilderState fileName input_
 
 runParserS' :: forall t e. ParserSig t e -> BuilderState' t e -> FilePath -> Text -> Either MegaparsecError (BuilderState' t e)
-runParserS' sig bs fileName input_ =
+runParserS' sig bs fileName input_ = case runParserS'' (parseToplevel @t @e) sig bs fileName input_ of
+  Left e -> Left e
+  Right (bs', ()) -> Right bs'
+
+runParserS'' ::
+  forall t e a.
+  ParsecS '[NameIdGen, InfoTableBuilder' t e, Reader (ParserSig t e), State LocalParams] a ->
+  ParserSig t e ->
+  BuilderState' t e ->
+  FilePath ->
+  Text ->
+  Either MegaparsecError (BuilderState' t e, a)
+runParserS'' parser sig bs fileName input_ =
   case run $
     evalState params $
       runReader sig $
         runInfoTableBuilder' bs $
           evalTopNameIdGen defaultModuleId $
-            P.runParserT (parseToplevel @t @e) fileName input_ of
+            P.runParserT parser fileName input_ of
     (_, Left err) -> Left (MegaparsecError err)
-    (bs', Right ()) -> Right bs'
+    (bs', Right x) -> Right (bs', x)
   where
     params =
       LocalParams