calamity-commands-0.2.0.0: CalamityCommands/CommandUtils.hs

-- | Command utilities
module CalamityCommands.CommandUtils (
  TypedCommandC,
  CommandForParsers,
  buildCommand,
  buildCommand',
  buildParser,
  buildCallback,
  runCommand,
  invokeCommand,
  groupPath,
  commandPath,
  commandParams,
) where

import CalamityCommands.Check
import CalamityCommands.Command
import CalamityCommands.Context
import CalamityCommands.Error
import CalamityCommands.Group
import CalamityCommands.Internal.RunIntoM
import CalamityCommands.Internal.Utils
import CalamityCommands.ParameterInfo
import CalamityCommands.Parser

import Control.Lens hiding (Context, (<.>))
import Control.Monad

import Data.Foldable
import Data.Kind
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import qualified Data.Text as S

import qualified Polysemy as P
import qualified Polysemy.Error as P
import qualified Polysemy.Fail as P

groupPath :: Group m c a -> [S.Text]
groupPath Group{names, parent} = foldMap groupPath parent <> [NE.head names]

commandPath :: Command m c a -> [S.Text]
commandPath Command{names, parent} = foldMap groupPath parent <> [NE.head names]

-- | Format a command's parameters
commandParams :: Command m c a -> S.Text
commandParams Command{params} =
  let formatted =
        map
          ( \(ParameterInfo (fromMaybe "" -> name) type_ _) ->
              "`" <> name <> ":" <> S.pack (show type_) <> "`"
          )
          params
   in S.intercalate ", " formatted

