-- | A default help command implementation
module Calamity.Commands.Help
    ( helpCommand'
    , helpCommand ) where

import           Calamity.Client.Types
import           Calamity.Commands.Check
import           Calamity.Commands.Command
import           Calamity.Commands.CommandUtils
import           Calamity.Commands.Context
import           Calamity.Commands.Dsl
import           Calamity.Commands.Group
import           Calamity.Commands.Handler
import           Calamity.Internal.LocalWriter
import           Calamity.Types.Tellable

import           Control.Applicative
import           Control.Lens hiding ( Context(..) )
import           Control.Monad

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.Reader                as P

data CommandOrGroup
  = Command' Command
  | Group' Group [S.Text]

helpCommandHelp :: Context -> L.Text
helpCommandHelp :: Context -> Text
helpCommandHelp _ = "Show help for a command or group."

helpForCommand :: Context -> Command -> L.Text
helpForCommand :: Context -> Command -> Text
helpForCommand ctx :: Context
ctx (cmd :: Command
cmd@Command { Context -> Text
$sel:help:Command :: Command -> Context -> Text
help :: Context -> Text
help }) = "```\nUsage: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prefix' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
params' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Context -> Text
help Context
ctx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n```"
  where prefix' :: Text
prefix' = Context
ctx Context -> Getting Text Context Text -> Text
forall s a. s -> Getting a s a -> a
^. IsLabel "prefix" (Getting Text Context Text)
Getting Text Context Text
#prefix
        path' :: Text
path'   = Text -> Text
L.fromStrict (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
S.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Command -> [Text]
commandPath Command
cmd
        params' :: Text
params' = Command -> Text
commandParams Command
cmd

fmtCommandWithParams :: Command -> L.Text
fmtCommandWithParams :: Command -> Text
fmtCommandWithParams cmd :: Command
cmd@Command { Text
$sel:name:Command :: Command -> Text
name :: Text
name } = Text -> Text
L.fromStrict Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Command -> Text
commandParams Command
cmd

helpForGroup :: Context -> Group -> L.Text
helpForGroup :: Context -> Group -> Text
helpForGroup ctx :: Context
ctx grp :: Group
grp = "```\nGroup: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Group
grp Group
-> Getting (Context -> Text) Group (Context -> Text)
-> Context
-> Text
forall s a. s -> Getting a s a -> a
^. IsLabel "help" (Getting (Context -> Text) Group (Context -> Text))
Getting (Context -> Text) Group (Context -> Text)
#help) Context
ctx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
groupsMsg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commandsMsg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n```"
  where path' :: Text
path' = Text -> Text
L.fromStrict (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
S.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Group -> [Text]
groupPath Group
grp
        groups :: [Text]
groups = HashMap Text Group -> [Text]
forall k v. HashMap k v -> [k]
LH.keys (HashMap Text Group -> [Text]) -> HashMap Text Group -> [Text]
forall a b. (a -> b) -> a -> b
$ Group
grp Group
-> Getting (HashMap Text Group) Group (HashMap Text Group)
-> HashMap Text Group
forall s a. s -> Getting a s a -> a
^. IsLabel
  "children"
  (Getting (HashMap Text Group) Group (HashMap Text Group))
Getting (HashMap Text Group) Group (HashMap Text Group)
#children
        commands :: [Command]
commands = HashMap Text Command -> [Command]
forall k v. HashMap k v -> [v]
LH.elems (HashMap Text Command -> [Command])
-> HashMap Text Command -> [Command]
forall a b. (a -> b) -> a -> b
$ Group
grp Group
-> Getting (HashMap Text Command) Group (HashMap Text Command)
-> HashMap Text Command
forall s a. s -> Getting a s a -> a
^. IsLabel
  "commands"
  (Getting (HashMap Text Command) Group (HashMap Text Command))
Getting (HashMap Text Command) Group (HashMap Text Command)
#commands
        groupsMsg :: Text
groupsMsg = if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
groups then "" else "The following child groups exist:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
L.fromStrict ([Text] -> Text
S.unlines ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ("- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
groups)
        commandsMsg :: Text
commandsMsg = if [Command] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Command]
commands then "" else "\nThe following child commands exist:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Text
L.unlines ([Text] -> Text) -> ([Command] -> [Text]) -> [Command] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ("- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> ([Command] -> [Text]) -> [Command] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Command -> Text) -> [Command] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Command -> Text
fmtCommandWithParams ([Command] -> Text) -> [Command] -> Text
forall a b. (a -> b) -> a -> b
$ [Command]
commands)

rootHelp :: CommandHandler -> L.Text
rootHelp :: CommandHandler -> Text
rootHelp handler :: CommandHandler
handler = "```\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
groupsMsg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commandsMsg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n```"
  where groups :: [Text]
groups = HashMap Text Group -> [Text]
forall k v. HashMap k v -> [k]
LH.keys (HashMap Text Group -> [Text]) -> HashMap Text Group -> [Text]
forall a b. (a -> b) -> a -> b
$ CommandHandler
handler CommandHandler
-> Getting (HashMap Text Group) CommandHandler (HashMap Text Group)
-> HashMap Text Group
forall s a. s -> Getting a s a -> a
^. IsLabel
  "groups"
  (Getting (HashMap Text Group) CommandHandler (HashMap Text Group))
Getting (HashMap Text Group) CommandHandler (HashMap Text Group)
#groups
        commands :: [Command]
commands = HashMap Text Command -> [Command]
forall k v. HashMap k v -> [v]
LH.elems (HashMap Text Command -> [Command])
-> HashMap Text Command -> [Command]
forall a b. (a -> b) -> a -> b
$ CommandHandler
handler CommandHandler
-> Getting
     (HashMap Text Command) CommandHandler (HashMap Text Command)
-> HashMap Text Command
forall s a. s -> Getting a s a -> a
^. IsLabel
  "commands"
  (Getting
     (HashMap Text Command) CommandHandler (HashMap Text Command))
Getting
  (HashMap Text Command) CommandHandler (HashMap Text Command)
#commands
        groupsMsg :: Text
groupsMsg = if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
groups then "" else "The following groups exist:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
L.fromStrict ([Text] -> Text
S.unlines ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ("- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
groups)
        commandsMsg :: Text
commandsMsg = if [Command] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Command]
commands then "" else "\nThe following commands exist:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Text
L.unlines ([Text] -> Text) -> ([Command] -> [Text]) -> [Command] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ("- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> ([Command] -> [Text]) -> [Command] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Command -> Text) -> [Command] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Command -> Text
fmtCommandWithParams ([Command] -> Text) -> [Command] -> Text
forall a b. (a -> b) -> a -> b
$ [Command]
commands)

-- TODO: process checks

helpCommandCallback :: BotC r => CommandHandler -> Context -> [S.Text] -> P.Sem (P.Fail ': r) ()
helpCommandCallback :: CommandHandler -> Context -> [Text] -> Sem (Fail : r) ()
helpCommandCallback handler :: CommandHandler
handler ctx :: Context
ctx path :: [Text]
path = do
  case CommandHandler -> [Text] -> Maybe CommandOrGroup
findCommandOrGroup CommandHandler
handler [Text]
path of
    Just (Command' cmd :: Command
cmd@Command { Text
name :: Text
$sel:name:Command :: Command -> Text
name }) ->
      Sem (Fail : r) (Either RestError Message) -> Sem (Fail : r) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem (Fail : r) (Either RestError Message) -> Sem (Fail : r) ())
-> Sem (Fail : r) (Either RestError Message) -> Sem (Fail : r) ()
forall a b. (a -> b) -> a -> b
$ Context -> Text -> Sem (Fail : r) (Either RestError Message)
forall msg (r :: [(* -> *) -> * -> *]) t.
(BotC r, ToMessage msg, Tellable t) =>
t -> msg -> Sem r (Either RestError Message)
tell @L.Text Context
ctx (Text -> Sem (Fail : r) (Either RestError Message))
-> Text -> Sem (Fail : r) (Either RestError Message)
forall a b. (a -> b) -> a -> b
$ "Help for command `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
L.fromStrict Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`: \n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Context -> Command -> Text
helpForCommand Context
ctx Command
cmd
    Just (Group' grp :: Group
grp@Group { Text
$sel:name:Group :: Group -> Text
name :: Text
name } remainingPath :: [Text]
remainingPath) ->
      let failedMsg :: Text
failedMsg = if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
remainingPath
            then ""
            else "No command or group with the path: `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
