{-# LANGUAGE TypeFamilies #-}

module Hsm.Repl
  ( Repl
  , repl
  , runRepl
  ) where

import Control.Monad (forM_)
import Data.Typeable (Proxy(Proxy), Typeable, typeRep)
import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>), liftIO)
import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
import Effectful.Exception (bracket)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Generic.Data.Function.Common.Generic.Meta (KnownSymbols, symbolVals)
import Hsm.Log (Log, Severity(Attention, Info, Trace), logMsg)
import Language.Haskell.Interpreter (GhcError(errMsg), InterpreterError(WontCompile), as, interpret, runInterpreter, setImports)
import String.ANSI (blue)
import System.Console.Haskeline (defaultSettings, getInputLine, handleInterrupt, withInterrupt)
import System.Console.Haskeline.IO (InputState, cancelInput, initializeInput, queryInput)

data Repl (p :: Symbol) (ms :: [Symbol]) (t :: *) (a :: * -> *) (b :: *)

type instance DispatchOf (Repl p ms t) = Static WithSideEffects

newtype instance StaticRep (Repl p ms t) =
  Repl InputState

repl ::
     forall p ms t es. (KnownSymbol p, KnownSymbols ms, Log "repl" :> es, Repl p ms t :> es, Show t, Typeable t)
  => Eff es (Maybe t)
repl = query >>= maybe (return Nothing) parse
  where
    query = do
      Repl inputState <- getStaticRep
      logMsg Trace $ "Expecting a value of type: " <> show (typeRep $ Proxy @t)
      unsafeEff_ . queryInput inputState . handleInterrupt (return Nothing) . withInterrupt . getInputLine . blue $ symbolVal (Proxy @p)
    parse string = do
      logMsg Trace $ "Parsing string: " <> string
      eitherValue <-
        unsafeEff_ . runInterpreter $ do
          setImports $ symbolVals @ms
          interpret string as
      case eitherValue of
        Right value -> do
          logMsg Trace $ "Parsed value: " <> show value
          return $ Just value
        Left (WontCompile errors) -> do
          forM_ errors $ logMsg Attention . errMsg
          repl
        Left err -> do
          logMsg Attention $ show err
          repl

runRepl ::
     forall p ms t es a. (IOE :> es, Log "repl" :> es)
  => Eff (Repl p ms t : es) a
  -> Eff es a
runRepl action = bracket inputStateAlloc inputStateDealloc $ \inputState -> evalStaticRep (Repl inputState) action
  where
    inputStateAlloc = do
      logMsg Info "Initializing input"
      liftIO $ initializeInput defaultSettings
    inputStateDealloc inputState = do
      logMsg Info "Cancelling input"
      liftIO $ cancelInput inputState