butcher 1.2.1.0 → 1.3.0.0

raw patch · 14 files changed

+1753/−1244 lines, 14 filesdep −eitherPVP ok

version bump matches the API change (PVP)

Dependencies removed: either

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• butcher.cabal +3/−5
• src-tests/TestMain.hs +33/−3
• src/UI/Butcher/Monadic.hs +4/−0
• src/UI/Butcher/Monadic/BuiltinCommands.hs +112/−9
• src/UI/Butcher/Monadic/Command.hs +1/−0
• src/UI/Butcher/Monadic/Flag.hs +32/−13
• src/UI/Butcher/Monadic/Interactive.hs +75/−13
• src/UI/Butcher/Monadic/Internal/Core.hs +1241/−1149
• src/UI/Butcher/Monadic/Internal/Types.hs +27/−4
• src/UI/Butcher/Monadic/Param.hs +60/−16
• src/UI/Butcher/Monadic/Pretty.hs +156/−30
• src/UI/Butcher/Monadic/Types.hs +1/−0
• srcinc/prelude.inc +0/−2

@@ -1,5 +1,13 @@ # Revision history for butcher +## 1.3.0.0  -- February 2018++* Experimental: Hidden commandparts (do not appear in help)+* Experimental: Bash completion+* Add addHelpCommandWith to support user-defined column count+* Fix help document printing (ribbons)+* Fix completion behaviour+ ## 1.2.1.0  -- November 2017  * Fix bug in 'ppUsageWithHelp'

@@ -1,5 +1,5 @@ name:                butcher-version:             1.2.1.0+version:             1.3.0.0 synopsis:            Chops a command or program invocation into digestable pieces. description:         See the <https://github.com/lspitzner/butcher/blob/master/README.md README> (it is properly formatted on github). license:             BSD3@@ -45,12 +45,11 @@     { base >=4.8 && <4.11     , free     , unsafe-    , microlens-    , microlens-th+    , microlens <0.5+    , microlens-th <0.5     , multistate     , pretty     , containers-    , either     , transformers     , mtl     , extra@@ -113,7 +112,6 @@     , multistate     , pretty     , containers-    , either     , transformers     , mtl     , extra

@@ -10,6 +10,7 @@  import UI.Butcher.Monadic import UI.Butcher.Monadic.Types+import UI.Butcher.Monadic.Interactive   @@ -31,7 +32,7 @@ simpleParseTest :: Spec simpleParseTest = do   it "failed parse 001" $ runCmdParser Nothing (InputString "foo") testCmd1-         `shouldSatisfy` Data.Either.Combinators.isLeft . snd+         `shouldSatisfy` Data.Either.isLeft . snd   it "toplevel" $ (testParse testCmd1 "" >>= _cmd_out)                   `shouldSatisfy` Maybe.isNothing   it "hasImpl 001" $ (testParse testCmd1 "abc" >>= _cmd_out)@@ -50,8 +51,8 @@     it "flag 2" $ testRun testCmd1 "abc --flong" `shouldBe` Right (Just 101)     it "flag 3" $ testRun testCmd1 "abc -f -f" `shouldBe` Right (Just 101)     it "flag 4" $ testRun testCmd1 "abc -f -g" `shouldBe` Right (Just 103)-    it "flag 5" $ testRun testCmd1 "abc -f -g -f" `shouldSatisfy` Data.Either.Combinators.isLeft -- no reordering-    it "flag 6" $ testRun testCmd1 "abc -g -f" `shouldSatisfy` Data.Either.Combinators.isLeft -- no reordering+    it "flag 5" $ testRun testCmd1 "abc -f -g -f" `shouldSatisfy` Data.Either.isLeft -- no reordering+    it "flag 6" $ testRun testCmd1 "abc -g -f" `shouldSatisfy` Data.Either.isLeft -- no reordering     it "flag 7" $ testRun testCmd1 "abc -g -g" `shouldBe` Right (Just 102)   describe "with reordering" $ do     it "cmd 1" $ testRun testCmd2 "abc" `shouldBe` Right (Just 100)@@ -117,6 +118,18 @@     it "case 4" $ testRun' testCmd7 "abc -f" `shouldBe` Right (Just (["abc"], 1))     it "case 5" $ testRun' testCmd7 "-g abc -f" `shouldBe` Right (Just (["abc"], 3))     it "case 6" $ testRun' testCmd7 "abc -g def" `shouldBe` Right (Just (["abc", "def"], 2))+  describe "completions" $ do+    it "case  1" $ testCompletion completionTestCmd "" `shouldBe` ""+    it "case  2" $ testCompletion completionTestCmd "a" `shouldBe` "bc"+    it "case  3" $ testCompletion completionTestCmd "abc" `shouldBe` "def"+    it "case  4" $ testCompletion completionTestCmd "abc " `shouldBe` "-"+    it "case  5" $ testCompletion completionTestCmd "abc -" `shouldBe` ""+    it "case  6" $ testCompletion completionTestCmd "abc --" `shouldBe` "flag"+    it "case  7" $ testCompletion completionTestCmd "abc -f" `shouldBe` ""+    it "case  8" $ testCompletion completionTestCmd "abcd" `shouldBe` "ef"+    it "case  9" $ testCompletion completionTestCmd "gh" `shouldBe` "i"+    it "case 10" $ testCompletion completionTestCmd "ghi" `shouldBe` ""+    it "case 11" $ testCompletion completionTestCmd "ghi " `shouldBe` "jkl"   @@ -201,6 +214,23 @@     when f $ WriterS.tell 1     when g $ WriterS.tell 2     pure args++completionTestCmd :: CmdParser Identity () ()+completionTestCmd = do+  addCmd "abc" $ do+    _ <- addSimpleBoolFlag "f" ["flag"] mempty+    addCmdImpl ()+  addCmd "abcdef" $ do+    _ <- addSimpleBoolFlag "f" ["flag"] mempty+    addCmdImpl ()+  addCmd "ghi" $ do+    addCmd "jkl" $ do+      addCmdImpl ()++testCompletion :: CmdParser Identity a () -> String -> String+testCompletion p inp = case runCmdParserExt Nothing (InputString inp) p of+  (cDesc, InputString cRest, _) -> simpleCompletion inp cDesc cRest+  _ -> error "wut"   testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out)

@@ -28,7 +28,11 @@   -- , test3     -- * Builtin commands   , addHelpCommand+  , addHelpCommand2+  , addHelpCommandWith   , addButcherDebugCommand+  , addShellCompletionCommand+  , addShellCompletionCommand'   , mapOut   ) where