L.fromStrict ([Text] -> Text
S.unwords [Text]
path) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "` exists for the group: `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
L.fromStrict Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`\n"
      in Sem (Fail : r) (Either RestError Message) -> Sem (Fail : r) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem (Fail : r) (Either RestError Message) -> Sem (Fail : r) ())
-> Sem (Fail : r) (Either RestError Message) -> Sem (Fail : r) ()
forall a b. (a -> b) -> a -> b
$ Context -> Text -> Sem (Fail : r) (Either RestError Message)
forall msg (r :: [(* -> *) -> * -> *]) t.
(BotC r, ToMessage msg, Tellable t) =>
t -> msg -> Sem r (Either RestError Message)
tell @L.Text Context
ctx (Text -> Sem (Fail : r) (Either RestError Message))
-> Text -> Sem (Fail : r) (Either RestError Message)
forall a b. (a -> b) -> a -> b
$ Text
failedMsg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "Help for group `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
L.fromStrict Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`: \n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Context -> Group -> Text
helpForGroup Context
ctx Group
grp
    Nothing -> let failedMsg :: Text
failedMsg = if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
path
                     then ""
                     else "No command or group with the path: `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
L.fromStrict ([Text] -> Text
S.unwords [Text]
path) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "` was found.\n"
               in Sem (Fail : r) (Either RestError Message) -> Sem (Fail : r) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem (Fail : r) (Either RestError Message) -> Sem (Fail : r) ())
