calamity-commands 0.4.0.0 → 0.4.1.0

raw patch · 19 files changed

+600/−584 lines, 19 filesdep ~textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: text

API changes (from Hackage documentation)

Files

• CalamityCommands.hs +12/−13
• CalamityCommands/AliasType.hs +1/−1
• CalamityCommands/Check.hs +8/−8
• CalamityCommands/Command.hs +16/−17
• CalamityCommands/CommandUtils.hs +13/−13
• CalamityCommands/Context.hs +2/−2
• CalamityCommands/Dsl.hs +202/−198
• CalamityCommands/Error.hs +7/−7
• CalamityCommands/Group.hs +12/−12
• CalamityCommands/Handler.hs +7/−7
• CalamityCommands/Help.hs +100/−91
• CalamityCommands/Internal/LocalWriter.hs +20/−16
• CalamityCommands/Internal/RunIntoM.hs +7/−8
• CalamityCommands/Internal/Utils.hs +4/−4
• CalamityCommands/ParameterInfo.hs +1/−1
• CalamityCommands/ParsePrefix.hs +2/−2
• CalamityCommands/Parser.hs +30/−30
• CalamityCommands/Utils.hs +52/−51
• calamity-commands.cabal +104/−103

@@ -2,20 +2,19 @@  This module exports the DSL and core types for using commands -} module CalamityCommands (-    module CalamityCommands.Context,-    module CalamityCommands.Dsl,-    module CalamityCommands.Error,-    module CalamityCommands.Handler,-    module CalamityCommands.Utils,-    module CalamityCommands.ParsePrefix,-    module CalamityCommands.Help,--    -- * Parameter parsers+  module CalamityCommands.Context,+  module CalamityCommands.Dsl,+  module CalamityCommands.Error,+  module CalamityCommands.Handler,+  module CalamityCommands.Utils,+  module CalamityCommands.ParsePrefix,+  module CalamityCommands.Help, -    module CalamityCommands.Parser,+  -- * Parameter parsers+  module CalamityCommands.Parser, -    -- * Commands-    -- $commandDocs+  -- * Commands+  -- $commandDocs ) where  import CalamityCommands.Context@@ -24,7 +23,7 @@ import CalamityCommands.Handler import CalamityCommands.Help import CalamityCommands.ParsePrefix-import CalamityCommands.Parser (Named, KleeneStarConcat, KleenePlusConcat, ParameterParser (..))+import CalamityCommands.Parser (KleenePlusConcat, KleeneStarConcat, Named, ParameterParser (..)) import CalamityCommands.Utils  {- $commandDocs

@@ -3,7 +3,7 @@   AliasType (..), ) where -import qualified TextShow+import TextShow qualified  data AliasType   = Alias

@@ -12,20 +12,20 @@ import CalamityCommands.Internal.RunIntoM import CalamityCommands.Internal.Utils import Data.Maybe-import qualified Data.Text as T+import Data.Text qualified as T import Optics-import qualified Polysemy as P+import Polysemy qualified as P  {- | A check for a command.   Every check for a command must return Nothing for the command to be run. -} data Check m c = MkCheck-  { -- | The name of the check.-    name :: T.Text-  , -- | The callback for the check, returns Nothing if it passes, otherwise-    -- returns the reason for it not passing.-    callback :: c -> m (Maybe T.Text)+  { name :: T.Text+  -- ^ The name of the check.+  , callback :: c -> m (Maybe T.Text)+  -- ^ The callback for the check, returns Nothing if it passes, otherwise+  -- returns the reason for it not passing.   }  $(makeFieldLabelsNoPrefix ''Check)@@ -40,7 +40,7 @@   pure $ MkCheck name cb''  -- | Given the name of a check and a pure callback function, build a check.-buildCheckPure :: Monad m => T.Text -> (c -> Maybe T.Text) -> Check m c+buildCheckPure :: (Monad m) => T.Text -> (c -> Maybe T.Text) -> Check m c buildCheckPure name cb = MkCheck name (pure . cb)  {- | Given an invokation context @c@, run a check and transform the result into an

@@ -9,10 +9,10 @@ import CalamityCommands.ParameterInfo import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty)-import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty qualified as NE import Data.Text as T import Optics-import qualified TextShow+import TextShow qualified import TextShow.TH (deriveTextShow)  -- | A command, paremeterised over its context@@ -20,20 +20,20 @@   Command   { names :: NonEmpty T.Text   , parent :: Maybe (Group m c a)-  , -- | If this command is hidden-    hidden :: Bool-  , -- | A list of checks that must pass for this command to be invoked-    checks :: [Check m c]-  , -- | A list of parameter metadata-    params :: [ParameterInfo]-  , -- | A function producing the \'help\' for the command.-    help :: c -> T.Text-  , -- | A function that parses the context for the command, producing the input-    -- @a@ for the command.-    parser :: c -> m (Either CommandError p)-  , -- | A function that given the context and the input (@p@) of the command,-    -- performs the action of the command.-    callback :: (c, p) -> m (Either T.Text a)+  , hidden :: Bool+  -- ^ If this command is hidden+  , checks :: [Check m c]+  -- ^ A list of checks that must pass for this command to be invoked+  , params :: [ParameterInfo]+  -- ^ A list of parameter metadata+  , help :: c -> T.Text+  -- ^ A function producing the \'help\' for the command.+  , parser :: c -> m (Either CommandError p)+  -- ^ A function that parses the context for the command, producing the input+  -- @a@ for the command.+  , callback :: (c, p) -> m (Either T.Text a)+  -- ^ A function that given the context and the input (@p@) of the command,+  -- performs the action of the command.   }  $(makeFieldLabelsNoPrefix ''Command)@@ -68,4 +68,3 @@         (NE.head <$> parent ^? _Just % #names)         (checks ^.. traversed % #name)         hidden-

@@ -22,27 +22,27 @@ import CalamityCommands.Internal.Utils import CalamityCommands.ParameterInfo import CalamityCommands.Parser-import Optics import Control.Monad import Data.Foldable import Data.Kind import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty qualified 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+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]+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]+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} =+commandParams Command {params} =   let formatted =         map           ( \(ParameterInfo (fromMaybe "" -> name) type_ _) ->@@ -140,7 +140,7 @@  -- | 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} =+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)@@ -149,7 +149,7 @@  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+invokeCommand ctx cmd@Command {checks} = P.runError $ do   for_ checks (P.fromEither <=< runCheck ctx)   P.fromEither =<< runCommand ctx cmd @@ -189,7 +189,7 @@    applyTup :: ApplyTupRes a b -> a -> b -instance ApplyTup as b => ApplyTup (a, as) b where+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@@ -201,7 +201,7 @@  buildTypedCommandParser ::   forall (ps :: [Type]) c r.-  ParameterParser (ListToTup ps) c r =>+  (ParameterParser (ListToTup ps) c r) =>   c ->   S.Text ->   P.Sem r (Either CommandError (ParserResult (ListToTup ps)))

@@ -10,9 +10,9 @@ ) where  import CalamityCommands.Command-import qualified Data.Text as T+import Data.Text qualified as T import Optics.TH-import qualified Polysemy as P+import Polysemy qualified as P  class CommandContext m c a | c -> m, c -> a where   -- | The prefix that was used to invoke the command

