{-# 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.Resource (Resource, allocateEff)
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 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 $
        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, Resource :> es)
  => Eff (Repl p ms t : es) a
  -> Eff es a
runRepl action = do
  inputState <- snd <$> allocateEff inputStateAlloc inputStateDealloc
  evalStaticRep (Repl inputState) action
  where
    inputStateAlloc = do
      logMsg Info "Initializing input"
      liftIO $ initializeInput defaultSettings
    inputStateDealloc inputState = do
      logMsg Info "Cancelling input"
      liftIO $ cancelInput inputState