From 718fce3ae70c9710a0fb93b6df6ca4fbb409c5c9 Mon Sep 17 00:00:00 2001 From: rockofox Date: Mon, 20 Nov 2023 18:05:53 +0100 Subject: [PATCH] Better REPL, adjusted CLI --- app/Main.hs | 195 ++++++++++++++++++++++++++++++--------------------- indigo.cabal | 12 ++-- 2 files changed, 125 insertions(+), 82 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 9116e0c..c21c2f5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -5,21 +6,25 @@ module Main where import BytecodeCompiler qualified import Control.Exception import Control.Monad -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Identity (Identity (..)) import Control.Monad.State (StateT (runStateT), evalStateT) import Control.Monad.State.Lazy import Data.ByteString.Lazy qualified as B -import Data.List (intercalate) -import Data.Maybe (fromJust, fromMaybe) +import Data.List (intercalate, isPrefixOf) +import Data.Maybe (fromJust, fromMaybe, isNothing) +import Data.Monoid +import Data.Set qualified as Set import Data.Text qualified as T import Data.Vector qualified as V import Data.Void import Data.Void qualified import GHC.IO.Handle (hFlush) import GHC.IO.StdHandles (stdout) +import GitHash import Options.Applicative import Parser +import System.Console.Repline import System.Exit (exitFailure, exitSuccess) import System.Posix.IO (stdOutput) import System.Posix.Terminal (queryTerminal) @@ -28,7 +33,7 @@ import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty) import VM qualified import Verifier -data Options = Options +data CmdOptions = Options { input :: Maybe FilePath , output :: Maybe FilePath , debug :: Bool @@ -37,20 +42,13 @@ data Options = Options , runBytecode :: Bool , breakpoints :: Maybe String , showTime :: Bool - , runRepl :: Bool + , showVersion :: Bool } -optionsParser :: Options.Applicative.Parser Options +optionsParser :: Options.Applicative.Parser CmdOptions optionsParser = Options - <$> optional - ( strOption - ( long "input" - <> short 'i' - <> metavar "FILE" - <> help "Input file. Use - for stdin." - ) - ) + <$> optional (argument str (metavar "FILE")) <*> optional ( strOption ( long "output" @@ -64,12 +62,12 @@ optionsParser = <> short 'd' <> help "Enable debug mode" ) - <*> switch (long "verbose" <> short 'v' <> help "Enable verbose mode") + <*> switch (long "verbose" <> short 'v' <> help "Enable verbose mode (deprecated/broken)") <*> switch (long "emit-bytecode" <> short 'b' <> help "Emit bytecode") <*> switch (long "run-bytecode" <> short 'r' <> help "Run bytecode") <*> optional (strOption (long "breakpoints" <> short 't' <> help "Breakpoints for the VM to trace (space separated list of program counter indices). -1 to trace on every instruction")) <*> switch (long "profile" <> short 'p' <> help "Show time spent parsing, compiling and running") - <*> switch (long "repl" <> short 'e' <> help "Start REPL") + <*> switch (long "version" <> short 'V' <> help "Show version") prettyPrintExpr :: Expr -> Int -> String prettyPrintExpr (DoBlock exprs) i = indent i ++ "DoBlock[\n" ++ intercalate "\n" (map (\x -> prettyPrintExpr x (i + 1)) exprs) ++ "\n" ++ indent i ++ "]" @@ -79,28 +77,26 @@ prettyPrintExpr (FuncDef name _ expr) i = _ -> "FuncDef[<" ++ name ++ ">" ++ prettyPrintExpr expr 0 ++ "]" prettyPrintExpr x i = indent i ++ show x -indent :: Int -> [Char] +indent :: Int -> String indent i = replicate (i * 2) ' ' prettyPrintProgram :: Program -> String -prettyPrintProgram (Program exprs) = do - intercalate "\n" (map (`prettyPrintExpr` 0) exprs) +prettyPrintProgram (Program exprs) = intercalate "\n" (map (`prettyPrintExpr` 0) exprs) -inputFile :: Maybe [Char] -> IO String +inputFile :: Maybe String -> IO String inputFile input = case input of Just "-" -> getContents Just file -> readFile file Nothing -> error "No input file specified" -inputFileBinary :: Maybe [Char] -> IO B.ByteString +inputFileBinary :: Maybe String -> IO B.ByteString inputFileBinary input = case input of Just "-" -> B.getContents Just file -> B.readFile file Nothing -> error "No input file specified" potentiallyTimedOperation :: (MonadIO m) => String -> Bool -> m a -> m a -potentiallyTimedOperation msg showTime action = do - if showTime then timeItNamed msg action else action +potentiallyTimedOperation msg showTime action = if showTime then timeItNamed msg action else action parseAndVerify :: String -> T.Text -> CompilerFlags -> IO (Either (ParseErrorBundle T.Text Void) Program) parseAndVerify name t cf = do @@ -115,21 +111,24 @@ parseAndVerify name t cf = do Right _ -> return $ Right program' -- parse :: String -> String -> CompilerFlags -> IO (Either (ParseErrorBundle T.Text Data.Void.Void) (Program)) -parse name input compilerFlags = do - return $ parseAndVerify name (T.pack input) CompilerFlags{verboseMode = False} +parse name input compilerFlags = return $ parseAndVerify name (T.pack input) CompilerFlags{verboseMode = False} main :: IO () main = do - Options input output debug verbose emitBytecode runBytecode breakpoints showTime runRepl <- + Options input output debug verbose emitBytecode runBytecode breakpoints showTime showVersion <- execParser $ info (optionsParser <**> helper) ( fullDesc - <> progDesc "TODO" + <> progDesc "Run without arguments to enter the REPL." <> header "indigo - a functional programming language" ) - when runRepl $ do - runStateT repl initREPLState + when showVersion $ do + putStrLn $ "Indigo, version " ++ version + exitSuccess + when (isNothing input) $ do + -- runStateT repl initREPLState + newRepl exitSuccess program <- if not runBytecode @@ -172,59 +171,99 @@ data REPLState = REPLState initREPLState = REPLState - { -- program = Program [FuncDef "main" [] (DoBlock [])], - program = Program [] + { program = Program [] , previousProgram = Program [] , previousStack = [] } -repl :: StateT REPLState IO () -repl = do - liftIO $ putStr "🔮> " - liftIO $ hFlush stdout - input <- liftIO getLine - case input of - ":exit" -> return () - ":ast" -> do - Program sexprs <- gets program +type Repl a = HaskelineT (StateT REPLState IO) a + +cmd :: String -> Repl () +cmd input = do + let (result, state) = runIdentity $ runStateT (parseProgram' (T.pack input)) (ParserState{compilerFlags = CompilerFlags{verboseMode = False}, validLets = [], validFunctions = []}) + case result of + Left err -> liftIO $ putStrLn $ errorBundlePretty err + Right program' -> do + let (Program pexrs) = program' + (Program sexprs) <- gets program + modify (\s -> s{previousProgram = Program sexprs}) + modify (\s -> s{program = Program (sexprs ++ pexrs)}) + mergedProgram <- gets program >>= \x -> return $ Program (exprs x ++ [FuncDef "main" [] (DoBlock [])]) + compiled <- liftIO $ evalStateT (BytecodeCompiler.compileProgram mergedProgram) (BytecodeCompiler.initCompilerState mergedProgram) + let mainPc = BytecodeCompiler.locateLabel compiled "main" + result <- liftIO $ try (VM.runVMVM $ (VM.initVM (V.fromList compiled)){VM.pc = mainPc, VM.callStack = [VM.StackFrame{returnAddress = mainPc, locals = []}]}) :: Repl (Either SomeException VM.VM) + case result of + Left err -> do + liftIO $ putStrLn $ VM.printAssembly (V.fromList compiled) True + liftIO $ print err + previousProgram <- gets previousProgram + modify (\s -> s{program = previousProgram}) + Right vm -> do + previousStack <- gets previousStack + when (previousStack /= VM.stack vm) $ liftIO $ print $ head $ VM.stack vm + modify (\s -> s{previousStack = VM.stack vm}) + +replCompleter :: (Monad m, MonadState REPLState m) => WordCompleter m +replCompleter n = do + (Program exprs) <- gets program + let names = map nameOf exprs + return $ filter (isPrefixOf n) names + where + nameOf (FuncDef name _ _) = name + nameOf (Function def dec) = nameOf (head def) + nameOf _ = "" + +opts :: [(String, String -> Repl ())] +opts = + [ ("exit", const $ liftIO exitSuccess) -- TODO: use the same as final + , + ( "help" + , const $ do + liftIO $ putStrLn ":: - start a multiline expression" + liftIO $ putStrLn ":ast - print the AST" + liftIO $ putStrLn ":vm - print the VM assembly" + liftIO $ putStrLn ":help - print this help message" + liftIO $ putStrLn ":exit / ^D - exit the REPL" + ) + , + ( "ast" + , const $ do + (Program sexprs) <- gets program liftIO $ putStrLn $ prettyPrintProgram (Program sexprs) - repl - ":vm" -> do - Program sexprs <- gets program + ) + , + ( "vm" + , const $ do + (Program sexprs) <- gets program compiled <- liftIO $ evalStateT (BytecodeCompiler.compileProgram (Program sexprs)) (BytecodeCompiler.initCompilerState (Program sexprs)) liftIO $ putStrLn $ VM.printAssembly (V.fromList compiled) True - repl - ":help" -> do - liftIO $ putStrLn "Commands:" - liftIO $ putStrLn ":exit - exit the REPL" - liftIO $ putStrLn ":ast - print the AST" - liftIO $ putStrLn ":vm - print the VM assembly" - repl - _ -> do - let (result, state) = runIdentity $ runStateT (parseProgram' (T.pack input)) (ParserState{compilerFlags = CompilerFlags{verboseMode = False}, validLets = [], validFunctions = []}) - case result of - Left err -> do - liftIO $ putStrLn $ errorBundlePretty err - repl - Right program' -> do - let (Program pexrs) = program' - (Program sexprs) <- gets program - modify (\s -> s{previousProgram = Program sexprs}) - modify (\s -> s{program = Program (sexprs ++ pexrs)}) - mergedProgram <- gets program >>= \x -> return $ Program (exprs x ++ [FuncDef "main" [] (DoBlock [])]) - compiled <- liftIO $ evalStateT (BytecodeCompiler.compileProgram mergedProgram) (BytecodeCompiler.initCompilerState mergedProgram) - let mainPc = BytecodeCompiler.locateLabel compiled "main" - result <- liftIO $ try (VM.runVMVM $ (VM.initVM (V.fromList compiled)){VM.pc = mainPc, VM.callStack = [VM.StackFrame{returnAddress = mainPc, locals = []}]}) :: StateT REPLState IO (Either SomeException VM.VM) - case result of - Left err -> do - liftIO $ putStrLn $ VM.printAssembly (V.fromList compiled) True - liftIO $ print err - previousProgram <- gets previousProgram - modify (\s -> s{program = previousProgram}) - repl - Right vm -> do - previousStack <- gets previousStack - when (previousStack /= VM.stack vm) $ do - liftIO $ print $ head $ VM.stack vm - modify (\s -> s{previousStack = VM.stack vm}) - repl + ) + ] + +version :: String +version = take 7 (giHash gi) + where + gi = $$tGitInfoCwd + +ini :: Repl () +ini = liftIO $ putStrLn $ "Indigo, version " ++ version ++ ". Type :help for help." + +final :: Repl ExitDecision +final = do + liftIO $ putStrLn "Goodbye!" + return Exit + +newRepl :: IO () +newRepl = + flip evalStateT initREPLState $ + evalReplOpts $ + ReplOpts + { banner = const $ pure "🔮> " + , command = cmd + , options = opts + , prefix = Just ':' + , multilineCommand = Just ":" + , tabComplete = Word replCompleter + , initialiser = ini + , finaliser = final + } diff --git a/indigo.cabal b/indigo.cabal index 3e3e1f4..ac37337 100644 --- a/indigo.cabal +++ b/indigo.cabal @@ -41,7 +41,7 @@ library split, vector, -- pretty-simple, - monad-loops + monad-loops, hs-source-dirs: lib default-language: Haskell2010 default-extensions: OverloadedStrings, @@ -55,7 +55,7 @@ library RecordWildCards, NamedFieldPuns -executable indigoc +executable indigo main-is: Main.hs hs-source-dirs: app build-depends: base, @@ -67,12 +67,16 @@ executable indigoc bytestring, indigo, vector, - timeit + timeit, + repline, + containers, + githash default-extensions: OverloadedStrings, ImportQualifiedPost, DisambiguateRecordFields, - DuplicateRecordFields + DuplicateRecordFields, + TemplateHaskell default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0