Add arguments to the Ivo interpreter (and shebang support).
The supported options are `-h`, `-V`, `-t`, `-T`, and `-c`. Additional arguments are files to be loaded. In the process, these additional changes have been made: * `:check` has been replaced with `:printTypes`; disabling typechecking is no longer possible. * Ivo programs no longer allow top-level expressions; a `main` definition must be used instead. * Traces and type information are now printed to `STDERR`. * The interpreter code underwent /some/ cleanup, but more is still needed.master
parent
280096ccb6
commit
b337ecb094
GPG Key ID:
4B7F3DA9351E577C
21
README.md
21
README.md
|
|
@ -9,8 +9,11 @@ This README serves to document the language as it currently stands,
|
|||
not what the language one day hopes to be.
|
||||
|
||||
## Using the Ivo interpreter
|
||||
You may run the Ivo interpreter using `stack run`;
|
||||
the interpreter does not take any arguments.
|
||||
You may run the Ivo interpreter (`ivo`)
|
||||
by installing it to your local path using `stack install`,
|
||||
or equivalently, using `stack run [-- args...]`.
|
||||
For information about `ivo`'s command line arguments, please refer to `ivo --help`
|
||||
(or `stack run -- --help`).
|
||||
|
||||
Type in your command, definition, or expression at the prompt: `>> `.
|
||||
Expressions will be typechecked, evaluated using call-by-value, and then printed.
|
||||
|
|
@ -30,17 +33,13 @@ These commands are available:
|
|||
|
||||
The filename may contain spaces, but trailing whitespace will be trimmed.
|
||||
|
||||
* `:check <on/off> <always/decls/off>`:
|
||||
* `:printTypes <both/decls/exprs/off>`:
|
||||
|
||||
* If the first argument is `on`,
|
||||
then expressions will only be evaluated and definitions will only be added
|
||||
only if typechecking succeeds.
|
||||
Print to STDERR the inferred types of top-level declarations,
|
||||
of expressions entered into the interpreters,
|
||||
of both, or of neither.
|
||||
|
||||
* If the second argument is `always`, then inferred types will always be printed;
|
||||
if it is `decls`, then only the inferred types of declarations will be printed;
|
||||
otherwise, the type of expressions are never printed.'
|
||||
|
||||
* The default values are `on` `decls`.
|
||||
This setting defaults to `off`.
|
||||
|
||||
* `:trace <off/local/global>`:
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,51 @@
|
|||
module Command where
|
||||
|
||||
import MonadApp
|
||||
|
||||
import Data.Text (Text)
|
||||
import Text.Parsec hiding (label)
|
||||
import Text.Parsec.Text (Parser)
|
||||
|
||||
data Command
|
||||
= Trace TraceOpts
|
||||
| PrintType PrintTypeOpts
|
||||
| Load FilePath
|
||||
| Clear
|
||||
|
||||
commandParser :: Parser Command
|
||||
commandParser = do
|
||||
char ':'
|
||||
clear <|> printType <|> trace <|> load
|
||||
where
|
||||
trace = Trace <$> do
|
||||
try $ string "trace"
|
||||
spaces
|
||||
try traceOff <|> try traceLocal <|> try traceGlobal
|
||||
traceOff = TraceOff <$ string "off"
|
||||
traceLocal = TraceLocal <$ string "local"
|
||||
traceGlobal = TraceGlobal <$ string "global"
|
||||
|
||||
printType = PrintType <$> do
|
||||
try $ string "printType"
|
||||
spaces
|
||||
try printBoth <|> try printDecls <|> printExprs <|> try printOff
|
||||
printBoth = PrintBoth <$ string "both"
|
||||
printDecls = PrintDecls <$ string "decls"
|
||||
printExprs = PrintExprs <$ string "exprs"
|
||||
printOff = PrintOff <$ string "off"
|
||||
|
||||
load = Load <$> do
|
||||
try $ string "load"
|
||||
spaces
|
||||
many1 (noneOf " ")
|
||||
|
||||
clear = Clear <$ try (string "clear")
|
||||
|
||||
-- | If the text is not command (i.e. starts with `:`), parse nothing;
|
||||
-- otherwise, parse the command or return a parse error.
|
||||
--
|
||||
-- This allows attempting to parse a command and then falling back
|
||||
-- to the expression interpreter if the input is not a command,
|
||||
-- without forgetting about command parse errors.
|
||||
parseCommand :: Text -> Either ParseError (Maybe Command)
|
||||
parseCommand = parse ((Just <$> commandParser <* spaces <* eof) <|> pure Nothing) "input"
|
||||
|
|
@ -0,0 +1,115 @@
|
|||
module Flags where
|
||||
|
||||
import MonadApp
|
||||
|
||||
import Data.Foldable (foldlM)
|
||||
import Data.Maybe (isJust)
|
||||
import System.Console.GetOpt
|
||||
( OptDescr (Option), ArgDescr (NoArg, OptArg, ReqArg), ArgOrder (Permute)
|
||||
, getOpt, usageInfo
|
||||
)
|
||||
import System.Environment (getArgs)
|
||||
|
||||
data Flag
|
||||
= FlagHelp
|
||||
| FlagVersion
|
||||
| FlagProgram String
|
||||
| FlagPrintTypes (Maybe String)
|
||||
| FlagTrace (Maybe String)
|
||||
|
||||
flagDescrs :: [OptDescr Flag]
|
||||
flagDescrs =
|
||||
[ Option ['h'] ["help"] (NoArg FlagHelp)
|
||||
"Print to STDOUT this help message and exit."
|
||||
, Option ['V'] ["version"] (NoArg FlagVersion)
|
||||
"Print to STDOUT the Ivo version number and exit."
|
||||
, Option ['c'] [] (ReqArg FlagProgram "FILE")
|
||||
"After loading all other files, execute the `main` function of this file and exit."
|
||||
, Option ['T'] ["print-types"] (OptArg FlagPrintTypes "decls|exprs|both")
|
||||
"Print to STDERR the inferred types for top-level declarations and/or expressions."
|
||||
, Option ['t'] ["trace"] (OptArg FlagTrace "local|global")
|
||||
"Print to STDERR each evaluation step, either the analyzed portion of, or the entire, expression."
|
||||
]
|
||||
|
||||
data ProgramAction
|
||||
= PrintHelp
|
||||
| PrintVersion
|
||||
| Interpreter ProgramOpts
|
||||
|
||||
defaultProgramAction :: ProgramAction
|
||||
defaultProgramAction = Interpreter defaultProgramOpts
|
||||
|
||||
data ProgramOpts = ProgramOpts
|
||||
{ pInterpreterOpts :: InterpreterOpts
|
||||
-- | The files which will be interpreted.
|
||||
, loadFiles :: [FilePath]
|
||||
-- | The file whose `main` function will be executed.
|
||||
, mainFile :: Maybe FilePath
|
||||
}
|
||||
|
||||
defaultProgramOpts :: ProgramOpts
|
||||
defaultProgramOpts = ProgramOpts
|
||||
{ pInterpreterOpts = defaultInterpreterOpts
|
||||
, loadFiles = []
|
||||
, mainFile = Nothing
|
||||
}
|
||||
|
||||
-- | Take all the flags and files passed to the program,
|
||||
-- and determine what action the program should take based on them.
|
||||
foldFlags :: [Flag] -> [String] -> Either String ProgramAction
|
||||
foldFlags flags files =
|
||||
foldlM applyFlag (Interpreter (defaultProgramOpts { loadFiles = files })) flags
|
||||
where
|
||||
applyFlag :: ProgramAction -> Flag -> Either String ProgramAction
|
||||
applyFlag PrintHelp _ = Right PrintHelp
|
||||
applyFlag _ FlagHelp = Right PrintHelp
|
||||
applyFlag PrintVersion _ = Right PrintVersion
|
||||
applyFlag _ FlagVersion = Right PrintVersion
|
||||
applyFlag (Interpreter opts) flag = Interpreter <$> applyInterpreterFlag flag
|
||||
where
|
||||
applyInterpreterFlag :: Flag -> Either String ProgramOpts
|
||||
applyInterpreterFlag (FlagProgram file)
|
||||
| isJust (mainFile opts) = Left "-c can only be specified once"
|
||||
| otherwise = Right $ opts { mainFile = Just file }
|
||||
applyInterpreterFlag (FlagPrintTypes mOpt) = case readPrintTypeOpt mOpt of
|
||||
Left opt -> Left $ "unknown --print-types option: " ++ opt ++ "\n"
|
||||
Right opt -> Right
|
||||
opts { pInterpreterOpts = (pInterpreterOpts opts) { printTypeOpts = opt } }
|
||||
applyInterpreterFlag (FlagTrace mOpt) = case readTraceOpt mOpt of
|
||||
Left opt -> Left $ "unknown --trace option: " ++ opt ++ "\n"
|
||||
Right opt -> Right
|
||||
opts { pInterpreterOpts = (pInterpreterOpts opts) { traceOpts = opt } }
|
||||
applyInterpreterFlag _ = error "Illegal flag"
|
||||
|
||||
readPrintTypeOpt :: Maybe String -> Either String PrintTypeOpts
|
||||
readPrintTypeOpt Nothing = Right PrintDecls
|
||||
readPrintTypeOpt (Just "decls") = Right PrintDecls
|
||||
readPrintTypeOpt (Just "exprs") = Right PrintExprs
|
||||
readPrintTypeOpt (Just "both") = Right PrintBoth
|
||||
readPrintTypeOpt (Just opt) = Left opt
|
||||
|
||||
readTraceOpt :: Maybe String -> Either String TraceOpts
|
||||
readTraceOpt Nothing = Right TraceLocal
|
||||
readTraceOpt (Just "local") = Right TraceLocal
|
||||
readTraceOpt (Just "global") = Right TraceGlobal
|
||||
readTraceOpt (Just opt) = Left opt
|
||||
|
||||
-- | Given a list of arguments as raw strings, determine what the program should do.
|
||||
decideAction :: [String] -> Either [String] ProgramAction
|
||||
decideAction args = case getOpt Permute flagDescrs args of
|
||||
(flags, files, errs) -> case foldFlags flags files of
|
||||
Left err -> Left $ err : errs
|
||||
Right action
|
||||
| not (null errs) -> Left errs
|
||||
| otherwise -> Right action
|
||||
|
||||
usageMessage :: String
|
||||
usageMessage = usageInfo "Usage: ivo [OPTION...] [files...]" flagDescrs
|
||||
|
||||
-- | Read the program's arguments and decide what to do.
|
||||
getAction :: IO ProgramAction
|
||||
getAction = do
|
||||
mAction <- decideAction <$> getArgs
|
||||
case mAction of
|
||||
Left errs -> ioError $ userError $ concat errs ++ usageMessage
|
||||
Right action -> pure action
|
||||
317
app/Main.hs
317
app/Main.hs
|
|
@ -1,237 +1,172 @@
|
|||
module Main (main) where
|
||||
|
||||
import Command
|
||||
import Flags
|
||||
import MonadApp
|
||||
|
||||
import Ivo
|
||||
|
||||
import Control.Exception (IOException, catch)
|
||||
import Data.Maybe (isJust)
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError, liftEither)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Control.Monad (when, zipWithM)
|
||||
import Control.Monad.Except (throwError, liftEither)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Loops (whileJust_)
|
||||
import Control.Monad.State (MonadState, StateT, evalStateT, gets, modify)
|
||||
import Control.Monad.State (gets, modify')
|
||||
import Control.Monad.Trans (lift)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.Maybe (isJust, fromJust)
|
||||
import Data.Text qualified as T
|
||||
import System.Console.Haskeline
|
||||
( InputT, runInputT, defaultSettings
|
||||
, outputStrLn, getInputLine, handleInterrupt, withInterrupt
|
||||
)
|
||||
import Text.Parsec
|
||||
import Text.Parsec.Text (Parser)
|
||||
import Data.Text.IO (readFile)
|
||||
import Prelude hiding (readFile)
|
||||
import System.Console.Haskeline (getInputLine)
|
||||
|
||||
outputTextLn :: MonadIO m => Text -> InputT m ()
|
||||
outputTextLn = outputStrLn . T.unpack
|
||||
main :: IO ()
|
||||
main = do
|
||||
action <- getAction
|
||||
case action of
|
||||
PrintHelp -> putStrLn usageMessage
|
||||
PrintVersion -> putStrLn "Ivo 0.1.0.0"
|
||||
Interpreter ProgramOpts { pInterpreterOpts, loadFiles, mainFile } -> do
|
||||
-- read the file contents first so we can print errors right away
|
||||
mMainContents <- mapM readArgFile mainFile
|
||||
filesContents <- mapM readArgFile loadFiles
|
||||
runAppM pInterpreterOpts do
|
||||
-- then parse
|
||||
mMain <- mapM (parseProgramHandleErrors $ fromJust mainFile) mMainContents
|
||||
case mMain of
|
||||
Just mainAST
|
||||
| any (\(name, _, _) -> name == "main") mainAST -> pure ()
|
||||
| otherwise -> throwError "File passed to `-c` does not contain a main function."
|
||||
Nothing -> pure ()
|
||||
|
||||
-- | Immediately quit the program when interrupted
|
||||
-- without performing any additional actions.
|
||||
-- (Without this, it will print an extra newline for some reason.)
|
||||
justDie :: (MonadIO m, MonadMask m) => InputT m () -> InputT m ()
|
||||
justDie = handleInterrupt (pure ()) . withInterrupt
|
||||
files <- zipWithM parseProgramHandleErrors loadFiles filesContents
|
||||
-- and only finally interpret
|
||||
mapM_ loadFile files
|
||||
maybe repl runProgram mMain
|
||||
|
||||
data AppState = AppState
|
||||
{ traceOptions :: TraceOptions
|
||||
, checkOptions :: CheckOptions
|
||||
, definitions :: HashMap Text CheckExpr
|
||||
}
|
||||
|
||||
data TraceOptions
|
||||
-- | Print the entire expression in traces.
|
||||
= TraceGlobal
|
||||
-- | Print only the modified part of the expression in traces.
|
||||
| TraceLocal
|
||||
-- | Do not trace evaluation.
|
||||
| TraceOff
|
||||
|
||||
data CheckOptions = CheckOptions
|
||||
-- | Require that an expression typechecks to run it.
|
||||
{ shouldTypecheck :: Bool
|
||||
-- | Print the inferred type of an expressions.
|
||||
, shouldPrintType :: CheckPrintOptions
|
||||
}
|
||||
|
||||
data CheckPrintOptions = PrintAlways | PrintDecls | PrintOff
|
||||
deriving Eq
|
||||
|
||||
shouldPrintTypeErrorsQ :: Bool -> CheckOptions -> Bool
|
||||
shouldPrintTypeErrorsQ isDecl opts
|
||||
= shouldTypecheck opts
|
||||
|| shouldPrintTypeQ isDecl opts
|
||||
|
||||
shouldPrintTypeQ :: Bool -> CheckOptions -> Bool
|
||||
shouldPrintTypeQ isDecl opts
|
||||
= shouldPrintType opts == PrintAlways
|
||||
|| shouldPrintType opts == PrintDecls && isDecl
|
||||
|
||||
defaultAppState :: AppState
|
||||
defaultAppState = AppState
|
||||
{ traceOptions = TraceOff
|
||||
, checkOptions = CheckOptions
|
||||
{ shouldTypecheck = True
|
||||
, shouldPrintType = PrintDecls
|
||||
}
|
||||
, definitions = HM.empty
|
||||
}
|
||||
|
||||
data Command
|
||||
= Trace TraceOptions
|
||||
| Check CheckOptions
|
||||
| Load FilePath
|
||||
| Clear
|
||||
|
||||
commandParser :: Parser Command
|
||||
commandParser = do
|
||||
char ':'
|
||||
trace <|> check <|> load <|> clear
|
||||
where
|
||||
trace = Trace <$> do
|
||||
try $ string "trace "
|
||||
try traceOff <|> try traceLocal <|> try traceGlobal
|
||||
traceOff = TraceOff <$ string "off"
|
||||
traceLocal = TraceLocal <$ string "local"
|
||||
traceGlobal = TraceGlobal <$ string "global"
|
||||
-- | When reading the file contents of a file passed as an argument,
|
||||
-- we want to print usage information and exit if the file can't be opened.
|
||||
readArgFile :: FilePath -> IO Text
|
||||
readArgFile file = readFile file `catch` handleException
|
||||
where
|
||||
handleException :: IOException -> IO a
|
||||
handleException _ = ioError $ userError $
|
||||
"Could not open file: " ++ file ++ "\n" ++ usageMessage
|
||||
|
||||
check = Check <$> do
|
||||
try $ string "check "
|
||||
spaces
|
||||
tc <- (True <$ try (string "on ")) <|> (False <$ try (string "off "))
|
||||
spaces
|
||||
pr <- try printAlways <|> try printDecls <|> try printOff
|
||||
pure $ CheckOptions tc pr
|
||||
printAlways = PrintAlways <$ string "always"
|
||||
printDecls = PrintDecls <$ string "decls"
|
||||
printOff = PrintOff <$ string "off"
|
||||
repl :: AppM ()
|
||||
repl = lift $ whileJust_ (fmap T.pack <$> lift (getInputLine ">> ")) \inputText ->
|
||||
handleErrors do
|
||||
input <- parseCommandOrTopLevel inputText
|
||||
either runCommand runTopLevel input
|
||||
|
||||
load = Load <$> do
|
||||
try $ string "load "
|
||||
spaces
|
||||
filename <- many1 (noneOf " ")
|
||||
spaces
|
||||
pure filename
|
||||
parseCommandOrTopLevel :: Text -> AppM (Either Command TopLevelAST)
|
||||
parseCommandOrTopLevel input = do
|
||||
mCmd <- liftParseError $ parseCommand input
|
||||
case mCmd of
|
||||
Nothing -> Right <$> liftParseError (parseTopLevel input)
|
||||
Just cmd -> pure $ Left cmd
|
||||
|
||||
clear = Clear <$ try (string "clear")
|
||||
parseProgramHandleErrors :: FilePath -> Text -> AppM ProgramAST
|
||||
parseProgramHandleErrors filename = liftParseError . parse programParser filename
|
||||
|
||||
class MonadState AppState m => MonadApp m where
|
||||
parsed :: Either ParseError a -> m a
|
||||
typecheckDecl :: Maybe Type -> Text -> CheckExpr -> m (Maybe Scheme)
|
||||
typecheckExpr :: CheckExpr -> m (Maybe Scheme)
|
||||
execute :: CheckExpr -> m EvalExpr
|
||||
liftParseError :: Either ParseError a -> AppM a
|
||||
liftParseError result = case result of
|
||||
Left err -> throwError $ T.pack $ show err
|
||||
Right x -> pure x
|
||||
|
||||
type AppM = ExceptT Text (StateT AppState (InputT IO))
|
||||
runProgram :: ProgramAST -> AppM ()
|
||||
runProgram program = do
|
||||
loadFile program
|
||||
runDeclOrExpr (Right (Var "main"))
|
||||
|
||||
liftInput :: InputT IO a -> AppM a
|
||||
liftInput = lift . lift
|
||||
loadFile :: ProgramAST -> AppM ()
|
||||
loadFile = mapM_ (\(name, ty, e) -> define name ty $ ast2check e)
|
||||
|
||||
instance MonadApp AppM where
|
||||
parsed (Left err) = throwError $ T.pack $ show err
|
||||
parsed (Right ok) = pure ok
|
||||
runTopLevel :: TopLevelAST -> AppM ()
|
||||
runTopLevel = mapM_ runDeclOrExpr
|
||||
|
||||
typecheckDecl ty = typecheck ty . Just
|
||||
typecheckExpr = typecheck Nothing Nothing
|
||||
runDeclOrExpr :: Either Declaration AST -> AppM ()
|
||||
runDeclOrExpr (Left (name, ty, exprAST)) = do
|
||||
defs <- gets definitions
|
||||
let expr = substitute defs $ ast2check exprAST
|
||||
_ <- typecheckDecl ty name expr
|
||||
define name ty expr
|
||||
runDeclOrExpr (Right exprAST) = do
|
||||
defs <- gets definitions
|
||||
let expr = substitute defs $ ast2check exprAST
|
||||
_ <- typecheckExpr expr
|
||||
value <- execute expr
|
||||
liftInput $ outputTextLn $ unparseEval value
|
||||
pure ()
|
||||
|
||||
execute checkExpr = do
|
||||
defs <- gets definitions
|
||||
let expr = check2eval $ substitute defs checkExpr
|
||||
traceOpts <- gets traceOptions
|
||||
case traceOpts of
|
||||
TraceOff -> do
|
||||
let value = eval expr
|
||||
liftInput $ outputTextLn $ unparseEval value
|
||||
pure value
|
||||
TraceLocal -> do
|
||||
let (value, trace) = evalTrace expr
|
||||
liftInput $ mapM_ (outputTextLn . unparseEval) trace
|
||||
pure value
|
||||
TraceGlobal -> do
|
||||
let (value, trace) = evalTraceGlobal expr
|
||||
liftInput $ mapM_ (outputTextLn . unparseEval) trace
|
||||
pure value
|
||||
typecheckDecl :: Maybe Type -> Text -> CheckExpr -> AppM Scheme
|
||||
typecheckDecl ty = typecheck ty . Just
|
||||
|
||||
typecheck :: Maybe Type -> Maybe Text -> CheckExpr -> AppM (Maybe Scheme)
|
||||
typecheckExpr :: CheckExpr-> AppM Scheme
|
||||
typecheckExpr = typecheck Nothing Nothing
|
||||
|
||||
typecheck :: Maybe Type -> Maybe Text -> CheckExpr -> AppM Scheme
|
||||
typecheck tann decl expr = do
|
||||
defs <- gets definitions
|
||||
let type_ = maybe infer check tann $ substitute defs expr
|
||||
checkOpts <- gets checkOptions
|
||||
if shouldTypecheck checkOpts
|
||||
then case type_ of
|
||||
Left err -> throwError $ "Typecheck error: " <> err
|
||||
Right t -> do
|
||||
printType checkOpts t
|
||||
pure $ Just t
|
||||
else do
|
||||
case type_ of
|
||||
Left err ->
|
||||
when (shouldPrintTypeErrorsQ isDecl checkOpts) $
|
||||
liftInput $ outputStrLn $ "Typecheck error: " <> T.unpack err
|
||||
Right t -> printType checkOpts t
|
||||
|
||||
pure Nothing
|
||||
case type_ of
|
||||
Left err -> throwError $ "Typecheck error: " <> err
|
||||
Right t -> do
|
||||
printTypeB <- gets $ shouldPrintType isDecl . interpreterOpts
|
||||
when printTypeB $ outputStderrLn $ prefix <> unparseScheme t
|
||||
pure t
|
||||
where
|
||||
isDecl = isJust decl
|
||||
|
||||
printType opts t =
|
||||
when (shouldPrintTypeQ isDecl opts) $
|
||||
liftInput $ outputTextLn $ prefix <> unparseScheme t
|
||||
|
||||
prefix = case decl of
|
||||
Just name -> name <> " : "
|
||||
Nothing -> ": "
|
||||
|
||||
define :: MonadApp m => Text -> CheckExpr -> m ()
|
||||
define name expr = modify \appState ->
|
||||
let expr' = substitute (definitions appState) expr
|
||||
in appState { definitions = HM.insert name expr' $ definitions appState }
|
||||
|
||||
runDeclOrExpr :: MonadApp m => DeclOrExprAST -> m ()
|
||||
runDeclOrExpr (Left (name, ty, exprAST)) = do
|
||||
execute :: CheckExpr -> AppM EvalExpr
|
||||
execute checkExpr = do
|
||||
defs <- gets definitions
|
||||
let expr = substitute defs $ ast2check exprAST
|
||||
let expr = check2eval $ substitute defs checkExpr
|
||||
traceOpts <- gets (traceOpts . interpreterOpts)
|
||||
case traceOpts of
|
||||
TraceOff -> do
|
||||
let value = eval expr
|
||||
pure value
|
||||
TraceLocal -> do
|
||||
let (value, trace) = evalTrace expr
|
||||
mapM_ (outputStderrLn . unparseEval) trace
|
||||
pure value
|
||||
TraceGlobal -> do
|
||||
let (value, trace) = evalTraceGlobal expr
|
||||
mapM_ (outputStderrLn . unparseEval) trace
|
||||
pure value
|
||||
|
||||
define :: Text -> Maybe Type -> CheckExpr -> AppM ()
|
||||
define name ty expr = do
|
||||
_ <- typecheckDecl ty name expr
|
||||
define name expr
|
||||
runDeclOrExpr (Right exprAST) = do
|
||||
defs <- gets definitions
|
||||
let expr = substitute defs $ ast2check exprAST
|
||||
_ <- typecheckExpr expr
|
||||
_ <- execute expr
|
||||
pure ()
|
||||
modify' \appState ->
|
||||
let expr' = substitute (definitions appState) expr
|
||||
in appState { definitions = HM.insert name expr' $ definitions appState }
|
||||
|
||||
runProgram :: MonadApp m => ProgramAST -> m ()
|
||||
runProgram = mapM_ runDeclOrExpr
|
||||
modifyInterpreterOpts :: (InterpreterOpts -> InterpreterOpts) -> AppM ()
|
||||
modifyInterpreterOpts f =
|
||||
modify' \app -> app { interpreterOpts = f (interpreterOpts app) }
|
||||
|
||||
runCommand :: forall m. (MonadApp m, MonadIO m, MonadError Text m) => Command -> m ()
|
||||
runCommand (Trace traceOpts) = modify \app -> app { traceOptions = traceOpts }
|
||||
runCommand (Check checkOpts) = modify \app -> app { checkOptions = checkOpts }
|
||||
runCommand Clear = modify \app -> app { definitions = HM.empty }
|
||||
runCommand :: Command -> AppM ()
|
||||
runCommand (Trace traceOpts) =
|
||||
modifyInterpreterOpts \opts -> opts { traceOpts }
|
||||
runCommand (PrintType printTypeOpts) =
|
||||
modifyInterpreterOpts \opts -> opts { printTypeOpts }
|
||||
runCommand Clear = modify' \app -> app { definitions = HM.empty }
|
||||
runCommand (Load filePath) = do
|
||||
input <- safeReadFile
|
||||
program <- parsed $ parse programParser filePath input
|
||||
program <- liftParseError $ parse programParser filePath input
|
||||
runProgram program
|
||||
where
|
||||
safeReadFile :: m Text
|
||||
safeReadFile :: AppM Text
|
||||
safeReadFile = liftEither =<< liftIO (
|
||||
(Right . T.pack <$> readFile filePath)
|
||||
(Right <$> readFile filePath)
|
||||
`catch` handleException)
|
||||
|
||||
handleException :: IOException -> IO (Either Text Text)
|
||||
handleException = pure . Left . T.pack . show
|
||||
|
||||
parseCommandOrDeclOrExpr :: MonadApp m => Text -> m (Either Command DeclOrExprAST)
|
||||
parseCommandOrDeclOrExpr input = parsed $ parse commandOrDeclOrExprParser "input" input
|
||||
where
|
||||
commandOrDeclOrExprParser =
|
||||
(Left <$> try commandParser) <|> (Right <$> declOrExprParser) <* spaces <* eof
|
||||
|
||||
main :: IO ()
|
||||
main = runInputT defaultSettings $ justDie $ flip evalStateT defaultAppState $
|
||||
whileJust_ (fmap T.pack <$> lift (getInputLine ">> ")) \inputText ->
|
||||
handleErrors do
|
||||
input <- parseCommandOrDeclOrExpr inputText
|
||||
either runCommand runDeclOrExpr input
|
||||
where
|
||||
handleErrors :: ExceptT Text (StateT AppState (InputT IO)) () -> StateT AppState (InputT IO) ()
|
||||
handleErrors m = do
|
||||
result <- runExceptT m
|
||||
case result of
|
||||
Left err -> lift $ outputTextLn err
|
||||
Right _ -> pure ()
|
||||
|
|
|
|||
|
|
@ -0,0 +1,97 @@
|
|||
module MonadApp where
|
||||
|
||||
import Ivo
|
||||
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Control.Monad.Except (ExceptT, runExceptT)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Control.Monad.State (StateT, evalStateT)
|
||||
import Control.Monad.Trans (lift)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.IO (hPutStrLn)
|
||||
import System.Console.Haskeline
|
||||
( InputT, runInputT, defaultSettings
|
||||
, outputStrLn, handleInterrupt, withInterrupt
|
||||
)
|
||||
import System.IO (stderr)
|
||||
|
||||
type AppM = ExceptT Text (StateT AppState (InputT IO))
|
||||
|
||||
runAppM :: InterpreterOpts -> AppM () -> IO ()
|
||||
runAppM opts =
|
||||
runInputT defaultSettings . justDie . flip evalStateT appState . handleErrors
|
||||
where
|
||||
appState :: AppState
|
||||
appState = defaultAppState { interpreterOpts = opts }
|
||||
|
||||
-- | Immediately quit the program when interrupted
|
||||
-- without performing any additional actions.
|
||||
-- (Without this, it will print an extra newline for some reason.)
|
||||
justDie :: (MonadIO m, MonadMask m) => InputT m () -> InputT m ()
|
||||
justDie = handleInterrupt (pure ()) . withInterrupt
|
||||
|
||||
handleErrors :: AppM () -> StateT AppState (InputT IO) ()
|
||||
handleErrors m = do
|
||||
result <- runExceptT m
|
||||
case result of
|
||||
Left err -> liftIO $ hPutStrLn stderr err
|
||||
Right _ -> pure ()
|
||||
|
||||
liftInput :: InputT IO a -> AppM a
|
||||
liftInput = lift . lift
|
||||
|
||||
outputTextLn :: MonadIO m => Text -> InputT m ()
|
||||
outputTextLn = outputStrLn . T.unpack
|
||||
|
||||
outputStderrLn :: Text -> AppM ()
|
||||
outputStderrLn = liftIO . hPutStrLn stderr
|
||||
|
||||
data AppState = AppState
|
||||
{ interpreterOpts :: InterpreterOpts
|
||||
, definitions :: HashMap Text CheckExpr
|
||||
}
|
||||
|
||||
defaultAppState :: AppState
|
||||
defaultAppState = AppState
|
||||
{ interpreterOpts = defaultInterpreterOpts
|
||||
, definitions = mempty
|
||||
}
|
||||
|
||||
data InterpreterOpts = InterpreterOpts
|
||||
{ traceOpts :: TraceOpts
|
||||
, printTypeOpts :: PrintTypeOpts
|
||||
}
|
||||
|
||||
defaultInterpreterOpts :: InterpreterOpts
|
||||
defaultInterpreterOpts = InterpreterOpts
|
||||
{ traceOpts = TraceOff
|
||||
, printTypeOpts = PrintOff
|
||||
}
|
||||
|
||||
data TraceOpts
|
||||
-- | Print the entire expression in traces.
|
||||
= TraceGlobal
|
||||
-- | Print only the modified part of the expression in traces.
|
||||
| TraceLocal
|
||||
-- | Do not trace evaluation.
|
||||
| TraceOff
|
||||
|
||||
data PrintTypeOpts
|
||||
-- | Do not print the inferred type of any expressions.
|
||||
= PrintOff
|
||||
-- | Print the inferred type of top-level declarations.
|
||||
| PrintDecls
|
||||
-- | Print the inferred type of top-level expressions.
|
||||
| PrintExprs
|
||||
-- | Print to STDERR the inferred types of
|
||||
-- both top-level declarations and top-level expressions.
|
||||
| PrintBoth
|
||||
deriving Eq
|
||||
|
||||
shouldPrintType :: Bool -> InterpreterOpts -> Bool
|
||||
shouldPrintType isDecl opts = case printTypeOpts opts of
|
||||
PrintBoth -> True
|
||||
PrintDecls -> isDecl
|
||||
PrintExprs -> not isDecl
|
||||
PrintOff -> False
|
||||
|
|
@ -1,3 +1,4 @@
|
|||
#!/usr/bin/env -S ivo -c
|
||||
// Create a list by iterating `f` `n` times:
|
||||
letrec iterate = \f x.
|
||||
{ Z -> []
|
||||
|
|
@ -5,8 +6,9 @@ letrec iterate = \f x.
|
|||
};
|
||||
|
||||
// Use the iterate function to count to 10:
|
||||
let countTo = iterate S 1
|
||||
in countTo 10;
|
||||
let countToTen : [Nat] =
|
||||
let countTo = iterate S 1
|
||||
in countTo 10;
|
||||
|
||||
// Append two lists together:
|
||||
letrec append = \xs ys.
|
||||
|
|
@ -21,29 +23,27 @@ letrec reverse =
|
|||
};
|
||||
|
||||
// Now we can reverse `"reverse"`:
|
||||
reverse "reverse";
|
||||
let reverseReverse : [Char] = reverse "reverse";
|
||||
|
||||
// Calculating `3 + 2` with the help of Church-encoded numerals:
|
||||
let Sf = \n f x. f (n f x)
|
||||
; plus = \x. x Sf
|
||||
in plus (\f x. f (f (f x))) (\f x. f (f x)) S Z;
|
||||
let threePlusTwo : Nat =
|
||||
let Sf = \n f x. f (n f x)
|
||||
; plus = \x. x Sf
|
||||
in plus (\f x. f (f (f x))) (\f x. f (f x)) S Z;
|
||||
|
||||
letrec undefined = undefined;
|
||||
|
||||
// This expression would loop forever, but `callcc` saves the day!
|
||||
S (callcc \k. undefined (k Z));
|
||||
let callccSaves : Nat = S (callcc \k. undefined (k Z));
|
||||
|
||||
// And if it wasn't clear, this is what the `Char` constructor does:
|
||||
{ Char c -> Char (S c) } 'a;
|
||||
let charB : Char = { Char c -> Char (S c) } 'a;
|
||||
// (it outputs `'b`)
|
||||
|
||||
// Here are a few expressions which don't typecheck but are handy for debugging the evaluator
|
||||
// (you can run them using `:check off off`:
|
||||
/*
|
||||
let D = \x. x x; F = \f. f (f y) in D (F \x. x);
|
||||
// y y
|
||||
let T = \f x. f (f x) in (\f x. T (T (T (T T))) f x) (\x. x) y;
|
||||
// y
|
||||
(\x y z. x y) y;
|
||||
// λy' z. y y'
|
||||
*/
|
||||
// pack all of the examples into tuples so the main function can print them
|
||||
let main =
|
||||
( countToTen
|
||||
, ( reverseReverse
|
||||
, ( callccSaves
|
||||
, charB
|
||||
)))
|
||||
|
|
|
|||
47
package.yaml
47
package.yaml
|
|
@ -12,30 +12,6 @@ description: Please see the README on GitHub at <https://github.com/ivol
|
|||
extra-source-files:
|
||||
- README.md
|
||||
|
||||
default-extensions:
|
||||
- BlockArguments
|
||||
- ConstraintKinds
|
||||
- DefaultSignatures
|
||||
- EmptyCase
|
||||
- EmptyDataDeriving
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- ImportQualifiedPost
|
||||
- InstanceSigs
|
||||
- LambdaCase
|
||||
- OverloadedStrings
|
||||
- PatternSynonyms
|
||||
- ScopedTypeVariables
|
||||
- StandaloneDeriving
|
||||
- ViewPatterns
|
||||
# Required for use of the 'trees that grow' pattern
|
||||
- MultiParamTypeClasses
|
||||
- TypeFamilies
|
||||
# Used by recursion-schemes when using template haskell
|
||||
- DeriveFoldable
|
||||
- DeriveFunctor
|
||||
- DeriveTraversable
|
||||
|
||||
dependencies:
|
||||
- base >= 4.14 && < 5
|
||||
- monad-loops >= 0.4.3 && < 0.5
|
||||
|
|
@ -45,6 +21,29 @@ dependencies:
|
|||
- text >= 1.2 && < 2
|
||||
- unordered-containers >= 0.2.13 && < 0.3
|
||||
|
||||
default-extensions:
|
||||
- BlockArguments
|
||||
- ConstraintKinds
|
||||
- DefaultSignatures
|
||||
- DeriveFoldable
|
||||
- DeriveFunctor
|
||||
- DeriveTraversable
|
||||
- EmptyCase
|
||||
- EmptyDataDeriving
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- ImportQualifiedPost
|
||||
- InstanceSigs
|
||||
- LambdaCase
|
||||
- MultiParamTypeClasses
|
||||
- NamedFieldPuns
|
||||
- OverloadedStrings
|
||||
- PatternSynonyms
|
||||
- ScopedTypeVariables
|
||||
- StandaloneDeriving
|
||||
- TypeFamilies
|
||||
- ViewPatterns
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
ghc-options:
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
module Ivo.Syntax.Parser
|
||||
( ParseError, parse
|
||||
, Declaration, DeclOrExprAST, ProgramAST
|
||||
, parseAST, parseDeclOrExpr, parseProgram
|
||||
, typeParser, schemeParser, astParser, declOrExprParser, programParser
|
||||
, Declaration, TopLevelAST, ProgramAST
|
||||
, parseAST, parseTopLevel, parseProgram
|
||||
, typeParser, schemeParser, astParser, topLevelParser, programParser
|
||||
) where
|
||||
|
||||
import Ivo.Syntax.Base
|
||||
|
|
@ -280,17 +280,26 @@ declaration = notFollowedBy (try let_) >> (declrec <|> decl)
|
|||
definitionAnn
|
||||
|
||||
-- | A program is a series of declarations and expressions to execute.
|
||||
type ProgramAST = [DeclOrExprAST]
|
||||
type DeclOrExprAST = Either Declaration AST
|
||||
type ProgramAST = [Declaration]
|
||||
type TopLevelAST = [Either Declaration AST]
|
||||
|
||||
declOrExprParser :: Parser DeclOrExprAST
|
||||
declOrExprParser = try (Left <$> declaration) <|> (Right <$> ambiguous)
|
||||
topLevel :: Parser (Either Declaration AST)
|
||||
topLevel = try (Left <$> declaration) <|> (Right <$> ambiguous)
|
||||
|
||||
topLevelParser :: Parser TopLevelAST
|
||||
topLevelParser = spaces *> sepEndBy topLevel (token ';') <* eof
|
||||
|
||||
shebang :: Parser ()
|
||||
shebang = do
|
||||
try $ keyword "#!"
|
||||
skipMany (noneOf "\n")
|
||||
spaces
|
||||
|
||||
programParser :: Parser ProgramAST
|
||||
programParser = spaces *> sepEndBy declOrExprParser (token ';') <* eof
|
||||
programParser = shebang *> sepEndBy declaration (token ';') <* eof
|
||||
|
||||
parseDeclOrExpr :: Text -> Either ParseError DeclOrExprAST
|
||||
parseDeclOrExpr = parse declOrExprParser "input"
|
||||
parseTopLevel :: Text -> Either ParseError TopLevelAST
|
||||
parseTopLevel = parse topLevelParser "input"
|
||||
|
||||
parseProgram :: Text -> Either ParseError ProgramAST
|
||||
parseProgram = parse programParser "input"
|
||||
|
|
|
|||
Loading…
Reference in New Issue