.gitignore

@@ -7,7 +7,6 @@
 /*.pdf
 dist/
 dist-newstyle/
-ci-out/
 .cabal-sandbox/
 .stack-work/
 cabal.sandbox.config
@@ -15,7 +14,3 @@ cabal.sandbox.config
 \#*.gui\#
 cabal.project.local
 .ghc.environment.*
-/result*
-/nix/seaaye-cache
-/nix/gcroots
-/nix/ci-out

ChangeLog.md

@@ -1,55 +1,5 @@
 # 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
-* Drop support for ghc < 8.4
-* Fix a somewhat hidden issue in the cabal file
-* Add support for building / testing via haskell.nix nixpkgs overlay
-
-## 1.3.3.1  -- April 2020
-
-* Fix a cabal file mistake
-
-## 1.3.3.0  -- April 2020
-
-* Fix bug with params with default when parsing from commandline
-* Add the `descendDescTo` function
-
 ## 1.3.2.3  -- June 2019
 
 * Fix broken build when using deque>=0.3

README.md

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

butcher.cabal

@@ -1,13 +1,12 @@
-cabal-version:       2.2
 name:                butcher
-version:             2.0.0.0
+version:             1.3.2.3
 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:             BSD-3-Clause
+license:             BSD3
 license-file:        LICENSE
 author:              Lennart Spitzner
 maintainer:          Lennart Spitzner <hexagoxel@hexagoxel.de>
-copyright:           Copyright (C) 2016-2020 Lennart Spitzner
+copyright:           Copyright (C) 2016-2019 Lennart Spitzner
 category:            UI
 build-type:          Simple
 Stability:           experimental
@@ -16,6 +15,7 @@ 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,11 +24,6 @@ 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
@@ -37,23 +32,12 @@ library
                        UI.Butcher.Monadic.Flag
                        UI.Butcher.Monadic.Pretty
                        UI.Butcher.Monadic.IO
+                       UI.Butcher.Monadic.Interactive
                        UI.Butcher.Monadic.BuiltinCommands
-                       UI.Butcher.Applicative.Command
+  other-modules:       UI.Butcher.Monadic.Internal.Types
-                       UI.Butcher.Applicative.Param
+                       UI.Butcher.Monadic.Internal.Core
-                       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.17
+    { base >=4.9 && <4.14
     , free < 5.2
     , unsafe < 0.1
     , microlens <0.5
@@ -63,12 +47,10 @@ library
     , containers <0.7
     , transformers <0.6
     , mtl <2.3
-    , extra <1.8
+    , extra <1.7
     , 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
@@ -125,12 +107,10 @@ test-suite tests
     , deque
     , hspec
     }
-  ghc-options:      -Wall -rtsopts
+  ghc-options:      -Wall
   main-is:          TestMain.hs
   other-modules:    
   hs-source-dirs:   src-tests
-  include-dirs:
-    srcinc
   default-extensions: {
     CPP
 
@@ -152,64 +132,3 @@ 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 +0,0 @@
-(import ./nix/all.nix).default.butcher

example1.md

@@ -0,0 +1,81 @@
+## 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

@@ -0,0 +1,24 @@
+## 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

@@ -0,0 +1,45 @@
+## 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

@@ -1,39 +0,0 @@
-{-# 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

@@ -1,33 +0,0 @@
-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

@@ -1,69 +0,0 @@
-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

@@ -1,27 +0,0 @@
-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
-

seaaye.nix

@@ -1,74 +0,0 @@
-{ 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 +0,0 @@
-(import ./nix/all.nix).default.shell

src-tests/TestMain.hs

@@ -4,12 +4,13 @@ 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
 
 
 
@@ -18,9 +19,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
@@ -30,102 +31,93 @@ checkTests = do
 
 simpleParseTest :: Spec
 simpleParseTest = do
-  it "failed parse 001"
+  it "failed parse 001" $ runCmdParser Nothing (InputString "foo") testCmd1
-    $ let r = runCmdParserSimpleString "foo" testCmd1
+         `shouldSatisfy` Data.Either.isLeft . snd
-      in  r `shouldSatisfy` Data.Either.isLeft
+  it "toplevel" $ (testParse testCmd1 "" >>= _cmd_out)
-  it "toplevel" $ (testParse testCmd1 "") `shouldBe` Nothing
+                  `shouldSatisfy` Maybe.isNothing
-  it "hasImpl 001" $ (testParse testCmd1 "abc") `shouldSatisfy` Maybe.isJust
+  it "hasImpl 001" $ (testParse testCmd1 "abc" >>= _cmd_out)
-  it "hasImpl 002" $ (testParse testCmd1 "def") `shouldSatisfy` Maybe.isJust
+                  `shouldSatisfy` Maybe.isJust
+  it "hasImpl 002" $ (testParse testCmd1 "def" >>= _cmd_out)
+                  `shouldSatisfy` Maybe.isJust
 
 
 simpleRunTest :: Spec
 simpleRunTest = do
-  it "failed run" $ testRun testCmd1 "" `shouldBeRight` Nothing
+  it "failed run" $ testRun testCmd1 "" `shouldBe` Right Nothing
   describe "no reordering" $ do
-    it "cmd 1" $ testRun testCmd1 "abc" `shouldBeRight` (Just 100)
+    it "cmd 1" $ testRun testCmd1 "abc" `shouldBe` Right (Just 100)
-    it "cmd 2" $ testRun testCmd1 "def" `shouldBeRight` (Just 200)
+    it "cmd 2" $ testRun testCmd1 "def" `shouldBe` Right (Just 200)
-    it "flag 1" $ testRun testCmd1 "abc -f" `shouldBeRight` (Just 101)
+    it "flag 1" $ testRun testCmd1 "abc -f" `shouldBe` Right (Just 101)
-    it "flag 2" $ testRun testCmd1 "abc --flong" `shouldBeRight` (Just 101)
+    it "flag 2" $ testRun testCmd1 "abc --flong" `shouldBe` Right (Just 101)
-    it "flag 3" $ testRun testCmd1 "abc -f -f" `shouldBeRight` (Just 101)
+    it "flag 3" $ testRun testCmd1 "abc -f -f" `shouldBe` Right (Just 101)
-    it "flag 4" $ testRun testCmd1 "abc -f -g" `shouldBeRight` (Just 103)
+    it "flag 4" $ testRun testCmd1 "abc -f -g" `shouldBe` Right (Just 103)
-    it "flag 5"
+    it "flag 5" $ testRun testCmd1 "abc -f -g -f" `shouldSatisfy` Data.Either.isLeft -- no reordering
-      $               testRun testCmd1 "abc -f -g -f"
+    it "flag 6" $ testRun testCmd1 "abc -g -f" `shouldSatisfy` Data.Either.isLeft -- no reordering
-      `shouldSatisfy` Data.Either.isLeft -- no reordering
+    it "flag 7" $ testRun testCmd1 "abc -g -g" `shouldBe` Right (Just 102)
-    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" `shouldBeRight` (Just 100)
+    it "cmd 1" $ testRun testCmd2 "abc" `shouldBe` Right (Just 100)
-    it "cmd 2" $ testRun testCmd2 "def" `shouldBeRight` (Just 200)
+    it "cmd 2" $ testRun testCmd2 "def" `shouldBe` Right (Just 200)
-    it "flag 1" $ testRun testCmd2 "abc -f" `shouldBeRight` (Just 101)
+    it "flag 1" $ testRun testCmd2 "abc -f" `shouldBe` Right (Just 101)
-    it "flag 2" $ testRun testCmd2 "abc --flong" `shouldBeRight` (Just 101)
+    it "flag 2" $ testRun testCmd2 "abc --flong" `shouldBe` Right (Just 101)
-    it "flag 3" $ testRun testCmd2 "abc -f -f" `shouldBeRight` (Just 101)
+    it "flag 3" $ testRun testCmd2 "abc -f -f" `shouldBe` Right (Just 101)
-    it "flag 4" $ testRun testCmd2 "abc -f -g" `shouldBeRight` (Just 103)
+    it "flag 4" $ testRun testCmd2 "abc -f -g" `shouldBe` Right (Just 103)
-    it "flag 5" $ testRun testCmd2 "abc -f -g -f" `shouldBeRight` (Just 103)
+    it "flag 5" $ testRun testCmd2 "abc -f -g -f" `shouldBe` Right (Just 103)
-    it "flag 6" $ testRun testCmd2 "abc -g -f" `shouldBeRight` (Just 103)
+    it "flag 6" $ testRun testCmd2 "abc -g -f" `shouldBe` Right (Just 103)
-    it "flag 7" $ testRun testCmd2 "abc -g -g" `shouldBeRight` (Just 102)
+    it "flag 7" $ testRun testCmd2 "abc -g -g" `shouldBe` Right (Just 102)
   describe "with action" $ do
-    it "flag 1" $ testRunA testCmd3 "abc" `shouldBeRight` 0
+    it "flag 1" $ testRunA testCmd3 "abc" `shouldBe` Right 0
-    it "flag 2" $ testRunA testCmd3 "abc -f" `shouldBeRight` 1
+    it "flag 2" $ testRunA testCmd3 "abc -f" `shouldBe` Right 1
-    it "flag 3" $ testRunA testCmd3 "abc -g" `shouldBeRight` 2
+    it "flag 3" $ testRunA testCmd3 "abc -g" `shouldBe` Right 2
-    it "flag 4" $ testRunA testCmd3 "abc -f -g" `shouldBeRight` 3
+    it "flag 4" $ testRunA testCmd3 "abc -f -g" `shouldBe` Right 3
-    it "flag 5" $ testRunA testCmd3 "abc -g -f" `shouldBeRight` 3
+    it "flag 5" $ testRunA testCmd3 "abc -g -f" `shouldBe` Right 3
+  describe "separated children" $ do
+    it "case 1" $ testRun testCmd4 "a aa" `shouldBe` Right (Just 1)
+    it "case 2" $ testRun testCmd4 "a ab" `shouldBe` Right (Just 2)
+    it "case 3" $ testRun testCmd4 "b ba" `shouldBe` Right (Just 3)
+    it "case 4" $ testRun testCmd4 "b bb" `shouldBe` Right (Just 4)
+    it "doc" $ show (ppHelpShallow (getDoc "" testCmd4)) `shouldBe`
+      List.unlines
+        [ "NAME"
+        , ""
+        , "  test"
+        , ""
+        , "USAGE"
+        , ""
+        , "  test a | b"
+        ]
+    it "doc" $ show (ppHelpShallow (getDoc "a" testCmd4)) `shouldBe`
+      List.unlines
+        [ "NAME"
+        , ""
+        , "  test a"
+        , ""
+        , "USAGE"
+        , ""
+        , "  test a aa | ab"
+        ]
   describe "read flags" $ do
-    it "flag 1" $ testRun testCmd5 "abc" `shouldBeRight` (Just 10)
+    it "flag 1" $ testRun testCmd5 "abc" `shouldBe` Right (Just 10)
-    it "flag 2" $ testRun testCmd5 "abc -f 2" `shouldBeRight` (Just 2)
+    it "flag 2" $ testRun testCmd5 "abc -f 2" `shouldBe` Right (Just 2)
-    it "flag 3" $ testRun testCmd5 "abc --flag 3" `shouldBeRight` (Just 3)
+    it "flag 3" $ testRun testCmd5 "abc --flag 3" `shouldBe` Right (Just 3)
-    it "flag 4" $ testRun testCmd5 "abc -f=4" `shouldBeRight` (Just 4)
+    it "flag 4" $ testRun testCmd5 "abc -f=4" `shouldBe` Right (Just 4)
-    it "flag 5" $ testRun testCmd5 "abc --flag=5" `shouldBeRight` (Just 5)
+    it "flag 5" $ testRun testCmd5 "abc --flag=5" `shouldBe` Right (Just 5)
     it "flag 6" $ testRun testCmd5 "abc -f" `shouldSatisfy` Data.Either.isLeft
-    it "flag 7"
+    it "flag 6" $ testRun testCmd5 "abc -flag 0" `shouldSatisfy` Data.Either.isLeft
-      $               testRun testCmd5 "abc -flag 0"
+    it "flag 6" $ testRun testCmd5 "abc --f 0" `shouldSatisfy` Data.Either.isLeft
-      `shouldSatisfy` Data.Either.isLeft
-    it "flag 8"
-      $               testRun testCmd5 "abc --f 0"
-      `shouldSatisfy` Data.Either.isLeft
   describe "addParamStrings" $ do
-    it "case 1" $ testRun' testCmd6 "" `shouldBeRight` (Just ([], 0))
+    it "case 1" $ testRun' testCmd6 "" `shouldBe` Right (Just ([], 0))
-    it "case 2" $ testRun' testCmd6 "-f" `shouldBeRight` (Just ([], 1))
+    it "case 2" $ testRun' testCmd6 "-f" `shouldBe` Right (Just ([], 1))
-    it "case 3" $ testRun' testCmd6 "abc" `shouldBeRight` (Just (["abc"], 0))
+    it "case 3" $ testRun' testCmd6 "abc" `shouldBe` Right (Just (["abc"], 0))
-    it "case 4"
+    it "case 4" $ testRun' testCmd6 "abc def" `shouldBe` Right (Just (["abc", "def"], 0))
-      $               testRun' testCmd6 "abc def"
+    it "case 5" $ testRun' testCmd6 "-g abc def" `shouldBe` Right (Just (["abc", "def"], 2))
-      `shouldBeRight` (Just (["abc", "def"], 0))
+    it "case 6" $ testRun' testCmd6 "-f -g def" `shouldBe` Right (Just (["def"], 3))
-    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 "" `shouldBeRight` (Just ([], 0))
+    it "case 1" $ testRun' testCmd7 "" `shouldBe` Right (Just ([], 0))
-    it "case 2" $ testRun' testCmd7 "-f" `shouldBeRight` (Just ([], 1))
+    it "case 2" $ testRun' testCmd7 "-f" `shouldBe` Right (Just ([], 1))
-    it "case 3" $ testRun' testCmd7 "abc" `shouldBeRight` (Just (["abc"], 0))
+    it "case 3" $ testRun' testCmd7 "abc" `shouldBe` Right (Just (["abc"], 0))
-    it "case 4" $ testRun' testCmd7 "abc -f" `shouldBeRight` (Just (["abc"], 1))
+    it "case 4" $ testRun' testCmd7 "abc -f" `shouldBe` Right (Just (["abc"], 1))
-    it "case 5"
+    it "case 5" $ testRun' testCmd7 "-g abc -f" `shouldBe` Right (Just (["abc"], 3))
-      $               testRun' testCmd7 "-g abc -f"
+    it "case 6" $ testRun' testCmd7 "abc -g def" `shouldBe` Right (Just (["abc", "def"], 2))
-      `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" `shouldBeRight` (Just 110)
-    it "case  5" $ testRun testCmdParam "False y" `shouldBeRight` (Just 310)
-    it "case  6" $ testRun testCmdParam "True n" `shouldBeRight` (Just 1110)
-    it "case  7" $ testRun testCmdParam "True y" `shouldBeRight` (Just 1310)
-    it "case  8" $ testRun testCmdParam "1 False y" `shouldBeRight` (Just 301)
-    it "case  9"
-      $               testRun testCmdParam "1 False y def"
-      `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"
@@ -173,8 +165,8 @@ testCmd3 :: CmdParser (StateS.State Int) () ()
 testCmd3 = do
   addCmd "abc" $ do
     reorderStart
-    addSimpleBoolFlagA "f" ["flong"] mempty (StateS.modify (+ 1))
+    addSimpleFlagA "f" ["flong"] mempty (StateS.modify (+1))
-    addSimpleBoolFlagA "g" ["glong"] mempty (StateS.modify (+ 2))
+    addSimpleFlagA "g" ["glong"] mempty (StateS.modify (+2))
     reorderStop
     addCmdImpl ()
   addCmd "def" $ do
@@ -198,13 +190,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
@@ -214,8 +206,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
@@ -223,21 +215,6 @@ testCmd7 = do
     when g $ WriterS.tell 2
     pure args
 
-testCmdParam :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
-testCmdParam = do
-  p :: Int <- addParamRead "INT" (paramDefault 10)
-  b        <- addParamRead "MANDR" mempty
-  r        <- addParamReadOpt "MAY1" (paramDefault 20)
-  s        <- addParamString "MAND" mempty
-  q        <- addParamString "STR" (paramDefault "abc")
-  addCmdImpl $ do
-    WriterS.tell (Sum p)
-    when (q == "abc") $ WriterS.tell 100
-    r `forM_` (WriterS.tell . Sum)
-    when b $ WriterS.tell $ Sum 1000
-    when (s == "y") $ WriterS.tell 200
-    pure ()
-
 completionTestCmd :: CmdParser Identity () ()
 completionTestCmd = do
   addCmd "abc" $ do
@@ -251,46 +228,32 @@ completionTestCmd = do
       addCmdImpl ()
 
 testCompletion :: CmdParser Identity a () -> String -> String
-testCompletion p inp =
+testCompletion p inp = case runCmdParserExt Nothing (InputString inp) p of
-  _ppi_inputSugg $ runCmdParser Nothing (InputString inp) p
+  (cDesc, InputString cRest, _) -> simpleCompletion inp cDesc cRest
+  _ -> error "wut"
 
 
-testParse :: CmdParser Identity out () -> String -> Maybe out
+testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out)
-testParse cmd s = case runCmdParserSimpleString s cmd of
+testParse cmd s = either (const Nothing) Just
-  Left{}  -> Nothing
+                $ snd
-  Right o -> Just o
+                $ runCmdParser Nothing (InputString s) cmd
 
-testRun
+testRun :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () -> String -> Either ParsingError (Maybe Int)
-  :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
+testRun cmd s = fmap (fmap (getSum . WriterS.execWriter) . _cmd_out)
-  -> String
+              $ snd
-  -> Either ParsingError (Maybe Int)
+              $ runCmdParser Nothing (InputString s) cmd
-testRun cmd s =
-  fmap (fmap (getSum . WriterS.execWriter)) $ _ppi_value $ runCmdParser
-    Nothing
-    (InputString s)
-    cmd
 
-testRun'
+testRun' :: CmdParser Identity (WriterS.Writer (Sum Int) a) () -> String -> Either ParsingError (Maybe (a, Int))
-  :: CmdParser Identity (WriterS.Writer (Sum Int) a) ()
-  -> String
-  -> Either ParsingError (Maybe (a, Int))
 testRun' cmd s =
-  fmap (fmap (fmap getSum . WriterS.runWriter)) $ _ppi_value $ runCmdParser
+  fmap (fmap (fmap getSum . WriterS.runWriter) . _cmd_out) $ snd $ runCmdParser
     Nothing
     (InputString s)
     cmd
 
-testRunA
+testRunA :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError Int
-  :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError Int
+testRunA cmd str = (\((_, e), s) -> e $> s)
-testRunA cmd str = case StateS.runState act (0 :: Int) of
+                 $ flip StateS.runState (0::Int)
-  (info, s) -> _ppi_value info $> s
+                 $ runCmdParserA Nothing (InputString str) cmd
-  where act = runCmdParserA Nothing (InputString str) cmd
 
-getDoc :: String -> CmdParser Identity out () -> CommandDesc
+getDoc :: String -> CmdParser Identity out () -> CommandDesc ()
-getDoc s p = _ppi_mainDesc $ runCmdParser (Just "test") (InputString s) p
+getDoc s = fst . runCmdParser (Just "test") (InputString s)
-
-
-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

@@ -1,210 +0,0 @@
-{-# 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

@@ -1,28 +0,0 @@
-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

@@ -1,298 +0,0 @@
-{-# 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

@@ -1,69 +0,0 @@
--- | 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

@@ -1,300 +0,0 @@
-{-# 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

@@ -1,45 +0,0 @@
-
--- | 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

@@ -1,421 +0,0 @@
-{-# 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

@@ -1,99 +0,0 @@
-{-# 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

@@ -1,42 +0,0 @@
-{-# 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/Interactive.hs

@@ -1,157 +0,0 @@
--- | 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

@@ -1,141 +0,0 @@
-{-# 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

@@ -1,394 +0,0 @@
-
--- | 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,22 +4,24 @@ module UI.Butcher.Monadic
     Input (..)
   , CmdParser
   , ParsingError (..)
-  , PartialParseInfo (..)
+  , CommandDesc(_cmd_out)
-  , CommandDesc
+  , cmd_out
   , -- * Run or Check CmdParsers
-    runCmdParserSimpleString
+    runCmdParserSimple
   , runCmdParser
+  , runCmdParserExt
   , runCmdParserA
-  , runCmdParserFromDesc
+  , runCmdParserAExt
-  , runCmdParserAFromDesc
   , runCmdParserWithHelpDesc
-  , toCmdDesc
+  , checkCmdParser
   , -- * Building CmdParsers
     module UI.Butcher.Monadic.Command
     -- * PrettyPrinting CommandDescs (usage/help)
   , module UI.Butcher.Monadic.Pretty
     -- * Wrapper around System.Environment.getArgs
   , module UI.Butcher.Monadic.IO
+    -- * Utilities for interactive feedback of commandlines (completions etc.)
+  , module UI.Butcher.Monadic.Interactive
   -- , cmds
   -- , sample
   -- , test
@@ -43,14 +45,14 @@ where
 
 #include "prelude.inc"
 
-import           UI.Butcher.Internal.Monadic
+import UI.Butcher.Monadic.Types
-import           UI.Butcher.Internal.MonadicTypes
+import UI.Butcher.Monadic.Internal.Types
-import           UI.Butcher.Internal.Interactive
+import UI.Butcher.Monadic.Command
-import           UI.Butcher.Monadic.BuiltinCommands
+import UI.Butcher.Monadic.BuiltinCommands
-import           UI.Butcher.Monadic.Command
+import UI.Butcher.Monadic.Internal.Core
-import           UI.Butcher.Monadic.IO
+import UI.Butcher.Monadic.Pretty
-import           UI.Butcher.Monadic.Pretty
+import UI.Butcher.Monadic.IO
-import           UI.Butcher.Monadic.Types
+import UI.Butcher.Monadic.Interactive
 
 import qualified Text.PrettyPrint as PP
 
@@ -66,7 +68,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
@@ -74,91 +76,27 @@ 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, Input, Either ParsingError (Maybe out))
+  -> (CommandDesc (), Either ParsingError (CommandDesc out))
 runCmdParserWithHelpDesc mProgName input cmdF =
   let (checkResult, fullDesc)
         -- knot-tying at its finest..
-        = ( toCmdDesc mProgName (cmdF fullDesc)
+        = ( checkCmdParser mProgName (cmdF fullDesc)
           , either (const emptyCommandDesc) id $ checkResult
           )
-  in runCmdParserCoreFromDesc fullDesc input (cmdF fullDesc)
+  in runCmdParser mProgName input (cmdF fullDesc)
 
 
 -- | Wrapper around 'runCmdParser' for very simple usage: Accept a @String@
 -- input and return only the output from the parser, or a plain error string
 -- on failure.
-runCmdParserSimpleString :: String -> CmdParser Identity out () -> Either String out
+runCmdParserSimple :: String -> CmdParser Identity out () -> Either String out
-runCmdParserSimpleString s p = case toCmdDesc Nothing p of
+runCmdParserSimple s p = case snd $ runCmdParser Nothing (InputString s) p of
-  Left err -> Left err
+  Left e -> Left $ parsingErrorString e
-  Right fullDesc -> 
+  Right desc ->
-    case runCmdParserCoreFromDesc fullDesc (InputString s) p of
+    maybe (Left "command has no implementation") Right $ _cmd_out desc
-      (_, _, 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
 --------------------------------------
@@ -217,23 +155,22 @@ 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 toCmdDesc (Just "butcher") _cmds of
+_test2 = case checkCmdParser (Just "butcher") _cmds of
   Left e -> putStrLn $ "LEFT: " ++ e
   Right desc -> do
     print $ ppUsage desc
     print $ maybe undefined id $ ppUsageAt ["hello"] desc
 
 _test3 :: String -> IO ()
-_test3 s = do
+_test3 s = case runCmdParser (Just "butcher") (InputString s) _cmds of
-  case _ppi_value info of
+  (desc, Left e) -> do
-    Left err -> do
+    print e
-      print err
+    print $ ppHelpShallow desc
-      print $ ppHelpShallow (_ppi_localDesc info)
+    _cmd_mParent desc `forM_` \(_, d) -> do
-      _cmd_mParent (_ppi_localDesc info) `forM_` \(_, d) -> do
+      print $ ppUsage d
-        print $ ppUsage d
+  (desc, Right out) -> do
-    Right Nothing -> do
+    case _cmd_out out of
-      putStrLn "command is missing implementation!"
+      Nothing -> do
-      print $ ppHelpShallow (_ppi_localDesc info)
+        putStrLn "command is missing implementation!"
-    Right (Just f) -> f
+        print $ ppHelpShallow desc
- where
+      Just f -> f
-  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.Internal.MonadicTypes
+import           UI.Butcher.Monadic.Internal.Types
-import           UI.Butcher.Internal.Monadic
+import           UI.Butcher.Monadic.Internal.Core
-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 -> CmdParser f (IO ()) ()
+addHelpCommand :: Applicative f => CommandDesc a -> 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 -> CmdParser f (IO ()) ()
+addHelpCommand2 :: Applicative f => CommandDesc a -> 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 -> IO String)
+  => (CommandDesc a -> IO String)
-  -> CommandDesc
+  -> CommandDesc a
   -> 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 -> CommandDesc
+      descent :: [String] -> CommandDesc a -> CommandDesc a
       descent [] curDesc = curDesc
       descent (w:wr) curDesc =
         case
@@ -110,7 +110,6 @@ 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
@@ -123,18 +122,16 @@ addShellCompletionCommand mainCmdParser = do
         "generate possible completions for given input arguments"
       rest <- addParamRestOfInputRaw "REALCOMMAND" mempty
       addCmdImpl $ do
-        let (cdesc, remaining, result) =
+        let (cdesc, remaining, _result) =
-              runCmdParserCoreFromDesc desc rest mainCmdParser
+              runCmdParserExt Nothing rest mainCmdParser
         let
-          info = combinedCompletion  rest
+          compls = shellCompletionWords (inputString rest)
-                     desc
                                         cdesc
-                                        remaining
+                                        (inputString remaining)
-                                        result
         let lastWord =
               reverse $ takeWhile (not . Char.isSpace) $ reverse $ inputString
                 rest
-        putStrLn $ List.unlines $ _ppi_choices info <&> \case
+        putStrLn $ List.unlines $ compls <&> \case
           CompletionString s  -> s
           CompletionFile      -> "$(compgen -f -- " ++ lastWord ++ ")"
           CompletionDirectory -> "$(compgen -d -- " ++ lastWord ++ ")"
@@ -148,7 +145,7 @@ addShellCompletionCommand mainCmdParser = do
 --
 -- > $ source <(foo completion bash-script foo)
 addShellCompletionCommand'
-  :: (CommandDesc -> CmdParser Identity (IO ()) ())
+  :: (CommandDesc out -> 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,7 +62,6 @@ module UI.Butcher.Monadic.Command
   , reorderStart
   , reorderStop
   , withReorder
-  , traverseBarbie
   , peekCmdDesc
   , peekInput
     -- * Building CmdParsers - myprog -v --input PATH
@@ -77,8 +76,6 @@ module UI.Butcher.Monadic.Command
   , addAlternatives
   , ManyUpperBound (..)
   , varPartDesc
-  , PartParser
-  , PartParseResult(..)
   )
 where
 
@@ -86,8 +83,10 @@ 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,19 +32,17 @@ where
 
 #include "prelude.inc"
 import           Control.Monad.Free
-import qualified Control.Monad.Trans.MultiRWS.Strict
+import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
-                                               as MultiRWSS
+import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS
-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.Internal.Monadic
+import           UI.Butcher.Monadic.Internal.Types
-import           UI.Butcher.Internal.MonadicTypes
+import           UI.Butcher.Monadic.Internal.Core
 
-import           Data.List.Extra                ( firstJust )
+import           Data.List.Extra ( firstJust )
 
 
 
@@ -59,7 +57,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 ()
@@ -94,7 +92,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.
@@ -132,18 +130,22 @@ addSimpleBoolFlag
 addSimpleBoolFlag shorts longs flag =
   addSimpleBoolFlagAll shorts longs flag (pure ())
 
--- | Applicative-enabled version of 'addSimpleBoolFlag'
+-- | Applicative-enabled version of 'addSimpleFlag'
-addSimpleBoolFlagA
+addSimpleFlagA
   :: String -- ^ short flag chars, i.e. "v" for -v
   -> [String] -- ^ list of long names, e.g. ["verbose"]
   -> Flag Void -- ^ properties
   -> f () -- ^ action to execute whenever this matches
   -> CmdParser f out ()
-addSimpleBoolFlagA shorts longs flag act =
+addSimpleFlagA shorts longs flag act
-  void $ addSimpleBoolFlagAll shorts longs flag act
+  = void $ addSimpleBoolFlagAll shorts longs flag act
 
 addSimpleBoolFlagAll
-  :: String -> [String] -> Flag Void -> f () -> CmdParser f out Bool
+  :: String
+  -> [String]
+  -> Flag Void
+  -> f ()
+  -> CmdParser f out Bool
 addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
   $ addCmdPartManyA ManyUpperBound1 (wrapHidden flag desc) parseF (\() -> a)
  where
@@ -154,12 +156,11 @@ addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
       $   PartAlts
       $   PartLiteral
       <$> allStrs
-  parseF :: PartParser () String
+  parseF :: String -> Maybe ((), String)
   parseF (dropWhile Char.isSpace -> str) =
-    resultFromMaybe
+    (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
-      $   (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
+      <|> ( firstJust
-      <|> (firstJust
+            ( \s ->
-            (\s ->
               [ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ]
             )
             allStrs
@@ -167,12 +168,11 @@ 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
+addSimpleCountFlag :: Applicative f
-  :: Applicative f
+                   => String -- ^ short flag chars, i.e. "v" for -v
-  => String -- ^ short flag chars, i.e. "v" for -v
+                   -> [String] -- ^ list of long names, i.e. ["verbose"]
-  -> [String] -- ^ list of long names, i.e. ["verbose"]
+                   -> Flag Void -- ^ properties
-  -> Flag Void -- ^ properties
+                   -> CmdParser f out Int
-  -> CmdParser f out Int
 addSimpleCountFlag shorts longs flag = fmap length
   $ addCmdPartMany ManyUpperBoundN (wrapHidden flag desc) parseF
  where
@@ -185,22 +185,16 @@ addSimpleCountFlag shorts longs flag = fmap length
       $   PartAlts
       $   PartLiteral
       <$> allStrs
-  parseF :: PartParser () String
+  parseF :: String -> Maybe ((), String)
   parseF (dropWhile Char.isSpace -> str) =
-    resultFromMaybe
+    (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
-      $   (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
+      <|> ( firstJust
-      <|> (firstJust
+            ( \s ->
-            (\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
@@ -210,10 +204,8 @@ addFlagReadParam
   -> String -- ^ param name
   -> Flag p -- ^ properties
   -> CmdParser f out p
-addFlagReadParam shorts longs name flag = addCmdPartInpA
+addFlagReadParam shorts longs name flag =
-  (wrapHidden flag desc)
+  addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())
-  parseF
-  (\_ -> pure ())
  where
   allStrs =
     [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
@@ -224,13 +216,11 @@ addFlagReadParam shorts longs name flag = addCmdPartInpA
   desc1 :: PartDesc
   desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
   desc2 = PartVariable name
-  parseF :: PartParser p Input
+  parseF :: Input -> Maybe (p, Input)
   parseF inp = case inp of
-    InputString str -> case parseResult of
+    InputString str ->
-      Nothing -> resultFromMaybe $ _flag_default flag <&> \x -> (x, inp)
+      maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)
-      Just (descOrVal, r) -> case descOrVal of
+        $ parseResult
-        Left  e   -> Failure (Just e)
-        Right val -> Success val (InputString r)
      where
       parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
         Data.Foldable.msum $ allStrs <&> \case
@@ -239,27 +229,23 @@ addFlagReadParam shorts longs name flag = addCmdPartInpA
         InpParseString $ do
           i <- StateS.get
           case Text.Read.reads i of
-            ((x, ' ' : r) : _) ->
+            ((x, ' ':r):_) -> StateS.put (dropWhile Char.isSpace r) $> x
-              StateS.put (dropWhile Char.isSpace r) $> Right x
+            ((x, ""   ):_) -> StateS.put "" $> x
-            ((x, "") : _) -> StateS.put "" $> Right x
+            _              -> mzero
-            _             -> pure $ Left desc2
+    InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
-    InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of
       Just ((), "") -> case argR of
-        []            -> Failure Nothing
+        []          -> Nothing
-        (arg2 : rest) -> case Text.Read.readMaybe arg2 of
+        (arg2:rest) -> readMaybe arg2 <&> \x -> (x, InputArgs rest)
-          Just x  -> Success x (InputArgs rest)
+      Just ((), remainingStr) ->
-          Nothing -> Failure (Just desc2)
+        readMaybe remainingStr <&> \x -> (x, 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 _ -> resultFromMaybe $ _flag_default flag <&> \d -> (d, inp)
+    InputArgs _ -> _flag_default flag <&> \d -> (d, inp)
 
 -- | One-argument flag, where the argument is parsed via its Read instance.
 -- This version can accumulate multiple values by using the same flag with
@@ -274,8 +260,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.
@@ -293,14 +279,12 @@ addFlagReadParams shorts longs name flag =
 --   = void $ addFlagReadParamsAll shorts longs name flag act
 
 addFlagReadParamsAll
-  :: forall f p out
+  :: forall f p out . (Typeable p, Text.Read.Read p, Show p) => String -- ^ short flag chars, i.e. "v" for -v
-   . (Typeable p, Text.Read.Read p, Show p)
+     -> [String] -- ^ list of long names, i.e. ["verbose"]
-  => String -- ^ short flag chars, i.e. "v" for -v
+     -> String -- ^ param name
-  -> [String] -- ^ list of long names, i.e. ["verbose"]
+     -> Flag p -- ^ properties
-  -> String -- ^ param name
+     -> (p -> f ()) -- ^ action to execute when ths param matches
-  -> Flag p -- ^ properties
+     -> CmdParser f out [p]
-  -> (p -> f ()) -- ^ action to execute when ths param matches
-  -> CmdParser f out [p]
 addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA
   ManyUpperBoundN
   (wrapHidden flag desc)
@@ -314,13 +298,10 @@ 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 :: PartParser p Input
+  parseF :: Input -> Maybe (p, Input)
   parseF inp = case inp of
-    InputString str -> case parseResult of
+    InputString str ->
-      Just (descOrVal, r) -> case descOrVal of
+      fmap (second InputString) $ parseResult
-        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
@@ -329,65 +310,46 @@ addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA
         InpParseString $ do
           i <- StateS.get
           case Text.Read.reads i of
-            ((x, ' ' : r) : _) ->
+            ((x, ' ':r):_) -> StateS.put (dropWhile Char.isSpace r) $> x
-              StateS.put (dropWhile Char.isSpace r) $> Right x
+            ((x, ""   ):_) -> StateS.put "" $> x
-            ((x, "") : _) -> StateS.put "" $> Right x
+            _              -> lift $ _flag_default flag
-            _             -> pure $ case _flag_default flag of
+    InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
-              Nothing  -> Left desc2
-              Just val -> Right val
-    InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of
       Just ((), "") -> case argR of
-        []            -> mdef
+        []          -> mdef
-        (arg2 : rest) -> case Text.Read.readMaybe arg2 of
+        (arg2:rest) -> (readMaybe arg2 <&> \x -> (x, InputArgs rest)) <|> mdef
-          Just x  -> Success x (InputArgs rest)
+        where mdef = _flag_default flag <&> \p -> (p, InputArgs argR)
-          Nothing -> mdef
+      Just ((), remainingStr) ->
-       where
+        readMaybe remainingStr <&> \x -> (x, InputArgs argR)
-        mdef = case _flag_default flag of
+      Nothing -> Nothing
-          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 _ -> Failure Nothing
+    InputArgs _ -> Nothing
 
 -- | One-argument flag where the argument can be an arbitrary string.
 addFlagStringParam
-  :: forall f out
+  :: forall f out . (Applicative f) => 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
+     -> String -- ^ param name
-  -> [String] -- ^ list of long names, i.e. ["verbose"]
+     -> Flag String -- ^ properties
-  -> String -- ^ param name
+     -> CmdParser f out String
-  -> Flag String -- ^ properties
+addFlagStringParam shorts longs name flag =
-  -> CmdParser f out String
+  addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())
-addFlagStringParam shorts longs name flag = addCmdPartInpA
-  (wrapHidden flag desc)
-  parseF
-  (\_ -> pure ())
  where
   allStrs =
     [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
-  desc =
+  desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2]
-    (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 :: PartParser String Input
+  parseF :: Input -> Maybe (String, Input)
   parseF inp = case inp of
-    InputString str -> case parseResult of
+    InputString str ->
-      Nothing -> resultFromMaybe $ _flag_default flag <&> \x -> (x, inp)
+      maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)
-      Just (descOrVal, r) -> case descOrVal of
+        $ parseResult
-        Left  e   -> Failure (Just e)
-        Right val -> Success val (InputString r)
      where
       parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
         Data.Foldable.msum $ allStrs <&> \case
@@ -397,22 +359,20 @@ addFlagStringParam shorts longs name flag = addCmdPartInpA
           i <- StateS.get
           let (x, rest) = break Char.isSpace $ dropWhile Char.isSpace i
           StateS.put rest
-          pure $ Right x
+          pure x
-    InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of
+    InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
       Just ((), "") -> case argR of
-        []         -> Failure Nothing
+        []       -> Nothing
-        (x : rest) -> Success x (InputArgs rest)
+        (x:rest) -> Just (x, InputArgs rest)
-      Just ((), remainingStr) -> case Text.Read.readMaybe remainingStr of
+      Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)
-        Just x  -> Success x (InputArgs argR)
+      Nothing                 -> _flag_default flag <&> \d -> (d, inp)
-        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 _ -> resultFromMaybe $ _flag_default flag <&> \d -> (d, inp)
+    InputArgs _ -> _flag_default flag <&> \d -> (d, inp)
 
 -- | One-argument flag where the argument can be an arbitrary string.
 -- This version can accumulate multiple values by using the same flag with
@@ -427,8 +387,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.
@@ -445,14 +405,13 @@ addFlagStringParams shorts longs name flag =
 --   = void $ addFlagStringParamsAll shorts longs name flag act
 
 addFlagStringParamsAll
-  :: forall f out
+  :: forall f out . String
-   . String
+     -> [String]
-  -> [String]
+     -> String
-  -> String
+     -> Flag Void -- we forbid the default because it has bad interaction
-  -> 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)
@@ -466,10 +425,9 @@ 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 :: PartParser String Input
+  parseF :: Input -> Maybe (String, Input)
   parseF inp = case inp of
-    InputString str ->
+    InputString str -> fmap (second InputString) $ parseResult
-      resultFromMaybe $ fmap (second InputString) $ parseResult
      where
       parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
         Data.Foldable.msum $ allStrs <&> \case
@@ -480,16 +438,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
-        []         -> Failure Nothing
+        []       -> Nothing
-        (x : rest) -> Success x (InputArgs rest)
+        (x:rest) -> Just (x, InputArgs rest)
-      Just ((), remainingStr) -> Success remainingStr (InputArgs argR)
+      Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)
-      Nothing                 -> Failure Nothing
+      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 _ -> Failure Nothing
+    InputArgs _ -> Nothing

src/UI/Butcher/Monadic/IO.hs

@@ -1,6 +1,7 @@
 -- | Turn your CmdParser into an IO () to be used as your program @main@.
 module UI.Butcher.Monadic.IO
   ( mainFromCmdParser
+  , mainFromCmdParserWithHelpDesc
   )
 where
 
@@ -8,19 +9,17 @@ where
 
 #include "prelude.inc"
 import           Control.Monad.Free
-import qualified Control.Monad.Trans.MultiRWS.Strict
+import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
-                                               as MultiRWSS
+import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS
-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.Internal.Monadic
+import           UI.Butcher.Monadic.Internal.Types
-import           UI.Butcher.Internal.MonadicTypes
+import           UI.Butcher.Monadic.Internal.Core
-import           UI.Butcher.Monadic.Param
 import           UI.Butcher.Monadic.Pretty
+import           UI.Butcher.Monadic.Param
 
 import           System.IO
 
@@ -38,35 +37,74 @@ import           System.IO
 mainFromCmdParser :: CmdParser Identity (IO ()) () -> IO ()
 mainFromCmdParser cmd = do
   progName <- System.Environment.getProgName
-  case toCmdDesc (Just progName) cmd of
+  case checkCmdParser (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 fullDesc -> do
+    Right _ -> do
       args <- System.Environment.getArgs
-      case runCmdParserCoreFromDesc fullDesc (InputArgs args) cmd of
+      case runCmdParser (Just progName) (InputArgs args) cmd of
-        (desc, _, Left err) -> do
+        (desc, Left (ParsingError mess remaining)) -> do
           putStrErrLn
             $  progName
             ++ ": error parsing arguments: "
-            ++ case _pe_messages err of
+            ++ case mess of
-                 []      -> ""
+                 []    -> ""
-                 (m : _) -> m
+                 (m:_) -> m
-          putStrErrLn $ case _pe_remaining err of
+          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   []  -> "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 out of
+        (desc, Right out                         ) -> case _cmd_out out of
+          Nothing -> do
+            putStrErrLn $ "usage:"
+            printErr $ ppUsage desc
+          Just a  -> a
+
+-- | Same as mainFromCmdParser, but with one additional twist: You get access
+-- to a knot-tied complete CommandDesc for this full command. Useful in
+-- combination with 'UI.Butcher.Monadic.BuiltinCommands.addHelpCommand'
+mainFromCmdParserWithHelpDesc
+  :: (CommandDesc () -> CmdParser Identity (IO ()) ()) -> IO ()
+mainFromCmdParserWithHelpDesc cmdF = do
+  progName <- System.Environment.getProgName
+  let (checkResult, fullDesc)
+        -- knot-tying at its finest..
+        = ( checkCmdParser (Just progName) (cmdF fullDesc)
+          , either (const emptyCommandDesc) id $ checkResult
+          )
+  case checkResult of
+    Left e -> do
+      putStrErrLn $ progName ++ ": internal error: failed sanity check for butcher main command parser!"
+      putStrErrLn $ "(" ++ e ++ ")"
+      putStrErrLn $ "aborting."
+    Right _ -> do
+      args <- System.Environment.getArgs
+      case runCmdParser (Just progName) (InputArgs args) (cmdF fullDesc) of
+        (desc, Left (ParsingError mess remaining)) -> do
+          putStrErrLn $ progName ++ ": error parsing arguments: " ++ head mess
+          putStrErrLn $ case remaining of
+            InputString "" -> "at the end of input."
+            InputString str -> case show str of
+              s | length s < 42 -> "at: " ++ s ++ "."
+              s -> "at: " ++ take 40 s ++ "..\"."
+            InputArgs [] -> "at the end of input"
+            InputArgs xs -> case List.unwords $ show <$> xs of
+              s | length s < 42 -> "at: " ++ s ++ "."
+              s -> "at: " ++ take 40 s ++ "..\"."
+          putStrErrLn $ "usage:"
+          printErr $ ppUsage desc
+        (desc, Right out) -> case _cmd_out out of
           Nothing -> do
             putStrErrLn $ "usage:"
             printErr $ ppUsage desc

src/UI/Butcher/Monadic/Interactive.hs

@@ -0,0 +1,201 @@
+-- | 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/Internal/Types.hs

@@ -5,25 +5,25 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module UI.Butcher.Internal.CommonTypes
+module UI.Butcher.Monadic.Internal.Types
   ( CommandDesc (..)
   , cmd_mParent
   , cmd_help
   , cmd_synopsis
   , cmd_parts
-  , cmd_hasImpl
+  , cmd_out
   , cmd_children
   , cmd_visibility
   , emptyCommandDesc
+  , CmdParserF (..)
+  , CmdParser
   , PartDesc (..)
   , Input (..)
-  , EpsilonFlag (..)
   , ParsingError (..)
   , addSuggestion
   , ManyUpperBound (..)
   , Visibility (..)
   , CompletionItem (..)
-  , PartialParseInfo (..)
   )
 where
 
@@ -47,29 +47,45 @@ 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)
+  deriving (Show, Eq)
 
 -- | 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
 
@@ -94,15 +110,18 @@ data Visibility = Visible | Hidden
 ---------
 
 -- | 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
+--
-  { _cmd_mParent  :: Maybe (Maybe String, CommandDesc)
+-- Note that there is the '_cmd_out' accessor that contains @Maybe out@ which
+-- might be useful after successful parsing.
+data CommandDesc out = CommandDesc
+  { _cmd_mParent  :: Maybe (Maybe String, CommandDesc out)
   , _cmd_synopsis :: Maybe PP.Doc
   , _cmd_help     :: Maybe PP.Doc
   , _cmd_parts    :: [PartDesc]
-  , _cmd_hasImpl  :: Bool
+  , _cmd_out      :: Maybe out
-  , _cmd_children :: Deque (Maybe String, CommandDesc)
+  , _cmd_children :: Deque (Maybe String, CommandDesc out)
                      -- we don't use a Map here because we'd like to
                      -- retain the order.
   , _cmd_visibility :: Visibility
@@ -160,40 +179,24 @@ command documentation structure
 
 --
 
--- | Empty 'CommandDesc' value. Mostly for butcher-internal usage.
+deriving instance Functor (CmdParserF f out)
-emptyCommandDesc :: CommandDesc
+deriving instance Functor CommandDesc
-emptyCommandDesc =
-  CommandDesc Nothing Nothing Nothing [] False mempty Visible
-
-instance Show CommandDesc where
-  show c = "Command help=" ++ show (_cmd_help c)
-        ++ " synopsis=" ++ show (_cmd_synopsis c)
-        ++ " mParent=" ++ show (fst <$> _cmd_mParent 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
+-- | Empty 'CommandDesc' value. Mostly for butcher-internal usage.
--- not only does it encode just parsing failure or success
+emptyCommandDesc :: CommandDesc out
--- (see @_ppi_value :: Either ParsingError (Maybe out)@) but also it encodes
+emptyCommandDesc =
--- information about partially succeeding parses. For example, the
+  CommandDesc Nothing Nothing Nothing [] Nothing mempty Visible
--- '_ppi_inputSugg' field serves as a tab-completion value.
+
-data PartialParseInfo out = PartialParseInfo
+instance Show (CommandDesc out) where
-  { _ppi_mainDesc        :: CommandDesc
+  show c = "Command help=" ++ show (_cmd_help c)
-  , _ppi_localDesc       :: CommandDesc
+        ++ " synopsis=" ++ show (_cmd_synopsis c)
-  , _ppi_value           :: Either ParsingError (Maybe out)
+        ++ " mParent=" ++ show (fst <$> _cmd_mParent c)
-  , _ppi_line            :: Input
+        ++ " out=" ++ maybe "(none)" (\_ -> "(smth)") (_cmd_out c)
-  , _ppi_rest            :: Input
+        ++ " parts.length=" ++ show (length $ _cmd_parts c)
-  , _ppi_lastword        :: String
+        ++ " parts=" ++ show (_cmd_parts c)
-  , _ppi_choices         :: [CompletionItem]
+        ++ " children=" ++ show (fst <$> _cmd_children c)
-  , _ppi_choicesHelp     :: [(CompletionItem, Maybe String)]
-  , _ppi_choiceCommon    :: String
-  , _ppi_inputSugg       :: String
-  , _ppi_prioDesc        :: Maybe PartDesc
-  , _ppi_interactiveHelp :: Int -> PP.Doc
-  }
 
 --
 

src/UI/Butcher/Monadic/Param.hs

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

src/UI/Butcher/Monadic/Pretty.hs

@@ -36,10 +36,344 @@ module UI.Butcher.Monadic.Pretty
   , ppPartDescUsage
   , ppPartDescHeader
   , parsingErrorString
-  , descendDescTo
   )
 where
 
 
 
-import           UI.Butcher.Internal.Pretty
+#include "prelude.inc"
+import           Control.Monad.Free
+import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
+import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS
+
+import qualified Text.PrettyPrint as PP
+import           Text.PrettyPrint ( (<+>), ($$), ($+$) )
+
+import           Data.HList.ContainsType
+
+import           UI.Butcher.Monadic.Internal.Types
+import           UI.Butcher.Monadic.Internal.Core
+
+
+
+-- | ppUsage exampleDesc yields:
+--
+-- > 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 =
+  case strings of
+    [] -> Just $ ppUsage desc
+    (s:sr) -> find ((Just s==) . fst) (_cmd_children desc) >>= ppUsageAt sr . snd
+
+-- | 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 (fromMaybe PP.empty $ ppPartDescUsage p)]
+          ++ (PP.nest 2 <$> go p)
+      PartReorder ps     -> ps >>= go
+      PartMany    p      -> go p
+      PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
+      PartHidden{}       -> []
+
+-- | ppHelpDepthOne exampleDesc yields:
+--
+-- > NAME
+-- > 
+-- >   example - a simple butcher example program
+-- > 
+-- > USAGE
+-- > 
+-- >   example [--short] NAME <command>
+-- > 
+-- > DESCRIPTION
+-- > 
+-- >   a very long help document
+-- > 
+-- > COMMANDS
+-- > 
+-- >   version
+-- >   help
+-- > 
+-- > ARGUMENTS
+-- > 
+-- >   --short             make the greeting short
+-- >   NAME                your name, so you can be greeted properly
+ppHelpDepthOne :: CommandDesc a -> PP.Doc
+ppHelpDepthOne desc =
+  nameSection
+    $+$ usageSection
+    $+$ descriptionSection
+    $+$ commandSection
+    $+$ partsSection
+    $+$ PP.text ""
+ where
+  CommandDesc mParent syn help parts _out children _hidden = desc
+  nameSection = case mParent of
+    Nothing -> PP.empty
+    Just{} ->
+      PP.text "NAME"
+        $+$ PP.text ""
+        $+$ PP.nest
+              2
+              ( case syn of
+                Nothing -> pparents mParent
+                Just s  -> pparents mParent <+> PP.text "-" <+> s
+              )
+        $+$ PP.text ""
+  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
+  pparents Nothing              = PP.empty
+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
+  usageSection =
+    PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsageShortSub desc)
+  descriptionSection = case help of
+    Nothing -> PP.empty
+    Just h ->
+      PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h
+  visibleChildren =
+    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
+  childDescs = visibleChildren <&> \(n, c) ->
+    PP.text n $$ PP.nest 20 (fromMaybe PP.empty (_cmd_synopsis c))
+  commandSection = if null visibleChildren
+    then PP.empty
+    else PP.text "" $+$ PP.text "COMMANDS" $+$ PP.text "" $+$ PP.nest
+      2
+      (PP.vcat $ Data.Foldable.toList childDescs)
+  partsSection = if null partsTuples
+    then PP.empty
+    else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest
+      2
+      (PP.vcat partsTuples)
+  partsTuples :: [PP.Doc]
+  partsTuples = parts >>= go
+   where
+    go = \case
+      PartLiteral{}      -> []
+      PartVariable{}     -> []
+      PartOptional p     -> go p
+      PartAlts     ps    -> ps >>= go
+      PartSeq      ps    -> ps >>= go
+      PartDefault    _ p -> go p
+      PartSuggestion _ p -> go p
+      PartRedirect s p ->
+        [PP.text s $$ PP.nest 20 (fromMaybe PP.empty $ ppPartDescUsage p)]
+          ++ (PP.nest 2 <$> go p)
+      PartReorder ps     -> ps >>= go
+      PartMany    p      -> go p
+      PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
+      PartHidden{}       -> []
+
+-- | Internal helper; users probably won't need this.
+ppPartDescUsage :: PartDesc -> 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,6 +3,7 @@
 -- | Types used in the butcher interface.
 module UI.Butcher.Monadic.Types
   ( CommandDesc(..)
+  , cmd_out
   , CmdParser
   , Input (..)
   , ParsingError (..)
@@ -18,4 +19,4 @@ where
 
 
 
-import           UI.Butcher.Internal.MonadicTypes
+import           UI.Butcher.Monadic.Internal.Types

srcinc/prelude.inc

@@ -1,80 +1,80 @@
--- import qualified Data.Graph
+import qualified Data.Graph
--- import qualified Data.IntMap
+import qualified Data.IntMap
--- import qualified Data.IntMap.Lazy
+import qualified Data.IntMap.Lazy
--- import qualified Data.IntMap.Strict
+import qualified Data.IntMap.Strict
--- import qualified Data.IntSet
+import qualified Data.IntSet
--- import qualified Data.Map
+import qualified Data.Map
--- import qualified Data.Map.Lazy
+import qualified Data.Map.Lazy
--- import qualified Data.Map.Strict
+import qualified Data.Map.Strict
--- import qualified Data.Sequence
+import qualified Data.Sequence
--- import qualified Data.Set
+import qualified Data.Set
--- import qualified Data.Tree
+import qualified Data.Tree
 
--- import qualified Control.Concurrent.Extra
+import qualified Control.Concurrent.Extra
--- import qualified Control.Exception.Extra
+import qualified Control.Exception.Extra
--- import qualified Control.Monad.Extra
+import qualified Control.Monad.Extra
--- import qualified Data.Either.Extra
+import qualified Data.Either.Extra
--- import qualified Data.IORef.Extra
+import qualified Data.IORef.Extra
--- import qualified Data.List.Extra
+import qualified Data.List.Extra
--- import qualified Data.Tuple.Extra
+import qualified Data.Tuple.Extra
--- import qualified Data.Version.Extra
+import qualified Data.Version.Extra
--- import qualified Numeric.Extra
+import qualified Numeric.Extra
--- import qualified System.Directory.Extra
+import qualified System.Directory.Extra
--- import qualified System.Environment.Extra
+import qualified System.Environment.Extra
--- import qualified System.IO.Extra
+import qualified System.IO.Extra
--- import qualified System.Info.Extra
+import qualified System.Info.Extra
--- import qualified System.Process.Extra
+import qualified System.Process.Extra
--- import qualified System.Time.Extra
+import qualified System.Time.Extra
 
--- import qualified Control.Monad.Trans.MultiRWS.Lazy
+import qualified Control.Monad.Trans.MultiRWS.Lazy
--- import qualified Control.Monad.Trans.MultiRWS.Strict
+import qualified Control.Monad.Trans.MultiRWS.Strict
--- import qualified Control.Monad.Trans.MultiReader
+import qualified Control.Monad.Trans.MultiReader
--- import qualified Control.Monad.Trans.MultiReader.Class
+import qualified Control.Monad.Trans.MultiReader.Class
--- import qualified Control.Monad.Trans.MultiReader.Lazy
+import qualified Control.Monad.Trans.MultiReader.Lazy
--- import qualified Control.Monad.Trans.MultiReader.Strict
+import qualified Control.Monad.Trans.MultiReader.Strict
--- import qualified Control.Monad.Trans.MultiState
+import qualified Control.Monad.Trans.MultiState
--- import qualified Control.Monad.Trans.MultiState.Class
+import qualified Control.Monad.Trans.MultiState.Class
--- import qualified Control.Monad.Trans.MultiState.Lazy
+import qualified Control.Monad.Trans.MultiState.Lazy
--- import qualified Control.Monad.Trans.MultiState.Strict
+import qualified Control.Monad.Trans.MultiState.Strict
--- import qualified Control.Monad.Trans.MultiWriter
+import qualified Control.Monad.Trans.MultiWriter
--- import qualified Control.Monad.Trans.MultiWriter.Class
+import qualified Control.Monad.Trans.MultiWriter.Class
--- import qualified Control.Monad.Trans.MultiWriter.Lazy
+import qualified Control.Monad.Trans.MultiWriter.Lazy
--- import qualified Control.Monad.Trans.MultiWriter.Strict
+import qualified Control.Monad.Trans.MultiWriter.Strict
 
--- import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
+import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
--- import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL
+import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL
 
--- import qualified Data.Bifunctor
+import qualified Data.Bifunctor
--- import qualified Data.Bits
+import qualified Data.Bits
--- import qualified Data.Bool
+import qualified Data.Bool
--- import qualified Data.Char
+import qualified Data.Char
--- import qualified Data.Coerce
+import qualified Data.Coerce
--- import qualified Data.Complex
+import qualified Data.Complex
--- import qualified Data.Data
+import qualified Data.Data
--- import qualified Data.Dynamic
+import qualified Data.Dynamic
 import qualified Data.Either
--- import qualified Data.Eq
+import qualified Data.Eq
--- import qualified Data.Fixed
+import qualified Data.Fixed
 import qualified Data.Foldable
 import qualified Data.Function
--- import qualified Data.Functor
+import qualified Data.Functor
--- import qualified Data.Functor.Identity
+import qualified Data.Functor.Identity
--- import qualified Data.IORef
+import qualified Data.IORef
--- import qualified Data.Int
+import qualified Data.Int
--- import qualified Data.Ix
+import qualified Data.Ix
--- import qualified Data.List
+import qualified Data.List
--- import qualified Data.Maybe
+import qualified Data.Maybe
 import qualified Data.Monoid
--- import qualified Data.Ord
+import qualified Data.Ord
--- import qualified Data.Proxy
+import qualified Data.Proxy
--- import qualified Debug.Trace
+import qualified Debug.Trace
--- import qualified Numeric
+import qualified Numeric
--- import qualified Numeric.Natural
+import qualified Numeric.Natural
 import qualified System.Environment
--- import qualified System.IO
+import qualified System.IO
 import qualified Text.Read
--- import qualified Text.Show
+import qualified Text.Show
--- import qualified Unsafe.Coerce
+import qualified Unsafe.Coerce
 
 import qualified Data.Bool as Bool
 import qualified Data.Char as Char
@@ -87,12 +87,12 @@ import qualified GHC.OldList as List
 import qualified Data.List as List
 #endif
 
--- import qualified Data.IntMap as IntMap
+import qualified Data.IntMap as IntMap
--- import qualified Data.IntMap.Strict as IntMapS
+import qualified Data.IntMap.Strict as IntMapS
 import qualified Data.Map.Strict as MapS
 import qualified Data.Map.Lazy as MapL
--- import qualified Data.Sequence as Seq
+import qualified Data.Sequence as Seq
--- import qualified Data.Set as Set
+import qualified Data.Set as Set
 
 import qualified Control.Monad.RWS.Class as RWS.Class
 import qualified Control.Monad.Reader.Class as Reader.Class
@@ -103,18 +103,25 @@ 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.Concurrent.MVar ( MVar )
--- import Control.Monad.ST ( ST )
+import Data.Int ( Int )
--- import Data.IORef ( IORef )
+import Data.Word ( Word )
-import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), Alt(..), )
+import Prelude ( Integer, Float, Double )
--- import Data.Ord ( Ordering(..), Down(..) )
+import Control.Monad.ST ( ST )
--- import Data.Ratio ( Ratio, Rational )
+import Data.Bool ( Bool(..) )
+import Data.Char ( Char )
+import Data.Either ( Either(..) )
+import Data.IORef ( IORef )
+import Data.Maybe ( Maybe(..) )
+import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), First(..), Last(..), Alt(..), )
+import Data.Ord ( Ordering(..), Down(..) )
+import Data.Ratio ( Ratio, Rational )
+import Data.String ( String )
 import Data.Void ( Void )
--- import Data.Proxy ( Proxy(..) )
+import System.IO ( IO )
+import Data.Proxy ( Proxy(..) )
 import Data.Sequence ( Seq )
 import Data.Semigroup ( Semigroup(..) )
 
@@ -129,7 +136,6 @@ import Prelude                            ( Char
                                           , String
                                           , Int
                                           , Integer
-                                          , Word
                                           , Float
                                           , Double
                                           , Bool (..)
@@ -162,7 +168,6 @@ import Prelude                            ( Char
                                           , putStrLn
                                           , putStr
                                           , Show (..)
-                                          , Read (..)
                                           , print
                                           , fst
                                           , snd
@@ -187,12 +192,6 @@ import Prelude                            ( Char
                                           , (^)
                                           , Foldable
                                           , Traversable
-                                          , mempty
-                                          , maybe
-                                          , Applicative(..)
-                                          , (<$)
-                                          , Monoid(..)
-                                          , either
                                           )
 
 import Data.Foldable                      ( foldl'
@@ -236,31 +235,38 @@ import Data.List                          ( partition
                                           , uncons
                                           )
 
--- import Data.Tuple                         ( swap
+import Data.Tuple                         ( swap
---                                           )
+                                          )
 
--- import Data.Char                          ( ord
+import Data.Char                          ( ord
---                                           , chr
+                                          , chr
---                                           )
+                                          )
 
--- import Data.Word                          ( Word32
+import Data.Maybe                         ( fromMaybe
---                                           )
+                                          , maybe
+                                          , listToMaybe
+                                          , maybeToList
+                                          , catMaybes
+                                          )
 
--- import Data.Ord                           ( comparing
+import Data.Word                          ( Word32
---                                           , Down (..)
+                                          )
---                                           )
 
--- import Data.Either                        ( either
+import Data.Ord                           ( comparing
---                                           )
+                                          , Down (..)
+                                          )
 
--- import Data.Ratio                         ( Ratio
+import Data.Either                        ( either
---                                           , (%)
+                                          )
---                                           , numerator
---                                           , denominator
---                                           )
 
--- import Text.Read                          ( readMaybe
+import Data.Ratio                         ( Ratio
---                                           )
+                                          , (%)
+                                          , numerator
+                                          , denominator
+                                          )
+
+import Text.Read                          ( readMaybe
+                                          )
 
 import Control.Monad                      ( Functor (..)
                                           , Monad (..)
@@ -295,57 +301,56 @@ import Control.Applicative                ( Applicative (..)
                                           , Alternative (..)
                                           )
 
--- import Foreign.Storable                   ( Storable )
+import Foreign.Storable                   ( Storable )
--- import GHC.Exts                           ( Constraint )
+import GHC.Exts                           ( Constraint )
 
--- import Control.Concurrent                 ( threadDelay
+import Control.Concurrent                 ( threadDelay
---                                           , forkIO
+                                          , forkIO
---                                           , forkOS
+                                          , forkOS
---                                           )
+                                          )
 
--- import Control.Concurrent.MVar            ( MVar
+import Control.Concurrent.MVar            ( MVar
---                                           , newEmptyMVar
+                                          , newEmptyMVar
---                                           , newMVar
+                                          , newMVar
---                                           , putMVar
+                                          , putMVar
---                                           , readMVar
+                                          , readMVar
---                                           , takeMVar
+                                          , takeMVar
---                                           , swapMVar
+                                          , swapMVar
---                                           )
+                                          )
 
--- import Control.Exception                  ( evaluate
+import Control.Exception                  ( evaluate
---                                           , bracket
+                                          , bracket
---                                           , assert
+                                          , assert
---                                           )
+                                          )
 
--- import Debug.Trace                        ( trace
+import Debug.Trace                        ( trace
---                                           , traceId
+                                          , traceId
---                                           , traceShowId
+                                          , traceShowId
---                                           , traceShow
+                                          , traceShow
---                                           , traceStack
+                                          , traceStack
---                                           , traceShowId
+                                          , traceShowId
---                                           , traceIO
+                                          , traceIO
---                                           , traceM
+                                          , traceM
---                                           , traceShowM
+                                          , traceShowM
---                                           )
+                                          )
 
--- import Foreign.ForeignPtr                 ( ForeignPtr
+import Foreign.ForeignPtr                 ( ForeignPtr
---                                           )
+                                          )
 
--- import Data.Monoid                        ( Monoid
+import Data.Monoid                        ( Monoid
---                                           , mempty
+                                          , mempty
---                                           , mconcat
+                                          , mconcat
---                                           )
+                                          )
 
--- import Data.Bifunctor                     ( bimap )
+import Data.Bifunctor                     ( bimap )
 import Data.Functor                       ( (<$), ($>) )
--- import Data.Function                      ( (&) )
+import Data.Function                      ( (&) )
--- import System.IO                          ( hFlush
+import System.IO                          ( hFlush
---                                           , stdout
+                                          , stdout
---                                           )
+                                          )
 
 import Data.Typeable                      ( Typeable
                                           , cast
-                                          , Proxy(..)
                                           )
 
 import Control.Arrow                      ( first
@@ -356,30 +361,30 @@ import Control.Arrow                      ( first
                                           , (<<<)
                                           )
 
--- import Data.Functor.Identity              ( Identity (..)
+import Data.Functor.Identity              ( Identity (..)
---                                           )
+                                          )
 
--- import Data.Proxy                         ( Proxy (..)
+import Data.Proxy                         ( Proxy (..)
---                                           )
+                                          )
 
--- import Data.Version                       ( showVersion
+import Data.Version                       ( showVersion
---                                           )
+                                          )
 
--- import Data.List.Extra                    ( nubOrd
+import Data.List.Extra                    ( nubOrd
---                                           , stripSuffix
+                                          , stripSuffix
---                                           )
+                                          )
--- import Control.Monad.Extra                ( whenM
+import Control.Monad.Extra                ( whenM
---                                           , unlessM
+                                          , unlessM
---                                           , ifM
+                                          , ifM
---                                           , notM
+                                          , notM
---                                           , orM
+                                          , orM
---                                           , andM
+                                          , andM
---                                           , anyM
+                                          , anyM
---                                           , allM
+                                          , allM
---                                           )
+                                          )
 
--- import Data.Tree                          ( Tree(..)
+import Data.Tree                          ( Tree(..)
---                                           )
+                                          )
 
 import Control.Monad.Trans.MultiRWS       ( MonadMultiReader(..)
                                           , MonadMultiWriter(..)
@@ -387,19 +392,19 @@ import Control.Monad.Trans.MultiRWS       ( MonadMultiReader(..)
                                           , mGet
                                           )
 
--- import Control.Monad.Trans.MultiReader    ( runMultiReaderTNil
+import Control.Monad.Trans.MultiReader    ( runMultiReaderTNil
---                                           , runMultiReaderTNil_
+                                          , runMultiReaderTNil_
---                                           , MultiReaderT (..)
+                                          , MultiReaderT (..)
---                                           , MultiReader
+                                          , MultiReader
---                                           , MultiReaderTNull
+                                          , MultiReaderTNull
---                                           )
+                                          )
 
--- import Control.Monad.IO.Class             ( MonadIO (..)
+import Control.Monad.IO.Class             ( MonadIO (..)
---                                           )
+                                          )
 
 import Control.Monad.Trans.Class          ( lift
                                           )
--- import Control.Monad.Trans.Maybe          ( MaybeT (..)
+import Control.Monad.Trans.Maybe          ( MaybeT (..)
---                                           )
+                                          )
 import Lens.Micro                         ( (<&>)
                                           )

stack-8-10.yaml

@@ -1,66 +0,0 @@
-# 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-18.13
-
-# 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-4.yaml

@@ -1,70 +0,0 @@
-# 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-12.26
-
-# 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:
-- deque-0.4.2.3
-- extra-1.7.1
-- strict-list-0.1.5
-- barbies-2.0.2.0
-- hsc2hs-0.68.7
-
-# 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-6.yaml

@@ -1,69 +0,0 @@
-# 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-14.4
-
-# 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:
-- .
-# 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: []
-
-extra-deps:
-- deque-0.4.2.3@sha256:7cc8ddfc77df351ff9c16e838ccdb4a89f055c80a3111e27eba8d90e8edde7d0,1853
-- strict-list-0.1.4@sha256:0fa869e2c21b710b7133e8628169f120fe6299342628edd3d5087ded299bc941,1631
-- semigroupoids-5.3.3@sha256:260b62cb8539bb988e7f551f10a45ef1c81421c0d79010e9bde9321bad4982a7,7363
-- 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: {}
-
-# 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

@@ -1,66 +0,0 @@
-# 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

@@ -1,100 +0,0 @@
-# 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

@@ -1,30 +0,0 @@
-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