expresso-0.1.2.3: src/Repl.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-- |
-- Module : Main
-- Copyright : (c) Tim Williams 2017-2019
-- License : BSD3
--
-- Maintainer : info@timphilipwilliams.com
-- Stability : experimental
-- Portability : portable
--
-- Expresso Read-Eval-Print-Loop.
--
module Main where
import Control.Applicative
-- import Control.Monad (forM_)
import Control.Monad.Except
import Control.Monad.State.Strict
import Data.Char
import Data.Version
import System.Console.Haskeline (InputT)
import System.Console.Haskeline.MonadException ()
import System.Directory
import System.FilePath
import Text.Parsec.String (Parser)
import qualified System.Console.Haskeline as HL
import qualified Text.Parsec as P
import Expresso
import Expresso.Parser ( pExp, pLetDecl, pSynonymDecl, topLevel
, reserved, reservedOp, stringLiteral
)
import Expresso.Utils
import Paths_expresso
ps1 :: String
ps1 = "λ"
data Mode = SingleLine | MultiLine | Quitting
data ReplState = ReplState
{ stateMode :: Mode
, stateBuffer :: [String]
, stateEnv :: Environments
, stateLibDirs :: [FilePath]
}
data Command
= Peek ExpI
| Type ExpI
| Load FilePath
| ChangeCWD FilePath
| BeginMulti
| Reset
| DumpEnv
| Quit
| Help
data Line
= Command Command
| Term ExpI
| Decl (Bind Name) (Maybe Type) ExpI
| TypeDecl SynonymDecl
| NoOp
type Repl = InputT (StateT ReplState IO)
main :: IO ()
main = do
preludePath <- liftIO $ getDataFileName "Prelude.x"
currentDir <- liftIO getCurrentDirectory
let libDirs = [takeDirectory preludePath, currentDir]
runRepl libDirs $ do
mapM_ spew
[ unwords ["Expresso", showVersion version, "REPL"]
, "Type :help or :h for a list of commands"
]
HL.catch
(loadPrelude preludePath)
(\(e :: HL.SomeException) ->
spew $ "Warning: Couldn't open " ++ preludePath ++ ": " ++ show e)
repl
-- | The read-eval-print-loop
repl :: Repl ()
repl = step repl
`HL.catch` (\(e :: HL.SomeException) -> spew (show e) >> repl)
where
step :: Repl () -> Repl ()
step cont = HL.withInterrupt $ do
mode <- lift $ gets stateMode
case mode of
MultiLine -> do
minput <- HL.getInputLine $ ps1 ++ "| "
whenJust minput $ \input ->
if isEndMulti input
then doEndMulti
else lift $ modify (addToBuffer input)
cont
SingleLine -> do
minput <- HL.getInputLine $ ps1 ++ "> "
whenJust minput process
cont
Quitting -> do
spew "Goodbye."
return ()
process :: String -> Repl ()
process str = do
case parseLine str of
Left err -> spew err
Right (Command c) -> doCommand c
Right (Term e) -> doEval showValue' e
Right (Decl b mty e) -> doDecl b mty e
Right (TypeDecl syn) -> doTypeDecl syn
Right NoOp -> return ()
`HL.catch` handler
where
handler :: HL.SomeException -> Repl ()
handler ex = spew $ "Caught exception: " ++ show ex
runRepl :: [FilePath] -> Repl a -> IO a
runRepl libDirs m = do
historyFile <- (</> ".expresso_history") <$> getHomeDirectory
let settings = HL.defaultSettings {HL.historyFile = Just historyFile}
evalStateT (HL.runInputT settings m) (emptyReplState libDirs)
emptyReplState :: [FilePath] -> ReplState
emptyReplState libDirs = ReplState
{ stateMode = SingleLine
, stateBuffer = mempty
, stateEnv = setLibDirs libDirs initEnvironments
, stateLibDirs = libDirs
}
loadPrelude :: FilePath -> Repl ()
loadPrelude path = do
spew $ "Loading Prelude from " ++ path
doLoad path
doCommand :: Command -> Repl ()
doCommand c = case c of
Peek e -> doEval (return . showValue) e
Type e -> doTypeOf e
Load path -> doLoad path
ChangeCWD path -> liftIO $ setCurrentDirectory path
Quit -> lift $ modify (setMode Quitting)
BeginMulti -> lift $ modify (setMode MultiLine)
Reset -> doReset
DumpEnv -> doDumpEnv
Help -> mapM_ spew
[ "REPL commands available from the prompt:"
, ""
, "<expression> evaluate an expression"
, ":peek <expression> evaluate, but not deeply"
, ":load <filename> import record expression as a module"
, ":{\\n ..lines.. \\n:}\\n multiline command"
, ":cd <path> change current working directory"
, ":type <term> show the type of <term>"
, ":reset reset REPL, unloading all definitions"
, ":env dump bound symbols in the environment"
, ":quit exit REPL"
, ":help display this list of commands"
, ""
]
doEval :: (Value -> IO String) -> ExpI -> Repl ()
doEval pp e = do
envs <- lift $ gets stateEnv
v'e <- liftIO $ evalWithEnv envs e
case v'e of
Left err -> spew err
Right val -> liftIO (pp val) >>= spew
doLoad :: FilePath -> Repl ()
doLoad path =
doDecl RecWildcard Nothing
$ Fix (InR (K (Import path)) :*: K dummyPos)
doDecl :: Bind Name -> Maybe Type -> ExpI -> Repl ()
doDecl b mty e = do
envs <- lift $ gets stateEnv
envs'e <- liftIO $ runEvalM $ bind envs b mty e
case envs'e of
Left err -> spew err
Right envs' -> lift $ modify (setEnv envs')
doTypeDecl :: SynonymDecl -> Repl ()
doTypeDecl syn = do
envs <- lift $ gets stateEnv
let envs'e = runExcept
. installSynonyms [syn]
. uninstallSynonym syn
$ envs
case envs'e of
Left err -> spew err
Right envs' -> lift $ modify (setEnv envs')
doTypeOf :: ExpI -> Repl ()
doTypeOf e = do
envs <- lift $ gets stateEnv
ms <- liftIO $ typeOfWithEnv envs e
case ms of
Left err -> spew err
Right sigma -> spew (showType sigma)
doReset :: Repl ()
doReset = lift $ do
libDirs <- gets stateLibDirs
modify (setEnv $ setLibDirs libDirs initEnvironments)
doDumpEnv :: Repl ()
doDumpEnv = do
envs <- lift $ gets stateEnv
forM_ (dumpTypeEnv envs) $ \(name, sigma) ->
spew $ name ++ " : " ++ showType sigma
parseLine :: String -> Either String Line
parseLine str
| all isSpace str = return NoOp
| otherwise = showError $ P.parse (topLevel pLine) "<interactive>" str
pLine :: Parser Line
pLine = pCommand <|> P.try pTerm <|> pDecl <|> pTypeDecl
pTerm :: Parser Line
pTerm = Term <$> pExp
pDecl :: Parser Line
pDecl = (\(b, mt, e) -> Decl b mt e)
<$> (reserved "let" *> pLetDecl)
pTypeDecl :: Parser Line
pTypeDecl = TypeDecl <$> pSynonymDecl
pCommand :: Parser Line
pCommand = Command <$> (reservedOp ":" *> p)
where
p = (reserved "peek" <|> reserved "p") *> (Peek <$> pExp)
<|> (reserved "type" <|> reserved "t") *> (Type <$> pExp)
<|> (reserved "load" <|> reserved "l") *> (Load <$> pFilePath)
<|> reserved "cd" *> (ChangeCWD <$> pFilePath)
<|> (reserved "reset" <|> reserved "r") *> pure Reset
<|> (reserved "env" <|> reserved "e") *> pure DumpEnv
<|> (reserved "quit" <|> reserved "q") *> pure Quit
<|> (reserved "help"
<|> reserved "h" <|> reserved "?") *> pure Help
<|> reserved "{" *> pure BeginMulti
pFilePath :: Parser FilePath
pFilePath = stringLiteral -- TODO
setMode :: Mode -> ReplState -> ReplState
setMode m s = s { stateMode = m }
setEnv :: Environments -> ReplState -> ReplState
setEnv envs s = s { stateEnv = envs }
addToBuffer :: String -> ReplState -> ReplState
addToBuffer str s = s { stateBuffer = stateBuffer s ++ [str] }
doEndMulti :: Repl ()
doEndMulti = do
str <- lift $ gets (unlines . stateBuffer)
lift $ modify $ clearBuffer . setMode SingleLine
process str
clearBuffer :: ReplState -> ReplState
clearBuffer s = s { stateBuffer = mempty }
isEndMulti :: String -> Bool
isEndMulti ":}" = True
isEndMulti _ = False
spew :: String -> Repl ()
spew = HL.outputStrLn
whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
whenJust mg f = maybe (pure ()) f mg