{-# LANGUAGE RecursiveDo #-}

-- | A DSL for generating commands and groups
module Calamity.Commands.Dsl
    ( command'
    , command
    , help
    , requires
    , requires'
    , requiresPure
    , group
    , group'
    , DSLState
    , raiseDSL ) where

import           Calamity.Commands.Check
import           Calamity.Commands.Command     hiding ( help )
import           Calamity.Commands.CommandUtils
import           Calamity.Commands.Context     hiding ( command )
import           Calamity.Commands.Error
import           Calamity.Commands.Group       hiding ( help )
import           Calamity.Commands.Handler
import           Calamity.Internal.LocalWriter

import qualified Data.HashMap.Lazy             as LH
import qualified Data.Text                     as S
import qualified Data.Text.Lazy                as L

import qualified Polysemy                      as P
import qualified Polysemy.Fail                 as P
import qualified Polysemy.Tagged               as P
import qualified Polysemy.Fixpoint             as P
import qualified Polysemy.Reader               as P

type DSLState r = (LocalWriter (LH.HashMap S.Text Command) ':
                       LocalWriter (LH.HashMap S.Text Group) ':
                       P.Reader (Maybe Group) ':
                       P.Reader (Context -> L.Text) ':
                       P.Tagged "original-help" (P.Reader (Context -> L.Text)) ':
                       P.Reader [Check] ':
                       P.Reader CommandHandler ':
                       P.Fixpoint ': r)

raiseDSL :: P.Sem r a -> P.Sem (DSLState r) a
raiseDSL :: Sem r a -> Sem (DSLState r) a
raiseDSL = Sem
  (LocalWriter (HashMap Text Group)
     : Reader (Maybe Group) : Reader (Context -> Text)
     : Tagged "original-help" (Reader (Context -> Text))
     : Reader [Check] : Reader CommandHandler : Fixpoint : r)
  a
-> Sem (DSLState r) a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise (Sem
   (LocalWriter (HashMap Text Group)
      : Reader (Maybe Group) : Reader (Context -> Text)
      : Tagged "original-help" (Reader (Context -> Text))
      : Reader [Check] : Reader CommandHandler : Fixpoint : r)
   a
 -> Sem (DSLState r) a)
-> (Sem r a
    -> Sem
         (LocalWriter (HashMap Text Group)
            : Reader (Maybe Group) : Reader (Context -> Text)
            : Tagged "original-help" (Reader (Context -> Text))
            : Reader [Check] : Reader CommandHandler : Fixpoint : r)
         a)
-> Sem r a
-> Sem (DSLState r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem
  (Reader (Maybe Group)
     : Reader (Context -> Text)
     : Tagged "original-help" (Reader (Context -> Text))
     : Reader [Check] : Reader CommandHandler : Fixpoint : r)
  a
-> Sem
     (LocalWriter (HashMap Text Group)
        : Reader (Maybe Group) : Reader (Context -> Text)
        : Tagged "original-help" (Reader (Context -> Text))
        : Reader [Check] : Reader CommandHandler : Fixpoint : r)
     a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise (Sem
   (Reader (Maybe Group)
      : Reader (Context -> Text)
      : Tagged "original-help" (Reader (Context -> Text))
      : Reader [Check] : Reader CommandHandler : Fixpoint : r)
   a
 -> Sem
      (LocalWriter (HashMap Text Group)
         : Reader (Maybe Group) : Reader (Context -> Text)
         : Tagged "original-help" (Reader (Context -> Text))
         : Reader [Check] : Reader CommandHandler : Fixpoint : r)
      a)
-> (Sem r a
    -> Sem
         (Reader (Maybe Group)
            : Reader (Context -> Text)
            : Tagged "original-help" (Reader (Context -> Text))
            : Reader [Check] : Reader CommandHandler : Fixpoint : r)
         a)
-> Sem r a
-> Sem
     (LocalWriter (HashMap Text Group)
        : Reader (Maybe Group) : Reader (Context -> Text)
        : Tagged "original-help" (Reader (Context -> Text))
        : Reader [Check] : Reader CommandHandler : Fixpoint : r)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem
  (Reader (Context -> Text)
     : Tagged "original-help" (Reader (Context -> Text))
     : Reader [Check] : Reader CommandHandler : Fixpoint : r)
  a
-> Sem
     (Reader (Maybe Group)
        : Reader (Context -> Text)
        : Tagged "original-help" (Reader (Context -> Text))
        : Reader [Check] : Reader CommandHandler : Fixpoint : r)
     a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise (Sem
   (Reader (Context -> Text)
      : Tagged "original-help" (Reader (Context -> Text))
      : Reader [Check] : Reader CommandHandler : Fixpoint : r)
   a
 -> Sem
      (Reader (Maybe Group)
         : Reader (Context -> Text)
         : Tagged "original-help" (Reader (Context -> Text))
         : Reader [Check] : Reader CommandHandler : Fixpoint : r)
      a)
-> (Sem r a
    -> Sem
         (Reader (Context -> Text)
            : Tagged "original-help" (Reader (Context -> Text))
            : Reader [Check] : Reader CommandHandler : Fixpoint : r)
         a)
-> Sem r a
-> Sem
     (Reader (Maybe Group)
        : Reader (Context -> Text)
        : Tagged "original-help" (Reader (Context -> Text))
        : Reader [Check] : Reader CommandHandler : Fixpoint : r)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem
  (Tagged "original-help" (Reader (Context -> Text))
     : Reader [Check] : Reader CommandHandler : Fixpoint : r)
  a
-> Sem
     (Reader (Context -> Text)
        : Tagged "original-help" (Reader (Context -> Text))
        : Reader [Check] : Reader CommandHandler : Fixpoint : r)
     a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise (Sem
   (Tagged "original-help" (Reader (Context -> Text))
      : Reader [Check] : Reader CommandHandler : Fixpoint : r)
   a
 -> Sem
      (Reader (Context -> Text)
         : Tagged "original-help" (Reader (Context -> Text))
         : Reader [Check] : Reader CommandHandler : Fixpoint : r)
      a)
-> (Sem r a
    -> Sem
         (Tagged "original-help" (Reader (Context -> Text))
            : Reader [Check] : Reader CommandHandler : Fixpoint : r)
         a)
-> Sem r a
-> Sem
     (Reader (Context -> Text)
        : Tagged "original-help" (Reader (Context -> Text))
        : Reader [Check] : Reader CommandHandler : Fixpoint : r)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Reader [Check] : Reader CommandHandler : Fixpoint : r) a
-> Sem
     (Tagged "original-help" (Reader (Context -> Text))
        : Reader [Check] : Reader CommandHandler : Fixpoint : r)
     a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise (Sem (Reader [Check] : Reader CommandHandler : Fixpoint : r) a
 -> Sem
      (Tagged "original-help" (Reader (Context -> Text))
         : Reader [Check] : Reader CommandHandler : Fixpoint : r)
      a)
-> (Sem r a
    -> Sem (Reader [Check] : Reader CommandHandler : Fixpoint : r) a)
-> Sem r a
-> Sem
     (Tagged "original-help" (Reader (Context -> Text))
        : Reader [Check] : Reader CommandHandler : Fixpoint : r)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Reader CommandHandler : Fixpoint : r) a
-> Sem (Reader [Check] : Reader CommandHandler : Fixpoint : r) a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise (Sem (Reader CommandHandler : Fixpoint : r) a
 -> Sem (Reader [Check] : Reader CommandHandler : Fixpoint : r) a)
-> (Sem r a -> Sem (Reader CommandHandler : Fixpoint : r) a)
-> Sem r a
-> Sem (Reader [Check] : Reader CommandHandler : Fixpoint : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Fixpoint : r) a
-> Sem (Reader CommandHandler : Fixpoint : r) a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise (Sem (Fixpoint : r) a
 -> Sem (Reader CommandHandler : Fixpoint : r) a)
-> (Sem r a -> Sem (Fixpoint : r) a)
-> Sem r a
-> Sem (Reader CommandHandler : Fixpoint : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r a -> Sem (Fixpoint : r) a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
P.raise

-- | Given the command name and parameter names, @parser@ and @callback@ for a
-- command in the 'P.Sem' monad, build a command by transforming the Polysemy
-- actions into IO actions. Then register the command.
--
-- The parent group, checks, and command help are drawn from the reader context.
command'
  :: P.Member (P.Final IO) r
  => S.Text
  -> [S.Text]
  -> (Context -> P.Sem r (Either CommandError a))
  -> ((Context, a) -> P.Sem (P.Fail ': r) ())
  -> P.Sem (DSLState r) Command
command' :: Text
-> [Text]
-> (Context -> Sem r (Either CommandError a))
-> ((Context, a) -> Sem (Fail : r) ())
-> Sem (DSLState r) Command
command' name :: Text
name params :: [Text]
params parser :: Context -> Sem r (Either CommandError a)
parser cb :: (Context, a) -> Sem (Fail : r) ()
cb = do
  Maybe Group
parent <- forall (r :: EffectRow).
MemberWithError (Reader (Maybe Group)) r =>
Sem r (Maybe Group)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Maybe Group)
  [Check]
checks <- forall (r :: EffectRow).
MemberWithError (Reader [Check]) r =>
Sem r [Check]
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @[Check]
  Context -> Text
help' <- forall (r :: EffectRow).
MemberWithError (Reader (Context -> Text)) r =>
Sem r (Context -> Text)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Context -> L.Text)
  Command
cmd <- Sem r Command -> Sem (DSLState r) Command
forall (r :: EffectRow) a. Sem r a -> Sem (DSLState r) a
raiseDSL (Sem r Command -> Sem (DSLState r) Command)
-> Sem r Command -> Sem (DSLState r) Command
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Group
-> [Check]
-> [Text]
-> (Context -> Text)
-> (Context -> Sem r (Either CommandError a))
-> ((Context, a) -> Sem (Fail : r) ())
-> Sem r Command
forall (r :: EffectRow) a.
Member (Final IO) r =>
Text
-> Maybe Group
-> [Check]
-> [Text]
-> (Context -> Text)
-> (Context -> Sem r (Either CommandError a))
-> ((Context, a) -> Sem (Fail : r) ())
-> Sem r Command
buildCommand' Text
name Maybe Group
parent [Check]
checks [Text]
params Context -> Text
help' Context -> Sem r (Either CommandError a)
parser (Context, a) -> Sem (Fail : r) ()
cb
  HashMap Text Command -> Sem (DSLState r) ()
forall o (r :: EffectRow).
MemberWithError (LocalWriter o) r =>
o -> Sem r ()
ltell (HashMap Text Command -> Sem (DSLState r) ())
-> HashMap Text Command -> Sem (DSLState r) ()
forall a b. (a -> b) -> a -> b
$ Text -> Command -> HashMap Text Command
forall k v. Hashable k => k -> v -> HashMap k v
LH.singleton Text
name Command
cmd
  Command -> Sem (DSLState r) Command
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command
cmd

-- | Given the name of a command and a callback, and a type level list of
-- the parameters, build and register a command.
--
-- ==== Examples
--
-- Building a command that bans a user by id.
--
-- @
-- 'command' \@\'['Calamity.Commands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'),
--                'Calamity.Commands.Parser.Named' "reason" ('Calamity.Commands.Parser.KleeneConcat' 'S.Text')]
--    "ban" $ \ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of
--      'Just' guild -> do
--        'Control.Monad.void' . 'Calamity.HTTP.invoke' . 'Calamity.HTTP.reason' r $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid
--        'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r)
--      'Nothing' -> 'void' $ 'Calamity.Types.Tellable.tell' @'L.Text' ctx "Can only ban users from guilds."
-- @
command :: forall ps r.
        ( P.Member (P.Final IO) r,
          TypedCommandC ps r)
        => S.Text
        -> (Context -> CommandForParsers ps r)
        -> P.Sem (DSLState r) Command
command :: Text
-> (Context -> CommandForParsers ps r) -> Sem (DSLState r) Command
command name :: Text
name cmd :: Context -> CommandForParsers ps r
cmd = do
  Maybe Group
parent <- forall (r :: EffectRow).
MemberWithError (Reader (Maybe Group)) r =>
Sem r (Maybe Group)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Maybe Group)
  [Check]