@@ -1,26 +1,27 @@ {-# LANGUAGE RecursiveDo #-}+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}  -- | A DSL for generating commands and groups module CalamityCommands.Dsl (-    -- * Commands DSL-    -- $dslTutorial-    command,-    command',-    commandA,-    commandA',-    hide,-    help,-    requires,-    requires',-    requiresPure,-    group,-    group',-    groupA,-    groupA',-    DSLState,-    DSLC,-    raiseDSL,-    fetchHandler,+  -- * Commands DSL+  -- $dslTutorial+  command,+  command',+  commandA,+  commandA',+  hide,+  help,+  requires,+  requires',+  requiresPure,+  group,+  group',+  groupA,+  groupA',+  DSLState,+  DSLC,+  raiseDSL,+  fetchHandler, ) where  import CalamityCommands.AliasType@@ -31,16 +32,16 @@ import CalamityCommands.Error import CalamityCommands.Group hiding (help) import CalamityCommands.Handler-import CalamityCommands.ParameterInfo import CalamityCommands.Internal.LocalWriter-import qualified Data.HashMap.Lazy as LH-import qualified Data.Text as T+import CalamityCommands.ParameterInfo+import Data.HashMap.Lazy qualified as LH import Data.List.NonEmpty (NonEmpty (..))-import qualified Polysemy as P-import qualified Polysemy.Fail as P-import qualified Polysemy.Fixpoint as P-import qualified Polysemy.Reader as P-import qualified Polysemy.Tagged as P+import Data.Text qualified as T+import Polysemy qualified as P+import Polysemy.Fail qualified as P+import Polysemy.Fixpoint qualified as P+import Polysemy.Reader qualified as P+import Polysemy.Tagged qualified as P  {- $dslTutorial @@ -76,29 +77,31 @@ -}  type DSLState m c a r =-    ( LocalWriter (LH.HashMap T.Text (Command m c a, AliasType))-        ': LocalWriter (LH.HashMap T.Text (Group m c a, AliasType))-            ': P.Reader (Maybe (Group m c a))-                ': P.Tagged "hidden" (P.Reader Bool)-                    ': P.Reader (c -> T.Text)-                        ': P.Tagged "original-help" (P.Reader (c -> T.Text))-                            ': P.Reader [Check m c]-                                ': P.Reader (CommandHandler m c a)-                                    ': P.Fixpoint-                                        ': r-    )+  ( LocalWriter (LH.HashMap T.Text (Command m c a, AliasType))+      ': LocalWriter (LH.HashMap T.Text (Group m c a, AliasType))+      ': P.Reader (Maybe (Group m c a))+      ': P.Tagged "hidden" (P.Reader Bool)+      ': P.Reader (c -> T.Text)+      ': P.Tagged "original-help" (P.Reader (c -> T.Text))+      ': P.Reader [Check m c]+      ': P.Reader (CommandHandler m c a)+      ': P.Fixpoint+      ': r+  ) -type DSLC m c a r = P.Members [-  LocalWriter (LH.HashMap T.Text (Command m c a, AliasType))-        , LocalWriter (LH.HashMap T.Text (Group m c a, AliasType))-            , P.Reader (Maybe (Group m c a))-                , P.Tagged "hidden" (P.Reader Bool)-                    , P.Reader (c -> T.Text)-                        , P.Tagged "original-help" (P.Reader (c -> T.Text))-                            , P.Reader [Check m c]-                                , P.Reader (CommandHandler m c a)-                                    , P.Fixpoint-                              ] r+type DSLC m c a r =+  P.Members+    [ LocalWriter (LH.HashMap T.Text (Command m c a, AliasType))+    , LocalWriter (LH.HashMap T.Text (Group m c a, AliasType))+    , P.Reader (Maybe (Group m c a))+    , P.Tagged "hidden" (P.Reader Bool)+    , P.Reader (c -> T.Text)+    , P.Tagged "original-help" (P.Reader (c -> T.Text))+    , P.Reader [Check m c]+    , P.Reader (CommandHandler m c a)+    , P.Fixpoint+    ]+    r  raiseDSL :: P.Sem r x -> P.Sem (DSLState m c a r) x raiseDSL = P.raise . P.raise . P.raise . P.raise . P.raise . P.raise . P.raise . P.raise . P.raise@@ -111,17 +114,17 @@  reader context. -} command' ::-    (Monad m, P.Member (P.Final m) r, DSLC m c a r) =>-    -- | The name of the command-    T.Text ->-    -- | The command's parameter metadata-    [ParameterInfo] ->-    -- | 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)-command' name params parser cb = commandA' name [] params parser cb+  (Monad m, P.Member (P.Final m) r, DSLC m c a r) =>+  -- | The name of the command+  T.Text ->+  -- | The command's parameter metadata+  [ParameterInfo] ->+  -- | 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)+command' name = commandA' name []  {- | Given the command name, aliases, and parameter names, @parser@ and @callback@  for a command in the 'P.Sem' monad, build a command by transforming the@@ -131,28 +134,28 @@  reader context. -} commandA' ::-    forall p c a m r.-    (Monad m, P.Member (P.Final m) r, DSLC m c a r) =>-    -- | The name of the command-    T.Text ->-    -- | The aliases for the command-    [T.Text] ->-    -- | The command's parameter metadata-    [ParameterInfo] ->-    -- | 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)+  forall p c a m r.+  (Monad m, P.Member (P.Final m) r, DSLC m c a r) =>+  -- | The name of the command+  T.Text ->+  -- | The aliases for the command+  [T.Text] ->+  -- | The command's parameter metadata+  [ParameterInfo] ->+  -- | 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) commandA' name aliases params parser cb = do-    parent <- P.ask @(Maybe (Group m c a))-    hidden <- P.tag $ P.ask @Bool-    checks <- P.ask @[Check m c]-    help' <- P.ask @(c -> T.Text)-    cmd <- buildCommand' (name :| aliases) parent hidden checks params help' parser cb-    ltell $ LH.singleton name (cmd, Original)-    ltell $ LH.fromList [(name, (cmd, Alias)) | name <- aliases]-    pure cmd+  parent <- P.ask @(Maybe (Group m c a))+  hidden <- P.tag $ P.ask @Bool+  checks <- P.ask @[Check m c]+  help' <- P.ask @(c -> T.Text)+  cmd <- buildCommand' (name :| aliases) parent hidden checks params help' parser cb+  ltell $ LH.singleton name (cmd, Original)+  ltell $ LH.fromList [(name, (cmd, Alias)) | name <- aliases]+  pure cmd  {- | Given the name of a command and a callback, and a type level list of  the parameters, build and register a command.@@ -175,19 +178,19 @@  @ -} command ::-    forall ps c a m r.-    ( Monad m-    , P.Member (P.Final m) r-    , DSLC m c a r-    , TypedCommandC ps c a r-    , CommandContext m c a-    ) =>-    -- | The name of the command-    T.Text ->-    -- | The callback for this command-    (c -> CommandForParsers ps r a) ->-    P.Sem r (Command m c a)-command name cmd = commandA @ps name [] cmd+  forall ps c a m r.+  ( Monad m+  , P.Member (P.Final m) r+  , DSLC m c a r+  , TypedCommandC ps c a r+  , CommandContext m c a+  ) =>+  -- | The name of the command+  T.Text ->+  -- | The callback for this command+  (c -> CommandForParsers ps r a) ->+  P.Sem r (Command m c a)+command name = commandA @ps name []  {- | Given the name and aliases of a command and a callback, and a type level list of  the parameters, build and register a command.@@ -206,37 +209,37 @@  @ -} commandA ::-    forall ps c a m r.-    ( Monad m-    , P.Member (P.Final m) r-    , DSLC m c a r-    , TypedCommandC ps c a r-    , CommandContext m c a-    ) =>-    -- | The name of the command-    T.Text ->-    -- | The aliases for the command-    [T.Text] ->-    -- | The callback for this command-    (c -> CommandForParsers ps r a) ->-    P.Sem r (Command m c a)+  forall ps c a m r.+  ( Monad m+  , P.Member (P.Final m) r+  , DSLC m c a r+  , TypedCommandC ps c a r+  , CommandContext m c a+  ) =>+  -- | The name of the command+  T.Text ->+  -- | The aliases for the command+  [T.Text] ->+  -- | The callback for this command+  (c -> CommandForParsers ps r a) ->+  P.Sem r (Command m c a) commandA name aliases cmd = do-    parent <- P.ask @(Maybe (Group m c a))-    hidden <- P.tag $ P.ask @Bool-    checks <- P.ask @[Check m c]-    help' <- P.ask @(c -> T.Text)-    cmd' <- buildCommand @ps (name :| aliases) parent hidden checks help' cmd-    ltell $ LH.singleton name (cmd', Original)-    ltell $ LH.fromList [(name, (cmd', Alias)) | name <- aliases]-    pure cmd'+  parent <- P.ask @(Maybe (Group m c a))+  hidden <- P.tag $ P.ask @Bool+  checks <- P.ask @[Check m c]+  help' <- P.ask @(c -> T.Text)+  cmd' <- buildCommand @ps (name :| aliases) parent hidden checks help' cmd+  ltell $ LH.singleton name (cmd', Original)+  ltell $ LH.fromList [(name, (cmd', Alias)) | name <- aliases]+  pure cmd'  {- | Set the visibility of any groups or commands registered inside the given  action to hidden. -} hide ::-    P.Member (P.Tagged "hidden" (P.Reader Bool)) r =>-    P.Sem r x ->-    P.Sem r x+  (P.Member (P.Tagged "hidden" (P.Reader Bool)) r) =>+  P.Sem r x ->+  P.Sem r x hide = P.tag @"hidden" . P.local @Bool (const True) . P.raise  {- | Set the help for any groups or commands registered inside the given action.@@ -250,19 +253,20 @@  @ -} help ::-    P.Member (P.Reader (c -> T.Text)) r =>-    (c -> T.Text) ->-    P.Sem r a ->-    P.Sem r a+  (P.Member (P.Reader (c -> T.Text)) r) =>+  (c -> T.Text) ->+  P.Sem r a ->+  P.Sem r a help = P.local . const  {- | Add to the list of checks for any commands registered inside the given  action. -}-requires :: DSLC m c a r =>-    [Check m c] ->-    P.Sem r x ->-    P.Sem r x+requires ::+  (DSLC m c a r) =>+  [Check m c] ->+  P.Sem r x ->+  P.Sem r x requires = P.local . (<>)  {- | Construct a check and add it to the list of checks for any commands@@ -271,16 +275,16 @@  Refer to 'CalamityCommands.Check.Check' for more info on checks. -} requires' ::-    (Monad m, P.Member (P.Final m) r, DSLC m c a r) =>-    -- | The name of the check-    T.Text ->-    -- | The callback for the check-    (c -> P.Sem r (Maybe T.Text)) ->-    P.Sem r x ->-    P.Sem r x+  (Monad m, P.Member (P.Final m) r, DSLC m c a r) =>+  -- | The name of the check+  T.Text ->+  -- | The callback for the check+  (c -> P.Sem r (Maybe T.Text)) ->+  P.Sem r x ->+  P.Sem r x requires' name cb m = do-    check <- buildCheck name cb-    requires [check] m+  check <- buildCheck name cb+  requires [check] m  {- | Construct some pure checks and add them to the list of checks for any  commands registered inside the given action.@@ -296,12 +300,12 @@  @ -} requiresPure ::-    (Monad m, DSLC m c a r) =>-    [(T.Text, c -> Maybe T.Text)] ->-    -- A list of check names and check callbacks-    P.Sem r x ->-    P.Sem r x-requiresPure checks = requires $ map (uncurry buildCheckPure) checks+  (Monad m, DSLC m c a r) =>+  [(T.Text, c -> Maybe T.Text)] ->+  -- A list of check names and check callbacks+  P.Sem r x ->+  P.Sem r x+requiresPure checks = requires $ fmap (uncurry buildCheckPure) checks  {- | Construct a group and place any commands registered in the given action  into the new group.@@ -310,12 +314,12 @@  'group'' if you don't want that (i.e. your help function is context aware). -} group ::-    (Monad m, P.Member (P.Final m) r, DSLC m c a r) =>-    -- | The name of the group-    T.Text ->-    P.Sem r x ->-    P.Sem r x-group name m = groupA name [] m+  (Monad m, P.Member (P.Final m) r, DSLC m c a r) =>+  -- | The name of the group+  T.Text ->+  P.Sem r x ->+  P.Sem r x+group name = groupA name []  {- | Construct a group with aliases and place any commands registered in the  given action into the new group.@@ -327,31 +331,31 @@  'group'' if you don't want that (i.e. your help function is context aware). -} groupA ::-    forall x c m a r.-    (Monad m, P.Member (P.Final m) r, DSLC m c a r) =>-    -- | The name of the group-    T.Text ->-    -- | The aliases of the group-    [T.Text] ->-    P.Sem r x ->-    P.Sem r x+  forall x c m a r.+  (Monad m, P.Member (P.Final m) r, DSLC m c a r) =>+  -- | The name of the group+  T.Text ->+  -- | The aliases of the group+  [T.Text] ->+  P.Sem r x ->+  P.Sem r x groupA name aliases m = mdo-    parent <- P.ask @(Maybe (Group m c a))-    hidden <- P.tag $ P.ask @Bool-    checks <- P.ask @[Check m c]-    help' <- P.ask @(c -> T.Text)-    origHelp <- fetchOrigHelp-    let group' = Group (name :| aliases) parent hidden commands children help' checks-    (children, (commands, res)) <--        llisten @(LH.HashMap T.Text (Group m c a, AliasType)) $-            llisten @(LH.HashMap T.Text (Command m c a, AliasType)) $-                P.local @(Maybe (Group m c a)) (const $ Just group') $-                    P.local @(c -> T.Text) (const origHelp) m-    ltell $ LH.singleton name (group', Original)-    ltell $ LH.fromList [(name, (group', Alias)) | name <- aliases]-    pure res+  parent <- P.ask @(Maybe (Group m c a))+  hidden <- P.tag $ P.ask @Bool+  checks <- P.ask @[Check m c]+  help' <- P.ask @(c -> T.Text)+  origHelp <- fetchOrigHelp+  let group' = Group (name :| aliases) parent hidden commands children help' checks+  (children, (commands, res)) <-+    llisten @(LH.HashMap T.Text (Group m c a, AliasType)) $+      llisten @(LH.HashMap T.Text (Command m c a, AliasType)) $+        P.local @(Maybe (Group m c a)) (const $ Just group') $+          P.local @(c -> T.Text) (const origHelp) m+  ltell $ LH.singleton name (group', Original)+  ltell $ LH.fromList [(name, (group', Alias)) | name <- aliases]+  pure res -fetchOrigHelp :: P.Member (P.Tagged "original-help" (P.Reader (c -> T.Text))) r => P.Sem r (c -> T.Text)+fetchOrigHelp :: (P.Member (P.Tagged "original-help" (P.Reader (c -> T.Text))) r) => P.Sem r (c -> T.Text) fetchOrigHelp = P.tag P.ask  {- | Construct a group and place any commands registered in the given action@@ -364,12 +368,12 @@  value. -} group' ::-    (P.Member (P.Final m) r, DSLC m c a r) =>-    -- | The name of the group-    T.Text ->-    P.Sem r x ->-    P.Sem r x-group' name m = groupA' name [] m+  (P.Member (P.Final m) r, DSLC m c a r) =>+  -- | The name of the group+  T.Text ->+  P.Sem r x ->+  P.Sem r x+group' name = groupA' name []  {- | Construct a group with aliases and place any commands registered in the given action  into the new group.@@ -381,28 +385,28 @@  value. -} groupA' ::-    forall x c m a r.-    (P.Member (P.Final m) r, DSLC m c a r) =>-    -- | The name of the group-    T.Text ->-    -- | The aliases of the group-    [T.Text] ->-    P.Sem r x ->-    P.Sem r x+  forall x c m a r.+  (P.Member (P.Final m) r, DSLC m c a r) =>+  -- | The name of the group+  T.Text ->+  -- | The aliases of the group+  [T.Text] ->+  P.Sem r x ->+  P.Sem r x groupA' name aliases m = mdo-    parent <- P.ask @(Maybe (Group m c a))-    hidden <- P.tag $ P.ask @Bool-    checks <- P.ask @[Check m c]-    help' <- P.ask @(c -> T.Text)-    let group' = Group (name :| aliases) parent hidden commands children help' checks-    (children, (commands, res)) <--        llisten @(LH.HashMap T.Text (Group m c a, AliasType)) $-            llisten @(LH.HashMap T.Text (Command m c a, AliasType)) $-                P.local @(Maybe (Group m c a)) (const $ Just group') m-    ltell $ LH.singleton name (group', Original)-    ltell $ LH.fromList [(name, (group', Alias)) | name <- aliases]-    pure res+  parent <- P.ask @(Maybe (Group m c a))+  hidden <- P.tag $ P.ask @Bool+  checks <- P.ask @[Check m c]+  help' <- P.ask @(c -> T.Text)+  let group' = Group (name :| aliases) parent hidden commands children help' checks+  (children, (commands, res)) <-+    llisten @(LH.HashMap T.Text (Group m c a, AliasType)) $+      llisten @(LH.HashMap T.Text (Command m c a, AliasType)) $+        P.local @(Maybe (Group m c a)) (const $ Just group') m+  ltell $ LH.singleton name (group', Original)+  ltell $ LH.fromList [(name, (group', Alias)) | name <- aliases]+  pure res  -- | Retrieve the final command handler for this block-fetchHandler :: DSLC m c a r => P.Sem r (CommandHandler m c a)+fetchHandler :: (DSLC m c a r) => P.Sem r (CommandHandler m c a) fetchHandler = P.ask

@@ -3,25 +3,25 @@ -- | Command errors module CalamityCommands.Error (CommandError (..)) where -import qualified Data.Text as T+import Data.Text qualified as T import TextShow.TH (deriveTextShow)  data CommandError   = ParseError+      -- | The type of the parser       T.Text-      -- ^ The type of the parser+      -- | The reason that parsing failed       T.Text-      -- ^ The reason that parsing failed   | CheckError+      -- | The name of the check that failed       T.Text-      -- ^ The name of the check that failed+      -- | The reason for the check failing       T.Text-      -- ^ The reason for the check failing   | InvokeError+      -- | The name of the command that failed       T.Text-      -- ^ The name of the command that failed+      -- | The reason for failing       T.Text-      -- ^ The reason for failing   deriving (Show)  $(deriveTextShow ''CommandError)

@@ -6,12 +6,12 @@ import CalamityCommands.AliasType import CalamityCommands.Check import {-# SOURCE #-} CalamityCommands.Command-import qualified Data.HashMap.Lazy as LH+import Data.HashMap.Lazy qualified as LH import Data.List.NonEmpty (NonEmpty)-import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T+import Data.List.NonEmpty qualified as NE+import Data.Text qualified as T import Optics-import qualified TextShow+import TextShow qualified import TextShow.TH (deriveTextShow)  -- | A group of commands@@ -19,14 +19,14 @@   { names :: NonEmpty T.Text   , parent :: Maybe (Group m c a)   , hidden :: Bool-  , -- | Any child commands of this group-    commands :: LH.HashMap T.Text (Command m c a, AliasType)-  , -- | Any child groups of this group-    children :: LH.HashMap T.Text (Group m c a, AliasType)-  , -- | A function producing the \'help\' for the group-    help :: c -> T.Text-  , -- | A list of checks that must pass-    checks :: [Check m c]+  , commands :: LH.HashMap T.Text (Command m c a, AliasType)+  -- ^ Any child commands of this group+  , children :: LH.HashMap T.Text (Group m c a, AliasType)+  -- ^ Any child groups of this group+  , help :: c -> T.Text+  -- ^ A function producing the \'help\' for the group+  , checks :: [Check m c]+  -- ^ A list of checks that must pass   }  $(makeFieldLabelsNoPrefix ''Group)

@@ -6,17 +6,17 @@ import CalamityCommands.AliasType import CalamityCommands.Command import CalamityCommands.Group-import qualified Data.HashMap.Lazy as LH-import qualified Data.Text as S+import Data.HashMap.Lazy qualified as LH+import Data.Text qualified as S import Optics.TH-import qualified TextShow+import TextShow qualified import TextShow.TH (deriveTextShow)  data CommandHandler m c a = CommandHandler-  { -- | Top level groups-    groups :: LH.HashMap S.Text (Group m c a, AliasType)-  , -- | Top level commands-    commands :: LH.HashMap S.Text (Command m c a, AliasType)+  { groups :: LH.HashMap S.Text (Group m c a, AliasType)+  -- ^ Top level groups+  , commands :: LH.HashMap S.Text (Command m c a, AliasType)+  -- ^ Top level commands   }  data CommandHandlerS m c a = CommandHandlerS

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}+ -- | A default help command implementation module CalamityCommands.Help (   helpCommand',@@ -12,18 +14,18 @@ import CalamityCommands.Dsl import CalamityCommands.Group import CalamityCommands.Handler-import CalamityCommands.ParameterInfo import CalamityCommands.Internal.LocalWriter+import CalamityCommands.ParameterInfo import Control.Applicative-import Optics-import qualified Data.HashMap.Lazy as LH+import Data.HashMap.Lazy qualified as LH import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty qualified as NE import Data.Maybe (mapMaybe)-import qualified Data.Text as T-import qualified Polysemy as P-import qualified Polysemy.Fail as P-import qualified Polysemy.Reader as P+import Data.Text qualified as T+import Optics+import Polysemy qualified as P+import Polysemy.Fail qualified as P+import Polysemy.Reader qualified as P  data CommandOrGroup m c a   = Command' (Command m c a)@@ -33,50 +35,55 @@ parameterTypeHelp pinfo =   let dedup = LH.toList . LH.fromList $ map (\(ParameterInfo _ t d) -> (t, d)) pinfo       typeDescs = T.unlines ["- " <> T.pack (show t) <> ": " <> d | (t, d) <- dedup]-  in if null dedup-      then ""-      else "Types:\n" <> typeDescs <> "\n"+   in if null dedup+        then ""+        else "Types:\n" <> typeDescs <> "\n"  helpCommandHelp :: c -> T.Text helpCommandHelp _ = "Show help for a command or group." -helpForCommand :: CommandContext m c a => c -> Command m c a -> T.Text-helpForCommand ctx cmd@Command{names, checks, help, params} =-  "Usage: " <> prefix' <> path' <> " " <> params' <> "\n"+helpForCommand :: (CommandContext m c a) => c -> Command m c a -> T.Text+helpForCommand ctx cmd@Command {names, checks, help, params} =+  "Usage: "+    <> prefix'+    <> path'+    <> " "+    <> params'+    <> "\n"     <> aliasesFmt     <> checksFmt     <> parameterTypeHelp params     <> help ctx- where-  prefix' = ctxPrefix ctx-  path' = T.unwords $ commandPath cmd-  params' = commandParams cmd-  aliases = NE.tail names-  checks' = map (^. #name) checks-  aliasesFmt =-    if null aliases-      then ""-      else "Aliases: " <> T.unwords aliases <> "\n"-  checksFmt =-    if null checks'-      then ""-      else "Checks: " <> T.unwords checks' <> "\n\n"+  where+    prefix' = ctxPrefix ctx+    path' = T.unwords $ commandPath cmd+    params' = commandParams cmd+    aliases = NE.tail names+    checks' = map (^. #name) checks+    aliasesFmt =+      if null aliases+        then ""+        else "Aliases: " <> T.unwords aliases <> "\n"+    checksFmt =+      if null checks'+        then ""+        else "Checks: " <> T.unwords checks' <> "\n\n"  fmtCommandWithParams :: Command m c a -> T.Text-fmtCommandWithParams cmd@Command{names} = formatWithAliases names <> " " <> commandParams cmd+fmtCommandWithParams cmd@Command {names} = formatWithAliases names <> " " <> commandParams cmd  formatWithAliases :: NonEmpty T.Text -> T.Text formatWithAliases (name :| aliases) = name <> aliasesFmt- where-  aliasesFmt = case aliases of-    [] -> ""-    aliases' -> "[" <> T.intercalate "|" aliases' <> "]"+  where+    aliasesFmt = case aliases of+      [] -> ""+      aliases' -> "[" <> T.intercalate "|" aliases' <> "]"  onlyOriginals :: [(a, AliasType)] -> [a] onlyOriginals = mapMaybe inner- where-  inner (_, Alias) = Nothing-  inner (a, Original) = Just a+  where+    inner (_, Alias) = Nothing+    inner (a, Original) = Just a  onlyVisibleC :: [Command m c a] -> [Command m c a] onlyVisibleC = mapMaybe notHiddenC@@ -84,60 +91,62 @@ onlyVisibleG :: [Group m c a] -> [Group m c a] onlyVisibleG = mapMaybe notHiddenG -helpForGroup :: CommandContext m c a => c -> Group m c a -> T.Text+helpForGroup :: (CommandContext m c a) => c -> Group m c a -> T.Text helpForGroup ctx grp =-  "Group: " <> path' <> "\n"+  "Group: "+    <> path'+    <> "\n"     <> aliasesFmt     <> checksFmt     <> (grp ^. #help) ctx     <> "\n"     <> groupsMsg     <> commandsMsg- where-  path' = T.unwords $ groupPath grp-  groups = onlyVisibleG . onlyOriginals . LH.elems $ grp ^. #children-  commands = onlyVisibleC . onlyOriginals . LH.elems $ grp ^. #commands-  groupsFmt = map formatWithAliases (groups ^.. traversed % #names)-  groupsMsg =-    if null groups-      then ""-      else "The following child groups exist:\n" <> (T.unlines . map ("- " <>) $ groupsFmt)-  commandsMsg =-    if null commands-      then ""-      else "\nThe following child commands exist:\n" <> (T.unlines . map (("- " <>) . fmtCommandWithParams) $ commands)-  aliases = NE.tail $ grp ^. #names-  checks' = map (^. #name) $ grp ^. #checks-  aliasesFmt =-    if null aliases-      then ""-      else "Aliases: " <> T.unwords aliases <> "\n"-  checksFmt =-    if null checks'-      then ""-      else "Checks: " <> T.unwords checks' <> "\n\n"+  where+    path' = T.unwords $ groupPath grp+    groups = onlyVisibleG . onlyOriginals . LH.elems $ grp ^. #children+    commands = onlyVisibleC . onlyOriginals . LH.elems $ grp ^. #commands+    groupsFmt = map formatWithAliases (groups ^.. traversed % #names)+    groupsMsg =+      if null groups+        then ""+        else "The following child groups exist:\n" <> (T.unlines . map ("- " <>) $ groupsFmt)+    commandsMsg =+      if null commands+        then ""+        else "\nThe following child commands exist:\n" <> (T.unlines . map (("- " <>) . fmtCommandWithParams) $ commands)+    aliases = NE.tail $ grp ^. #names+    checks' = map (^. #name) $ grp ^. #checks+    aliasesFmt =+      if null aliases+        then ""+        else "Aliases: " <> T.unwords aliases <> "\n"+    checksFmt =+      if null checks'+        then ""+        else "Checks: " <> T.unwords checks' <> "\n\n"  rootHelp :: CommandHandler m c a -> T.Text rootHelp handler = groupsMsg <> commandsMsg- where-  groups = onlyVisibleG . onlyOriginals . LH.elems $ handler ^. #groups-  commands = onlyVisibleC . onlyOriginals . LH.elems $ handler ^. #commands-  groupsFmt = map formatWithAliases (groups ^.. traversed % #names)-  groupsMsg =-    if null groups-      then ""-      else "The following groups exist:\n" <> (T.unlines . map ("- " <>) $ groupsFmt)-  commandsMsg =-    if null commands-      then ""-      else "\nThe following commands exist:\n" <> (T.unlines . map (("- " <>) . fmtCommandWithParams) $ commands)+  where+    groups = onlyVisibleG . onlyOriginals . LH.elems $ handler ^. #groups+    commands = onlyVisibleC . onlyOriginals . LH.elems $ handler ^. #commands+    groupsFmt = map formatWithAliases (groups ^.. traversed % #names)+    groupsMsg =+      if null groups+        then ""+        else "The following groups exist:\n" <> (T.unlines . map ("- " <>) $ groupsFmt)+    commandsMsg =+      if null commands+        then ""+        else "\nThe following commands exist:\n" <> (T.unlines . map (("- " <>) . fmtCommandWithParams) $ commands) -renderHelp :: CommandContext m c a => CommandHandler m c a -> c -> [T.Text] -> T.Text+renderHelp :: (CommandContext m c a) => CommandHandler m c a -> c -> [T.Text] -> T.Text renderHelp handler ctx path =   case findCommandOrGroup handler path of-    Just (Command' cmd@Command{names}) ->+    Just (Command' cmd@Command {names}) ->       "Help for command `" <> NE.head names <> "`: \n" <> helpForCommand ctx cmd-    Just (Group' grp@Group{names} remainingPath) ->+    Just (Group' grp@Group {names} remainingPath) ->       let failedMsg =             if null remainingPath               then ""@@ -232,22 +241,22 @@   pure cmd  notHiddenC :: Command m c a -> Maybe (Command m c a)-notHiddenC c@Command{hidden} = if hidden then Nothing else Just c+notHiddenC c@Command {hidden} = if hidden then Nothing else Just c  notHiddenG :: Group m c a -> Maybe (Group m c a)-notHiddenG g@Group{hidden} = if hidden then Nothing else Just g+notHiddenG g@Group {hidden} = if hidden then Nothing else Just g  findCommandOrGroup :: CommandHandler m c a -> [T.Text] -> Maybe (CommandOrGroup m c a)-findCommandOrGroup handler path = go (handler ^. #commands, handler ^. #groups) path- where-  go ::-    (LH.HashMap T.Text (Command m c a, AliasType), LH.HashMap T.Text (Group m c a, AliasType)) ->-    [T.Text] ->-    Maybe (CommandOrGroup m c a)-  go (commands, groups) (x : xs) =-    case LH.lookup x commands of-      Just (notHiddenC -> Just cmd, _) -> Just (Command' cmd)-      _ -> case LH.lookup x groups of-        Just (notHiddenG -> Just group, _) -> go (group ^. #commands, group ^. #children) xs <|> Just (Group' group xs)-        _ -> Nothing-  go _ [] = Nothing+findCommandOrGroup handler = go (handler ^. #commands, handler ^. #groups)+  where+    go ::+      (LH.HashMap T.Text (Command m c a, AliasType), LH.HashMap T.Text (Group m c a, AliasType)) ->+      [T.Text] ->+      Maybe (CommandOrGroup m c a)+    go (commands, groups) (x : xs) =+      case LH.lookup x commands of+        Just (notHiddenC -> Just cmd, _) -> Just (Command' cmd)+        _ -> case LH.lookup x groups of+          Just (notHiddenG -> Just group, _) -> go (group ^. #commands, group ^. #children) xs <|> Just (Group' group xs)+          _ -> Nothing+    go _ [] = Nothing

@@ -1,14 +1,15 @@ {-# LANGUAGE TemplateHaskell #-}  -- | A Writer monad that supports local writing, reverse reader I guess?-module CalamityCommands.Internal.LocalWriter-    ( LocalWriter(..)-    , ltell-    , llisten-    , runLocalWriter ) where+module CalamityCommands.Internal.LocalWriter (+  LocalWriter (..),+  ltell,+  llisten,+  runLocalWriter,+) where -import qualified Polysemy       as P-import qualified Polysemy.State as P+import Polysemy qualified as P+import Polysemy.State qualified as P  data LocalWriter o m a where   Ltell :: o -> LocalWriter o m ()@@ -16,12 +17,15 @@  P.makeSem ''LocalWriter -runLocalWriter :: Monoid o => P.Sem (LocalWriter o ': r) a -> P.Sem r (o, a)-runLocalWriter = P.runState mempty . P.reinterpretH-  (\case-     Ltell o   -> do-       P.modify' (<> o) >>= P.pureT-     Llisten m -> do-       mm <- P.runT m-       (o, fa) <- P.raise $ runLocalWriter mm-       pure $ fmap (o, ) fa)+runLocalWriter :: (Monoid o) => P.Sem (LocalWriter o ': r) a -> P.Sem r (o, a)+runLocalWriter =+  P.runState mempty+    . P.reinterpretH+      ( \case+          Ltell o -> do+            P.modify' (<> o) >>= P.pureT+          Llisten m -> do+            mm <- P.runT m+            (o, fa) <- P.raise $ runLocalWriter mm+            pure $ fmap (o,) fa+      )

@@ -1,14 +1,13 @@-{-# LANGUAGE TemplateHaskell #-}- -- | Something for converting polysemy actions into monadic actions-module CalamityCommands.Internal.RunIntoM-    ( runSemToM-    , bindSemToM ) where+module CalamityCommands.Internal.RunIntoM (+  runSemToM,+  bindSemToM,+) where -import           Data.Functor+import Data.Functor -import qualified Polysemy                         as P-import qualified Polysemy.Final                   as P+import Polysemy qualified as P+import Polysemy.Final qualified as P  runSemToM :: forall m r a. (Monad m, P.Member (P.Final m) r) => P.Sem r a -> P.Sem r (m (Maybe a)) runSemToM m = P.withStrategicToFinal $ do

@@ -57,16 +57,16 @@ --             _ -> --               go action' -whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()+whenJust :: (Applicative m) => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe (pure ()) -whenM :: Monad m => m Bool -> m () -> m ()+whenM :: (Monad m) => m Bool -> m () -> m () whenM p m =   p >>= \case     True -> m     False -> pure () -unlessM :: Monad m => m Bool -> m () -> m ()+unlessM :: (Monad m) => m Bool -> m () -> m () unlessM = whenM . (not <$>)  lastMaybe :: Maybe a -> Maybe a -> Maybe a@@ -98,7 +98,7 @@  infixl 4 <<*>> -(<.>) :: Functor f => (a -> b) -> (c -> f a) -> (c -> f b)+(<.>) :: (Functor f) => (a -> b) -> (c -> f a) -> (c -> f b) (<.>) f g x = f <$> g x  infixl 4 <.>

@@ -5,7 +5,7 @@   ParameterInfo (..), ) where -import qualified Data.Text as S+import Data.Text qualified as S import Data.Typeable import Optics.TH (makeFieldLabelsNoPrefix) import TextShow.TH (deriveTextShow)

@@ -7,9 +7,9 @@   useConstantPrefix, ) where -import qualified Data.Text as T+import Data.Text qualified as T -import qualified Polysemy as P+import Polysemy qualified as P  -- | An effect for parsing the prefix of a command. data ParsePrefix msg m a where

@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}  -- | Something that can parse user input module CalamityCommands.Parser (@@ -18,21 +19,21 @@ import CalamityCommands.ParameterInfo  import Control.Monad-import Optics import Data.Char (isSpace) import Data.Kind import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromMaybe) import Data.Semigroup-import qualified Data.Text as T-import qualified Data.Text.Lazy as L+import Data.Text qualified as T+import Data.Text.Lazy qualified as L import Data.Typeable import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)-import qualified Polysemy as P-import qualified Polysemy.Error as P-import qualified Polysemy.Reader as P-import qualified Polysemy.State as P import Numeric.Natural (Natural)+import Optics+import Polysemy qualified as P+import Polysemy.Error qualified as P+import Polysemy.Reader qualified as P+import Polysemy.State qualified as P import Text.Megaparsec hiding (parse) import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer (decimal, float, signed)@@ -48,21 +49,20 @@  that parse a parameter from anywhere in the input message. -} data ParserState = ParserState-  { -- | The current offset, or where the next parser should start parsing at-    off :: Int-  , -- | The input message ot parse-    msg :: T.Text+  { off :: Int+  -- ^ The current offset, or where the next parser should start parsing at+  , msg :: T.Text+  -- ^ The input message ot parse   }   deriving (Show)  $(makeFieldLabelsNoPrefix ''ParserState) --- | type ParserEffs c r =   ( P.State ParserState       ': P.Error (T.Text, T.Text) -- (failing parser name, error reason)-        ': P.Reader c -- the current parser state-          ': r -- context+      ': P.Reader c -- the current parser state+      ': r -- context   )  -- | Run a command parser, @ctx@ is the context, @t@ is the text input@@ -75,7 +75,7 @@  parameter @ps@ of 'CalamityCommands.Dsl.command',  'CalamityCommands.CommandUtils.buildCommand', etc. -}-class Typeable a => ParameterParser (a :: Type) c r where+class (Typeable a) => ParameterParser (a :: Type) c r where   type ParserResult a    type ParserResult a = a@@ -104,12 +104,12 @@    parse = mapE (_1 .~ parserName @(Named s a) @c @r) $ parse @a @c @r -parserName :: forall a c r. ParameterParser a c r => T.Text+parserName :: forall a c r. (ParameterParser a c r) => T.Text parserName =   let ParameterInfo (fromMaybe "" -> name) type_ _ = parameterInfo @a @c @r    in name <> ":" <> T.pack (show type_) -mapE :: P.Member (P.Error e) r => (e -> e) -> P.Sem r a -> P.Sem r a+mapE :: (P.Member (P.Error e) r) => (e -> e) -> P.Sem r a -> P.Sem r a mapE f m = P.catch m (P.throw . f)  {- | Parse a paremeter using a MegaParsec parser.@@ -159,7 +159,7 @@   parse = parseMP (parserName @Float) (signed mempty (try float <|> decimal))   parameterDescription = "number" -instance ParameterParser a c r => ParameterParser (Maybe a) c r where+instance (ParameterParser a c r) => ParameterParser (Maybe a) c r where   type ParserResult (Maybe a) = Maybe (ParserResult a)    parse = P.catch (Just <$> parse @a) (const $ pure Nothing)@@ -176,16 +176,16 @@         Right <$> parse @b @c @r   parameterDescription = "either '" <> parameterDescription @a @c @r <> "' or '" <> parameterDescription @b @c @r <> "'" -instance ParameterParser a c r => ParameterParser [a] c r where+instance (ParameterParser a c r) => ParameterParser [a] c r where   type ParserResult [a] = [ParserResult a]    parse = go []-   where-    go :: [ParserResult a] -> P.Sem (ParserEffs c r) [ParserResult a]-    go l =-      P.catch (Just <$> parse @a) (const $ pure Nothing) >>= \case-        Just a -> go $ l <> [a]-        Nothing -> pure l+    where+      go :: [ParserResult a] -> P.Sem (ParserEffs c r) [ParserResult a]+      go l =+        P.catch (Just <$> parse @a) (const $ pure Nothing) >>= \case+          Just a -> go $ l <> [a]+          Nothing -> pure l    parameterDescription = "zero or more '" <> parameterDescription @a @c @r <> "'" @@ -271,23 +271,23 @@ skipN :: (Stream s, Ord e) => Int -> ParsecT e s m () skipN n = void $ takeP Nothing n -trackOffsets :: MonadParsec e s m => m a -> m (a, Int)+trackOffsets :: (MonadParsec e s m) => m a -> m (a, Int) trackOffsets m = do   offs <- getOffset   a <- m   offe <- getOffset   pure (a, offe - offs) -item :: MonadParsec e T.Text m => m T.Text+item :: (MonadParsec e T.Text m) => m T.Text item = try quotedString <|> someNonWS -manySingle :: MonadParsec e s m => m (Tokens s)+manySingle :: (MonadParsec e s m) => m (Tokens s) manySingle = takeWhileP (Just "Any character") (const True) -someSingle :: MonadParsec e s m => m (Tokens s)+someSingle :: (MonadParsec e s m) => m (Tokens s) someSingle = takeWhile1P (Just "any character") (const True) -quotedString :: MonadParsec e T.Text m => m T.Text+quotedString :: (MonadParsec e T.Text m) => m T.Text quotedString =   try (between (chunk "'") (chunk "'") (takeWhileP (Just "any character") (/= '\'')))     <|> between (chunk "\"") (chunk "\"") (takeWhileP (Just "any character") (/= '"'))

