Skip to content

Commit

Permalink
Better REPL, adjusted CLI
Browse files Browse the repository at this point in the history
  • Loading branch information
@rockofox
rockofox committed Nov 20, 2023
1 parent 4cf5739 commit 718fce3
Show file tree
Hide file tree
Showing 2 changed files with 125 additions and 82 deletions.
195 changes: 117 additions & 78 deletions app/Main.hs
View file
Original file line number Diff line number Diff line change
@@ -1,25 +1,30 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

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)
Expand All @@ -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
Expand All @@ -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"
Expand All @@ -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 ++ "]"
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
}
12 changes: 8 additions & 4 deletions indigo.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -41,7 +41,7 @@ library
split,
vector,
-- pretty-simple,
monad-loops
monad-loops,
hs-source-dirs: lib
default-language: Haskell2010
default-extensions: OverloadedStrings,
Expand All @@ -55,7 +55,7 @@ library
RecordWildCards,
NamedFieldPuns

executable indigoc
executable indigo
main-is: Main.hs
hs-source-dirs: app
build-depends: base,
Expand All @@ -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
Expand Down

0 comments on commit 718fce3

Please sign in to comment.