butcher (empty) → 1.1.0.0

raw patch · 17 files changed

+3700/−0 lines, 17 filesdep +basedep +bifunctorsdep +butchersetup-changed

Dependencies added: base, bifunctors, butcher, containers, deque, either, extra, free, hspec, microlens, microlens-th, mtl, multistate, pretty, transformers, unsafe, void

Files

• ChangeLog.md +5/−0
• LICENSE +30/−0
• README.md +241/−0
• Setup.hs +2/−0
• butcher.cabal +158/−0
• src-tests/TestMain.hs +187/−0
• src/UI/Butcher/Monadic.hs +167/−0
• src/UI/Butcher/Monadic/BuiltinCommands.hs +68/−0
• src/UI/Butcher/Monadic/Command.hs +95/−0
• src/UI/Butcher/Monadic/Flag.hs +419/−0
• src/UI/Butcher/Monadic/IO.hs +117/−0
• src/UI/Butcher/Monadic/Internal/Core.hs +1147/−0
• src/UI/Butcher/Monadic/Internal/Types.hs +210/−0
• src/UI/Butcher/Monadic/Param.hs +171/−0
• src/UI/Butcher/Monadic/Pretty.hs +254/−0
• src/UI/Butcher/Monadic/Types.hs +20/−0
• srcinc/prelude.inc +409/−0

@@ -0,0 +1,5 @@+# Revision history for cmdparse-applicative++## 1.1.0.0  -- May 2017++* First version. Released on an unsuspecting world.

@@ -0,0 +1,30 @@+Copyright (c) 2016, Lennart Spitzner++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Lennart Spitzner nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,241 @@+# butcher++#### Chops a command or program invocation into digestable pieces.++Similar to the `optparse-applicative` package, but less features,+more flexibility and more evil.++The main differences are:++* Provides a pure interface by default++* Exposes an evil monadic interface, which allows for much nicer binding of+  command part results to some variable name.++    In `optparse-applicative` you easily lose track of what field you are+    modifying after the 5th `<*>` (admittedly, i think -XRecordWildCards+    improves on that issue already.)++    Evil, because you are not allowed to use the monad's full power in this+    case, i.e. there is a constraint that is not statically enforced.+    See below.++* The monadic interface allows much clearer definitions of commandparses+  with (nested) subcommands. No pesky sum-types are necessary.++## Examples++The minimal example is++~~~~.hs+main = mainFromCmdParser $ addCmdImpl $ putStrLn "Hello, World!"+~~~~++But lets look at a more feature-complete example:++~~~~.hs+main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do++  addCmdSynopsis "a simple butcher example program"+  addCmdHelpStr "a very long help document"++  addCmd "version" $ do+    porcelain <- addSimpleBoolFlag "" ["porcelain"]+      (flagHelpStr "print nothing but the numeric version")+    addCmdHelpStr "prints the version of this program"+    addCmdImpl $ putStrLn $ if porcelain+      then "0.0.0.999"+      else "example, version 0.0.0.999"++  addCmd "help" $ addCmdImpl $ print $ ppHelpShallow helpDesc++  short <- addSimpleBoolFlag "" ["short"]+    (flagHelpStr "make the greeting short")+  name <- addStringParam "NAME"+    (paramHelpStr "your name, so you can be greeted properly")++  addCmdImpl $ do+    if short+      then putStrLn $ "hi, " ++ name ++ "!"+      else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!"+~~~~++Further:++- [Full description of the above example, including sample behaviour](example1.md)+- [Example of a pure usage of a CmdParser](example2.md)+- [Example of using a CmdParser on interactive input](example3.md)+- The [brittany](https://github.com/lspitzner/brittany) formatting tool is a+  program that uses butcher for implementing its commandline interface. See+  its [main module source](https://github.com/lspitzner/brittany/blob/master/src-brittany/Main.hs)+  or [the config flag parser](https://github.com/lspitzner/brittany/blob/master/src/Language/Haskell/Brittany/Config.hs).++## The evil monadic interface++As long as you only use Applicative or (Kleisli) Arrow, you can use the+interface freely. When you use Monad, there is one rule: Whenever you read+any command-parts like in++~~~~+f <- addFlag ...+p <- addParam ...+~~~~++you are only allowed to use bindings bound thusly in any command's+implemenation, i.e. inside the parameter to `addCmdImpl`. You are _not_+allowed to force/inspect/patternmatch on them before that. _good_ usage is:++~~~~+addCmdImpl $ do+  print x+  print y+~~~~++while _bad_ would be++~~~~+f <- addFlag+when f $ do+  p <- addParam+  -- evil: the existence of the param `p`+  -- depends on parse result for the flag `f`.+~~~~++That means that checking if a combination of flags is allowed must be done+after parsing. (But different commands and their subcommands (can) have+separate sets of flags.)++## (abstract) Package intentions++Consider a commandline invocation like "ghc -O -i src -Main.hs -o Main". This+package provides a way for the programmer to simultaneously define the+semantics of your program based on its arguments and retrieve documentation+for the user. More specifically, i had three goals in mind:++1. Straight-forward description of (sub)command and flag-specific behaviour+2. Extract understandable usage/help commandline documents/texts from that+   descriptions, think of `ghc --help` or `stack init --help`.+3. Extract necessary information to compute commandline completion results+   from any partial input. (This is not implemented to any serious degree.)++## Semantics++Basic elements of a command are flags, parameters and subcommands. These can+be composed in certain ways, i.e. flags can have a (or possibly multiple?)+parameters; parameters can be grouped into sequences, and commands can have+subcommands.++Commands are essentially `String -> Either ParseError out` where `out` can+be chosen by the user. It could for example be `IO ()`.++To allow more flexible composition, the parts of a command have the "classic"+parser's type: `String -> Maybe (p, String)` where `p` depends on the part.+Parse a prefix of the input and return something and the remaining input, or+fail with `Nothing`.++A command-parser contains a sequence of parts and then a number of subcommands+and/or some implementation. ++### Commands and Child-Commands++- ~~~~ .hs+  myParser :: CmdParser Identity Int ()+  myParser = return ()+  ~~~~++  input | `runCmdParserSimple input myParser`+  ----- | -------------+  "" | Left "command has no implementation"+  "x" | Left "error parsing arguments: could not parse input/unprocessed input at: \"x\"."++- ~~~~ .hs+  myParser :: CmdParser Identity Int ()+  myParser = do+    addCmd "foo" $ addCmdImpl 2+    addCmd "bar" $ addCmdImpl 3+    addCmd "noimpl" $ pure ()+    addCmd "twoimpls" $ do+      addCmdImpl 4+      addCmdImpl 5+    addCmdImpl 1+  ~~~~+  +  input | `runCmdParserSimple input myParser`+  ----- | -------------+  "" | Right 1+  "x" | Left "error parsing arguments: could not parse input/unprocessed input at: \"x\"."+  "foo" | Right 2+  "bar" | Right 3+  "foo bar" | Left "error parsing arguments: could not parse input/unprocessed input at: \"bar\"."+  "noimpl" | Left "command has no implementation"+  "twoimpls" | Right 5++### Flags++- without any annotation, no reodering is allowed and the flags must appear in order:+  ~~~~ .hs+  myParser :: CmdParser Identity (Bool, Int, Int) ()+  myParser = do+    b <- addSimpleBoolFlag "b" [] mempty+    c <- addSimpleCountFlag "c" [] mempty+    i <- addFlagReadParam "i" [] "number" (flagDefault 42)+    addCmdImpl $ (b, c, i)+  ~~~~+  +  input | `runCmdParserSimple input myParser`+  ----- | -------------+  "" | Right (False,0,42)+  "-b -c -i 3" | Right (True,1,3)+  "-c -b" | Left "error parsing arguments: could not parse input/unprocessed input at: \"-b\"."+  "-c -c -c" | Right (False,3,42)++- this time with reordering; also "j" has no default and thus becomes mandatory, still it must not+  occur more than once:+  ~~~~ .hs+  myParser :: CmdParser Identity (Bool, Int, Int, Int) ()+  myParser = do+    reorderStart -- this time with reordering+    b <- addSimpleBoolFlag "b" [] mempty+    c <- addSimpleCountFlag "c" [] mempty+    i <- addFlagReadParam "i" [] "number" (flagDefault 42)+    j <- addFlagReadParam "j" [] "number" mempty -- no default: flag mandatory+    reorderStop+    addCmdImpl $ (b, c, i, j)+  ~~~~+  +  input | `runCmdParserSimple input myParser`+  ---------------------------- | -------------+  "-b" | Left "error parsing arguments:<br>could not parse expected input -j number with remaining input:<br>InputString \"\" at the end of input."+  "-j=5" | Right (False,0,42,5)+  "-c -b -b -j=5" | Right (True,1,42,5)+  "-j=5 -i=1 -c -b" | Right (True,1,1,5)+  "-c -j=5 -c -i=5 -c" | Right (False,3,5,5)+  "-j=5 -j=5" | Left "error parsing arguments: could not parse input/unprocessed input at: \"-j=5\"."++- addFlagReadParams - these can occur more than once. Note that defaults have slightly different semantics:+  ~~~~ .hs+  myParser :: CmdParser Identity (Int, [Int]) ()+  myParser = do+    reorderStart+    i <- addFlagReadParam "i" [] "number" (flagDefault 42)+    js <- addFlagReadParams "j" [] "number" (flagDefault 50)+    reorderStop+    addCmdImpl $ (i, js)+  ~~~~+  +  input | `runCmdParserSimple input myParser`+  ---------------------------- | -------------+  "" | Right (42,[])+  "-i" | Left "error parsing arguments: could not parse input/unprocessed input at: \"-i\"."+  "-j=1 -j=2 -j=3" | Right (42,[1,2,3])+  "-j" | Right (42,[50])+  "-i=1" | Right (1,[])+  "-j=2" | Right (42,[2])+  "-j=2 -i=1 -j=3" | Right (1,[2,3])+  +### Params++TODO+++

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,158 @@+name:                butcher+version:             1.1.0.0+synopsis:            Chops a command or program invocation into digestable pieces.+description:         See the README (it is properly formatted on github)+license:             BSD3+license-file:        LICENSE+author:              Lennart Spitzner+maintainer:          lsp@informatik.uni-kiel.de+copyright:           Copyright (C) 2016-2017 Lennart Spitzner+category:            UI+build-type:          Simple+Stability:           experimental+extra-source-files: {+  ChangeLog.md+  srcinc/prelude.inc+  README.md+}+cabal-version:       >=1.10+homepage:            https://github.com/lspitzner/butcher/+bug-reports:         https://github.com/lspitzner/butcher/issues++source-repository head {+  type: git+  location: https://github.com/lspitzner/butcher.git+}++flag butcher-dev+  description: dev options+  default: False+  manual: True++library+  exposed-modules:     UI.Butcher.Monadic.Types+                       UI.Butcher.Monadic+                       UI.Butcher.Monadic.Command+                       UI.Butcher.Monadic.Param+                       UI.Butcher.Monadic.Flag+                       UI.Butcher.Monadic.Pretty+                       UI.Butcher.Monadic.IO+                       UI.Butcher.Monadic.BuiltinCommands+  other-modules:       UI.Butcher.Monadic.Internal.Types+                       UI.Butcher.Monadic.Internal.Core+  build-depends:+    { base >=4.8 && <4.10+    , free+    , unsafe+    , microlens+    , microlens-th+    , multistate+    , pretty+    , containers+    , either+    , transformers+    , mtl+    , extra+    , void+    , bifunctors+    , deque+    }+  if flag(butcher-dev) {+    build-depends:+      hspec+  }+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions: {+    CPP++    NoImplicitPrelude++    GADTs++    FlexibleContexts+    FlexibleInstances+    ScopedTypeVariables+    MonadComprehensions+    LambdaCase+    MultiWayIf+    KindSignatures+  }+  other-extensions: {+    DeriveFunctor+    ExistentialQuantification+    GeneralizedNewtypeDeriving+    StandaloneDeriving+    DataKinds+    TypeOperators+    TemplateHaskell+  }+  ghc-options: {+    -Wall+    -fno-spec-constr+    -j+    -fno-warn-unused-imports+    -fno-warn-orphans+  }+  if flag(butcher-dev) {+    ghc-options: -O0 -Werror -fprof-auto -fprof-cafs+  }+  include-dirs:+    srcinc++test-suite tests+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  build-depends:+    { base >=4.8 && <4.10+    , butcher+    , free+    , unsafe+    , microlens+    , microlens-th+    , multistate+    , pretty+    , containers+    , either+    , transformers+    , mtl+    , extra+    , deque+    }+  if flag(butcher-dev) {+    buildable:        True+    build-depends:+      hspec+  } else {+    buildable:        False+  }+  ghc-options:      -Wall+  main-is:          TestMain.hs+  other-modules:    +  hs-source-dirs:   src-tests+  default-extensions: {+    CPP++    NoImplicitPrelude++    GADTs++    FlexibleContexts+    FlexibleInstances+    ScopedTypeVariables+    MonadComprehensions+    LambdaCase+    MultiWayIf+    KindSignatures+  }+  ghc-options: {+    -Wall+    -fno-spec-constr+    -j+    -fno-warn-unused-imports+    -fno-warn-orphans+  }+  if flag(butcher-dev) {+    ghc-options: -Werror -fprof-auto -fprof-cafs -O0+  }+

