perga/app/Repl.hs

module Repl (repl, showEnvEntry) where

import Control.Monad.Reader
import Data.Functor (void)
import Data.List (isPrefixOf, stripPrefix)
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 | Normalize 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 = TypeQuery <$> stripPrefix ":t " input
    | ":n " `isPrefixOf` input = Normalize <$> stripPrefix ":n " input
    | otherwise = Just $ Input input

showEnvEntry :: T.Text -> EnvLine -> String
showEnvEntry k EL{_ty = t} = T.unpack k ++ " : " ++ prettyS t

dumpEnv :: Env -> InputT IO ()
dumpEnv = void . M.traverseWithKey ((outputStrLn .) . showEnvEntry)

handleInput :: Env -> String -> InputT IO Env
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 Env
repl = do
    home <- getHomeDirectory
    let basepath = home </> ".cache" </> "perga"
    let filepath = basepath </> "history"
    createDirectoryIfMissing True basepath
    runInputT (defaultSettings{historyFile = Just filepath}) (loop M.empty)
  where
    loop :: Env -> InputT IO Env
    loop env = do
        minput <- getInputLine "> "
        case parseCommand minput of
            Nothing -> pure env
            Just Quit -> pure env
            Just DumpEnv -> dumpEnv env >> loop env
            Just (TypeQuery input) ->
                ( case M.lookup (T.pack input) env of
                    Nothing -> outputStrLn (input ++ " unbound")
                    Just (EL{_ty = t}) -> outputStrLn $ prettyS t
                )
                    >> loop env
            Just (Normalize input) ->
                ( case parseExpr env (T.pack input) of
                    Left err -> outputStrLn err
                    Right expr -> case runReaderT (normalize expr) env of
                        Left err -> outputStrLn $ show err
                        Right result -> outputStrLn $ prettyS result
                )
                    >> loop env
            Just (Input input) -> do
                env' <- handleInput env input
                loop env'