2021-03-15 23:56:52 -07:00
|
|
|
module Main (main) where
|
2019-08-15 10:42:24 -07:00
|
|
|
|
2021-03-26 22:58:45 -07:00
|
|
|
import Command
|
|
|
|
import Flags
|
|
|
|
import MonadApp
|
|
|
|
|
2021-03-26 12:31:55 -07:00
|
|
|
import Ivo
|
2021-03-16 17:19:50 -07:00
|
|
|
|
2021-03-18 14:40:04 -07:00
|
|
|
import Control.Exception (IOException, catch)
|
2021-03-26 22:58:45 -07:00
|
|
|
import Control.Monad (when, zipWithM)
|
|
|
|
import Control.Monad.Except (throwError, liftEither)
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
2021-03-18 14:40:04 -07:00
|
|
|
import Control.Monad.Loops (whileJust_)
|
2021-03-26 22:58:45 -07:00
|
|
|
import Control.Monad.State (gets, modify')
|
2021-03-18 14:40:04 -07:00
|
|
|
import Control.Monad.Trans (lift)
|
|
|
|
import Data.HashMap.Strict qualified as HM
|
2021-03-26 22:58:45 -07:00
|
|
|
import Data.Maybe (isJust, fromJust)
|
2021-03-18 14:40:04 -07:00
|
|
|
import Data.Text qualified as T
|
2021-03-26 22:58:45 -07:00
|
|
|
import Data.Text.IO (readFile)
|
|
|
|
import Prelude hiding (readFile)
|
|
|
|
import System.Console.Haskeline (getInputLine)
|
2021-03-18 14:40:04 -07:00
|
|
|
|
2021-03-26 22:58:45 -07:00
|
|
|
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 ()
|
|
|
|
|
|
|
|
files <- zipWithM parseProgramHandleErrors loadFiles filesContents
|
|
|
|
-- and only finally interpret
|
|
|
|
mapM_ loadFile files
|
|
|
|
maybe repl runProgram mMain
|
2021-03-18 14:40:04 -07:00
|
|
|
|
2021-03-26 22:58:45 -07:00
|
|
|
where
|
|
|
|
-- | 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
|
|
|
|
|
|
|
|
repl :: AppM ()
|
|
|
|
repl = lift $ whileJust_ (fmap T.pack <$> lift (getInputLine ">> ")) \inputText ->
|
|
|
|
handleErrors do
|
|
|
|
input <- parseCommandOrTopLevel inputText
|
|
|
|
either runCommand runTopLevel input
|
|
|
|
|
|
|
|
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
|
|
|
|
|
|
|
|
parseProgramHandleErrors :: FilePath -> Text -> AppM ProgramAST
|
|
|
|
parseProgramHandleErrors filename = liftParseError . parse programParser filename
|
|
|
|
|
|
|
|
liftParseError :: Either ParseError a -> AppM a
|
|
|
|
liftParseError result = case result of
|
|
|
|
Left err -> throwError $ T.pack $ show err
|
|
|
|
Right x -> pure x
|
|
|
|
|
|
|
|
runProgram :: ProgramAST -> AppM ()
|
|
|
|
runProgram program = do
|
|
|
|
loadFile program
|
|
|
|
runDeclOrExpr (Right (Var "main"))
|
|
|
|
|
|
|
|
loadFile :: ProgramAST -> AppM ()
|
2021-03-29 22:53:01 -07:00
|
|
|
loadFile = mapM_ (\(name, ty, e) -> define name ty $ decl2check name e)
|
2021-03-26 22:58:45 -07:00
|
|
|
|
|
|
|
runTopLevel :: TopLevelAST -> AppM ()
|
|
|
|
runTopLevel = mapM_ runDeclOrExpr
|
|
|
|
|
|
|
|
runDeclOrExpr :: Either Declaration AST -> AppM ()
|
2021-03-29 22:53:01 -07:00
|
|
|
runDeclOrExpr (Left (name, ty, body)) = do
|
2021-03-18 14:40:04 -07:00
|
|
|
defs <- gets definitions
|
2021-03-29 22:53:01 -07:00
|
|
|
let expr = substitute defs $ decl2check name body
|
2021-03-26 14:55:23 -07:00
|
|
|
_ <- typecheckDecl ty name expr
|
2021-03-26 22:58:45 -07:00
|
|
|
define name ty expr
|
2021-03-18 14:40:04 -07:00
|
|
|
runDeclOrExpr (Right exprAST) = do
|
|
|
|
defs <- gets definitions
|
|
|
|
let expr = substitute defs $ ast2check exprAST
|
|
|
|
_ <- typecheckExpr expr
|
2021-03-26 22:58:45 -07:00
|
|
|
value <- execute expr
|
|
|
|
liftInput $ outputTextLn $ unparseEval value
|
2021-03-18 14:40:04 -07:00
|
|
|
pure ()
|
|
|
|
|
2021-03-26 22:58:45 -07:00
|
|
|
typecheckDecl :: Maybe Type -> Text -> CheckExpr -> AppM Scheme
|
|
|
|
typecheckDecl ty = typecheck ty . Just
|
|
|
|
|
|
|
|
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
|
|
|
|
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
|
|
|
|
|
|
|
|
prefix = case decl of
|
|
|
|
Just name -> name <> " : "
|
|
|
|
Nothing -> ": "
|
2021-03-18 14:40:04 -07:00
|
|
|
|
2021-03-26 22:58:45 -07:00
|
|
|
execute :: CheckExpr -> AppM EvalExpr
|
|
|
|
execute checkExpr = do
|
|
|
|
defs <- gets definitions
|
|
|
|
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
|
|
|
|
modify' \appState ->
|
|
|
|
let expr' = substitute (definitions appState) expr
|
|
|
|
in appState { definitions = HM.insert name expr' $ definitions appState }
|
|
|
|
|
|
|
|
modifyInterpreterOpts :: (InterpreterOpts -> InterpreterOpts) -> AppM ()
|
|
|
|
modifyInterpreterOpts f =
|
|
|
|
modify' \app -> app { interpreterOpts = f (interpreterOpts app) }
|
|
|
|
|
|
|
|
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 }
|
2021-03-18 14:40:04 -07:00
|
|
|
runCommand (Load filePath) = do
|
|
|
|
input <- safeReadFile
|
2021-03-26 22:58:45 -07:00
|
|
|
program <- liftParseError $ parse programParser filePath input
|
2021-03-18 14:40:04 -07:00
|
|
|
runProgram program
|
|
|
|
where
|
2021-03-26 22:58:45 -07:00
|
|
|
safeReadFile :: AppM Text
|
2021-03-18 14:40:04 -07:00
|
|
|
safeReadFile = liftEither =<< liftIO (
|
2021-03-26 22:58:45 -07:00
|
|
|
(Right <$> readFile filePath)
|
2021-03-18 14:40:04 -07:00
|
|
|
`catch` handleException)
|
|
|
|
|
|
|
|
handleException :: IOException -> IO (Either Text Text)
|
|
|
|
handleException = pure . Left . T.pack . show
|