@@ -0,0 +1,187 @@+module Main where++++#include "prelude.inc"++import Test.Hspec++-- import NeatInterpolation++import UI.Butcher.Monadic+import UI.Butcher.Monadic.Types++++main :: IO ()+main = hspec $ tests++tests :: Spec+tests = do+  describe "checkTests" checkTests+  describe "simpleParseTest" simpleParseTest+  describe "simpleRunTest" simpleRunTest+++checkTests :: Spec+checkTests = do+  before_ pending $ it "check001" $ True `shouldBe` True+++simpleParseTest :: Spec+simpleParseTest = do+  it "failed parse 001" $ runCmdParser Nothing (InputString "foo") testCmd1+         `shouldSatisfy` Data.Either.Combinators.isLeft . snd+  it "toplevel" $ (testParse testCmd1 "" >>= _cmd_out)+                  `shouldSatisfy` Maybe.isNothing+  it "hasImpl 001" $ (testParse testCmd1 "abc" >>= _cmd_out)+                  `shouldSatisfy` Maybe.isJust+  it "hasImpl 002" $ (testParse testCmd1 "def" >>= _cmd_out)+                  `shouldSatisfy` Maybe.isJust+++simpleRunTest :: Spec+simpleRunTest = do+  it "failed run" $ testRun testCmd1 "" `shouldBe` Right Nothing+  describe "no reordering" $ do+    it "cmd 1" $ testRun testCmd1 "abc" `shouldBe` Right (Just 100)+    it "cmd 2" $ testRun testCmd1 "def" `shouldBe` Right (Just 200)+    it "flag 1" $ testRun testCmd1 "abc -f" `shouldBe` Right (Just 101)+    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 7" $ testRun testCmd1 "abc -g -g" `shouldBe` Right (Just 102)+  describe "with reordering" $ do+    it "cmd 1" $ testRun testCmd2 "abc" `shouldBe` Right (Just 100)+    it "cmd 2" $ testRun testCmd2 "def" `shouldBe` Right (Just 200)+    it "flag 1" $ testRun testCmd2 "abc -f" `shouldBe` Right (Just 101)+    it "flag 2" $ testRun testCmd2 "abc --flong" `shouldBe` Right (Just 101)+    it "flag 3" $ testRun testCmd2 "abc -f -f" `shouldBe` Right (Just 101)+    it "flag 4" $ testRun testCmd2 "abc -f -g" `shouldBe` Right (Just 103)+    it "flag 5" $ testRun testCmd2 "abc -f -g -f" `shouldBe` Right (Just 103)+    it "flag 6" $ testRun testCmd2 "abc -g -f" `shouldBe` Right (Just 103)+    it "flag 7" $ testRun testCmd2 "abc -g -g" `shouldBe` Right (Just 102)+  describe "with action" $ do+    it "flag 1" $ testRunA testCmd3 "abc" `shouldBe` Right 0+    it "flag 2" $ testRunA testCmd3 "abc -f" `shouldBe` Right 1+    it "flag 3" $ testRunA testCmd3 "abc -g" `shouldBe` Right 2+    it "flag 4" $ testRunA testCmd3 "abc -f -g" `shouldBe` Right 3+    it "flag 5" $ testRunA testCmd3 "abc -g -f" `shouldBe` Right 3+  describe "separated children" $ do+    it "case 1" $ testRun testCmd4 "a aa" `shouldBe` Right (Just 1)+    it "case 2" $ testRun testCmd4 "a ab" `shouldBe` Right (Just 2)+    it "case 3" $ testRun testCmd4 "b ba" `shouldBe` Right (Just 3)+    it "case 4" $ testRun testCmd4 "b bb" `shouldBe` Right (Just 4)+    it "doc" $ show (ppHelpShallow (getDoc "" testCmd4)) `shouldBe`+      List.unlines+        [ "NAME"+        , ""+        , "  test"+        , ""+        , "USAGE"+        , ""+        , "  test a | b"+        ]+    it "doc" $ show (ppHelpShallow (getDoc "a" testCmd4)) `shouldBe`+      List.unlines+        [ "NAME"+        , ""+        , "  test a"+        , ""+        , "USAGE"+        , ""+        , "  test a aa | ab"+        ]+  describe "read flags" $ do+    it "flag 1" $ testRun testCmd5 "abc" `shouldBe` Right (Just 10)+    it "flag 2" $ testRun testCmd5 "abc -f 2" `shouldBe` Right (Just 2)+    it "flag 3" $ testRun testCmd5 "abc --flag 3" `shouldBe` Right (Just 3)+    it "flag 4" $ testRun testCmd5 "abc -f=4" `shouldBe` Right (Just 4)+    it "flag 5" $ testRun testCmd5 "abc --flag=5" `shouldBe` Right (Just 5)+    it "flag 6" $ testRun testCmd5 "abc -f" `shouldSatisfy` Data.Either.isLeft+    it "flag 6" $ testRun testCmd5 "abc -flag 0" `shouldSatisfy` Data.Either.isLeft+    it "flag 6" $ testRun testCmd5 "abc --f 0" `shouldSatisfy` Data.Either.isLeft+++++testCmd1 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()+testCmd1 = do+  addCmd "abc" $ do+    f <- addSimpleBoolFlag "f" ["flong"] mempty+    g <- addSimpleBoolFlag "g" ["glong"] mempty+    addCmdImpl $ do+      when f $ WriterS.tell 1+      when g $ WriterS.tell 2+      WriterS.tell 100+  addCmd "def" $ do+    addCmdImpl $ do+      WriterS.tell 200++testCmd2 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()+testCmd2 = do+  addCmd "abc" $ do+    reorderStart+    f <- addSimpleBoolFlag "f" ["flong"] mempty+    g <- addSimpleBoolFlag "g" ["glong"] mempty+    reorderStop+    addCmdImpl $ do+      when f $ WriterS.tell 1+      when g $ WriterS.tell 2+      WriterS.tell 100+  addCmd "def" $ do+    addCmdImpl $ do+      WriterS.tell 200++testCmd3 :: CmdParser (StateS.State Int) () ()+testCmd3 = do+  addCmd "abc" $ do+    reorderStart+    addSimpleFlagA "f" ["flong"] mempty (StateS.modify (+1))+    addSimpleFlagA "g" ["glong"] mempty (StateS.modify (+2))+    reorderStop+    addCmdImpl ()+  addCmd "def" $ do+    addCmdImpl ()++testCmd4 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()+testCmd4 = do+  addCmd "a" $ do+    addCmd "aa" $ do+      addCmdImpl $ WriterS.tell 1+  addCmd "b" $ do+    addCmd "bb" $ do+      addCmdImpl $ WriterS.tell 4+  addCmd "a" $ do+    addCmd "ab" $ do+      addCmdImpl $ WriterS.tell 2+  addCmd "b" $ do+    addCmd "ba" $ do+      addCmdImpl $ WriterS.tell 3++testCmd5 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()+testCmd5 = do+  addCmd "abc" $ do+    x <- addFlagReadParam "f" ["flag"] "flag" (flagDefault (10::Int))+    addCmdImpl $ WriterS.tell (Sum x)+++testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out)+testParse cmd s = either (const Nothing) Just+                $ snd+                $ runCmdParser Nothing (InputString s) cmd++testRun :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () -> String -> Either ParsingError (Maybe Int)+testRun cmd s = fmap (fmap (getSum . WriterS.execWriter) . _cmd_out)+              $ snd+              $ runCmdParser Nothing (InputString s) cmd++testRunA :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError Int+testRunA cmd str = (\((_, e), s) -> e $> s)+                 $ flip StateS.runState (0::Int)+                 $ runCmdParserA Nothing (InputString str) cmd++getDoc :: String -> CmdParser Identity out () -> CommandDesc ()+getDoc s = fst . runCmdParser (Just "test") (InputString s)

