{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC "-fno-warn-orphans" #-}
{-# LANGUAGE LambdaCase #-}

module Minilang.REPL.Haskeline where

import Control.Exception (throw)
import Control.Monad.Catch
import Control.Monad.Reader
import Control.Monad.State
import Data.Bifunctor
import Data.List
  ( isPrefixOf,
    isSuffixOf,
  )
import Data.Text (pack, unpack)
import Data.Text.IO as Text
import Minilang.REPL.Run (handleCommand)
import Minilang.REPL.Types
import System.Console.Haskeline
  ( Completion (Completion, replacement),
    CompletionFunc,
    InputT,
    getInputLineWithInitial,
    outputStrLn,
  )
import System.Directory (listDirectory)
import Minilang.Lambda.Parser (resugar, pretty)
import qualified Minilang.Lambda.Unify as Unify
import Minilang.REPL.Pure (render)

-- * Haskeline REPL

newtype Haskeline a = Haskeline {runHaskeline :: StateT REPLEnv (InputT IO) a}
  deriving (Functor, Applicative, Monad, MonadIO, MonadState REPLEnv)

hoist :: InputT IO a -> Haskeline a
hoist m = Haskeline $ StateT $ \s -> m >>= \a -> pure (a, s)

instance MonadREPL Haskeline where
  input = do
    i <- hoist (getInputLineWithInitial "λΠ> " ("", ""))
    case i of
      Nothing -> pure EOF
      Just (pack -> t) -> pure $ interpret t
  output = hoist . outputStrLn . unpack . render
  prompt = pure ()
  load = fmap (first FileError) . hoist . lift . try . Text.readFile . unpack

  getEnv = get
  setEnv = put

completion :: CompletionFunc IO
completion = completion' . first reverse

data CompleteWith
  = SetUnset String
  | LoadFile
  | AllCommands

completion' :: CompletionFunc IO
completion' (inputString, _) =
  case matchedCompletionRule inputString of
    SetUnset com : _ -> setUnsetCompletion com
    LoadFile : _ -> completeLoadWithFiles (drop 6 inputString)
    _ -> allCommandCompletions
  where
    matchedCompletionRule prefix =
      snd
        <$> filter
          (($ prefix) . fst)
          [ ((":set" `isPrefixOf`), SetUnset ":set"),
            ((":unset" `isPrefixOf`), SetUnset ":unset"),
            ((":load" `isPrefixOf`), LoadFile),
            (const True, AllCommands)
          ]

    completeLoadWithFiles prefix = do
      files <- filter (prefix `isPrefixOf`) . filter (".lisp" `isSuffixOf`) <$> listDirectory "."
      pure ("", fmap (\fp -> Completion (":load " <> fp) fp True) files)

    setUnsetCompletion com =
      pure
        ( "",
          filter
            ((inputString `isPrefixOf`) . replacement)
            [ Completion (com <> " step") "step - Step through evaluation process, displaying each rule application" True,
              Completion (com <> " debug") "debug - Debug parsing of input" True
            ]
        )

    allCommandCompletions =
      pure
        ( "",
          filter
            ((inputString `isPrefixOf`) . replacement)
            [ Completion ":quit" ":quit - Quit minilang REPL" False,
              Completion ":env" ":env - Dump current environment and context (types and values)" False,
              Completion ":clear" ":clear - Clear environment" False,
              Completion ":load" ":load - Load a file into the REPL" True,
              Completion ":set" ":set - Set some properties of the REPL" True,
              Completion ":unset" ":unset - Unset some properties of the REPL" True,
              Completion ":help" ":help - Provide help on commands" True
            ]
        )

instance MonadCatch Haskeline where
  Haskeline m `catch` f = Haskeline $ m `catch` \e -> runHaskeline (f e)

instance MonadThrow Haskeline where
  throwM = throw