62 lines
2.1 KiB
Haskell
62 lines
2.1 KiB
Haskell
module Repl (repl, showEnvEntry) where
|
|
|
|
import Data.Functor (void)
|
|
import Data.List (isPrefixOf)
|
|
import qualified Data.Map as M
|
|
import qualified Data.Text as T
|
|
import Eval
|
|
import Expr
|
|
import Parser
|
|
import System.Console.Haskeline
|
|
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
|
|
import System.FilePath ((</>))
|
|
|
|
data ReplCommand = Quit | DumpEnv | TypeQuery String | Input String deriving (Show)
|
|
|
|
parseCommand :: Maybe String -> Maybe ReplCommand
|
|
parseCommand Nothing = Nothing
|
|
parseCommand (Just ":q") = Just Quit
|
|
parseCommand (Just ":e") = Just DumpEnv
|
|
parseCommand (Just input)
|
|
| ":t" `isPrefixOf` input = case words input of
|
|
[":t", rest] -> Just $ TypeQuery rest
|
|
_ -> Nothing
|
|
| otherwise = Just $ Input input
|
|
|
|
showEnvEntry :: T.Text -> Expr -> String
|
|
showEnvEntry k v = T.unpack k ++ " : " ++ prettyS v
|
|
|
|
dumpEnv :: Env -> InputT IO ()
|
|
dumpEnv = void . M.traverseWithKey ((outputStrLn .) . showEnvEntry)
|
|
|
|
handleInput :: GlobalState -> String -> InputT IO GlobalState
|
|
handleInput env input =
|
|
let (res, env') = parseDefEmpty env (T.pack input)
|
|
in case res of
|
|
Left err -> outputStrLn err >> pure env'
|
|
Right () -> pure env'
|
|
|
|
repl :: IO GlobalState
|
|
repl = do
|
|
home <- getHomeDirectory
|
|
let basepath = home </> ".cache" </> "perga"
|
|
let filepath = basepath </> "history"
|
|
createDirectoryIfMissing True basepath
|
|
runInputT (defaultSettings{historyFile = Just filepath}) (loop GS{_defs = M.empty, _types = M.empty})
|
|
where
|
|
loop :: GlobalState -> InputT IO GlobalState
|
|
loop env = do
|
|
minput <- getInputLine "> "
|
|
case parseCommand minput of
|
|
Nothing -> pure env
|
|
Just Quit -> pure env
|
|
Just DumpEnv -> dumpEnv (_types env) >> loop env
|
|
Just (TypeQuery input) ->
|
|
( case M.lookup (T.pack input) (_types env) of
|
|
Nothing -> outputStrLn (input ++ " unbound")
|
|
Just expr -> outputStrLn $ prettyS expr
|
|
)
|
|
>> loop env
|
|
Just (Input input) -> do
|
|
env' <- handleInput env input
|
|
loop env'
|