{-# LANGUAGE TemplateHaskell #-}

-- | Command context typeclass
module CalamityCommands.Context (
  CommandContext (..),
  ConstructContext (..),
  constructContext,
  BasicContext (..),
  useBasicContext,
) where

import qualified Data.Text.Lazy as L
import GHC.Generics (Generic)
import qualified Polysemy as P

import CalamityCommands.Command

class CommandContext m c a | c -> m, c -> a where
  -- | The prefix that was used to invoke the command
  ctxPrefix :: c -> L.Text

  -- | The command that was invoked
  ctxCommand :: c -> Command m c a

  -- | The message remaining after consuming the prefix
  ctxUnparsedParams :: c -> L.Text

-- | An effect for constructing the context for a command
data ConstructContext msg ctx m' a' m a where
  -- | Construct a context for a command invokation, returning Just @context@ on
  -- success, or Nothing if a context could not be constructed
  ConstructContext ::
    -- | The (prefix, command, remaining)
    (L.Text, Command m' ctx a', L.Text) ->
    -- | The message type to extract the context from
    msg ->
    ConstructContext msg ctx m' a' m (Maybe ctx)

P.makeSem ''ConstructContext

-- | A basic context that only knows the prefix used and the unparsed input
data BasicContext m a = BasicContext
  { BasicContext m a -> Text
bcPrefix :: L.Text
  , BasicContext m a -> Command m (BasicContext m a) a
bcCommand :: Command m (BasicContext m a) a
  , BasicContext m a -> Text
bcUnparsedParams :: L.Text
  }
  deriving (Int -> BasicContext m a -> ShowS
[BasicContext m a] -> ShowS
BasicContext m a -> String
(Int -> BasicContext m a -> ShowS)
-> (BasicContext m a -> String)
-> ([BasicContext m a] -> ShowS)
-> Show (BasicContext m a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: * -> *) a. Int -> BasicContext m a -> ShowS
forall (m :: * -> *) a. [BasicContext m a] -> ShowS
forall (m :: * -> *) a. BasicContext m a -> String
showList :: [BasicContext m a] -> ShowS
$cshowList :: forall (m :: * -> *) a. [BasicContext m a] -> ShowS
show :: BasicContext m a -> String
$cshow :: forall (m :: * -> *) a. BasicContext m a -> String
showsPrec :: Int -> BasicContext m a -> ShowS
$cshowsPrec :: forall (m :: * -> *) a. Int -> BasicContext m a -> ShowS
Show, (forall x. BasicContext m a -> Rep (BasicContext m a) x)
-> (forall x. Rep (BasicContext m a) x -> BasicContext m a)
-> Generic (BasicContext m a)
forall x. Rep (BasicContext m a) x -> BasicContext m a
forall x. BasicContext m a -> Rep (BasicContext m a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) a x.
Rep (BasicContext m a) x -> BasicContext m a
forall (m :: * -> *) a x.
BasicContext m a -> Rep (BasicContext m a) x
$cto :: forall (m :: * -> *) a x.
Rep (BasicContext m a) x -> BasicContext m a
$cfrom :: forall (m :: * -> *) a x.
BasicContext m a -> Rep (BasicContext m a) x
Generic)

instance CommandContext m (BasicContext m a) a where
  ctxPrefix :: BasicContext m a -> Text
ctxPrefix = BasicContext m a -> Text
forall (m :: * -> *) a. BasicContext m a -> Text
bcPrefix
  ctxCommand :: BasicContext m a -> Command m (BasicContext m a) a
ctxCommand = BasicContext m a -> Command m (BasicContext m a) a
forall (m :: * -> *) a.
BasicContext m a -> Command m (BasicContext m a) a
bcCommand
  ctxUnparsedParams :: BasicContext m a -> Text
ctxUnparsedParams = BasicContext m a -> Text
forall (m :: * -> *) a. BasicContext m a -> Text
bcUnparsedParams

-- | A default interpretation for 'ConstructContext' that constructs a BasicContext
useBasicContext :: P.Sem (ConstructContext msg (BasicContext m a') m a' ': r) a -> P.Sem r a
useBasicContext :: Sem (ConstructContext msg (BasicContext m a') m a' : r) a
-> Sem r a
useBasicContext =
  (forall (rInitial :: EffectRow) x.
 ConstructContext msg (BasicContext m a') m a' (Sem rInitial) x
 -> Sem r x)
-> Sem (ConstructContext msg (BasicContext m a') m a' : r) a
-> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret
    ( \case
        ConstructContext (pre, cmd, up) _ -> Maybe (BasicContext m a') -> Sem r (Maybe (BasicContext m a'))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (BasicContext m a') -> Sem r (Maybe (BasicContext m a')))
-> (BasicContext m a' -> Maybe (BasicContext m a'))
-> BasicContext m a'
-> Sem r (Maybe (BasicContext m a'))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BasicContext m a' -> Maybe (BasicContext m a')
forall a. a -> Maybe a
Just (BasicContext m a' -> Sem r (Maybe (BasicContext m a')))
-> BasicContext m a' -> Sem r (Maybe (BasicContext m a'))
forall a b. (a -> b) -> a -> b
$ Text
-> Command m (BasicContext m a') a' -> Text -> BasicContext m a'
forall (m :: * -> *) a.
Text -> Command m (BasicContext m a) a -> Text -> BasicContext m a
BasicContext Text
pre Command m (BasicContext m a') a'
cmd Text
up
    )