perga/app/Repl.hs

module Repl (repl, showEnvEntry) where

import Check (findType)
import Data.List (stripPrefix)
import qualified Data.Map.Strict as M
import Data.Text (pack)
import Elaborator
import Errors (Result)
import Eval
import Expr
import Parser
import Program
import System.Console.Haskeline
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
import System.FilePath ((</>))

data ReplCommand
    = Quit
    | DumpEnv
    | TypeQuery String
    | ValueQuery String
    | Normalize String
    | WeakNormalize String
    | Input String
    | LoadFile 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
    | ":v " `isPrefixOf` input = ValueQuery <$> stripPrefix ":v " input
    | ":n " `isPrefixOf` input = Normalize <$> stripPrefix ":n " input
    | ":w " `isPrefixOf` input = WeakNormalize <$> stripPrefix ":w " input
    | ":l " `isPrefixOf` input = LoadFile <$> stripPrefix ":l " input
    | otherwise = Just $ Input input

handleInput :: Env -> String -> InputT IO Env
handleInput env input =
    case parseDef "repl" (pack input) of
        Left err -> outputStrLn err >> pure env
        Right irDef -> case evalDef env irDef of
            Left err -> outputStrLn (toString err) >> pure env
            Right env' -> pure env'

actOnParse :: String -> (Expr -> InputT IO ()) -> InputT IO ()
actOnParse input action = case parseExpr "repl" (pack input) of
    Left err -> outputStrLn err
    Right expr -> action $ elaborate expr

printErrorOrResult :: Env -> (Expr -> ReaderT Env Result Expr) -> Expr -> InputT IO ()
printErrorOrResult env action expr = putTextLn $ either toText pretty $ runReaderT (action expr) env

parseActPrint :: Env -> String -> (Expr -> ReaderT Env Result Expr) -> InputT IO ()
parseActPrint env input action = actOnParse input (printErrorOrResult env action)

lookupAct :: Env -> String -> (Definition -> InputT IO ()) -> InputT IO ()
lookupAct env input action = maybe (outputStrLn $ "'" ++ input ++ "' unbound") action $ M.lookup (pack input) 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 -> lift (dumpEnv env) >> loop env
            Just (TypeQuery input) -> parseActPrint env input (findType []) >> loop env
            Just (ValueQuery input) -> lookupAct env input (putTextLn . pretty . _val) >> loop env
            Just (Normalize input) -> parseActPrint env input normalize >> loop env
            Just (WeakNormalize input) -> parseActPrint env input whnf >> loop env
            Just (LoadFile filename) -> lift (runExceptT $ handleAndParseFile env filename) >>= either ((>> loop env) . outputStrLn) loop
            Just (Input input) -> handleInput env input >>= loop