@@ -1,4 +1,5 @@ {-# LANGUAGE RecursiveDo #-}+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}  -- | Command handler utilities module CalamityCommands.Utils (@@ -21,14 +22,14 @@ import CalamityCommands.ParsePrefix import Control.Monad.Fix (MonadFix) import Data.Char (isSpace)-import qualified Data.HashMap.Lazy as LH-import qualified Data.Text as T-import qualified Polysemy as P-import qualified Polysemy.Error as P-import qualified Polysemy.Fixpoint as P-import qualified Polysemy.Reader as P-import qualified Polysemy.Tagged as P+import Data.HashMap.Lazy qualified as LH+import Data.Text qualified as T import Optics+import Polysemy qualified as P+import Polysemy.Error qualified as P+import Polysemy.Fixpoint qualified as P+import Polysemy.Reader qualified as P+import Polysemy.Tagged qualified as P  mapLeft :: (e -> e') -> Either e a -> Either e' a mapLeft f (Left x) = Left $ f x@@ -96,27 +97,27 @@   (groups, (cmds, a)) <- inner handler m   let handler = CommandHandler groups cmds   pure (handler, a)- where-  inner ::-    CommandHandler m c a ->-    P.Sem (DSLState m c a r) x ->-    P.Sem-      (P.Fixpoint ': r)-      ( LH.HashMap T.Text (Group m c a, AliasType)-      , (LH.HashMap T.Text (Command m c a, AliasType), x)-      )-  inner h =-    P.runReader h-      . P.runReader []-      . P.runReader defaultHelp-      . P.untag @"original-help"-      . P.runReader defaultHelp-      . P.runReader False-      . P.untag @"hidden"-      . P.runReader Nothing-      . runLocalWriter @(LH.HashMap T.Text (Group m c a, AliasType))-      . runLocalWriter @(LH.HashMap T.Text (Command m c a, AliasType))-  defaultHelp = const "This command or group has no help."+  where+    inner ::+      CommandHandler m c a ->+      P.Sem (DSLState m c a r) x ->+      P.Sem+        (P.Fixpoint ': r)+        ( LH.HashMap T.Text (Group m c a, AliasType)+        , (LH.HashMap T.Text (Command m c a, AliasType), x)+        )+    inner h =+      P.runReader h+        . P.runReader []+        . P.runReader defaultHelp+        . P.untag @"original-help"+        . P.runReader defaultHelp+        . P.runReader False+        . P.untag @"hidden"+        . P.runReader Nothing+        . runLocalWriter @(LH.HashMap T.Text (Group m c a, AliasType))+        . runLocalWriter @(LH.HashMap T.Text (Command m c a, AliasType))+    defaultHelp = const "This command or group has no help."  nextWord :: T.Text -> (T.Text, T.Text) nextWord = T.break isSpace . T.stripStart@@ -135,29 +136,29 @@ -} findCommand :: forall c a m. CommandHandler m c a -> T.Text -> Either [T.Text] (Command m c a, T.Text) findCommand handler msg = goH $ nextWord msg- where-  goH :: (T.Text, T.Text) -> Either [T.Text] (Command m c a, T.Text)-  goH ("", _) = Left []-  goH (x, xs) =-    attachSoFar-      x-      ( ((,xs) <$> attachInitial (LH.lookup x (handler ^. #commands)))-          <> (attachInitial (LH.lookup x (handler ^. #groups)) >>= goG (nextWord xs))-      )+  where+    goH :: (T.Text, T.Text) -> Either [T.Text] (Command m c a, T.Text)+    goH ("", _) = Left []+    goH (x, xs) =+      attachSoFar+        x+        ( ((,xs) <$> attachInitial (LH.lookup x (handler ^. #commands)))+            <> (attachInitial (LH.lookup x (handler ^. #groups)) >>= goG (nextWord xs))+        ) -  goG :: (T.Text, T.Text) -> Group m c a -> Either [T.Text] (Command m c a, T.Text)-  goG ("", _) _ = Left []-  goG (x, xs) g =-    attachSoFar-      x-      ( ((,xs) <$> attachInitial (LH.lookup x (g ^. #commands)))-          <> (attachInitial (LH.lookup x (g ^. #children)) >>= goG (nextWord xs))-      )+    goG :: (T.Text, T.Text) -> Group m c a -> Either [T.Text] (Command m c a, T.Text)+    goG ("", _) _ = Left []+    goG (x, xs) g =+      attachSoFar+        x+        ( ((,xs) <$> attachInitial (LH.lookup x (g ^. #commands)))+            <> (attachInitial (LH.lookup x (g ^. #children)) >>= goG (nextWord xs))+        ) -  attachInitial :: forall a b. Maybe (a, b) -> Either [T.Text] a-  attachInitial (Just (a, _)) = Right a-  attachInitial Nothing = Left []+    attachInitial :: forall a b. Maybe (a, b) -> Either [T.Text] a+    attachInitial (Just (a, _)) = Right a+    attachInitial Nothing = Left [] -  attachSoFar :: forall a. T.Text -> Either [T.Text] a -> Either [T.Text] a-  attachSoFar cmd (Left xs) = Left (cmd : xs)-  attachSoFar _ r = r+    attachSoFar :: forall a. T.Text -> Either [T.Text] a -> Either [T.Text] a+    attachSoFar cmd (Left xs) = Left (cmd : xs)+    attachSoFar _ r = r

@@ -1,114 +1,115 @@-cabal-version: 1.18+cabal-version:      2.0+name:               calamity-commands+version:            0.4.1.0+synopsis:+  A library for declaring, parsing, and invoking text-input based commands --- This file has been generated from package.yaml by hpack version 0.34.4.------ see: https://github.com/sol/hpack+description:+  Please see the README on GitHub at <https://github.com/simmsb/calamity#readme> -name:           calamity-commands-version:        0.4.0.0-synopsis:       A library for declaring, parsing, and invoking text-input based commands-description:    Please see the README on GitHub at <https://github.com/simmsb/calamity#readme>-category:       Utils-homepage:       https://github.com/simmsb/calamity-bug-reports:    https://github.com/simmsb/calamity/issues-author:         Ben Simms-maintainer:     ben@bensimms.moe-copyright:      2020 Ben Simms-license:        MIT-license-file:   LICENSE-build-type:     Simple-tested-with:-    GHC == 8.10.7, GHC == 9.2.2+category:           Utils+homepage:           https://github.com/simmsb/calamity+bug-reports:        https://github.com/simmsb/calamity/issues+author:             Ben Simms+maintainer:         ben@bensimms.moe+copyright:          2020 Ben Simms+license:            MIT+license-file:       LICENSE+build-type:         Simple+tested-with:        GHC ==9.4.4 extra-source-files:-    README.md-    ChangeLog.md-extra-doc-files:-    README.md+  ChangeLog.md+  README.md +extra-doc-files:    README.md+ source-repository head-  type: git+  type:     git   location: https://github.com/simmsb/calamity  library   exposed-modules:-      CalamityCommands-      CalamityCommands.AliasType-      CalamityCommands.Check-      CalamityCommands.Command-      CalamityCommands.CommandUtils-      CalamityCommands.Context-      CalamityCommands.Dsl-      CalamityCommands.Error-      CalamityCommands.Group-      CalamityCommands.Handler-      CalamityCommands.Help-      CalamityCommands.Internal.LocalWriter-      CalamityCommands.Internal.RunIntoM-      CalamityCommands.Internal.Utils-      CalamityCommands.ParameterInfo-      CalamityCommands.ParsePrefix-      CalamityCommands.Parser-      CalamityCommands.Utils-  hs-source-dirs:-      ./+    CalamityCommands+    CalamityCommands.AliasType+    CalamityCommands.Check+    CalamityCommands.Command+    CalamityCommands.CommandUtils+    CalamityCommands.Context+    CalamityCommands.Dsl+    CalamityCommands.Error+    CalamityCommands.Group+    CalamityCommands.Handler+    CalamityCommands.Help+    CalamityCommands.Internal.LocalWriter+    CalamityCommands.Internal.RunIntoM+    CalamityCommands.Internal.Utils+    CalamityCommands.ParameterInfo+    CalamityCommands.ParsePrefix+    CalamityCommands.Parser+    CalamityCommands.Utils++  hs-source-dirs:     ./   default-extensions:-      StrictData-      AllowAmbiguousTypes-      BlockArguments-      NoMonomorphismRestriction-      BangPatterns-      BinaryLiterals-      UndecidableInstances-      ConstraintKinds-      DataKinds-      DefaultSignatures-      DeriveDataTypeable-      DeriveFoldable-      DeriveFunctor-      DeriveGeneric-      DeriveTraversable-      DoAndIfThenElse-      EmptyDataDecls-      ExistentialQuantification-      FlexibleContexts-      FlexibleInstances-      FunctionalDependencies-      GADTs-      DerivingVia-      DerivingStrategies-      GeneralizedNewtypeDeriving-      StandaloneDeriving-      DeriveAnyClass-      InstanceSigs-      KindSignatures-      LambdaCase-      MultiParamTypeClasses-      MultiWayIf-      NamedFieldPuns-      OverloadedStrings-      OverloadedLabels-      PartialTypeSignatures-      PatternGuards-      PolyKinds-      RankNTypes-      RecordWildCards-      ScopedTypeVariables-      TupleSections-      TypeFamilies-      TypeSynonymInstances-      ViewPatterns-      DuplicateRecordFields-      TypeOperators-      TypeApplications-      RoleAnnotations-  ghc-options: -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall -fno-warn-name-shadowing+    AllowAmbiguousTypes+    BangPatterns+    BinaryLiterals+    BlockArguments+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveAnyClass+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveTraversable+    DerivingStrategies+    DerivingVia+    DoAndIfThenElse+    DuplicateRecordFields+    EmptyDataDecls+    ExistentialQuantification+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    InstanceSigs+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    NamedFieldPuns+    NoMonomorphismRestriction+    OverloadedLabels+    OverloadedStrings+    PartialTypeSignatures+    PatternGuards+    PolyKinds+    RankNTypes+    RecordWildCards+    RoleAnnotations+    ScopedTypeVariables+    StandaloneDeriving+    StrictData+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+    TypeSynonymInstances+    UndecidableInstances+    ViewPatterns++  ghc-options:        -funbox-strict-fields -Wall -fno-warn-name-shadowing   build-depends:-      base >=4.13 && <5-    , optics >=0.4.1 && <0.5-    , megaparsec >=8 && <10-    , polysemy >=1.5 && <2-    , polysemy-plugin >=0.3 && <0.5-    , text >=1.2 && <2.1-    , text-show >=3.8 && <4-    , unordered-containers ==0.2.*-  default-language: Haskell2010+      base                  >=4.13  && <5+    , megaparsec            >=8     && <10+    , optics                >=0.4.1 && <0.5+    , polysemy              >=1.5   && <2+    , polysemy-plugin       >=0.3   && <0.5+    , text                  >=1.2   && <2.2+    , text-show             >=3.8   && <4+    , unordered-containers  >=0.2   && <0.3++  default-language:   Haskell2010