-> Sem (Fail : r) (Either RestError Message) -> Sem (Fail : r) ()
forall a b. (a -> b) -> a -> b
$ Context -> Text -> Sem (Fail : r) (Either RestError Message)
forall msg (r :: [(* -> *) -> * -> *]) t.
(BotC r, ToMessage msg, Tellable t) =>
t -> msg -> Sem r (Either RestError Message)
tell @L.Text Context
ctx (Text -> Sem (Fail : r) (Either RestError Message))
-> Text -> Sem (Fail : r) (Either RestError Message)
forall a b. (a -> b) -> a -> b
$ Text
failedMsg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CommandHandler -> Text
rootHelp CommandHandler
handler

-- | Given a 'CommandHandler', optionally a parent 'Group', and a list of 'Check's,
-- construct a help command that will provide help for all the commands and
-- groups in the passed 'CommandHandler'.
helpCommand' :: BotC r => CommandHandler -> Maybe Group -> [Check] -> P.Sem r Command
helpCommand' :: CommandHandler -> Maybe Group -> [Check] -> Sem r Command
helpCommand' handler :: CommandHandler
handler parent :: Maybe Group
parent checks :: [Check]
checks = Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> CommandForParsers '[[Text]] r)
-> Sem r Command
forall (ps :: [*]) (r :: [(* -> *) -> * -> *]).
(Member (Final IO) r, TypedCommandC ps r) =>
Text
-> Maybe Group
-> [Check]
-> (Context -> Text)
-> (Context -> CommandForParsers ps r)
-> Sem r Command
buildCommand @'[[S.Text]] "help" Maybe Group
parent [Check]
checks Context -> Text
helpCommandHelp
  (CommandHandler -> Context -> [Text] -> Sem (Fail : r) ()
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
CommandHandler -> Context -> [Text] -> Sem (Fail : r) ()
helpCommandCallback CommandHandler
handler)

-- | Create and register the default help command for all the commands
-- registered in the commands DSL this is used in.
helpCommand :: BotC r => P.Sem (DSLState r) Command
helpCommand :: Sem (DSLState r) Command
helpCommand = do
  CommandHandler
handler <- forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Reader CommandHandler) r =>
Sem r CommandHandler
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Reader i) r =>
Sem r i
P.ask @CommandHandler
  Maybe Group
parent <- forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Reader (Maybe Group)) r =>
Sem r (Maybe Group)
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Reader i) r =>
Sem r i
P.ask @(Maybe Group)
  [Check]