checks <- forall (r :: EffectRow).
MemberWithError (Reader [Check]) r =>
Sem r [Check]
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @[Check]
  Context -> Text
help' <- forall (r :: EffectRow).
MemberWithError (Reader (Context -> Text)) r =>
Sem r (Context -> Text)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Context -> L.Text)
  Command
cmd' <- Sem r Command -> Sem (DSLState r) Command
forall (r :: EffectRow) a. Sem r a -> Sem (DSLState r) a
raiseDSL (Sem r Command -> Sem (DSLState r) Command)
-> Sem r Command -> Sem (DSLState r) Command
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> CommandForParsers ps r)
-> Sem r Command
forall (ps :: [*]) (r :: EffectRow).
(Member (Final IO) r, TypedCommandC ps r) =>
Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> CommandForParsers ps r)
-> Sem r Command
buildCommand @ps Text
name Maybe Group
parent [Check]
checks Context -> Text
help' Context -> CommandForParsers ps r
cmd
  HashMap Text Command -> Sem (DSLState r) ()
forall o (r :: EffectRow).
MemberWithError (LocalWriter o) r =>
o -> Sem r ()
ltell (HashMap Text Command -> Sem (DSLState r) ())
-> HashMap Text Command -> Sem (DSLState r) ()
forall a b. (a -> b) -> a -> b
$ Text -> Command -> HashMap Text Command
forall k v. Hashable k => k -> v -> HashMap k v
LH.singleton Text
name Command
cmd'
  Command -> Sem (DSLState r) Command
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command
cmd'