@@ -0,0 +1,167 @@+-- | Main module of the butcher interface. It reexports everything that is+-- exposed in the submodules.+module UI.Butcher.Monadic+  ( -- * Types+    Input (..)+  , CmdParser+  , ParsingError (..)+  , CommandDesc(_cmd_out)+  , cmd_out+  , -- * Run or Check CmdParsers+    runCmdParserSimple+  , runCmdParser+  , runCmdParserExt+  , runCmdParserA+  , runCmdParserAExt+  , runCmdParserWithHelpDesc+  , checkCmdParser+  , -- * Building CmdParsers+    module UI.Butcher.Monadic.Command+    -- * PrettyPrinting CommandDescs (usage/help)+  , module  UI.Butcher.Monadic.Pretty+    -- * Wrapper around System.Environment.getArgs+  , module  UI.Butcher.Monadic.IO+  -- , cmds+  -- , sample+  -- , test+  -- , test2+  -- , test3+    -- * Builtin commands+  , addHelpCommand+  , addButcherDebugCommand+  , mapOut+  )+where++++#include "prelude.inc"++import UI.Butcher.Monadic.Types+import UI.Butcher.Monadic.Internal.Types+import UI.Butcher.Monadic.Command+import UI.Butcher.Monadic.BuiltinCommands+import UI.Butcher.Monadic.Internal.Core+import UI.Butcher.Monadic.Pretty+import UI.Butcher.Monadic.IO++import qualified Text.PrettyPrint as PP++++#ifdef HLINT+{-# ANN module "HLint: ignore Use import/export shortcut" #-}+#endif++++-- | Like 'runCmdParser', but with one additional twist: You get access+-- to a knot-tied complete CommandDesc for this full command. Useful in+-- combination with 'UI.Butcher.Monadic.BuiltinCommands.addHelpCommand'.+--+-- Note that the @CommandDesc ()@ in the output is _not_ the same value as the+-- parameter passed to the parser function: The output value contains a more+-- "shallow" description. This is more efficient for complex CmdParsers when+-- used interactively, because non-relevant parts of the CmdParser are not+-- traversed unless the parser function argument is forced.+runCmdParserWithHelpDesc+  :: Maybe String -- ^ program name to be used for the top-level @CommandDesc@+  -> Input -- ^ input to be processed+  -> (CommandDesc () -> CmdParser Identity out ()) -- ^ parser to use+  -> (CommandDesc (), Either ParsingError (CommandDesc out))+runCmdParserWithHelpDesc mProgName input cmdF =+  let (checkResult, fullDesc)+        -- knot-tying at its finest..+        = ( checkCmdParser mProgName (cmdF fullDesc)+          , either (const emptyCommandDesc) id $ checkResult+          )+  in runCmdParser mProgName input (cmdF fullDesc)+++-- | Wrapper around 'runCmdParser' for very simple usage: Accept a @String@+-- input and return only the output from the parser, returning @Nothing@ in+-- any error case.+runCmdParserSimple :: String -> CmdParser Identity out () -> Either String out+runCmdParserSimple s p = case snd $ runCmdParser Nothing (InputString s) p of+  Left e -> Left $ parsingErrorString e+  Right desc ->+    maybe (Left "command has no implementation") Right $ _cmd_out desc+++--------------------------------------+-- all below is for testing purposes+--------------------------------------+++_cmds :: CmdParser Identity (IO ()) ()+_cmds = do+  addCmd "echo" $ do+    addCmdHelpStr "print its parameter to output"+    str <- addReadParam "STRING" (paramHelpStr "the string to print")+    addCmdImpl $ do+      putStrLn str+  addCmd "hello" $ do+    addCmdHelpStr "greet the user"+    reorderStart+    short <- addSimpleBoolFlag "" ["short"] mempty+    name <- addReadParam "NAME" (paramHelpStr "your name, so you can be greeted properly"+                              <> paramDefault "user")+    reorderStop+    addCmdImpl $ do+      if short+        then putStrLn $ "hi, " ++ name ++ "!"+        else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!"+  addCmd "foo" $ do+    addCmdHelpStr "foo"+    desc <- peekCmdDesc+    addCmdImpl $ do+      putStrLn "foo"+      print $ ppHelpShallow desc+  addCmd "help" $ do+    desc <- peekCmdDesc+    addCmdImpl $ do+      print $ ppHelpShallow $ maybe undefined snd (_cmd_mParent desc)++data Sample = Sample+  { _hello :: Int+  , _s1   :: String+  , _s2   :: String+  , _quiet :: Bool+  }+  deriving Show++-- sample :: OPA.Parser Sample+-- sample = Sample+--      <$> OPA.option OPA.auto+--          ( OPA.long "hello"+--         <> OPA.metavar "TARGET"+--         <> OPA.help "Target for the greeting" )+--      <*> OPA.strArgument (OPA.metavar "S1")+--      <*> OPA.strArgument (OPA.metavar "S2")+--      <*> OPA.switch+--          ( OPA.long "quiet"+--         <> OPA.help "Whether to be quiet" )+-- +-- test :: String -> OPA.ParserResult Sample+-- test s = OPA.execParserPure OPA.defaultPrefs (OPA.ParserInfo sample True mempty mempty mempty (-13) True) (List.words s)++_test2 :: IO ()+_test2 = case checkCmdParser (Just "butcher") _cmds of+  Left e -> putStrLn $ "LEFT: " ++ e+  Right desc -> do+    print $ ppUsage desc+    print $ maybe undefined id $ ppUsageAt ["hello"] desc++_test3 :: String -> IO ()+_test3 s = case runCmdParser (Just "butcher") (InputString s) _cmds of+  (desc, Left e) -> do+    print e+    print $ ppHelpShallow desc+    _cmd_mParent desc `forM_` \(_, d) -> do+      print $ ppUsage d+  (desc, Right out) -> do+    case _cmd_out out of+      Nothing -> do+        putStrLn "command is missing implementation!"+        print $ ppHelpShallow desc+      Just f -> f

@@ -0,0 +1,68 @@+-- | Some CmdParser actions that add predefined commands.+module UI.Butcher.Monadic.BuiltinCommands+  ( addHelpCommand+  , addHelpCommandShallow+  , addButcherDebugCommand+  )+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 Text.PrettyPrint as PP++import           Data.HList.ContainsType++import           UI.Butcher.Monadic.Internal.Types+import           UI.Butcher.Monadic.Internal.Core+import           UI.Butcher.Monadic.Pretty+import           UI.Butcher.Monadic.Param++import           System.IO++++-- | 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+  rest <- addRestOfInputStringParam "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 w $ Data.Foldable.toList $ _cmd_children curDesc of+            Nothing    -> curDesc+            Just child -> descent wr child+    print $ ppHelpShallow $ descent restWords parentDesc++-- | Adds a help command that prints help for the command currently in context.+--+-- This version does _not_ include further childcommands, i.e. "help foo" will+-- not print the help for subcommand "foo".+--+-- This also yields slightly different output depending on if it is used+-- before or after adding other subcommands. In general 'addHelpCommand'+-- should be preferred.+addHelpCommandShallow :: Applicative f => CmdParser f (IO ()) ()+addHelpCommandShallow = addCmd "help" $ do+  desc <- peekCmdDesc+  _rest <- addRestOfInputStringParam "SUBCOMMAND(s)" mempty+  addCmdImpl $ do+    let parentDesc = maybe undefined snd (_cmd_mParent desc)+    print $ ppHelpShallow $ parentDesc++-- | Prints the raw CommandDesc structure.+addButcherDebugCommand :: Applicative f => CmdParser f (IO ()) ()+addButcherDebugCommand = addCmd "butcherdebug" $ do+  desc <- peekCmdDesc+  addCmdImpl $ do+    print $ maybe undefined snd (_cmd_mParent desc)+

@@ -0,0 +1,95 @@+-- this module only re-exports the appropriate user-facing stuff from some+-- other modules.+-- | Building-blocks of a CmdParser.+--+-- The simplest sensible CmdParser is just+--+-- > addCmdImpl $ putStrLn "hello, world!"+--+-- (assuming out is IO ()).+--+-- The empty CmdParser is also valid:+--+-- > return ()+--+-- But not very interesting - you won't get an 'out' value from this (e.g. an+-- IO-action to execute) when this matches (on the empty input).+--+-- > do+-- >   addCmd "sub" $ do+-- >     addCmdImpl $ putStrLn "sub successful"+--+-- Here, note that there is no implementation at the top-level. This means that+-- on the empty input the resulting CommandDesc has no out-value, but on "sub"+-- it has. Executed as a program, the user would be shown the usage on empty+-- input, and the putStrLn would happen on "sub".+--+-- More than one subcommand? easy:+--+-- > do+-- >   addCmd "foo" $ do {..}+-- >   addCmd "bar" $ do {..}+--+-- Basic flag usage:+--+-- > do+-- >   shouldVerbose <- addSimpleBoolFlag "v" ["verbose"] mzero+-- >   addCmdImpl $ if shouldVerbose+-- >     then putStrLn "Hello, World!!!!!"+-- >     else putStrLn "hi."+--+-- Basic param usage:+--+-- > addCmd "echo" $ do+-- >   addCmdHelpStr "print its parameter to output"+-- >   str <- addRestOfInputStringParam "STRING" (paramHelpStr "the string to print")+-- >   addCmdImpl $ putStrLn str+-- > addCmd "echoInt" $ do+-- >   i <- addReadParam "INT" mempty+-- >   addCmdImpl $ print (i::Int) -- need to disambiguate via typesig.+--+-- There are some other flag/param methods in the respective modules.+-- Also note the example at 'reorderStart'.++module UI.Butcher.Monadic.Command+  ( addCmd+  , addCmdImpl+  , addCmdSynopsis+  , addCmdHelp+  , addCmdHelpStr+  , reorderStart+  , reorderStop+  , withReorder+  , peekCmdDesc+  , peekInput+    -- * Building CmdParsers - myprog -v --input PATH+  , module  UI.Butcher.Monadic.Flag+    -- * Building CmdParsers - myprog SOME_INT+  , module  UI.Butcher.Monadic.Param+    -- * Low-level part functions+  , addCmdPart+  , addCmdPartMany+  , addCmdPartInp+  , addCmdPartManyInp+  , ManyUpperBound (..)+  )+where++++#include "prelude.inc"++++import           UI.Butcher.Monadic.Internal.Types+import           UI.Butcher.Monadic.Internal.Core+import           UI.Butcher.Monadic.Flag+import           UI.Butcher.Monadic.Param++++-- | Safe wrapper around 'reorderStart'/'reorderStop' for cases where reducing+-- to a single binding is possible/preferable.+withReorder :: CmdParser f out a -> CmdParser f out a+withReorder x = reorderStart *> x <* reorderStop+