checks <- forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Reader [Check]) r =>
Sem r [Check]
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Reader i) r =>
Sem r i
P.ask @[Check]
  Command
cmd <- Sem r Command -> Sem (DSLState r) Command
forall (r :: [(* -> *) -> * -> *]) 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
$ CommandHandler -> Maybe Group -> [Check] -> Sem r Command
forall (r :: [(* -> *) -> * -> *]).
BotC r =>
CommandHandler -> Maybe Group -> [Check] -> Sem r Command
helpCommand' CommandHandler
handler Maybe Group
parent [Check]
checks
  HashMap Text Command -> Sem (DSLState r) ()
forall o (r :: [(* -> *) -> * -> *]).
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 "help" Command
cmd
  Command -> Sem (DSLState r) Command
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command
cmd

findCommandOrGroup :: CommandHandler -> [S.Text] -> Maybe CommandOrGroup
findCommandOrGroup :: CommandHandler -> [Text] -> Maybe CommandOrGroup
findCommandOrGroup handler :: CommandHandler
handler path :: [Text]
path = (HashMap Text Command, HashMap Text Group)
-> [Text] -> Maybe CommandOrGroup
go (CommandHandler
handler CommandHandler
-> Getting
     (HashMap Text Command) CommandHandler (HashMap Text Command)
-> HashMap Text Command
forall s a. s -> Getting a s a -> a
^. IsLabel
  "commands"
  (Getting
     (HashMap Text Command) CommandHandler (HashMap Text Command))
Getting
  (HashMap Text Command) CommandHandler (HashMap Text Command)
#commands, CommandHandler
handler CommandHandler
-> Getting (HashMap Text Group) CommandHandler (HashMap Text Group)
-> HashMap Text Group
forall s a. s -> Getting a s a -> a
^. IsLabel
  "groups"
  (Getting (HashMap Text Group) CommandHandler (HashMap Text Group))
Getting (HashMap Text Group) CommandHandler (HashMap Text Group)
#groups) [Text]
path
  where go :: (LH.HashMap S.Text Command, LH.HashMap S.Text Group) -> [S.Text] -> Maybe CommandOrGroup
        go :: (HashMap Text Command, HashMap Text Group)
-> [Text] -> Maybe CommandOrGroup
go (commands :: HashMap Text Command
commands, groups :: HashMap Text Group
groups) (x :: Text
x : xs :: [Text]
xs) =
          case Text -> HashMap Text Command -> Maybe Command
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
LH.lookup Text
x HashMap Text Command
commands of
            Just cmd :: Command
cmd -> CommandOrGroup -> Maybe CommandOrGroup
forall a. a -> Maybe a
Just (Command -> CommandOrGroup
Command' Command
cmd)
            Nothing  -> case Text -> HashMap Text Group -> Maybe Group
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
LH.lookup Text
x HashMap Text Group
groups of
              Just group :: Group
group -> (HashMap Text Command, HashMap Text Group)
-> [Text] -> Maybe CommandOrGroup
go (Group
group Group
-> Getting (HashMap Text Command) Group (HashMap Text Command)
-> HashMap Text Command
forall s a. s -> Getting a s a -> a
^. IsLabel
  "commands"
  (Getting (HashMap Text Command) Group (HashMap Text Command))
Getting (HashMap Text Command) Group (HashMap Text Command)
#commands, Group
group Group
-> Getting (HashMap Text Group) Group (HashMap Text Group)
-> HashMap Text Group
forall s a. s -> Getting a s a -> a
^. IsLabel
  "children"
  (Getting (HashMap Text Group) Group (HashMap Text Group))
Getting (HashMap Text Group) Group (HashMap Text Group)
#children) [Text]
xs Maybe CommandOrGroup
-> Maybe CommandOrGroup -> Maybe CommandOrGroup
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CommandOrGroup -> Maybe CommandOrGroup
forall a. a -> Maybe a
Just (Group -> [Text] -> CommandOrGroup
Group' Group
group [Text]
xs)
              Nothing    -> Maybe CommandOrGroup
forall a. Maybe a
Nothing
        go _ [] = Maybe CommandOrGroup
forall a. Maybe a
Nothing