Update/Correct changelog

mainFromCmdParserWithHelpDesc is no longer required, because
peekCmdDesc can be used at the top-level to access the full
CmdDesc value. The knot-tying implementation is no longer
required either.

.gitignore

@@ -15,3 +15,7 @@ cabal.sandbox.config
 \#*.gui\#
 cabal.project.local
 .ghc.environment.*
+/result*
+/nix/seaaye-cache
+/nix/gcroots
+/nix/ci-out

ChangeLog.md

@@ -1,5 +1,39 @@
 # Revision history for butcher
 
+## 2.0.0.0  -- May 2023
+
+Large internal refactor including some breaking API changes.
+
+- Support ghc-9.0 and ghc-9.2
+- Add the "Applicative" interface in addition to the existing "Monadic" one.
+  This is slightly less expressive but conceptually cleaner/safer (and its
+  implementation is nicer). For best readability you may need `ApplicativeDo`.
+- The applicative interface is *NOT* finished and the test-suite does not
+  cover it.
+- Add the `traverseBarbie` construct to elegantly define a parser for a
+  config data-structure.\
+  Introduces a dependency on the `barbies` library.
+- Refactor the module structure a bit, and change the API of the central
+  `runCmdParser` function. It now returns a `PartialParseInfo`. Essentially,
+  `runCmdParser` is a combination of the previous `runCmdParser` and the
+  previous `simpleCompletion`. This API design is a curious advantage to
+  laziness: Returning a complex struct is harmless as fields that the user
+  does not use won't be evaluated. The downside is that the core function now
+  looks like a complex beast, but the upside is that there is no need to
+  expose multiple functions that are supposed to be chained in a certain way
+  to get all functionality (if desired), and we still _can_ provide simpler
+  versions that are just projections on the `PartialParseInfo`.
+- Remove deprecated functions
+- `peekCmdDesc` is now guaranteed to yield the proper full `CmdDesc` value
+  for the current command or child-command.
+- Remove the `mainFromCmdParserWithHelpDesc` function, because it is redundant
+  given the new semantics of `peekCmdDesc`.
+- Stop support for an anti-feature: The implicit merging of multiple
+  sub-commands definitions with the same name.
+- Internal refactor: The monadic interface now uses two-phase setup: First step
+  is to create a full CommandDesc value, second is running the parser on input
+  while the CommandDesc is chained along
+
 ## 1.3.3.2  -- June 2020
 
 * Support ghc-8.10

README.md

@@ -9,19 +9,24 @@ The main differences are:
 
 * Provides a pure interface by default
 
-* Exposes an evil monadic interface, which allows for much nicer binding of
+* Exposes two interfaces: One based on `Applicative` and one based on `Monad`.
-  command part results to some variable name.
+  The monadic one is slightly more expressive, the applicative interface is
+  conceptually cleaner but currently is less tested.
 
-    In `optparse-applicative` you easily lose track of what field you are
+* The monadic interface must be used as if `ApplicativeDo` was enabled,
-    modifying after the 5th `<*>` (admittedly, i think -XRecordWildCards
+  but does not actually require `ApplicativeDo`. This is implemented via
-    improves on that issue already.)
+  some evil hackery, but nonetheless useful.
 
-    Evil, because you are not allowed to use the monad's full power in this
+* It is not necessary to define data-structure for diffenent child-commands.
-    case, i.e. there is a constraint that is not statically enforced.
+  In general this is geared towards keeping names and definitions/parsers
-    See below.
+  of flags/parameters/child-commands connected, while the default
+  `MyFlags <$> someParser <*> … <*> … <*> … <*> … <*> …` is harder to read
+  and prone to accidental swapping.
 
-* The monadic interface allows much clearer definitions of commandparses
+* Supports connecting to "barbies"
-  with (nested) subcommands. No pesky sum-types are necessary.
+  (see the [`barbies`](https://hackage.haskell.org/package/barbies) package).
+  This allows re-using data-structure definitions for the parser and config
+  values without losing track of field order.
 
 ## Examples
 
@@ -34,7 +39,9 @@ main = mainFromCmdParser $ addCmdImpl $ putStrLn "Hello, World!"
 But lets look at a more feature-complete example:
 
 ~~~~.hs
-main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do
+main = mainFromCmdParser $ do
+
+  helpDesc <- peekCmdDesc
 
   addCmdSynopsis "a simple butcher example program"
   addCmdHelpStr "a very long help document"
@@ -44,14 +51,14 @@ main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do
       (flagHelpStr "print nothing but the numeric version")
     addCmdHelpStr "prints the version of this program"
     addCmdImpl $ putStrLn $ if porcelain
-      then "0.0.0.999"
+      then "1.0"
-      else "example, version 0.0.0.999"
+      else "example, version 1.0"
 
   addCmd "help" $ addCmdImpl $ print $ ppHelpShallow helpDesc
 
   short <- addSimpleBoolFlag "" ["short"]
     (flagHelpStr "make the greeting short")
-  name <- addStringParam "NAME"
+  name <- addParamString "NAME"
     (paramHelpStr "your name, so you can be greeted properly")
 
   addCmdImpl $ do
@@ -62,9 +69,7 @@ main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do
 
 Further:
 
-- [Full description of the above example, including sample behaviour](example1.md)
+- See the examples folder included in the package
-- [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)

butcher.cabal

@@ -1,8 +1,9 @@
+cabal-version:       2.2
 name:                butcher
-version:             1.3.3.2
+version:             2.0.0.0
 synopsis:            Chops a command or program invocation into digestable pieces.
 description:         See the <https://github.com/lspitzner/butcher/blob/master/README.md README> (it is properly formatted on github).
-license:             BSD3
+license:             BSD-3-Clause
 license-file:        LICENSE
 author:              Lennart Spitzner
 maintainer:          Lennart Spitzner <hexagoxel@hexagoxel.de>
@@ -15,7 +16,6 @@ extra-source-files: {
   srcinc/prelude.inc
   README.md
 }
-cabal-version:       >=1.10
 homepage:            https://github.com/lspitzner/butcher/
 bug-reports:         https://github.com/lspitzner/butcher/issues
 
@@ -24,6 +24,11 @@ source-repository head {
   location: https://github.com/lspitzner/butcher.git
 }
 
+flag butcher-examples
+  description: must be enabled to build examples
+  default: False
+  manual: True
+
 library
   exposed-modules:     UI.Butcher.Monadic.Types
                        UI.Butcher.Monadic
@@ -32,12 +37,23 @@ library
                        UI.Butcher.Monadic.Flag
                        UI.Butcher.Monadic.Pretty
                        UI.Butcher.Monadic.IO
-                       UI.Butcher.Monadic.Interactive
                        UI.Butcher.Monadic.BuiltinCommands
-  other-modules:       UI.Butcher.Monadic.Internal.Types
+                       UI.Butcher.Applicative.Command
-                       UI.Butcher.Monadic.Internal.Core
+                       UI.Butcher.Applicative.Param
+                       UI.Butcher.Applicative.Flag
+                       UI.Butcher.Applicative.Pretty
+                       UI.Butcher.Applicative.IO
+                       UI.Butcher.Applicative
+  other-modules:       UI.Butcher.Internal.CommonTypes
+                       UI.Butcher.Internal.MonadicTypes
+                       UI.Butcher.Internal.Monadic
+                       UI.Butcher.Internal.ApplicativeTypes
+                       UI.Butcher.Internal.Applicative
+                       UI.Butcher.Internal.BasicStringParser
+                       UI.Butcher.Internal.Pretty
+                       UI.Butcher.Internal.Interactive
   build-depends:
-    { base >=4.11 && <4.15
+    { base >=4.11 && <4.17
     , free < 5.2
     , unsafe < 0.1
     , microlens <0.5
@@ -51,6 +67,8 @@ library
     , void <0.8
     , bifunctors <5.6
     , deque >=0.3 && <0.5
+    , barbies >= 2.0.2.0 && <2.1
+    , semigroups
     }
   hs-source-dirs:      src
   default-language:    Haskell2010
@@ -134,3 +152,64 @@ test-suite tests
     -fno-warn-unused-imports
     -fno-warn-orphans
   }
+
+common example-base
+  default-language: Haskell2010
+  hs-source-dirs:   examples
+  include-dirs:
+    srcinc
+  default-extensions: {
+    GADTs
+
+    FlexibleContexts
+    FlexibleInstances
+    ScopedTypeVariables
+    MonadComprehensions
+    LambdaCase
+    MultiWayIf
+    KindSignatures
+  }
+  ghc-options: {
+    -Wall
+    -rtsopts
+    -fno-warn-unused-imports
+    -fno-warn-orphans
+  }
+  if !flag(butcher-examples) {
+    buildable: False
+  }
+
+executable example01
+  import: example-base
+  build-depends:
+    { base
+    , butcher
+    }
+  main-is:          HelloWorld.hs
+  other-modules:    
+
+executable example02
+  import: example-base
+  build-depends:
+    { base
+    , butcher
+    }
+  main-is:          SimpleCommandlineParser.hs
+
+executable example03
+  import: example-base
+  build-depends:
+    { base
+    , butcher
+    , concurrent-output
+    }
+  main-is:          InteractiveConcurrentOutput.hs
+
+executable example04
+  import: example-base
+  build-depends:
+    { base
+    , butcher
+    , barbies
+    }
+  main-is:          BarbieParsing.hs

default.nix

@@ -1 +1 @@
-(import ./nix/all.nix {}).default.multistate
+(import ./nix/all.nix).default.butcher

example1.md

@@ -1,81 +0,0 @@
-## CmdParser definition
-
-~~~~.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 "1.0"
-      else "example, version 1.0"
-
-  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!"
-~~~~
-
-## Program behaviour (executable is named `example`):
-
-~~~~
-> ./example
-example: error parsing arguments: could not parse NAME
-at the end of input
-usage:
-example [--short] NAME [version | help]
-~~~~
-
----
-
-~~~~
-> ./example help
-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
-~~~~
-
----
-
-~~~~
-> ./example garfield
-hello, garfield, welcome from butcher!
-~~~~
-
----
-
-~~~~
-> ./example --short garfield
-hi, garfield!
-~~~~
-
----
-
-~~~~
-> ./example version --porcelain
-1.0
-~~~~

example2.md

@@ -1,24 +0,0 @@
-## definitions
-
-~~~~.hs
-exampleCmdParser :: CmdParser Identity Int ()
-exampleCmdParser = do
-  addCmd "foo" $ addCmdImpl 42
-  addCmd "bar" $ addCmdImpl 99
-  addCmdImpl 0
-
-fooBarParser :: String -> Either ParsingError (CommandDesc Int)
-fooBarParser str = result
-  where
-    (_desc, result) =
-      runCmdParser (Just "example") (InputString str) exampleCmdParser
-~~~~
-
-## Behaviour of fooBarParser:
-
-~~~~
-fooBarParser ""    ~> Right 0
-foobarParser "foo" ~> Right 42
-foobarParser "bar" ~> Right 99
-fooBarParser _     ~> Left someParsingError
-~~~~

example3.md

@@ -1,45 +0,0 @@
-## program
-
-~~~~.hs
-data Out = Abort | Continue (IO ())
-
-main = do
-  putStrLn "example interactive commandline program."
-  loop
- where
-  cmdParser :: CmdParser Identity Out ()
-  cmdParser = do
-    addCmd "exit" $ addCmdImpl Abort
-    addCmd "greeting" $ addCmdImpl $ Continue $ putStrLn "hi!"
-  loop = do
-    putStr "example> "
-    hFlush stdout
-    line <- getLine
-    case cmdRunParser Nothing (InputString line) cmdParser of
-      (_, Left err) -> do
-        print err
-        loop
-      (_, Right desc) -> case _cmd_out desc of
-        Nothing -> do
-          putStrLn "Usage: "
-          print $ ppUsage desc
-          loop
-        Just Abort -> return ()
-        Just (Continue action) -> do
-          action
-          loop
-~~~~
-
-## sample session:
-
-~~~~
-bash> ./example<enter>
-example interactive commandline program.
-example> <enter>
-Usage: 
-exit | greeting
-example> greeting<enter>
-hi!
-example> exit<enter>
-bash> 
-~~~~

examples/BarbieParsing.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Main where
+
+import           Barbies
+import           Barbies.Bare
+import           GHC.Generics                   ( Generic )
+import           UI.Butcher.Monadic
+
+
+
+data MyConfig s f = MyConfig
+  { verbosity    :: Wear s f Int
+  , dryRun       :: Wear s f Bool
+  , innerOptions :: Wear s f [String]
+  }
+  deriving Generic
+
+instance BareB MyConfig
+instance FunctorB (MyConfig Covered)
+instance TraversableB (MyConfig Covered)
+
+main :: IO ()
+main = mainFromCmdParser $ do
+
+  reorderStart
+  config <- traverseBarbie MyConfig
+    { verbosity    = addFlagReadParam "v" ["verbosity"] "INT" (flagDefault 1)
+    , dryRun       = addSimpleBoolFlag "" ["dryRun", "dry-run"] mempty
+    , innerOptions = addFlagStringParams "" ["inner-option"] "OPT" mempty
+    }
+  reorderStop
+
+  addCmdImpl $ do
+    putStrLn $ "commandline arguments produced the following config values:"
+    putStrLn $ "verbosity    = " ++ show (verbosity config)
+    putStrLn $ "dryRun       = " ++ show (dryRun config)
+    putStrLn $ "innerOptions = " ++ show (innerOptions config)
+

examples/HelloWorld.hs

@@ -0,0 +1,33 @@
+module Main where
+
+import           UI.Butcher.Monadic
+
+
+
+main :: IO ()
+main = mainFromCmdParser $ do
+
+  helpDesc <- peekCmdDesc
+
+  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 "1.0"
+      else "example, version 1.0"
+
+  addCmd "help" $ addCmdImpl $ print $ ppHelpShallow helpDesc
+
+  short <- addSimpleBoolFlag "" ["short"]
+    (flagHelpStr "make the greeting short")
+  name <- addParamString "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!"

examples/InteractiveConcurrentOutput.hs

@@ -0,0 +1,69 @@
+module Main
+  ( main
+  )
+where
+
+
+import           Data.Char
+import           Data.Functor.Identity
+
+import           System.Console.Concurrent
+import           System.Console.Regions
+import           System.IO
+
+import           UI.Butcher.Monadic
+
+
+parser :: CmdParser Identity (IO ()) ()
+parser = do
+  addCmd "inner" $ do
+    addCmdSynopsis "inner thingy"
+    my <- addSimpleBoolFlag "" ["my"] mempty
+    addCmdImpl $ do
+      putStrLn $ "my = " ++ show my
+      putStrLn "inner"
+  addCmd "ither" $ do
+    addCmdSynopsis "another inner command"
+    addCmdImpl $ putStrLn "other"
+  reorderStart
+  foo      <- addSimpleBoolFlag "" ["foo"] (flagHelpStr "!foo help!")
+  fooo     <- addSimpleBoolFlag "" ["fooo"] (flagHelpStr "!fooo help!")
+  bar      <- addSimpleBoolFlag "" ["bar"] (flagHelpStr "!bar is useful!")
+  x :: Int <- addFlagReadParam "x" [] "X" mempty
+  _b       <- addSimpleBoolFlag "b" [] mempty
+  reorderStop
+  addCmdImpl $ do
+    putStrLn $ "foo = " ++ show foo
+    putStrLn $ "fooo = " ++ show fooo
+    putStrLn $ "bar = " ++ show bar
+    putStrLn $ "x = " ++ show x
+
+main :: IO ()
+main = displayConsoleRegions $ do
+  withReg $ \reg1 -> withReg $ \reg2 -> withReg $ \reg3 -> do
+    let Right desc = toCmdDesc Nothing parser
+    let mainLoop s = do
+          let info = runCmdParserFromDesc desc (InputString s) parser
+          setConsoleRegion reg1 $ show (_ppi_interactiveHelp info 5)
+          setConsoleRegion reg2 (s ++ _ppi_inputSugg info)
+          setConsoleRegion reg3 s
+          -- putStr s
+          c <- getChar
+          -- outputConcurrent (show (ord c) ++ "\n")
+          -- print $ show $ ord 
+          case ord c of
+            127 -> do
+              -- putStr [c]
+              mainLoop (if null s then s else init s)
+            10 -> do
+              -- putStr (replicate 100 $ chr 127)
+              mainLoop ""
+            27 -> pure ()
+            _  -> do
+              -- putStr s -- [c]
+              mainLoop (s ++ [c])
+    hSetEcho stdin False
+    hSetBuffering stdin  NoBuffering
+    hSetBuffering stdout NoBuffering
+    mainLoop ""
+  where withReg = withConsoleRegion Linear

examples/SimpleCommandlineParser.hs

@@ -0,0 +1,27 @@
+module Main where
+
+import           UI.Butcher.Monadic
+
+
+
+main :: IO ()
+main = mainFromCmdParser $ do
+  addCmd "inner" $ do
+    my <- addSimpleBoolFlag "" ["my"] mempty
+    addCmdImpl $ do
+      putStrLn $ "my = " ++ show my
+      putStrLn "inner"
+  addCmd "other" $ do
+    addCmdImpl $ putStrLn "other"
+  reorderStart
+  foo      <- addSimpleBoolFlag "" ["foo"] mempty
+  bar      <- addSimpleBoolFlag "" ["bar"] mempty
+  x :: Int <- addFlagReadParam "x" [] "X" mempty
+  b        <- addSimpleBoolFlag "b" [] mempty
+  reorderStop
+  addCmdImpl $ do
+    putStrLn $ "foo = " ++ show foo
+    putStrLn $ "bar = " ++ show bar
+    putStrLn $ "x = " ++ show x
+    putStrLn $ "b = " ++ show b
+

nix/.gitignore

@@ -1,2 +0,0 @@
-nixpkgs.nix
-local-extra-deps.nix

nix/README.md

@@ -1,32 +0,0 @@
-
-This nix setup expects the iohk haskell-nix overlay to be available/included
-when importing `<nixpkgs>`. Also, you might need a specific commit if you
-want to test against all supported ghcs (8.4 - 8.10, currently).
-
-# Useful commands:
-
-~~~~.sh
-# enter a shell for a specific build-plan
-# (cabal-solved with ghc-8.4 in this case)
-nix-shell nix/all.nix -A '"hackage-8.4".shell'
-# run tests against ghcs 8.4 through 8.10, both against hackage and stackage package sets
-nix/ci.sh
-~~~~
-
-
-# Files in this directory:
-
-all.nix          - main entrypoint into this package's nix world
-via-hackage.nix  - how to build this via cabal-solved package-set
-via-stackage.nix - how to build via stackage-based package set
-nixpkgs.nix      - optional - if you want to use a custom nixpkgs channel
-                   (the replacement needs to have haskell-nix overlay _and_
-                   the cabal-check feature enabled though!)
-local-extra-deps.nix - optional - for defining local addition deps for
-                   dev testing
-
-(plus some currently unused:)
-
-materialized  - materializations of cabal-solved build-plans
-plan.nix      - manual materialization of unsolved build-plan (used with
-                stackage snapshot to build package set)

nix/all.nix

@@ -1,99 +0,0 @@
-let
-  importOrElse = maybePath: otherwise:
-    if builtins.pathExists maybePath then import maybePath else otherwise;
-  pkgs = importOrElse ./nixpkgs.nix
-    ( let
-        haskellNix = import (
-          builtins.fetchTarball
-            https://github.com/lspitzner/haskell.nix/archive/4ad436d66d1a553d1a36d89fcab9329f10ae36e9.tar.gz
-        ) { version = 2; };
-        nixpkgsSrc = haskellNix.sources.nixpkgs-1909;
-      in
-      import nixpkgsSrc haskellNix.nixpkgsArgs
-    );
-  gitignoreSrc = pkgs.fetchFromGitHub {
-    # owner = "hercules-ci";
-    owner = "lspitzner"; # TODO switch back to the above once PR is merged
-                         # see https://github.com/hercules-ci/gitignore.nix/pull/44
-    repo = "gitignore.nix";
-    rev = "97d53665298d2b31b79e5fe4b60edb12a6661547";
-    sha256 = "sha256:1b3z2ikpg32zsfrhv4fb17dqavgg7d4wahslxlm37w68y7adsdav";
-  };
-  inherit (import gitignoreSrc { inherit (pkgs) lib; }) gitignoreSource gitignoreFilter;
-  cleanedSource = pkgs.lib.cleanSourceWith {
-    name = "butcher";
-    src = ./..;
-    filter = p: t:
-      let baseName = baseNameOf (toString p);
-      in gitignoreFilter ./.. p t
-      && baseName != ".gitignore"
-      && baseName != "nix"
-      && baseName != "shell.nix"
-      && baseName != "default.nix";
-  };
-  localExtraDeps = importOrElse ./local-extra-deps.nix (_: []) {inherit pkgs;};
-  args = {
-    inherit pkgs;
-    inherit cleanedSource;
-    pkg-def-extras = localExtraDeps;
-  };
-  inherit (builtins) hasAttr;
-in
-assert pkgs.lib.assertMsg (hasAttr "haskell-nix" pkgs) "need iohk haskell-nix overlay!";
-let
-  versions = {
-    # "stack-8.0" = import ./via-stack.nix (args // { resolver = "lts-9.21"; });
-    # "stack-8.2" = import ./via-stack.nix (args // { resolver = "lts-11.22"; });
-    "stackage-8.4" = import ./via-stackage.nix (args // {
-      # resolver = "lts-12.26";
-      stackFile = "stack-8.4.yaml";
-    });
-    "stackage-8.6" = import ./via-stackage.nix (args // {
-      # resolver = "lts-14.27";
-      stackFile = "stack-8.6.yaml";
-    });
-    "stackage-8.8" = import ./via-stackage.nix (args // {
-      # resolver = "lts-15.12";
-      stackFile = "stack-8.8.yaml";
-    });
-    "hackage-8.4" = import ./via-hackage.nix (args // { 
-      ghc-ver = "ghc844";
-      index-state = "2020-05-01T00:00:00Z";
-      # plan-sha256 = "0s6rfanb6zxhr5zbinp7h25ahwasciwj3ambsr6zdxm1l782b3ap";
-      # materialized = ./materialized/hackage-8.4;
-      configureArgs = "--allow-newer multistate:*";
-    });
-    "hackage-8.6" = import ./via-hackage.nix (args // { 
-      ghc-ver = "ghc865";
-      index-state = "2020-05-01T00:00:00Z";
-      # plan-sha256 = "01m95xirrh00dvdxrpsx8flhcwlwcvgr3diwlnkw7lj5f3i7rfrl";
-      # materialized = ./materialized/hackage-8.6;
-      configureArgs = "--allow-newer multistate:*";
-    });
-    "hackage-8.8" = import ./via-hackage.nix (args // { 
-      ghc-ver = "ghc883";
-      index-state = "2020-05-01T00:00:00Z";
-      # plan-sha256 = "14qs7ynlf7p2qvdk8sf498y87ss5vab3ylnbpc8sacqbpv2hv4pf";
-      # materialized = ./materialized/hackage-8.8;
-      configureArgs = "--allow-newer multistate:*";
-    });
-  } // (if hasAttr "ghc8101" pkgs.haskell-nix.compiler
-    then {
-    "hackage-8.10" = import ./via-hackage.nix (args // { 
-      ghc-ver = "ghc8101";
-      index-state = "2020-06-06T00:00:00Z";
-      # index-sha256 = "1h1x65840jl6w2qvyq9csc7b3ivadr933glarnmydk2b23vw2i77";
-      # plan-sha256 = "1s8a6cb5qgf4ky5s750rzx6aa52slp1skazh8kbx0dbfjd6df7yw";
-      # materialized = ./materialized/hackage-8.10;
-      configureArgs = "--allow-newer multistate:* --constraint 'splitmix<0.1'";
-    });
-    } else builtins.trace "warn: ghc 8.10 is not avaiable, will not be tested!" {}
-  );
-  linkFarmFromDrvs = name: drvs:
-    let mkEntryFromDrv = drv: { name = drv.name; path = drv; };
-    in pkgs.linkFarm name (map mkEntryFromDrv drvs);
-in
-versions // {
-  inherit cleanedSource;
-  default = versions."stackage-8.8";
-}

nix/ci.sh