@@ -0,0 +1,419 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Flags are arguments to your current command that are prefixed with "-" or+-- "--", for example "-v" or "--verbose". These flags can have zero or one+-- argument. (Butcher internally has more general concept of "CmdPart" that+-- could handle any number of arguments, so take this as what this module aims+-- to provide, not what you could theoretically implement on top of butcher).++-- Note that the current implementation only accepts "--foo param" but not+-- "--foo=param". Someone really ought to implement support for the latter+-- at some point :)+module UI.Butcher.Monadic.Flag+  ( Flag(..)+  , flagHelp+  , flagHelpStr+  , flagDefault+  , addSimpleBoolFlag+  , addSimpleCountFlag+  , addSimpleFlagA+  , addFlagReadParam+  , addFlagReadParams+  -- , addFlagReadParamA+  , addFlagStringParam+  , addFlagStringParams+  -- , addFlagStringParamA+  )+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 Text.PrettyPrint as PP++import           Data.HList.ContainsType++import           UI.Butcher.Monadic.Internal.Types+import           UI.Butcher.Monadic.Internal.Core++import           Data.List.Extra ( firstJust )++++-- TODO: perhaps move this to Types module and refactor all code to use it+newtype InpParseString a = InpParseString (StateS.StateT String Maybe a)+  deriving (Functor, Applicative, Monad, State.Class.MonadState String, Alternative, MonadPlus)++runInpParseString :: String -> InpParseString a -> Maybe (a, String)+runInpParseString s (InpParseString m) = StateS.runStateT m s++pExpect :: String -> InpParseString ()+pExpect s = InpParseString $ do+  inp <- StateS.get+  case List.stripPrefix s inp of+    Nothing -> mzero+    Just rest -> StateS.put rest++pExpectEof :: InpParseString ()+pExpectEof =+  InpParseString $ StateS.get >>= \inp -> if null inp then pure () else mzero++-- pDropSpace :: InpParseString ()+-- pDropSpace = InpParseString $ StateS.modify (dropWhile (==' '))++pOption :: InpParseString () -> InpParseString ()+pOption m = m <|> return ()++++-- | 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+  }++instance Monoid (Flag p) where+  mempty = Flag Nothing Nothing+  Flag a1 b1 `mappend` Flag a2 b2 = Flag (a1 <|> a2) (b1 <|> b2)++-- | Create a 'Flag' with just a help text.+flagHelp :: PP.Doc -> Flag p+flagHelp h = mempty { _flag_help = Just h }++-- | Create a 'Flag' with just a help text.+flagHelpStr :: String -> Flag p+flagHelpStr s = mempty { _flag_help = Just $ PP.text s }++-- | Create a 'Flag' with just a default value.+flagDefault :: p -> Flag p+flagDefault d = mempty { _flag_default = Just d }++-- | A no-parameter flag where non-occurence means False, occurence means True.+addSimpleBoolFlag+  :: Applicative f+  => String -- ^ short flag chars, i.e. "v" for -v+  -> [String] -- ^ list of long names, e.g. ["verbose"]+  -> Flag Void -- ^ properties+  -> CmdParser f out Bool+addSimpleBoolFlag shorts longs flag =+  addSimpleBoolFlagAll shorts longs flag (pure ())++-- | Applicative-enabled version of 'addSimpleFlag'+addSimpleFlagA+  :: String -- ^ short flag chars, i.e. "v" for -v+  -> [String] -- ^ list of long names, e.g. ["verbose"]+  -> Flag Void -- ^ properties+  -> f () -- ^ action to execute whenever this matches+  -> CmdParser f out ()+addSimpleFlagA shorts longs flag act+  = void $ addSimpleBoolFlagAll shorts longs flag act++addSimpleBoolFlagAll+  :: String+  -> [String]+  -> Flag Void+  -> f ()+  -> CmdParser f out Bool+addSimpleBoolFlagAll shorts longs flag a+  = fmap (not . null)+  $ addCmdPartManyA ManyUpperBound1 desc parseF (\() -> a)+  where+    allStrs = fmap (\c -> "-"++[c]) shorts+           ++ fmap (\s -> "--"++s)  longs+    desc :: PartDesc+    desc = (maybe id PartWithHelp $ _flag_help flag)+         $ PartAlts $ PartLiteral <$> allStrs+    parseF :: String -> Maybe ((), String)+    parseF str = ( firstJust (\s -> [ ((), drop (length s) str) | s==str ])+                             allStrs)+             <|> ( firstJust (\s -> [ ((), drop (length s + 1) str)+                                    | (s ++ " ") `isPrefixOf` str ])+                             allStrs)++-- | A no-parameter flag that can occur multiple times. Returns the number of+-- occurences (0 or more).+addSimpleCountFlag :: Applicative f+                   => String -- ^ short flag chars, i.e. "v" for -v+                   -> [String] -- ^ list of long names, i.e. ["verbose"]+                   -> Flag Void -- ^ properties+                   -> CmdParser f out Int+addSimpleCountFlag shorts longs flag+  = fmap length+  $ addCmdPartMany ManyUpperBoundN desc parseF+  where+    -- we _could_ allow this to parse repeated short flags, like "-vvv"+    -- (meaning "-v -v -v") correctly.+    allStrs = fmap (\c -> "-"++[c]) shorts+           ++ fmap (\s -> "--"++s)  longs+    desc :: PartDesc+    desc = (maybe id PartWithHelp $ _flag_help flag)+         $ PartAlts $ PartLiteral <$> allStrs+    parseF :: String -> Maybe ((), String)+    parseF str = ( firstJust (\s -> [ ((), drop (length s) str) | s==str ])+                             allStrs)+             <|> ( firstJust (\s -> [ ((), drop (length s + 1) str)+                                    | (s ++ " ") `isPrefixOf` str ])+                             allStrs)++-- | One-argument flag, where the argument is parsed via its Read instance.+addFlagReadParam+  :: forall f p out+   . (Applicative f, Typeable p, Text.Read.Read p, Show p)+  => String -- ^ short flag chars, i.e. "v" for -v+  -> [String] -- ^ list of long names, i.e. ["verbose"]+  -> String -- ^ param name+  -> Flag p -- ^ properties+  -> CmdParser f out p+addFlagReadParam shorts longs name flag = addCmdPartInpA desc+                                                         parseF+                                                         (\_ -> pure ())+ where+  allStrs =+    [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]+  desc =+    (maybe id PartWithHelp $ _flag_help flag)+      $ maybe id (PartDefault . show) (_flag_default flag)+      $ PartSeq [desc1, desc2]+  desc1 :: PartDesc+  desc1 = PartAlts $ PartLiteral . either id id <$> allStrs+  desc2 = PartVariable name+  parseF :: Input -> Maybe (p, Input)+  parseF inp = case inp of+    InputString str ->+      maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)+        $ parseResult+     where+      parseResult = runInpParseString str $ do+        Data.Foldable.msum $ allStrs <&> \case+          Left  s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")+          Right s -> pExpect s *> (pExpect " " <|> pExpect "=")+        InpParseString $ do+          i <- StateS.get+          case Text.Read.reads i of+            ((x, ' ':r):_) -> StateS.put (dropWhile Char.isSpace r) $> x+            ((x, ""   ):_) -> StateS.put "" $> x+            _              -> mzero+    InputArgs (arg1:argR) -> case runInpParseString arg1 parser of+      Just ((), "") -> case argR of+        []          -> Nothing+        (arg2:rest) -> readMaybe arg2 <&> \x -> (x, InputArgs rest)+      Just ((), remainingStr) ->+        readMaybe remainingStr <&> \x -> (x, InputArgs argR)+      Nothing -> _flag_default flag <&> \d -> (d, inp)+     where+      parser :: InpParseString ()+      parser = do+        Data.Foldable.msum $ allStrs <&> \case+          Left  s -> pExpect s *> pOption (pExpect "=")+          Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)+    InputArgs _ -> _flag_default flag <&> \d -> (d, inp)++-- | One-argument flag, where the argument is parsed via its Read instance.+-- This version can accumulate multiple values by using the same flag with+-- different arguments multiple times.+--+-- E.g. "--foo 3 --foo 5" yields [3,5].+addFlagReadParams+  :: forall f p out+   . (Applicative f, Typeable p, Text.Read.Read p, Show p)+  => String -- ^ short flag chars, i.e. "v" for -v+  -> [String] -- ^ list of long names, i.e. ["verbose"]+  -> String -- ^ param name+  -> Flag p -- ^ properties+  -> CmdParser f out [p]+addFlagReadParams shorts longs name flag+  = addFlagReadParamsAll shorts longs name flag (\_ -> pure ())++-- TODO: this implementation is wrong, because it uses addCmdPartManyInpA+--       while this really is no Many.+-- | Applicative-enabled version of 'addFlagReadParam'+-- addFlagReadParamA+--   :: forall f p out+--    . (Typeable p, Text.Read.Read p, Show p)+--   => String -- ^ short flag chars, i.e. "v" for -v+--   -> [String] -- ^ list of long names, i.e. ["verbose"]+--   -> String -- ^ param name+--   -> Flag p -- ^ properties+--   -> (p -> f ()) -- ^ action to execute when ths param matches+--   -> CmdParser f out ()+-- addFlagReadParamA shorts longs name flag act+--   = void $ addFlagReadParamsAll shorts longs name flag act++addFlagReadParamsAll+  :: forall f p out . (Typeable p, Text.Read.Read p, Show p) => String -- ^ short flag chars, i.e. "v" for -v+     -> [String] -- ^ list of long names, i.e. ["verbose"]+     -> String -- ^ param name+     -> Flag p -- ^ properties+     -> (p -> f ()) -- ^ action to execute when ths param matches+     -> CmdParser f out [p]+addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA+  ManyUpperBoundN+  desc+  parseF+  act+ where+  allStrs =+    [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]+  desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2]+  desc1 :: PartDesc+  desc1 = PartAlts $ PartLiteral . either id id <$> allStrs+  desc2 =+    (maybe id (PartDefault . show) $ _flag_default flag) $ PartVariable name+  parseF :: Input -> Maybe (p, Input)+  parseF inp = case inp of+    InputString str -> fmap (second InputString) $ parseResult+     where+      parseResult = runInpParseString str $ do+        Data.Foldable.msum $ allStrs <&> \case+          Left  s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")+          Right s -> pExpect s *> (pExpect " " <|> pExpect "=")+        InpParseString $ do+          i <- StateS.get+          case Text.Read.reads i of+            ((x, ' ':r):_) -> StateS.put (dropWhile Char.isSpace r) $> x+            ((x, ""   ):_) -> StateS.put "" $> x+            _              -> lift $ _flag_default flag+    InputArgs (arg1:argR) -> case runInpParseString arg1 parser of+      Just ((), "") -> case argR of+        []          -> mdef+        (arg2:rest) -> (readMaybe arg2 <&> \x -> (x, InputArgs rest)) <|> mdef+        where mdef = _flag_default flag <&> \p -> (p, InputArgs argR)+      Just ((), remainingStr) ->+        readMaybe remainingStr <&> \x -> (x, InputArgs argR)+      Nothing -> Nothing+     where+      parser :: InpParseString ()+      parser = do+        Data.Foldable.msum $ allStrs <&> \case+          Left  s -> pExpect s *> pOption (pExpect "=")+          Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)+    InputArgs _ -> Nothing++-- | One-argument flag where the argument can be an arbitrary string.+addFlagStringParam+  :: forall f out . (Applicative f) => String -- ^ short flag chars, i.e. "v" for -v+     -> [String] -- ^ list of long names, i.e. ["verbose"]+     -> String -- ^ param name+     -> Flag String -- ^ properties+     -> CmdParser f out String+addFlagStringParam shorts longs name flag = addCmdPartInpA desc+                                                           parseF+                                                           (\_ -> pure ())+ where+  allStrs =+    [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]+  desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2]+  desc1 :: PartDesc+  desc1 = PartAlts $ PartLiteral . either id id <$> allStrs+  desc2 = PartVariable name+  parseF :: Input -> Maybe (String, Input)+  parseF inp = case inp of+    InputString str ->+      maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)+        $ parseResult+     where+      parseResult = runInpParseString str $ do+        Data.Foldable.msum $ allStrs <&> \case+          Left  s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")+          Right s -> pExpect s *> (pExpect " " <|> pExpect "=")+        InpParseString $ do+          i <- StateS.get+          let (x, rest) = break Char.isSpace $ dropWhile Char.isSpace i+          StateS.put rest+          pure x+    InputArgs (arg1:argR) -> case runInpParseString arg1 parser of+      Just ((), ""          ) -> case argR of+        []       -> Nothing+        (x:rest) -> Just (x, InputArgs rest)+      Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)+      Nothing                 -> _flag_default flag <&> \d -> (d, inp)+     where+      parser :: InpParseString ()+      parser = do+        Data.Foldable.msum $ allStrs <&> \case+          Left  s -> pExpect s *> pOption (pExpect "=")+          Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)+    InputArgs _ -> _flag_default flag <&> \d -> (d, inp)++-- | One-argument flag where the argument can be an arbitrary string.+-- This version can accumulate multiple values by using the same flag with+-- different arguments multiple times.+--+-- E.g. "--foo abc --foo def" yields ["abc", "def"].+addFlagStringParams+  :: forall f out+   . (Applicative f)+  => String -- ^ short flag chars, i.e. "v" for -v+  -> [String] -- ^ list of long names, i.e. ["verbose"]+  -> String -- ^ param name+  -> Flag Void -- ^ properties+  -> CmdParser f out [String]+addFlagStringParams shorts longs name flag+  = addFlagStringParamsAll shorts longs name flag (\_ -> pure ())++-- TODO: this implementation is wrong, because it uses addCmdPartManyInpA+--       while this really is no Many.+-- -- | Applicative-enabled version of 'addFlagStringParam'+-- addFlagStringParamA+--   :: forall f out+--   .  String -- ^ short flag chars, i.e. "v" for -v+--   -> [String] -- ^ list of long names, i.e. ["verbose"]+--   -> String -- ^ param name+--   -> Flag Void -- ^ properties+--   -> (String -> f ()) -- ^ action to execute when ths param matches+--   -> CmdParser f out ()+-- addFlagStringParamA shorts longs name flag act+--   = void $ addFlagStringParamsAll shorts longs name flag act++addFlagStringParamsAll+  :: forall f out . String+     -> [String]+     -> String+     -> Flag Void -- we forbid the default because it has bad interaction+               -- with the eat-anything behaviour of the string parser.+     -> (String -> f ())+     -> CmdParser f out [String]+addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA+  ManyUpperBoundN+  desc+  parseF+  act+ where+  allStrs =+    [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]+  desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2]+  desc1 :: PartDesc+  desc1 = PartAlts $ PartLiteral . either id id <$> allStrs+  desc2 =+    (maybe id (PartDefault . show) $ _flag_default flag) $ PartVariable name+  parseF :: Input -> Maybe (String, Input)+  parseF inp = case inp of+    InputString str -> fmap (second InputString) $ parseResult+     where+      parseResult = runInpParseString str $ do+        Data.Foldable.msum $ allStrs <&> \case+          Left  s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")+          Right s -> pExpect s *> (pExpect " " <|> pExpect "=")+        InpParseString $ do+          i <- StateS.get+          let (x, rest) = break Char.isSpace $ dropWhile Char.isSpace i+          StateS.put rest+          pure x+    InputArgs (arg1:argR) -> case runInpParseString arg1 parser of+      Just ((), ""          ) -> case argR of+        []       -> Nothing+        (x:rest) -> Just (x, InputArgs rest)+      Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)+      Nothing                 -> Nothing+     where+      parser :: InpParseString ()+      parser = do+        Data.Foldable.msum $ allStrs <&> \case+          Left  s -> pExpect s *> pOption (pExpect "=")+          Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)+    InputArgs _ -> Nothing

