diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -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'
diff --git a/butcher.cabal b/butcher.cabal
--- a/butcher.cabal
+++ b/butcher.cabal
@@ -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
diff --git a/src-tests/TestMain.hs b/src-tests/TestMain.hs
--- a/src-tests/TestMain.hs
+++ b/src-tests/TestMain.hs
@@ -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)
diff --git a/src/UI/Butcher/Monadic.hs b/src/UI/Butcher/Monadic.hs
--- a/src/UI/Butcher/Monadic.hs
+++ b/src/UI/Butcher/Monadic.hs
@@ -28,7 +28,11 @@
   -- , test3
     -- * Builtin commands
   , addHelpCommand
+  , addHelpCommand2
+  , addHelpCommandWith
   , addButcherDebugCommand
+  , addShellCompletionCommand
+  , addShellCompletionCommand'
   , mapOut
   )
 where
diff --git a/src/UI/Butcher/Monadic/BuiltinCommands.hs b/src/UI/Butcher/Monadic/BuiltinCommands.hs
--- a/src/UI/Butcher/Monadic/BuiltinCommands.hs
+++ b/src/UI/Butcher/Monadic/BuiltinCommands.hs
@@ -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
+      ]
 
diff --git a/src/UI/Butcher/Monadic/Command.hs b/src/UI/Butcher/Monadic/Command.hs
--- a/src/UI/Butcher/Monadic/Command.hs
+++ b/src/UI/Butcher/Monadic/Command.hs
@@ -53,6 +53,7 @@
 
 module UI.Butcher.Monadic.Command
   ( addCmd
+  , addCmdHidden
   , addNullCmd
   , addCmdImpl
   , addCmdSynopsis
diff --git a/src/UI/Butcher/Monadic/Flag.hs b/src/UI/Butcher/Monadic/Flag.hs
--- a/src/UI/Butcher/Monadic/Flag.hs
+++ b/src/UI/Butcher/Monadic/Flag.hs
@@ -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
diff --git a/src/UI/Butcher/Monadic/Interactive.hs b/src/UI/Butcher/Monadic/Interactive.hs
--- a/src/UI/Butcher/Monadic/Interactive.hs
+++ b/src/UI/Butcher/Monadic/Interactive.hs
@@ -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{}        -> []
diff --git a/src/UI/Butcher/Monadic/Internal/Core.hs b/src/UI/Butcher/Monadic/Internal/Core.hs
--- a/src/UI/Butcher/Monadic/Internal/Core.hs
+++ b/src/UI/Butcher/Monadic/Internal/Core.hs
@@ -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
diff --git a/src/UI/Butcher/Monadic/Internal/Types.hs b/src/UI/Butcher/Monadic/Internal/Types.hs
--- a/src/UI/Butcher/Monadic/Internal/Types.hs
+++ b/src/UI/Butcher/Monadic/Internal/Types.hs
@@ -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
diff --git a/src/UI/Butcher/Monadic/Param.hs b/src/UI/Butcher/Monadic/Param.hs
--- a/src/UI/Butcher/Monadic/Param.hs
+++ b/src/UI/Butcher/Monadic/Param.hs
@@ -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 [])
+
diff --git a/src/UI/Butcher/Monadic/Pretty.hs b/src/UI/Butcher/Monadic/Pretty.hs
--- a/src/UI/Butcher/Monadic/Pretty.hs
+++ b/src/UI/Butcher/Monadic/Pretty.hs
@@ -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
diff --git a/src/UI/Butcher/Monadic/Types.hs b/src/UI/Butcher/Monadic/Types.hs
--- a/src/UI/Butcher/Monadic/Types.hs
+++ b/src/UI/Butcher/Monadic/Types.hs
@@ -8,6 +8,7 @@
   , Input (..)
   , ParsingError (..)
   , PartDesc(..)
+  , emptyCommandDesc
   )
 where
 
diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc
--- a/srcinc/prelude.inc
+++ b/srcinc/prelude.inc
@@ -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