-- | Set the help for any groups or commands registered inside the given action.
help :: P.Member (P.Reader (Context -> L.Text)) r
     => (Context -> L.Text)
     -> P.Sem r a
     -> P.Sem r a
help :: (Context -> Text) -> Sem r a -> Sem r a
help = ((Context -> Text) -> Context -> Text) -> Sem r a -> Sem r a
forall i (r :: EffectRow) a.
MemberWithError (Reader i) r =>
(i -> i) -> Sem r a -> Sem r a
P.local (((Context -> Text) -> Context -> Text) -> Sem r a -> Sem r a)
-> ((Context -> Text) -> (Context -> Text) -> Context -> Text)
-> (Context -> Text)
-> Sem r a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context -> Text) -> (Context -> Text) -> Context -> Text
forall a b. a -> b -> a
const

-- | Add to the list of checks for any commands registered inside the given
-- action.
requires :: [Check]
         -> P.Sem (DSLState r) a
         -> P.Sem (DSLState r) a
requires :: [Check] -> Sem (DSLState r) a -> Sem (DSLState r) a
requires = ([Check] -> [Check]) -> Sem (DSLState r) a -> Sem (DSLState r) a
forall i (r :: EffectRow) a.
MemberWithError (Reader i) r =>
(i -> i) -> Sem r a -> Sem r a
P.local (([Check] -> [Check]) -> Sem (DSLState r) a -> Sem (DSLState r) a)
-> ([Check] -> [Check] -> [Check])
-> [Check]
-> Sem (DSLState r) a
-> Sem (DSLState r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Check] -> [Check] -> [Check]
forall a. Semigroup a => a -> a -> a
(<>)

