{-# 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