{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Minilang.REPL.Run where

import Control.Monad.Catch
import Data.Text hiding (replicate)
import Minilang.Lambda (loadProgram, evalInEnv)
import Minilang.Lambda.Eval (newEnv)
import Minilang.Lambda.Infer (extendContext, infer, newContext)
import qualified Minilang.Lambda.Infer as Infer
import Minilang.Lambda.Parser (AST (..), parse, parseProgram, resugar)
import Minilang.Lambda.Unify (Type (TyVar))
import Minilang.REPL.Types

-- | Run a REPL session
runREPL ::
  (MonadCatch m, MonadREPL m) => m ()
runREPL = go
  where
    go = do
      prompt
      raw <- input
      case raw of
        EOF -> output Bye
        In txt -> handleUserInput txt >> go
        Com cmd -> handleCommand cmd >> go

handleUserInput ::
  (MonadCatch m, MonadREPL m) =>
  Text ->
  m ()
handleUserInput txt = do
  repl@REPLEnv {language, env, context} <- getEnv
  case parse txt of
    Left err -> output (Msg $ pack $ show err)
    Right (Def ident body) -> do
      let v = evalInEnv env body
      case language of
        Typed ->
          case infer v of
            Left typeError -> output (Msg $ Infer.render typeError)
            Right typ -> do
              setEnv $
                repl
                  { env = (ident, v) : env,
                    context = extendContext ident typ context
                  }
              output (Defined ident typ)
        Untyped -> do
          setEnv $ repl {env = (ident, v) : env}
          output (Defined ident (TyVar "<?>"))
    Right expr -> do
      let v = evalInEnv env expr
          ast = resugar v
      case language of
        Typed ->
          case infer v of
            Left typeError -> output (Msg $ Infer.render typeError)
            Right typ -> do
              let
              output (Evaluated ast v typ)
        Untyped ->
          output (Evaluated ast v (TyVar "<?>"))

handleCommand ::
  (MonadCatch m, MonadREPL m) =>
  Command ->
  m ()
handleCommand ClearEnv = getEnv >>= \e -> setEnv (e {env = newEnv, context = newContext})
handleCommand DumpEnv =
  getEnv >>= \REPLEnv {..} ->
    output (CurrentEnv env context language)
handleCommand (Load (File file)) = do
  t <- load file
  case t of
    Left err -> output (Msg $ pack $ show err)
    Right prog -> loadProgramInEnv prog
handleCommand (Load (Data prog)) = loadProgramInEnv prog
handleCommand (Set (StepTypeChecker st)) = getEnv >>= \e -> setEnv (e {stepTypeCheck = st})
handleCommand (Set (DebugParser st)) = getEnv >>= \e -> setEnv (e {debugParser = st})
handleCommand (Set (SelectLanguage lang)) =
  getEnv >>= \e ->
    setEnv (e {language = lang})
      >> output (Msg $ "Language set to " <> pack (show lang))
handleCommand Help =
  output (Msg helpText)

loadProgramInEnv ::
  (MonadCatch m, MonadREPL m) =>
  Text ->
  m ()
loadProgramInEnv prog = do
  repl@REPLEnv {env, context, language} <- getEnv
  case parseProgram prog of
    Left err -> output (Msg $ pack $ show err)
    Right exprs -> do
      case loadProgram language env context exprs of
        Left typeError -> output (Msg $ pack $ show typeError)
        Right (results, env', context') -> do
          setEnv (repl {env = env', context = context'})
          mapM_ (\(term, typ) -> output (Evaluated (resugar term) term typ)) results