-- | Construct a check and add it to the list of checks for any commands
-- registered inside the given action.
requires' :: P.Member (P.Final IO) r
          => S.Text
          -> (Context -> P.Sem r (Maybe L.Text))
          -> P.Sem (DSLState r) a
          -> P.Sem (DSLState r) a
requires' :: Text
-> (Context -> Sem r (Maybe Text))
-> Sem (DSLState r) a
-> Sem (DSLState r) a
requires' name :: Text
name cb :: Context -> Sem r (Maybe Text)
cb m :: Sem (DSLState r) a
m = do
  Check
check <- Sem r Check -> Sem (DSLState r) Check
forall (r :: EffectRow) a. Sem r a -> Sem (DSLState r) a
raiseDSL (Sem r Check -> Sem (DSLState r) Check)
-> Sem r Check -> Sem (DSLState r) Check
forall a b. (a -> b) -> a -> b
$ Text -> (Context -> Sem r (Maybe Text)) -> Sem r Check
forall (r :: EffectRow).
Member (Final IO) r =>
Text -> (Context -> Sem r (Maybe Text)) -> Sem r Check
buildCheck Text
name Context -> Sem r (Maybe Text)
cb
  [Check] -> Sem (DSLState r) a -> Sem (DSLState r) a
forall (r :: EffectRow) a.
[Check] -> Sem (DSLState r) a -> Sem (DSLState r) a
requires [Check
check] Sem (DSLState r) a
m