{- | Given the properties of a 'Command' with the @parser@ and @callback@ in the
 'P.Sem' monad, build a command by transforming the Polysemy actions into @m@
 actions.
-}
buildCommand' ::
  forall c m a p r.
  (Monad m, P.Member (P.Final m) r) =>
  -- | The name (and aliases) of the command
  NonEmpty S.Text ->
  -- | The parent group of the command
  Maybe (Group m c a) ->
  -- | If the command is hidden
  Bool ->
  -- | The checks for the command
  [Check m c] ->
  -- | The command's parameter metadata
  [ParameterInfo] ->
  -- | The help generator for this command
  (c -> S.Text) ->
  -- | The parser for this command
  (c -> P.Sem r (Either CommandError p)) ->
  -- | The callback for this command
  ((c, p) -> P.Sem (P.Fail ': r) a) ->
  P.Sem r (Command m c a)
buildCommand' names@(name :| _) parent hidden checks params help parser cb = do
  cb' <- buildCallback cb
  parser' <- buildParser name parser
  pure $ Command names parent hidden checks params help parser' cb'

{- | Given the properties of a 'Command', a callback, and a type level list of
 the parameters, build a command by constructing a parser and wiring it up to
 the callback.

 ==== Examples

 Building a command that adds two numbers.

 @
 'buildCommand' \@\'['CalamityCommands.Parser.Named' "a" 'Int', 'CalamityCommands.Parser.Named' "b" 'Int']
    "add" 'Nothing' [] ('const' "Add two integers") $ \\ctx a b ->
      'pure' '$' 'Right' (a '+' b)
 @
-}
buildCommand ::
  forall ps c m a r.
  (Monad m, P.Member (P.Final m) r, TypedCommandC ps c a r, CommandContext m c a) =>
  -- | The name (and aliases) of the command
  NonEmpty S.Text ->
  -- | The parent group of the command
  Maybe (Group m c a) ->
  -- | If the command is hidden
  Bool ->
  -- | The checks for the command
  [Check m c] ->
  -- | The help generator for this command
  (c -> S.Text) ->
  -- | The callback foor this command
  (c -> CommandForParsers ps r a) ->
  P.Sem r (Command m c a)
buildCommand names parent hidden checks help command =
  let (parser, cb) = buildTypedCommand @ps command
   in buildCommand' names parent hidden checks (parameterInfos @ps @c @r) help parser cb

{- | Given the name of the command the parser is for and a parser function in
 the 'P.Sem' monad, build a parser by transforming the Polysemy action into an
 @m@ action.
-}
buildParser ::
  (Monad m, P.Member (P.Final m) r) =>
  S.Text ->
  (c -> P.Sem r (Either CommandError a)) ->
  P.Sem r (c -> m (Either CommandError a))
buildParser name cb = do
  cb' <- bindSemToM cb
  let cb'' ctx = fromMaybe (Left $ ParseError ("Parser for command: " <> name) "failed internally") <$> cb' ctx
  pure cb''

{- | Given a callback for a command in the 'P.Sem' monad, build a command callback by
 transforming the Polysemy action into an @m@ action.
-}
buildCallback ::
  (Monad m, P.Member (P.Final m) r) => ((c, p) -> P.Sem (P.Fail ': r) a) -> P.Sem r ((c, p) -> m (Either S.Text a))
buildCallback cb = do
  cb' <- bindSemToM (\x -> P.runFail (cb x) <&> mapLeft S.pack)
  let cb'' = fromMaybe (Left "failed internally") <.> cb'
  pure cb''

-- | Given an invokation Context @c@, run a command. This does not perform the command's checks.
runCommand :: (Monad m, P.Member (P.Embed m) r) => c -> Command m c a -> P.Sem r (Either CommandError a)
runCommand ctx Command{names = name :| _, parser, callback} =
  P.embed (parser ctx) >>= \case
    Left e -> pure $ Left e
    Right p' -> P.embed (callback (ctx, p')) <&> mapLeft (InvokeError name)

{- | Given an invokation Context @c@, first run all of the command's checks, then
 run the command if they all pass.
-}
invokeCommand :: (Monad m, P.Member (P.Embed m) r) => c -> Command m c a -> P.Sem r (Either CommandError a)
invokeCommand ctx cmd@Command{checks} = P.runError $ do
  for_ checks (P.fromEither <=< runCheck ctx)
  P.fromEither =<< runCommand ctx cmd

type CommandSemType r a = P.Sem (P.Fail ': r) a

-- | Some constraints used for making parameter typed commands work
type TypedCommandC ps c a r =
  ( ApplyTupRes (ParserResult (ListToTup ps)) (CommandSemType r a) ~ CommandForParsers ps r a
  , ParameterParser (ListToTup ps) c r
  , ApplyTup (ParserResult (ListToTup ps)) (CommandSemType r a)
  , ParameterInfoForParsers ps c r
  )

buildTypedCommand ::
  forall (ps :: [Type]) c m a p r.
  (TypedCommandC ps c a r, p ~ ParserResult (ListToTup ps), CommandContext m c a) =>
  (c -> CommandForParsers ps r a) ->
  ( c -> P.Sem r (Either CommandError p)
  , (c, p) -> P.Sem (P.Fail ': r) a
  )
buildTypedCommand cmd =
  let parser ctx = buildTypedCommandParser @ps ctx (ctxUnparsedParams @m ctx)
      consumer (ctx, r) = applyTup (cmd ctx) r
   in (parser, consumer)

class ParameterInfoForParsers (ps :: [Type]) c r where
  parameterInfos :: [ParameterInfo]

instance ParameterInfoForParsers '[] c r where
  parameterInfos = []

instance (ParameterParser x c r, ParameterInfoForParsers xs c r) => ParameterInfoForParsers (x : xs) c r where
  parameterInfos = parameterInfo @x @c @r : parameterInfos @xs @c @r

class ApplyTup a b where
  type ApplyTupRes a b

  applyTup :: ApplyTupRes a b -> a -> b

instance ApplyTup as b => ApplyTup (a, as) b where
  type ApplyTupRes (a, as) b = a -> ApplyTupRes as b

  applyTup f (a, as) = applyTup (f a) as

instance ApplyTup () b where
  type ApplyTupRes () b = b

  applyTup r () = r

buildTypedCommandParser ::
  forall (ps :: [Type]) c r.
  ParameterParser (ListToTup ps) c r =>
  c ->
  S.Text ->
  P.Sem r (Either CommandError (ParserResult (ListToTup ps)))
buildTypedCommandParser ctx t =
  runCommandParser ctx t (parse @(ListToTup ps) @c @r) <&> \case
    Right r -> Right r
    Left (n, e) -> Left $ ParseError n e

type family ListToTup (ps :: [Type]) where
  ListToTup '[] = ()
  ListToTup (x ': xs) = (x, ListToTup xs)

{- | Transform a type level list of types implementing the 'ParameterParser' typeclass into
 the type a command callback matching those parameters should be.

 As an example:

 @
 'CommandForParsers' [ 'S.Text', 'Int', 'CalamityCommands.Parser.Named' "something" 'S.Text' ] r a ~
   ('S.Text' -> 'Int' -> 'S.Text' -> 'P.Sem' r ('P.Fail' ': r) a)
 @
-}
type family CommandForParsers (ps :: [Type]) r a where
  CommandForParsers '[] r a = P.Sem (P.Fail ': r) a
  CommandForParsers (x ': xs) r a = ParserResult x -> CommandForParsers xs r a