@@ -0,0 +1,117 @@+-- | Turn your CmdParser into an IO () to be used as your program @main@.+module UI.Butcher.Monadic.IO+  ( mainFromCmdParser+  , mainFromCmdParserWithHelpDesc+  )+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 Text.PrettyPrint as PP++import           Data.HList.ContainsType++import           UI.Butcher.Monadic.Internal.Types+import           UI.Butcher.Monadic.Internal.Core+import           UI.Butcher.Monadic.Pretty+import           UI.Butcher.Monadic.Param++import           System.IO++++-- | Utility method that allows using a 'CmdParser' as your @main@ function:+--+-- > main = mainFromCmdParser $ do+-- >   addCmdImpl $ putStrLn "This is a fairly boring program."+--+-- Uses @System.Environment.getProgName@ as program name and+-- @System.Environment.getArgs@ as the input to be parsed. Prints some+-- appropriate messages if parsing fails or if the command has no+-- implementation; if all is well executes the \'out\' action (the IO ()).+mainFromCmdParser :: CmdParser Identity (IO ()) () -> IO ()+mainFromCmdParser cmd = do+  progName <- System.Environment.getProgName+  case checkCmdParser (Just progName) cmd of+    Left  e -> do+      putStrErrLn+        $ progName+        ++ ": internal error: failed sanity check for butcher main command parser!"+      putStrErrLn $ "(" ++ e ++ ")"+      putStrErrLn $ "aborting."+    Right _ -> do+      args <- System.Environment.getArgs+      case runCmdParser (Just progName) (InputArgs args) cmd of+        (desc, Left (ParsingError mess remaining)) -> do+          putStrErrLn+            $  progName+            ++ ": error parsing arguments: "+            ++ case mess of+                 []    -> ""+                 (m:_) -> m+          putStrErrLn $ case remaining of+            InputString ""  -> "at the end of input."+            InputString str -> case show str of+              s | length s < 42 -> "at: " ++ s ++ "."+              s                 -> "at: " ++ take 40 s ++ "..\"."+            InputArgs   []  -> "at the end of input"+            InputArgs   xs  -> case List.unwords $ show <$> xs of+              s | length s < 42 -> "at: " ++ s ++ "."+              s                 -> "at: " ++ take 40 s ++ "..\"."+          putStrErrLn $ "usage:"+          printErr $ ppUsage desc+        (desc, Right out                         ) -> case _cmd_out out of+          Nothing -> do+            putStrErrLn $ "usage:"+            printErr $ ppUsage desc+          Just a  -> a++-- | Same as mainFromCmdParser, but with one additional twist: You get access+-- to a knot-tied complete CommandDesc for this full command. Useful in+-- combination with 'UI.Butcher.Monadic.BuiltinCommands.addHelpCommand'+mainFromCmdParserWithHelpDesc+  :: (CommandDesc () -> CmdParser Identity (IO ()) ()) -> IO ()+mainFromCmdParserWithHelpDesc cmdF = do+  progName <- System.Environment.getProgName+  let (checkResult, fullDesc)+        -- knot-tying at its finest..+        = ( checkCmdParser (Just progName) (cmdF fullDesc)+          , either (const emptyCommandDesc) id $ checkResult+          )+  case checkResult of+    Left e -> do+      putStrErrLn $ progName ++ ": internal error: failed sanity check for butcher main command parser!"+      putStrErrLn $ "(" ++ e ++ ")"+      putStrErrLn $ "aborting."+    Right _ -> do+      args <- System.Environment.getArgs+      case runCmdParser (Just progName) (InputArgs args) (cmdF fullDesc) of+        (desc, Left (ParsingError mess remaining)) -> do+          putStrErrLn $ progName ++ ": error parsing arguments: " ++ head mess+          putStrErrLn $ case remaining of+            InputString "" -> "at the end of input."+            InputString str -> case show str of+              s | length s < 42 -> "at: " ++ s ++ "."+              s -> "at: " ++ take 40 s ++ "..\"."+            InputArgs [] -> "at the end of input"+            InputArgs xs -> case List.unwords $ show <$> xs of+              s | length s < 42 -> "at: " ++ s ++ "."+              s -> "at: " ++ take 40 s ++ "..\"."+          putStrErrLn $ "usage:"+          printErr $ ppUsage desc+        (desc, Right out) -> case _cmd_out out of+          Nothing -> do+            putStrErrLn $ "usage:"+            printErr $ ppUsage desc+          Just a -> a++putStrErrLn :: String -> IO ()+putStrErrLn s = hPutStrLn stderr s++printErr :: Show a => a -> IO ()+printErr = putStrErrLn . show