-- | Construct some pure checks and add them to the list of checks for any
-- commands registered inside the given action.
requiresPure :: [(S.Text, Context -> Maybe L.Text)]
             -> P.Sem (DSLState r) a
             -> P.Sem (DSLState r) a
requiresPure :: [(Text, Context -> Maybe Text)]
-> Sem (DSLState r) a -> Sem (DSLState r) a
requiresPure checks :: [(Text, Context -> Maybe Text)]
checks = [Check] -> Sem (DSLState r) a -> Sem (DSLState r) a
forall (r :: EffectRow) a.
[Check] -> Sem (DSLState r) a -> Sem (DSLState r) a
requires ([Check] -> Sem (DSLState r) a -> Sem (DSLState r) a)
-> [Check] -> Sem (DSLState r) a -> Sem (DSLState r) a
forall a b. (a -> b) -> a -> b
$ ((Text, Context -> Maybe Text) -> Check)
-> [(Text, Context -> Maybe Text)] -> [Check]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> (Context -> Maybe Text) -> Check)
-> (Text, Context -> Maybe Text) -> Check
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> (Context -> Maybe Text) -> Check
buildCheckPure) [(Text, Context -> Maybe Text)]
checks

-- | Construct a group and place any commands registered in the given action
-- into the new group.
--
-- This also resets the @help@ function back to it's original value, use
-- 'group'' if you don't want that (i.e. your help function is context aware).
group :: P.Member (P.Final IO) r
         => S.Text
         -> P.Sem (DSLState r) a
         -> P.Sem (DSLState r) a
group :: Text -> Sem (DSLState r) a -> Sem (DSLState r) a
group name :: Text
name m :: Sem (DSLState r) a
m = mdo
  Maybe Group
parent <- forall (r :: EffectRow).
MemberWithError (Reader (Maybe Group)) r =>
Sem r (Maybe Group)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Maybe Group)
  [Check]
checks <- forall (r :: EffectRow).
MemberWithError (Reader [Check]) r =>
Sem r [Check]
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @[Check]
  Context -> Text
help'  <- forall (r :: EffectRow).
MemberWithError (Reader (Context -> Text)) r =>
Sem r (Context -> Text)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Context -> L.Text)
  Context -> Text
origHelp <- Sem (DSLState r) (Context -> Text)
forall (r :: EffectRow).
Member (Tagged "original-help" (Reader (Context -> Text))) r =>
Sem r (Context -> Text)
fetchOrigHelp
  let group' :: Group