@@ -1,8 +1,12 @@ -- | Some CmdParser actions that add predefined commands. module UI.Butcher.Monadic.BuiltinCommands   ( addHelpCommand+  , addHelpCommand2+  , addHelpCommandWith   , addHelpCommandShallow   , addButcherDebugCommand+  , addShellCompletionCommand+  , addShellCompletionCommand'   ) where @@ -21,6 +25,7 @@ import           UI.Butcher.Monadic.Internal.Core import           UI.Butcher.Monadic.Pretty import           UI.Butcher.Monadic.Param+import           UI.Butcher.Monadic.Interactive  import           System.IO @@ -29,19 +34,50 @@ -- | Adds a proper full help command. To obtain the 'CommandDesc' value, see -- 'UI.Butcher.Monadic.cmdRunParserWithHelpDesc' or -- 'UI.Butcher.Monadic.IO.mainFromCmdParserWithHelpDesc'.-addHelpCommand :: Applicative f => CommandDesc () -> CmdParser f (IO ()) ()-addHelpCommand desc = addCmd "help" $ do+--+-- > addHelpCommand = addHelpCommandWith+-- >   (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpShallow)+addHelpCommand :: Applicative f => CommandDesc a -> CmdParser f (IO ()) ()+addHelpCommand = addHelpCommandWith+  (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpShallow)++-- | Adds a proper full help command. In contrast to 'addHelpCommand',+-- this version is a bit more verbose about available subcommands as it+-- includes their synopses.+--+-- To obtain the 'CommandDesc' value, see+-- 'UI.Butcher.Monadic.cmdRunParserWithHelpDesc' or+-- 'UI.Butcher.Monadic.IO.mainFromCmdParserWithHelpDesc'.+--+-- > addHelpCommand2 = addHelpCommandWith+-- >   (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpDepthOne)+addHelpCommand2 :: Applicative f => CommandDesc a -> CmdParser f (IO ()) ()+addHelpCommand2 = addHelpCommandWith+  (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpDepthOne)++-- | Adds a proper full help command, using the specified function to turn+-- the relevant subcommand's 'CommandDesc' into a String.+addHelpCommandWith+  :: Applicative f+  => (CommandDesc a -> IO String)+  -> CommandDesc a+  -> CmdParser f (IO ()) ()+addHelpCommandWith f desc = addCmd "help" $ do+  addCmdSynopsis "print help about this command"   rest <- addParamRestOfInput "SUBCOMMAND(s)" mempty   addCmdImpl $ do-    let parentDesc = maybe undefined snd (_cmd_mParent desc)-    let restWords  = List.words rest-    let descent :: [String] -> CommandDesc a -> CommandDesc a-        descent [] curDesc = curDesc-        descent (w:wr) curDesc =-          case List.lookup (Just w) $ Data.Foldable.toList $ _cmd_children curDesc of+    let restWords = List.words rest+    let+      descent :: [String] -> CommandDesc a -> CommandDesc a+      descent [] curDesc = curDesc+      descent (w:wr) curDesc =+        case+            List.lookup (Just w) $ Data.Foldable.toList $ _cmd_children curDesc+          of             Nothing    -> curDesc             Just child -> descent wr child-    print $ ppHelpShallow $ descent restWords parentDesc+    s <- f $ descent restWords desc+    putStrLn s  -- | Adds a help command that prints help for the command currently in context. --@@ -65,4 +101,71 @@   desc <- peekCmdDesc   addCmdImpl $ do     print $ maybe undefined snd (_cmd_mParent desc)++-- | Adds the "completion" command and several subcommands.+--+-- This command can be used in the following manner:+--+-- > $ source <(foo completion bash-script foo)+addShellCompletionCommand+  :: CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()+addShellCompletionCommand mainCmdParser = do+  addCmdHidden "completion" $ do+    addCmdSynopsis "utilites to enable bash-completion"+    addCmd "bash-script" $ do+      addCmdSynopsis "generate a bash script for completion functionality"+      exeName <- addParamString "EXENAME" mempty+      addCmdImpl $ do+        putStr $ completionScriptBash exeName+    addCmd "bash-gen" $ do+      addCmdSynopsis+        "generate possible completions for given input arguments"+      rest <- addParamRestOfInputRaw "REALCOMMAND" mempty+      addCmdImpl $ do+        let (cdesc, remaining, _result) =+              runCmdParserExt Nothing rest mainCmdParser+        let+          compls = shellCompletionWords (inputString rest)+                                        cdesc+                                        (inputString remaining)+        let lastWord =+              reverse $ takeWhile (not . Char.isSpace) $ reverse $ inputString+                rest+        putStrLn $ List.unlines $ compls <&> \case+          CompletionString s  -> s+          CompletionFile      -> "$(compgen -f -- " ++ lastWord ++ ")"+          CompletionDirectory -> "$(compgen -d -- " ++ lastWord ++ ")"+ where+  inputString (InputString s ) = s+  inputString (InputArgs   as) = List.unwords as++-- | Adds the "completion" command and several subcommands+--+-- This command can be used in the following manner:+--+-- > $ source <(foo completion bash-script foo)+addShellCompletionCommand'+  :: (CommandDesc out -> CmdParser Identity (IO ()) ())+  -> CmdParser Identity (IO ()) ()+addShellCompletionCommand' f = addShellCompletionCommand (f emptyCommandDesc)++completionScriptBash :: String -> String+completionScriptBash exeName =+  List.unlines+    $ [ "function _" ++ exeName ++ "()"+      , "{"+      , "  local IFS=$'\\n'"+      , "  COMPREPLY=()"+      , "  local result=$("+      ++ exeName+      ++ " completion bash-gen \"${COMP_WORDS[@]:1}\")"+      , "  for r in ${result[@]}; do"+      , "    local IFS=$'\\n '"+      , "    for s in $(eval echo ${r}); do"+      , "      COMPREPLY+=(${s})"+      , "    done"+      , "  done"+      , "}"+      , "complete -F _" ++ exeName ++ " " ++ exeName+      ] 

@@ -53,6 +53,7 @@  module UI.Butcher.Monadic.Command   ( addCmd+  , addCmdHidden   , addNullCmd   , addCmdImpl   , addCmdSynopsis

@@ -15,6 +15,7 @@   , flagHelp   , flagHelpStr   , flagDefault+  , flagHidden   , addSimpleBoolFlag   , addSimpleCountFlag   , addSimpleFlagA@@ -74,13 +75,19 @@ -- | flag-description monoid. You probably won't need to use the constructor; -- mzero or any (<>) of flag(Help|Default) works well. data Flag p = Flag-  { _flag_help    :: Maybe PP.Doc-  , _flag_default :: Maybe p+  { _flag_help       :: Maybe PP.Doc+  , _flag_default    :: Maybe p+  , _flag_visibility :: Visibility   }  instance Monoid (Flag p) where-  mempty = Flag Nothing Nothing-  Flag a1 b1 `mappend` Flag a2 b2 = Flag (a1 <|> a2) (b1 <|> b2)+  mempty = Flag Nothing Nothing Visible+  Flag a1 b1 c1 `mappend` Flag a2 b2 c2 = Flag (a1 <|> a2)+                                               (b1 <|> b2)+                                               (appVis c1 c2)+   where+    appVis Visible Visible = Visible+    appVis _       _       = Hidden  -- | Create a 'Flag' with just a help text. flagHelp :: PP.Doc -> Flag p@@ -88,12 +95,25 @@  -- | Create a 'Flag' with just a help text. flagHelpStr :: String -> Flag p-flagHelpStr s = mempty { _flag_help = Just $ PP.text s }+flagHelpStr s =+  mempty { _flag_help = Just $ PP.fsep $ fmap PP.text $ List.words s }  -- | Create a 'Flag' with just a default value. flagDefault :: p -> Flag p flagDefault d = mempty { _flag_default = Just d } +-- | Create a 'Flag' marked as hidden. Similar to hidden commands, hidden+-- flags will not included in pretty-printing (help, usage etc.)+--+-- This feature is not well tested yet.+flagHidden :: Flag p+flagHidden = mempty { _flag_visibility = Hidden }++wrapHidden :: Flag p -> PartDesc -> PartDesc+wrapHidden f = case _flag_visibility f of+  Visible -> id+  Hidden  -> PartHidden+ -- | A no-parameter flag where non-occurence means False, occurence means True. addSimpleBoolFlag   :: Applicative f@@ -121,7 +141,7 @@   -> f ()   -> CmdParser f out Bool addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)-  $ addCmdPartManyA ManyUpperBound1 desc parseF (\() -> a)+  $ addCmdPartManyA ManyUpperBound1 (wrapHidden flag desc) parseF (\() -> a)  where   allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs   desc :: PartDesc@@ -148,7 +168,7 @@                    -> Flag Void -- ^ properties                    -> CmdParser f out Int addSimpleCountFlag shorts longs flag = fmap length-  $ addCmdPartMany ManyUpperBoundN desc parseF+  $ addCmdPartMany ManyUpperBoundN (wrapHidden flag desc) parseF  where     -- we _could_ allow this to parse repeated short flags, like "-vvv"     -- (meaning "-v -v -v") correctly.@@ -179,7 +199,7 @@   -> Flag p -- ^ properties   -> CmdParser f out p addFlagReadParam shorts longs name flag =-  addCmdPartInpA desc parseF (\_ -> pure ())+  addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())  where   allStrs =     [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]@@ -261,7 +281,7 @@      -> CmdParser f out [p] addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA   ManyUpperBoundN-  desc+  (wrapHidden flag desc)   parseF   act  where@@ -310,9 +330,8 @@      -> String -- ^ param name      -> Flag String -- ^ properties      -> CmdParser f out String-addFlagStringParam shorts longs name flag = addCmdPartInpA desc-                                                           parseF-                                                           (\_ -> pure ())+addFlagStringParam shorts longs name flag =+  addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())  where   allStrs =     [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]@@ -389,7 +408,7 @@      -> CmdParser f out [String] addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA   ManyUpperBoundN-  desc+  (wrapHidden flag desc)   parseF   act  where

@@ -2,6 +2,7 @@ -- e.g. a REPL. module UI.Butcher.Monadic.Interactive   ( simpleCompletion+  , shellCompletionWords   , interactiveHelpDoc   , partDescStrings   )@@ -29,34 +30,72 @@                     -- subcommand. See 'UI.Butcher.Monadic.runCmdParserExt'.   -> String         -- ^ completion, i.e. a string that might be appended                     -- to the current prompt when user presses tab.-simpleCompletion line cdesc pcRest =-  List.drop (List.length lastWord) $ case choices of-    [] -> ""-    (c1:cr) ->-      case-          filter (\s -> List.all (s`isPrefixOf`) cr) $ reverse $ List.inits c1-        of-          []    -> ""-          (x:_) -> x+simpleCompletion line cdesc pcRest = List.drop (List.length lastWord)+  $ longestCommonPrefix choices  where+  longestCommonPrefix [] = ""+  longestCommonPrefix (c1:cr) =+    case find (\s -> List.all (s `isPrefixOf`) cr) $ reverse $ List.inits c1 of+      Nothing -> ""+      Just x  -> x   nameDesc = case _cmd_mParent cdesc of-    Nothing                        -> cdesc-    Just (_, parent) | null pcRest -> parent-    Just{}                         -> cdesc+    Nothing -> cdesc+    Just (_, parent) | null pcRest && not (null lastWord) -> parent+        -- not finished writing a command. if we have commands abc and abcdef,+        -- we may want "def" as a completion after "abc".+    Just{}  -> cdesc   lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ line   choices :: [String]   choices = join     [ [ r       | (Just r, _) <- Data.Foldable.toList (_cmd_children nameDesc)       , lastWord `isPrefixOf` r+      , lastWord /= r       ]     , [ s       | s <- partDescStrings =<< _cmd_parts nameDesc       , lastWord `isPrefixOf` s+      , lastWord /= s       ]     ]  +-- | Derives a list of completion items from a given input string and a given+-- 'CommandDesc'. Considers potential subcommands and where available the+-- completion info present in 'PartDesc's.+--+-- See 'addShellCompletion' which uses this.+shellCompletionWords+  :: String         -- ^ input string+  -> CommandDesc () -- ^ CommandDesc obtained on that input string+  -> String         -- ^ "remaining" input after the last successfully parsed+                    -- subcommand. See 'UI.Butcher.Monadic.runCmdParserExt'.+  -> [CompletionItem]+shellCompletionWords line cdesc pcRest = choices+ where+  nameDesc = case _cmd_mParent cdesc of+    Nothing -> cdesc+    Just (_, parent) | null pcRest && not (null lastWord) -> parent+        -- not finished writing a command. if we have commands abc and abcdef,+        -- we may want "def" as a completion after "abc".+    Just{}  -> cdesc+  lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ line+  choices :: [CompletionItem]+  choices = join+    [ [ CompletionString r+      | (Just r, _) <- Data.Foldable.toList (_cmd_children nameDesc)+      , lastWord `isPrefixOf` r+      , lastWord /= r+      ]+    , [ c+      | c <- partDescCompletions =<< _cmd_parts cdesc+      , case c of+        CompletionString s -> lastWord `isPrefixOf` s && lastWord /= s+        _                  -> True+      ]+    ]++ -- | Produces a 'PP.Doc' as a hint for the user during interactive command -- input. Takes the current (incomplete) prompt line into account. For example -- when you have commands (among others) \'config set-email\' and@@ -124,9 +163,32 @@   PartSeq      []     -> []   PartSeq      (x:_)  -> partDescStrings x   PartDefault    _  x -> partDescStrings x-  PartSuggestion ss x -> [ s | s <- ss ] ++ partDescStrings x+  PartSuggestion ss x -> [ s | CompletionString s <- ss ] ++ partDescStrings x   PartRedirect   _  x -> partDescStrings x   PartReorder xs      -> xs >>= partDescStrings   PartMany    x       -> partDescStrings x   PartWithHelp _h x   -> partDescStrings x -- TODO: handle help+  PartHidden{}        -> [] ++-- | Obtains a list of "expected"/potential strings for a command part+-- described in the 'PartDesc'. In constrast to the 'simpleCompletion'+-- function this function does not take into account any current input, and+-- consequently the output elements can in general not be appended to partial+-- input to form valid input.+partDescCompletions :: PartDesc -> [CompletionItem]+partDescCompletions = \case+  PartLiteral  s      -> [CompletionString s]+  PartVariable _      -> []+  -- TODO: we could handle seq of optional and such much better+  PartOptional x      -> partDescCompletions x+  PartAlts     alts   -> alts >>= partDescCompletions+  PartSeq      []     -> []+  PartSeq      (x:_)  -> partDescCompletions x+  PartDefault    _  x -> partDescCompletions x+  PartSuggestion ss x -> ss ++ partDescCompletions x+  PartRedirect   _  x -> partDescCompletions x+  PartReorder xs      -> xs >>= partDescCompletions+  PartMany    x       -> partDescCompletions x+  PartWithHelp _h x   -> partDescCompletions x -- TODO: handle help+  PartHidden{}        -> []

@@ -5,1153 +5,1245 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TemplateHaskell #-}--module UI.Butcher.Monadic.Internal.Core-  ( addCmdSynopsis-  , addCmdHelp-  , addCmdHelpStr-  , peekCmdDesc-  , peekInput-  , addCmdPart-  , addCmdPartA-  , addCmdPartMany-  , addCmdPartManyA-  , addCmdPartInp-  , addCmdPartInpA-  , addCmdPartManyInp-  , addCmdPartManyInpA-  , addCmd-  , addNullCmd-  , addCmdImpl-  , reorderStart-  , reorderStop-  , checkCmdParser-  , runCmdParser-  , runCmdParserExt-  , runCmdParserA-  , runCmdParserAExt-  , mapOut-  )-where----#include "prelude.inc"-import           Control.Monad.Free-import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS-import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS--import qualified Lens.Micro as Lens-import           Lens.Micro ( (%~), (.~) )--import qualified Text.PrettyPrint as PP-import           Text.PrettyPrint ( (<+>), ($$), ($+$) )--import           Data.HList.ContainsType--import           Data.Dynamic--import           UI.Butcher.Monadic.Internal.Types------ general-purpose helpers-------------------------------mModify :: MonadMultiState s m => (s -> s) -> m ()-mModify f = mGet >>= mSet . f---- sadly, you need a degree in type inference to know when we can use--- these operators and when it must be avoided due to type ambiguities--- arising around s in the signatures below. That's the price of not having--- the functional dependency in MonadMulti*T.--(.=+) :: MonadMultiState s m-      => Lens.ASetter s s a b -> b -> m ()-l .=+ b = mModify $ l .~ b--(%=+) :: MonadMultiState s m-      => Lens.ASetter s s a b -> (a -> b) -> m ()-l %=+ f = mModify (l %~ f)---- inflateStateProxy :: (Monad m, ContainsType s ss)---                   => p s -> StateS.StateT s m a -> MultiRWSS.MultiRWST r w ss m a--- inflateStateProxy _ = MultiRWSS.inflateState---- more on-topic stuff--------------------------------- instance IsHelpBuilder (CmdBuilder out) where---   help s = liftF $ CmdBuilderHelp s ()--- --- instance IsHelpBuilder (ParamBuilder p) where---   help s = liftF $ ParamBuilderHelp s ()--- --- instance IsHelpBuilder FlagBuilder where---   help s = liftF $ FlagBuilderHelp s ()---- | Add a synopsis to the command currently in scope; at top level this will--- be the implicit top-level command.------ Adding a second synopsis will overwrite a previous synopsis;--- 'checkCmdParser' will check that you don't (accidentally) do this however.-addCmdSynopsis :: String -> CmdParser f out ()-addCmdSynopsis s = liftF $ CmdParserSynopsis s ()---- | Add a help document to the command currently in scope; at top level this--- will be the implicit top-level command.------ Adding a second document will overwrite a previous document;--- 'checkCmdParser' will check that you don't (accidentally) do this however.-addCmdHelp :: PP.Doc -> CmdParser f out ()-addCmdHelp s = liftF $ CmdParserHelp s ()---- | Like @'addCmdHelp' . PP.text@-addCmdHelpStr :: String -> CmdParser f out ()-addCmdHelpStr s = liftF $ CmdParserHelp (PP.text s) ()---- | Semi-hacky way of accessing the output CommandDesc from inside of a--- 'CmdParser'. This is not implemented via knot-tying, i.e. the CommandDesc--- you get is _not_ equivalent to the CommandDesc returned by 'runCmdParser'.--- Also see 'runCmdParserWithHelpDesc' which does knot-tying.------ For best results, use this "below"--- any 'addCmd' invocations in the current context, e.g. directly before--- the 'addCmdImpl' invocation.-peekCmdDesc :: CmdParser f out (CommandDesc ())-peekCmdDesc = liftF $ CmdParserPeekDesc id---- | Semi-hacky way of accessing the current input that is not yet processed.--- This must not be used to do any parsing. The purpose of this function is--- to provide a String to be used for output to the user, as feedback about--- what command was executed. For example we may think of an interactive--- program reacting to commandline input such as--- "run --delay 60 fire-rockets" which shows a 60 second delay on the--- "fire-rockets" command. The latter string could have been obtained--- via 'peekInput' after having parsed "run --delay 60" already.-peekInput :: CmdParser f out String-peekInput = liftF $ CmdParserPeekInput id---- | Add part that is expected to occur exactly once in the input. May--- succeed on empty input (e.g. by having a default).-addCmdPart-  :: (Applicative f, Typeable p)-  => PartDesc-  -> (String -> Maybe (p, String))-  -> CmdParser f out p-addCmdPart p f = liftF $ CmdParserPart p f (\_ -> pure ()) id--addCmdPartA-  :: (Typeable p)-  => PartDesc-  -> (String -> Maybe (p, String))-  -> (p -> f ())-  -> CmdParser f out p-addCmdPartA p f a = liftF $ CmdParserPart p f a id---- | Add part that is not required to occur, and can occur as often as--- indicated by 'ManyUpperBound'. Must not succeed on empty input.-addCmdPartMany-  :: (Applicative f, Typeable p)-  => ManyUpperBound-  -> PartDesc-  -> (String -> Maybe (p, String))-  -> CmdParser f out [p]-addCmdPartMany b p f = liftF $ CmdParserPartMany b p f (\_ -> pure ()) id--addCmdPartManyA-  :: (Typeable p)-  => ManyUpperBound-  -> PartDesc-  -> (String -> Maybe (p, String))-  -> (p -> f ())-  -> CmdParser f out [p]-addCmdPartManyA b p f a = liftF $ CmdParserPartMany b p f a id---- | Add part that is expected to occur exactly once in the input. May--- succeed on empty input (e.g. by having a default).------ Only difference to 'addCmdPart' is that it accepts 'Input', i.e. can--- behave differently for @String@ and @[String]@ input.-addCmdPartInp-  :: (Applicative f, Typeable p)-  => PartDesc-  -> (Input -> Maybe (p, Input))-  -> CmdParser f out p-addCmdPartInp p f = liftF $ CmdParserPartInp p f (\_ -> pure ()) id--addCmdPartInpA-  :: (Typeable p)-  => PartDesc-  -> (Input -> Maybe (p, Input))-  -> (p -> f ())-  -> CmdParser f out p-addCmdPartInpA p f a = liftF $ CmdParserPartInp p f a id---- | Add part that is not required to occur, and can occur as often as--- indicated by 'ManyUpperBound'. Must not succeed on empty input.------ Only difference to 'addCmdPart' is that it accepts 'Input', i.e. can--- behave differently for @String@ and @[String]@ input.-addCmdPartManyInp-  :: (Applicative f, Typeable p)-  => ManyUpperBound-  -> PartDesc-  -> (Input -> Maybe (p, Input))-  -> CmdParser f out [p]-addCmdPartManyInp b p f = liftF $ CmdParserPartManyInp b p f (\_ -> pure ()) id--addCmdPartManyInpA-  :: (Typeable p)-  => ManyUpperBound-  -> PartDesc-  -> (Input -> Maybe (p, Input))-  -> (p -> f ())-  -> CmdParser f out [p]-addCmdPartManyInpA b p f a = liftF $ CmdParserPartManyInp b p f a id---- | Add a new child command in the current context.-addCmd-  :: Applicative f-  => String -- ^ command name-  -> CmdParser f out () -- ^ subcommand-  -> CmdParser f out ()-addCmd str sub = liftF $ CmdParserChild (Just str) sub (pure ()) ()---- | Add a new nameless child command in the current context. Nameless means--- that this command matches the empty input, i.e. will always apply.--- This feature is experimental and CommandDesc pretty-printing might not--- correctly in presense of nullCmds.-addNullCmd :: Applicative f => CmdParser f out () -> CmdParser f out ()-addNullCmd sub = liftF $ CmdParserChild Nothing sub (pure ()) ()---- | Add an implementation to the current command.-addCmdImpl :: out -> CmdParser f out ()-addCmdImpl o = liftF $ CmdParserImpl o ()---- | Best explained via example:------ > do--- >   reorderStart--- >   bright <- addSimpleBoolFlag "" ["bright"] mempty--- >   yellow <- addSimpleBoolFlag "" ["yellow"] mempty--- >   reorderStop--- >   ..------ will accept any inputs "" "--bright" "--yellow" "--bright --yellow" "--yellow --bright".------ This works for any flags/params, but bear in mind that the results might--- be unexpected because params may match on any input.------ Note that start/stop must occur in pairs, and it will be a runtime error--- if you mess this up. Use 'checkCmdParser' if you want to check all parts--- of your 'CmdParser' without providing inputs that provide 100% coverage.-reorderStart :: CmdParser f out ()-reorderStart = liftF $ CmdParserReorderStart ()---- | See 'reorderStart'-reorderStop :: CmdParser f out ()-reorderStop = liftF $ CmdParserReorderStop ()---- addPartHelp :: String -> CmdPartParser ()--- addPartHelp s = liftF $ CmdPartParserHelp s ()--- --- addPartParserBasic :: (String -> Maybe (p, String)) -> Maybe p -> CmdPartParser p--- addPartParserBasic f def = liftF $ CmdPartParserCore f def id--- --- addPartParserOptionalBasic :: CmdPartParser p -> CmdPartParser (Maybe p)--- addPartParserOptionalBasic p = liftF $ CmdPartParserOptional p id--data PartGatherData f-  = forall p . Typeable p => PartGatherData-    { _pgd_id     :: Int-    , _pgd_desc   :: PartDesc-    , _pgd_parseF :: Either (String -> Maybe (p, String))-                            (Input  -> Maybe (p, Input))-    , _pgd_act    :: p -> f ()-    , _pgd_many   :: Bool-    }--data ChildGather f out = ChildGather (Maybe String) (CmdParser f out ()) (f ())--type PartParsedData = Map Int [Dynamic]--data CmdDescStack = StackBottom (Deque PartDesc)-                  | StackLayer  (Deque PartDesc) String CmdDescStack--descStackAdd :: PartDesc -> CmdDescStack -> CmdDescStack-descStackAdd d = \case-  StackBottom l    -> StackBottom $ Deque.snoc d l-  StackLayer l s u -> StackLayer (Deque.snoc d l) s u----- | Because butcher is evil (i.e. has constraints not encoded in the types;--- see the README), this method can be used as a rough check that you did not--- mess up. It traverses all possible parts of the 'CmdParser' thereby--- ensuring that the 'CmdParser' has a valid structure.------ This method also yields a _complete_ @CommandDesc@ output, where the other--- runCmdParser* functions all traverse only a shallow structure around the--- parts of the 'CmdParser' touched while parsing the current input.-checkCmdParser :: forall f out-                . Maybe String -- ^ top-level command name-               -> CmdParser f out () -- ^ parser to check-               -> Either String (CommandDesc ())-checkCmdParser mTopLevel cmdParser-    = (>>= final)-    $ MultiRWSS.runMultiRWSTNil-    $ MultiRWSS.withMultiStateAS (StackBottom mempty)-    $ MultiRWSS.withMultiStateS emptyCommandDesc-    $ processMain cmdParser-  where-    final :: (CommandDesc out, CmdDescStack)-          -> Either String (CommandDesc ())-    final (desc, stack)-      = case stack of-        StackBottom descs -> Right-                           $ descFixParentsWithTopM (mTopLevel <&> \n -> (Just n, emptyCommandDesc))-                           $ () <$ desc-          { _cmd_parts = Data.Foldable.toList descs-          }-        StackLayer _ _ _ -> Left "unclosed ReorderStart or GroupStart"-    processMain :: CmdParser f out ()-                -> MultiRWSS.MultiRWST '[] '[] '[CommandDesc out, CmdDescStack] (Either String) ()-    processMain = \case-      Pure x -> return x-      Free (CmdParserHelp h next) -> do-        cmd :: CommandDesc out <- mGet-        mSet $ cmd { _cmd_help = Just h }-        processMain next-      Free (CmdParserSynopsis s next) -> do-        cmd :: CommandDesc out <- mGet-        mSet $ cmd { _cmd_synopsis = Just $ PP.text s }-        processMain next-      Free (CmdParserPeekDesc nextF) -> do-        processMain $ nextF monadMisuseError-      Free (CmdParserPeekInput nextF) -> do-        processMain $ nextF monadMisuseError-      Free (CmdParserPart desc _parseF _act nextF) -> do-        do-          descStack <- mGet-          mSet $ descStackAdd desc descStack-        processMain $ nextF monadMisuseError-      Free (CmdParserPartInp desc _parseF _act nextF) -> do-        do-          descStack <- mGet-          mSet $ descStackAdd desc descStack-        processMain $ nextF monadMisuseError-      Free (CmdParserPartMany bound desc _parseF _act nextF) -> do-        do-          descStack <- mGet-          mSet $ descStackAdd (wrapBoundDesc bound desc) descStack-        processMain $ nextF monadMisuseError-      Free (CmdParserPartManyInp bound desc _parseF _act nextF) -> do-        do-          descStack <- mGet-          mSet $ descStackAdd (wrapBoundDesc bound desc) descStack-        processMain $ nextF monadMisuseError-      Free (CmdParserChild cmdStr sub _act next) -> do-        mInitialDesc <- takeCommandChild cmdStr-        cmd :: CommandDesc out <- mGet-        subCmd <- do-          stackCur :: CmdDescStack <- mGet-          mSet $ fromMaybe (emptyCommandDesc :: CommandDesc out) mInitialDesc-          mSet $ StackBottom mempty-          processMain sub-          c <- mGet-          stackBelow <- mGet-          mSet cmd-          mSet stackCur-          subParts <- case stackBelow of-            StackBottom descs -> return $ Data.Foldable.toList descs-            StackLayer _ _ _ -> lift $ Left "unclosed ReorderStart or GroupStart"-          return c { _cmd_parts = subParts }-        mSet $ cmd-          { _cmd_children = (cmdStr, subCmd) `Deque.snoc` _cmd_children cmd-          }-        processMain next-      Free (CmdParserImpl out next) -> do-        cmd_out .=+ Just out-        processMain $ next-      Free (CmdParserGrouped groupName next) -> do-        stackCur <- mGet-        mSet $ StackLayer mempty groupName stackCur-        processMain $ next-      Free (CmdParserGroupEnd next) -> do-        stackCur <- mGet-        case stackCur of-          StackBottom{} -> do-            lift $ Left $ "butcher interface error: group end without group start"-          StackLayer _descs "" _up -> do-            lift $ Left $ "GroupEnd found, but expected ReorderStop first"-          StackLayer descs groupName up -> do-            mSet $ descStackAdd (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) up-            processMain $ next-      Free (CmdParserReorderStop next) -> do-        stackCur <- mGet-        case stackCur of-          StackBottom{} -> lift $ Left $ "ReorderStop without reorderStart"-          StackLayer descs "" up -> do-            mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up-          StackLayer{} -> lift $ Left $ "Found ReorderStop, but need GroupEnd first"-        processMain next-      Free (CmdParserReorderStart next) -> do-        stackCur <- mGet-        mSet $ StackLayer mempty "" stackCur-        processMain next--    monadMisuseError :: a-    monadMisuseError = error "CmdParser definition error - used Monad powers where only Applicative/Arrow is allowed"--newtype PastCommandInput = PastCommandInput Input----- | Run a @CmdParser@ on the given input, returning:------ a) A @CommandDesc ()@ that accurately represents the subcommand that was---    reached, even if parsing failed. Because this is returned always, the---    argument is @()@ because "out" requires a successful parse.------ b) Either an error or the result of a successful parse, including a proper---    "CommandDesc out" from which an "out" can be extracted (presuming that---    the command has an implementation).-runCmdParser-  :: Maybe String -- ^ program name to be used for the top-level @CommandDesc@-  -> Input -- ^ input to be processed-  -> CmdParser Identity out () -- ^ parser to use-  -> (CommandDesc (), Either ParsingError (CommandDesc out))-runCmdParser mTopLevel inputInitial cmdParser-  = runIdentity-  $ runCmdParserA mTopLevel inputInitial cmdParser---- | Like 'runCmdParser', but also returning all input after the last--- successfully parsed subcommand. E.g. for some input--- "myprog foo bar -v --wrong" where parsing fails at "--wrong", this will--- contain the full "-v --wrong". Useful for interactive feedback stuff.-runCmdParserExt-  :: Maybe String -- ^ program name to be used for the top-level @CommandDesc@-  -> Input -- ^ input to be processed-  -> CmdParser Identity out () -- ^ parser to use-  -> (CommandDesc (), Input, Either ParsingError (CommandDesc out))-runCmdParserExt mTopLevel inputInitial cmdParser-  = runIdentity-  $ runCmdParserAExt mTopLevel inputInitial cmdParser---- | The Applicative-enabled version of 'runCmdParser'.-runCmdParserA :: forall f out-               . Applicative f-              => Maybe String -- ^ program name to be used for the top-level @CommandDesc@-              -> Input -- ^ input to be processed-              -> CmdParser f out () -- ^ parser to use-              -> f ( CommandDesc ()-                   , Either ParsingError (CommandDesc out)-                   )-runCmdParserA mTopLevel inputInitial cmdParser =-  (\(x, _, z) -> (x, z)) <$> runCmdParserAExt mTopLevel inputInitial cmdParser---- | The Applicative-enabled version of 'runCmdParserExt'.-runCmdParserAExt-  :: forall f out . Applicative f-  => Maybe String -- ^ program name to be used for the top-level @CommandDesc@-  -> Input -- ^ input to be processed-  -> CmdParser f out () -- ^ parser to use-  -> f (CommandDesc (), Input, Either ParsingError (CommandDesc out))-runCmdParserAExt mTopLevel inputInitial cmdParser-    = runIdentity-    $ MultiRWSS.runMultiRWSTNil-    $ (<&> captureFinal)-    $ MultiRWSS.withMultiWriterWA-    $ MultiRWSS.withMultiStateA cmdParser-    $ MultiRWSS.withMultiStateSA (StackBottom mempty)-    $ MultiRWSS.withMultiStateSA inputInitial-    $ MultiRWSS.withMultiStateSA (PastCommandInput inputInitial)-    $ MultiRWSS.withMultiStateSA initialCommandDesc-    $ processMain cmdParser-  where-    initialCommandDesc = emptyCommandDesc-      { _cmd_mParent = mTopLevel <&> \n -> (Just n, emptyCommandDesc) }-    captureFinal-      :: ([String], (CmdDescStack, (Input, (PastCommandInput, (CommandDesc out, f())))))-      -> f (CommandDesc (), Input, Either ParsingError (CommandDesc out))-    captureFinal (errs, (descStack, (inputRest, (PastCommandInput pastCmdInput, (cmd, act))))) =-        act $> (() <$ cmd', pastCmdInput, res)-      where-        errs' = errs ++ inputErrs ++ stackErrs-        inputErrs = case inputRest of-          InputString s | all Char.isSpace s -> []-          InputString{} -> ["could not parse input/unprocessed input"]-          InputArgs [] -> []-          InputArgs{} -> ["could not parse input/unprocessed input"]-        stackErrs = case descStack of-          StackBottom{} -> []-          _ -> ["butcher interface error: unclosed group"]-        cmd' = postProcessCmd descStack cmd-        res = if null errs'-          then Right cmd'-          else Left $ ParsingError errs' inputRest-    processMain :: CmdParser f out ()-                -> MultiRWSS.MultiRWS-                     '[]-                     '[[String]]-                     '[CommandDesc out, PastCommandInput, Input, CmdDescStack, CmdParser f out ()]-                     (f ())-    processMain = \case-      Pure () -> return $ pure $ ()-      Free (CmdParserHelp h next) -> do-        cmd :: CommandDesc out <- mGet-        mSet $ cmd { _cmd_help = Just h }-        processMain next-      Free (CmdParserSynopsis s next) -> do-        cmd :: CommandDesc out <- mGet-        mSet $ cmd { _cmd_synopsis = Just $ PP.text s }-        processMain next-      Free (CmdParserPeekDesc nextF) -> do-        parser <- mGet-        -- partialDesc :: CommandDesc out <- mGet-        -- partialStack :: CmdDescStack <- mGet-        -- run the rest without affecting the actual stack-        -- to retrieve the complete cmddesc.-        cmdCur :: CommandDesc out <- mGet-        let (cmd :: CommandDesc out, stack)-              = runIdentity-              $ MultiRWSS.runMultiRWSTNil-              $ MultiRWSS.withMultiStateSA emptyCommandDesc-                  { _cmd_mParent = _cmd_mParent cmdCur } -- partialDesc-              $ MultiRWSS.withMultiStateS (StackBottom mempty) -- partialStack-              $ iterM processCmdShallow $ parser-        processMain $ nextF $ () <$ postProcessCmd stack cmd-      Free (CmdParserPeekInput nextF) -> do-        processMain $ nextF $ inputToString inputInitial-      Free (CmdParserPart desc parseF actF nextF) -> do-        do-          descStack <- mGet-          mSet $ descStackAdd desc descStack-        input <- mGet-        case input of-          InputString str -> case parseF str of-            Just (x, rest) -> do-              mSet $ InputString rest-              actRest <- processMain $ nextF x-              return $ actF x *> actRest-            Nothing -> do-              mTell ["could not parse " ++ getPartSeqDescPositionName desc]-              processMain $ nextF monadMisuseError-          InputArgs (str:strr) -> case parseF str of-            Just (x, "") -> do-              mSet $ InputArgs strr-              actRest <- processMain $ nextF x-              return $ actF x *> actRest-            _ -> do-              mTell ["could not parse " ++ getPartSeqDescPositionName desc]-              processMain $ nextF monadMisuseError-          InputArgs [] -> do-            mTell ["could not parse " ++ getPartSeqDescPositionName desc]-            processMain $ nextF monadMisuseError-      Free (CmdParserPartInp desc parseF actF nextF) -> do-        do-          descStack <- mGet-          mSet $ descStackAdd desc descStack-        input <- mGet-        case parseF input of-          Just (x, rest) -> do-            mSet $ rest-            actRest <- processMain $ nextF x-            return $ actF x *> actRest-          Nothing -> do-            mTell ["could not parse " ++ getPartSeqDescPositionName desc]-            processMain $ nextF monadMisuseError-      Free (CmdParserPartMany bound desc parseF actF nextF) -> do-        do-          descStack <- mGet-          mSet $ descStackAdd (wrapBoundDesc bound desc) descStack-        let proc = do-              dropSpaces-              input <- mGet-              case input of-                InputString str -> case parseF str of-                  Just (x, r) -> do-                    mSet $ InputString r-                    xr <- proc-                    return $ x:xr-                  Nothing -> return []-                InputArgs (str:strr) -> case parseF str of-                  Just (x, "") -> do-                    mSet $ InputArgs strr-                    xr <- proc-                    return $ x:xr-                  _ -> return []-                InputArgs [] -> return []-        r <- proc-        let act = traverse actF r-        (act *>) <$> processMain (nextF $ r)-      Free (CmdParserPartManyInp bound desc parseF actF nextF) -> do-        do-          descStack <- mGet-          mSet $ descStackAdd (wrapBoundDesc bound desc) descStack-        let proc = do-              dropSpaces-              input <- mGet-              case parseF input of-                Just (x, r) -> do-                  mSet $ r-                  xr <- proc-                  return $ x:xr-                Nothing -> return []-        r <- proc-        let act = traverse actF r-        (act *>) <$> processMain (nextF $ r)-      f@(Free (CmdParserChild _ _ _ _)) -> do-        dropSpaces-        input <- mGet-        (gatheredChildren :: [ChildGather f out], restCmdParser) <--          MultiRWSS.withMultiWriterWA $ childrenGather f-        let-          child_fold-            :: (Deque (Maybe String), Map (Maybe String) (CmdParser f out (), f ()))-            -> ChildGather f out-            -> (Deque (Maybe String), Map (Maybe String) (CmdParser f out (), f ()))-          child_fold (c_names, c_map) (ChildGather name child act) =-            case name `MapS.lookup` c_map of-              Nothing ->-                ( Deque.snoc name c_names-                , MapS.insert name (child, act) c_map-                )-              Just (child', act') ->-                ( c_names-                , MapS.insert name (child' >> child, act') c_map-                   -- we intentionally override/ignore act here.-                   -- TODO: it should be documented that we expect the same act-                   -- on different child nodes with the same name.-                )-          (child_name_list, child_map) =-            foldl' child_fold (mempty, MapS.empty) gatheredChildren-          combined_child_list = Data.Foldable.toList child_name_list <&> \n ->-            (n, child_map MapS.! n)-        let mRest = asum $ combined_child_list <&> \(mname, (child, act)) ->-              case (mname, input) of-                (Just name, InputString str) | name == str ->-                  Just $ (Just name, child, act, InputString "")-                (Just name, InputString str) | (name++" ") `isPrefixOf` str ->-                  Just $ (Just name, child, act, InputString $ drop (length name + 1) str)-                (Just name, InputArgs (str:strr)) | name == str ->-                  Just $ (Just name, child, act, InputArgs strr)-                (Nothing, _) ->-                  Just $ (Nothing, child, act, input)-                _ -> Nothing-        case mRest of-          Nothing -> do -- a child not matching what we have in the input-            let initialDesc :: CommandDesc out = emptyCommandDesc-            -- get the shallow desc for the child in a separate env.-            combined_child_list `forM_` \(child_name, (child, _)) -> do-              let (subCmd, subStack)-                    = runIdentity-                    $ MultiRWSS.runMultiRWSTNil-                    $ MultiRWSS.withMultiStateSA initialDesc-                    $ MultiRWSS.withMultiStateS (StackBottom mempty)-                    $ iterM processCmdShallow child-              cmd_children %=+ Deque.snoc (child_name, postProcessCmd subStack subCmd)-            -- proceed regularly on the same layer-            processMain $ restCmdParser-          Just (name, child, act, rest) -> do -- matching child -> descend-            -- process all remaining stuff on the same layer shallowly,-            -- including the current node. This will be replaced later.-            iterM processCmdShallow f-            -- so the descend-            cmd <- do-              c :: CommandDesc out <- mGet-              prevStack :: CmdDescStack <- mGet-              return $ postProcessCmd prevStack c-            mSet $ rest-            mSet $ PastCommandInput rest-            mSet $ emptyCommandDesc-              { _cmd_mParent = Just (name, cmd)-              }-            mSet $ child-            mSet $ StackBottom mempty-            childAct <- processMain child-            -- check that descending yielded-            return $ act *> childAct-      Free (CmdParserImpl out next) -> do-        cmd_out .=+ Just out-        processMain $ next-      Free (CmdParserGrouped groupName next) -> do-        stackCur <- mGet-        mSet $ StackLayer mempty groupName stackCur-        processMain $ next-      Free (CmdParserGroupEnd next) -> do-        stackCur <- mGet-        case stackCur of-          StackBottom{} -> do-            mTell $ ["butcher interface error: group end without group start"]-            return $ pure () -- hard abort should be fine for this case.-          StackLayer descs groupName up -> do-            mSet $ descStackAdd (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) up-            processMain $ next-      Free (CmdParserReorderStop next) -> do-        mTell $ ["butcher interface error: reorder stop without reorder start"]-        processMain next-      Free (CmdParserReorderStart next) -> do-        reorderData <- MultiRWSS.withMultiStateA (1::Int)-                  $ MultiRWSS.withMultiWriterW-                  $ iterM reorderPartGather $ next-        let-          reorderMapInit :: Map Int (PartGatherData f)-          reorderMapInit = MapS.fromList $ reorderData <&> \d -> (_pgd_id d, d)-          tryParsePartData :: Input -> PartGatherData f -> First (Int, Dynamic, Input, Bool, f ())-          tryParsePartData input (PartGatherData pid _ pfe act allowMany) =-            First [ (pid, toDyn r, rest, allowMany, act r)-                  | (r, rest) <- case pfe of-                      Left pfStr -> case input of-                        InputString str -> case pfStr str of-                          Just (x, r) | r/=str -> Just (x, InputString r)-                          _ -> Nothing-                        InputArgs (str:strr) -> case pfStr str of-                          Just (x, "") -> Just (x, InputArgs strr)-                          _ -> Nothing-                        InputArgs [] -> Nothing-                      Right pfInp -> case pfInp input of-                        Just (x, r) | r/=input -> Just (x, r)-                        _ -> Nothing-                  ]-          parseLoop = do-            input <- mGet-            m :: Map Int (PartGatherData f) <- mGet-            case getFirst $ Data.Foldable.foldMap (tryParsePartData input) m of-                       -- i will be angry if foldMap ever decides to not fold-                       -- in order of keys.-              Nothing -> return $ pure ()-              Just (pid, x, rest, more, act) -> do-                mSet rest-                mModify $ MapS.insertWith (++) pid [x]-                when (not more) $ do-                  mSet $ MapS.delete pid m-                actRest <- parseLoop-                return $ act *> actRest-        (finalMap, (fr, acts)) <- MultiRWSS.withMultiStateSA (MapS.empty :: PartParsedData)-                                $ MultiRWSS.withMultiStateA reorderMapInit-                                $ do-          acts <- parseLoop -- filling the map-          stackCur <- mGet-          mSet $ StackLayer mempty "" stackCur-          fr <- MultiRWSS.withMultiStateA (1::Int) $ processParsedParts next-          return (fr, acts)-        -- we check that all data placed in the map has been consumed while-        -- running the parts for which we collected the parseresults.-        -- there can only be any rest if the collection of parts changed-        -- between the reorderPartGather traversal and the processParsedParts-        -- consumption.-        if MapS.null finalMap-          then do-            actRest <- processMain fr-            return $ acts *> actRest-          else monadMisuseError--    reorderPartGather-      :: ( MonadMultiState Int m-         , MonadMultiWriter [PartGatherData f] m-         , MonadMultiWriter [String] m-         )-      => CmdParserF f out (m ())-      -> m ()-    reorderPartGather = \case-      -- TODO: why do PartGatherData contain desc?-      CmdParserPart desc parseF actF nextF -> do-        pid <- mGet-        mSet $ pid + 1-        mTell [PartGatherData pid desc (Left parseF) actF False]-        nextF $ monadMisuseError-      CmdParserPartInp desc parseF actF nextF -> do-        pid <- mGet-        mSet $ pid + 1-        mTell [PartGatherData pid desc (Right parseF) actF False]-        nextF $ monadMisuseError-      CmdParserPartMany _ desc parseF actF nextF -> do-        pid <- mGet-        mSet $ pid + 1-        mTell [PartGatherData pid desc (Left parseF) actF True]-        nextF $ monadMisuseError-      CmdParserPartManyInp _ desc parseF actF nextF -> do-        pid <- mGet-        mSet $ pid + 1-        mTell [PartGatherData pid desc (Right parseF) actF True]-        nextF $ monadMisuseError-      CmdParserReorderStop _next -> do-        return ()-      CmdParserHelp{}         -> restCase-      CmdParserSynopsis{}     -> restCase-      CmdParserPeekDesc{}     -> restCase-      CmdParserPeekInput{}    -> restCase-      CmdParserChild{}        -> restCase-      CmdParserImpl{}         -> restCase-      CmdParserReorderStart{} -> restCase-      CmdParserGrouped{}      -> restCase-      CmdParserGroupEnd{}     -> restCase-      where-        restCase = do-          mTell ["Did not find expected ReorderStop after the reordered parts"]-          return ()--    childrenGather-      :: ( MonadMultiWriter [ChildGather f out] m-         , MonadMultiState (CmdParser f out ()) m-         , MonadMultiState (CommandDesc out) m-         )-      => CmdParser f out a-      -> m (CmdParser f out a)-    childrenGather = \case-      Free (CmdParserChild cmdStr sub act next) -> do-        mTell [ChildGather cmdStr sub act]-        childrenGather next-      Free (CmdParserPeekInput nextF) -> do-        childrenGather $ nextF $ inputToString inputInitial-      Free (CmdParserPeekDesc nextF) -> do-        parser <- mGet-        -- partialDesc :: CommandDesc out <- mGet-        -- partialStack :: CmdDescStack <- mGet-        -- run the rest without affecting the actual stack-        -- to retrieve the complete cmddesc.-        cmdCur :: CommandDesc out <- mGet-        let (cmd :: CommandDesc out, stack)-              = runIdentity-              $ MultiRWSS.runMultiRWSTNil-              $ MultiRWSS.withMultiStateSA emptyCommandDesc-                  { _cmd_mParent = _cmd_mParent cmdCur } -- partialDesc-              $ MultiRWSS.withMultiStateS (StackBottom mempty) -- partialStack-              $ iterM processCmdShallow $ parser-        childrenGather $ nextF $ () <$ postProcessCmd stack cmd-      something -> return something--    processParsedParts-      :: forall m r w s m0 a-       . ( MonadMultiState Int m-         , MonadMultiState PartParsedData m-         , MonadMultiState (Map Int (PartGatherData f)) m-         , MonadMultiState Input m-         , MonadMultiState (CommandDesc out) m-         , MonadMultiWriter [[Char]] m-         , m ~ MultiRWSS.MultiRWST r w s m0-         , ContainsType (CmdParser f out ()) s-         , ContainsType CmdDescStack s-         , Monad m0-         )-      => CmdParser f out a-      -> m (CmdParser f out a)-    processParsedParts = \case-      Free (CmdParserPart    desc _ _ (nextF :: p -> CmdParser f out a)) -> part desc nextF-      Free (CmdParserPartInp desc _ _ (nextF :: p -> CmdParser f out a)) -> part desc nextF-      Free (CmdParserPartMany bound desc _ _ nextF) -> partMany bound desc nextF-      Free (CmdParserPartManyInp bound desc _ _ nextF) -> partMany bound desc nextF-      Free (CmdParserReorderStop next) -> do-        stackCur <- mGet-        case stackCur of-          StackBottom{} -> do-            mTell ["unexpected stackBottom"]-          StackLayer descs _ up -> do-            mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up-        return next-      Free (CmdParserGrouped groupName next) -> do-        stackCur <- mGet-        mSet $ StackLayer mempty groupName stackCur-        processParsedParts $ next-      Free (CmdParserGroupEnd next) -> do-        stackCur <- mGet-        case stackCur of-          StackBottom{} -> do-            mTell $ ["butcher interface error: group end without group start"]-            return $ next -- hard abort should be fine for this case.-          StackLayer descs groupName up -> do-            mSet $ descStackAdd (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) up-            processParsedParts $ next        -      Pure x -> return $ return $ x-      f -> do-        mTell ["Did not find expected ReorderStop after the reordered parts"]-        return f-      where-        part-          :: forall p-           . Typeable p-          => PartDesc-          -> (p -> CmdParser f out a)-          -> m (CmdParser f out a)-        part desc nextF = do-          do-            stackCur <- mGet-            mSet $ descStackAdd desc stackCur-          pid <- mGet-          mSet $ pid + 1-          parsedMap :: PartParsedData <- mGet-          mSet $ MapS.delete pid parsedMap-          partMap :: Map Int (PartGatherData f) <- mGet-          input :: Input <- mGet-          let errorResult = do-                mTell ["could not parse expected input "-                    ++ getPartSeqDescPositionName desc-                    ++ " with remaining input: "-                    ++ show input-                    ]-                failureCurrentShallowRerun-                processParsedParts $ nextF monadMisuseError-              continueOrMisuse :: Maybe p -> m (CmdParser f out a)-              continueOrMisuse = maybe monadMisuseError-                                       (processParsedParts . nextF)-          case MapS.lookup pid parsedMap of-            Nothing -> case MapS.lookup pid partMap of-              Nothing -> monadMisuseError -- it would still be in the map-                                          -- if it never had been successfully-                                          -- parsed, as indicicated by the-                                          -- previous parsedMap Nothing lookup.-              Just (PartGatherData _ _ pfe _ _) -> case pfe of-                Left pf -> case pf "" of-                  Nothing -> errorResult-                  Just (dx, _) -> continueOrMisuse $ cast dx-                Right pf -> case pf (InputArgs []) of-                  Nothing -> errorResult-                  Just (dx, _) -> continueOrMisuse $ cast dx-            Just [dx] -> continueOrMisuse $ fromDynamic dx-            Just _ -> monadMisuseError-        partMany-          :: Typeable p-          => ManyUpperBound-          -> PartDesc-          -> ([p] -> CmdParser f out a)-          -> m (CmdParser f out a)-        partMany bound desc nextF = do-          do-            stackCur <- mGet-            mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur-          pid <- mGet-          mSet $ pid + 1-          m :: PartParsedData <- mGet-          mSet $ MapS.delete pid m-          let partDyns = case MapS.lookup pid m of-                Nothing -> []-                Just r -> reverse r-          case mapM fromDynamic partDyns of-            Nothing -> monadMisuseError-            Just xs -> processParsedParts $ nextF xs--    -- this does no error reporting at all.-    -- user needs to use check for that purpose instead.-    processCmdShallow :: ( MonadMultiState (CommandDesc out) m-                         , MonadMultiState CmdDescStack m-                         )-                      => CmdParserF f out (m ())-                      -> m ()-    processCmdShallow = \case-      CmdParserHelp h next -> do-        cmd :: CommandDesc out <- mGet-        mSet $ cmd { _cmd_help = Just h }-        next-      CmdParserSynopsis s next -> do-        cmd :: CommandDesc out <- mGet-        mSet $ cmd { _cmd_synopsis = Just $ PP.text s }-        next-      CmdParserPeekDesc nextF -> do-        mGet >>= nextF . fmap (\(_ :: out) -> ())-      CmdParserPeekInput nextF -> do-        nextF $ inputToString inputInitial-      CmdParserPart desc _parseF _act nextF -> do-        do-          stackCur <- mGet-          mSet $ descStackAdd desc stackCur-        nextF monadMisuseError-      CmdParserPartInp desc _parseF _act nextF -> do-        do-          stackCur <- mGet-          mSet $ descStackAdd desc stackCur-        nextF monadMisuseError-      CmdParserPartMany bound desc _parseF _act nextF -> do-        do-          stackCur <- mGet-          mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur-        nextF monadMisuseError-      CmdParserPartManyInp bound desc _parseF _act nextF -> do-        do-          stackCur <- mGet-          mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur-        nextF monadMisuseError-      CmdParserChild cmdStr _sub _act next -> do-        mExisting <- takeCommandChild cmdStr-        let childDesc :: CommandDesc out = fromMaybe emptyCommandDesc mExisting-        cmd_children %=+ Deque.snoc (cmdStr, childDesc)-        next-      CmdParserImpl out     next -> do-        cmd_out .=+ Just out-        next-      CmdParserGrouped groupName next -> do-        stackCur <- mGet-        mSet $ StackLayer mempty groupName stackCur-        next-      CmdParserGroupEnd next -> do-        stackCur <- mGet-        case stackCur of-          StackBottom{} -> do-            return ()-          StackLayer _descs "" _up -> do-            return ()-          StackLayer descs groupName up -> do-            mSet $ descStackAdd (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) up-            next-      CmdParserReorderStop next -> do-        stackCur <- mGet-        case stackCur of-          StackBottom{} -> return ()-          StackLayer descs "" up -> do-            mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up-          StackLayer{} -> return ()-        next-      CmdParserReorderStart next -> do-        stackCur <- mGet-        mSet $ StackLayer mempty "" stackCur-        next--    failureCurrentShallowRerun-      :: ( m ~ MultiRWSS.MultiRWST r w s m0-         , MonadMultiState (CmdParser f out ()) m-         , MonadMultiState (CommandDesc out) m-         , ContainsType CmdDescStack s-         , Monad m0-         )-      => m ()-    failureCurrentShallowRerun = do-      parser <- mGet-      cmd :: CommandDesc out -        <- MultiRWSS.withMultiStateS emptyCommandDesc-         $ iterM processCmdShallow parser-      mSet cmd--    postProcessCmd :: CmdDescStack -> CommandDesc out -> CommandDesc out-    postProcessCmd descStack cmd-      = descFixParents-      $ cmd { _cmd_parts    = case descStack of-                StackBottom l -> Data.Foldable.toList l-                StackLayer{} -> []-            }--    monadMisuseError :: a-    monadMisuseError = error "CmdParser definition error - used Monad powers where only Applicative/Arrow is allowed"--    -    getPartSeqDescPositionName :: PartDesc -> String-    getPartSeqDescPositionName = \case-      PartLiteral    s -> s-      PartVariable   s -> s-      PartOptional ds' -> f ds'-      PartAlts alts    -> f $ head alts -- this is not optimal, but probably-                                     -- does not matter.-      PartDefault  _ d -> f d-      PartSuggestion _ d -> f d-      PartRedirect s _ -> s-      PartMany      ds -> f ds-      PartWithHelp _ d -> f d-      PartSeq       ds -> List.unwords $ f <$> ds-      PartReorder   ds -> List.unwords $ f <$> ds--      where-        f = getPartSeqDescPositionName--    dropSpaces :: MonadMultiState Input m => m ()-    dropSpaces = do-      inp <- mGet-      case inp of-        InputString s -> mSet $ InputString $ dropWhile Char.isSpace s-        InputArgs{}   -> return ()--    inputToString :: Input -> String-    inputToString (InputString s) = s-    inputToString (InputArgs ss) = List.unwords ss--dequeLookupRemove :: Eq k => k -> Deque (k, a) -> (Maybe a, Deque (k, a))-dequeLookupRemove key deque = case Deque.uncons deque of-  Nothing -> (Nothing, mempty)-  Just ((k, v), rest) -> if k==key-    then (Just v, rest)-    else let (r, rest') = dequeLookupRemove key rest-          in (r, Deque.cons (k, v) rest')--takeCommandChild-  :: MonadMultiState (CommandDesc out) m-  => Maybe String-  -> m (Maybe (CommandDesc out))-takeCommandChild key = do-  cmd <- mGet-  let (r, children') = dequeLookupRemove key $ _cmd_children cmd-  mSet cmd { _cmd_children = children' }-  return r---- | map over the @out@ type argument-mapOut :: (outa -> outb) -> CmdParser f outa () -> CmdParser f outb ()-mapOut f = hoistFree $ \case-  CmdParserHelp     doc r               -> CmdParserHelp doc r-  CmdParserSynopsis s   r               -> CmdParserSynopsis s r-  CmdParserPeekDesc  fr                 -> CmdParserPeekDesc fr-  CmdParserPeekInput fr                 -> CmdParserPeekInput fr-  CmdParserPart desc fp fa fr           -> CmdParserPart desc fp fa fr-  CmdParserPartMany bound desc fp fa fr -> CmdParserPartMany bound desc fp fa fr-  CmdParserPartInp desc fp fa fr        -> CmdParserPartInp desc fp fa fr-  CmdParserPartManyInp bound desc fp fa fr ->-    CmdParserPartManyInp bound desc fp fa fr-  CmdParserChild s child act r -> CmdParserChild s (mapOut f child) act r-  CmdParserImpl out r          -> CmdParserImpl (f out) r-  CmdParserReorderStart r      -> CmdParserReorderStart r-  CmdParserReorderStop  r      -> CmdParserReorderStop r-  CmdParserGrouped s r         -> CmdParserGrouped s r-  CmdParserGroupEnd r          -> CmdParserGroupEnd r---- cmdActionPartial :: CommandDesc out -> Either String out--- cmdActionPartial = maybe (Left err) Right . _cmd_out---   where---     err = "command is missing implementation!"---  --- cmdAction :: CmdParser out () -> String -> Either String out--- cmdAction b s = case runCmdParser Nothing s b of---   (_, Right cmd)                     -> cmdActionPartial cmd---   (_, Left (ParsingError (out:_) _)) -> Left $ out---   _ -> error "whoops"--- --- cmdActionRun :: (CommandDesc () -> ParsingError -> out)---              -> CmdParser out ()---              -> String---              -> out--- cmdActionRun f p s = case runCmdParser Nothing s p of---   (cmd, Right out) -> case _cmd_out out of---     Just o -> o---     Nothing -> f cmd (ParsingError ["command is missing implementation!"] "")---   (cmd, Left err) -> f cmd err--wrapBoundDesc :: ManyUpperBound -> PartDesc -> PartDesc-wrapBoundDesc ManyUpperBound1 = PartOptional-wrapBoundDesc ManyUpperBoundN = PartMany---descFixParents :: CommandDesc a -> CommandDesc a-descFixParents = descFixParentsWithTopM Nothing---- descFixParentsWithTop :: String -> CommandDesc a -> CommandDesc a--- descFixParentsWithTop s = descFixParentsWithTopM (Just (s, emptyCommandDesc))--descFixParentsWithTopM :: Maybe (Maybe String, CommandDesc a) -> CommandDesc a -> CommandDesc a-descFixParentsWithTopM mTop topDesc = Data.Function.fix $ \fixed -> topDesc-        { _cmd_mParent  = goUp fixed <$> (mTop <|> _cmd_mParent topDesc)-        , _cmd_children = _cmd_children topDesc <&> goDown fixed-        }-  where-    goUp :: CommandDesc a -> (Maybe String, CommandDesc a) -> (Maybe String, CommandDesc a)-    goUp child (childName, parent) = (,) childName $ Data.Function.fix $ \fixed -> parent-      { _cmd_mParent = goUp fixed <$> _cmd_mParent parent-      , _cmd_children = _cmd_children parent <&> \(n, c) -> if n==childName-          then (n, child)-          else (n, c)-      }-    goDown :: CommandDesc a -> (Maybe String, CommandDesc a) -> (Maybe String, CommandDesc a)-    goDown parent (childName, child) = (,) childName $ Data.Function.fix $ \fixed -> child-      { _cmd_mParent = Just (childName, parent)-      , _cmd_children = _cmd_children child <&> goDown fixed-      }---_tooLongText :: Int -- max length-            -> String -- alternative if actual length is bigger than max.-            -> String -- text to print, if length is fine.-            -> PP.Doc+module UI.Butcher.Monadic.Internal.Core+  ( addCmdSynopsis+  , addCmdHelp+  , addCmdHelpStr+  , peekCmdDesc+  , peekInput+  , addCmdPart+  , addCmdPartA+  , addCmdPartMany+  , addCmdPartManyA+  , addCmdPartInp+  , addCmdPartInpA+  , addCmdPartManyInp+  , addCmdPartManyInpA+  , addCmd+  , addCmdHidden+  , addNullCmd+  , addCmdImpl+  , reorderStart+  , reorderStop+  , checkCmdParser+  , runCmdParser+  , runCmdParserExt+  , runCmdParserA+  , runCmdParserAExt+  , mapOut+  )+where++++#include "prelude.inc"+import           Control.Monad.Free+import qualified Control.Monad.Trans.MultiRWS.Strict+                                               as MultiRWSS+import qualified Control.Monad.Trans.MultiState.Strict+                                               as MultiStateS++import qualified Lens.Micro                    as Lens+import           Lens.Micro                     ( (%~)+                                                , (.~)+                                                )++import qualified Text.PrettyPrint              as PP+import           Text.PrettyPrint               ( (<+>)+                                                , ($$)+                                                , ($+$)+                                                )++import           Data.HList.ContainsType++import           Data.Dynamic++import           UI.Butcher.Monadic.Internal.Types++++-- general-purpose helpers+----------------------------++mModify :: MonadMultiState s m => (s -> s) -> m ()+mModify f = mGet >>= mSet . f++-- sadly, you need a degree in type inference to know when we can use+-- these operators and when it must be avoided due to type ambiguities+-- arising around s in the signatures below. That's the price of not having+-- the functional dependency in MonadMulti*T.++(.=+) :: MonadMultiState s m => Lens.ASetter s s a b -> b -> m ()+l .=+ b = mModify $ l .~ b++(%=+) :: MonadMultiState s m => Lens.ASetter s s a b -> (a -> b) -> m ()+l %=+ f = mModify (l %~ f)++-- inflateStateProxy :: (Monad m, ContainsType s ss)+--                   => p s -> StateS.StateT s m a -> MultiRWSS.MultiRWST r w ss m a+-- inflateStateProxy _ = MultiRWSS.inflateState++-- more on-topic stuff+----------------------------++-- instance IsHelpBuilder (CmdBuilder out) where+--   help s = liftF $ CmdBuilderHelp s ()+-- +-- instance IsHelpBuilder (ParamBuilder p) where+--   help s = liftF $ ParamBuilderHelp s ()+-- +-- instance IsHelpBuilder FlagBuilder where+--   help s = liftF $ FlagBuilderHelp s ()++-- | Add a synopsis to the command currently in scope; at top level this will+-- be the implicit top-level command.+--+-- Adding a second synopsis will overwrite a previous synopsis;+-- 'checkCmdParser' will check that you don't (accidentally) do this however.+addCmdSynopsis :: String -> CmdParser f out ()+addCmdSynopsis s = liftF $ CmdParserSynopsis s ()++-- | Add a help document to the command currently in scope; at top level this+-- will be the implicit top-level command.+--+-- Adding a second document will overwrite a previous document;+-- 'checkCmdParser' will check that you don't (accidentally) do this however.+addCmdHelp :: PP.Doc -> CmdParser f out ()+addCmdHelp s = liftF $ CmdParserHelp s ()++-- | Like @'addCmdHelp' . PP.text@+addCmdHelpStr :: String -> CmdParser f out ()+addCmdHelpStr s = liftF $ CmdParserHelp (PP.text s) ()++-- | Semi-hacky way of accessing the output CommandDesc from inside of a+-- 'CmdParser'. This is not implemented via knot-tying, i.e. the CommandDesc+-- you get is _not_ equivalent to the CommandDesc returned by 'runCmdParser'.+-- Also see 'runCmdParserWithHelpDesc' which does knot-tying.+--+-- For best results, use this "below"+-- any 'addCmd' invocations in the current context, e.g. directly before+-- the 'addCmdImpl' invocation.+peekCmdDesc :: CmdParser f out (CommandDesc ())+peekCmdDesc = liftF $ CmdParserPeekDesc id++-- | Semi-hacky way of accessing the current input that is not yet processed.+-- This must not be used to do any parsing. The purpose of this function is+-- to provide a String to be used for output to the user, as feedback about+-- what command was executed. For example we may think of an interactive+-- program reacting to commandline input such as+-- "run --delay 60 fire-rockets" which shows a 60 second delay on the+-- "fire-rockets" command. The latter string could have been obtained+-- via 'peekInput' after having parsed "run --delay 60" already.+peekInput :: CmdParser f out String+peekInput = liftF $ CmdParserPeekInput id++-- | Add part that is expected to occur exactly once in the input. May+-- succeed on empty input (e.g. by having a default).+addCmdPart+  :: (Applicative f, Typeable p)+  => PartDesc+  -> (String -> Maybe (p, String))+  -> CmdParser f out p+addCmdPart p f = liftF $ CmdParserPart p f (\_ -> pure ()) id++addCmdPartA+  :: (Typeable p)+  => PartDesc+  -> (String -> Maybe (p, String))+  -> (p -> f ())+  -> CmdParser f out p+addCmdPartA p f a = liftF $ CmdParserPart p f a id++-- | Add part that is not required to occur, and can occur as often as+-- indicated by 'ManyUpperBound'. Must not succeed on empty input.+addCmdPartMany+  :: (Applicative f, Typeable p)+  => ManyUpperBound+  -> PartDesc+  -> (String -> Maybe (p, String))+  -> CmdParser f out [p]+addCmdPartMany b p f = liftF $ CmdParserPartMany b p f (\_ -> pure ()) id++addCmdPartManyA+  :: (Typeable p)+  => ManyUpperBound+  -> PartDesc+  -> (String -> Maybe (p, String))+  -> (p -> f ())+  -> CmdParser f out [p]+addCmdPartManyA b p f a = liftF $ CmdParserPartMany b p f a id++-- | Add part that is expected to occur exactly once in the input. May+-- succeed on empty input (e.g. by having a default).+--+-- Only difference to 'addCmdPart' is that it accepts 'Input', i.e. can+-- behave differently for @String@ and @[String]@ input.+addCmdPartInp+  :: (Applicative f, Typeable p)+  => PartDesc+  -> (Input -> Maybe (p, Input))+  -> CmdParser f out p+addCmdPartInp p f = liftF $ CmdParserPartInp p f (\_ -> pure ()) id++addCmdPartInpA+  :: (Typeable p)+  => PartDesc+  -> (Input -> Maybe (p, Input))+  -> (p -> f ())+  -> CmdParser f out p+addCmdPartInpA p f a = liftF $ CmdParserPartInp p f a id++-- | Add part that is not required to occur, and can occur as often as+-- indicated by 'ManyUpperBound'. Must not succeed on empty input.+--+-- Only difference to 'addCmdPart' is that it accepts 'Input', i.e. can+-- behave differently for @String@ and @[String]@ input.+addCmdPartManyInp+  :: (Applicative f, Typeable p)+  => ManyUpperBound+  -> PartDesc+  -> (Input -> Maybe (p, Input))+  -> CmdParser f out [p]+addCmdPartManyInp b p f = liftF $ CmdParserPartManyInp b p f (\_ -> pure ()) id++addCmdPartManyInpA+  :: (Typeable p)+  => ManyUpperBound+  -> PartDesc+  -> (Input -> Maybe (p, Input))+  -> (p -> f ())+  -> CmdParser f out [p]+addCmdPartManyInpA b p f a = liftF $ CmdParserPartManyInp b p f a id++-- | Add a new child command in the current context.+addCmd+  :: Applicative f+  => String -- ^ command name+  -> CmdParser f out () -- ^ subcommand+  -> CmdParser f out ()+addCmd str sub = liftF $ CmdParserChild (Just str) Visible sub (pure ()) ()++-- | Add a new child command in the current context, but make it hidden. It+-- will not appear in docs/help generated by e.g. the functions in the+-- @Pretty@ module.+--+-- This feature is not well tested yet.+addCmdHidden+  :: Applicative f+  => String -- ^ command name+  -> CmdParser f out () -- ^ subcommand+  -> CmdParser f out ()+addCmdHidden str sub =+  liftF $ CmdParserChild (Just str) Hidden sub (pure ()) ()++-- | Add a new nameless child command in the current context. Nameless means+-- that this command matches the empty input, i.e. will always apply.+-- This feature is experimental and CommandDesc pretty-printing might not+-- correctly in presense of nullCmds.+addNullCmd :: Applicative f => CmdParser f out () -> CmdParser f out ()+addNullCmd sub = liftF $ CmdParserChild Nothing Hidden sub (pure ()) ()++-- | Add an implementation to the current command.+addCmdImpl :: out -> CmdParser f out ()+addCmdImpl o = liftF $ CmdParserImpl o ()++-- | Best explained via example:+--+-- > do+-- >   reorderStart+-- >   bright <- addSimpleBoolFlag "" ["bright"] mempty+-- >   yellow <- addSimpleBoolFlag "" ["yellow"] mempty+-- >   reorderStop+-- >   ..+--+-- will accept any inputs "" "--bright" "--yellow" "--bright --yellow" "--yellow --bright".+--+-- This works for any flags/params, but bear in mind that the results might+-- be unexpected because params may match on any input.+--+-- Note that start/stop must occur in pairs, and it will be a runtime error+-- if you mess this up. Use 'checkCmdParser' if you want to check all parts+-- of your 'CmdParser' without providing inputs that provide 100% coverage.+reorderStart :: CmdParser f out ()+reorderStart = liftF $ CmdParserReorderStart ()++-- | See 'reorderStart'+reorderStop :: CmdParser f out ()+reorderStop = liftF $ CmdParserReorderStop ()++-- addPartHelp :: String -> CmdPartParser ()+-- addPartHelp s = liftF $ CmdPartParserHelp s ()+-- +-- addPartParserBasic :: (String -> Maybe (p, String)) -> Maybe p -> CmdPartParser p+-- addPartParserBasic f def = liftF $ CmdPartParserCore f def id+-- +-- addPartParserOptionalBasic :: CmdPartParser p -> CmdPartParser (Maybe p)+-- addPartParserOptionalBasic p = liftF $ CmdPartParserOptional p id++data PartGatherData f+  = forall p . Typeable p => PartGatherData+    { _pgd_id     :: Int+    , _pgd_desc   :: PartDesc+    , _pgd_parseF :: Either (String -> Maybe (p, String))+                            (Input  -> Maybe (p, Input))+    , _pgd_act    :: p -> f ()+    , _pgd_many   :: Bool+    }++data ChildGather f out =+  ChildGather (Maybe String) Visibility (CmdParser f out ()) (f ())++type PartParsedData = Map Int [Dynamic]++data CmdDescStack = StackBottom (Deque PartDesc)+                  | StackLayer  (Deque PartDesc) String CmdDescStack++descStackAdd :: PartDesc -> CmdDescStack -> CmdDescStack+descStackAdd d = \case+  StackBottom l    -> StackBottom $ Deque.snoc d l+  StackLayer l s u -> StackLayer (Deque.snoc d l) s u+++-- | Because butcher is evil (i.e. has constraints not encoded in the types;+-- see the README), this method can be used as a rough check that you did not+-- mess up. It traverses all possible parts of the 'CmdParser' thereby+-- ensuring that the 'CmdParser' has a valid structure.+--+-- This method also yields a _complete_ @CommandDesc@ output, where the other+-- runCmdParser* functions all traverse only a shallow structure around the+-- parts of the 'CmdParser' touched while parsing the current input.+checkCmdParser+  :: forall f out+   . Maybe String -- ^ top-level command name+  -> CmdParser f out () -- ^ parser to check+  -> Either String (CommandDesc ())+checkCmdParser mTopLevel cmdParser =+  (>>= final)+    $ MultiRWSS.runMultiRWSTNil+    $ MultiRWSS.withMultiStateAS (StackBottom mempty)+    $ MultiRWSS.withMultiStateS emptyCommandDesc+    $ processMain cmdParser+ where+  final :: (CommandDesc out, CmdDescStack) -> Either String (CommandDesc ())+  final (desc, stack) = case stack of+    StackBottom descs ->+      Right+        $  descFixParentsWithTopM+             (mTopLevel <&> \n -> (Just n, emptyCommandDesc))+        $  ()+        <$ desc { _cmd_parts = Data.Foldable.toList descs }+    StackLayer _ _ _ -> Left "unclosed ReorderStart or GroupStart"+  processMain+    :: CmdParser f out ()+    -> MultiRWSS.MultiRWST+         '[]+         '[]+         '[CommandDesc out, CmdDescStack]+         (Either String)+         ()+  processMain = \case+    Pure x                      -> return x+    Free (CmdParserHelp h next) -> do+      cmd :: CommandDesc out <- mGet+      mSet $ cmd { _cmd_help = Just h }+      processMain next+    Free (CmdParserSynopsis s next) -> do+      cmd :: CommandDesc out <- mGet+      mSet+        $ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s }+      processMain next+    Free (CmdParserPeekDesc nextF) -> do+      processMain $ nextF monadMisuseError+    Free (CmdParserPeekInput nextF) -> do+      processMain $ nextF monadMisuseError+    Free (CmdParserPart desc _parseF _act nextF) -> do+      do+        descStack <- mGet+        mSet $ descStackAdd desc descStack+      processMain $ nextF monadMisuseError+    Free (CmdParserPartInp desc _parseF _act nextF) -> do+      do+        descStack <- mGet+        mSet $ descStackAdd desc descStack+      processMain $ nextF monadMisuseError+    Free (CmdParserPartMany bound desc _parseF _act nextF) -> do+      do+        descStack <- mGet+        mSet $ descStackAdd (wrapBoundDesc bound desc) descStack+      processMain $ nextF monadMisuseError+    Free (CmdParserPartManyInp bound desc _parseF _act nextF) -> do+      do+        descStack <- mGet+        mSet $ descStackAdd (wrapBoundDesc bound desc) descStack+      processMain $ nextF monadMisuseError+    Free (CmdParserChild cmdStr vis sub _act next) -> do+      mInitialDesc           <- takeCommandChild cmdStr+      cmd :: CommandDesc out <- mGet+      subCmd                 <- do+        stackCur :: CmdDescStack <- mGet+        mSet $ fromMaybe (emptyCommandDesc :: CommandDesc out) mInitialDesc+        mSet $ StackBottom mempty+        processMain sub+        c          <- mGet+        stackBelow <- mGet+        mSet cmd+        mSet stackCur+        subParts <- case stackBelow of+          StackBottom descs -> return $ Data.Foldable.toList descs+          StackLayer _ _ _  -> lift $ Left "unclosed ReorderStart or GroupStart"+        return c { _cmd_parts = subParts, _cmd_visibility = vis }+      mSet $ cmd+        { _cmd_children = (cmdStr, subCmd) `Deque.snoc` _cmd_children cmd+        }+      processMain next+    Free (CmdParserImpl out next) -> do+      cmd_out .=+ Just out+      processMain $ next+    Free (CmdParserGrouped groupName next) -> do+      stackCur <- mGet+      mSet $ StackLayer mempty groupName stackCur+      processMain $ next+    Free (CmdParserGroupEnd next) -> do+      stackCur <- mGet+      case stackCur of+        StackBottom{} -> do+          lift $ Left $ "butcher interface error: group end without group start"+        StackLayer _descs "" _up -> do+          lift $ Left $ "GroupEnd found, but expected ReorderStop first"+        StackLayer descs groupName up -> do+          mSet $ descStackAdd+            (PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))+            up+          processMain $ next+    Free (CmdParserReorderStop next) -> do+      stackCur <- mGet+      case stackCur of+        StackBottom{} -> lift $ Left $ "ReorderStop without reorderStart"+        StackLayer descs "" up -> do+          mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up+        StackLayer{} ->+          lift $ Left $ "Found ReorderStop, but need GroupEnd first"+      processMain next+    Free (CmdParserReorderStart next) -> do+      stackCur <- mGet+      mSet $ StackLayer mempty "" stackCur+      processMain next++  monadMisuseError :: a+  monadMisuseError =+    error+      $  "CmdParser definition error -"+      ++ " used Monad powers where only Applicative/Arrow is allowed"++newtype PastCommandInput = PastCommandInput Input+++-- | Run a @CmdParser@ on the given input, returning:+--+-- a) A @CommandDesc ()@ that accurately represents the subcommand that was+--    reached, even if parsing failed. Because this is returned always, the+--    argument is @()@ because "out" requires a successful parse.+--+-- b) Either an error or the result of a successful parse, including a proper+--    "CommandDesc out" from which an "out" can be extracted (presuming that+--    the command has an implementation).+runCmdParser+  :: Maybe String -- ^ program name to be used for the top-level @CommandDesc@+  -> Input -- ^ input to be processed+  -> CmdParser Identity out () -- ^ parser to use+  -> (CommandDesc (), Either ParsingError (CommandDesc out))+runCmdParser mTopLevel inputInitial cmdParser =+  runIdentity $ runCmdParserA mTopLevel inputInitial cmdParser++-- | Like 'runCmdParser', but also returning all input after the last+-- successfully parsed subcommand. E.g. for some input+-- "myprog foo bar -v --wrong" where parsing fails at "--wrong", this will+-- contain the full "-v --wrong". Useful for interactive feedback stuff.+runCmdParserExt+  :: Maybe String -- ^ program name to be used for the top-level @CommandDesc@+  -> Input -- ^ input to be processed+  -> CmdParser Identity out () -- ^ parser to use+  -> (CommandDesc (), Input, Either ParsingError (CommandDesc out))+runCmdParserExt mTopLevel inputInitial cmdParser =+  runIdentity $ runCmdParserAExt mTopLevel inputInitial cmdParser++-- | The Applicative-enabled version of 'runCmdParser'.+runCmdParserA+  :: forall f out+   . Applicative f+  => Maybe String -- ^ program name to be used for the top-level @CommandDesc@+  -> Input -- ^ input to be processed+  -> CmdParser f out () -- ^ parser to use+  -> f (CommandDesc (), Either ParsingError (CommandDesc out))+runCmdParserA mTopLevel inputInitial cmdParser =+  (\(x, _, z) -> (x, z)) <$> runCmdParserAExt mTopLevel inputInitial cmdParser++-- | The Applicative-enabled version of 'runCmdParserExt'.+runCmdParserAExt+  :: forall f out+   . Applicative f+  => Maybe String -- ^ program name to be used for the top-level @CommandDesc@+  -> Input -- ^ input to be processed+  -> CmdParser f out () -- ^ parser to use+  -> f+       ( CommandDesc ()+       , Input+       , Either ParsingError (CommandDesc out)+       )+runCmdParserAExt mTopLevel inputInitial cmdParser =+  runIdentity+    $ MultiRWSS.runMultiRWSTNil+    $ (<&> captureFinal)+    $ MultiRWSS.withMultiWriterWA+    $ MultiRWSS.withMultiStateA cmdParser+    $ MultiRWSS.withMultiStateSA (StackBottom mempty)+    $ MultiRWSS.withMultiStateSA inputInitial+    $ MultiRWSS.withMultiStateSA (PastCommandInput inputInitial)+    $ MultiRWSS.withMultiStateSA initialCommandDesc+    $ processMain cmdParser+ where+  initialCommandDesc = emptyCommandDesc+    { _cmd_mParent = mTopLevel <&> \n -> (Just n, emptyCommandDesc)+    }+  captureFinal+    :: ( [String]+       , (CmdDescStack, (Input, (PastCommandInput, (CommandDesc out, f ()))))+       )+    -> f (CommandDesc (), Input, Either ParsingError (CommandDesc out))+  captureFinal tuple1 = act $> (() <$ cmd', pastCmdInput, res)+   where+    (errs                         , tuple2) = tuple1+    (descStack                    , tuple3) = tuple2+    (inputRest                    , tuple4) = tuple3+    (PastCommandInput pastCmdInput, tuple5) = tuple4+    (cmd                          , act   ) = tuple5+    errs'     = errs ++ inputErrs ++ stackErrs+    inputErrs = case inputRest of+      InputString s | all Char.isSpace s -> []+      InputString{} -> ["could not parse input/unprocessed input"]+      InputArgs [] -> []+      InputArgs{} -> ["could not parse input/unprocessed input"]+    stackErrs = case descStack of+      StackBottom{} -> []+      _             -> ["butcher interface error: unclosed group"]+    cmd' = postProcessCmd descStack cmd+    res =+      if null errs' then Right cmd' else Left $ ParsingError errs' inputRest+  processMain+    :: CmdParser f out ()+    -> MultiRWSS.MultiRWS+         '[]+         '[[String]]+         '[CommandDesc out, PastCommandInput, Input, CmdDescStack, CmdParser+           f+           out+           ()]+         (f ())+  processMain = \case+    Pure ()                     -> return $ pure $ ()+    Free (CmdParserHelp h next) -> do+      cmd :: CommandDesc out <- mGet+      mSet $ cmd { _cmd_help = Just h }+      processMain next+    Free (CmdParserSynopsis s next) -> do+      cmd :: CommandDesc out <- mGet+      mSet+        $ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s }+      processMain next+    Free (CmdParserPeekDesc nextF) -> do+      parser                    <- mGet+      -- partialDesc :: CommandDesc out <- mGet+      -- partialStack :: CmdDescStack <- mGet+      -- run the rest without affecting the actual stack+      -- to retrieve the complete cmddesc.+      cmdCur :: CommandDesc out <- mGet+      let (cmd :: CommandDesc out, stack) =+            runIdentity+              $ MultiRWSS.runMultiRWSTNil+              $ MultiRWSS.withMultiStateSA emptyCommandDesc+                  { _cmd_mParent = _cmd_mParent cmdCur+                  } -- partialDesc+              $ MultiRWSS.withMultiStateS (StackBottom mempty) -- partialStack+              $ iterM processCmdShallow+              $ parser+      processMain $ nextF $ () <$ postProcessCmd stack cmd+    Free (CmdParserPeekInput nextF) -> do+      processMain $ nextF $ inputToString inputInitial+    Free (CmdParserPart desc parseF actF nextF) -> do+      do+        descStack <- mGet+        mSet $ descStackAdd desc descStack+      input <- mGet+      case input of+        InputString str -> case parseF str of+          Just (x, rest) -> do+            mSet $ InputString rest+            actRest <- processMain $ nextF x+            return $ actF x *> actRest+          Nothing -> do+            mTell ["could not parse " ++ getPartSeqDescPositionName desc]+            processMain $ nextF monadMisuseError+        InputArgs (str:strr) -> case parseF str of+          Just (x, "") -> do+            mSet $ InputArgs strr+            actRest <- processMain $ nextF x+            return $ actF x *> actRest+          _ -> do+            mTell ["could not parse " ++ getPartSeqDescPositionName desc]+            processMain $ nextF monadMisuseError+        InputArgs [] -> do+          mTell ["could not parse " ++ getPartSeqDescPositionName desc]+          processMain $ nextF monadMisuseError+    Free (CmdParserPartInp desc parseF actF nextF) -> do+      do+        descStack <- mGet+        mSet $ descStackAdd desc descStack+      input <- mGet+      case parseF input of+        Just (x, rest) -> do+          mSet $ rest+          actRest <- processMain $ nextF x+          return $ actF x *> actRest+        Nothing -> do+          mTell ["could not parse " ++ getPartSeqDescPositionName desc]+          processMain $ nextF monadMisuseError+    Free (CmdParserPartMany bound desc parseF actF nextF) -> do+      do+        descStack <- mGet+        mSet $ descStackAdd (wrapBoundDesc bound desc) descStack+      let proc = do+            dropSpaces+            input <- mGet+            case input of+              InputString str -> case parseF str of+                Just (x, r) -> do+                  mSet $ InputString r+                  xr <- proc+                  return $ x : xr+                Nothing -> return []+              InputArgs (str:strr) -> case parseF str of+                Just (x, "") -> do+                  mSet $ InputArgs strr+                  xr <- proc+                  return $ x : xr+                _ -> return []+              InputArgs [] -> return []+      r <- proc+      let act = traverse actF r+      (act *>) <$> processMain (nextF $ r)+    Free (CmdParserPartManyInp bound desc parseF actF nextF) -> do+      do+        descStack <- mGet+        mSet $ descStackAdd (wrapBoundDesc bound desc) descStack+      let proc = do+            dropSpaces+            input <- mGet+            case parseF input of+              Just (x, r) -> do+                mSet $ r+                xr <- proc+                return $ x : xr+              Nothing -> return []+      r <- proc+      let act = traverse actF r+      (act *>) <$> processMain (nextF $ r)+    f@(Free (CmdParserChild _ _ _ _ _)) -> do+      dropSpaces+      input <- mGet+      (gatheredChildren :: [ChildGather f out], restCmdParser) <-+        MultiRWSS.withMultiWriterWA $ childrenGather f+      let+        child_fold+          :: ( Deque (Maybe String)+             , Map (Maybe String) (Visibility, CmdParser f out (), f ())+             )+          -> ChildGather f out+          -> ( Deque (Maybe String)+             , Map (Maybe String) (Visibility, CmdParser f out (), f ())+             )+        child_fold (c_names, c_map) (ChildGather name vis child act) =+          case name `MapS.lookup` c_map of+            Nothing ->+              ( Deque.snoc name c_names+              , MapS.insert name (vis, child, act) c_map+              )+            Just (vis', child', act') ->+              ( c_names+              , MapS.insert name (vis', child' >> child, act') c_map+                 -- we intentionally override/ignore act here.+                 -- TODO: it should be documented that we expect the same act+                 -- on different child nodes with the same name.+              )+        (child_name_list, child_map) =+          foldl' child_fold (mempty, MapS.empty) gatheredChildren+        combined_child_list =+          Data.Foldable.toList child_name_list <&> \n -> (n, child_map MapS.! n)+      let+        mRest = asum $ combined_child_list <&> \(mname, (child, act, vis)) ->+          case (mname, input) of+            (Just name, InputString str) | name == str ->+              Just $ (Just name, child, act, vis, InputString "")+            (Just name, InputString str) | (name ++ " ") `isPrefixOf` str ->+              Just+                $ ( Just name+                  , child+                  , act+                  , vis+                  , InputString $ drop (length name + 1) str+                  )+            (Just name, InputArgs (str:strr)) | name == str ->+              Just $ (Just name, child, act, vis, InputArgs strr)+            (Nothing, _) -> Just $ (Nothing, child, act, vis, input)+            _            -> Nothing+      case mRest of+        Nothing -> do -- a child not matching what we have in the input+          let initialDesc :: CommandDesc out = emptyCommandDesc+          -- get the shallow desc for the child in a separate env.+          combined_child_list `forM_` \(child_name, (vis, child, _)) -> do+            let (subCmd, subStack) =+                  runIdentity+                    $ MultiRWSS.runMultiRWSTNil+                    $ MultiRWSS.withMultiStateSA initialDesc+                    $ MultiRWSS.withMultiStateS (StackBottom mempty)+                    $ iterM processCmdShallow child+            cmd_children %=+ Deque.snoc+              ( child_name+              , postProcessCmd subStack subCmd { _cmd_visibility = vis }+              )+          -- proceed regularly on the same layer+          processMain $ restCmdParser+        Just (name, vis, child, act, rest) -> do -- matching child -> descend+          -- process all remaining stuff on the same layer shallowly,+          -- including the current node. This will be replaced later.+          iterM processCmdShallow f+          -- so the descend+          cmd <- do+            c :: CommandDesc out      <- mGet+            prevStack :: CmdDescStack <- mGet+            return $ postProcessCmd prevStack c+          mSet $ rest+          mSet $ PastCommandInput rest+          mSet $ emptyCommandDesc { _cmd_mParent    = Just (name, cmd)+                                  , _cmd_visibility = vis+                                  }+          mSet $ child+          mSet $ StackBottom mempty+          childAct <- processMain child+          -- check that descending yielded+          return $ act *> childAct+    Free (CmdParserImpl out next) -> do+      cmd_out .=+ Just out+      processMain $ next+    Free (CmdParserGrouped groupName next) -> do+      stackCur <- mGet+      mSet $ StackLayer mempty groupName stackCur+      processMain $ next+    Free (CmdParserGroupEnd next) -> do+      stackCur <- mGet+      case stackCur of+        StackBottom{} -> do+          mTell $ ["butcher interface error: group end without group start"]+          return $ pure () -- hard abort should be fine for this case.+        StackLayer descs groupName up -> do+          mSet $ descStackAdd+            (PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))+            up+          processMain $ next+    Free (CmdParserReorderStop next) -> do+      mTell $ ["butcher interface error: reorder stop without reorder start"]+      processMain next+    Free (CmdParserReorderStart next) -> do+      reorderData <-+        MultiRWSS.withMultiStateA (1 :: Int)+        $ MultiRWSS.withMultiWriterW+        $ iterM reorderPartGather+        $ next+      let+        reorderMapInit :: Map Int (PartGatherData f)+        reorderMapInit = MapS.fromList $ reorderData <&> \d -> (_pgd_id d, d)+        tryParsePartData+          :: Input+          -> PartGatherData f+          -> First (Int, Dynamic, Input, Bool, f ())+        tryParsePartData input (PartGatherData pid _ pfe act allowMany) = First+          [ (pid, toDyn r, rest, allowMany, act r)+          | (r, rest) <- case pfe of+            Left pfStr -> case input of+              InputString str -> case pfStr str of+                Just (x, r) | r /= str -> Just (x, InputString r)+                _                      -> Nothing+              InputArgs (str:strr) -> case pfStr str of+                Just (x, "") -> Just (x, InputArgs strr)+                _            -> Nothing+              InputArgs [] -> Nothing+            Right pfInp -> case pfInp input of+              Just (x, r) | r /= input -> Just (x, r)+              _                        -> Nothing+          ]+        parseLoop = do+          input                           <- mGet+          m :: Map Int (PartGatherData f) <- mGet+          case getFirst $ Data.Foldable.foldMap (tryParsePartData input) m of+                     -- i will be angry if foldMap ever decides to not fold+                     -- in order of keys.+            Nothing                        -> return $ pure ()+            Just (pid, x, rest, more, act) -> do+              mSet rest+              mModify $ MapS.insertWith (++) pid [x]+              when (not more) $ do+                mSet $ MapS.delete pid m+              actRest <- parseLoop+              return $ act *> actRest+      (finalMap, (fr, acts)) <-+        MultiRWSS.withMultiStateSA (MapS.empty :: PartParsedData)+        $ MultiRWSS.withMultiStateA reorderMapInit+        $ do+            acts     <- parseLoop -- filling the map+            stackCur <- mGet+            mSet $ StackLayer mempty "" stackCur+            fr <- MultiRWSS.withMultiStateA (1 :: Int) $ processParsedParts next+            return (fr, acts)+      -- we check that all data placed in the map has been consumed while+      -- running the parts for which we collected the parseresults.+      -- there can only be any rest if the collection of parts changed+      -- between the reorderPartGather traversal and the processParsedParts+      -- consumption.+      if MapS.null finalMap+        then do+          actRest <- processMain fr+          return $ acts *> actRest+        else monadMisuseError++  reorderPartGather+    :: ( MonadMultiState Int m+       , MonadMultiWriter [PartGatherData f] m+       , MonadMultiWriter [String] m+       )+    => CmdParserF f out (m ())+    -> m ()+  reorderPartGather = \case+    -- TODO: why do PartGatherData contain desc?+    CmdParserPart desc parseF actF nextF -> do+      pid <- mGet+      mSet $ pid + 1+      mTell [PartGatherData pid desc (Left parseF) actF False]+      nextF $ monadMisuseError+    CmdParserPartInp desc parseF actF nextF -> do+      pid <- mGet+      mSet $ pid + 1+      mTell [PartGatherData pid desc (Right parseF) actF False]+      nextF $ monadMisuseError+    CmdParserPartMany _ desc parseF actF nextF -> do+      pid <- mGet+      mSet $ pid + 1+      mTell [PartGatherData pid desc (Left parseF) actF True]+      nextF $ monadMisuseError+    CmdParserPartManyInp _ desc parseF actF nextF -> do+      pid <- mGet+      mSet $ pid + 1+      mTell [PartGatherData pid desc (Right parseF) actF True]+      nextF $ monadMisuseError+    CmdParserReorderStop _next -> do+      return ()+    CmdParserHelp{}         -> restCase+    CmdParserSynopsis{}     -> restCase+    CmdParserPeekDesc{}     -> restCase+    CmdParserPeekInput{}    -> restCase+    CmdParserChild{}        -> restCase+    CmdParserImpl{}         -> restCase+    CmdParserReorderStart{} -> restCase+    CmdParserGrouped{}      -> restCase+    CmdParserGroupEnd{}     -> restCase+   where+    restCase = do+      mTell ["Did not find expected ReorderStop after the reordered parts"]+      return ()++  childrenGather+    :: ( MonadMultiWriter [ChildGather f out] m+       , MonadMultiState (CmdParser f out ()) m+       , MonadMultiState (CommandDesc out) m+       )+    => CmdParser f out a+    -> m (CmdParser f out a)+  childrenGather = \case+    Free (CmdParserChild cmdStr vis sub act next) -> do+      mTell [ChildGather cmdStr vis sub act]+      childrenGather next+    Free (CmdParserPeekInput nextF) -> do+      childrenGather $ nextF $ inputToString inputInitial+    Free (CmdParserPeekDesc nextF) -> do+      parser                    <- mGet+      -- partialDesc :: CommandDesc out <- mGet+      -- partialStack :: CmdDescStack <- mGet+      -- run the rest without affecting the actual stack+      -- to retrieve the complete cmddesc.+      cmdCur :: CommandDesc out <- mGet+      let (cmd :: CommandDesc out, stack) =+            runIdentity+              $ MultiRWSS.runMultiRWSTNil+              $ MultiRWSS.withMultiStateSA emptyCommandDesc+                  { _cmd_mParent = _cmd_mParent cmdCur+                  } -- partialDesc+              $ MultiRWSS.withMultiStateS (StackBottom mempty) -- partialStack+              $ iterM processCmdShallow+              $ parser+      childrenGather $ nextF $ () <$ postProcessCmd stack cmd+    something -> return something++  processParsedParts+    :: forall m r w s m0 a+     . ( MonadMultiState Int m+       , MonadMultiState PartParsedData m+       , MonadMultiState (Map Int (PartGatherData f)) m+       , MonadMultiState Input m+       , MonadMultiState (CommandDesc out) m+       , MonadMultiWriter [[Char]] m+       , m ~ MultiRWSS.MultiRWST r w s m0+       , ContainsType (CmdParser f out ()) s+       , ContainsType CmdDescStack s+       , Monad m0+       )+    => CmdParser f out a+    -> m (CmdParser f out a)+  processParsedParts = \case+    Free (CmdParserPart desc _ _ (nextF :: p -> CmdParser f out a)) ->+      part desc nextF+    Free (CmdParserPartInp desc _ _ (nextF :: p -> CmdParser f out a)) ->+      part desc nextF+    Free (CmdParserPartMany bound desc _ _ nextF) -> partMany bound desc nextF+    Free (CmdParserPartManyInp bound desc _ _ nextF) ->+      partMany bound desc nextF+    Free (CmdParserReorderStop next) -> do+      stackCur <- mGet+      case stackCur of+        StackBottom{} -> do+          mTell ["unexpected stackBottom"]+        StackLayer descs _ up -> do+          mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up+      return next+    Free (CmdParserGrouped groupName next) -> do+      stackCur <- mGet+      mSet $ StackLayer mempty groupName stackCur+      processParsedParts $ next+    Free (CmdParserGroupEnd next) -> do+      stackCur <- mGet+      case stackCur of+        StackBottom{} -> do+          mTell $ ["butcher interface error: group end without group start"]+          return $ next -- hard abort should be fine for this case.+        StackLayer descs groupName up -> do+          mSet $ descStackAdd+            (PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))+            up+          processParsedParts $ next+    Pure x -> return $ return $ x+    f      -> do+      mTell ["Did not find expected ReorderStop after the reordered parts"]+      return f+   where+    part+      :: forall p+       . Typeable p+      => PartDesc+      -> (p -> CmdParser f out a)+      -> m (CmdParser f out a)+    part desc nextF = do+      do+        stackCur <- mGet+        mSet $ descStackAdd desc stackCur+      pid <- mGet+      mSet $ pid + 1+      parsedMap :: PartParsedData <- mGet+      mSet $ MapS.delete pid parsedMap+      partMap :: Map Int (PartGatherData f) <- mGet+      input :: Input                        <- mGet+      let+        errorResult = do+          mTell+            [ "could not parse expected input "+              ++ getPartSeqDescPositionName desc+              ++ " with remaining input: "+              ++ show input+            ]+          failureCurrentShallowRerun+          processParsedParts $ nextF monadMisuseError+        continueOrMisuse :: Maybe p -> m (CmdParser f out a)+        continueOrMisuse = maybe monadMisuseError (processParsedParts . nextF)+      case MapS.lookup pid parsedMap of+        Nothing -> case MapS.lookup pid partMap of+          Nothing                           -> monadMisuseError -- it would still be in the map+                                      -- if it never had been successfully+                                      -- parsed, as indicicated by the+                                      -- previous parsedMap Nothing lookup.+          Just (PartGatherData _ _ pfe _ _) -> case pfe of+            Left pf -> case pf "" of+              Nothing      -> errorResult+              Just (dx, _) -> continueOrMisuse $ cast dx+            Right pf -> case pf (InputArgs []) of+              Nothing      -> errorResult+              Just (dx, _) -> continueOrMisuse $ cast dx+        Just [dx] -> continueOrMisuse $ fromDynamic dx+        Just _    -> monadMisuseError+    partMany+      :: Typeable p+      => ManyUpperBound+      -> PartDesc+      -> ([p] -> CmdParser f out a)+      -> m (CmdParser f out a)+    partMany bound desc nextF = do+      do+        stackCur <- mGet+        mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur+      pid <- mGet+      mSet $ pid + 1+      m :: PartParsedData <- mGet+      mSet $ MapS.delete pid m+      let partDyns = case MapS.lookup pid m of+            Nothing -> []+            Just r  -> reverse r+      case mapM fromDynamic partDyns of+        Nothing -> monadMisuseError+        Just xs -> processParsedParts $ nextF xs++  -- this does no error reporting at all.+  -- user needs to use check for that purpose instead.+  processCmdShallow+    :: (MonadMultiState (CommandDesc out) m, MonadMultiState CmdDescStack m)+    => CmdParserF f out (m ())+    -> m ()+  processCmdShallow = \case+    CmdParserHelp h next -> do+      cmd :: CommandDesc out <- mGet+      mSet $ cmd { _cmd_help = Just h }+      next+    CmdParserSynopsis s next -> do+      cmd :: CommandDesc out <- mGet+      mSet+        $ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s }+      next+    CmdParserPeekDesc nextF -> do+      mGet >>= nextF . fmap (\(_ :: out) -> ())+    CmdParserPeekInput nextF -> do+      nextF $ inputToString inputInitial+    CmdParserPart desc _parseF _act nextF -> do+      do+        stackCur <- mGet+        mSet $ descStackAdd desc stackCur+      nextF monadMisuseError+    CmdParserPartInp desc _parseF _act nextF -> do+      do+        stackCur <- mGet+        mSet $ descStackAdd desc stackCur+      nextF monadMisuseError+    CmdParserPartMany bound desc _parseF _act nextF -> do+      do+        stackCur <- mGet+        mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur+      nextF monadMisuseError+    CmdParserPartManyInp bound desc _parseF _act nextF -> do+      do+        stackCur <- mGet+        mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur+      nextF monadMisuseError+    CmdParserChild cmdStr vis _sub _act next -> do+      mExisting <- takeCommandChild cmdStr+      let childDesc :: CommandDesc out =+            fromMaybe emptyCommandDesc { _cmd_visibility = vis } mExisting+      cmd_children %=+ Deque.snoc (cmdStr, childDesc)+      next+    CmdParserImpl out next -> do+      cmd_out .=+ Just out+      next+    CmdParserGrouped groupName next -> do+      stackCur <- mGet+      mSet $ StackLayer mempty groupName stackCur+      next+    CmdParserGroupEnd next -> do+      stackCur <- mGet+      case stackCur of+        StackBottom{} -> do+          return ()+        StackLayer _descs "" _up -> do+          return ()+        StackLayer descs groupName up -> do+          mSet $ descStackAdd+            (PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))+            up+          next+    CmdParserReorderStop next -> do+      stackCur <- mGet+      case stackCur of+        StackBottom{}          -> return ()+        StackLayer descs "" up -> do+          mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up+        StackLayer{} -> return ()+      next+    CmdParserReorderStart next -> do+      stackCur <- mGet+      mSet $ StackLayer mempty "" stackCur+      next++  failureCurrentShallowRerun+    :: ( m ~ MultiRWSS.MultiRWST r w s m0+       , MonadMultiState (CmdParser f out ()) m+       , MonadMultiState (CommandDesc out) m+       , ContainsType CmdDescStack s+       , Monad m0+       )+    => m ()+  failureCurrentShallowRerun = do+    parser                 <- mGet+    cmd :: CommandDesc out <-+      MultiRWSS.withMultiStateS emptyCommandDesc+        $ iterM processCmdShallow parser+    mSet cmd++  postProcessCmd :: CmdDescStack -> CommandDesc out -> CommandDesc out+  postProcessCmd descStack cmd = descFixParents $ cmd+    { _cmd_parts = case descStack of+      StackBottom l -> Data.Foldable.toList l+      StackLayer{}  -> []+    }++  monadMisuseError :: a+  monadMisuseError =+    error+      $  "CmdParser definition error -"+      ++ " used Monad powers where only Applicative/Arrow is allowed"+++  getPartSeqDescPositionName :: PartDesc -> String+  getPartSeqDescPositionName = \case+    PartLiteral  s     -> s+    PartVariable s     -> s+    PartOptional ds'   -> f ds'+    PartAlts     alts  -> f $ head alts -- this is not optimal, but probably+                                   -- does not matter.+    PartDefault    _ d -> f d+    PartSuggestion _ d -> f d+    PartRedirect   s _ -> s+    PartMany ds        -> f ds+    PartWithHelp _ d   -> f d+    PartSeq     ds     -> List.unwords $ f <$> ds+    PartReorder ds     -> List.unwords $ f <$> ds+    PartHidden  d      -> f d+    where f = getPartSeqDescPositionName++  dropSpaces :: MonadMultiState Input m => m ()+  dropSpaces = do+    inp <- mGet+    case inp of+      InputString s -> mSet $ InputString $ dropWhile Char.isSpace s+      InputArgs{}   -> return ()++  inputToString :: Input -> String+  inputToString (InputString s ) = s+  inputToString (InputArgs   ss) = List.unwords ss++dequeLookupRemove :: Eq k => k -> Deque (k, a) -> (Maybe a, Deque (k, a))+dequeLookupRemove key deque = case Deque.uncons deque of+  Nothing             -> (Nothing, mempty)+  Just ((k, v), rest) -> if k == key+    then (Just v, rest)+    else+      let (r, rest') = dequeLookupRemove key rest+      in  (r, Deque.cons (k, v) rest')++takeCommandChild+  :: MonadMultiState (CommandDesc out) m+  => Maybe String+  -> m (Maybe (CommandDesc out))+takeCommandChild key = do+  cmd <- mGet+  let (r, children') = dequeLookupRemove key $ _cmd_children cmd+  mSet cmd { _cmd_children = children' }+  return r++-- | map over the @out@ type argument+mapOut :: (outa -> outb) -> CmdParser f outa () -> CmdParser f outb ()+mapOut f = hoistFree $ \case+  CmdParserHelp     doc r     -> CmdParserHelp doc r+  CmdParserSynopsis s   r     -> CmdParserSynopsis s r+  CmdParserPeekDesc  fr       -> CmdParserPeekDesc fr+  CmdParserPeekInput fr       -> CmdParserPeekInput fr+  CmdParserPart desc fp fa fr -> CmdParserPart desc fp fa fr+  CmdParserPartMany bound desc fp fa fr ->+    CmdParserPartMany bound desc fp fa fr+  CmdParserPartInp desc fp fa fr -> CmdParserPartInp desc fp fa fr+  CmdParserPartManyInp bound desc fp fa fr ->+    CmdParserPartManyInp bound desc fp fa fr+  CmdParserChild s vis child act r ->+    CmdParserChild s vis (mapOut f child) act r+  CmdParserImpl out r     -> CmdParserImpl (f out) r+  CmdParserReorderStart r -> CmdParserReorderStart r+  CmdParserReorderStop  r -> CmdParserReorderStop r+  CmdParserGrouped s r    -> CmdParserGrouped s r+  CmdParserGroupEnd r     -> CmdParserGroupEnd r++-- cmdActionPartial :: CommandDesc out -> Either String out+-- cmdActionPartial = maybe (Left err) Right . _cmd_out+--   where+--     err = "command is missing implementation!"+--  +-- cmdAction :: CmdParser out () -> String -> Either String out+-- cmdAction b s = case runCmdParser Nothing s b of+--   (_, Right cmd)                     -> cmdActionPartial cmd+--   (_, Left (ParsingError (out:_) _)) -> Left $ out+--   _ -> error "whoops"+-- +-- cmdActionRun :: (CommandDesc () -> ParsingError -> out)+--              -> CmdParser out ()+--              -> String+--              -> out+-- cmdActionRun f p s = case runCmdParser Nothing s p of+--   (cmd, Right out) -> case _cmd_out out of+--     Just o -> o+--     Nothing -> f cmd (ParsingError ["command is missing implementation!"] "")+--   (cmd, Left err) -> f cmd err++wrapBoundDesc :: ManyUpperBound -> PartDesc -> PartDesc+wrapBoundDesc ManyUpperBound1 = PartOptional+wrapBoundDesc ManyUpperBoundN = PartMany+++descFixParents :: CommandDesc a -> CommandDesc a+descFixParents = descFixParentsWithTopM Nothing++-- descFixParentsWithTop :: String -> CommandDesc a -> CommandDesc a+-- descFixParentsWithTop s = descFixParentsWithTopM (Just (s, emptyCommandDesc))++descFixParentsWithTopM+  :: Maybe (Maybe String, CommandDesc a) -> CommandDesc a -> CommandDesc a+descFixParentsWithTopM mTop topDesc = Data.Function.fix $ \fixed -> topDesc+  { _cmd_mParent  = goUp fixed <$> (mTop <|> _cmd_mParent topDesc)+  , _cmd_children = _cmd_children topDesc <&> goDown fixed+  }+ where+  goUp+    :: CommandDesc a+    -> (Maybe String, CommandDesc a)+    -> (Maybe String, CommandDesc a)+  goUp child (childName, parent) =+    (,) childName $ Data.Function.fix $ \fixed -> parent+      { _cmd_mParent  = goUp fixed <$> _cmd_mParent parent+      , _cmd_children = _cmd_children parent+        <&> \(n, c) -> if n == childName then (n, child) else (n, c)+      }+  goDown+    :: CommandDesc a+    -> (Maybe String, CommandDesc a)+    -> (Maybe String, CommandDesc a)+  goDown parent (childName, child) =+    (,) childName $ Data.Function.fix $ \fixed -> child+      { _cmd_mParent  = Just (childName, parent)+      , _cmd_children = _cmd_children child <&> goDown fixed+      }+++_tooLongText+  :: Int -- max length+  -> String -- alternative if actual length is bigger than max.+  -> String -- text to print, if length is fine.+  -> PP.Doc _tooLongText i alt s = PP.text $ Bool.bool alt s $ null $ drop i s

@@ -13,6 +13,7 @@   , cmd_parts   , cmd_out   , cmd_children+  , cmd_visibility   , emptyCommandDesc   , CmdParserF (..)   , CmdParser@@ -21,6 +22,8 @@   , ParsingError (..)   , addSuggestion   , ManyUpperBound (..)+  , Visibility (..)+  , CompletionItem (..)   ) where @@ -57,6 +60,9 @@   = ManyUpperBound1   | ManyUpperBoundN +data Visibility = Visible | Hidden+  deriving (Show, Eq)+ data CmdParserF f out a   =                          CmdParserHelp PP.Doc a   |                          CmdParserSynopsis String a@@ -68,7 +74,7 @@   | forall p . Typeable p => CmdParserPartMany ManyUpperBound PartDesc (String -> Maybe (p, String)) (p -> f ()) ([p] -> a)   | forall p . Typeable p => CmdParserPartInp PartDesc (Input -> Maybe (p, Input)) (p -> f ()) (p -> a)   | forall p . Typeable p => CmdParserPartManyInp ManyUpperBound PartDesc (Input -> Maybe (p, Input)) (p -> f ()) ([p] -> a)-  |                          CmdParserChild (Maybe String) (CmdParser f out ()) (f ()) a+  |                          CmdParserChild (Maybe String) Visibility (CmdParser f out ()) (f ()) a   |                          CmdParserImpl  out                                a   |                          CmdParserReorderStart                             a   |                          CmdParserReorderStop                              a@@ -117,6 +123,7 @@   , _cmd_children :: Deque (Maybe String, CommandDesc out)                      -- we don't use a Map here because we'd like to                      -- retain the order.+  , _cmd_visibility :: Visibility   }  -- type PartSeqDesc = [PartDesc]@@ -134,18 +141,27 @@   | PartSeq [PartDesc]   | PartDefault String -- default representation                 PartDesc-  | PartSuggestion [String] PartDesc+  | PartSuggestion [CompletionItem] PartDesc   | PartRedirect String -- name for the redirection                  PartDesc   | PartReorder [PartDesc]   | PartMany PartDesc   | PartWithHelp PP.Doc PartDesc+  | PartHidden PartDesc   deriving Show -addSuggestion :: Maybe [String] -> PartDesc -> PartDesc+addSuggestion :: Maybe [CompletionItem] -> PartDesc -> PartDesc addSuggestion Nothing     = id addSuggestion (Just sugs) = PartSuggestion sugs ++data CompletionItem+  = CompletionString String+  | CompletionDirectory+  | CompletionFile+  deriving Show++ {- command documentation structure 1. terminals. e.g. "--dry-run"@@ -167,8 +183,10 @@  -- +-- | Empty 'CommandDesc' value. Mostly for butcher-internal usage. emptyCommandDesc :: CommandDesc out-emptyCommandDesc = CommandDesc Nothing Nothing Nothing [] Nothing mempty+emptyCommandDesc =+  CommandDesc Nothing Nothing Nothing [] Nothing mempty Visible  instance Show (CommandDesc out) where   show c = "Command help=" ++ show (_cmd_help c)@@ -208,3 +226,8 @@ --   show (CmdParserChild s _ _) = "(CmdParserChild " ++ s ++ ")" --   show (CmdParserRun _) = "CmdParserRun" +instance Alternative Deque where+  empty = mempty+  (<|>) = Deque.prepend++instance MonadPlus Deque

@@ -9,6 +9,8 @@   , paramHelpStr   , paramDefault   , paramSuggestions+  , paramFile+  , paramDirectory   , addParamRead   , addParamReadOpt   , addParamString@@ -18,6 +20,7 @@   , addParamNoFlagStringOpt   , addParamNoFlagStrings   , addParamRestOfInput+  , addParamRestOfInputRaw   , -- * Deprecated for more consistent naming     addReadParam   , addReadParamOpt@@ -49,7 +52,7 @@ data Param p = Param   { _param_default :: Maybe p   , _param_help :: Maybe PP.Doc-  , _param_suggestions :: Maybe [p]+  , _param_suggestions :: Maybe [CompletionItem]   }  instance Monoid (Param p) where@@ -77,9 +80,18 @@ paramDefault d = mempty { _param_default = Just d }  -- | Create a 'Param' with just a list of suggestion values.-paramSuggestions :: [p] -> Param p-paramSuggestions ss = mempty { _param_suggestions = Just ss }+paramSuggestions :: [String] -> Param p+paramSuggestions ss =+  mempty { _param_suggestions = Just $ CompletionString <$> ss } +-- | Create a 'Param' that is a file path.+paramFile :: Param p+paramFile = mempty { _param_suggestions = Just [CompletionFile] }++-- | Create a 'Param' that is a directory path.+paramDirectory :: Param p+paramDirectory = mempty { _param_suggestions = Just [CompletionDirectory] }+ -- | Add a parameter to the 'CmdParser' by making use of a 'Text.Read.Read' -- instance. Take care not to use this to return Strings unless you really -- want that, because it will require the quotation marks and escaping as@@ -99,7 +111,8 @@ addReadParam name par = addCmdPart desc parseF   where     desc :: PartDesc-    desc = (maybe id PartWithHelp $ _param_help par)+    desc = addSuggestion (_param_suggestions par)+         $ (maybe id PartWithHelp $ _param_help par)          $ (maybe id (PartDefault . show) $ _param_default par)          $ PartVariable name     parseF :: String -> Maybe (a, String)@@ -124,7 +137,8 @@ addReadParamOpt name par = addCmdPart desc parseF   where     desc :: PartDesc-    desc = PartOptional+    desc = addSuggestion (_param_suggestions par)+         $ PartOptional          $ (maybe id PartWithHelp $ _param_help par)          $ PartVariable name     parseF :: String -> Maybe (Maybe a, String)@@ -180,7 +194,8 @@ addStringParamOpt name par = addCmdPartInp desc parseF   where     desc :: PartDesc-    desc = PartOptional+    desc = addSuggestion (_param_suggestions par)+         $ PartOptional          $ (maybe id PartWithHelp $ _param_help par)          $ PartVariable name     parseF :: Input -> Maybe (Maybe String, Input)@@ -213,7 +228,10 @@ addStringParams name par = addCmdPartManyInp ManyUpperBoundN desc parseF  where   desc :: PartDesc-  desc = (maybe id PartWithHelp $ _param_help par) $ PartVariable name+  desc =+    addSuggestion (_param_suggestions par)+      $ (maybe id PartWithHelp $ _param_help par)+      $ PartVariable name   parseF :: Input -> Maybe (String, Input)   parseF (InputString str) =     case break Char.isSpace $ dropWhile Char.isSpace str of@@ -284,7 +302,10 @@ addParamNoFlagStrings name par = addCmdPartManyInp ManyUpperBoundN desc parseF  where   desc :: PartDesc-  desc = (maybe id PartWithHelp $ _param_help par) $ PartVariable name+  desc =+    addSuggestion (_param_suggestions par)+      $ (maybe id PartWithHelp $ _param_help par)+      $ PartVariable name   parseF :: Input -> Maybe (String, Input)   parseF (InputString str) =     case break Char.isSpace $ dropWhile Char.isSpace str of@@ -307,15 +328,38 @@ addParamRestOfInput = addRestOfInputStringParam {-# DEPRECATED addRestOfInputStringParam "use 'addParamRestOfInput'" #-} addRestOfInputStringParam-  :: forall f out . (Applicative f)+  :: forall f out+   . (Applicative f)   => String   -> Param Void   -> CmdParser f out String addRestOfInputStringParam name par = addCmdPartInp desc parseF-  where-    desc :: PartDesc-    desc = (maybe id PartWithHelp $ _param_help par)-         $ PartVariable name-    parseF :: Input -> Maybe (String, Input)-    parseF (InputString str) = Just (str, InputString "")-    parseF (InputArgs args)  = Just (List.unwords args, InputArgs [])+ where+  desc :: PartDesc+  desc =+    addSuggestion (_param_suggestions par)+      $ (maybe id PartWithHelp $ _param_help par)+      $ PartVariable name+  parseF :: Input -> Maybe (String, Input)+  parseF (InputString str ) = Just (str, InputString "")+  parseF (InputArgs   args) = Just (List.unwords args, InputArgs [])+++-- | Add a parameter that consumes _all_ remaining input, returning a raw+-- 'Input' value.+addParamRestOfInputRaw+  :: forall f out . (Applicative f)+  => String+  -> Param Void+  -> CmdParser f out Input+addParamRestOfInputRaw name par = addCmdPartInp desc parseF+ where+  desc :: PartDesc+  desc =+    addSuggestion (_param_suggestions par)+      $ (maybe id PartWithHelp $ _param_help par)+      $ PartVariable name+  parseF :: Input -> Maybe (Input, Input)+  parseF i@InputString{} = Just (i, InputString "")+  parseF i@InputArgs{}   = Just (i, InputArgs [])+

@@ -28,8 +28,10 @@ -- >       else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!" module UI.Butcher.Monadic.Pretty   ( ppUsage+  , ppUsageShortSub   , ppUsageAt   , ppHelpShallow+  , ppHelpDepthOne   , ppUsageWithHelp   , ppPartDescUsage   , ppPartDescHeader@@ -58,16 +60,18 @@ -- -- > example [--short] NAME [version | help] ppUsage :: CommandDesc a -> PP.Doc-ppUsage (CommandDesc mParent _syn _help parts out children) = pparents mParent-  <+> PP.sep [PP.fsep partDocs, subsDoc]+ppUsage (CommandDesc mParent _syn _help parts out children _hidden) =+  pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]  where   pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc   pparents Nothing              = PP.empty   pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n   pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)-  partDocs = parts <&> ppPartDescUsage-  subsDoc  = case out of-    _ | null children -> PP.empty -- TODO: remove debug+  partDocs = Maybe.mapMaybe ppPartDescUsage parts+  visibleChildren =+    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]+  subsDoc = case out of+    _ | null visibleChildren -> PP.empty     Nothing | null parts -> subDoc             | otherwise  -> PP.parens $ subDoc     Just{} -> PP.brackets $ subDoc@@ -75,8 +79,31 @@     PP.fcat       $ PP.punctuate (PP.text " | ")       $ Data.Foldable.toList-      $ [ PP.text n | (Just n, _) <- children ]+      $ (PP.text . fst) <$> visibleChildren +-- | ppUsageShortSub exampleDesc yields:+--+-- > example [--short] NAME <command>+--+-- I.e. Subcommands are abbreviated using the @<command>@ label, instead+-- of being listed.+ppUsageShortSub :: CommandDesc a -> PP.Doc+ppUsageShortSub (CommandDesc mParent _syn _help parts out children _hidden) =+  pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]+ where+  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc+  pparents Nothing              = PP.empty+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)+  partDocs = Maybe.mapMaybe ppPartDescUsage parts+  visibleChildren =+    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]+  subsDoc = case out of+    _ | null visibleChildren -> PP.empty+    Nothing                  -> subDoc+    Just{}                   -> PP.brackets $ subDoc+  subDoc = if null visibleChildren then PP.empty else PP.text "<command>"+ -- | ppUsageWithHelp exampleDesc yields: -- -- > example [--short] NAME@@ -84,14 +111,14 @@ -- -- And yes, the line break is not optimal in this instance with default print. ppUsageWithHelp :: CommandDesc a -> PP.Doc-ppUsageWithHelp (CommandDesc mParent _syn help parts out children) =+ppUsageWithHelp (CommandDesc mParent _syn help parts out children _hidden) =   pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc  where   pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc   pparents Nothing              = PP.empty   pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n   pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)-  partDocs = parts <&> ppPartDescUsage+  partDocs = Maybe.mapMaybe ppPartDescUsage parts   subsDoc  = case out of     _ | null children -> PP.empty -- TODO: remove debug     Nothing | null parts -> subDoc@@ -101,7 +128,7 @@     PP.fcat       $ PP.punctuate (PP.text " | ")       $ Data.Foldable.toList-      $ [ PP.text n | (Just n, _) <- children ]+      $ [ PP.text n | (Just n, c) <- children, _cmd_visibility c == Visible ]   helpDoc = case help of     Nothing -> PP.empty     Just h  -> PP.text ":" PP.<+> h@@ -119,7 +146,7 @@     [] -> Just $ ppUsage desc     (s:sr) -> find ((Just s==) . fst) (_cmd_children desc) >>= ppUsageAt sr . snd --- | ppHelpShalloe exampleDesc yields:+-- | ppHelpShallow exampleDesc yields: -- -- > NAME -- > @@ -138,13 +165,14 @@ -- >   --short             make the greeting short -- >   NAME                your name, so you can be greeted properly ppHelpShallow :: CommandDesc a -> PP.Doc-ppHelpShallow desc@(CommandDesc mParent syn help parts _out _children) =+ppHelpShallow desc =   nameSection     $+$ usageSection     $+$ descriptionSection     $+$ partsSection     $+$ PP.text ""  where+  CommandDesc mParent syn help parts _out _children _hidden = desc   nameSection = case mParent of     Nothing -> PP.empty     Just{} ->@@ -183,24 +211,121 @@       PartDefault    _ p -> go p       PartSuggestion _ p -> go p       PartRedirect s p ->-        [PP.text s $$ PP.nest 20 (ppPartDescUsage p)] ++ (PP.nest 2 <$> go p)+        [PP.text s $$ PP.nest 20 (fromMaybe PP.empty $ ppPartDescUsage p)]+          ++ (PP.nest 2 <$> go p)       PartReorder ps     -> ps >>= go       PartMany    p      -> go p       PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p+      PartHidden{}       -> [] +-- | ppHelpDepthOne exampleDesc yields:+--+-- > NAME+-- > +-- >   example - a simple butcher example program+-- > +-- > USAGE+-- > +-- >   example [--short] NAME <command>+-- > +-- > DESCRIPTION+-- > +-- >   a very long help document+-- > +-- > COMMANDS+-- > +-- >   version+-- >   help+-- > +-- > ARGUMENTS+-- > +-- >   --short             make the greeting short+-- >   NAME                your name, so you can be greeted properly+ppHelpDepthOne :: CommandDesc a -> PP.Doc+ppHelpDepthOne desc =+  nameSection+    $+$ usageSection+    $+$ descriptionSection+    $+$ commandSection+    $+$ partsSection+    $+$ PP.text ""+ where+  CommandDesc mParent syn help parts _out children _hidden = desc+  nameSection = case mParent of+    Nothing -> PP.empty+    Just{} ->+      PP.text "NAME"+        $+$ PP.text ""+        $+$ PP.nest+              2+              ( case syn of+                Nothing -> pparents mParent+                Just s  -> pparents mParent <+> PP.text "-" <+> s+              )+        $+$ PP.text ""+  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc+  pparents Nothing              = PP.empty+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)+  usageSection =+    PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsageShortSub desc)+  descriptionSection = case help of+    Nothing -> PP.empty+    Just h ->+      PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h+  visibleChildren =+    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]+  childDescs = visibleChildren <&> \(n, c) ->+    PP.text n $$ PP.nest 20 (fromMaybe PP.empty (_cmd_synopsis c))+  commandSection = if null visibleChildren+    then PP.empty+    else PP.text "" $+$ PP.text "COMMANDS" $+$ PP.text "" $+$ PP.nest+      2+      (PP.vcat $ Data.Foldable.toList childDescs)+  partsSection = if null partsTuples+    then PP.empty+    else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest+      2+      (PP.vcat partsTuples)+  partsTuples :: [PP.Doc]+  partsTuples = parts >>= go+   where+    go = \case+      PartLiteral{}      -> []+      PartVariable{}     -> []+      PartOptional p     -> go p+      PartAlts     ps    -> ps >>= go+      PartSeq      ps    -> ps >>= go+      PartDefault    _ p -> go p+      PartSuggestion _ p -> go p+      PartRedirect s p ->+        [PP.text s $$ PP.nest 20 (fromMaybe PP.empty $ ppPartDescUsage p)]+          ++ (PP.nest 2 <$> go p)+      PartReorder ps     -> ps >>= go+      PartMany    p      -> go p+      PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p+      PartHidden{}       -> []+ -- | Internal helper; users probably won't need this.-ppPartDescUsage :: PartDesc -> PP.Doc+ppPartDescUsage :: PartDesc -> Maybe PP.Doc ppPartDescUsage = \case-  PartLiteral  s  -> PP.text s-  PartVariable s  -> PP.text s-  PartOptional p  -> PP.brackets $ rec p-  PartAlts     ps -> PP.fcat $ PP.punctuate (PP.text ",") $ rec <$> ps-  PartSeq      ps -> PP.fsep $ rec <$> ps-  PartDefault _ p -> PP.brackets $ rec p-  PartSuggestion s p ->-    PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ fmap PP.text s ++ [rec p]-  PartRedirect s _ -> PP.text s-  PartMany p       -> rec p <> PP.text "+"+  PartLiteral  s -> Just $ PP.text s+  PartVariable s -> Just $ PP.text s+  PartOptional p -> PP.brackets <$> rec p+  PartAlts ps ->+    [ PP.fcat $ PP.punctuate (PP.text ",") ds+    | let ds = Maybe.mapMaybe rec ps+    , not (null ds)+    ]+  PartSeq ps -> [ PP.fsep ds | let ds = Maybe.mapMaybe rec ps, not (null ds) ]+  PartDefault    _   p -> PP.brackets <$> rec p+  PartSuggestion sgs p -> rec p <&> \d ->+    case [ PP.text s | CompletionString s <- sgs ] of+      [] -> d+      sgsDocs ->+        PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ sgsDocs ++ [d]+  PartRedirect s _ -> Just $ PP.text s+  PartMany p       -> rec p <&> (<> PP.text "+")   PartWithHelp _ p -> rec p   PartReorder ps ->     let flags  = [ d | PartMany d <- ps ]@@ -210,11 +335,12 @@             _          -> True           )           ps-    in  PP.sep-          [(PP.fsep $ PP.brackets . rec <$> flags), PP.fsep (rec <$> params)]-- where-  rec = ppPartDescUsage+    in  Just $ PP.sep+          [ (PP.fsep $ PP.brackets <$> Maybe.mapMaybe rec flags)+          , PP.fsep (Maybe.mapMaybe rec params)+          ]+  PartHidden{} -> Nothing+  where rec = ppPartDescUsage  -- | Internal helper; users probably won't need this. ppPartDescHeader :: PartDesc -> PP.Doc@@ -230,8 +356,8 @@   PartWithHelp _ d   -> rec d   PartSeq     ds     -> PP.hsep $ rec <$> ds   PartReorder ds     -> PP.vcat $ rec <$> ds- where-  rec = ppPartDescHeader+  PartHidden  d      -> rec d+  where rec = ppPartDescHeader  -- | Simple conversion from 'ParsingError' to 'String'. parsingErrorString :: ParsingError -> String

@@ -8,6 +8,7 @@   , Input (..)   , ParsingError (..)   , PartDesc(..)+  , emptyCommandDesc   ) where 

@@ -26,8 +26,6 @@ import qualified System.Process.Extra import qualified System.Time.Extra -import qualified Data.Either.Combinators- import qualified Control.Monad.Trans.MultiRWS.Lazy import qualified Control.Monad.Trans.MultiRWS.Strict import qualified Control.Monad.Trans.MultiReader