@@ -1,50 +0,0 @@
-
-OUTDIR="ci-out"
-SUMMARY="$OUTDIR/0-summary"
-CABAL_CHECK_ATTRPATH="hackage-8.10"
-
-set -x
-
-mkdir -p "$OUTDIR"
-echo "# test summary" > "$SUMMARY"
-
-function build-one {
-  local ATTRPATH=$1
-  # nix-build --no-out-link nix/all.nix -A "\"$ATTRPATH\".butcher.components.library"\
-  #   2> >(tee "$OUTDIR/$ATTRPATH-1-build-lib.txt" >&2)
-  # (($? == 0)) || { echo "$ATTRPATH: build src failed" >> "$SUMMARY"; return 1; }
-  # nix-build --no-out-link nix/all.nix -A "\"$ATTRPATH\".butcher.components.tests"\
-  #   2> >(tee "$OUTDIR/$ATTRPATH-2-build-test.txt" >&2)
-  # (($? == 0)) || { echo "$ATTRPATH: build test failed" >> "$SUMMARY"; return 1; }
-  OUT=$(nix-build -o "$OUTDIR/$ATTRPATH-test-result.txt" nix/all.nix -A "\"$ATTRPATH\".butcher.checks.tests"\
-    2> >(tee "$OUTDIR/$ATTRPATH-build.txt" >&2))
-  (($? == 0)) || { echo "$ATTRPATH: run test failed" >> "$SUMMARY"; return 1; }
-  echo "$ATTRPATH: $(grep examples "$OUTDIR/$ATTRPATH-test-result.txt")" >> "$SUMMARY"
-}
-
-function cabal-check {
-  nix-build --no-out-link nix/all.nix -A "\"$CABAL_CHECK_ATTRPATH\".checks.cabal-check"\
-    2> >(tee "$OUTDIR/cabal-check.txt" >&2)
-  (($? == 0)) || { echo "cabal-check: failed" >> "$SUMMARY"; return 1; }
-  echo "cabal-check: success" >> "$SUMMARY"
-}
-
-find "$OUTDIR" -name "stackage*" -delete
-find "$OUTDIR" -name "hackage*" -delete
-rm "$OUTDIR/cabal-check.txt"
-CLEANEDSOURCE=$(nix-instantiate --eval --read-write-mode nix/all.nix -A "cleanedSource.outPath")
-(($? == 0)) || exit 1
-( eval "cd $CLEANEDSOURCE; find" ) > "$OUTDIR/1-cleanedSource.txt"
-
-build-one "stackage-8.4"
-build-one "stackage-8.6"
-build-one "stackage-8.8"
-
-build-one "hackage-8.4"
-build-one "hackage-8.6"
-build-one "hackage-8.8"
-build-one "hackage-8.10"
-
-cabal-check
-
-cat "$SUMMARY"

nix/via-hackage.nix

@@ -1,58 +0,0 @@
-{ pkgs
-, cleanedSource
-, pkg-def-extras ? []
-, ghc-ver
-, index-state
-, index-sha256 ? null
-, plan-sha256 ? null
-, materialized ? null
-, configureArgs ? null
-}:
-let
-  butcher-plan = pkgs.haskell-nix.importAndFilterProject (pkgs.haskell-nix.callCabalProjectToNix {
-    src = cleanedSource;
-    inherit index-state index-sha256 plan-sha256 materialized configureArgs;
-    # ghc = pkgs.haskell-nix.compiler.${ghc-ver};
-    compiler-nix-name = ghc-ver;
-  });
-in rec {
-  inherit butcher-plan pkgs;
-
-  hsPkgs = 
-    let
-    in let pkg-set = pkgs.haskell-nix.mkCabalProjectPkgSet
-              { plan-pkgs = butcher-plan.pkgs;
-                pkg-def-extras = pkg-def-extras;
-                modules = [ 
-                  { ghc.package = pkgs.haskell-nix.compiler.${ghc-ver}; }
-                ];
-              };
-    in pkg-set.config.hsPkgs;
-
-  inherit (hsPkgs) butcher;
-  inherit (hsPkgs.butcher) checks;
-  shell = hsPkgs.shellFor {
-    # Include only the *local* packages of your project.
-    packages = ps: with ps; [
-      butcher
-    ];
-
-    # Builds a Hoogle documentation index of all dependencies,
-    # and provides a "hoogle" command to search the index.
-    withHoogle = false;
-
-    # You might want some extra tools in the shell (optional).
-
-    # Some common tools can be added with the `tools` argument
-    # tools = { cabal = "3.2.0.0"; };
-    # See overlays/tools.nix for more details
-
-    # Some you may need to get some other way.
-    buildInputs = with pkgs.haskellPackages;
-      [ pkgs.haskell-nix.cabal-install ghcid bash pkgs.nix ];
-
-    # Prevents cabal from choosing alternate plans, so that
-    # *all* dependencies are provided by Nix.
-    exactDeps = true;
-  };
-}

nix/via-stackage.nix

@@ -1,89 +0,0 @@
-{ pkgs
-, cleanedSource
-, stackFile
-, pkg-def-extras ? []
-}:
-let
-  # package-desc = import ./plan.nix;
-  # butcher-plan = {
-  #   inherit resolver;
-  #   extras = hackage:
-  #     { butcher = args: package-desc args // {
-  #       src = pkgs.haskell-nix.cleanSourceHaskell {
-  #         src = pkgs.haskell-nix.haskellLib.cleanGit { src = ./..; name = "butcher"; };
-  #         name = "butcher";
-  #       };
-  #     };
-  #   };
-  # };
-  # this does not work at all, does not use local package (!)
-  # butcher-plan = (pkgs.haskell-nix.importAndFilterProject (
-  #   (pkgs.haskell-nix.callStackToNix {
-  #     name = "butcher-plan";
-  #     src = ./..;
-  #     stackYamlFile = builtins.toFile "stack.yaml" ''
-  #       resolver: ${resolver}
-  #       packages:
-  #         - '.'
-  #       extra-deps: []
-  #       extra-package-dbs: []
-  #     '';
-  #     ignorePackageYaml = true;
-  #   })
-  # ));
-  cleanedSource = pkgs.haskell-nix.cleanSourceHaskell { name = "butcher-"+stackFile; src = ./..; };
-  butcher-nix = pkgs.haskell-nix.callStackToNix {
-    name = "butcher";
-    src = cleanedSource;
-    stackYaml = stackFile;
-  };
-  butcher-plan = pkgs.haskell-nix.importAndFilterProject butcher-nix;
-  # butcher-pkgs = {
-  #   inherit (butcher-plan.pkgs) modules resolver;
-  #   extras = butcher-plan.pkgs.extras ps;
-  # };
-  generatedCache = pkgs.haskell-nix.genStackCache {
-    src = cleanedSource;
-    stackYaml = stackFile;
-  };
-  hsPkgs = (pkgs.haskell-nix.mkStackPkgSet {
-    stack-pkgs = butcher-plan.pkgs;
-    pkg-def-extras = pkg-def-extras;
-    modules = pkgs.lib.singleton (pkgs.haskell-nix.mkCacheModule generatedCache);
-  }).config.hsPkgs;
-in {
-  inherit butcher-plan hsPkgs pkgs;
-  inherit (hsPkgs) butcher;
-  inherit (hsPkgs.butcher) checks;
-  shell = hsPkgs.shellFor {
-    # Include only the *local* packages of your project.
-    packages = ps: with ps; [
-      butcher
-    ];
-
-    # Builds a Hoogle documentation index of all dependencies,
-    # and provides a "hoogle" command to search the index.
-    withHoogle = false;
-
-    # You might want some extra tools in the shell (optional).
-
-    # Some common tools can be added with the `tools` argument
-    # tools = { cabal = "3.2.0.0"; };
-    # See overlays/tools.nix for more details
-
-    # Some you may need to get some other way.
-    buildInputs = with pkgs.haskellPackages;
-      [ cabal-install ghcid bash pkgs.nix ];
-
-    # Prevents cabal from choosing alternate plans, so that
-    # *all* dependencies are provided by Nix.
-    exactDeps = true;
-  };
-}
-# pkgs.haskell-nix.stackProject {
-#   src = pkgs.haskell-nix.haskellLib.cleanGit { src = ./.; name = "butcher"; };
-#   pkg-def-extras = pkg-def-extras;
-#   modules = [
-#     { doHaddock = false; }
-#   ];
-# }

seaaye.nix

@@ -0,0 +1,74 @@
+{ seaaye-spec = 1;
+  haskell-nix-url = https://github.com/input-output-hk/haskell.nix/archive/506208fc9226e207a7beb1b4a26bbd9504a0f680.tar.gz;
+  haskell-nix-nixpkgs = "nixpkgs-2205";
+  package-name = "butcher";
+  targets =
+  {
+    hackage-8-06 = {
+      resolver = "hackage";
+      index-state = "2022-07-01T00:00:00Z";
+      ghc-ver = "ghc865";
+    };
+    hackage-8-08 = {
+      resolver = "hackage";
+      index-state = "2022-07-01T00:00:00Z";
+      ghc-ver = "ghc884";
+    };
+    hackage-8-10 = {
+      resolver = "hackage";
+      index-state = "2022-07-01T00:00:00Z";
+      ghc-ver = "ghc8107";
+    };
+    hackage-9-00 = {
+      resolver = "hackage";
+      index-state = "2022-07-01T00:00:00Z";
+      ghc-ver = "ghc902";
+    };
+    hackage-9-02 = {
+      resolver = "hackage";
+      index-state = "2022-07-01T00:00:00Z";
+      ghc-ver = "ghc925";
+    };
+    stackage-8-06 = {
+      resolver = "stackage";
+      stackFile = "stack-8-6.yaml";
+      ghc-ver = "ghc865";
+    };
+    stackage-8-08 = {
+      resolver = "stackage";
+      stackFile = "stack-8-8.yaml";
+      ghc-ver = "ghc884";
+    };
+    stackage-8-10 = {
+      resolver = "stackage";
+      stackFile = "stack-8-10.yaml";
+      ghc-ver = "ghc8107";
+    };
+    stackage-9-00 = {
+      resolver = "stackage";
+      stackFile = "stack-9-0.yaml";
+      ghc-ver = "ghc902";
+    };
+    stackage-9-02 = {
+      resolver = "stackage";
+      stackFile = "stack-9-2.yaml";
+      ghc-ver = "ghc925";
+    };
+  };
+  module-flags = [
+    # N.B.: There are haskell-nix module options. See the haskell-nix docs
+    #       for details. Also, be careful about typos: In many cases you
+    #       will not get errors but the typo'd flag will just not have any
+    #       effect!
+    # { packages.my-package.flags.my-package-examples-examples = true; }
+    { packages.butcher.flags.butcher-examples = true; }
+  ];
+  default-target = "hackage-8-06";
+  do-check-hackage = "hackage.haskell.org";
+  do-check-changelog = "changelog.md";
+  cabal-project-local = ''
+    package butcher
+      flags: +butcher-examples
+  '';
+  # local-config-path = ./seaaye-local.nix;
+}

shell.nix

@@ -1 +1 @@
-(import ./nix/all.nix {}).default.shell
+(import ./nix/all.nix).default.shell

src-tests/TestMain.hs

@@ -4,13 +4,12 @@ module Main where
 
 #include "prelude.inc"
 
-import Test.Hspec
+import           Test.Hspec
 
 -- import NeatInterpolation
 
-import UI.Butcher.Monadic
+import           UI.Butcher.Monadic
-import UI.Butcher.Monadic.Types
+import           UI.Butcher.Monadic.Types
-import UI.Butcher.Monadic.Interactive
 
 
 
@@ -19,9 +18,9 @@ main = hspec $ tests
 
 tests :: Spec
 tests = do
-  describe "checkTests" checkTests
+  describe "checkTests"      checkTests
   describe "simpleParseTest" simpleParseTest
-  describe "simpleRunTest" simpleRunTest
+  describe "simpleRunTest"   simpleRunTest
 
 
 checkTests :: Spec
@@ -31,105 +30,102 @@ checkTests = do
 
 simpleParseTest :: Spec
 simpleParseTest = do