group' = Text
-> Maybe Group
-> HashMap Text Command
-> HashMap Text Group
-> (Context -> Text)
-> [Check]
-> Group
Group Text
name Maybe Group
parent HashMap Text Command
commands HashMap Text Group
children Context -> Text
help' [Check]
checks
  (children :: HashMap Text Group
children, (commands :: HashMap Text Command
commands, res :: a
res)) <- forall (r :: EffectRow) a.
MemberWithError (LocalWriter (HashMap Text Group)) r =>
Sem r a -> Sem r (HashMap Text Group, a)
forall o (r :: EffectRow) a.
MemberWithError (LocalWriter o) r =>
Sem r a -> Sem r (o, a)
llisten @(LH.HashMap S.Text Group) (Sem (DSLState r) (HashMap Text Command, a)
 -> Sem
      (DSLState r) (HashMap Text Group, (HashMap Text Command, a)))
-> Sem (DSLState r) (HashMap Text Command, a)
-> Sem (DSLState r) (HashMap Text Group, (HashMap Text Command, a))
forall a b. (a -> b) -> a -> b
$
                                 forall (r :: EffectRow) a.
MemberWithError (LocalWriter (HashMap Text Command)) r =>
Sem r a -> Sem r (HashMap Text Command, a)
forall o (r :: EffectRow) a.
MemberWithError (LocalWriter o) r =>
Sem r a -> Sem r (o, a)
llisten @(LH.HashMap S.Text Command) (Sem (DSLState r) a -> Sem (DSLState r) (HashMap Text Command, a))
-> Sem (DSLState r) a -> Sem (DSLState r) (HashMap Text Command, a)
forall a b. (a -> b) -> a -> b
$
                                 (Maybe Group -> Maybe Group)
-> Sem (DSLState r) a -> Sem (DSLState r) a
forall i (r :: EffectRow) a.
MemberWithError (Reader i) r =>
(i -> i) -> Sem r a -> Sem r a
P.local @(Maybe Group) (Maybe Group -> Maybe Group -> Maybe Group
forall a b. a -> b -> a
const (Maybe Group -> Maybe Group -> Maybe Group)
-> Maybe Group -> Maybe Group -> Maybe Group
forall a b. (a -> b) -> a -> b
$ Group -> Maybe Group
forall a. a -> Maybe a
Just Group
group') (Sem (DSLState r) a -> Sem (DSLState r) a)
-> Sem (DSLState r) a -> Sem (DSLState r) a
forall a b. (a -> b) -> a -> b
$
                                 ((Context -> Text) -> Context -> Text)
-> Sem (DSLState r) a -> Sem (DSLState r) a
forall i (r :: EffectRow) a.
MemberWithError (Reader i) r =>
(i -> i) -> Sem r a -> Sem r a
P.local @(Context -> L.Text) ((Context -> Text) -> (Context -> Text) -> Context -> Text
forall a b. a -> b -> a
const Context -> Text
origHelp) Sem (DSLState r) a
m
  HashMap Text Group -> Sem (DSLState r) ()
forall o (r :: EffectRow).
MemberWithError (LocalWriter o) r =>
o -> Sem r ()
ltell (HashMap Text Group -> Sem (DSLState r) ())
-> HashMap Text Group -> Sem (DSLState r) ()
forall a b. (a -> b) -> a -> b
$ Text -> Group -> HashMap Text Group
forall k v. Hashable k => k -> v -> HashMap k v
LH.singleton Text
name Group
group'
  a -> Sem (DSLState r) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

fetchOrigHelp :: P.Member (P.Tagged "original-help" (P.Reader (Context -> L.Text))) r => P.Sem r (Context -> L.Text)
fetchOrigHelp :: Sem r (Context -> Text)
fetchOrigHelp = Sem (Reader (Context -> Text) : r) (Context -> Text)
-> Sem r (Context -> Text)
forall k1 (k2 :: k1) (e :: Effect) (r :: EffectRow) a.
Member (Tagged k2 e) r =>
Sem (e : r) a -> Sem r a
P.tag Sem (Reader (Context -> Text) : r) (Context -> Text)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask

-- | Construct a group and place any commands registered in the given action
-- into the new group.
--
-- Unlike 'help' this doesn't reset the @help@ function back to it's original
-- value.
group' :: P.Member (P.Final IO) r
         => S.Text
         -> P.Sem (DSLState r) a
         -> P.Sem (DSLState r) a
group' :: Text -> Sem (DSLState r) a -> Sem (DSLState r) a
group' name :: Text
name m :: Sem (DSLState r) a
m = mdo
  Maybe Group
parent <- forall (r :: EffectRow).
MemberWithError (Reader (Maybe Group)) r =>
Sem r (Maybe Group)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Maybe Group)
  [Check]