@@ -0,0 +1,1147 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# 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+  , 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 str 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 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 -> (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 -> (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 String, Map String (CmdParser f out (), f ()))+            -> ChildGather f out+            -> (Deque String, Map 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 <&> \(name, (child, act)) ->+              case input of+                InputString str | name == str ->+                  Just $ (name, child, act, InputString "")+                InputString str | (name++" ") `isPrefixOf` str ->+                  Just $ (name, child, act, InputString $ drop (length name + 1) str)+                InputArgs (str:strr) | name == str ->+                  Just $ (name, child, act, InputArgs strr)+                _ -> 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 :: String -> Deque (String, a) -> (Maybe a, Deque (String, 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+  => 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 (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 -> (String, CommandDesc a) -> (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 -> (String, CommandDesc a) -> (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

@@ -0,0 +1,210 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}++module UI.Butcher.Monadic.Internal.Types+  ( CommandDesc (..)+  , cmd_mParent+  , cmd_help+  , cmd_synopsis+  , cmd_parts+  , cmd_out+  , cmd_children+  , emptyCommandDesc+  , CmdParserF (..)+  , CmdParser+  , PartDesc (..)+  , Input (..)+  , ParsingError (..)+  , addSuggestion+  , ManyUpperBound (..)+  )+where++++#include "prelude.inc"+import           Control.Monad.Free+import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS++import qualified Lens.Micro.TH as LensTH++import qualified Text.PrettyPrint as PP++++-- | Butcher supports two input modi: @String@ and @[String]@. Program+-- arguments have the latter form, while parsing interactive command input+-- (e.g. when you implement a terminal of sorts) is easier when you can+-- process the full @String@ without having to wordify it first by some+-- means (and List.words is not the right approach in many situations.)+data Input = InputString String | InputArgs [String]+  deriving (Show, Eq)++-- | Information about an error that occured when trying to parse some @Input@+-- using some @CmdParser@.+data ParsingError = ParsingError+  { _pe_messages  :: [String]+  , _pe_remaining :: Input+  }+  deriving (Show, Eq)++-- | Specifies whether we accept 0-1 or 0-n for @CmdParserPart@s.+data ManyUpperBound+  = ManyUpperBound1+  | ManyUpperBoundN++data CmdParserF f out a+  =                          CmdParserHelp PP.Doc a+  |                          CmdParserSynopsis String a+  |                          CmdParserPeekDesc (CommandDesc () -> a)+  |                          CmdParserPeekInput (String -> a)+  -- TODO: we can clean up this duplication by providing+  -- a function (String -> Maybe (p, String)) -> (Input -> Maybe (p, Input)).+  | forall p . Typeable p => CmdParserPart PartDesc (String -> Maybe (p, String)) (p -> f ()) (p -> a)+  | 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 String (CmdParser f out ()) (f ()) a+  |                          CmdParserImpl  out                                a+  |                          CmdParserReorderStart                             a+  |                          CmdParserReorderStop                              a+  |                          CmdParserGrouped String                           a+  |                          CmdParserGroupEnd                                 a++-- | The CmdParser monad type. It is a free monad over some functor but users+-- of butcher don't need to know more than that 'CmdParser' is a 'Monad'.+type CmdParser f out = Free (CmdParserF f out)+++-- type CmdParser a = CmdParserM a a++-- data CmdPartParserF a+--   = CmdPartParserHelp String a+--   | forall p . CmdPartParserCore (String -> Maybe (p, String)) -- parser+--                                  (Maybe p) -- optional default value+--                                  (p -> a)+--   | forall p . CmdPartParserOptional (CmdPartParser p)+--                                      (Maybe p -> a)+--   -- the idea here was to allow adding some dynamic data to each "node" of+--   -- the output CommandDesc so the user can potentially add custom additional+--   -- information, and write a custom pretty-printer for e.g. help output+--   -- from that dynamically-enriched CommandDesc structure.+--   -- disabled for now, because i am not sure what exactly "adding to every+--   -- node" involves, because the mapping from Functor to Desc is nontrivial.+--   -- (and because i don't have a direct use-case at the moment..)+--   -- | CmdPartParserCustom Dynamic a+-- +-- type CmdPartParser = Free CmdPartParserF++---------++-- | A representation/description of a command parser built via the+-- 'CmdParser' monad. Can be transformed into a pretty Doc to display+-- as usage/help via 'ppUsage' and related functions.+--+-- Note that there is the '_cmd_out' accessor that contains @Maybe out@ which+-- might be useful after successful parsing.+data CommandDesc out = CommandDesc+  { _cmd_mParent  :: Maybe (String, CommandDesc out)+  , _cmd_synopsis :: Maybe PP.Doc+  , _cmd_help     :: Maybe PP.Doc+  , _cmd_parts    :: [PartDesc]+  , _cmd_out      :: Maybe out+  , _cmd_children :: Deque (String, CommandDesc out) -- we don't use a Map here+                                                     -- because we'd like to+                                                     -- retain the order.+  }++-- type PartSeqDesc = [PartDesc]++-- | A representation/description of a command's parts, i.e. flags or params.+-- As a butcher user, the higher-level pretty-printing functions for+-- 'CommandDesc' are probably sufficient.+data PartDesc+  = PartLiteral String -- expect a literal string, like "--dry-run"+  | PartVariable String -- expect some user-provided input. The+                               -- string represents the name for the variable+                               -- used in the documentation, e.g. "FILE"+  | PartOptional PartDesc+  | PartAlts [PartDesc]+  | PartSeq [PartDesc]+  | PartDefault String -- default representation+                PartDesc+  | PartSuggestion [String] PartDesc+  | PartRedirect String -- name for the redirection+                 PartDesc+  | PartReorder [PartDesc]+  | PartMany PartDesc+  | PartWithHelp PP.Doc PartDesc+  deriving Show++addSuggestion :: Maybe [String] -> PartDesc -> PartDesc+addSuggestion Nothing     = id+addSuggestion (Just sugs) = PartSuggestion sugs++{-+command documentation structure+1. terminals. e.g. "--dry-run"+2. non-terminals, e.g. "FILES"+3. sequences, e.g. "<program> FLAGS NUMBER PATH"+-- 4. alternatives, e.g. "--date=(relative|local|iso|rfc|..)"+5. sub-commands: git (init|commit|push|clone|..)+   compared to 4, the subcommands have their own flags and params;+   they essentially "take over".+6. optional, e.g. "cabal run [COMPONENT]"+7. default, e.g. "-O(LEVEL=1)"+8. indirection, e.g. "cabal COMMAND\n\nCOMMAND: ..."+-}++--++deriving instance Functor (CmdParserF f out)+deriving instance Functor CommandDesc++--++emptyCommandDesc :: CommandDesc out+emptyCommandDesc = CommandDesc Nothing Nothing Nothing [] Nothing mempty++instance Show (CommandDesc out) where+  show c = "Command help=" ++ show (_cmd_help c)+        ++ " synopsis=" ++ show (_cmd_synopsis c)+        ++ " mParent=" ++ show (fst <$> _cmd_mParent c)+        ++ " out=" ++ maybe "(none)" (\_ -> "(smth)") (_cmd_out c)+        ++ " parts.length=" ++ show (length $ _cmd_parts c)+        ++ " parts=" ++ show (_cmd_parts c)+        ++ " children=" ++ show (fst <$> _cmd_children c)++--++LensTH.makeLenses ''CommandDesc+LensTH.makeLenses ''PartDesc++--++++-- instance Show FlagDesc where+--   show (FlagDesc _ short long helpM params) = show (short, long, helpM, params) -- TODO: improve++-- class Typeable a => IsParam a where+--   paramParse :: String -> Maybe (a, String, String) -- value, representation, rest+--   paramStaticDef :: a++-- emptyParamDesc :: ParamDesc a+-- emptyParamDesc = ParamDesc Nothing Nothing++-- deriving instance Show a => Show (ParamDesc a)+++-- instance Show a => Show (CmdParserF out a) where+--   show (CmdParserHelp s x) = "(CmdParserHelp " ++ show s ++ " " ++ show x ++ ")"+--   show (CmdParserFlag shorts longs _ _) = "(CmdParserFlag -" ++ shorts ++ " " ++ show longs ++ ")"+--   show (CmdParserParam s _ _) = "(CmdParserParam " ++ s ++ ")"+--   show (CmdParserChild s _ _) = "(CmdParserChild " ++ s ++ ")"+--   show (CmdParserRun _) = "CmdParserRun"+

@@ -0,0 +1,171 @@++-- | Parameters are arguments of your current command that are not prefixed+-- by some flag. Typical commandline interface is something like+-- "PROGRAM [FLAGS] INPUT". Here, FLAGS are Flags in butcher, and INPUT is+-- a Param, in this case a String representing a path, for example.+module UI.Butcher.Monadic.Param+  ( Param(..)+  , paramHelp+  , paramHelpStr+  , paramDefault+  , paramSuggestions+  , addReadParam+  , addReadParamOpt+  , addStringParam+  , addStringParamOpt+  , addRestOfInputStringParam+  )+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 Text.PrettyPrint as PP++import           Data.HList.ContainsType++import           UI.Butcher.Monadic.Internal.Types+import           UI.Butcher.Monadic.Internal.Core++++-- | param-description monoid. You probably won't need to use the constructor;+-- mzero or any (<>) of param(Help|Default|Suggestion) works well.+data Param p = Param+  { _param_default :: Maybe p+  , _param_help :: Maybe PP.Doc+  , _param_suggestions :: Maybe [p]+  }++instance Monoid (Param p) where+  mempty = Param Nothing Nothing Nothing+  mappend (Param a1 b1 c1)+          (Param a2 b2 c2)+    = Param+          (a1 `f` a2)+          (b1 `mappend` b2)+          (c1 `mappend` c2)+    where+      f Nothing x = x+      f x       _ = x++-- | Create a 'Param' with just a help text.+paramHelpStr :: String -> Param p+paramHelpStr s = mempty { _param_help = Just $ PP.text s }++-- | Create a 'Param' with just a help text.+paramHelp :: PP.Doc -> Param p+paramHelp h = mempty { _param_help = Just h }++-- | Create a 'Param' with just a default value.+paramDefault :: p -> Param p+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 }++-- | 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+-- is normal for the Show/Read instances for String.+addReadParam :: forall f out a+              . (Applicative f, Typeable a, Show a, Text.Read.Read a)+             => String -- ^ paramater name, for use in usage/help texts+             -> Param a -- ^ properties+             -> CmdParser f out a+addReadParam name par = addCmdPart desc parseF+  where+    desc :: PartDesc+    desc = (maybe id PartWithHelp $ _param_help par)+         $ (maybe id (PartDefault . show) $ _param_default par)+         $ PartVariable name+    parseF :: String -> Maybe (a, String)+    parseF s = case Text.Read.reads s of+      ((x, ' ':r):_) -> Just (x, dropWhile Char.isSpace r)+      ((x, []):_)    -> Just (x, [])+      _ -> _param_default par <&> \x -> (x, s)++-- | Like addReadParam, but optional. I.e. if reading fails, returns Nothing.+addReadParamOpt :: forall f out a+                 . (Applicative f, Typeable a, Text.Read.Read a)+                => String -- ^ paramater name, for use in usage/help texts+                -> Param a -- ^ properties+                -> CmdParser f out (Maybe a)+addReadParamOpt name par = addCmdPart desc parseF+  where+    desc :: PartDesc+    desc = PartOptional+         $ (maybe id PartWithHelp $ _param_help par)+         $ PartVariable name+    parseF :: String -> Maybe (Maybe a, String)+    parseF s = case Text.Read.reads s of+      ((x, ' ':r):_) -> Just (Just x, dropWhile Char.isSpace r)+      ((x, []):_)    -> Just (Just x, [])+      _ -> Just (Nothing, s) -- TODO: we could warn about a default..++-- | Add a parameter that matches any string of non-space characters if input+-- String, or one full argument if input is [String]. See the 'Input' doc for+-- this distinction.+addStringParam+  :: forall f out . (Applicative f)+  => String+  -> Param String+  -> CmdParser f out String+addStringParam name par = addCmdPartInp desc parseF+  where+    desc :: PartDesc+    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+          ("", rest) -> _param_default par <&> \x -> (x, InputString rest)+          (x, rest) -> Just (x, InputString rest)+    parseF (InputArgs args) = case args of+      (s1:sR) -> Just (s1, InputArgs sR)+      []      -> _param_default par <&> \x -> (x, InputArgs args)++-- | Like 'addStringParam', but optional, I.e. succeeding with Nothing if+-- there is no remaining input.+addStringParamOpt+  :: forall f out . (Applicative f)+  => String+  -> Param Void+  -> CmdParser f out (Maybe String)+addStringParamOpt name par = addCmdPartInp desc parseF+  where+    desc :: PartDesc+    desc = PartOptional+         $ (maybe id PartWithHelp $ _param_help par)+         $ PartVariable name+    parseF :: Input -> Maybe (Maybe String, Input)+    parseF (InputString str)+      = case break Char.isSpace $ dropWhile Char.isSpace str of+          ("", rest) -> Just (Nothing, InputString rest)+          (x, rest) -> Just (Just x, InputString rest)+    parseF (InputArgs args) = case args of+      (s1:sR) -> Just (Just s1, InputArgs sR)+      []      -> Just (Nothing, InputArgs [])+++-- | Add a parameter that consumes _all_ remaining input. Typical usecase is+-- after a "--" as common in certain (unix?) commandline tools.+addRestOfInputStringParam+  :: 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 [])

@@ -0,0 +1,254 @@++-- | Pretty-print of CommandDescs. To explain what the different functions+-- do, we will use an example CmdParser. The CommandDesc derived from that+-- CmdParser will serve as example input to the functions in this module.+--+-- > main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do+-- > +-- >   addCmdSynopsis "a simple butcher example program"+-- >   addCmdHelpStr "a very long help document"+-- > +-- >   addCmd "version" $ do+-- >     porcelain <- addSimpleBoolFlag "" ["porcelain"]+-- >       (flagHelpStr "print nothing but the numeric version")+-- >     addCmdHelpStr "prints the version of this program"+-- >     addCmdImpl $ putStrLn $ if porcelain+-- >       then "0.0.0.999"+-- >       else "example, version 0.0.0.999"+-- > +-- >   addCmd "help" $ addCmdImpl $ print $ ppHelpShallow helpDesc+-- > +-- >   short <- addSimpleBoolFlag "" ["short"] (flagHelpStr "make the greeting short")+-- >   name <- addStringParam "NAME"+-- >     (paramHelpStr "your name, so you can be greeted properly")+-- > +-- >   addCmdImpl $ do+-- >     if short+-- >       then putStrLn $ "hi, " ++ name ++ "!"+-- >       else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!"+module UI.Butcher.Monadic.Pretty+  ( ppUsage+  , ppUsageAt+  , ppHelpShallow+  , ppUsageWithHelp+  , ppPartDescUsage+  , ppPartDescHeader+  , parsingErrorString+  )+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 Text.PrettyPrint as PP+import           Text.PrettyPrint ( (<+>), ($$), ($+$) )++import           Data.HList.ContainsType++import           UI.Butcher.Monadic.Internal.Types+import           UI.Butcher.Monadic.Internal.Core++++-- | ppUsage exampleDesc yields:+--+-- > playground [--short] NAME [version | help]+ppUsage :: CommandDesc a -> PP.Doc+ppUsage (CommandDesc mParent _help _syn parts out children) = pparents mParent+  <+> PP.fsep (partDocs ++ [subsDoc])+ where+  pparents :: Maybe (String, CommandDesc out) -> PP.Doc+  pparents Nothing        = PP.empty+  pparents (Just (n, cd)) = pparents (_cmd_mParent cd) <+> PP.text n+  partDocs = parts <&> ppPartDescUsage+  subsDoc  = case out of+    _ | null children -> PP.empty -- TODO: remove debug+    Nothing | null parts -> subDoc+            | otherwise  -> PP.parens $ subDoc+    Just{} -> PP.brackets $ subDoc+  subDoc =+    PP.fcat+      $   PP.punctuate (PP.text " | ")+      $   Data.Foldable.toList+      $   children+      <&> \(n, _) -> PP.text n++-- | ppUsageWithHelp exampleDesc yields:+--+-- > playground [--short] NAME+-- >            [version | help]: a simple butcher example program+--+-- And yes, the line break is not optimal in this instance with default print.+ppUsageWithHelp :: CommandDesc a -> PP.Doc+ppUsageWithHelp (CommandDesc mParent help _syn parts out children) =+  pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc+ where+  pparents :: Maybe (String, CommandDesc out) -> PP.Doc+  pparents Nothing        = PP.empty+  pparents (Just (n, cd)) = pparents (_cmd_mParent cd) <+> PP.text n+  partDocs = parts <&> ppPartDescUsage+  subsDoc  = case out of+    _ | null children -> PP.empty -- TODO: remove debug+    Nothing | null parts -> subDoc+            | otherwise  -> PP.parens $ subDoc+    Just{} -> PP.brackets $ subDoc+  subDoc =+    PP.fcat+      $   PP.punctuate (PP.text " | ")+      $   Data.Foldable.toList+      $   children+      <&> \(n, _) -> PP.text n+  helpDoc = case help of+    Nothing -> PP.empty+    Just h  -> PP.text ":" PP.<+> h++-- | > ppUsageAt [] = ppUsage+--+-- fromJust $ ppUsageAt ["version"] exampleDesc yields:+--+-- > example version [--porcelain]+ppUsageAt :: [String] -- (sub)command sequence+          -> CommandDesc a+          -> Maybe PP.Doc+ppUsageAt strings desc =+  case strings of+    [] -> Just $ ppUsage desc+    (s:sr) -> find ((s==) . fst) (_cmd_children desc) >>= ppUsageAt sr . snd++-- | ppHelpShalloe exampleDesc yields:+--+-- > NAME+-- > +-- >   example - a simple butcher example program+-- > +-- > USAGE+-- > +-- >   example [--short] NAME [version | help]+-- > +-- > DESCRIPTION+-- > +-- >   a very long help document+-- > +-- > ARGUMENTS+-- > +-- >   --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) =+        nameSection+    $+$ usageSection+    $+$ descriptionSection+    $+$ partsSection+    $+$ PP.text ""+  where+    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 (String, CommandDesc out) -> PP.Doc+    pparents Nothing = PP.empty+    pparents (Just (n, cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n+    usageSection =+            PP.text "USAGE"+        $+$ PP.text ""+        $+$ PP.nest 2 (ppUsage desc)+    descriptionSection = case help of+      Nothing -> PP.empty+      Just h ->+            PP.text ""+        $+$ PP.text "DESCRIPTION"+        $+$ PP.text ""+        $+$ PP.nest 2 h+    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 (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++-- | Internal helper; users probably won't need this.+ppPartDescUsage :: PartDesc -> 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 "+"+  PartWithHelp _ p -> rec p+  PartReorder ps ->+    let flags  = [ d | PartMany d <- ps ]+        params = filter ( \case+                          PartMany{} -> False+                          _          -> True+                        )+                        ps+    in  PP.brackets (PP.fsep $ rec <$> flags) <+> PP.fsep (rec <$> params)+ where+  rec = ppPartDescUsage++-- | Internal helper; users probably won't need this.+ppPartDescHeader :: PartDesc -> PP.Doc+ppPartDescHeader = \case+  PartLiteral  s     -> PP.text s+  PartVariable s     -> PP.text s+  PartOptional ds'   -> rec ds'+  PartAlts     alts  -> PP.hcat $ List.intersperse (PP.text ",") $ rec <$> alts+  PartDefault    _ d -> rec d+  PartSuggestion _ d -> rec d+  PartRedirect   s _ -> PP.text s+  PartMany ds        -> rec ds+  PartWithHelp _ d   -> rec d+  PartSeq     ds     -> PP.hsep $ rec <$> ds+  PartReorder ds     -> PP.vcat $ rec <$> ds+ where+  rec = ppPartDescHeader++-- | Simple conversion from 'ParsingError' to 'String'.+parsingErrorString :: ParsingError -> String+parsingErrorString (ParsingError mess remaining) =+  "error parsing arguments: " ++ messStr ++ remainingStr+ where+  messStr      = case mess of+    []    -> ""+    (m:_) -> m ++ " "+  remainingStr = case remaining of+    InputString ""  -> "at the end of input."+    InputString str -> case show str of+      s | length s < 42 -> "at: " ++ s ++ "."+      s                 -> "at: " ++ take 40 s ++ "..\"."+    InputArgs   []  -> "at the end of input"+    InputArgs   xs  -> case List.unwords $ show <$> xs of+      s | length s < 42 -> "at: " ++ s ++ "."+      s                 -> "at: " ++ take 40 s ++ "..\"."+

