perga/app/Repl.hs

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'