calamity-commands-0.4.1.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.Monad
import Data.Foldable
import Data.Kind
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Maybe
import Data.Text qualified as S
import Optics
import Polysemy qualified as P
import Polysemy.Error qualified as P
import Polysemy.Fail qualified 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