@@ -0,0 +1,20 @@+-- this module only re-exports the appropriate user-facing stuff from the+-- internal Types module.+-- | Types used in the butcher interface.+module UI.Butcher.Monadic.Types+  ( CommandDesc(..)+  , cmd_out+  , CmdParser+  , Input (..)+  , ParsingError (..)+  , PartDesc(..)+  )+where++++#include "prelude.inc"++++import           UI.Butcher.Monadic.Internal.Types

@@ -0,0 +1,409 @@+import qualified Data.Graph+import qualified Data.IntMap+import qualified Data.IntMap.Lazy+import qualified Data.IntMap.Strict+import qualified Data.IntSet+import qualified Data.Map+import qualified Data.Map.Lazy+import qualified Data.Map.Strict+import qualified Data.Sequence+import qualified Data.Set+import qualified Data.Tree++import qualified Control.Concurrent.Extra+import qualified Control.Exception.Extra+import qualified Control.Monad.Extra+import qualified Data.Either.Extra+import qualified Data.IORef.Extra+import qualified Data.List.Extra+import qualified Data.Tuple.Extra+import qualified Data.Version.Extra+import qualified Numeric.Extra+import qualified System.Directory.Extra+import qualified System.Environment.Extra+import qualified System.IO.Extra+import qualified System.Info.Extra+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+import qualified Control.Monad.Trans.MultiReader.Class+import qualified Control.Monad.Trans.MultiReader.Lazy+import qualified Control.Monad.Trans.MultiReader.Strict+import qualified Control.Monad.Trans.MultiState+import qualified Control.Monad.Trans.MultiState.Class+import qualified Control.Monad.Trans.MultiState.Lazy+import qualified Control.Monad.Trans.MultiState.Strict+import qualified Control.Monad.Trans.MultiWriter+import qualified Control.Monad.Trans.MultiWriter.Class+import qualified Control.Monad.Trans.MultiWriter.Lazy+import qualified Control.Monad.Trans.MultiWriter.Strict++import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS+import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL++import qualified Data.Bifunctor+import qualified Data.Bits+import qualified Data.Bool+import qualified Data.Char+import qualified Data.Coerce+import qualified Data.Complex+import qualified Data.Data+import qualified Data.Dynamic+import qualified Data.Either+import qualified Data.Eq+import qualified Data.Fixed+import qualified Data.Foldable+import qualified Data.Function+import qualified Data.Functor+import qualified Data.Functor.Identity+import qualified Data.IORef+import qualified Data.Int+import qualified Data.Ix+import qualified Data.List+import qualified Data.Maybe+import qualified Data.Monoid+import qualified Data.Ord+import qualified Data.Proxy+import qualified Debug.Trace+import qualified Numeric+import qualified Numeric.Natural+import qualified System.Environment+import qualified System.IO+import qualified Text.Read+import qualified Text.Show+import qualified Unsafe.Coerce++import qualified Data.Bool as Bool+import qualified Data.Char as Char+import qualified Data.Maybe as Maybe+import qualified Control.Monad.Trans.Writer.Strict as WriterS++#if MIN_VERSION_base(4,9,0)+import qualified GHC.OldList as List+#else+import qualified Data.List as List+#endif++import qualified Data.IntMap as IntMap+import qualified Data.IntMap.Strict as IntMapS+import qualified Data.Map.Strict as MapS+import qualified Data.Map.Lazy as MapL+import qualified Data.Sequence as Seq+import qualified Data.Set as Set++import qualified Control.Monad.RWS.Class as RWS.Class+import qualified Control.Monad.Reader.Class as Reader.Class+import qualified Control.Monad.State.Class as State.Class+import qualified Control.Monad.Writer.Class as Writer.Class++import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.State.Lazy as StateL+import qualified Control.Monad.Trans.State.Strict as StateS++import Data.Functor.Identity ( Identity(..) )+import Control.Concurrent.Chan ( Chan )+import Control.Concurrent.MVar ( MVar )+import Data.Int ( Int )+import Data.Word ( Word )+import Prelude ( Integer, Float, Double )+import Control.Monad.ST ( ST )+import Data.Bool ( Bool(..) )+import Data.Char ( Char )+import Data.Either ( Either(..) )+import Data.IORef ( IORef )+import Data.Maybe ( Maybe(..) )+import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), First(..), Last(..), Alt(..), )+import Data.Ord ( Ordering(..), Down(..) )+import Data.Ratio ( Ratio, Rational )+import Data.String ( String )+import Data.Void ( Void )+import System.IO ( IO )+import Data.Proxy ( Proxy(..) )+import Data.Sequence ( Seq )++import Data.Map ( Map )+import Data.Set ( Set )++import Deque ( Deque )++import qualified Deque++import Prelude                            ( Char+                                          , String+                                          , Int+                                          , Integer+                                          , Float+                                          , Double+                                          , Bool (..)+                                          , undefined+                                          , Eq (..)+                                          , Ord (..)+                                          , Enum (..)+                                          , Bounded (..)+                                          , Maybe (..)+                                          , Either (..)+                                          , IO+                                          , (<$>)+                                          , (.)+                                          , ($)+                                          , ($!)+                                          , Num (..)+                                          , Integral (..)+                                          , Fractional (..)+                                          , Floating (..)+                                          , RealFrac (..)+                                          , RealFloat (..)+                                          , fromIntegral+                                          , error+                                          , foldr+                                          , foldl+                                          , foldr1+                                          , id+                                          , map+                                          , subtract+                                          , putStrLn+                                          , putStr+                                          , Show (..)+                                          , print+                                          , fst+                                          , snd+                                          , (++)+                                          , not+                                          , (&&)+                                          , (||)+                                          , curry+                                          , uncurry+                                          , Ordering (..)+                                          , flip+                                          , const+                                          , seq+                                          , reverse+                                          , otherwise+                                          , traverse+                                          , realToFrac+                                          , or+                                          , and+                                          , head+                                          , any+                                          , (^)+                                          , Foldable+                                          , Traversable+                                          )++import Data.Foldable                      ( foldl'+                                          , foldr'+                                          , fold+                                          , asum+                                          )++import Data.List                          ( partition+                                          , null+                                          , elem+                                          , notElem+                                          , minimum+                                          , maximum+                                          , length+                                          , all+                                          , take+                                          , drop+                                          , find+                                          , sum+                                          , zip+                                          , zip3+                                          , zipWith+                                          , repeat+                                          , replicate+                                          , iterate+                                          , nub+                                          , filter+                                          , intersperse+                                          , intercalate+                                          , isSuffixOf+                                          , isPrefixOf+                                          , dropWhile+                                          , takeWhile+                                          , unzip+                                          , break+                                          , transpose+                                          , sortBy+                                          , mapAccumL+                                          , mapAccumR+                                          , uncons+                                          )++import Data.Tuple                         ( swap+                                          )++import Data.Char                          ( ord+                                          , chr+                                          )++import Data.Maybe                         ( fromMaybe+                                          , maybe+                                          , listToMaybe+                                          , maybeToList+                                          , catMaybes+                                          )++import Data.Word                          ( Word32+                                          )++import Data.Ord                           ( comparing+                                          , Down (..)+                                          )++import Data.Either                        ( either+                                          )++import Data.Ratio                         ( Ratio+                                          , (%)+                                          , numerator+                                          , denominator+                                          )++import Text.Read                          ( readMaybe+                                          )++import Control.Monad                      ( Functor (..)+                                          , Monad (..)+                                          , MonadPlus (..)+                                          , mapM+                                          , mapM_+                                          , forM+                                          , forM_+                                          , sequence+                                          , sequence_+                                          , (=<<)+                                          , (>=>)+                                          , (<=<)+                                          , forever+                                          , void+                                          , join+                                          , replicateM+                                          , replicateM_+                                          , guard+                                          , when+                                          , unless+                                          , liftM+                                          , liftM2+                                          , liftM3+                                          , liftM4+                                          , liftM5+                                          , filterM+                                          , (<$!>)+                                          )++import Control.Applicative                ( Applicative (..)+                                          , Alternative (..)+                                          )++import Foreign.Storable                   ( Storable )+import GHC.Exts                           ( Constraint )++import Control.Concurrent                 ( threadDelay+                                          , forkIO+                                          , forkOS+                                          )++import Control.Concurrent.MVar            ( MVar+                                          , newEmptyMVar+                                          , newMVar+                                          , putMVar+                                          , readMVar+                                          , takeMVar+                                          , swapMVar+                                          )++import Control.Exception                  ( evaluate+                                          , bracket+                                          , assert+                                          )++import Debug.Trace                        ( trace+                                          , traceId+                                          , traceShowId+                                          , traceShow+                                          , traceStack+                                          , traceShowId+                                          , traceIO+                                          , traceM+                                          , traceShowM+                                          )++import Foreign.ForeignPtr                 ( ForeignPtr+                                          )++import Data.Monoid                        ( (<>)+                                          , mconcat+                                          , Monoid (..)+                                          )++import Data.Bifunctor                     ( bimap )+import Data.Functor                       ( (<$), ($>) )+import Data.Function                      ( (&) )+import System.IO                          ( hFlush+                                          , stdout+                                          )++import Data.Typeable                      ( Typeable+                                          )++import Control.Arrow                      ( first+                                          , second+                                          , (***)+                                          , (&&&)+                                          , (>>>)+                                          , (<<<)+                                          )++import Data.Functor.Identity              ( Identity (..)+                                          )++import Data.Proxy                         ( Proxy (..)+                                          )++import Data.Version                       ( showVersion+                                          )++import Data.List.Extra                    ( nubOrd+                                          , stripSuffix+                                          )+import Control.Monad.Extra                ( whenM+                                          , unlessM+                                          , ifM+                                          , notM+                                          , orM+                                          , andM+                                          , anyM+                                          , allM+                                          )++import Data.Tree                          ( Tree(..)+                                          )++import Control.Monad.Trans.MultiRWS       ( MonadMultiReader(..)+                                          , MonadMultiWriter(..)+                                          , MonadMultiState(..)+                                          )++import Control.Monad.Trans.MultiReader    ( runMultiReaderTNil+                                          , runMultiReaderTNil_+                                          , MultiReaderT (..)+                                          , MultiReader+                                          , MultiReaderTNull+                                          )++import Control.Monad.IO.Class             ( MonadIO (..)+                                          )++import Control.Monad.Trans.Class          ( lift+                                          )+import Control.Monad.Trans.Maybe          ( MaybeT (..)+                                          )+import Lens.Micro                         ( (<&>)+                                          )