diff --git a/app/Commands/Dev/Tree.hs b/app/Commands/Dev/Tree.hs index d8042f6f6e..696ec1e351 100644 --- a/app/Commands/Dev/Tree.hs +++ b/app/Commands/Dev/Tree.hs @@ -6,6 +6,7 @@ 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 @@ -13,3 +14,4 @@ runCommand = \case Compile opts -> Compile.runCommand opts Read opts -> Read.runCommand opts FromAsm opts -> FromAsm.runCommand opts + Repl opts -> Repl.runCommand opts diff --git a/app/Commands/Dev/Tree/Options.hs b/app/Commands/Dev/Tree/Options.hs index 1f2da46cff..c05db03db3 100644 --- a/app/Commands/Dev/Tree/Options.hs +++ b/app/Commands/Dev/Tree/Options.hs @@ -4,6 +4,7 @@ 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 @@ -11,18 +12,23 @@ data TreeCommand | 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 diff --git a/app/Commands/Dev/Tree/Repl.hs b/app/Commands/Dev/Tree/Repl.hs new file mode 100644 index 0000000000..068fe31579 --- /dev/null +++ b/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 = "" + +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 + } diff --git a/app/Commands/Dev/Tree/Repl/Options.hs b/app/Commands/Dev/Tree/Repl/Options.hs new file mode 100644 index 0000000000..e8f13d3423 --- /dev/null +++ b/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 diff --git a/app/TreeEvaluator.hs b/app/TreeEvaluator.hs index ea4bae52b7..08d21dade9 100644 --- a/app/TreeEvaluator.hs +++ b/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) diff --git a/src/Juvix/Compiler/Tree/Evaluator.hs b/src/Juvix/Compiler/Tree/Evaluator.hs index 8279c6b4c0..2809bf2d50 100644 --- a/src/Juvix/Compiler/Tree/Evaluator.hs +++ b/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 diff --git a/src/Juvix/Compiler/Tree/Translation/FromSource.hs b/src/Juvix/Compiler/Tree/Translation/FromSource.hs index 6e34a72c7f..5087c96291 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromSource.hs +++ b/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 diff --git a/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs index 48b072bf24..6d4bdd58ef 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs +++ b/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