-  it "failed parse 001" $ runCmdParser Nothing (InputString "foo") testCmd1
+  it "failed parse 001"
-         `shouldSatisfy` Data.Either.isLeft . snd
+    $ let r = runCmdParserSimpleString "foo" testCmd1
-  it "toplevel" $ (testParse testCmd1 "" >>= _cmd_out)
+      in  r `shouldSatisfy` Data.Either.isLeft
-                  `shouldSatisfy` Maybe.isNothing
+  it "toplevel" $ (testParse testCmd1 "") `shouldBe` Nothing
-  it "hasImpl 001" $ (testParse testCmd1 "abc" >>= _cmd_out)
+  it "hasImpl 001" $ (testParse testCmd1 "abc") `shouldSatisfy` Maybe.isJust
-                  `shouldSatisfy` Maybe.isJust
+  it "hasImpl 002" $ (testParse testCmd1 "def") `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
+  it "failed run" $ testRun testCmd1 "" `shouldBeRight` Nothing
   describe "no reordering" $ do
-    it "cmd 1" $ testRun testCmd1 "abc" `shouldBe` Right (Just 100)
+    it "cmd 1" $ testRun testCmd1 "abc" `shouldBeRight` (Just 100)
-    it "cmd 2" $ testRun testCmd1 "def" `shouldBe` Right (Just 200)
+    it "cmd 2" $ testRun testCmd1 "def" `shouldBeRight` (Just 200)
-    it "flag 1" $ testRun testCmd1 "abc -f" `shouldBe` Right (Just 101)
+    it "flag 1" $ testRun testCmd1 "abc -f" `shouldBeRight` (Just 101)
-    it "flag 2" $ testRun testCmd1 "abc --flong" `shouldBe` Right (Just 101)
+    it "flag 2" $ testRun testCmd1 "abc --flong" `shouldBeRight` (Just 101)
-    it "flag 3" $ testRun testCmd1 "abc -f -f" `shouldBe` Right (Just 101)
+    it "flag 3" $ testRun testCmd1 "abc -f -f" `shouldBeRight` (Just 101)
-    it "flag 4" $ testRun testCmd1 "abc -f -g" `shouldBe` Right (Just 103)
+    it "flag 4" $ testRun testCmd1 "abc -f -g" `shouldBeRight` (Just 103)
-    it "flag 5" $ testRun testCmd1 "abc -f -g -f" `shouldSatisfy` Data.Either.isLeft -- no reordering
+    it "flag 5"
-    it "flag 6" $ testRun testCmd1 "abc -g -f" `shouldSatisfy` Data.Either.isLeft -- no reordering
+      $               testRun testCmd1 "abc -f -g -f"
-    it "flag 7" $ testRun testCmd1 "abc -g -g" `shouldBe` Right (Just 102)
+      `shouldSatisfy` Data.Either.isLeft -- no reordering
+    it "flag 6"
+      $               testRun testCmd1 "abc -g -f"
+      `shouldSatisfy` Data.Either.isLeft -- no reordering
+    it "flag 7" $ testRun testCmd1 "abc -g -g" `shouldBeRight` (Just 102)
   describe "with reordering" $ do
-    it "cmd 1" $ testRun testCmd2 "abc" `shouldBe` Right (Just 100)
+    it "cmd 1" $ testRun testCmd2 "abc" `shouldBeRight` (Just 100)
-    it "cmd 2" $ testRun testCmd2 "def" `shouldBe` Right (Just 200)
+    it "cmd 2" $ testRun testCmd2 "def" `shouldBeRight` (Just 200)
-    it "flag 1" $ testRun testCmd2 "abc -f" `shouldBe` Right (Just 101)
+    it "flag 1" $ testRun testCmd2 "abc -f" `shouldBeRight` (Just 101)
-    it "flag 2" $ testRun testCmd2 "abc --flong" `shouldBe` Right (Just 101)
+    it "flag 2" $ testRun testCmd2 "abc --flong" `shouldBeRight` (Just 101)
-    it "flag 3" $ testRun testCmd2 "abc -f -f" `shouldBe` Right (Just 101)
+    it "flag 3" $ testRun testCmd2 "abc -f -f" `shouldBeRight` (Just 101)
-    it "flag 4" $ testRun testCmd2 "abc -f -g" `shouldBe` Right (Just 103)
+    it "flag 4" $ testRun testCmd2 "abc -f -g" `shouldBeRight` (Just 103)
-    it "flag 5" $ testRun testCmd2 "abc -f -g -f" `shouldBe` Right (Just 103)
+    it "flag 5" $ testRun testCmd2 "abc -f -g -f" `shouldBeRight` (Just 103)
-    it "flag 6" $ testRun testCmd2 "abc -g -f" `shouldBe` Right (Just 103)
+    it "flag 6" $ testRun testCmd2 "abc -g -f" `shouldBeRight` (Just 103)
-    it "flag 7" $ testRun testCmd2 "abc -g -g" `shouldBe` Right (Just 102)
+    it "flag 7" $ testRun testCmd2 "abc -g -g" `shouldBeRight` (Just 102)
   describe "with action" $ do
-    it "flag 1" $ testRunA testCmd3 "abc" `shouldBe` Right 0
+    it "flag 1" $ testRunA testCmd3 "abc" `shouldBeRight` 0
-    it "flag 2" $ testRunA testCmd3 "abc -f" `shouldBe` Right 1
+    it "flag 2" $ testRunA testCmd3 "abc -f" `shouldBeRight` 1
-    it "flag 3" $ testRunA testCmd3 "abc -g" `shouldBe` Right 2
+    it "flag 3" $ testRunA testCmd3 "abc -g" `shouldBeRight` 2
-    it "flag 4" $ testRunA testCmd3 "abc -f -g" `shouldBe` Right 3
+    it "flag 4" $ testRunA testCmd3 "abc -f -g" `shouldBeRight` 3
-    it "flag 5" $ testRunA testCmd3 "abc -g -f" `shouldBe` Right 3
+    it "flag 5" $ testRunA testCmd3 "abc -g -f" `shouldBeRight` 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 1" $ testRun testCmd5 "abc" `shouldBeRight` (Just 10)
-    it "flag 2" $ testRun testCmd5 "abc -f 2" `shouldBe` Right (Just 2)
+    it "flag 2" $ testRun testCmd5 "abc -f 2" `shouldBeRight` (Just 2)
-    it "flag 3" $ testRun testCmd5 "abc --flag 3" `shouldBe` Right (Just 3)
+    it "flag 3" $ testRun testCmd5 "abc --flag 3" `shouldBeRight` (Just 3)
-    it "flag 4" $ testRun testCmd5 "abc -f=4" `shouldBe` Right (Just 4)
+    it "flag 4" $ testRun testCmd5 "abc -f=4" `shouldBeRight` (Just 4)
-    it "flag 5" $ testRun testCmd5 "abc --flag=5" `shouldBe` Right (Just 5)
+    it "flag 5" $ testRun testCmd5 "abc --flag=5" `shouldBeRight` (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 7"
-    it "flag 6" $ testRun testCmd5 "abc --f 0" `shouldSatisfy` Data.Either.isLeft
+      $               testRun testCmd5 "abc -flag 0"
+      `shouldSatisfy` Data.Either.isLeft
+    it "flag 8"
+      $               testRun testCmd5 "abc --f 0"
+      `shouldSatisfy` Data.Either.isLeft
   describe "addParamStrings" $ do
-    it "case 1" $ testRun' testCmd6 "" `shouldBe` Right (Just ([], 0))
+    it "case 1" $ testRun' testCmd6 "" `shouldBeRight` (Just ([], 0))
-    it "case 2" $ testRun' testCmd6 "-f" `shouldBe` Right (Just ([], 1))
+    it "case 2" $ testRun' testCmd6 "-f" `shouldBeRight` (Just ([], 1))
-    it "case 3" $ testRun' testCmd6 "abc" `shouldBe` Right (Just (["abc"], 0))
+    it "case 3" $ testRun' testCmd6 "abc" `shouldBeRight` (Just (["abc"], 0))
-    it "case 4" $ testRun' testCmd6 "abc def" `shouldBe` Right (Just (["abc", "def"], 0))
+    it "case 4"
-    it "case 5" $ testRun' testCmd6 "-g abc def" `shouldBe` Right (Just (["abc", "def"], 2))
+      $               testRun' testCmd6 "abc def"
-    it "case 6" $ testRun' testCmd6 "-f -g def" `shouldBe` Right (Just (["def"], 3))
+      `shouldBeRight` (Just (["abc", "def"], 0))
+    it "case 5"
+      $               testRun' testCmd6 "-g abc def"
+      `shouldBeRight` (Just (["abc", "def"], 2))
+    it "case 6"
+      $               testRun' testCmd6 "-f -g def"
+      `shouldBeRight` (Just (["def"], 3))
   describe "addParamNoFlagStrings" $ do
-    it "case 1" $ testRun' testCmd7 "" `shouldBe` Right (Just ([], 0))
+    it "case 1" $ testRun' testCmd7 "" `shouldBeRight` (Just ([], 0))
-    it "case 2" $ testRun' testCmd7 "-f" `shouldBe` Right (Just ([], 1))
+    it "case 2" $ testRun' testCmd7 "-f" `shouldBeRight` (Just ([], 1))
-    it "case 3" $ testRun' testCmd7 "abc" `shouldBe` Right (Just (["abc"], 0))
+    it "case 3" $ testRun' testCmd7 "abc" `shouldBeRight` (Just (["abc"], 0))
-    it "case 4" $ testRun' testCmd7 "abc -f" `shouldBe` Right (Just (["abc"], 1))
+    it "case 4" $ testRun' testCmd7 "abc -f" `shouldBeRight` (Just (["abc"], 1))
-    it "case 5" $ testRun' testCmd7 "-g abc -f" `shouldBe` Right (Just (["abc"], 3))
+    it "case 5"
-    it "case 6" $ testRun' testCmd7 "abc -g def" `shouldBe` Right (Just (["abc", "def"], 2))
+      $               testRun' testCmd7 "-g abc -f"
+      `shouldBeRight` (Just (["abc"], 3))
+    it "case 6"
+      $               testRun' testCmd7 "abc -g def"
+      `shouldBeRight` (Just (["abc", "def"], 2))
   describe "defaultParam" $ do
     it "case  1" $ testRun testCmdParam "" `shouldSatisfy` Data.Either.isLeft
     it "case  2" $ testRun testCmdParam "n" `shouldSatisfy` Data.Either.isLeft
     it "case  3" $ testRun testCmdParam "y" `shouldSatisfy` Data.Either.isLeft
-    it "case  4" $ testRun testCmdParam "False n" `shouldBe` Right (Just 110)
+    it "case  4" $ testRun testCmdParam "False n" `shouldBeRight` (Just 110)
-    it "case  5" $ testRun testCmdParam "False y" `shouldBe` Right (Just 310)
+    it "case  5" $ testRun testCmdParam "False y" `shouldBeRight` (Just 310)
-    it "case  6" $ testRun testCmdParam "True n" `shouldBe` Right (Just 1110)
+    it "case  6" $ testRun testCmdParam "True n" `shouldBeRight` (Just 1110)
-    it "case  7" $ testRun testCmdParam "True y" `shouldBe` Right (Just 1310)
+    it "case  7" $ testRun testCmdParam "True y" `shouldBeRight` (Just 1310)
-    it "case  8" $ testRun testCmdParam "1 False y" `shouldBe` Right (Just 301)
+    it "case  8" $ testRun testCmdParam "1 False y" `shouldBeRight` (Just 301)
-    it "case  9" $ testRun testCmdParam "1 False y def" `shouldBe` Right (Just 201)
+    it "case  9"
-    it "case 10" $ testRun testCmdParam "1 False 2 y def" `shouldBe` Right (Just 203)
+      $               testRun testCmdParam "1 False y def"
-    it "case 11" $ testRun testCmdParam "1 True 2 y def" `shouldBe` Right (Just 1203)
+      `shouldBeRight` (Just 201)
+    it "case 10"
+      $               testRun testCmdParam "1 False 2 y def"
+      `shouldBeRight` (Just 203)
+    it "case 11"
+      $               testRun testCmdParam "1 True 2 y def"
+      `shouldBeRight` (Just 1203)
   describe "completions" $ do
     it "case  1" $ testCompletion completionTestCmd "" `shouldBe` ""
     it "case  2" $ testCompletion completionTestCmd "a" `shouldBe` "bc"
@@ -177,8 +173,8 @@ testCmd3 :: CmdParser (StateS.State Int) () ()
 testCmd3 = do
   addCmd "abc" $ do
     reorderStart
-    addSimpleFlagA "f" ["flong"] mempty (StateS.modify (+1))
+    addSimpleBoolFlagA "f" ["flong"] mempty (StateS.modify (+ 1))
-    addSimpleFlagA "g" ["glong"] mempty (StateS.modify (+2))
+    addSimpleBoolFlagA "g" ["glong"] mempty (StateS.modify (+ 2))
     reorderStop
     addCmdImpl ()
   addCmd "def" $ do
@@ -202,13 +198,13 @@ testCmd4 = do
 testCmd5 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
 testCmd5 = do
   addCmd "abc" $ do
-    x <- addFlagReadParam "f" ["flag"] "flag" (flagDefault (10::Int))
+    x <- addFlagReadParam "f" ["flag"] "flag" (flagDefault (10 :: Int))
     addCmdImpl $ WriterS.tell (Sum x)
 
 testCmd6 :: CmdParser Identity (WriterS.Writer (Sum Int) [String]) ()
 testCmd6 = do
-  f <- addSimpleBoolFlag "f" ["flong"] mempty
+  f    <- addSimpleBoolFlag "f" ["flong"] mempty
-  g <- addSimpleBoolFlag "g" ["glong"] mempty
+  g    <- addSimpleBoolFlag "g" ["glong"] mempty
   args <- addParamStrings "ARGS" mempty
   addCmdImpl $ do
     when f $ WriterS.tell 1
@@ -218,8 +214,8 @@ testCmd6 = do
 testCmd7 :: CmdParser Identity (WriterS.Writer (Sum Int) [String]) ()
 testCmd7 = do
   reorderStart
-  f <- addSimpleBoolFlag "f" ["flong"] mempty
+  f    <- addSimpleBoolFlag "f" ["flong"] mempty
-  g <- addSimpleBoolFlag "g" ["glong"] mempty
+  g    <- addSimpleBoolFlag "g" ["glong"] mempty
   args <- addParamNoFlagStrings "ARGS" mempty
   reorderStop
   addCmdImpl $ do
@@ -230,16 +226,16 @@ testCmd7 = do
 testCmdParam :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
 testCmdParam = do
   p :: Int <- addParamRead "INT" (paramDefault 10)
-  b <- addParamRead "MANDR" mempty
+  b        <- addParamRead "MANDR" mempty
-  r <- addParamReadOpt "MAY1" (paramDefault 20)
+  r        <- addParamReadOpt "MAY1" (paramDefault 20)
-  s <- addParamString "MAND" mempty
+  s        <- addParamString "MAND" mempty
-  q <- addParamString "STR" (paramDefault "abc")
+  q        <- addParamString "STR" (paramDefault "abc")
   addCmdImpl $ do
     WriterS.tell (Sum p)
-    when (q=="abc") $ WriterS.tell 100
+    when (q == "abc") $ WriterS.tell 100
     r `forM_` (WriterS.tell . Sum)
     when b $ WriterS.tell $ Sum 1000
-    when (s=="y") $ WriterS.tell 200
+    when (s == "y") $ WriterS.tell 200
     pure ()
 
 completionTestCmd :: CmdParser Identity () ()
@@ -255,32 +251,46 @@ completionTestCmd = do
       addCmdImpl ()
 
 testCompletion :: CmdParser Identity a () -> String -> String
-testCompletion p inp = case runCmdParserExt Nothing (InputString inp) p of
+testCompletion p inp =
-  (cDesc, InputString cRest, _) -> simpleCompletion inp cDesc cRest
+  _ppi_inputSugg $ runCmdParser Nothing (InputString inp) p
-  _ -> error "wut"
 
 
-testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out)
+testParse :: CmdParser Identity out () -> String -> Maybe out
-testParse cmd s = either (const Nothing) Just
+testParse cmd s = case runCmdParserSimpleString s cmd of
-                $ snd
+  Left{}  -> Nothing
-                $ runCmdParser Nothing (InputString s) cmd
+  Right o -> Just o
 
-testRun :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () -> String -> Either ParsingError (Maybe Int)
+testRun
-testRun cmd s = fmap (fmap (getSum . WriterS.execWriter) . _cmd_out)
+  :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
-              $ snd
+  -> String
-              $ runCmdParser Nothing (InputString s) cmd
+  -> Either ParsingError (Maybe Int)
-
+testRun cmd s =
-testRun' :: CmdParser Identity (WriterS.Writer (Sum Int) a) () -> String -> Either ParsingError (Maybe (a, Int))
+  fmap (fmap (getSum . WriterS.execWriter)) $ _ppi_value $ runCmdParser
-testRun' cmd s =
-  fmap (fmap (fmap getSum . WriterS.runWriter) . _cmd_out) $ snd $ runCmdParser
     Nothing
     (InputString s)
     cmd
 
-testRunA :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError Int
+testRun'
-testRunA cmd str = (\((_, e), s) -> e $> s)
+  :: CmdParser Identity (WriterS.Writer (Sum Int) a) ()
-                 $ flip StateS.runState (0::Int)
+  -> String
-                 $ runCmdParserA Nothing (InputString str) cmd
+  -> Either ParsingError (Maybe (a, Int))
+testRun' cmd s =
+  fmap (fmap (fmap getSum . WriterS.runWriter)) $ _ppi_value $ runCmdParser
+    Nothing
+    (InputString s)
+    cmd
 
-getDoc :: String -> CmdParser Identity out () -> CommandDesc ()
+testRunA
-getDoc s = fst . runCmdParser (Just "test") (InputString s)
+  :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError Int
+testRunA cmd str = case StateS.runState act (0 :: Int) of
+  (info, s) -> _ppi_value info $> s
+  where act = runCmdParserA Nothing (InputString str) cmd
+
+getDoc :: String -> CmdParser Identity out () -> CommandDesc
+getDoc s p = _ppi_mainDesc $ runCmdParser (Just "test") (InputString s) p
+
+
+shouldBeRight :: (Show l, Show r, Eq r) => Either l r -> r -> Expectation
+shouldBeRight x y = x `shouldSatisfy` \case
+  Left{}  -> False
+  Right r -> r == y

src/UI/Butcher/Applicative.hs

@@ -0,0 +1,210 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
+
+
+module UI.Butcher.Applicative
+  ( -- * Types
+    Input(..)
+  , CmdParser
+  , ParsingError(..)
+  , PartialParseInfo(..)
+  , CommandDesc
+  , PartDesc(..)
+  , Visibility(..)
+    -- * Run CmdParsers
+  , runCmdParserSimpleString
+  , runCmdParserSimpleArgv
+  , runCmdParser
+  , runCmdParserFromDesc
+    -- * Building CmdParsers
+  , module UI.Butcher.Applicative.Command
+  , module UI.Butcher.Applicative.Param
+  , module UI.Butcher.Applicative.Flag
+    -- * PrettyPrinting CommandDescs (usage/help)
+  , module UI.Butcher.Applicative.Pretty
+    -- * Wrapper around System.Environment.getArgs
+  , module UI.Butcher.Applicative.IO
+    -- * Advanced usage
+  , emptyCommandDesc
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import qualified Barbies
+import qualified Barbies.Bare                  as Barbies
+import           Data.Kind
+import           Data.List.Extra                ( firstJust )
+import           Data.Semigroup                 ( Last(..) )
+import           Data.Semigroup.Generic
+import           GHC.Generics                   ( Generic )
+
+import           UI.Butcher.Applicative.Command
+import           UI.Butcher.Applicative.Flag
+import           UI.Butcher.Applicative.IO
+import           UI.Butcher.Applicative.Param
+import           UI.Butcher.Applicative.Pretty
+import           UI.Butcher.Internal.Applicative
+import           UI.Butcher.Internal.ApplicativeTypes
+import           UI.Butcher.Internal.CommonTypes
+import           UI.Butcher.Internal.Interactive
+
+
+
+-- runCmdParser
+--   :: forall out
+--    . Input
+--   -> CmdParser out out
+--   -> (CommandDesc, Either ParsingError out)
+-- runCmdParser initialInput initialParser =
+--   let topDesc = toCmdDesc initialParser
+--   in  (topDesc, runCmdParserCoreFromDesc initialInput topDesc initialParser)
+
+-- | Run a parser on the given input, and return a struct with all kinds of
+-- output. The input does not need to be complete, i.e. if you have a command
+-- "clean" then on input "cle" you will not get a successful parse
+-- (@_ppi_value@ will be @Left{}@) but other fields will be useful nonetheless.
+-- For example @_ppi_inputSugg@ might be "an". Depends on what other commands
+-- exist, of course.
+--
+-- On successful parses, @_ppi_value@ will be @Right{}@ but the other fields
+-- still might be useful as well - for example to display the description of
+-- the command about to be executed (once user presses enter).
+--
+-- Note that with haskell's laziness there is no performance cost to
+-- using this function - the fields you are not interested in will not be
+-- computed.
+runCmdParser :: forall out . Input -> CmdParser out out -> PartialParseInfo out
+runCmdParser input parser =
+  let topDesc = toCmdDesc parser in runCmdParserFromDesc topDesc input parser
+
+-- | This function is the part of the @runCmdParser@ functionality that
+-- depends on the input. For interactive use this avoids recomputing the
+-- commandDesc.
+--
+-- For usage see the source of 'runCmdParser'.
+runCmdParserFromDesc
+  :: forall out
+   . CommandDesc
+  -> Input
+  -> CmdParser out out
+  -> PartialParseInfo out
+runCmdParserFromDesc topDesc input parser =
+  let (localDesc, remainingInput, result) =
+        runCmdParserCoreFromDesc input topDesc parser
+  in  combinedCompletion input
+                         topDesc
+                         localDesc
+                         remainingInput
+                         (fmap Just result)
+
+
+-- | Wrapper around 'runCmdParser' for very simple usage: Accept a @String@
+-- input and return only the output from the parser, or a plain error string
+-- on failure.
+runCmdParserSimpleString :: String -> CmdParser out out -> Either String out
+runCmdParserSimpleString s p =
+  let info = runCmdParser (InputString s) p
+  in
+    case _ppi_value info of
+      Left  e           -> Left $ parsingErrorString e
+      Right (Just desc) -> Right desc
+      Right Nothing ->
+        error "Applicative parser should not return Right Nothing"
+
+-- | Wrapper around 'runCmdParser' for very simple usage: Accept a list of
+-- @String@s (args)and return only the output from the parser, or a plain
+-- error string on failure.
+runCmdParserSimpleArgv :: [String] -> CmdParser out out -> Either String out
+runCmdParserSimpleArgv s p =
+  let info = runCmdParser (InputArgs s) p
+  in
+    case _ppi_value info of
+      Left  e           -> Left $ parsingErrorString e
+      Right (Just desc) -> Right desc
+      Right Nothing ->
+        error "Applicative parser should not return Right Nothing"
+
+-- | Like 'runCmdParser', but with one additional twist: You get access
+-- to a knot-tied complete CommandDesc for this full command.
+-- runCmdParserWithHelpDesc
+--   :: Input -- ^ input to be processed
+--   -> (CommandDesc -> CmdParser out out) -- ^ parser to use
+--   -> (CommandDesc, Either ParsingError out)
+-- runCmdParserWithHelpDesc input cmdF =
+--   -- knot-tying at its finest..
+--   let (desc, parser) = (toCmdDesc parser, cmdF desc)
+--   in  (desc, runCmdParserCoreFromDesc input desc parser)
+
+
+data MyFlagStruct (c :: Type) (f :: Type -> Type) = MyFlagStruct
+  { _userName :: Barbies.Wear c f String
+  , _shout    :: Barbies.WearTwo c f Last Bool
+  , _dryrun   :: Barbies.WearTwo c f Last Bool
+  }
+  deriving Generic
+
+instance Barbies.FunctorB (MyFlagStruct Barbies.Covered)
+instance Barbies.BareB MyFlagStruct
+instance Barbies.TraversableB (MyFlagStruct Barbies.Covered)
+instance Semigroup (MyFlagStruct Barbies.Covered Maybe) where
+  (<>) = gmappend
+
+_test :: IO ()
+_test = do
+  let parser = do
+        addCmd "help" $ pure $ do
+          putStrLn "help: print helpful help"
+        arg :: Int <- addParamRead "SOMEARG" mempty
+        -- addCmd "dryrun-arg" $ pure $ do
+        --   putStrLn $ "arg = " ++ show arg
+        reorderStart
+        flags <- traverseBarbie MyFlagStruct
+          { _userName = addFlagStringParam "u"
+                                           ["user"]
+                                           "USERNAME"
+                                           (flagDefault "user")
+          , _shout    = Last <$> addSimpleBoolFlag "s" ["shout"] mempty
+          , _dryrun   = Last <$> addSimpleBoolFlag "d" ["dryrun"] mempty
+          }
+        reorderStop
+        pure $ do
+          print arg
+          let shoutOrNot = if _shout flags then map Char.toUpper else id
+          if (_dryrun flags)
+            then do
+              putStrLn "would print greeting"
+            else do
+              putStrLn $ shoutOrNot $ "hello, " ++ _userName flags
+
+  let info = runCmdParser (InputArgs ["42", "--shout", "-u=lsp"]) parser
+        -- runCmdParser (InputArgs ["help"]) parser
+  let desc = _ppi_mainDesc info
+  print desc
+  print $ ppHelpDepthOne desc
+  case _ppi_value info of
+    Left err -> do
+      putStrLn "parsing error"
+      print err
+    Right Nothing  -> putStrLn "no implementation"
+    Right (Just f) -> f
+
+
+-- butcherMain :: ButcherA (IO ()) -> IO ()
+-- 
+-- type ButcherA out = Writer [ButcherCmd out] ()
+-- type ButcherCmd = Ap ButcherCmdF out
+-- data ButcherCmdF a
+--   = ButcherCmdHelp String (() -> a)
+--   | ButcherCmdParamString (String -> a)
+

src/UI/Butcher/Applicative/Command.hs

@@ -0,0 +1,28 @@
+module UI.Butcher.Applicative.Command
+  ( addCmd
+  , addCmdHidden
+  , peekCmdDesc
+  , reorderStart
+  , reorderStop
+  , withReorder
+  , traverseBarbie
+    -- * Low-level part functions
+  , addCmdPart
+  , addCmdPartMany
+  , addCmdPartInp
+  , addCmdPartManyInp
+  )
+where
+
+#include "prelude.inc"
+
+import           UI.Butcher.Internal.ApplicativeTypes
+import           UI.Butcher.Internal.Applicative
+
+
+
+-- | Safe wrapper around 'reorderStart'/'reorderStop' for cases where reducing
+-- to a single binding is possible/preferable.
+withReorder :: CmdParser out a -> CmdParser out a
+withReorder x = reorderStart *> x <* reorderStop
+

src/UI/Butcher/Applicative/Flag.hs

@@ -0,0 +1,298 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+
+module UI.Butcher.Applicative.Flag
+  ( Flag(..)
+  , flagDefault
+  , flagHelp
+  , flagHelpStr
+  , addSimpleBoolFlag
+  , addSimpleCountFlag
+  , addFlagReadParam
+  , addFlagReadParams
+  , addFlagStringParam
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import           Control.Applicative.Free
+import           Control.Monad.ST
+import           Data.Kind
+import           Data.List.Extra                ( firstJust )
+import           Data.STRef
+import qualified Text.PrettyPrint              as PP
+
+import           UI.Butcher.Applicative.Param
+import           UI.Butcher.Internal.ApplicativeTypes
+import           UI.Butcher.Internal.Applicative
+import           UI.Butcher.Internal.BasicStringParser
+import           UI.Butcher.Internal.Pretty
+
+import           Debug.Trace
+
+
+
+-- | flag-description monoid. You probably won't need to use the constructor;
+-- mzero or any (<>) of flag(Help|Default) works well.
+data Flag a = Flag
+  { _flag_help       :: Maybe PP.Doc
+  , _flag_default    :: Maybe a
+  , _flag_visibility :: Visibility
+  }
+
+
+appendFlag :: Flag p -> Flag p -> Flag p
+appendFlag (Flag a1 b1 c1) (Flag a2 b2 c2) = Flag (a1 <|> a2)
+                                                  (b1 <|> b2)
+                                                  (appVis c1 c2)
+ where
+  appVis Visible Visible = Visible
+  appVis _       _       = Hidden
+
+instance Semigroup (Flag p) where
+  (<>) = appendFlag
+
+instance Monoid (Flag a) where
+  mempty  = Flag Nothing Nothing Visible
+  mappend = (<>)
+
+-- | 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.fsep $ fmap PP.text $ List.words s }
+
+-- | Create a 'Flag' with just a default value.
+flagDefault :: p -> Flag p
+flagDefault d = mempty { _flag_default = Just d }
+
+wrapHidden :: Flag p -> PartDesc -> PartDesc
+wrapHidden f = case _flag_visibility f of
+  Visible -> id
+  Hidden  -> PartHidden
+
+
+-- | A no-parameter flag where non-occurence means False, occurence means True.
+addSimpleBoolFlag :: String -> [String] -> Flag Void -> CmdParser out Bool
+addSimpleBoolFlag shorts longs opts = fmap (not . null)
+  $ addCmdPartMany ManyUpperBound1 (wrapHidden opts desc) parseF
+ where
+  allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs
+  desc :: PartDesc
+  desc =
+    (maybe id PartWithHelp $ _flag_help opts)
+      $   PartAlts
+      $   PartLiteral
+      <$> allStrs
+  parseF :: String -> EpsilonFlag -> Maybe ((), String)
+  parseF (dropWhile Char.isSpace -> 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
+  :: String -- ^ short flag chars, i.e. "v" for -v
+  -> [String] -- ^ list of long names, i.e. ["verbose"]
+  -> Flag Void -- ^ properties
+  -> CmdParser out Int
+addSimpleCountFlag shorts longs flag = fmap length
+  $ addCmdPartMany ManyUpperBoundN (wrapHidden flag 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 -> EpsilonFlag -> Maybe ((), String)
+  parseF (dropWhile Char.isSpace -> 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 out p
+   . (Typeable p, 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 out p
+addFlagReadParam shorts longs name opts = addCmdPartInp
+  (wrapHidden opts desc)
+  parseF
+ where
+  allStrs =
+    [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
+  desc =
+    (maybe id PartWithHelp $ _flag_help opts)
+      $ maybe id (PartDefault . show) (_flag_default opts)
+      $ PartSeq [desc1, desc2]
+  desc1 :: PartDesc
+  desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
+  desc2 = PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (p, Input)
+  parseF inp e = case inp of
+    InputString str -> case parseResult of
+      Just (x, rest) -> Just (x, InputString rest)
+      Nothing        -> viaDef
+     where
+      parseResult = runInpParseString (dropWhile Char.isSpace 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) -> Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest)
+      Just ((), remainingStr) ->
+        Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR)
+      Nothing -> viaDef
+     where
+      parser :: InpParseString ()
+      parser = do
+        Data.Foldable.msum $ allStrs <&> \case
+          Left  s -> pExpect s *> pOption (pExpect "=")
+          Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
+    InputArgs _ -> viaDef
+    where viaDef = [ (x, inp) | x <- _flag_default opts, e == AllowEpsilon ]
+
+
+-- | 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 p out
+   . (Typeable p, 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 out [p]
+addFlagReadParams shorts longs name flag = addCmdPartManyInp
+  ManyUpperBoundN
+  (wrapHidden flag desc)
+  parseF
+ 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 -> EpsilonFlag -> Maybe (p, Input)
+  parseF inp _ = case inp of
+    InputString str -> fmap (second InputString) $ parseResult
+     where
+      parseResult = runInpParseString (dropWhile Char.isSpace 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) ->
+          (Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest)) <|> mdef
+        where mdef = _flag_default flag <&> \p -> (p, InputArgs argR)
+      Just ((), remainingStr) ->
+        Text.Read.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 out
+   . String -- ^ short flag chars, i.e. "v" for -v
+  -> [String] -- ^ list of long names, i.e. ["verbose"]
+  -> String -- ^ param name
+  -> Flag String -- ^ properties
+  -> CmdParser out String
+addFlagStringParam shorts longs name opts = addCmdPartInp
+  (wrapHidden opts desc)
+  parseF
+ where
+  allStrs =
+    [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
+  desc = (maybe id PartWithHelp $ _flag_help opts) $ PartSeq [desc1, desc2]
+  desc1 :: PartDesc
+  desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
+  desc2 = PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (String, Input)
+  parseF inp e = case inp of
+    InputString str -> case parseResult of
+      Just (x, rest) -> Just (x, InputString rest)
+      Nothing        -> viaDef
+     where
+      parseResult = runInpParseString (dropWhile Char.isSpace 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                 -> viaDef
+     where
+      parser :: InpParseString ()
+      parser = do
+        Data.Foldable.msum $ allStrs <&> \case
+          Left  s -> pExpect s *> pOption (pExpect "=")
+          Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
+    InputArgs _ -> viaDef
+    where viaDef = [ (x, inp) | x <- _flag_default opts, e == AllowEpsilon ]

src/UI/Butcher/Applicative/IO.hs

@@ -0,0 +1,69 @@
+-- | Turn your CmdParser into an IO () to be used as your program @main@.
+module UI.Butcher.Applicative.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.Internal.Applicative
+import           UI.Butcher.Internal.ApplicativeTypes
+import           UI.Butcher.Monadic.Param
+import           UI.Butcher.Monadic.Pretty
+
+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 (IO ()) (IO ()) -> IO ()
+mainFromCmdParser cmd = do
+  progName <- System.Environment.getProgName
+  args     <- System.Environment.getArgs
+  let topDesc = toCmdDesc cmd
+  case runCmdParserCoreFromDesc (InputArgs args) topDesc cmd of
+    (desc, _remaining, Left err) -> do
+      putStrErrLn
+        $  progName
+        ++ ": error parsing arguments: "
+        ++ case _pe_messages err of
+             []      -> ""
+             (m : _) -> m
+      putStrErrLn $ case _pe_remaining err 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, _remaining, Right out) -> out
+
+putStrErrLn :: String -> IO ()
+putStrErrLn s = hPutStrLn stderr s
+
+printErr :: Show a => a -> IO ()
+printErr = putStrErrLn . show

src/UI/Butcher/Applicative/Param.hs

@@ -0,0 +1,300 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+
+module UI.Butcher.Applicative.Param
+  ( Param(..)
+  , paramHelp
+  , paramHelpStr
+  , paramDefault
+  , paramSuggestions
+  , paramFile
+  , paramDirectory
+  , addParamRead
+  , addParamReadOpt
+  , addParamString
+  , addParamStringOpt
+  , addParamStrings
+  , addParamNoFlagString
+  , addParamNoFlagStringOpt
+  , addParamNoFlagStrings
+  , addParamRestOfInput
+  , addParamRestOfInputRaw
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import           Control.Applicative.Free
+import           Control.Monad.ST
+import           Data.Kind
+import           Data.List.Extra                ( firstJust )
+import           Data.STRef
+import qualified Text.PrettyPrint              as PP
+
+import           UI.Butcher.Internal.ApplicativeTypes
+import           UI.Butcher.Internal.Applicative
+import           UI.Butcher.Internal.Pretty
+
+
+-- | 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 [CompletionItem]
+  }
+
+appendParam :: Param p -> Param p -> Param p
+appendParam (Param a1 b1 c1) (Param a2 b2 c2) =
+  Param (a1 <|> a2) (b1 <> b2) (c1 <> c2)
+
+instance Semigroup (Param p) where
+  (<>) = appendParam
+
+instance Monoid (Param p) where
+  mempty  = Param Nothing Nothing Nothing
+  mappend = (<>)
+
+-- | 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 :: [String] -> Param p
+paramSuggestions ss =
+  mempty { _param_suggestions = Just $ CompletionString <$> ss }
+
+-- | Create a 'Param' that is a file path.
+paramFile :: Param p
+paramFile = mempty { _param_suggestions = Just [CompletionFile] }
+
+-- | Create a 'Param' that is a directory path.
+paramDirectory :: Param p
+paramDirectory = mempty { _param_suggestions = Just [CompletionDirectory] }
+
+
+-- | Add a parameter to the 'CmdParser' by making use of a 'Text.Read.Read'
+-- instance. Take care not to use this to return Strings unless you really
+-- want that, because it will require the quotation marks and escaping as
+-- is normal for the Show/Read instances for String.
+addParamRead
+  :: forall out a
+   . (Typeable a, Show a, Text.Read.Read a)
+  => String -- ^ paramater name, for use in usage/help texts
+  -> Param a -- ^ properties
+  -> CmdParser out a
+addParamRead name par = addCmdPart desc parseF
+ where
+  desc :: PartDesc
+  desc =
+    addSuggestion (_param_suggestions par)
+      $ (maybe id PartWithHelp $ _param_help par)
+      $ (maybe id (PartDefault . show) $ _param_default par)
+      $ PartVariable name
+  parseF :: String -> EpsilonFlag -> Maybe (a, String)
+  parseF s e = case (Text.Read.reads s, e) of
+    (((x, ' ' : r) : _), _           ) -> Just (x, dropWhile Char.isSpace r)
+    (((x, []     ) : _), _           ) -> Just (x, [])
+    (_                 , AllowEpsilon) -> _param_default par <&> \x -> (x, s)
+    (_                 , DenyEpsilon ) -> Nothing
+
+addSuggestion :: Maybe [CompletionItem] -> PartDesc -> PartDesc
+addSuggestion Nothing     = id
+addSuggestion (Just sugs) = PartSuggestion sugs
+
+-- | Like addReadParam, but optional. I.e. if reading fails, returns Nothing.
+addParamReadOpt
+  :: forall out a
+   . (Typeable a, Text.Read.Read a)
+  => String -- ^ paramater name, for use in usage/help texts
+  -> Param a -- ^ properties
+  -> CmdParser out (Maybe a)
+addParamReadOpt name par = addCmdPart desc parseF
+ where
+  desc :: PartDesc
+  desc =
+    addSuggestion (_param_suggestions par)
+      $ PartOptional
+      $ (maybe id PartWithHelp $ _param_help par)
+      $ PartVariable name
+  parseF :: String -> EpsilonFlag -> Maybe (Maybe a, String)
+  parseF s e = case Text.Read.reads s of
+    ((x, ' ' : r) : _) -> Just (Just x, dropWhile Char.isSpace r)
+    ((x, []     ) : _) -> Just (Just x, [])
+    _                  -> [ (Nothing, s) | e == AllowEpsilon ]
+
+
+-- | Add a parameter that matches any string of non-space characters if
+-- input==String, or one full argument if input==[String]. See the 'Input' doc
+-- for this distinction.
+addParamString :: String -> Param String -> CmdParser out String
+addParamString name par = addCmdPartInp desc parseF
+ where
+  desc :: PartDesc
+  desc =
+    addSuggestion (_param_suggestions par)
+      $ (maybe id PartWithHelp $ _param_help par)
+      $ PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (String, Input)
+  parseF (InputString str) e =
+    case break Char.isSpace $ dropWhile Char.isSpace str of
+      ("", rest) ->
+        [ (x, InputString rest) | x <- _param_default par, e == AllowEpsilon ]
+      (x, rest) -> Just (x, InputString rest)
+  parseF (InputArgs args) e = case args of
+    (s1 : sR) -> Just (s1, InputArgs sR)
+    [] -> [ (x, InputArgs args) | x <- _param_default par, e == AllowEpsilon ]
+
+-- | Like 'addParamString', but optional, I.e. succeeding with Nothing if
+-- there is no remaining input.
+addParamStringOpt :: String -> Param Void -> CmdParser out (Maybe String)
+addParamStringOpt name par = addCmdPartInp desc parseF
+ where
+  desc :: PartDesc
+  desc =
+    addSuggestion (_param_suggestions par)
+      $ PartOptional
+      $ (maybe id PartWithHelp $ _param_help par)
+      $ PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (Maybe String, Input)
+  parseF (InputString str) e =
+    case break Char.isSpace $ dropWhile Char.isSpace str of
+      ("", rest) -> [ (Nothing, InputString rest) | e == AllowEpsilon ]
+      (x , rest) -> Just (Just x, InputString rest)
+  parseF (InputArgs args) e = case args of
+    (s1 : sR) -> Just (Just s1, InputArgs sR)
+    []        -> [ (Nothing, InputArgs []) | e == AllowEpsilon ]
+
+
+-- | Add a parameter that matches any string of non-space characters if
+-- input==String, or one full argument if input==[String]. See the 'Input' doc
+-- for this distinction.
+addParamStrings :: String -> Param Void -> CmdParser out [String]
+addParamStrings name par = addCmdPartManyInp ManyUpperBoundN desc parseF
+ where
+  desc :: PartDesc
+  desc =
+    addSuggestion (_param_suggestions par)
+      $ (maybe id PartWithHelp $ _param_help par)
+      $ PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (String, Input)
+  parseF (InputString str) _e =
+    case break Char.isSpace $ dropWhile Char.isSpace str of
+      ("", _   ) -> Nothing
+      (x , rest) -> Just (x, InputString rest)
+  parseF (InputArgs args) _e = case args of
+    (s1 : sR) -> Just (s1, InputArgs sR)
+    []        -> Nothing
+
+
+-- | Like 'addParamString' but does not match strings starting with a dash.
+-- This prevents misinterpretation of flags as params.
+addParamNoFlagString :: String -> Param String -> CmdParser out String
+addParamNoFlagString name par = addCmdPartInp desc parseF
+ where
+  desc :: PartDesc
+  desc =
+    addSuggestion (_param_suggestions par)
+      $ (maybe id PartWithHelp $ _param_help par)
+      $ PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (String, Input)
+  parseF (InputString str) e =
+    case break Char.isSpace $ dropWhile Char.isSpace str of
+      ("", rest) ->
+        [ (x, InputString rest) | x <- _param_default par, e == AllowEpsilon ]
+      ('-' : _, _) ->
+        [ (x, InputString str) | x <- _param_default par, e == AllowEpsilon ]
+      (x, rest) -> Just (x, InputString rest)
+  parseF (InputArgs args) e = case args of
+    [] -> [ (x, InputArgs args) | x <- _param_default par, e == AllowEpsilon ]
+    (('-' : _) : _) ->
+      [ (x, InputArgs args) | x <- _param_default par, e == AllowEpsilon ]
+    (s1 : sR) -> Just (s1, InputArgs sR)
+
+-- | Like 'addParamStringOpt' but does not match strings starting with a dash.
+-- This prevents misinterpretation of flags as params.
+addParamNoFlagStringOpt :: String -> Param Void -> CmdParser out (Maybe String)
+addParamNoFlagStringOpt name par = addCmdPartInp desc parseF
+ where
+  desc :: PartDesc
+  desc =
+    PartOptional $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (Maybe String, Input)
+  parseF (InputString str) e =
+    case break Char.isSpace $ dropWhile Char.isSpace str of
+      (""     , rest) -> [ (Nothing, InputString rest) | e == AllowEpsilon ]
+      ('-' : _, _   ) -> [ (Nothing, InputString str) | e == AllowEpsilon ]
+      (x      , rest) -> Just (Just x, InputString rest)
+  parseF (InputArgs args) e = case args of
+    []               -> [ (Nothing, InputArgs []) | e == AllowEpsilon ]
+    (('-' : _) : _ ) -> [ (Nothing, InputArgs args) | e == AllowEpsilon ]
+    (s1        : sR) -> Just (Just s1, InputArgs sR)
+
+-- | Like 'addParamStrings' but does not match strings starting with a dash.
+-- This prevents misinterpretation of flags as params.
+addParamNoFlagStrings :: String -> Param Void -> CmdParser out [String]
+addParamNoFlagStrings name par = addCmdPartManyInp ManyUpperBoundN desc parseF
+ where
+  desc :: PartDesc
+  desc =
+    addSuggestion (_param_suggestions par)
+      $ (maybe id PartWithHelp $ _param_help par)
+      $ PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (String, Input)
+  parseF (InputString str) _e =
+    case break Char.isSpace $ dropWhile Char.isSpace str of
+      (""     , _   ) -> Nothing
+      ('-' : _, _   ) -> Nothing
+      (x      , rest) -> Just (x, InputString rest)
+  parseF (InputArgs args) _e = case args of
+    []               -> Nothing
+    (('-' : _) : _ ) -> Nothing
+    (s1        : sR) -> Just (s1, InputArgs sR)
+
+
+-- | Add a parameter that consumes _all_ remaining input. Typical usecase is
+-- after a "--" as common in certain (unix?) commandline tools.
+addParamRestOfInput :: String -> Param Void -> CmdParser out String
+addParamRestOfInput name par = addCmdPartInp desc parseF
+ where
+  desc :: PartDesc
+  desc =
+    addSuggestion (_param_suggestions par)
+      $ (maybe id PartWithHelp $ _param_help par)
+      $ PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (String, Input)
+  parseF (InputString str ) _e = Just (str, InputString "")
+  parseF (InputArgs   args) _e = Just (List.unwords args, InputArgs [])
+
+
+-- | Add a parameter that consumes _all_ remaining input, returning a raw
+-- 'Input' value.
+addParamRestOfInputRaw :: String -> Param Void -> CmdParser out Input
+addParamRestOfInputRaw name par = addCmdPartInp desc parseF
+ where
+  desc :: PartDesc
+  desc =
+    addSuggestion (_param_suggestions par)
+      $ (maybe id PartWithHelp $ _param_help par)
+      $ PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (Input, Input)
+  parseF i@InputString{} _e = Just (i, InputString "")
+  parseF i@InputArgs{}   _e = Just (i, InputArgs [])
+

src/UI/Butcher/Applicative/Pretty.hs

@@ -0,0 +1,45 @@
+
+-- | 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.Applicative.Pretty
+  ( ppUsage
+  , ppUsageShortSub
+  , ppUsageAt
+  , ppHelpShallow
+  , ppHelpDepthOne
+  , ppUsageWithHelp
+  , ppPartDescUsage
+  , ppPartDescHeader
+  , parsingErrorString
+  , descendDescTo
+  )
+where
+
+
+
+import           UI.Butcher.Internal.Pretty

src/UI/Butcher/Internal/Applicative.hs

@@ -0,0 +1,421 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module UI.Butcher.Internal.Applicative
+  ( -- runCmdParser
+  -- , runCmdParserWithHelpDesc
+  -- , runCmdParserSimple
+    runCmdParserCoreFromDesc
+  , toCmdDesc
+  , traverseBarbie
+  , addCmd
+  , addCmdHidden
+  , addCmdPart
+  , addCmdPartMany
+  , addCmdPartInp
+  , addCmdPartManyInp
+  , peekCmdDesc
+  , reorderStart
+  , reorderStop
+  )
+where
+
+
+
+
+#include "prelude.inc"
+
+import qualified Barbies
+import qualified Barbies.Bare                  as Barbies
+import           Control.Applicative.Free
+import           Control.Monad.ST
+import           Data.STRef
+import qualified Text.PrettyPrint              as PP
+
+import           UI.Butcher.Internal.ApplicativeTypes
+import           UI.Butcher.Internal.CommonTypes
+import           UI.Butcher.Internal.Interactive
+import           UI.Butcher.Internal.Pretty
+
+
+
+data DescState = DescState
+  { parts    :: Deque PartDesc
+  , children :: Deque (String, CommandDesc)
+  , help     :: Maybe PP.Doc
+  , reorder  :: Maybe (Deque PartDesc)
+  }
+
+toCmdDesc :: forall out . CmdParser out out -> CommandDesc
+toCmdDesc cmdParser =
+  let final = appEndo (runAp_ f cmdParser) initialState
+  in  CommandDesc { _cmd_mParent    = Nothing
+                  , _cmd_synopsis   = Nothing
+                  , _cmd_help       = help final
+                  , _cmd_parts      = Data.Foldable.toList $ parts final
+                  , _cmd_hasImpl    = True -- all applicatives have an impl atm
+                  , _cmd_children   = fmap (first Just) $ children final
+                  , _cmd_visibility = Visible
+                  }
+ where
+  f :: CmdParserF out a -> Endo (DescState)
+  f x = Endo $ \s -> case x of
+    CmdParserHelp     doc _         -> s { help = Just doc }
+    CmdParserSynopsis _   _         -> error "todo"
+    CmdParserPeekDesc _             -> s
+    CmdParserPeekInput _            -> s
+    -- CmdParserPart desc _ _          -> appendPart s desc
+    -- CmdParserPartMany _ desc _ _    -> appendPart s desc
+    CmdParserPartInp desc _ _       -> appendPart s desc
+    CmdParserPartManyInp _ desc _ _ -> appendPart s desc
+    CmdParserChild name vis parser _ ->
+      appendChild s $ (name, (toCmdDesc parser) { _cmd_visibility = vis })
+    CmdParserReorderStart _ -> s { reorder = reorder s <|> Just empty }
+    CmdParserReorderStop  _ -> case reorder s of
+      Nothing -> s
+      Just ps -> s { parts = parts s <> ps, reorder = Nothing }
+   where
+    appendPart s p = s { parts = Deque.cons p (parts s) }
+    appendChild s c = s { children = Deque.cons c (children s) }
+  initialState = DescState { parts    = mempty
+                           , children = mempty
+                           , help     = Nothing
+                           , reorder  = mempty
+                           }
+
+data ParserState out = ParserState
+  { p_parts    :: Deque PartDesc
+  , p_children :: Deque (String, CommandDesc)
+  , p_help     :: Maybe PP.Doc
+  , p_reorder  :: Maybe (Deque PartDesc)
+  , p_input    :: Input
+  , p_currentDesc :: CommandDesc
+  }
+
+runCmdParserCoreFromDesc
+  :: forall out
+   . Input
+  -> CommandDesc
+  -> CmdParser out out
+  -> (CommandDesc, Input, Either ParsingError out)
+runCmdParserCoreFromDesc input desc parser =
+  let initialState = ParserState { p_parts    = mempty
+                                 , p_children = mempty
+                                 , p_help     = Nothing
+                                 , p_reorder  = mempty
+                                 , p_input    = input
+                                 , p_currentDesc = desc
+                                 }
+      (result, finalState) = runST $ StateS.runStateT (iter parser) initialState
+  in  (desc, p_input finalState, result)
+ where
+  iter
+    :: forall s
+     . CmdParser out out
+    -> StateS.StateT (ParserState out) (ST s) (Either ParsingError out)
+  iter = \case
+    Pure x                          -> pure $ Right x
+    Ap (CmdParserHelp     _ x) next -> continue next x
+    Ap (CmdParserSynopsis _ x) next -> continue next x
+    Ap (CmdParserPeekDesc f) next -> do
+      s <- StateS.get
+      iter $ next <*> Pure (f (p_currentDesc s))
+    Ap (CmdParserPeekInput f ) next -> do
+      s <- StateS.get
+      iter $ next <*> Pure (f (inputToString $ p_input s))
+    Ap (CmdParserPartInp _d parseF f) next -> do
+      s <- StateS.get
+      case parseF (p_input s) AllowEpsilon of
+        Just (x, rest) -> do
+          StateS.put s { p_input = rest }
+          iter $ next <&> \g -> g (f x)
+        Nothing -> pure $ Left $ ParsingError
+          { _pe_messages     = ["could not parse"]
+          , _pe_remaining    = p_input s
+          , _pe_expectedDesc = Nothing -- TODO
+          }
+    Ap (CmdParserPartManyInp _ _ parseF f) next -> do
+      let loop = do
+            dropSpaces
+            s <- StateS.get
+            case parseF (p_input s) AllowEpsilon of
+              Just (x, rest) -> do
+                StateS.put s { p_input = rest }
+                (x :) <$> loop
+              Nothing -> pure $ []
+      ps <- loop
+      iter $ next <&> \g -> g (f ps)
+    Ap (CmdParserChild name _ childParser x) next -> do
+      dropSpaces
+      s <- StateS.get
+      let childDesc = case find ((== Just name) . fst) (_cmd_children desc) of
+            Just (_, d) -> d
+            Nothing     -> error "inconsistent child name map"
+      case p_input s of
+        InputString str -> if
+          | str == name -> do
+            StateS.put ParserState { p_parts    = mempty
+                                 , p_children = mempty
+                                 , p_help     = Nothing
+                                 , p_reorder  = mempty
+                                 , p_input    = InputString ""
+                                 , p_currentDesc = childDesc
+                                 }
+            iter childParser
+          |
+-- TODO str prefix
+            otherwise -> continue next x
+        InputArgs (a1 : ar) | a1 == name -> do
+          StateS.put ParserState { p_parts    = mempty
+                                 , p_children = mempty
+                                 , p_help     = Nothing
+                                 , p_reorder  = mempty
+                                 , p_input    = InputArgs ar
+                                 , p_currentDesc = childDesc
+                                 }
+          iter childParser
+        InputArgs{} -> continue next x
+    Ap (CmdParserReorderStart startX) next -> Except.runExceptT $ do
+      let
+        enrich
+          :: forall a
+           . CmdParser out a
+          -> StateS.StateT
+               (ParserState out)
+               (ST s)
+               (Ap (EnrichedCmdParserF s out) a, [ReorderUnit s])
+        enrich = \case
+          Ap (CmdParserPartInp _ parseF f) n -> do
+            ref         <- lift $ newSTRef Nothing
+            (n', units) <- enrich n
+            pure (Ap (ViaRef ref f) n', ReorderUnit ref parseF : units)
+          Ap (CmdParserPartManyInp bound _ parseF f) n -> do
+            ref         <- lift $ newSTRef []
+            (n', units) <- enrich n
+            pure
+              ( Ap (ViaRefMany ref f) n'
+              , ReorderUnitMany bound ref parseF : units
+              )
+          Ap (CmdParserReorderStop x) n -> do
+            pure $ (liftAp $ Final (n <*> Pure x), [])
+          Ap x n -> do
+            (n', units) <- enrich n
+            pure (Ap (Lifted x) n', units)
+          Pure x -> do
+            pure (Pure x, [])
+        consumeReordered
+          :: [ReorderUnit s]
+          -> StateS.StateT (ParserState out) (ST s) [ReorderUnit s]
+        consumeReordered units = do
+          s <- StateS.get
+          let
+            matchF = \case
+              ReorderUnit ref parseF ->
+                case parseF (p_input s) DenyEpsilon of
+                  Nothing        -> Nothing
+                  Just (x, rest) -> Just $ \newUnits -> do
+                    lift $ writeSTRef ref (Just x)
+                    StateS.put s { p_input = rest }
+                    consumeReordered newUnits
+              ReorderUnitMany bound ref parseF ->
+                case parseF (p_input s) DenyEpsilon of
+                  Nothing        -> Nothing
+                  Just (x, rest) -> Just $ \newUnits -> do
+                    lift $ modifySTRef ref (x :)
+                    StateS.put s { p_input = rest }
+                    consumeReordered
+                      $ if bound == ManyUpperBound1 then newUnits else units
+          let (newUnits, mAct) = extract matchF units
+          case mAct of
+            Nothing  -> pure units
+            Just act -> act newUnits
+        derich
+          :: forall a
+           . Ap (EnrichedCmdParserF s out) a
+          -> ST s (CmdParser out a)
+        derich = \case
+          Ap (ViaRef ref f) n -> do
+            m <- readSTRef ref
+            case m of
+              Nothing -> error "butcher intenal error - reorder ref Nothing"
+              Just x  -> derich $ n <*> Pure (f x)
+          Ap (ViaRefMany ref f) n -> do
+            x <- readSTRef ref
+            derich $ n <*> Pure (f $ reverse x)
+          Ap (Lifted l) n -> Ap l <$> derich n
+          Ap (Final  f) n -> do
+            n' <- derich n
+            pure $ n' <*> f
+          Pure x -> pure $ Pure x
+
+      (e, units)     <- lift $ enrich (next <*> Pure startX)
+      remainingUnits <- lift $ consumeReordered units
+      remainingUnits `forM_` \case
+        ReorderUnit ref parseF -> case parseF (InputArgs []) AllowEpsilon of
+          Nothing -> do
+            s <- State.Class.get
+            Except.throwE ParsingError { _pe_messages     = ["could not parse"]
+                                       , _pe_remaining    = p_input s
+                                       , _pe_expectedDesc = Nothing -- TODO
+                                       }
+          Just (x, _) -> do
+            lift $ lift $ writeSTRef ref (Just x)
+        ReorderUnitMany{} -> pure ()
+      Except.ExceptT $ iter =<< lift (derich e)
+    Ap (CmdParserReorderStop _) next -> error "TODO" next
+   where
+    continue
+      :: Ap (CmdParserF out) (a -> out)
+      -> a
+      -> StateS.StateT (ParserState out) (ST s1) (Either ParsingError out)
+    continue next x = iter (next <*> Pure x)
+    inputToString :: Input -> String
+    inputToString (InputString s ) = s
+    inputToString (InputArgs   ss) = List.unwords ss
+    dropSpaces :: forall m . Monad m => StateS.StateT (ParserState out) m ()
+    dropSpaces = do
+      st <- StateS.get
+      case p_input st of
+        InputString s ->
+          StateS.put $ st { p_input = InputString $ dropWhile Char.isSpace s }
+        InputArgs{} -> return ()
+
+
+-- | If you have a higher-kinded config type (let's assume it is a plain
+-- record) then this turns a record whose fields are @CmdParser@s over
+-- different values into a CmdParser that returns a record with the parsed
+-- values in the fields.
+--
+-- See the BarbieParsing example included in this package.
+traverseBarbie
+  :: (Barbies.BareB c, Barbies.TraversableB (c Barbies.Covered))
+  => c Barbies.Covered (CmdParser out)
+  -> CmdParser out (c Barbies.Bare Identity)
+traverseBarbie k = do
+  r <- Barbies.btraverse (fmap Identity) k
+  pure $ Barbies.bstrip r
+
+
+-- | Add part that is expected to occur exactly once in the input.
+-- The EpsilonFlag specifies whether succeeding on empty input is permitted
+-- or not.
+addCmdPart
+  :: Typeable p
+  => PartDesc
+  -> (String -> EpsilonFlag -> Maybe (p, String))
+  -> CmdParser out p
+addCmdPart p f = liftAp $ CmdParserPartInp p (convertStringToInputParse f) id
+
+-- | Add part that is not required to occur, and can occur as often as
+-- indicated by 'ManyUpperBound'. The EpsilonFlag specifies whether succeeding
+-- on empty input is permitted or not.
+addCmdPartMany
+  :: Typeable p
+  => ManyUpperBound
+  -> PartDesc
+  -> (String -> EpsilonFlag -> Maybe (p, String))
+  -> CmdParser out [p]
+addCmdPartMany b p f =
+  liftAp $ CmdParserPartManyInp b p (convertStringToInputParse f) id
+
+-- | Add part that is expected to occur exactly once in the input.
+-- The EpsilonFlag specifies whether succeeding on empty input is permitted
+-- or not.
+--
+-- Only difference to 'addCmdPart' is that it accepts 'Input', i.e. can
+-- behave differently for @String@ and @[String]@ input.
+addCmdPartInp
+  :: Typeable p
+  => PartDesc
+  -> (Input -> EpsilonFlag -> Maybe (p, Input))
+  -> CmdParser out p
+addCmdPartInp p f = liftAp $ CmdParserPartInp p f id
+
+-- | Add part that is not required to occur, and can occur as often as
+-- indicated by 'ManyUpperBound'.
+-- The EpsilonFlag specifies whether succeeding on empty input is permitted
+-- or not.
+--
+-- Only difference to 'addCmdPart' is that it accepts 'Input', i.e. can
+-- behave differently for @String@ and @[String]@ input.
+addCmdPartManyInp
+  :: Typeable p
+  => ManyUpperBound
+  -> PartDesc
+  -> (Input -> EpsilonFlag -> Maybe (p, Input))
+  -> CmdParser out [p]
+addCmdPartManyInp b p f = liftAp $ CmdParserPartManyInp b p f id
+
+-- | 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 'toCmdDesc' if you want to check all parts
+-- of your 'CmdParser' without providing inputs that provide 100% coverage.
+reorderStart :: CmdParser out ()
+reorderStart = liftAp $ CmdParserReorderStart ()
+
+-- | See 'reorderStart'
+reorderStop :: CmdParser out ()
+reorderStop = liftAp $ CmdParserReorderStop ()
+
+-- | Add a new child command in the current context.
+addCmd
+  :: String -- ^ command name
+  -> CmdParser out out -- ^ subcommand
+  -> CmdParser out ()
+addCmd str sub = liftAp $ CmdParserChild str Visible sub ()
+
+-- | Add a new child command in the current context, but make it hidden. It
+-- will not appear in docs/help generated by e.g. the functions in the
+-- @Pretty@ module.
+--
+-- This feature is not well tested yet.
+addCmdHidden
+  :: String -- ^ command name
+  -> CmdParser out out -- ^ subcommand
+  -> CmdParser out ()
+addCmdHidden str sub = liftAp $ CmdParserChild str Hidden sub ()
+
+
+-- | Get the CommandDesc on the current level of the parser
+-- (i.e. for a command child, you get the child's CommandDesc).
+peekCmdDesc :: CmdParser out CommandDesc
+peekCmdDesc = liftAp $ CmdParserPeekDesc id
+
+
+extract :: (a -> Maybe b) -> [a] -> ([a], Maybe b)
+extract _ []       = ([], Nothing)
+extract f (x : xs) = case f x of
+  Nothing -> let ~(l, m) = extract f xs in (x : l, m)
+  Just b  -> (xs, Just b)
+
+-- I don't believe this version is any more efficient. It _can_ be one tad
+-- easier to use if it matches this pattern, but you _cannot_ get a non-strict
+-- delete out of this any longer.
+-- extractCont :: (a -> Maybe ([a] -> b)) -> [a] -> Maybe b
+-- extractCont f = go id
+--  where
+--   go _         []       = Nothing
+--   go startList (x : xs) = case f x of
+--     Nothing -> go ((x :) . startList) xs
+--     Just g  -> Just (g (startList xs))

src/UI/Butcher/Internal/ApplicativeTypes.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+-- {-# LANGUAGE PolyKinds #-}
+
+module UI.Butcher.Internal.ApplicativeTypes
+  ( PartDesc(..)
+  , EpsilonFlag(..)
+  , CmdParser
+  , ManyUpperBound(..)
+  , Input(..)
+  , CommandDesc(..)
+  , CmdParserF(..)
+  , convertStringToInputParse
+  , Visibility(..)
+  , CompletionItem(..)
+  , ParsingError(..)
+  , EnrichedCmdParserF(..)
+  , ReorderUnit(..)
+  )
+where
+
+
+
+#include "prelude.inc"
+import           Control.Applicative.Free
+import qualified Control.Monad.Trans.MultiState.Strict
+                                               as MultiStateS
+import           Data.STRef
+
+import           Data.Coerce                    ( coerce )
+import           GHC.TypeLits                   ( Nat )
+
+import qualified Text.PrettyPrint              as PP
+
+import           UI.Butcher.Internal.CommonTypes
+                                               as CommonTypes
+
+
+
+data CmdParserF out a
+  = CmdParserHelp PP.Doc a
+  | CmdParserSynopsis String a
+  | CmdParserPeekDesc (CommandDesc -> a)
+  | CmdParserPeekInput (String -> a)
+  | forall p . Typeable p => CmdParserPartInp
+                               PartDesc
+                               (Input -> EpsilonFlag -> Maybe (p, Input))
+                               (p -> a)
+  | forall p . Typeable p => CmdParserPartManyInp
+                               ManyUpperBound
+                               PartDesc
+                               (Input -> EpsilonFlag -> Maybe (p, Input))
+                               ([p] -> a)
+  | CmdParserChild String Visibility (CmdParser out out) a
+  | CmdParserReorderStart                    a
+  | CmdParserReorderStop                     a
+
+-- | The CmdParser monad type. It is a free applicative over some functor but
+-- users of butcher don't need to know more than that 'CmdParser' is a 'Monad'.
+type CmdParser out = Ap (CmdParserF out)
+
+data EnrichedCmdParserF s out a
+  = forall p . Typeable p => ViaRef (STRef s (Maybe p)) (p -> a)
+  | forall p . Typeable p => ViaRefMany (STRef s [p]) ([p] -> a)
+  | Lifted (CmdParserF out a)
+  | Final (CmdParser out a)
+
+data ReorderUnit s
+  = forall p . ReorderUnit (STRef s (Maybe p))
+                           (Input -> EpsilonFlag -> Maybe (p, Input))
+  | forall p . ReorderUnitMany ManyUpperBound
+                               (STRef s [p])
+                               (Input -> EpsilonFlag -> Maybe (p, Input))
+
+convertStringToInputParse
+  :: (String -> EpsilonFlag -> (Maybe (p, String)))
+  -> (Input -> EpsilonFlag -> Maybe (p, Input))
+convertStringToInputParse f i e = case i of
+  InputString s -> case f s e of
+    Nothing        -> Nothing
+    Just (p, rest) -> Just (p, InputString rest)
+  input@(InputArgs (a1 : ar)) -> case f a1 e of
+    Just (p, "")                -> Just (p, InputArgs ar)
+    Just (p, rest) | rest == a1 -> Just (p, input)
+    _                           -> Nothing
+  InputArgs [] -> case f "" e of
+    Just (p, "") -> Just (p, InputArgs [])
+    _            -> Nothing

src/UI/Butcher/Internal/BasicStringParser.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module UI.Butcher.Internal.BasicStringParser
+  ( InpParseString(..)
+  , runInpParseString
+  , pExpect
+  , pExpectEof
+  , pDropSpace
+  , pOption
+  )
+where
+
+
+
+#include "prelude.inc"
+
+
+
+-- 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 ()
+

src/UI/Butcher/Internal/CommonTypes.hs

@@ -5,25 +5,25 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module UI.Butcher.Monadic.Internal.Types
+module UI.Butcher.Internal.CommonTypes
   ( CommandDesc (..)
   , cmd_mParent
   , cmd_help
   , cmd_synopsis
   , cmd_parts
-  , cmd_out
+  , cmd_hasImpl
   , cmd_children
   , cmd_visibility
   , emptyCommandDesc
-  , CmdParserF (..)
-  , CmdParser
   , PartDesc (..)
   , Input (..)
+  , EpsilonFlag (..)
   , ParsingError (..)
   , addSuggestion
   , ManyUpperBound (..)
   , Visibility (..)
   , CompletionItem (..)
+  , PartialParseInfo (..)
   )
 where
 
@@ -47,45 +47,29 @@ import qualified Text.PrettyPrint as PP
 data Input = InputString String | InputArgs [String]
   deriving (Show, Eq)
 
+data EpsilonFlag = AllowEpsilon | DenyEpsilon deriving Eq
+
 -- | Information about an error that occured when trying to parse some @Input@
 -- using some @CmdParser@.
 data ParsingError = ParsingError
-  { _pe_messages  :: [String]
+  { _pe_messages     :: [String]
-  , _pe_remaining :: Input
+  , _pe_remaining    :: Input
+  , _pe_expectedDesc :: Maybe PartDesc
   }
-  deriving (Show, Eq)
+  deriving (Show)
 
 -- | Specifies whether we accept 0-1 or 0-n for @CmdParserPart@s.
 data ManyUpperBound
   = ManyUpperBound1
   | ManyUpperBoundN
+  deriving Eq
 
+-- | Flag for command visibility. Hidden commands will not show up in generated
+-- help documents or listed as alternatives for possible command completions
+-- etc.
 data Visibility = Visible | Hidden
   deriving (Show, Eq)
 
-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 (Maybe String) Visibility (CmdParser f out ()) (f ()) a
-  |                          CmdParserImpl  out                                a
-  |                          CmdParserReorderStart                             a
-  |                          CmdParserReorderStop                              a
-  |                          CmdParserGrouped String                           a
-  |                          CmdParserGroupEnd                                 a
-  | forall p . Typeable p => CmdParserAlternatives PartDesc [((String -> Bool), CmdParser f out p)] (p -> 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
 
@@ -110,18 +94,15 @@ type CmdParser f out = Free (CmdParserF f out)
 ---------
 
 -- | A representation/description of a command parser built via the
--- 'CmdParser' monad. Can be transformed into a pretty Doc to display
+-- @CmdParser@ monad. Can be transformed into a pretty Doc to display
 -- as usage/help via 'UI.Butcher.Monadic.Pretty.ppUsage' and related functions.
---
+data CommandDesc = CommandDesc
--- Note that there is the '_cmd_out' accessor that contains @Maybe out@ which
+  { _cmd_mParent  :: Maybe (Maybe String, CommandDesc)
--- might be useful after successful parsing.
-data CommandDesc out = CommandDesc
-  { _cmd_mParent  :: Maybe (Maybe String, CommandDesc out)
   , _cmd_synopsis :: Maybe PP.Doc
   , _cmd_help     :: Maybe PP.Doc
   , _cmd_parts    :: [PartDesc]
-  , _cmd_out      :: Maybe out
+  , _cmd_hasImpl  :: Bool
-  , _cmd_children :: Deque (Maybe String, CommandDesc out)
+  , _cmd_children :: Deque (Maybe String, CommandDesc)
                      -- we don't use a Map here because we'd like to
                      -- retain the order.
   , _cmd_visibility :: Visibility
@@ -179,27 +160,43 @@ command documentation structure
 
 --
 
-deriving instance Functor (CmdParserF f out)
-deriving instance Functor CommandDesc
-
---
-
 -- | Empty 'CommandDesc' value. Mostly for butcher-internal usage.
-emptyCommandDesc :: CommandDesc out
+emptyCommandDesc :: CommandDesc
 emptyCommandDesc =
-  CommandDesc Nothing Nothing Nothing [] Nothing mempty Visible
+  CommandDesc Nothing Nothing Nothing [] False mempty Visible
 
-instance Show (CommandDesc out) where
+instance Show CommandDesc 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)
 
 --
 
+-- | Return type of the parsing function. This has a lot of fields, because
+-- not only does it encode just parsing failure or success
+-- (see @_ppi_value :: Either ParsingError (Maybe out)@) but also it encodes
+-- information about partially succeeding parses. For example, the
+-- '_ppi_inputSugg' field serves as a tab-completion value.
+data PartialParseInfo out = PartialParseInfo
+  { _ppi_mainDesc        :: CommandDesc
+  , _ppi_localDesc       :: CommandDesc
+  , _ppi_value           :: Either ParsingError (Maybe out)
+  , _ppi_line            :: Input
+  , _ppi_rest            :: Input
+  , _ppi_lastword        :: String
+  , _ppi_choices         :: [CompletionItem]
+  , _ppi_choicesHelp     :: [(CompletionItem, Maybe String)]
+  , _ppi_choiceCommon    :: String
+  , _ppi_inputSugg       :: String
+  , _ppi_prioDesc        :: Maybe PartDesc
+  , _ppi_interactiveHelp :: Int -> PP.Doc
+  }
+
+--
+
 LensTH.makeLenses ''CommandDesc
 LensTH.makeLenses ''PartDesc
 

src/UI/Butcher/Internal/Interactive.hs

@@ -0,0 +1,157 @@
+-- | Utilities when writing interactive programs that interpret commands,
+-- e.g. a REPL.
+module UI.Butcher.Internal.Interactive
+  ( partDescStrings
+  , CompletionItem(..)
+  , PartialParseInfo(..)
+  , combinedCompletion
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import qualified Text.PrettyPrint              as PP
+
+import           UI.Butcher.Internal.Monadic
+import           UI.Butcher.Internal.MonadicTypes
+import           UI.Butcher.Monadic.Pretty
+
+
+
+combinedCompletion
+  :: Input
+  -> CommandDesc
+  -> CommandDesc
+  -> Input
+  -> Either ParsingError (Maybe out)
+  -> PartialParseInfo out
+combinedCompletion line topDesc localDesc pcRest e = PartialParseInfo
+  { _ppi_mainDesc        = topDesc
+  , _ppi_localDesc       = localDesc
+  , _ppi_value           = e
+  , _ppi_line            = line
+  , _ppi_rest            = pcRest
+  , _ppi_lastword        = lastWord
+  , _ppi_choices         = fst <$> choices
+  , _ppi_choicesHelp     = choices
+  , _ppi_choiceCommon    = longestCommonPrefix
+  , _ppi_inputSugg       = compl
+  , _ppi_prioDesc        = prioDesc
+  , _ppi_interactiveHelp = interactiveHelp
+  }
+ where
+  lastWord = case line of
+    InputString s  -> reverse $ takeWhile (not . Char.isSpace) $ reverse s
+    InputArgs   ss -> List.last ss
+  nullRest = case pcRest of
+    InputString s  -> null s
+    InputArgs   ss -> null ss
+  nameDesc = case _cmd_mParent localDesc of
+    Nothing -> localDesc
+    Just (_, parent) | nullRest && not (null lastWord) -> parent
+        -- not finished writing a command. if we have commands abc and abcdef,
+        -- we may want "def" as a completion after "abc".
+    Just{}  -> localDesc
+  choicesViaParent :: [(CompletionItem, Maybe String)] -- input, help
+  choicesViaParent = join
+    [ [ (CompletionString r, fmap show $ _cmd_synopsis c)
+      | (Just r, c) <- Data.Foldable.toList (_cmd_children nameDesc)
+      , lastWord `isPrefixOf` r
+      -- , lastWord /= r
+      ]
+    , [ (CompletionString s, h) -- TODO we might not want to restrict to
+                                -- CompletionString here
+      | (CompletionString s, h) <- partDescComplsWithHelp Nothing
+        =<< _cmd_parts nameDesc
+      , lastWord `isPrefixOf` s
+      -- , lastWord /= s
+      ]
+    ]
+  prioDesc = case e of
+    Left err -> _pe_expectedDesc err
+    Right{}  -> Nothing
+  choices = case prioDesc of
+    Just d  -> partDescComplsWithHelp Nothing d
+    Nothing -> choicesViaParent
+  complStrs           = [ s | (CompletionString s, _) <- choices ]
+  longestCommonPrefix = case complStrs of
+    [] -> ""
+    (c1 : cr) ->
+      case
+          find (\s -> List.all (s `isPrefixOf`) cr) $ reverse $ List.inits c1
+        of
+          Nothing -> ""
+          Just x  -> x
+  compl    = List.drop (List.length lastWord) longestCommonPrefix
+  nullLine = case line of
+    InputString "" -> True
+    InputArgs   [] -> True
+    _              -> False
+  interactiveHelp maxLines = if
+    | nullLine      -> helpStrShort
+    | null lastWord -> helpStrShort
+    | nullRest      -> helpStr maxLines
+    | otherwise     -> helpStr maxLines
+  helpStr maxLines = if List.length choices > maxLines
+    then PP.fcat $ List.intersperse (PP.text "|") $ PP.text <$> complStrs
+    else PP.vcat $ choices >>= \case
+      (CompletionString s, Nothing) -> [PP.text s]
+      (CompletionString s, Just h ) -> [PP.text s PP.<+> PP.text h]
+      (_                 , Nothing) -> []
+      (_                 , Just h ) -> [PP.text h]
+  helpStrShort = ppUsageWithHelp localDesc
+
+
+partDescComplsWithHelp
+  :: Maybe String -> PartDesc -> [(CompletionItem, Maybe String)]
+partDescComplsWithHelp mHelp = \case
+  PartLiteral  s       -> [(CompletionString s, mHelp)]
+  PartVariable _       -> []
+  -- TODO: we could handle seq of optional and such much better
+  PartOptional x       -> rec x
+  PartAlts     alts    -> alts >>= rec
+  PartSeq      []      -> []
+  PartSeq      (x : _) -> rec x
+  PartDefault    _  x  -> rec x
+  PartSuggestion ss x  -> [ (c, mHelp) | c <- ss ] ++ rec x
+  PartRedirect   _  x  -> rec x
+  PartReorder xs       -> xs >>= rec
+  PartMany    x        -> rec x
+  PartWithHelp h x     -> partDescComplsWithHelp (Just $ show h) x
+  PartHidden{}         -> []
+  where rec = partDescComplsWithHelp mHelp
+
+
+-- | Obtains a list of "expected"/potential strings for a command part
+-- described in the 'PartDesc'. In constrast to the 'combinedCompletion'
+-- function this function does not take into account any current input, and
+-- consequently the output elements can in general not be appended to partial
+-- input to form valid input.
+partDescStrings :: PartDesc -> [String]
+partDescStrings = \case
+  PartLiteral  s       -> [s]
+  PartVariable _       -> []
+  -- TODO: we could handle seq of optional and such much better
+  PartOptional x       -> partDescStrings x
+  PartAlts     alts    -> alts >>= partDescStrings
+  PartSeq      []      -> []
+  PartSeq      (x : _) -> partDescStrings x
+  PartDefault    _  x  -> partDescStrings x
+  PartSuggestion ss x  -> [ s | CompletionString s <- ss ] ++ partDescStrings x
+  PartRedirect   _  x  -> partDescStrings x
+  PartReorder xs       -> xs >>= partDescStrings
+  PartMany    x        -> partDescStrings x
+  PartWithHelp _h x    -> partDescStrings x -- TODO: handle help
+  PartHidden{}         -> []
+
+
+-- | Obtains a list of "expected"/potential strings for a command part
+-- described in the 'PartDesc'. In constrast to the 'combinedCompletion'
+-- function this function does not take into account any current input, and
+-- consequently the output elements can in general not be appended to partial
+-- input to form valid input.
+-- This is currently not properly implemented 
+_partDescCompletions :: PartDesc -> [CompletionItem]
+_partDescCompletions = fmap CompletionString . partDescStrings

src/UI/Butcher/Internal/MonadicTypes.hs

@@ -0,0 +1,141 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module UI.Butcher.Internal.MonadicTypes
+  ( CommandDesc(..)
+  , cmd_mParent
+  , cmd_help
+  , cmd_synopsis
+  , cmd_parts
+  , cmd_children
+  , cmd_visibility
+  , emptyCommandDesc
+  , CmdParserF(..)
+  , CmdParser
+  , PartDesc(..)
+  , Input(..)
+  , ParsingError(..)
+  , addSuggestion
+  , ManyUpperBound(..)
+  , Visibility(..)
+  , CompletionItem(..)
+  , PartParseResult(..)
+  , PartParser
+  , PartialParseInfo(..)
+  , resultFromMaybe
+  )
+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
+
+import           UI.Butcher.Internal.CommonTypes
+
+
+
+data PartParseResult val input
+  = Success val input -- value, remaining input
+  | Failure (Maybe PartDesc) -- desc of the expected part, if appropriate
+
+type PartParser val input = input -> PartParseResult val input
+
+resultFromMaybe :: Maybe (val, input) -> PartParseResult val input
+resultFromMaybe = \case
+  Just (x, r) -> Success x r
+  Nothing     -> Failure Nothing
+
+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 (PartParser p String) (p -> f ()) (p -> a)
+  | forall p . Typeable p => CmdParserPartMany ManyUpperBound PartDesc (PartParser p String) (p -> f ()) ([p] -> a)
+  | forall p . Typeable p => CmdParserPartInp PartDesc (PartParser p Input) (p -> f ()) (p -> a)
+  | forall p . Typeable p => CmdParserPartManyInp ManyUpperBound PartDesc (PartParser p Input) (p -> f ()) ([p] -> a)
+  |                          CmdParserChild (Maybe String) Visibility (CmdParser f out ()) (f ()) a
+  |                          CmdParserImpl  out                                a
+  |                          CmdParserReorderStart                             a
+  |                          CmdParserReorderStop                              a
+  |                          CmdParserGrouped String                           a
+  |                          CmdParserGroupEnd                                 a
+  | forall p . Typeable p => CmdParserAlternatives PartDesc [((String -> Bool), CmdParser f out p)] (p -> 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
+
+---------
+
+{-
+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)
+
+-- 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"

src/UI/Butcher/Internal/Pretty.hs

@@ -0,0 +1,394 @@
+
+-- | 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.Internal.Pretty
+  ( ppUsage
+  , ppUsageShortSub
+  , ppUsageAt
+  , ppHelpShallow
+  , ppHelpDepthOne
+  , ppUsageWithHelp
+  , ppPartDescUsage
+  , ppPartDescHeader
+  , parsingErrorString
+  , descendDescTo
+  )
+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.Internal.Monadic
+import           UI.Butcher.Internal.MonadicTypes
+
+
+
+-- | ppUsage exampleDesc yields:
+--
+-- > example [--short] NAME [version | help]
+ppUsage :: CommandDesc -> PP.Doc
+ppUsage (CommandDesc mParent _syn _help parts hasImpl children _hidden) =
+  pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]
+ where
+  pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc
+  pparents Nothing              = PP.empty
+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
+  partDocs = Maybe.mapMaybe ppPartDescUsage parts
+  visibleChildren =
+    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
+  subsDoc = if
+    | null visibleChildren -> PP.empty
+    | hasImpl              -> PP.brackets $ subDoc
+    | null parts           -> subDoc
+    | otherwise            -> PP.parens $ subDoc
+  subDoc =
+    PP.fcat
+      $   PP.punctuate (PP.text " | ")
+      $   Data.Foldable.toList
+      $   (PP.text . fst)
+      <$> visibleChildren
+
+-- | ppUsageShortSub exampleDesc yields:
+--
+-- > example [--short] NAME <command>
+--
+-- I.e. Subcommands are abbreviated using the @<command>@ label, instead
+-- of being listed.
+ppUsageShortSub :: CommandDesc -> PP.Doc
+ppUsageShortSub (CommandDesc mParent _syn _help parts hasImpl children _hidden)
+  = pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]
+ where
+  pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc
+  pparents Nothing              = PP.empty
+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
+  partDocs = Maybe.mapMaybe ppPartDescUsage parts
+  visibleChildren =
+    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
+  subsDoc = if
+    | null visibleChildren -> PP.empty
+    | hasImpl              -> PP.brackets $ subDoc
+    | otherwise            -> subDoc
+  subDoc = if null visibleChildren then PP.empty else PP.text "<command>"
+
+-- | ppUsageWithHelp exampleDesc yields:
+--
+-- > example [--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 -> PP.Doc
+ppUsageWithHelp (CommandDesc mParent _syn help parts hasImpl children _hidden)
+  = pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc
+ where
+  pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc
+  pparents Nothing              = PP.empty
+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
+  partDocs = Maybe.mapMaybe ppPartDescUsage parts
+  subsDoc  = if
+    | null children -> PP.empty
+    | -- TODO: remove debug
+      hasImpl       -> PP.brackets $ subDoc
+    | null parts    -> subDoc
+    | otherwise     -> PP.parens $ subDoc
+  subDoc =
+    PP.fcat
+      $ PP.punctuate (PP.text " | ")
+      $ Data.Foldable.toList
+      $ [ PP.text n | (Just n, c) <- children, _cmd_visibility c == Visible ]
+  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
+  -> Maybe PP.Doc
+ppUsageAt strings desc = ppUsage <$> descendDescTo strings desc
+
+-- | Access a child command's CommandDesc.
+descendDescTo :: [String] -> CommandDesc -> Maybe (CommandDesc)
+descendDescTo strings desc = case strings of
+  []       -> Just desc
+  (s : sr) -> do -- Maybe
+    (_, childDesc) <- find ((Just s ==) . fst) (_cmd_children desc)
+    descendDescTo sr childDesc
+
+-- | ppHelpShallow 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 -> PP.Doc
+ppHelpShallow desc =
+  nameSection
+    $+$ usageSection
+    $+$ descriptionSection
+    $+$ partsSection
+    $+$ PP.text ""
+ where
+  CommandDesc mParent syn help parts _out _children _hidden = desc
+  nameSection = case mParent of
+    Nothing -> PP.empty
+    Just{} ->
+      PP.text "NAME"
+        $+$ PP.text ""
+        $+$ PP.nest
+              2
+              (case syn of
+                Nothing -> pparents mParent
+                Just s  -> pparents mParent <+> PP.text "-" <+> s
+              )
+        $+$ PP.text ""
+  pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc
+  pparents Nothing              = PP.empty
+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
+  usageSection = PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (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 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)]
+          ++ (PP.nest 2 <$> go p)
+      PartReorder ps     -> ps >>= go
+      PartMany    p      -> go p
+      PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
+      PartHidden{}       -> []
+
+-- | ppHelpDepthOne exampleDesc yields:
+--
+-- > NAME
+-- > 
+-- >   example - a simple butcher example program
+-- > 
+-- > USAGE
+-- > 
+-- >   example [--short] NAME <command>
+-- > 
+-- > DESCRIPTION
+-- > 
+-- >   a very long help document
+-- > 
+-- > COMMANDS
+-- > 
+-- >   version
+-- >   help
+-- > 
+-- > ARGUMENTS
+-- > 
+-- >   --short             make the greeting short
+-- >   NAME                your name, so you can be greeted properly
+ppHelpDepthOne :: CommandDesc -> PP.Doc
+ppHelpDepthOne desc =
+  nameSection
+    $+$ usageSection
+    $+$ descriptionSection
+    $+$ commandSection
+    $+$ partsSection
+    $+$ PP.text ""
+ where
+  CommandDesc mParent syn help parts _out children _hidden = desc
+  nameSection = case mParent of
+    Nothing -> PP.empty
+    Just{} ->
+      PP.text "NAME"
+        $+$ PP.text ""
+        $+$ PP.nest
+              2
+              (case syn of
+                Nothing -> pparents mParent
+                Just s  -> pparents mParent <+> PP.text "-" <+> s
+              )
+        $+$ PP.text ""
+  pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc
+  pparents Nothing              = PP.empty
+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
+  usageSection =
+    PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsageShortSub desc)
+  descriptionSection = case help of
+    Nothing -> PP.empty
+    Just h ->
+      PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h
+  visibleChildren =
+    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
+  childDescs = visibleChildren <&> \(n, c) ->
+    PP.text n $$ PP.nest 20 (Maybe.fromMaybe PP.empty (_cmd_synopsis c))
+  commandSection = if null visibleChildren
+    then PP.empty
+    else PP.text "" $+$ PP.text "COMMANDS" $+$ PP.text "" $+$ PP.nest
+      2
+      (PP.vcat $ Data.Foldable.toList childDescs)
+  partsSection = if null partsTuples
+    then PP.empty
+    else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest
+      2
+      (PP.vcat partsTuples)
+  partsTuples :: [PP.Doc]
+  partsTuples = parts >>= go
+   where
+    go = \case
+      PartLiteral{}      -> []
+      PartVariable{}     -> []
+      PartOptional p     -> go p
+      PartAlts     ps    -> ps >>= go
+      PartSeq      ps    -> ps >>= go
+      PartDefault    _ p -> go p
+      PartSuggestion _ p -> go p
+      PartRedirect s p ->
+        [PP.text s $$ PP.nest 20 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)]
+          ++ (PP.nest 2 <$> go p)
+      PartReorder ps     -> ps >>= go
+      PartMany    p      -> go p
+      PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
+      PartHidden{}       -> []
+
+-- | Internal helper; users probably won't need this.
+ppPartDescUsage :: PartDesc -> Maybe PP.Doc
+ppPartDescUsage = \case
+  PartLiteral  s -> Just $ PP.text s
+  PartVariable s -> Just $ PP.text s
+  PartOptional p -> PP.brackets <$> rec p
+  PartAlts ps ->
+    [ PP.fcat $ PP.punctuate (PP.text ",") ds
+    | let ds = Maybe.mapMaybe rec ps
+    , not (null ds)
+    ]
+  PartSeq ps -> [ PP.fsep ds | let ds = Maybe.mapMaybe rec ps, not (null ds) ]
+  PartDefault    _   p -> PP.brackets <$> rec p
+  PartSuggestion sgs p -> rec p <&> \d ->
+    case [ PP.text s | CompletionString s <- sgs ] of
+      [] -> d
+      sgsDocs ->
+        PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ sgsDocs ++ [d]
+  PartRedirect s _ -> Just $ PP.text s
+  PartMany p       -> rec p <&> (PP.<> PP.text "+")
+  PartWithHelp _ p -> rec p
+  PartReorder ps ->
+    let flags  = [ d | PartMany d <- ps ]
+        params = filter
+          (\case
+            PartMany{} -> False
+            _          -> True
+          )
+          ps
+    in  Just $ PP.sep
+          [ (PP.fsep $ PP.brackets <$> Maybe.mapMaybe rec flags)
+          , PP.fsep (Maybe.mapMaybe rec params)
+          ]
+  PartHidden{} -> Nothing
+  where rec = ppPartDescUsage
+
+-- | Internal helper; users probably won't need this.
+ppPartDescHeader :: PartDesc -> PP.Doc
+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
+  PartHidden  d      -> rec d
+  where rec = ppPartDescHeader
+
+-- | Simple conversion from 'ParsingError' to 'String'.
+parsingErrorString :: ParsingError -> String
+parsingErrorString pe = "error parsing arguments: " ++ messStr ++ remainingStr
+ where
+  mess      = _pe_messages pe
+  remaining = _pe_remaining pe
+  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 ++ "..\"."
+

src/UI/Butcher/Monadic.hs

@@ -4,24 +4,22 @@ module UI.Butcher.Monadic
     Input (..)
   , CmdParser
   , ParsingError (..)
-  , CommandDesc(_cmd_out)
+  , PartialParseInfo (..)
-  , cmd_out
+  , CommandDesc
   , -- * Run or Check CmdParsers
-    runCmdParserSimple
+    runCmdParserSimpleString
   , runCmdParser
-  , runCmdParserExt
   , runCmdParserA
-  , runCmdParserAExt
+  , runCmdParserFromDesc
+  , runCmdParserAFromDesc
   , runCmdParserWithHelpDesc
-  , checkCmdParser
+  , toCmdDesc
   , -- * 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
-    -- * Utilities for interactive feedback of commandlines (completions etc.)
-  , module UI.Butcher.Monadic.Interactive
   -- , cmds
   -- , sample
   -- , test
@@ -45,14 +43,14 @@ where
 
 #include "prelude.inc"
 
-import UI.Butcher.Monadic.Types
+import           UI.Butcher.Internal.Monadic
-import UI.Butcher.Monadic.Internal.Types
+import           UI.Butcher.Internal.MonadicTypes
-import UI.Butcher.Monadic.Command
+import           UI.Butcher.Internal.Interactive
-import UI.Butcher.Monadic.BuiltinCommands
+import           UI.Butcher.Monadic.BuiltinCommands
-import UI.Butcher.Monadic.Internal.Core
+import           UI.Butcher.Monadic.Command
-import UI.Butcher.Monadic.Pretty
+import           UI.Butcher.Monadic.IO
-import UI.Butcher.Monadic.IO
+import           UI.Butcher.Monadic.Pretty
-import UI.Butcher.Monadic.Interactive
+import           UI.Butcher.Monadic.Types
 
 import qualified Text.PrettyPrint as PP
 
@@ -68,7 +66,7 @@ import qualified Text.PrettyPrint as PP
 -- 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
+-- 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
@@ -76,27 +74,91 @@ import qualified Text.PrettyPrint as PP
 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 -> CmdParser Identity out ()) -- ^ parser to use
-  -> (CommandDesc (), Either ParsingError (CommandDesc out))
+  -> (CommandDesc, Input, Either ParsingError (Maybe out))
 runCmdParserWithHelpDesc mProgName input cmdF =
   let (checkResult, fullDesc)
         -- knot-tying at its finest..
-        = ( checkCmdParser mProgName (cmdF fullDesc)
+        = ( toCmdDesc mProgName (cmdF fullDesc)
           , either (const emptyCommandDesc) id $ checkResult
           )
-  in runCmdParser mProgName input (cmdF fullDesc)
+  in runCmdParserCoreFromDesc fullDesc input (cmdF fullDesc)
 
 
 -- | Wrapper around 'runCmdParser' for very simple usage: Accept a @String@
 -- input and return only the output from the parser, or a plain error string
 -- on failure.
-runCmdParserSimple :: String -> CmdParser Identity out () -> Either String out
+runCmdParserSimpleString :: String -> CmdParser Identity out () -> Either String out
-runCmdParserSimple s p = case snd $ runCmdParser Nothing (InputString s) p of
+runCmdParserSimpleString s p = case toCmdDesc Nothing p of
-  Left e -> Left $ parsingErrorString e
+  Left err -> Left err
-  Right desc ->
+  Right fullDesc -> 
-    maybe (Left "command has no implementation") Right $ _cmd_out desc
+    case runCmdParserCoreFromDesc fullDesc (InputString s) p of
+      (_, _, Left e) -> Left $ parsingErrorString e
+      (_, _, Right outM) ->
+        maybe (Left "command has no implementation") Right $ outM
 
 
+-- | Runs a 'CmdParser' on the given 'Input', returning the 'PartialParseInfo'
+-- struct that encodes both general success/failure and that has additional
+-- fields that are useful for interactive help or feedback to the user
+-- (think something like "did you mean to use command foo?").
+runCmdParser
+  :: forall out
+   . Maybe String -- ^ top-level command name
+  -> Input
+  -> CmdParser Identity out ()
+  -> PartialParseInfo out
+runCmdParser mTopLevel input parser =
+  let topDesc = case toCmdDesc mTopLevel parser of
+        Left  err -> error err
+        Right d   -> d
+  in  runCmdParserFromDesc topDesc input parser
+
+-- | Runs a parser given 'Input', a 'CmdParser' and the 'CommandDesc' that was
+-- derived from the 'CmdParser' using 'toCmdDesc'.
+-- 'runCmdParser' will do both steps, but this is useful
+-- a) if the 'CommandDesc' can be re-used because the 'Input' changes but the
+-- 'CmdParser' does not.
+-- b) because in some (rare) cases 'toCmdDesc' may fail, and calling it
+-- explicitly allows handling that case properly.
+runCmdParserFromDesc
+  :: forall out
+   . CommandDesc
+  -> Input
+  -> CmdParser Identity out ()
+  -> PartialParseInfo out
+runCmdParserFromDesc topDesc input parser =
+  let (localDesc, remainingInput, result) =
+        runCmdParserCoreFromDesc topDesc input parser
+  in  combinedCompletion input topDesc localDesc remainingInput result
+
+-- | The Applicative-enabled version of 'runCmdParser'.
+runCmdParserA
+  :: forall f out
+   . Applicative f
+  => Maybe String -- ^ top-level command name
+  -> Input
+  -> CmdParser f out ()
+  -> f (PartialParseInfo out)
+runCmdParserA mTopLevel input parser =
+  let topDesc = case toCmdDesc mTopLevel parser of
+        Left  err -> error err
+        Right d   -> d
+  in  runCmdParserAFromDesc topDesc input parser
+
+-- | The Applicative-enabled version of 'runCmdParserA'.
+runCmdParserAFromDesc
+  :: forall f out
+   . Applicative f
+  => CommandDesc
+  -> Input
+  -> CmdParser f out ()
+  -> f (PartialParseInfo out)
+runCmdParserAFromDesc topDesc input parser =
+  let mapper (localDesc, remainingInput, result) =
+        combinedCompletion input topDesc localDesc remainingInput result
+  in  mapper <$> runCmdParserCoreFromDescA topDesc input parser
+
 --------------------------------------
 -- all below is for testing purposes
 --------------------------------------
@@ -155,22 +217,23 @@ data Sample = 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
+_test2 = case toCmdDesc (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
+_test3 s = do
-  (desc, Left e) -> do
+  case _ppi_value info of
-    print e
+    Left err -> do
-    print $ ppHelpShallow desc
+      print err
-    _cmd_mParent desc `forM_` \(_, d) -> do
+      print $ ppHelpShallow (_ppi_localDesc info)
-      print $ ppUsage d
+      _cmd_mParent (_ppi_localDesc info) `forM_` \(_, d) -> do
-  (desc, Right out) -> do
+        print $ ppUsage d
-    case _cmd_out out of
+    Right Nothing -> do
-      Nothing -> do
+      putStrLn "command is missing implementation!"
-        putStrLn "command is missing implementation!"
+      print $ ppHelpShallow (_ppi_localDesc info)
-        print $ ppHelpShallow desc
+    Right (Just f) -> f
-      Just f -> f
+ where
+  info = runCmdParser Nothing (InputString s) _cmds

src/UI/Butcher/Monadic/BuiltinCommands.hs

@@ -21,11 +21,11 @@ import qualified Text.PrettyPrint as PP
 
 import           Data.HList.ContainsType
 
-import           UI.Butcher.Monadic.Internal.Types
+import           UI.Butcher.Internal.MonadicTypes
-import           UI.Butcher.Monadic.Internal.Core
+import           UI.Butcher.Internal.Monadic
+import           UI.Butcher.Internal.Interactive
 import           UI.Butcher.Monadic.Pretty
 import           UI.Butcher.Monadic.Param
-import           UI.Butcher.Monadic.Interactive
 
 import           System.IO
 
@@ -37,7 +37,7 @@ import           System.IO
 --
 -- > addHelpCommand = addHelpCommandWith
 -- >   (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpShallow)
-addHelpCommand :: Applicative f => CommandDesc a -> CmdParser f (IO ()) ()
+addHelpCommand :: Applicative f => CommandDesc -> CmdParser f (IO ()) ()
 addHelpCommand = addHelpCommandWith
   (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpShallow)
 
@@ -51,7 +51,7 @@ addHelpCommand = addHelpCommandWith
 --
 -- > addHelpCommand2 = addHelpCommandWith
 -- >   (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpDepthOne)
-addHelpCommand2 :: Applicative f => CommandDesc a -> CmdParser f (IO ()) ()
+addHelpCommand2 :: Applicative f => CommandDesc -> CmdParser f (IO ()) ()
 addHelpCommand2 = addHelpCommandWith
   (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpDepthOne)
 
@@ -59,8 +59,8 @@ addHelpCommand2 = addHelpCommandWith
 -- the relevant subcommand's 'CommandDesc' into a String.
 addHelpCommandWith
   :: Applicative f
-  => (CommandDesc a -> IO String)
+  => (CommandDesc -> IO String)
-  -> CommandDesc a
+  -> CommandDesc
   -> CmdParser f (IO ()) ()
 addHelpCommandWith f desc = addCmd "help" $ do
   addCmdSynopsis "print help about this command"
@@ -68,7 +68,7 @@ addHelpCommandWith f desc = addCmd "help" $ do
   addCmdImpl $ do
     let restWords = List.words rest
     let
-      descent :: [String] -> CommandDesc a -> CommandDesc a
+      descent :: [String] -> CommandDesc -> CommandDesc
       descent [] curDesc = curDesc
       descent (w:wr) curDesc =
         case
@@ -110,6 +110,7 @@ addButcherDebugCommand = addCmd "butcherdebug" $ do
 addShellCompletionCommand
   :: CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
 addShellCompletionCommand mainCmdParser = do
+  desc <- peekCmdDesc
   addCmdHidden "completion" $ do
     addCmdSynopsis "utilites to enable bash-completion"
     addCmd "bash-script" $ do
@@ -122,16 +123,18 @@ addShellCompletionCommand mainCmdParser = do
         "generate possible completions for given input arguments"
       rest <- addParamRestOfInputRaw "REALCOMMAND" mempty
       addCmdImpl $ do
-        let (cdesc, remaining, _result) =
+        let (cdesc, remaining, result) =
-              runCmdParserExt Nothing rest mainCmdParser
+              runCmdParserCoreFromDesc desc rest mainCmdParser
         let
-          compls = shellCompletionWords (inputString rest)
+          info = combinedCompletion  rest
+                     desc
                                         cdesc
-                                        (inputString remaining)
+                                        remaining
+                                        result
         let lastWord =
               reverse $ takeWhile (not . Char.isSpace) $ reverse $ inputString
                 rest
-        putStrLn $ List.unlines $ compls <&> \case
+        putStrLn $ List.unlines $ _ppi_choices info <&> \case
           CompletionString s  -> s
           CompletionFile      -> "$(compgen -f -- " ++ lastWord ++ ")"
           CompletionDirectory -> "$(compgen -d -- " ++ lastWord ++ ")"
@@ -145,7 +148,7 @@ addShellCompletionCommand mainCmdParser = do
 --
 -- > $ source <(foo completion bash-script foo)
 addShellCompletionCommand'
-  :: (CommandDesc out -> CmdParser Identity (IO ()) ())
+  :: (CommandDesc -> CmdParser Identity (IO ()) ())
   -> CmdParser Identity (IO ()) ()
 addShellCompletionCommand' f = addShellCompletionCommand (f emptyCommandDesc)
 

src/UI/Butcher/Monadic/Command.hs

@@ -12,7 +12,7 @@
 --
 -- > return ()
 --
--- But not very interesting - you won't get an 'out' value from this (e.g. an
+-- 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
@@ -62,6 +62,7 @@ module UI.Butcher.Monadic.Command
   , reorderStart
   , reorderStop
   , withReorder
+  , traverseBarbie
   , peekCmdDesc
   , peekInput
     -- * Building CmdParsers - myprog -v --input PATH
@@ -76,6 +77,8 @@ module UI.Butcher.Monadic.Command
   , addAlternatives
   , ManyUpperBound (..)
   , varPartDesc
+  , PartParser
+  , PartParseResult(..)
   )
 where
 
@@ -83,10 +86,8 @@ where
 
 #include "prelude.inc"
 
-
+import           UI.Butcher.Internal.MonadicTypes
-
+import           UI.Butcher.Internal.Monadic
-import           UI.Butcher.Monadic.Internal.Types
-import           UI.Butcher.Monadic.Internal.Core
 import           UI.Butcher.Monadic.Flag
 import           UI.Butcher.Monadic.Param
 

src/UI/Butcher/Monadic/Flag.hs

@@ -17,8 +17,8 @@ module UI.Butcher.Monadic.Flag
   , flagDefault
   , flagHidden
   , addSimpleBoolFlag
+  , addSimpleBoolFlagA
   , addSimpleCountFlag
-  , addSimpleFlagA
   , addFlagReadParam
   , addFlagReadParams
   -- , addFlagReadParamA
@@ -32,17 +32,19 @@ where
 
 #include "prelude.inc"
 import           Control.Monad.Free
-import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
+import qualified Control.Monad.Trans.MultiRWS.Strict
-import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS
+                                               as MultiRWSS
+import qualified Control.Monad.Trans.MultiState.Strict
+                                               as MultiStateS
 
-import qualified Text.PrettyPrint as PP
+import qualified Text.PrettyPrint              as PP
 
 import           Data.HList.ContainsType
 
-import           UI.Butcher.Monadic.Internal.Types
+import           UI.Butcher.Internal.Monadic
-import           UI.Butcher.Monadic.Internal.Core
+import           UI.Butcher.Internal.MonadicTypes
 
-import           Data.List.Extra ( firstJust )
+import           Data.List.Extra                ( firstJust )
 
 
 
@@ -57,7 +59,7 @@ pExpect :: String -> InpParseString ()
 pExpect s = InpParseString $ do
   inp <- StateS.get
   case List.stripPrefix s inp of
-    Nothing -> mzero
+    Nothing   -> mzero
     Just rest -> StateS.put rest
 
 pExpectEof :: InpParseString ()
@@ -92,7 +94,7 @@ instance Semigroup (Flag p) where
   (<>) = appendFlag
 
 instance Monoid (Flag p) where
-  mempty = Flag Nothing Nothing Visible
+  mempty  = Flag Nothing Nothing Visible
   mappend = (<>)
 
 -- | Create a 'Flag' with just a help text.
@@ -130,22 +132,18 @@ addSimpleBoolFlag
 addSimpleBoolFlag shorts longs flag =
   addSimpleBoolFlagAll shorts longs flag (pure ())
 
--- | Applicative-enabled version of 'addSimpleFlag'
+-- | Applicative-enabled version of 'addSimpleBoolFlag'
-addSimpleFlagA
+addSimpleBoolFlagA
   :: 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
+addSimpleBoolFlagA shorts longs flag act =
-  = void $ addSimpleBoolFlagAll shorts longs flag act
+  void $ addSimpleBoolFlagAll shorts longs flag act
 
 addSimpleBoolFlagAll
-  :: String
+  :: String -> [String] -> Flag Void -> f () -> CmdParser f out Bool
-  -> [String]
-  -> Flag Void
-  -> f ()
-  -> CmdParser f out Bool
 addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
   $ addCmdPartManyA ManyUpperBound1 (wrapHidden flag desc) parseF (\() -> a)
  where
@@ -156,11 +154,12 @@ addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
       $   PartAlts
       $   PartLiteral
       <$> allStrs
-  parseF :: String -> Maybe ((), String)
+  parseF :: PartParser () String
   parseF (dropWhile Char.isSpace -> str) =
-    (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
+    resultFromMaybe
-      <|> ( firstJust
+      $   (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
-            ( \s ->
+      <|> (firstJust
+            (\s ->
               [ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ]
             )
             allStrs
@@ -168,11 +167,12 @@ addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
 
 -- | A no-parameter flag that can occur multiple times. Returns the number of
 -- occurences (0 or more).
-addSimpleCountFlag :: Applicative f
+addSimpleCountFlag
-                   => String -- ^ short flag chars, i.e. "v" for -v
+  :: Applicative f
-                   -> [String] -- ^ list of long names, i.e. ["verbose"]
+  => String -- ^ short flag chars, i.e. "v" for -v
-                   -> Flag Void -- ^ properties
+  -> [String] -- ^ list of long names, i.e. ["verbose"]
-                   -> CmdParser f out Int
+  -> Flag Void -- ^ properties
+  -> CmdParser f out Int
 addSimpleCountFlag shorts longs flag = fmap length
   $ addCmdPartMany ManyUpperBoundN (wrapHidden flag desc) parseF
  where
@@ -185,16 +185,22 @@ addSimpleCountFlag shorts longs flag = fmap length
       $   PartAlts
       $   PartLiteral
       <$> allStrs
-  parseF :: String -> Maybe ((), String)
+  parseF :: PartParser () String
   parseF (dropWhile Char.isSpace -> str) =
-    (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
+    resultFromMaybe
-      <|> ( firstJust
+      $   (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
-            ( \s ->
+      <|> (firstJust
+            (\s ->
               [ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ]
             )
             allStrs
           )
 
+
+-- can have one of
+--   1) no default 2) default is nothing + just value 3) default value
+-- inner default only makes sense if there is an outer default
+
 -- | One-argument flag, where the argument is parsed via its Read instance.
 addFlagReadParam
   :: forall f p out
@@ -204,8 +210,10 @@ addFlagReadParam
   -> String -- ^ param name
   -> Flag p -- ^ properties
   -> CmdParser f out p
-addFlagReadParam shorts longs name flag =
+addFlagReadParam shorts longs name flag = addCmdPartInpA
-  addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())
+  (wrapHidden flag desc)
+  parseF
+  (\_ -> pure ())
  where
   allStrs =
     [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
@@ -216,11 +224,13 @@ addFlagReadParam shorts longs name flag =
   desc1 :: PartDesc
   desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
   desc2 = PartVariable name
-  parseF :: Input -> Maybe (p, Input)
+  parseF :: PartParser p Input
   parseF inp = case inp of
-    InputString str ->
+    InputString str -> case parseResult of
-      maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)
+      Nothing -> resultFromMaybe $ _flag_default flag <&> \x -> (x, inp)
-        $ parseResult
+      Just (descOrVal, r) -> case descOrVal of
+        Left  e   -> Failure (Just e)
+        Right val -> Success val (InputString r)
      where
       parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
         Data.Foldable.msum $ allStrs <&> \case
@@ -229,23 +239,27 @@ addFlagReadParam shorts longs name flag =
         InpParseString $ do
           i <- StateS.get
           case Text.Read.reads i of
-            ((x, ' ':r):_) -> StateS.put (dropWhile Char.isSpace r) $> x
+            ((x, ' ' : r) : _) ->
-            ((x, ""   ):_) -> StateS.put "" $> x
+              StateS.put (dropWhile Char.isSpace r) $> Right x
-            _              -> mzero
+            ((x, "") : _) -> StateS.put "" $> Right x
-    InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
+            _             -> pure $ Left desc2
+    InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of
       Just ((), "") -> case argR of
-        []          -> Nothing
+        []            -> Failure Nothing
-        (arg2:rest) -> Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest)
+        (arg2 : rest) -> case Text.Read.readMaybe arg2 of
-      Just ((), remainingStr) ->
+          Just x  -> Success x (InputArgs rest)
-        Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR)
+          Nothing -> Failure (Just desc2)
-      Nothing -> _flag_default flag <&> \d -> (d, inp)
+      Just ((), remainingStr) -> case Text.Read.readMaybe remainingStr of
+        Just x  -> Success x (InputArgs argR)
+        Nothing -> Failure (Just desc2)
+      Nothing -> resultFromMaybe $ _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)
+    InputArgs _ -> resultFromMaybe $ _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
@@ -260,8 +274,8 @@ addFlagReadParams
   -> String -- ^ param name
   -> Flag p -- ^ properties
   -> CmdParser f out [p]
-addFlagReadParams shorts longs name flag
+addFlagReadParams shorts longs name flag =
-  = addFlagReadParamsAll shorts longs name flag (\_ -> pure ())
+  addFlagReadParamsAll shorts longs name flag (\_ -> pure ())
 
 -- TODO: this implementation is wrong, because it uses addCmdPartManyInpA
 --       while this really is no Many.
@@ -279,12 +293,14 @@ addFlagReadParams shorts longs name flag
 --   = 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
+  :: forall f p out
-     -> [String] -- ^ list of long names, i.e. ["verbose"]
+   . (Typeable p, Text.Read.Read p, Show p)
-     -> String -- ^ param name
+  => String -- ^ short flag chars, i.e. "v" for -v
-     -> Flag p -- ^ properties
+  -> [String] -- ^ list of long names, i.e. ["verbose"]
-     -> (p -> f ()) -- ^ action to execute when ths param matches
+  -> String -- ^ param name
-     -> CmdParser f out [p]
+  -> Flag p -- ^ properties
+  -> (p -> f ()) -- ^ action to execute when ths param matches
+  -> CmdParser f out [p]
 addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA
   ManyUpperBoundN
   (wrapHidden flag desc)
@@ -298,10 +314,13 @@ addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA
   desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
   desc2 =
     (maybe id (PartDefault . show) $ _flag_default flag) $ PartVariable name
-  parseF :: Input -> Maybe (p, Input)
+  parseF :: PartParser p Input
   parseF inp = case inp of
-    InputString str ->
+    InputString str -> case parseResult of
-      fmap (second InputString) $ parseResult
+      Just (descOrVal, r) -> case descOrVal of
+        Right val -> Success val (InputString r)
+        Left  err -> Failure (Just err)
+      Nothing -> Failure Nothing
      where
       parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
         Data.Foldable.msum $ allStrs <&> \case
@@ -310,46 +329,65 @@ addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA
         InpParseString $ do
           i <- StateS.get
           case Text.Read.reads i of
-            ((x, ' ':r):_) -> StateS.put (dropWhile Char.isSpace r) $> x
+            ((x, ' ' : r) : _) ->
-            ((x, ""   ):_) -> StateS.put "" $> x
+              StateS.put (dropWhile Char.isSpace r) $> Right x
-            _              -> lift $ _flag_default flag
+            ((x, "") : _) -> StateS.put "" $> Right x
-    InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
+            _             -> pure $ case _flag_default flag of
+              Nothing  -> Left desc2
+              Just val -> Right val
+    InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of
       Just ((), "") -> case argR of
-        []          -> mdef
+        []            -> mdef
-        (arg2:rest) -> (Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest)) <|> mdef
+        (arg2 : rest) -> case Text.Read.readMaybe arg2 of
-        where mdef = _flag_default flag <&> \p -> (p, InputArgs argR)
+          Just x  -> Success x (InputArgs rest)
-      Just ((), remainingStr) ->
+          Nothing -> mdef
-        Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR)
+       where
-      Nothing -> Nothing
+        mdef = case _flag_default flag of
+          Nothing  -> Failure (Just desc2)
+          Just val -> Success val (InputArgs argR)
+      Just ((), remainingStr) -> case Text.Read.readMaybe remainingStr of
+        Just x  -> Success x (InputArgs argR)
+        Nothing -> Failure (Just desc2) -- this is a bit questionable,
+                  -- could also make it Nothing.
+      Nothing -> Failure 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
+    InputArgs _ -> Failure 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
+  :: forall f out
-     -> [String] -- ^ list of long names, i.e. ["verbose"]
+   . (Applicative f)
-     -> String -- ^ param name
+  => String -- ^ short flag chars, i.e. "v" for -v
-     -> Flag String -- ^ properties
+  -> [String] -- ^ list of long names, i.e. ["verbose"]
-     -> CmdParser f out String
+  -> String -- ^ param name
-addFlagStringParam shorts longs name flag =
+  -> Flag String -- ^ properties
-  addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())
+  -> CmdParser f out String
+addFlagStringParam shorts longs name flag = addCmdPartInpA
+  (wrapHidden flag desc)
+  parseF
+  (\_ -> pure ())
  where
   allStrs =
     [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
-  desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2]
+  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 (String, Input)
+  parseF :: PartParser String Input
   parseF inp = case inp of
-    InputString str ->
+    InputString str -> case parseResult of
-      maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)
+      Nothing -> resultFromMaybe $ _flag_default flag <&> \x -> (x, inp)
-        $ parseResult
+      Just (descOrVal, r) -> case descOrVal of
+        Left  e   -> Failure (Just e)
+        Right val -> Success val (InputString r)
      where
       parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
         Data.Foldable.msum $ allStrs <&> \case
@@ -359,20 +397,22 @@ addFlagStringParam shorts longs name flag =
           i <- StateS.get
           let (x, rest) = break Char.isSpace $ dropWhile Char.isSpace i
           StateS.put rest
-          pure x
+          pure $ Right x
-    InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
+    InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of
       Just ((), "") -> case argR of
-        []       -> Nothing
+        []         -> Failure Nothing
-        (x:rest) -> Just (x, InputArgs rest)
+        (x : rest) -> Success x (InputArgs rest)
-      Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)
+      Just ((), remainingStr) -> case Text.Read.readMaybe remainingStr of
-      Nothing                 -> _flag_default flag <&> \d -> (d, inp)
+        Just x  -> Success x (InputArgs argR)
+        Nothing -> Failure (Just desc2)
+      Nothing -> resultFromMaybe $ _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)
+    InputArgs _ -> resultFromMaybe $ _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
@@ -387,8 +427,8 @@ addFlagStringParams
   -> String -- ^ param name
   -> Flag Void -- ^ properties
   -> CmdParser f out [String]
-addFlagStringParams shorts longs name flag
+addFlagStringParams shorts longs name flag =
-  = addFlagStringParamsAll shorts longs name flag (\_ -> pure ())
+  addFlagStringParamsAll shorts longs name flag (\_ -> pure ())
 
 -- TODO: this implementation is wrong, because it uses addCmdPartManyInpA
 --       while this really is no Many.
@@ -405,13 +445,14 @@ addFlagStringParams shorts longs name flag
 --   = void $ addFlagStringParamsAll shorts longs name flag act
 
 addFlagStringParamsAll
-  :: forall f out . String
+  :: forall f out
-     -> [String]
+   . String
-     -> String
+  -> [String]
-     -> Flag Void -- we forbid the default because it has bad interaction
+  -> String
+  -> Flag Void -- we forbid the default because it has bad interaction
                -- with the eat-anything behaviour of the string parser.
-     -> (String -> f ())
+  -> (String -> f ())
-     -> CmdParser f out [String]
+  -> CmdParser f out [String]
 addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA
   ManyUpperBoundN
   (wrapHidden flag desc)
@@ -425,9 +466,10 @@ addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA
   desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
   desc2 =
     (maybe id (PartDefault . show) $ _flag_default flag) $ PartVariable name
-  parseF :: Input -> Maybe (String, Input)
+  parseF :: PartParser String Input
   parseF inp = case inp of
-    InputString str -> fmap (second InputString) $ parseResult
+    InputString str ->
+      resultFromMaybe $ fmap (second InputString) $ parseResult
      where
       parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
         Data.Foldable.msum $ allStrs <&> \case
@@ -438,16 +480,16 @@ addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA
           let (x, rest) = break Char.isSpace $ dropWhile Char.isSpace i
           StateS.put rest
           pure x
-    InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
+    InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of
-      Just ((), ""          ) -> case argR of
+      Just ((), "") -> case argR of
-        []       -> Nothing
+        []         -> Failure Nothing
-        (x:rest) -> Just (x, InputArgs rest)
+        (x : rest) -> Success x (InputArgs rest)
-      Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)
+      Just ((), remainingStr) -> Success remainingStr (InputArgs argR)
-      Nothing                 -> Nothing
+      Nothing                 -> Failure 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
+    InputArgs _ -> Failure Nothing

src/UI/Butcher/Monadic/IO.hs

@@ -1,7 +1,6 @@
 -- | Turn your CmdParser into an IO () to be used as your program @main@.
 module UI.Butcher.Monadic.IO
   ( mainFromCmdParser
-  , mainFromCmdParserWithHelpDesc
   )
 where
 
@@ -9,17 +8,19 @@ where
 
 #include "prelude.inc"
 import           Control.Monad.Free
-import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
+import qualified Control.Monad.Trans.MultiRWS.Strict
-import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS
+                                               as MultiRWSS
+import qualified Control.Monad.Trans.MultiState.Strict
+                                               as MultiStateS
 
-import qualified Text.PrettyPrint as PP
+import qualified Text.PrettyPrint              as PP
 
 import           Data.HList.ContainsType
 
-import           UI.Butcher.Monadic.Internal.Types
+import           UI.Butcher.Internal.Monadic
-import           UI.Butcher.Monadic.Internal.Core
+import           UI.Butcher.Internal.MonadicTypes
-import           UI.Butcher.Monadic.Pretty
 import           UI.Butcher.Monadic.Param
+import           UI.Butcher.Monadic.Pretty
 
 import           System.IO
 
@@ -37,74 +38,35 @@ import           System.IO
 mainFromCmdParser :: CmdParser Identity (IO ()) () -> IO ()
 mainFromCmdParser cmd = do
   progName <- System.Environment.getProgName
-  case checkCmdParser (Just progName) cmd of
+  case toCmdDesc (Just progName) cmd of
-    Left  e -> do
+    Left e -> do
       putStrErrLn
         $ progName
         ++ ": internal error: failed sanity check for butcher main command parser!"
       putStrErrLn $ "(" ++ e ++ ")"
       putStrErrLn $ "aborting."
-    Right _ -> do
+    Right fullDesc -> do
       args <- System.Environment.getArgs
-      case runCmdParser (Just progName) (InputArgs args) cmd of
+      case runCmdParserCoreFromDesc fullDesc (InputArgs args) cmd of
-        (desc, Left (ParsingError mess remaining)) -> do
+        (desc, _, Left err) -> do
           putStrErrLn
             $  progName
             ++ ": error parsing arguments: "
-            ++ case mess of
+            ++ case _pe_messages err of
-                 []    -> ""
+                 []      -> ""
-                 (m:_) -> m
+                 (m : _) -> m
-          putStrErrLn $ case remaining of
+          putStrErrLn $ case _pe_remaining err 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 [] -> "at the end of input"
-            InputArgs   xs  -> case List.unwords $ show <$> xs of
+            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
+        (desc, _, Right out) -> case 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

src/UI/Butcher/Monadic/Interactive.hs

@@ -1,201 +0,0 @@
--- | Utilities when writing interactive programs that interpret commands,
--- e.g. a REPL.
-module UI.Butcher.Monadic.Interactive
-  ( simpleCompletion
-  , shellCompletionWords
-  , interactiveHelpDoc
-  , partDescStrings
-  )
-where
-
-
-
-#include "prelude.inc"
-
-import qualified Text.PrettyPrint as PP
-
-import           UI.Butcher.Monadic.Internal.Types
-import           UI.Butcher.Monadic.Internal.Core
-import           UI.Butcher.Monadic.Pretty
-
-
-
--- | Derives a potential completion from a given input string and a given
--- 'CommandDesc'. Considers potential subcommands and where available the
--- completion info present in 'PartDesc's.
-simpleCompletion
-  :: String         -- ^ input string
-  -> CommandDesc () -- ^ CommandDesc obtained on that input string
-  -> String         -- ^ "remaining" input after the last successfully parsed
-                    -- subcommand. See 'UI.Butcher.Monadic.runCmdParserExt'.
-  -> String         -- ^ completion, i.e. a string that might be appended
-                    -- to the current prompt when user presses tab.
-simpleCompletion line cdesc pcRest = case reverse line of
-  []              -> compl
-  ' ' : _         -> compl
-  _ | null pcRest -> "" -- necessary to prevent subcommand completion
-                        -- appearing before space that is, if you have command
-                        -- "aaa" with subcommand "sss", we want completion
-                        -- "sss" on "aaa " but not on "aaa".
-  _               -> compl
- where
-  compl = List.drop (List.length lastWord) (longestCommonPrefix choices)
-  longestCommonPrefix [] = ""
-  longestCommonPrefix (c1 : cr) =
-    case find (\s -> List.all (s `isPrefixOf`) cr) $ reverse $ List.inits c1 of
-      Nothing -> ""
-      Just x  -> x
-  nameDesc = case _cmd_mParent cdesc of
-    Nothing -> cdesc
-    Just (_, parent) | null pcRest && not (null lastWord) -> parent
-        -- not finished writing a command. if we have commands abc and abcdef,
-        -- we may want "def" as a completion after "abc".
-    Just{}  -> cdesc
-  lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ line
-  choices :: [String]
-  choices = join
-    [ [ r
-      | (Just r, _) <- Data.Foldable.toList (_cmd_children nameDesc)
-      , lastWord `isPrefixOf` r
-      , lastWord /= r
-      ]
-    , [ s
-      | s <- partDescStrings =<< _cmd_parts nameDesc
-      , lastWord `isPrefixOf` s
-      , lastWord /= s
-      ]
-    ]
-
-
--- | Derives a list of completion items from a given input string and a given
--- 'CommandDesc'. Considers potential subcommands and where available the
--- completion info present in 'PartDesc's.
---
--- See 'addShellCompletion' which uses this.
-shellCompletionWords
-  :: String         -- ^ input string
-  -> CommandDesc () -- ^ CommandDesc obtained on that input string
-  -> String         -- ^ "remaining" input after the last successfully parsed
-                    -- subcommand. See 'UI.Butcher.Monadic.runCmdParserExt'.
-  -> [CompletionItem]
-shellCompletionWords line cdesc pcRest = choices
- where
-  nameDesc = case _cmd_mParent cdesc of
-    Nothing -> cdesc
-    Just (_, parent) | null pcRest && not (null lastWord) -> parent
-        -- not finished writing a command. if we have commands abc and abcdef,
-        -- we may want "def" as a completion after "abc".
-    Just{}  -> cdesc
-  lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ line
-  choices :: [CompletionItem]
-  choices = join
-    [ [ CompletionString r
-      | (Just r, _) <- Data.Foldable.toList (_cmd_children nameDesc)
-      , lastWord `isPrefixOf` r
-      , lastWord /= r
-      ]
-    , [ c
-      | c <- partDescCompletions =<< _cmd_parts cdesc
-      , case c of
-        CompletionString s -> lastWord `isPrefixOf` s && lastWord /= s
-        _                  -> True
-      ]
-    ]
-
-
--- | Produces a 'PP.Doc' as a hint for the user during interactive command
--- input. Takes the current (incomplete) prompt line into account. For example
--- when you have commands (among others) \'config set-email\' and
--- \'config get-email\', then on empty prompt there will be an item \'config\';
--- on the partial prompt \'config \' the help doc will contain the
--- \'set-email\' and \'get-email\' items.
-interactiveHelpDoc
-  :: String         -- ^ input string
-  -> CommandDesc () -- ^ CommandDesc obtained on that input string
-  -> String         -- ^ "remaining" input after the last successfully parsed
-                    -- subcommand. See 'UI.Butcher.Monadic.runCmdParserExt'.
-  -> Int            -- ^ max length of help text
-  -> PP.Doc
-interactiveHelpDoc cmdline desc pcRest maxLines = if
-  | null cmdline             -> helpStrShort
-  | List.last cmdline == ' ' -> helpStrShort
-  | otherwise                -> helpStr
- where
-  helpStr = if List.length optionLines > maxLines
-    then
-      PP.fcat $ List.intersperse (PP.text "|") $ PP.text . fst <$> optionLines
-    else PP.vcat $ optionLines <&> \case
-      (s, "") -> PP.text s
-      (s, h ) -> PP.text s PP.<> PP.text h
-   where
-    nameDesc = case _cmd_mParent desc of
-      Nothing                        -> desc
-      Just (_, parent) | null pcRest -> parent
-      Just{}                         -> desc
-
-    lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ cmdline
-    optionLines :: [(String, String)]
-    optionLines = -- a list of potential words that make sense, given
-                    -- the current input.
-                  join
-      [ [ (s, e)
-        | (Just s, c) <- Data.Foldable.toList (_cmd_children nameDesc)
-        , lastWord `isPrefixOf` s
-        , let e = join $ join
-                [ [ " ARGS" | not $ null $ _cmd_parts c ]
-                , [ " CMDS" | not $ null $ _cmd_children c ]
-                , [ ": " ++ show h | Just h <- [_cmd_help c] ]
-                ]
-        ]
-      , [ (s, "")
-        | s <- partDescStrings =<< _cmd_parts nameDesc
-        , lastWord `isPrefixOf` s
-        ]
-      ]
-  helpStrShort = ppUsageWithHelp desc
-
-
--- | Obtains a list of "expected"/potential strings for a command part
--- described in the 'PartDesc'. In constrast to the 'simpleCompletion'
--- function this function does not take into account any current input, and
--- consequently the output elements can in general not be appended to partial
--- input to form valid input.
-partDescStrings :: PartDesc -> [String]
-partDescStrings = \case
-  PartLiteral  s      -> [s]
-  PartVariable _      -> []
-  -- TODO: we could handle seq of optional and such much better
-  PartOptional x      -> partDescStrings x
-  PartAlts     alts   -> alts >>= partDescStrings
-  PartSeq      []     -> []
-  PartSeq      (x:_)  -> partDescStrings x
-  PartDefault    _  x -> partDescStrings x
-  PartSuggestion ss x -> [ s | CompletionString s <- ss ] ++ partDescStrings x
-  PartRedirect   _  x -> partDescStrings x
-  PartReorder xs      -> xs >>= partDescStrings
-  PartMany    x       -> partDescStrings x
-  PartWithHelp _h x   -> partDescStrings x -- TODO: handle help
-  PartHidden{}        -> []
-
-
--- | Obtains a list of "expected"/potential strings for a command part
--- described in the 'PartDesc'. In constrast to the 'simpleCompletion'
--- function this function does not take into account any current input, and
--- consequently the output elements can in general not be appended to partial
--- input to form valid input.
-partDescCompletions :: PartDesc -> [CompletionItem]
-partDescCompletions = \case
-  PartLiteral  s      -> [CompletionString s]
-  PartVariable _      -> []
-  -- TODO: we could handle seq of optional and such much better
-  PartOptional x      -> partDescCompletions x
-  PartAlts     alts   -> alts >>= partDescCompletions
-  PartSeq      []     -> []
-  PartSeq      (x:_)  -> partDescCompletions x
-  PartDefault    _  x -> partDescCompletions x
-  PartSuggestion ss x -> ss ++ partDescCompletions x
-  PartRedirect   _  x -> partDescCompletions x
-  PartReorder xs      -> xs >>= partDescCompletions
-  PartMany    x       -> partDescCompletions x
-  PartWithHelp _h x   -> partDescCompletions x -- TODO: handle help
-  PartHidden{}        -> []

src/UI/Butcher/Monadic/Param.hs

@@ -21,13 +21,6 @@ module UI.Butcher.Monadic.Param
   , addParamNoFlagStrings
   , addParamRestOfInput
   , addParamRestOfInputRaw
-  , -- * Deprecated for more consistent naming
-    addReadParam
-  , addReadParamOpt
-  , addStringParam
-  , addStringParamOpt
-  , addStringParams
-  , addRestOfInputStringParam
   )
 where
 
@@ -35,23 +28,25 @@ where
 
 #include "prelude.inc"
 import           Control.Monad.Free
-import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
+import qualified Control.Monad.Trans.MultiRWS.Strict
-import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS
+                                               as MultiRWSS
+import qualified Control.Monad.Trans.MultiState.Strict
+                                               as MultiStateS
 
-import qualified Text.PrettyPrint as PP
+import qualified Text.PrettyPrint              as PP
 
 import           Data.HList.ContainsType
 
-import           UI.Butcher.Monadic.Internal.Types
+import           UI.Butcher.Internal.Monadic
-import           UI.Butcher.Monadic.Internal.Core
+import           UI.Butcher.Internal.MonadicTypes
 
 
 
 -- | 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_default     :: Maybe p
-  , _param_help :: Maybe PP.Doc
+  , _param_help        :: Maybe PP.Doc
   , _param_suggestions :: Maybe [CompletionItem]
   }
 
@@ -67,7 +62,7 @@ instance Semigroup (Param p) where
   (<>) = appendParam
 
 instance Monoid (Param p) where
-  mempty = Param Nothing Nothing Nothing
+  mempty  = Param Nothing Nothing Nothing
   mappend = (<>)
 
 -- | Create a 'Param' with just a help text.
@@ -99,116 +94,97 @@ paramDirectory = mempty { _param_suggestions = Just [CompletionDirectory] }
 -- 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.
-addParamRead :: forall f out a
+addParamRead
-              . (Applicative f, Typeable a, Show a, Text.Read.Read a)
+  :: forall f out a
-             => String -- ^ paramater name, for use in usage/help texts
+   . (Applicative f, Typeable a, Show a, Text.Read.Read a)
-             -> Param a -- ^ properties
+  => String -- ^ paramater name, for use in usage/help texts
-             -> CmdParser f out a
+  -> Param a -- ^ properties
-addParamRead = addReadParam
+  -> CmdParser f out a
-{-# DEPRECATED addReadParam "use 'addParamRead'" #-}
+addParamRead name par = addCmdPart desc parseF
-addReadParam :: forall f out a
+ where
-              . (Applicative f, Typeable a, Show a, Text.Read.Read a)
+  desc :: PartDesc
-             => String -- ^ paramater name, for use in usage/help texts
+  desc =
-             -> Param a -- ^ properties
+    addSuggestion (_param_suggestions par)
-             -> CmdParser f out a
+      $ (maybe id PartWithHelp $ _param_help par)
-addReadParam name par = addCmdPart desc parseF
+      $ (maybe id (PartDefault . show) $ _param_default par)
-  where
+      $ PartVariable name
-    desc :: PartDesc
+  parseF :: PartParser a String
-    desc = addSuggestion (_param_suggestions par)
+  parseF s = resultFromMaybe $ case Text.Read.reads s of
-         $ (maybe id PartWithHelp $ _param_help par)
+    ((x, ' ' : r) : _) -> Just (x, dropWhile Char.isSpace r)
-         $ (maybe id (PartDefault . show) $ _param_default par)
+    ((x, []     ) : _) -> Just (x, [])
-         $ PartVariable name
+    _                  -> _param_default par <&> \x -> (x, s)
-    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.
-addParamReadOpt :: forall f out a
+addParamReadOpt
-                 . (Applicative f, Typeable a, Text.Read.Read a)
+  :: forall f out a
-                => String -- ^ paramater name, for use in usage/help texts
+   . (Applicative f, Typeable a, Text.Read.Read a)
-                -> Param a -- ^ properties
+  => String -- ^ paramater name, for use in usage/help texts
-                -> CmdParser f out (Maybe a)
+  -> Param a -- ^ properties
-addParamReadOpt = addReadParamOpt
+  -> CmdParser f out (Maybe a)
-{-# DEPRECATED addReadParamOpt "use 'addParamReadOpt'" #-}
+addParamReadOpt name par = addCmdPart desc parseF
-addReadParamOpt :: forall f out a
+ where
-                 . (Applicative f, Typeable a, Text.Read.Read a)
+  desc :: PartDesc
-                => String -- ^ paramater name, for use in usage/help texts
+  desc =
-                -> Param a -- ^ properties
+    addSuggestion (_param_suggestions par)
-                -> CmdParser f out (Maybe a)
+      $ PartOptional
-addReadParamOpt name par = addCmdPart desc parseF
+      $ (maybe id PartWithHelp $ _param_help par)
-  where
+      $ PartVariable name
-    desc :: PartDesc
+  parseF :: PartParser (Maybe a) String
-    desc = addSuggestion (_param_suggestions par)
+  parseF s = resultFromMaybe $ case Text.Read.reads s of
-         $ PartOptional
+    ((x, ' ' : r) : _) -> Just (Just x, dropWhile Char.isSpace r)
-         $ (maybe id PartWithHelp $ _param_help par)
+    ((x, []     ) : _) -> Just (Just x, [])
-         $ PartVariable name
+    _                  -> Just (Nothing, s) -- TODO: we could warn about a default..
-    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==[String]. See the 'Input' doc
 -- for this distinction.
 addParamString
-  :: forall f out . (Applicative f)
+  :: forall f out
+   . (Applicative f)
   => String
   -> Param String
   -> CmdParser f out String
-addParamString = addStringParam
+addParamString name par = addCmdPartInp desc parseF
-{-# DEPRECATED addStringParam "use 'addParamString'" #-}
+ where
-addStringParam
+  desc :: PartDesc
-  :: forall f out . (Applicative f)
+  desc =
-  => String
+    addSuggestion (_param_suggestions par)
-  -> Param String
+      $ (maybe id PartWithHelp $ _param_help par)
-  -> CmdParser f out String
+      $ PartVariable name
-addStringParam name par = addCmdPartInp desc parseF
+  parseF :: PartParser String Input
-  where
+  parseF (InputString str) =
-    desc :: PartDesc
+    case break Char.isSpace $ dropWhile Char.isSpace str of
-    desc = addSuggestion (_param_suggestions par)
+      ("", rest) ->
-         $ (maybe id PartWithHelp $ _param_help par)
+        resultFromMaybe $ _param_default par <&> \x -> (x, InputString rest)
-         $ PartVariable name
+      (x, rest) -> Success x (InputString rest)
-    parseF :: Input -> Maybe (String, Input)
+  parseF (InputArgs args) = case args of
-    parseF (InputString str)
+    (s1 : sR) -> Success s1 (InputArgs sR)
-      = case break Char.isSpace $ dropWhile Char.isSpace str of
+    [] -> resultFromMaybe $ _param_default par <&> \x -> (x, InputArgs args)
-          ("", 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 'addParamString', but optional, I.e. succeeding with Nothing if
 -- there is no remaining input.
 addParamStringOpt
-  :: forall f out . (Applicative f)
+  :: forall f out
+   . (Applicative f)
   => String
   -> Param Void
   -> CmdParser f out (Maybe String)
-addParamStringOpt = addStringParamOpt
+addParamStringOpt name par = addCmdPartInp desc parseF
-{-# DEPRECATED addStringParamOpt "use 'addParamStringOpt'" #-}
+ where
-addStringParamOpt
+  desc :: PartDesc
-  :: forall f out . (Applicative f)
+  desc =
-  => String
+    addSuggestion (_param_suggestions par)
-  -> Param Void
+      $ PartOptional
-  -> CmdParser f out (Maybe String)
+      $ (maybe id PartWithHelp $ _param_help par)
-addStringParamOpt name par = addCmdPartInp desc parseF
+      $ PartVariable name
-  where
+  parseF :: PartParser (Maybe String) Input
-    desc :: PartDesc
+  parseF (InputString str) =
-    desc = addSuggestion (_param_suggestions par)
+    case break Char.isSpace $ dropWhile Char.isSpace str of
-         $ PartOptional
+      ("", rest) -> Success Nothing (InputString rest)
-         $ (maybe id PartWithHelp $ _param_help par)
+      (x , rest) -> Success (Just x) (InputString rest)
-         $ PartVariable name
+  parseF (InputArgs args) = case args of
-    parseF :: Input -> Maybe (Maybe String, Input)
+    (s1 : sR) -> Success (Just s1) (InputArgs sR)
-    parseF (InputString str)
+    []        -> Success Nothing (InputArgs [])
-      = 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 matches any string of non-space characters if
@@ -220,35 +196,28 @@ addParamStrings
   => String
   -> Param Void
   -> CmdParser f out [String]
-addParamStrings = addStringParams
+addParamStrings name par = addCmdPartManyInp ManyUpperBoundN desc parseF
-{-# DEPRECATED addStringParams "use 'addParamStrings'" #-}
-addStringParams
-  :: forall f out
-   . (Applicative f)
-  => String
-  -> Param Void
-  -> CmdParser f out [String]
-addStringParams name par = addCmdPartManyInp ManyUpperBoundN desc parseF
  where
   desc :: PartDesc
   desc =
     addSuggestion (_param_suggestions par)
       $ (maybe id PartWithHelp $ _param_help par)
       $ PartVariable name
-  parseF :: Input -> Maybe (String, Input)
+  parseF :: PartParser String Input
   parseF (InputString str) =
     case break Char.isSpace $ dropWhile Char.isSpace str of
-      ("", _   ) -> Nothing
+      ("", _   ) -> Failure Nothing
-      (x , rest) -> Just (x, InputString rest)
+      (x , rest) -> Success x (InputString rest)
   parseF (InputArgs args) = case args of
-    (s1:sR) -> Just (s1, InputArgs sR)
+    (s1 : sR) -> Success s1 (InputArgs sR)
-    []      -> Nothing
+    []        -> Failure Nothing
 
 
 -- | Like 'addParamString' but does not match strings starting with a dash.
 -- This prevents misinterpretation of flags as params.
 addParamNoFlagString
-  :: forall f out . (Applicative f)
+  :: forall f out
+   . (Applicative f)
   => String
   -> Param String
   -> CmdParser f out String
@@ -259,16 +228,16 @@ addParamNoFlagString name par = addCmdPartInp desc parseF
     addSuggestion (_param_suggestions par)
       $ (maybe id PartWithHelp $ _param_help par)
       $ PartVariable name
-  parseF :: Input -> Maybe (String, Input)
+  parseF :: PartParser String Input
   parseF (InputString str) =
-    case break Char.isSpace $ dropWhile Char.isSpace str of
+    resultFromMaybe $ case break Char.isSpace $ dropWhile Char.isSpace str of
-      (""   , rest) -> _param_default par <&> \x -> (x, InputString rest)
+      (""     , rest) -> _param_default par <&> \x -> (x, InputString rest)
-      ('-':_, _   ) -> _param_default par <&> \x -> (x, InputString str)
+      ('-' : _, _   ) -> _param_default par <&> \x -> (x, InputString str)
-      (x    , rest) -> Just (x, InputString rest)
+      (x      , rest) -> Just (x, InputString rest)
-  parseF (InputArgs args) = case args of
+  parseF (InputArgs args) = resultFromMaybe $ case args of
-    []           -> _param_default par <&> \x -> (x, InputArgs args)
+    []               -> _param_default par <&> \x -> (x, InputArgs args)
-    (('-':_):_ ) -> _param_default par <&> \x -> (x, InputArgs args)
+    (('-' : _) : _ ) -> _param_default par <&> \x -> (x, InputArgs args)
-    (s1     :sR) -> Just (s1, InputArgs sR)
+    (s1        : sR) -> Just (s1, InputArgs sR)
 
 -- | Like 'addParamStringOpt' but does not match strings starting with a dash.
 -- This prevents misinterpretation of flags as params.
@@ -283,16 +252,16 @@ addParamNoFlagStringOpt name par = addCmdPartInp desc parseF
   desc :: PartDesc
   desc =
     PartOptional $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name
-  parseF :: Input -> Maybe (Maybe String, Input)
+  parseF :: PartParser (Maybe String) Input
   parseF (InputString str) =
     case break Char.isSpace $ dropWhile Char.isSpace str of
-      (""   , rest) -> Just (Nothing, InputString rest)
+      (""     , rest) -> Success Nothing (InputString rest)
-      ('-':_, _   ) -> Just (Nothing, InputString str)
+      ('-' : _, _   ) -> Success Nothing (InputString str)
-      (x    , rest) -> Just (Just x, InputString rest)
+      (x      , rest) -> Success (Just x) (InputString rest)
   parseF (InputArgs args) = case args of
-    []           -> Just (Nothing, InputArgs [])
+    []               -> Success Nothing (InputArgs [])
-    (('-':_):_ ) -> Just (Nothing, InputArgs args)
+    (('-' : _) : _ ) -> Success Nothing (InputArgs args)
-    (s1     :sR) -> Just (Just s1, InputArgs sR)
+    (s1        : sR) -> Success (Just s1) (InputArgs sR)
 
 -- | Like 'addParamStrings' but does not match strings starting with a dash.
 -- This prevents misinterpretation of flags as params.
@@ -309,49 +278,43 @@ addParamNoFlagStrings name par = addCmdPartManyInp ManyUpperBoundN desc parseF
     addSuggestion (_param_suggestions par)
       $ (maybe id PartWithHelp $ _param_help par)
       $ PartVariable name
-  parseF :: Input -> Maybe (String, Input)
+  parseF :: PartParser String Input
   parseF (InputString str) =
     case break Char.isSpace $ dropWhile Char.isSpace str of
-      (""   , _   ) -> Nothing
+      (""     , _   ) -> Failure Nothing
-      ('-':_, _   ) -> Nothing
+      ('-' : _, _   ) -> Failure Nothing
-      (x    , rest) -> Just (x, InputString rest)
+      (x      , rest) -> Success x (InputString rest)
   parseF (InputArgs args) = case args of
-    []           -> Nothing
+    []               -> Failure Nothing
-    (('-':_):_ ) -> Nothing
+    (('-' : _) : _ ) -> Failure Nothing
-    (s1     :sR) -> Just (s1, InputArgs sR)
+    (s1        : sR) -> Success s1 (InputArgs sR)
 
 
 -- | Add a parameter that consumes _all_ remaining input. Typical usecase is
 -- after a "--" as common in certain (unix?) commandline tools.
 addParamRestOfInput
-  :: forall f out . (Applicative f)
-  => String
-  -> Param Void
-  -> CmdParser f out String
-addParamRestOfInput = addRestOfInputStringParam
-{-# DEPRECATED addRestOfInputStringParam "use 'addParamRestOfInput'" #-}
-addRestOfInputStringParam
   :: forall f out
    . (Applicative f)
   => String
   -> Param Void
   -> CmdParser f out String
-addRestOfInputStringParam name par = addCmdPartInp desc parseF
+addParamRestOfInput 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 :: PartParser String Input
-  parseF (InputString str ) = Just (str, InputString "")
+  parseF (InputString str ) = Success str (InputString "")
-  parseF (InputArgs   args) = Just (List.unwords args, InputArgs [])
+  parseF (InputArgs   args) = Success (List.unwords args) (InputArgs [])
 
 
 -- | Add a parameter that consumes _all_ remaining input, returning a raw
 -- 'Input' value.
 addParamRestOfInputRaw
-  :: forall f out . (Applicative f)
+  :: forall f out
+   . (Applicative f)
   => String
   -> Param Void
   -> CmdParser f out Input
@@ -362,7 +325,7 @@ addParamRestOfInputRaw name par = addCmdPartInp desc parseF
     addSuggestion (_param_suggestions par)
       $ (maybe id PartWithHelp $ _param_help par)
       $ PartVariable name
-  parseF :: Input -> Maybe (Input, Input)
+  parseF :: PartParser Input Input
-  parseF i@InputString{} = Just (i, InputString "")
+  parseF i@InputString{} = Success i (InputString "")
-  parseF i@InputArgs{}   = Just (i, InputArgs [])
+  parseF i@InputArgs{}   = Success i (InputArgs [])
 

src/UI/Butcher/Monadic/Pretty.hs

@@ -42,351 +42,4 @@ where
 
 
 
-#include "prelude.inc"
+import           UI.Butcher.Internal.Pretty
-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:
---
--- > example [--short] NAME [version | help]
-ppUsage :: CommandDesc a -> PP.Doc
-ppUsage (CommandDesc mParent _syn _help parts out children _hidden) =
-  pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]
- where
-  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-  pparents Nothing              = PP.empty
-  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
-  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
-  partDocs = Maybe.mapMaybe ppPartDescUsage parts
-  visibleChildren =
-    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
-  subsDoc = case out of
-    _ | null visibleChildren -> PP.empty
-    Nothing | null parts -> subDoc
-            | otherwise  -> PP.parens $ subDoc
-    Just{} -> PP.brackets $ subDoc
-  subDoc =
-    PP.fcat
-      $   PP.punctuate (PP.text " | ")
-      $   Data.Foldable.toList
-      $   (PP.text . fst)
-      <$> visibleChildren
-
--- | ppUsageShortSub exampleDesc yields:
---
--- > example [--short] NAME <command>
---
--- I.e. Subcommands are abbreviated using the @<command>@ label, instead
--- of being listed.
-ppUsageShortSub :: CommandDesc a -> PP.Doc
-ppUsageShortSub (CommandDesc mParent _syn _help parts out children _hidden) =
-  pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]
- where
-  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-  pparents Nothing              = PP.empty
-  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
-  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
-  partDocs = Maybe.mapMaybe ppPartDescUsage parts
-  visibleChildren =
-    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
-  subsDoc = case out of
-    _ | null visibleChildren -> PP.empty
-    Nothing                  -> subDoc
-    Just{}                   -> PP.brackets $ subDoc
-  subDoc = if null visibleChildren then PP.empty else PP.text "<command>"
-
--- | ppUsageWithHelp exampleDesc yields:
---
--- > example [--short] NAME
--- >         [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 _syn help parts out children _hidden) =
-  pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc
- where
-  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-  pparents Nothing              = PP.empty
-  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
-  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
-  partDocs = Maybe.mapMaybe ppPartDescUsage parts
-  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
-      $ [ PP.text n | (Just n, c) <- children, _cmd_visibility c == Visible ]
-  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 = ppUsage <$> descendDescTo strings desc
-
--- | Access a child command's CommandDesc.
-descendDescTo :: [String] -> CommandDesc a -> Maybe (CommandDesc a)
-descendDescTo strings desc = case strings of
-  [] -> Just desc
-  (s : sr) -> do -- Maybe
-    (_, childDesc) <- find ((Just s ==) . fst) (_cmd_children desc)
-    descendDescTo sr childDesc
-
--- | ppHelpShallow 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 =
-  nameSection
-    $+$ usageSection
-    $+$ descriptionSection
-    $+$ partsSection
-    $+$ PP.text ""
- where
-  CommandDesc mParent syn help parts _out _children _hidden = desc
-  nameSection = case mParent of
-    Nothing -> PP.empty
-    Just{} ->
-      PP.text "NAME"
-        $+$ PP.text ""
-        $+$ PP.nest
-              2
-              (case syn of
-                Nothing -> pparents mParent
-                Just s  -> pparents mParent <+> PP.text "-" <+> s
-              )
-        $+$ PP.text ""
-  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-  pparents Nothing              = PP.empty
-  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
-  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
-  usageSection = PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (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 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)]
-          ++ (PP.nest 2 <$> go p)
-      PartReorder ps     -> ps >>= go
-      PartMany    p      -> go p
-      PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
-      PartHidden{}       -> []
-
--- | ppHelpDepthOne exampleDesc yields:
---
--- > NAME
--- > 
--- >   example - a simple butcher example program
--- > 
--- > USAGE
--- > 
--- >   example [--short] NAME <command>
--- > 
--- > DESCRIPTION
--- > 
--- >   a very long help document
--- > 
--- > COMMANDS
--- > 
--- >   version
--- >   help
--- > 
--- > ARGUMENTS
--- > 
--- >   --short             make the greeting short
--- >   NAME                your name, so you can be greeted properly
-ppHelpDepthOne :: CommandDesc a -> PP.Doc
-ppHelpDepthOne desc =
-  nameSection
-    $+$ usageSection
-    $+$ descriptionSection
-    $+$ commandSection
-    $+$ partsSection
-    $+$ PP.text ""
- where
-  CommandDesc mParent syn help parts _out children _hidden = desc
-  nameSection = case mParent of
-    Nothing -> PP.empty
-    Just{} ->
-      PP.text "NAME"
-        $+$ PP.text ""
-        $+$ PP.nest
-              2
-              (case syn of
-                Nothing -> pparents mParent
-                Just s  -> pparents mParent <+> PP.text "-" <+> s
-              )
-        $+$ PP.text ""
-  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-  pparents Nothing              = PP.empty
-  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
-  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
-  usageSection =
-    PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsageShortSub desc)
-  descriptionSection = case help of
-    Nothing -> PP.empty
-    Just h ->
-      PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h
-  visibleChildren =
-    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
-  childDescs = visibleChildren <&> \(n, c) ->
-    PP.text n $$ PP.nest 20 (Maybe.fromMaybe PP.empty (_cmd_synopsis c))
-  commandSection = if null visibleChildren
-    then PP.empty
-    else PP.text "" $+$ PP.text "COMMANDS" $+$ PP.text "" $+$ PP.nest
-      2
-      (PP.vcat $ Data.Foldable.toList childDescs)
-  partsSection = if null partsTuples
-    then PP.empty
-    else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest
-      2
-      (PP.vcat partsTuples)
-  partsTuples :: [PP.Doc]
-  partsTuples = parts >>= go
-   where
-    go = \case
-      PartLiteral{}      -> []
-      PartVariable{}     -> []
-      PartOptional p     -> go p
-      PartAlts     ps    -> ps >>= go
-      PartSeq      ps    -> ps >>= go
-      PartDefault    _ p -> go p
-      PartSuggestion _ p -> go p
-      PartRedirect s p ->
-        [PP.text s $$ PP.nest 20 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)]
-          ++ (PP.nest 2 <$> go p)
-      PartReorder ps     -> ps >>= go
-      PartMany    p      -> go p
-      PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
-      PartHidden{}       -> []
-
--- | Internal helper; users probably won't need this.
-ppPartDescUsage :: PartDesc -> Maybe PP.Doc
-ppPartDescUsage = \case
-  PartLiteral  s -> Just $ PP.text s
-  PartVariable s -> Just $ PP.text s
-  PartOptional p -> PP.brackets <$> rec p
-  PartAlts ps ->
-    [ PP.fcat $ PP.punctuate (PP.text ",") ds
-    | let ds = Maybe.mapMaybe rec ps
-    , not (null ds)
-    ]
-  PartSeq ps -> [ PP.fsep ds | let ds = Maybe.mapMaybe rec ps, not (null ds) ]
-  PartDefault    _   p -> PP.brackets <$> rec p
-  PartSuggestion sgs p -> rec p <&> \d ->
-    case [ PP.text s | CompletionString s <- sgs ] of
-      [] -> d
-      sgsDocs ->
-        PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ sgsDocs ++ [d]
-  PartRedirect s _ -> Just $ PP.text s
-  PartMany p       -> rec p <&> (PP.<> PP.text "+")
-  PartWithHelp _ p -> rec p
-  PartReorder ps ->
-    let flags  = [ d | PartMany d <- ps ]
-        params = filter
-          (\case
-            PartMany{} -> False
-            _          -> True
-          )
-          ps
-    in  Just $ PP.sep
-          [ (PP.fsep $ PP.brackets <$> Maybe.mapMaybe rec flags)
-          , PP.fsep (Maybe.mapMaybe rec params)
-          ]
-  PartHidden{} -> Nothing
-  where rec = ppPartDescUsage
-
--- | Internal helper; users probably won't need this.
-ppPartDescHeader :: PartDesc -> PP.Doc
-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
-  PartHidden  d      -> rec d
-  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 ++ "..\"."
-

src/UI/Butcher/Monadic/Types.hs

@@ -3,7 +3,6 @@
 -- | Types used in the butcher interface.
 module UI.Butcher.Monadic.Types
   ( CommandDesc(..)
-  , cmd_out
   , CmdParser
   , Input (..)
   , ParsingError (..)
@@ -19,4 +18,4 @@ where
 
 
 
-import           UI.Butcher.Monadic.Internal.Types
+import           UI.Butcher.Internal.MonadicTypes

srcinc/prelude.inc

@@ -103,12 +103,14 @@ 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 qualified Control.Monad.Trans.Except as Except
+
 import Data.Functor.Identity ( Identity(..) )
 import Control.Concurrent.Chan ( Chan )
 -- import Control.Concurrent.MVar ( MVar )
 -- import Control.Monad.ST ( ST )
 -- import Data.IORef ( IORef )
-import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), First(..), Last(..), Alt(..), )
+import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), Alt(..), )
 -- import Data.Ord ( Ordering(..), Down(..) )
 -- import Data.Ratio ( Ratio, Rational )
 import Data.Void ( Void )
@@ -160,6 +162,7 @@ import Prelude                            ( Char
                                           , putStrLn
                                           , putStr
                                           , Show (..)
+                                          , Read (..)
                                           , print
                                           , fst
                                           , snd

stack-8-10.yaml

@@ -11,7 +11,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-15.12
+resolver: lts-18.13
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -38,7 +38,8 @@ packages:
 # - git: https://github.com/commercialhaskell/stack.git
 #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
 #
-# extra-deps: []
+extra-deps:
+  - barbies-2.0.2.0
 
 # Override default flag values for local packages and extra-deps
 # flags: {}

stack-8-4.yaml

@@ -42,7 +42,8 @@ extra-deps:
 - deque-0.4.2.3
 - extra-1.7.1
 - strict-list-0.1.5
-- barbies-2.0.1.0
+- barbies-2.0.2.0
+- hsc2hs-0.68.7
 
 # Override default flag values for local packages and extra-deps
 # flags: {}

stack-8-6.yaml

@@ -42,6 +42,7 @@ extra-deps:
 - base-orphans-0.8.1@sha256:defd0057b5db93257528d89b5b01a0fee9738e878c121c686948ac4aa5dded63,2927
 - hashable-1.3.0.0
 - unordered-containers-0.2.10.0
+- barbies-2.0.2.0
 
 # Override default flag values for local packages and extra-deps
 # flags: {}

stack-8-8.yaml

@@ -0,0 +1,66 @@
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-16.31
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+- .
+# The following packages have been ignored due to incompatibility with the
+# resolver compiler, dependency conflicts with other packages
+# or unsatisfied dependencies.
+#- .
+
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+extra-deps:
+  - barbies-2.0.2.0
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.1"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

stack-8-8_.yaml

@@ -0,0 +1,100 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver:
+  compiler: ghc-8.8.1
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+# The following packages have been ignored due to incompatibility with the
+# resolver compiler, dependency conflicts with other packages
+# or unsatisfied dependencies.
+- .
+
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+extra-deps:
+- bifunctors-5.5.5@sha256:e89def05aa5a9c729435592c11a35b54747558b1ec15c7283c7d61df03873ab6,3300
+- deque-0.4.2.3@sha256:7cc8ddfc77df351ff9c16e838ccdb4a89f055c80a3111e27eba8d90e8edde7d0,1853
+- extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af,2705
+- free-5.1.2@sha256:cd57d8cbaf8ef37620219095694b83e3b3baf3b06e1c59f422a4954d3a5f4c42,4116
+- microlens-0.4.11.2@sha256:765ec5cdd12a459e65161f0e3cdbce84652bf634d62af3911ba24e4bf8d4d944,4455
+- microlens-th-0.4.3.2@sha256:dd09aa02b7dc235a91b1e9ea6cd4be2f24c74ef067bc4e5fa2a5453c8b999d2c,2199
+- multistate-0.8.0.2@sha256:fbb0d8ade9ef73c8ed92488f5804d0ebe75d3a9c24bf53452bc3a4f32b34cb2e,3713
+- unsafe-0.0@sha256:93e58ac9aa1f4f9c50e12662a211f6c0b6f28b65c570ff17359851451c9bcb3a,1851
+- void-0.7.3@sha256:13d30f62fcdf065e595d679d4ac8b4b0c1bb1a1b73db7b5b5a8f857cb5c8a546,1857
+- base-orphans-0.8.1@sha256:defd0057b5db93257528d89b5b01a0fee9738e878c121c686948ac4aa5dded63,2927
+- clock-0.8@sha256:b4ae207e2d3761450060a0d0feb873269233898039c76fceef9cc1a544067767,4113
+- comonad-5.0.5@sha256:b33bc635615647916e374a27e96c3de4df390684001eab6291283471cd3a9b62,3345
+- distributive-0.6@sha256:26507cf231eb10db1eb54bc358477418ce87d5077ff76c66743925fb49494b54,3018
+- exceptions-0.10.3@sha256:6e8e66f3acf2ea59f9e100c55a885591c1981789ac2222022ff523c30990efb8,2251
+- monad-control-1.0.2.3@sha256:a3ae888d2fed2e2a0ca33ae11e2480219e07312bccf1a02ffe2ba2e3ec5913ee,2255
+- profunctors-5.4@sha256:545fdbc05131fa29e6612e915ec5d4dadfbcf3a6def86c8b95ca26593b21b259,2073
+- semigroupoids-5.3.3@sha256:260b62cb8539bb988e7f551f10a45ef1c81421c0d79010e9bde9321bad4982a7,7363
+- semigroups-0.19.1@sha256:ecae129621e0d2f77bef2f01e4458c2e0567ab6e1f39579c61d7cec8058ebb0e,6262
+- strict-list-0.1.4@sha256:0fa869e2c21b710b7133e8628169f120fe6299342628edd3d5087ded299bc941,1631
+- tagged-0.8.6@sha256:7093ee39c9779beeacffa4b0035a0e8a25da16afcd1c1a876930207fb8e31d1c,2606
+- th-abstraction-0.3.1.0@sha256:96042f6658f2dccfac03b33f0fd59f62b1f65b9b0a765d8a2ea6026f4081ee4a,1838
+- transformers-base-0.4.5.2@sha256:e4d8155470905ba2942033a1537fc4cf91927d1c9b34693fd57ddf3bc02334af,1550
+- cabal-doctest-1.0.7@sha256:2a9d524b9593fc5054c0bcfda9aeaffd4203f3663b77fab57db35ddd48ce6ad3,1573
+- contravariant-1.5.2@sha256:853259271870000c007a281f0bf0bf6e1aaa97c5fd5cd5734d7b0d79b9de2af5,2761
+- hashable-1.3.0.0@sha256:7ad8edaa681e81162ddddb4d703a9cffe6a0c9ddcfede31cf6569507ed3f1ddb,5179
+- transformers-compat-0.6.5@sha256:50b00c57bf3fc379ec2477bfc261a2aebc983084488478adb29854f193af4696,5490
+- unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204,5199
+- StateVar-1.2@sha256:9ab3e4a0e252d28bc2f799c83e0725c3e23e8d3b722cff0fdb9822e64b6c16ac,1413
+
+allow-newer: True
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.1"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

stack-9-0.yaml

@@ -0,0 +1,30 @@
+resolver: lts-19.33
+
+packages:
+- .
+
+extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.1"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor