tricu/src/REPL.hs

module REPL where

import Eval
import FileEval
import Lexer
import Parser
import Research

import Control.Exception         (SomeException, catch)
import Control.Monad.IO.Class    (liftIO)
import Control.Monad.Catch       (handle, MonadCatch)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Data.Char                 (isSpace)
import Data.List                 ( dropWhile
                                 , dropWhileEnd
                                 , isPrefixOf)
import System.Console.Haskeline

import qualified Data.Map as Map

repl :: Env -> IO ()
repl env = runInputT settings (withInterrupt (loop env True))
  where
    settings :: Settings IO
    settings = Settings
      { complete = completeWord Nothing " \t" completeCommands
      , historyFile = Just ".tricu_history"
      , autoAddHistory = True
      }

    completeCommands :: String -> IO [Completion]
    completeCommands str = return $ map simpleCompletion $
      filter (str `isPrefixOf`) commands
      where
        commands = ["!exit", "!decode", "!definitions", "!import"]

    loop :: Env -> Bool -> InputT IO ()
    loop env decode = handle (interruptHandler env decode) $ do
      minput <- getInputLine "tricu < "
      case minput of
        Nothing -> outputStrLn "Exiting tricu"
        Just s
          | strip s == "" -> loop env decode
          | strip s == "!exit" -> outputStrLn "Exiting tricu"
          | strip s == "!decode" -> do
              outputStrLn $ "Decoding " ++ (if decode then "disabled" else "enabled")
              loop env (not decode)
          | strip s == "!definitions" -> do
              let defs = Map.keys $ Map.delete "!result" env
              if null defs
                then outputStrLn "No definitions discovered."
                else do
                  outputStrLn "Available definitions:"
                  mapM_ outputStrLn defs
              loop env decode
          | "!import" `isPrefixOf` strip s -> handleImport env decode
          | take 2 s == "--" -> loop env decode
          | otherwise -> do
              newEnv <- liftIO $ processInput env s decode `catch` errorHandler env
              loop newEnv decode

    handleImport :: Env -> Bool -> InputT IO ()
    handleImport env decode = do
      result <- runMaybeT $ do
        let fileSettings = setComplete completeFilename defaultSettings
        path <- MaybeT $ runInputT fileSettings $
          getInputLineWithInitial "File path to load < " ("", "")

        contents <- liftIO $ readFile (strip path)

        if | Left err <- parseProgram (lexTricu contents) -> do
               lift $ outputStrLn $ "Parse error: " ++ handleParseError err
               MaybeT $ return Nothing
           | Right ast <- parseProgram (lexTricu contents) -> do
               ns <- MaybeT $ runInputT defaultSettings $
                 getInputLineWithInitial "Namespace (or !Local for no namespace) < " ("", "")

               processedAst <- liftIO $ preprocessFile (strip path)
               let namespacedAst | strip ns == "!Local" = processedAst
                                | otherwise = nsDefinitions (strip ns) processedAst
                   loadedEnv = evalTricu env namespacedAst
               return loadedEnv

      if | Nothing <- result -> do
             outputStrLn "Import cancelled."
             loop env decode
         | Just loadedEnv <- result ->
             loop (Map.delete "!result" loadedEnv) decode

    interruptHandler :: Env -> Bool -> Interrupt -> InputT IO ()
    interruptHandler env decode _ = do
      outputStrLn "Interrupted with CTRL+C\n\
                  \You can use the !exit command or CTRL+D to exit"
      loop env decode

    processInput :: Env -> String -> Bool -> IO Env
    processInput env input decode = do
      let asts   = parseTricu input
          newEnv = evalTricu env asts
      case Map.lookup "!result" newEnv of
        Just r -> do
          putStrLn $ "tricu > " ++
            if decode
              then decodeResult r
              else show r
        Nothing -> pure ()
      return newEnv

    errorHandler :: Env -> SomeException -> IO (Env)
    errorHandler env e = do
      putStrLn $ "Error: " ++ show e
      return env

    strip :: String -> String
    strip = dropWhileEnd isSpace . dropWhile isSpace