checks <- forall (r :: EffectRow).
MemberWithError (Reader [Check]) r =>
Sem r [Check]
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @[Check]
  Context -> Text
help'  <- forall (r :: EffectRow).
MemberWithError (Reader (Context -> Text)) r =>
Sem r (Context -> Text)
forall i (r :: EffectRow). MemberWithError (Reader i) r => Sem r i
P.ask @(Context -> L.Text)
  let group' :: Group
group' = Text
-> Maybe Group
-> HashMap Text Command
-> HashMap Text Group
-> (Context -> Text)
-> [Check]
-> Group
Group Text
name Maybe Group
parent HashMap Text Command
commands HashMap Text Group
children Context -> Text
help' [Check]
checks
  (children :: HashMap Text Group
children, (commands :: HashMap Text Command
commands, res :: a
res)) <- forall (r :: EffectRow) a.
MemberWithError (LocalWriter (HashMap Text Group)) r =>
Sem r a -> Sem r (HashMap Text Group, a)
forall o (r :: EffectRow) a.
MemberWithError (LocalWriter o) r =>
Sem r a -> Sem r (o, a)
llisten @(LH.HashMap S.Text Group) (Sem (DSLState r) (HashMap Text Command, a)
 -> Sem
      (DSLState r) (HashMap Text Group, (HashMap Text Command, a)))
-> Sem (DSLState r) (HashMap Text Command, a)
-> Sem (DSLState r) (HashMap Text Group, (HashMap Text Command, a))
forall a b. (a -> b) -> a -> b
$
                                 forall (r :: EffectRow) a.
MemberWithError (LocalWriter (HashMap Text Command)) r =>
Sem r a -> Sem r (HashMap Text Command, a)
forall o (r :: EffectRow) a.
MemberWithError (LocalWriter o) r =>
Sem r a -> Sem r (o, a)
llisten @(LH.HashMap S.Text Command) (Sem (DSLState r) a -> Sem (DSLState r) (HashMap Text Command, a))
-> Sem (DSLState r) a -> Sem (DSLState r) (HashMap Text Command, a)
forall a b. (a -> b) -> a -> b
$
                                 (Maybe Group -> Maybe Group)
-> Sem (DSLState r) a -> Sem (DSLState r) a
forall i (r :: EffectRow) a.
MemberWithError (Reader i) r =>
(i -> i) -> Sem r a -> Sem r a
P.local @(Maybe Group) (Maybe Group -> Maybe Group -> Maybe Group
forall a b. a -> b -> a
const (Maybe Group -> Maybe Group -> Maybe Group)
-> Maybe Group -> Maybe Group -> Maybe Group
forall a b. (a -> b) -> a -> b
$ Group -> Maybe Group
forall a. a -> Maybe a
Just Group
group') Sem (DSLState r) a
m
  HashMap Text Group -> Sem (DSLState r) ()
forall o (r :: EffectRow).
MemberWithError (LocalWriter o) r =>
o -> Sem r ()
ltell (HashMap Text Group -> Sem (DSLState r) ())
-> HashMap Text Group -> Sem (DSLState r) ()
forall a b. (a -> b) -> a -> b
$ Text -> Group -> HashMap Text Group
forall k v. Hashable k => k -> v -> HashMap k v
LH.singleton Text
name Group
group'
  a -> Sem (DSLState r) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res