Major changeset: Add applicative, Refactor monadic interface

- 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
- applicative interface has a somewhat nicer/cleaner implementation, is
  more secure by avoiding any demands on the API user that are not encoded
  in types, but is slightly less expressive and requires ApplicativeDo to
  get readable code.
- The applicative interface is *NOT* finished and the test-suite does not
  cover it.
- Add the `traverseBarbie` construct which introduces a dependency on
  the `barbies` library. This also effectively:
- Stop support for ghc < 8.4.
- 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`.
- Stop support for an anti-feature: The implicit merging of multiple
  sub-commands definitions with the same name.

butcher.cabal

@@ -32,10 +32,21 @@ library
                        UI.Butcher.Monadic.Flag
                        UI.Butcher.Monadic.Pretty
                        UI.Butcher.Monadic.IO
-                       UI.Butcher.Monadic.Interactive
                        UI.Butcher.Monadic.BuiltinCommands
-  other-modules:       UI.Butcher.Monadic.Internal.Types
+                       UI.Butcher.Applicative.Command
-                       UI.Butcher.Monadic.Internal.Core
+                       UI.Butcher.Applicative.Param
+                       UI.Butcher.Applicative.Flag
+                       UI.Butcher.Applicative.Pretty
+                       UI.Butcher.Applicative.IO
+                       UI.Butcher.Applicative
+  other-modules:       UI.Butcher.Internal.CommonTypes
+                       UI.Butcher.Internal.MonadicTypes
+                       UI.Butcher.Internal.Monadic
+                       UI.Butcher.Internal.ApplicativeTypes
+                       UI.Butcher.Internal.Applicative
+                       UI.Butcher.Internal.BasicStringParser
+                       UI.Butcher.Internal.Pretty
+                       UI.Butcher.Internal.Interactive
   build-depends:
     { base >=4.11 && <4.15
     , free < 5.2
@@ -51,6 +62,8 @@ library
     , void <0.8
     , bifunctors <5.6
     , deque >=0.3 && <0.5
+    , barbies >= 2.0.2.0 && <2.1
+    , semigroups
     }
   hs-source-dirs:      src
   default-language:    Haskell2010

src-tests/TestMain.hs

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

src/UI/Butcher/Applicative.hs

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

src/UI/Butcher/Applicative/Command.hs

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

src/UI/Butcher/Applicative/Flag.hs

@@ -0,0 +1,295 @@
+{-# 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
+
+
+
+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
+
+
+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
+          )
+
+
+addFlagReadParam
+  :: forall out p
+   . (Typeable p, Read p, Show p)
+  => String -- ^ short flag chars, i.e. "v" for -v
+  -> [String] -- ^ list of long names, i.e. ["verbose"]
+  -> String -- ^ param name
+  -> Flag p -- ^ properties
+  -> CmdParser out p
+addFlagReadParam shorts longs name opts = addCmdPartInp
+  (wrapHidden opts desc)
+  parseF
+ where
+  allStrs =
+    [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
+  desc =
+    (maybe id PartWithHelp $ _flag_help opts)
+      $ maybe id (PartDefault . show) (_flag_default opts)
+      $ PartSeq [desc1, desc2]
+  desc1 :: PartDesc
+  desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
+  desc2 = PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (p, Input)
+  parseF inp e = case inp of
+    InputString str -> case parseResult of
+      Just (x, rest) -> Just (x, InputString rest)
+      Nothing        -> viaDef
+     where
+      parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
+        Data.Foldable.msum $ allStrs <&> \case
+          Left  s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")
+          Right s -> pExpect s *> (pExpect " " <|> pExpect "=")
+        InpParseString $ do
+          i <- StateS.get
+          case Text.Read.reads i of
+            ((x, ' ' : r) : _) -> StateS.put (dropWhile Char.isSpace r) $> x
+            ((x, ""     ) : _) -> StateS.put "" $> x
+            _                  -> mzero
+    InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of
+      Just ((), "") -> case argR of
+        []            -> Nothing
+        (arg2 : rest) -> Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest)
+      Just ((), remainingStr) ->
+        Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR)
+      Nothing -> viaDef
+     where
+      parser :: InpParseString ()
+      parser = do
+        Data.Foldable.msum $ allStrs <&> \case
+          Left  s -> pExpect s *> pOption (pExpect "=")
+          Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
+    InputArgs _ -> viaDef
+    where viaDef = [ (x, inp) | x <- _flag_default opts, e == AllowEpsilon ]
+
+
+-- | One-argument flag, where the argument is parsed via its Read instance.
+-- This version can accumulate multiple values by using the same flag with
+-- different arguments multiple times.
+--
+-- E.g. "--foo 3 --foo 5" yields [3,5].
+addFlagReadParams
+  :: forall p out
+   . (Typeable p, Read p, Show p)
+  => String -- ^ short flag chars, i.e. "v" for -v
+  -> [String] -- ^ list of long names, i.e. ["verbose"]
+  -> String -- ^ param name
+  -> Flag p -- ^ properties
+  -> CmdParser out [p]
+addFlagReadParams shorts longs name flag = addCmdPartManyInp
+  ManyUpperBoundN
+  (wrapHidden flag desc)
+  parseF
+ where
+  allStrs =
+    [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
+  desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2]
+  desc1 :: PartDesc
+  desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
+  desc2 =
+    (maybe id (PartDefault . show) $ _flag_default flag) $ PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (p, Input)
+  parseF inp _ = case inp of
+    InputString str -> fmap (second InputString) $ parseResult
+     where
+      parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
+        Data.Foldable.msum $ allStrs <&> \case
+          Left  s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")
+          Right s -> pExpect s *> (pExpect " " <|> pExpect "=")
+        InpParseString $ do
+          i <- StateS.get
+          case Text.Read.reads i of
+            ((x, ' ' : r) : _) -> StateS.put (dropWhile Char.isSpace r) $> x
+            ((x, ""     ) : _) -> StateS.put "" $> x
+            _                  -> lift $ _flag_default flag
+    InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of
+      Just ((), "") -> case argR of
+        [] -> mdef
+        (arg2 : rest) ->
+          (Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest)) <|> mdef
+        where mdef = _flag_default flag <&> \p -> (p, InputArgs argR)
+      Just ((), remainingStr) ->
+        Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR)
+      Nothing -> Nothing
+     where
+      parser :: InpParseString ()
+      parser = do
+        Data.Foldable.msum $ allStrs <&> \case
+          Left  s -> pExpect s *> pOption (pExpect "=")
+          Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
+    InputArgs _ -> Nothing
+
+
+-- | One-argument flag where the argument can be an arbitrary string.
+addFlagStringParam
+  :: forall out
+   . String -- ^ short flag chars, i.e. "v" for -v
+  -> [String] -- ^ list of long names, i.e. ["verbose"]
+  -> String -- ^ param name
+  -> Flag String -- ^ properties
+  -> CmdParser out String
+addFlagStringParam shorts longs name opts = addCmdPartInp
+  (wrapHidden opts desc)
+  parseF
+ where
+  allStrs =
+    [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
+  desc = (maybe id PartWithHelp $ _flag_help opts) $ PartSeq [desc1, desc2]
+  desc1 :: PartDesc
+  desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
+  desc2 = PartVariable name
+  parseF :: Input -> EpsilonFlag -> Maybe (String, Input)
+  parseF inp e = case inp of
+    InputString str -> case parseResult of
+      Just (x, rest) -> Just (x, InputString rest)
+      Nothing        -> viaDef
+     where
+      parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
+        Data.Foldable.msum $ allStrs <&> \case
+          Left  s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")
+          Right s -> pExpect s *> (pExpect " " <|> pExpect "=")
+        InpParseString $ do
+          i <- StateS.get
+          let (x, rest) = break Char.isSpace $ dropWhile Char.isSpace i
+          StateS.put rest
+          pure x
+    InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of
+      Just ((), "") -> case argR of
+        []         -> Nothing
+        (x : rest) -> Just (x, InputArgs rest)
+      Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)
+      Nothing                 -> viaDef
+     where
+      parser :: InpParseString ()
+      parser = do
+        Data.Foldable.msum $ allStrs <&> \case
+          Left  s -> pExpect s *> pOption (pExpect "=")
+          Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
+    InputArgs _ -> viaDef
+    where viaDef = [ (x, inp) | x <- _flag_default opts, e == AllowEpsilon ]

src/UI/Butcher/Applicative/IO.hs

@@ -0,0 +1,94 @@
+-- | 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
+
+-- | 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 (IO ()) (IO ())) -> IO ()
+-- mainFromCmdParserWithHelpDesc cmdF = do
+--   progName <- System.Environment.getProgName
+--   args     <- System.Environment.getArgs
+--   case runCmdParserWithHelpDesc (InputArgs args) cmdF of
+--     (desc, Left err) -> do
+--       putStrErrLn $ progName ++ ": error parsing arguments: " ++ head
+--         (_pe_messages err)
+--       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, Right out) -> out
+
+putStrErrLn :: String -> IO ()
+putStrErrLn s = hPutStrLn stderr s
+
+printErr :: Show a => a -> IO ()
+printErr = putStrErrLn . show

src/UI/Butcher/Applicative/Param.hs

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

src/UI/Butcher/Applicative/Pretty.hs

@@ -0,0 +1,45 @@
+
+-- | Pretty-print of CommandDescs. To explain what the different functions
+-- do, we will use an example CmdParser. The CommandDesc derived from that
+-- CmdParser will serve as example input to the functions in this module.
+--
+-- > main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do
+-- > 
+-- >   addCmdSynopsis "a simple butcher example program"
+-- >   addCmdHelpStr "a very long help document"
+-- > 
+-- >   addCmd "version" $ do
+-- >     porcelain <- addSimpleBoolFlag "" ["porcelain"]
+-- >       (flagHelpStr "print nothing but the numeric version")
+-- >     addCmdHelpStr "prints the version of this program"
+-- >     addCmdImpl $ putStrLn $ if porcelain
+-- >       then "0.0.0.999"
+-- >       else "example, version 0.0.0.999"
+-- > 
+-- >   addCmd "help" $ addCmdImpl $ print $ ppHelpShallow helpDesc
+-- > 
+-- >   short <- addSimpleBoolFlag "" ["short"] (flagHelpStr "make the greeting short")
+-- >   name <- addStringParam "NAME"
+-- >     (paramHelpStr "your name, so you can be greeted properly")
+-- > 
+-- >   addCmdImpl $ do
+-- >     if short
+-- >       then putStrLn $ "hi, " ++ name ++ "!"
+-- >       else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!"
+module UI.Butcher.Applicative.Pretty
+  ( ppUsage
+  , ppUsageShortSub
+  , ppUsageAt
+  , ppHelpShallow
+  , ppHelpDepthOne
+  , ppUsageWithHelp
+  , ppPartDescUsage
+  , ppPartDescHeader
+  , parsingErrorString
+  , descendDescTo
+  )
+where
+
+
+
+import           UI.Butcher.Internal.Pretty

src/UI/Butcher/Internal/Applicative.hs

@@ -0,0 +1,378 @@
+{-# 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 ()
+
+
+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
+
+
+addCmdPart
+  :: Typeable p
+  => PartDesc
+  -> (String -> EpsilonFlag -> Maybe (p, String))
+  -> CmdParser out p
+addCmdPart p f = liftAp $ CmdParserPartInp p (convertStringToInputParse f) id
+
+addCmdPartMany
+  :: Typeable p
+  => ManyUpperBound
+  -> PartDesc
+  -> (String -> EpsilonFlag -> Maybe (p, String))
+  -> CmdParser out [p]
+addCmdPartMany b p f =
+  liftAp $ CmdParserPartManyInp b p (convertStringToInputParse f) id
+
+addCmdPartInp
+  :: Typeable p
+  => PartDesc
+  -> (Input -> EpsilonFlag -> Maybe (p, Input))
+  -> CmdParser out p
+addCmdPartInp p f = liftAp $ CmdParserPartInp p f id
+
+addCmdPartManyInp
+  :: Typeable p
+  => ManyUpperBound
+  -> PartDesc
+  -> (Input -> EpsilonFlag -> Maybe (p, Input))
+  -> CmdParser out [p]
+addCmdPartManyInp b p f = liftAp $ CmdParserPartManyInp b p f id
+
+reorderStart :: CmdParser out ()
+reorderStart = liftAp $ CmdParserReorderStart ()
+
+reorderStop :: CmdParser out ()
+reorderStop = liftAp $ CmdParserReorderStop ()
+
+-- | Add a new child command in the current context.
+addCmd
+  :: String -- ^ command name
+  -> CmdParser out out -- ^ subcommand
+  -> CmdParser out ()
+addCmd str sub = liftAp $ CmdParserChild str Visible sub ()
+
+-- | Add a new child command in the current context, but make it hidden. It
+-- will not appear in docs/help generated by e.g. the functions in the
+-- @Pretty@ module.
+--
+-- This feature is not well tested yet.
+addCmdHidden
+  :: String -- ^ command name
+  -> CmdParser out out -- ^ subcommand
+  -> CmdParser out ()
+addCmdHidden str sub = liftAp $ CmdParserChild str Hidden sub ()
+
+
+-- | Get the CommandDesc on the current level of the parser
+-- (i.e. for a command child, you get the child's CommandDesc).
+peekCmdDesc :: CmdParser out CommandDesc
+peekCmdDesc = liftAp $ CmdParserPeekDesc id
+
+
+extract :: (a -> Maybe b) -> [a] -> ([a], Maybe b)
+extract _ []       = ([], Nothing)
+extract f (x : xs) = case f x of
+  Nothing -> let ~(l, m) = extract f xs in (x : l, m)
+  Just b  -> (xs, Just b)
+
+-- I don't believe this version is any more efficient. It _can_ be one tad
+-- easier to use if it matches this pattern, but you _cannot_ get a non-strict
+-- delete out of this any longer.
+-- extractCont :: (a -> Maybe ([a] -> b)) -> [a] -> Maybe b
+-- extractCont f = go id
+--  where
+--   go _         []       = Nothing
+--   go startList (x : xs) = case f x of
+--     Nothing -> go ((x :) . startList) xs
+--     Just g  -> Just (g (startList xs))

src/UI/Butcher/Internal/ApplicativeTypes.hs

@@ -0,0 +1,97 @@
+{-# 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
+
+type CmdParser out = Ap (CmdParserF out)
+
+data EnrichedCmdParserF s out a
+  = forall p . Typeable p => ViaRef (STRef s (Maybe p)) (p -> a)
+  | forall p . Typeable p => ViaRefMany (STRef s [p]) ([p] -> a)
+  | Lifted (CmdParserF out a)
+  | Final (CmdParser out a)
+
+data ReorderUnit s
+  = forall p . ReorderUnit (STRef s (Maybe p))
+                           (Input -> EpsilonFlag -> Maybe (p, Input))
+  | forall p . ReorderUnitMany ManyUpperBound
+                               (STRef s [p])
+                               (Input -> EpsilonFlag -> Maybe (p, Input))
+
+convertStringToInputParse
+  :: (String -> EpsilonFlag -> (Maybe (p, String)))
+  -> (Input -> EpsilonFlag -> Maybe (p, Input))
+convertStringToInputParse f i e = case i of
+  InputString s -> case f s e of
+    Nothing        -> Nothing
+    Just (p, rest) -> Just (p, InputString rest)
+  input@(InputArgs (a1 : ar)) -> case f a1 e of
+    Just (p, "")                -> Just (p, InputArgs ar)
+    Just (p, rest) | rest == a1 -> Just (p, input)
+    _                           -> Nothing
+  InputArgs [] -> case f "" e of
+    Just (p, "") -> Just (p, InputArgs [])
+    _            -> Nothing

src/UI/Butcher/Internal/BasicStringParser.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module UI.Butcher.Internal.BasicStringParser
+  ( InpParseString(..)
+  , runInpParseString
+  , pExpect
+  , pExpectEof
+  , pDropSpace
+  , pOption
+  )
+where
+
+
+
+#include "prelude.inc"
+
+
+
+-- TODO: perhaps move this to Types module and refactor all code to use it
+newtype InpParseString a = InpParseString (StateS.StateT String Maybe a)
+  deriving (Functor, Applicative, Monad, State.Class.MonadState String, Alternative, MonadPlus)
+
+runInpParseString :: String -> InpParseString a -> Maybe (a, String)
+runInpParseString s (InpParseString m) = StateS.runStateT m s
+
+pExpect :: String -> InpParseString ()
+pExpect s = InpParseString $ do
+  inp <- StateS.get
+  case List.stripPrefix s inp of
+    Nothing   -> mzero
+    Just rest -> StateS.put rest
+
+pExpectEof :: InpParseString ()
+pExpectEof =
+  InpParseString $ StateS.get >>= \inp -> if null inp then pure () else mzero
+
+pDropSpace :: InpParseString ()
+pDropSpace = InpParseString $ StateS.modify (dropWhile (== ' '))
+
+pOption :: InpParseString () -> InpParseString ()
+pOption m = m <|> return ()
+

src/UI/Butcher/Internal/CommonTypes.hs

@@ -5,25 +5,25 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module UI.Butcher.Monadic.Internal.Types
+module UI.Butcher.Internal.CommonTypes
   ( CommandDesc (..)
   , cmd_mParent
   , cmd_help
   , cmd_synopsis
   , cmd_parts
-  , cmd_out
+  , cmd_hasImpl
   , cmd_children
   , cmd_visibility
   , emptyCommandDesc
-  , CmdParserF (..)
-  , CmdParser
   , PartDesc (..)
   , Input (..)
+  , EpsilonFlag (..)
   , ParsingError (..)
   , addSuggestion
   , ManyUpperBound (..)
   , Visibility (..)
   , CompletionItem (..)
+  , PartialParseInfo (..)
   )
 where
 
@@ -47,45 +47,26 @@ import qualified Text.PrettyPrint as PP
 data Input = InputString String | InputArgs [String]
   deriving (Show, Eq)
 
+data EpsilonFlag = AllowEpsilon | DenyEpsilon deriving Eq
+
 -- | Information about an error that occured when trying to parse some @Input@
 -- using some @CmdParser@.
 data ParsingError = ParsingError
-  { _pe_messages  :: [String]
+  { _pe_messages     :: [String]
-  , _pe_remaining :: Input
+  , _pe_remaining    :: Input
+  , _pe_expectedDesc :: Maybe PartDesc
   }
-  deriving (Show, Eq)
+  deriving (Show)
 
 -- | Specifies whether we accept 0-1 or 0-n for @CmdParserPart@s.
 data ManyUpperBound
   = ManyUpperBound1
   | ManyUpperBoundN
+  deriving Eq
 
 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
 
@@ -115,13 +96,13 @@ type CmdParser f out = Free (CmdParserF f out)
 --
 -- Note that there is the '_cmd_out' accessor that contains @Maybe out@ which
 -- might be useful after successful parsing.
-data CommandDesc out = CommandDesc
+data CommandDesc = CommandDesc
-  { _cmd_mParent  :: Maybe (Maybe String, CommandDesc out)
+  { _cmd_mParent  :: Maybe (Maybe String, CommandDesc)
   , _cmd_synopsis :: Maybe PP.Doc
   , _cmd_help     :: Maybe PP.Doc
   , _cmd_parts    :: [PartDesc]
-  , _cmd_out      :: Maybe out
+  , _cmd_hasImpl  :: Bool
-  , _cmd_children :: Deque (Maybe String, CommandDesc out)
+  , _cmd_children :: Deque (Maybe String, CommandDesc)
                      -- we don't use a Map here because we'd like to
                      -- retain the order.
   , _cmd_visibility :: Visibility
@@ -179,27 +160,38 @@ command documentation structure
 
 --
 
-deriving instance Functor (CmdParserF f out)
-deriving instance Functor CommandDesc
-
---
-
 -- | Empty 'CommandDesc' value. Mostly for butcher-internal usage.
-emptyCommandDesc :: CommandDesc out
+emptyCommandDesc :: CommandDesc
 emptyCommandDesc =
-  CommandDesc Nothing Nothing Nothing [] Nothing mempty Visible
+  CommandDesc Nothing Nothing Nothing [] False mempty Visible
 
-instance Show (CommandDesc out) where
+instance Show CommandDesc where
   show c = "Command help=" ++ show (_cmd_help c)
         ++ " synopsis=" ++ show (_cmd_synopsis c)
         ++ " mParent=" ++ show (fst <$> _cmd_mParent c)
-        ++ " out=" ++ maybe "(none)" (\_ -> "(smth)") (_cmd_out c)
         ++ " parts.length=" ++ show (length $ _cmd_parts c)
         ++ " parts=" ++ show (_cmd_parts c)
         ++ " children=" ++ show (fst <$> _cmd_children c)
 
 --
 
+data PartialParseInfo out = PartialParseInfo
+  { _ppi_mainDesc        :: CommandDesc
+  , _ppi_localDesc       :: CommandDesc
+  , _ppi_value           :: Either ParsingError (Maybe out)
+  , _ppi_line            :: Input
+  , _ppi_rest            :: Input
+  , _ppi_lastword        :: String
+  , _ppi_choices         :: [CompletionItem]
+  , _ppi_choicesHelp     :: [(CompletionItem, Maybe String)]
+  , _ppi_choiceCommon    :: String
+  , _ppi_inputSugg       :: String
+  , _ppi_prioDesc        :: Maybe PartDesc
+  , _ppi_interactiveHelp :: Int -> PP.Doc
+  }
+
+--
+
 LensTH.makeLenses ''CommandDesc
 LensTH.makeLenses ''PartDesc
 

src/UI/Butcher/Internal/Interactive.hs

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

src/UI/Butcher/Internal/MonadicTypes.hs

@@ -0,0 +1,141 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module UI.Butcher.Internal.MonadicTypes
+  ( CommandDesc(..)
+  , cmd_mParent
+  , cmd_help
+  , cmd_synopsis
+  , cmd_parts
+  , cmd_children
+  , cmd_visibility
+  , emptyCommandDesc
+  , CmdParserF(..)
+  , CmdParser
+  , PartDesc(..)
+  , Input(..)
+  , ParsingError(..)
+  , addSuggestion
+  , ManyUpperBound(..)
+  , Visibility(..)
+  , CompletionItem(..)
+  , PartParseResult(..)
+  , PartParser
+  , PartialParseInfo(..)
+  , resultFromMaybe
+  )
+where
+
+
+
+#include "prelude.inc"
+import           Control.Monad.Free
+import qualified Control.Monad.Trans.MultiState.Strict
+                                               as MultiStateS
+
+import qualified Lens.Micro.TH                 as LensTH
+
+import qualified Text.PrettyPrint              as PP
+
+import           UI.Butcher.Internal.CommonTypes
+
+
+
+data PartParseResult val input
+  = Success val input -- value, remaining input
+  | Failure (Maybe PartDesc) -- desc of the expected part, if appropriate
+
+type PartParser val input = input -> PartParseResult val input
+
+resultFromMaybe :: Maybe (val, input) -> PartParseResult val input
+resultFromMaybe = \case
+  Just (x, r) -> Success x r
+  Nothing     -> Failure Nothing
+
+data CmdParserF f out a
+  =                          CmdParserHelp PP.Doc a
+  |                          CmdParserSynopsis String a
+  |                          CmdParserPeekDesc (CommandDesc -> a)
+  |                          CmdParserPeekInput (String -> a)
+  -- TODO: we can clean up this duplication by providing
+  -- a function (String -> Maybe (p, String)) -> (Input -> Maybe (p, Input)).
+  | forall p . Typeable p => CmdParserPart PartDesc (PartParser p String) (p -> f ()) (p -> a)
+  | forall p . Typeable p => CmdParserPartMany ManyUpperBound PartDesc (PartParser p String) (p -> f ()) ([p] -> a)
+  | forall p . Typeable p => CmdParserPartInp PartDesc (PartParser p Input) (p -> f ()) (p -> a)
+  | forall p . Typeable p => CmdParserPartManyInp ManyUpperBound PartDesc (PartParser p Input) (p -> f ()) ([p] -> a)
+  |                          CmdParserChild (Maybe String) Visibility (CmdParser f out ()) (f ()) a
+  |                          CmdParserImpl  out                                a
+  |                          CmdParserReorderStart                             a
+  |                          CmdParserReorderStop                              a
+  |                          CmdParserGrouped String                           a
+  |                          CmdParserGroupEnd                                 a
+  | forall p . Typeable p => CmdParserAlternatives PartDesc [((String -> Bool), CmdParser f out p)] (p -> a)
+
+-- | The CmdParser monad type. It is a free monad over some functor but users
+-- of butcher don't need to know more than that 'CmdParser' is a 'Monad'.
+type CmdParser f out = Free (CmdParserF f out)
+
+
+-- type CmdParser a = CmdParserM a a
+
+-- data CmdPartParserF a
+--   = CmdPartParserHelp String a
+--   | forall p . CmdPartParserCore (String -> Maybe (p, String)) -- parser
+--                                  (Maybe p) -- optional default value
+--                                  (p -> a)
+--   | forall p . CmdPartParserOptional (CmdPartParser p)
+--                                      (Maybe p -> a)
+--   -- the idea here was to allow adding some dynamic data to each "node" of
+--   -- the output CommandDesc so the user can potentially add custom additional
+--   -- information, and write a custom pretty-printer for e.g. help output
+--   -- from that dynamically-enriched CommandDesc structure.
+--   -- disabled for now, because i am not sure what exactly "adding to every
+--   -- node" involves, because the mapping from Functor to Desc is nontrivial.
+--   -- (and because i don't have a direct use-case at the moment..)
+--   -- | CmdPartParserCustom Dynamic a
+-- 
+-- type CmdPartParser = Free CmdPartParserF
+
+---------
+
+{-
+command documentation structure
+1. terminals. e.g. "--dry-run"
+2. non-terminals, e.g. "FILES"
+3. sequences, e.g. "<program> FLAGS NUMBER PATH"
+-- 4. alternatives, e.g. "--date=(relative|local|iso|rfc|..)"
+5. sub-commands: git (init|commit|push|clone|..)
+   compared to 4, the subcommands have their own flags and params;
+   they essentially "take over".
+6. optional, e.g. "cabal run [COMPONENT]"
+7. default, e.g. "-O(LEVEL=1)"
+8. indirection, e.g. "cabal COMMAND\n\nCOMMAND: ..."
+-}
+
+--
+
+deriving instance Functor (CmdParserF f out)
+
+-- instance Show FlagDesc where
+--   show (FlagDesc _ short long helpM params) = show (short, long, helpM, params) -- TODO: improve
+
+-- class Typeable a => IsParam a where
+--   paramParse :: String -> Maybe (a, String, String) -- value, representation, rest
+--   paramStaticDef :: a
+
+-- emptyParamDesc :: ParamDesc a
+-- emptyParamDesc = ParamDesc Nothing Nothing
+
+-- deriving instance Show a => Show (ParamDesc a)
+
+
+-- instance Show a => Show (CmdParserF out a) where
+--   show (CmdParserHelp s x) = "(CmdParserHelp " ++ show s ++ " " ++ show x ++ ")"
+--   show (CmdParserFlag shorts longs _ _) = "(CmdParserFlag -" ++ shorts ++ " " ++ show longs ++ ")"
+--   show (CmdParserParam s _ _) = "(CmdParserParam " ++ s ++ ")"
+--   show (CmdParserChild s _ _) = "(CmdParserChild " ++ s ++ ")"
+--   show (CmdParserRun _) = "CmdParserRun"

src/UI/Butcher/Internal/Pretty.hs

@@ -0,0 +1,394 @@
+
+-- | Pretty-print of CommandDescs. To explain what the different functions
+-- do, we will use an example CmdParser. The CommandDesc derived from that
+-- CmdParser will serve as example input to the functions in this module.
+--
+-- > main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do
+-- > 
+-- >   addCmdSynopsis "a simple butcher example program"
+-- >   addCmdHelpStr "a very long help document"
+-- > 
+-- >   addCmd "version" $ do
+-- >     porcelain <- addSimpleBoolFlag "" ["porcelain"]
+-- >       (flagHelpStr "print nothing but the numeric version")
+-- >     addCmdHelpStr "prints the version of this program"
+-- >     addCmdImpl $ putStrLn $ if porcelain
+-- >       then "0.0.0.999"
+-- >       else "example, version 0.0.0.999"
+-- > 
+-- >   addCmd "help" $ addCmdImpl $ print $ ppHelpShallow helpDesc
+-- > 
+-- >   short <- addSimpleBoolFlag "" ["short"] (flagHelpStr "make the greeting short")
+-- >   name <- addStringParam "NAME"
+-- >     (paramHelpStr "your name, so you can be greeted properly")
+-- > 
+-- >   addCmdImpl $ do
+-- >     if short
+-- >       then putStrLn $ "hi, " ++ name ++ "!"
+-- >       else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!"
+module UI.Butcher.Internal.Pretty
+  ( ppUsage
+  , ppUsageShortSub
+  , ppUsageAt
+  , ppHelpShallow
+  , ppHelpDepthOne
+  , ppUsageWithHelp
+  , ppPartDescUsage
+  , ppPartDescHeader
+  , parsingErrorString
+  , descendDescTo
+  )
+where
+
+
+
+#include "prelude.inc"
+import           Control.Monad.Free
+import qualified Control.Monad.Trans.MultiRWS.Strict
+                                               as MultiRWSS
+import qualified Control.Monad.Trans.MultiState.Strict
+                                               as MultiStateS
+
+import qualified Text.PrettyPrint              as PP
+import           Text.PrettyPrint               ( ($$)
+                                                , ($+$)
+                                                , (<+>)
+                                                )
+
+import           Data.HList.ContainsType
+
+import           UI.Butcher.Internal.Monadic
+import           UI.Butcher.Internal.MonadicTypes
+
+
+
+-- | ppUsage exampleDesc yields:
+--
+-- > example [--short] NAME [version | help]
+ppUsage :: CommandDesc -> PP.Doc
+ppUsage (CommandDesc mParent _syn _help parts hasImpl children _hidden) =
+  pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]
+ where
+  pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc
+  pparents Nothing              = PP.empty
+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
+  partDocs = Maybe.mapMaybe ppPartDescUsage parts
+  visibleChildren =
+    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
+  subsDoc = if
+    | null visibleChildren -> PP.empty
+    | hasImpl              -> PP.brackets $ subDoc
+    | null parts           -> subDoc
+    | otherwise            -> PP.parens $ subDoc
+  subDoc =
+    PP.fcat
+      $   PP.punctuate (PP.text " | ")
+      $   Data.Foldable.toList
+      $   (PP.text . fst)
+      <$> visibleChildren
+
+-- | ppUsageShortSub exampleDesc yields:
+--
+-- > example [--short] NAME <command>
+--
+-- I.e. Subcommands are abbreviated using the @<command>@ label, instead
+-- of being listed.
+ppUsageShortSub :: CommandDesc -> PP.Doc
+ppUsageShortSub (CommandDesc mParent _syn _help parts hasImpl children _hidden)
+  = pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]
+ where
+  pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc
+  pparents Nothing              = PP.empty
+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
+  partDocs = Maybe.mapMaybe ppPartDescUsage parts
+  visibleChildren =
+    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
+  subsDoc = if
+    | null visibleChildren -> PP.empty
+    | hasImpl              -> PP.brackets $ subDoc
+    | otherwise            -> subDoc
+  subDoc = if null visibleChildren then PP.empty else PP.text "<command>"
+
+-- | ppUsageWithHelp exampleDesc yields:
+--
+-- > example [--short] NAME
+-- >         [version | help]: a simple butcher example program
+--
+-- And yes, the line break is not optimal in this instance with default print.
+ppUsageWithHelp :: CommandDesc -> PP.Doc
+ppUsageWithHelp (CommandDesc mParent _syn help parts hasImpl children _hidden)
+  = pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc
+ where
+  pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc
+  pparents Nothing              = PP.empty
+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
+  partDocs = Maybe.mapMaybe ppPartDescUsage parts
+  subsDoc  = if
+    | null children -> PP.empty
+    | -- TODO: remove debug
+      hasImpl       -> PP.brackets $ subDoc
+    | null parts    -> subDoc
+    | otherwise     -> PP.parens $ subDoc
+  subDoc =
+    PP.fcat
+      $ PP.punctuate (PP.text " | ")
+      $ Data.Foldable.toList
+      $ [ PP.text n | (Just n, c) <- children, _cmd_visibility c == Visible ]
+  helpDoc = case help of
+    Nothing -> PP.empty
+    Just h  -> PP.text ":" PP.<+> h
+
+-- | > ppUsageAt [] = ppUsage
+--
+-- fromJust $ ppUsageAt ["version"] exampleDesc yields:
+--
+-- > example version [--porcelain]
+ppUsageAt
+  :: [String] -- (sub)command sequence
+  -> CommandDesc
+  -> Maybe PP.Doc
+ppUsageAt strings desc = ppUsage <$> descendDescTo strings desc
+
+-- | Access a child command's CommandDesc.
+descendDescTo :: [String] -> CommandDesc -> Maybe (CommandDesc)
+descendDescTo strings desc = case strings of
+  []       -> Just desc
+  (s : sr) -> do -- Maybe
+    (_, childDesc) <- find ((Just s ==) . fst) (_cmd_children desc)
+    descendDescTo sr childDesc
+
+-- | ppHelpShallow exampleDesc yields:
+--
+-- > NAME
+-- > 
+-- >   example - a simple butcher example program
+-- > 
+-- > USAGE
+-- > 
+-- >   example [--short] NAME [version | help]
+-- > 
+-- > DESCRIPTION
+-- > 
+-- >   a very long help document
+-- > 
+-- > ARGUMENTS
+-- > 
+-- >   --short             make the greeting short
+-- >   NAME                your name, so you can be greeted properly
+ppHelpShallow :: CommandDesc -> PP.Doc
+ppHelpShallow desc =
+  nameSection
+    $+$ usageSection
+    $+$ descriptionSection
+    $+$ partsSection
+    $+$ PP.text ""
+ where
+  CommandDesc mParent syn help parts _out _children _hidden = desc
+  nameSection = case mParent of
+    Nothing -> PP.empty
+    Just{} ->
+      PP.text "NAME"
+        $+$ PP.text ""
+        $+$ PP.nest
+              2
+              (case syn of
+                Nothing -> pparents mParent
+                Just s  -> pparents mParent <+> PP.text "-" <+> s
+              )
+        $+$ PP.text ""
+  pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc
+  pparents Nothing              = PP.empty
+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
+  usageSection = PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsage desc)
+  descriptionSection = case help of
+    Nothing -> PP.empty
+    Just h ->
+      PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h
+  partsSection = if null partsTuples
+    then PP.empty
+    else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest
+      2
+      (PP.vcat partsTuples)
+  partsTuples :: [PP.Doc]
+  partsTuples = parts >>= go
+   where
+    go = \case
+      PartLiteral{}      -> []
+      PartVariable{}     -> []
+      PartOptional p     -> go p
+      PartAlts     ps    -> ps >>= go
+      PartSeq      ps    -> ps >>= go
+      PartDefault    _ p -> go p
+      PartSuggestion _ p -> go p
+      PartRedirect s p ->
+        [PP.text s $$ PP.nest 20 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)]
+          ++ (PP.nest 2 <$> go p)
+      PartReorder ps     -> ps >>= go
+      PartMany    p      -> go p
+      PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
+      PartHidden{}       -> []
+
+-- | ppHelpDepthOne exampleDesc yields:
+--
+-- > NAME
+-- > 
+-- >   example - a simple butcher example program
+-- > 
+-- > USAGE
+-- > 
+-- >   example [--short] NAME <command>
+-- > 
+-- > DESCRIPTION
+-- > 
+-- >   a very long help document
+-- > 
+-- > COMMANDS
+-- > 
+-- >   version
+-- >   help
+-- > 
+-- > ARGUMENTS
+-- > 
+-- >   --short             make the greeting short
+-- >   NAME                your name, so you can be greeted properly
+ppHelpDepthOne :: CommandDesc -> PP.Doc
+ppHelpDepthOne desc =
+  nameSection
+    $+$ usageSection
+    $+$ descriptionSection
+    $+$ commandSection
+    $+$ partsSection
+    $+$ PP.text ""
+ where
+  CommandDesc mParent syn help parts _out children _hidden = desc
+  nameSection = case mParent of
+    Nothing -> PP.empty
+    Just{} ->
+      PP.text "NAME"
+        $+$ PP.text ""
+        $+$ PP.nest
+              2
+              (case syn of
+                Nothing -> pparents mParent
+                Just s  -> pparents mParent <+> PP.text "-" <+> s
+              )
+        $+$ PP.text ""
+  pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc
+  pparents Nothing              = PP.empty
+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
+  usageSection =
+    PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsageShortSub desc)
+  descriptionSection = case help of
+    Nothing -> PP.empty
+    Just h ->
+      PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h
+  visibleChildren =
+    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
+  childDescs = visibleChildren <&> \(n, c) ->
+    PP.text n $$ PP.nest 20 (Maybe.fromMaybe PP.empty (_cmd_synopsis c))
+  commandSection = if null visibleChildren
+    then PP.empty
+    else PP.text "" $+$ PP.text "COMMANDS" $+$ PP.text "" $+$ PP.nest
+      2
+      (PP.vcat $ Data.Foldable.toList childDescs)
+  partsSection = if null partsTuples
+    then PP.empty
+    else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest
+      2
+      (PP.vcat partsTuples)
+  partsTuples :: [PP.Doc]
+  partsTuples = parts >>= go
+   where
+    go = \case
+      PartLiteral{}      -> []
+      PartVariable{}     -> []
+      PartOptional p     -> go p
+      PartAlts     ps    -> ps >>= go
+      PartSeq      ps    -> ps >>= go
+      PartDefault    _ p -> go p
+      PartSuggestion _ p -> go p
+      PartRedirect s p ->
+        [PP.text s $$ PP.nest 20 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)]
+          ++ (PP.nest 2 <$> go p)
+      PartReorder ps     -> ps >>= go
+      PartMany    p      -> go p
+      PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
+      PartHidden{}       -> []
+
+-- | Internal helper; users probably won't need this.
+ppPartDescUsage :: PartDesc -> Maybe PP.Doc
+ppPartDescUsage = \case
+  PartLiteral  s -> Just $ PP.text s
+  PartVariable s -> Just $ PP.text s
+  PartOptional p -> PP.brackets <$> rec p
+  PartAlts ps ->
+    [ PP.fcat $ PP.punctuate (PP.text ",") ds
+    | let ds = Maybe.mapMaybe rec ps
+    , not (null ds)
+    ]
+  PartSeq ps -> [ PP.fsep ds | let ds = Maybe.mapMaybe rec ps, not (null ds) ]
+  PartDefault    _   p -> PP.brackets <$> rec p
+  PartSuggestion sgs p -> rec p <&> \d ->
+    case [ PP.text s | CompletionString s <- sgs ] of
+      [] -> d
+      sgsDocs ->
+        PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ sgsDocs ++ [d]
+  PartRedirect s _ -> Just $ PP.text s
+  PartMany p       -> rec p <&> (PP.<> PP.text "+")
+  PartWithHelp _ p -> rec p
+  PartReorder ps ->
+    let flags  = [ d | PartMany d <- ps ]
+        params = filter
+          (\case
+            PartMany{} -> False
+            _          -> True
+          )
+          ps
+    in  Just $ PP.sep
+          [ (PP.fsep $ PP.brackets <$> Maybe.mapMaybe rec flags)
+          , PP.fsep (Maybe.mapMaybe rec params)
+          ]
+  PartHidden{} -> Nothing
+  where rec = ppPartDescUsage
+
+-- | Internal helper; users probably won't need this.
+ppPartDescHeader :: PartDesc -> PP.Doc
+ppPartDescHeader = \case
+  PartLiteral  s     -> PP.text s
+  PartVariable s     -> PP.text s
+  PartOptional ds'   -> rec ds'
+  PartAlts     alts  -> PP.hcat $ List.intersperse (PP.text ",") $ rec <$> alts
+  PartDefault    _ d -> rec d
+  PartSuggestion _ d -> rec d
+  PartRedirect   s _ -> PP.text s
+  PartMany ds        -> rec ds
+  PartWithHelp _ d   -> rec d
+  PartSeq     ds     -> PP.hsep $ rec <$> ds
+  PartReorder ds     -> PP.vcat $ rec <$> ds
+  PartHidden  d      -> rec d
+  where rec = ppPartDescHeader
+
+-- | Simple conversion from 'ParsingError' to 'String'.
+parsingErrorString :: ParsingError -> String
+parsingErrorString pe = "error parsing arguments: " ++ messStr ++ remainingStr
+ where
+  mess      = _pe_messages pe
+  remaining = _pe_remaining pe
+  messStr   = case mess of
+    []      -> ""
+    (m : _) -> m ++ " "
+  remainingStr = case remaining of
+    InputString ""  -> "at the end of input."
+    InputString str -> case show str of
+      s | length s < 42 -> "at: " ++ s ++ "."
+      s                 -> "at: " ++ take 40 s ++ "..\"."
+    InputArgs [] -> "at the end of input"
+    InputArgs xs -> case List.unwords $ show <$> xs of
+      s | length s < 42 -> "at: " ++ s ++ "."
+      s                 -> "at: " ++ take 40 s ++ "..\"."
+

src/UI/Butcher/Monadic.hs

@@ -4,24 +4,22 @@ module UI.Butcher.Monadic
     Input (..)
   , CmdParser
   , ParsingError (..)
-  , CommandDesc(_cmd_out)
+  , PartialParseInfo (..)
-  , cmd_out
+  , CommandDesc
   , -- * Run or Check CmdParsers
-    runCmdParserSimple
+    runCmdParserSimpleString
   , runCmdParser
-  , runCmdParserExt
   , runCmdParserA
-  , runCmdParserAExt
+  , runCmdParserFromDesc
+  , runCmdParserAFromDesc
   , runCmdParserWithHelpDesc
-  , checkCmdParser
+  , toCmdDesc
   , -- * Building CmdParsers
     module UI.Butcher.Monadic.Command
     -- * PrettyPrinting CommandDescs (usage/help)
   , module UI.Butcher.Monadic.Pretty
     -- * Wrapper around System.Environment.getArgs
   , module UI.Butcher.Monadic.IO
-    -- * Utilities for interactive feedback of commandlines (completions etc.)
-  , module UI.Butcher.Monadic.Interactive
   -- , cmds
   -- , sample
   -- , test
@@ -45,14 +43,14 @@ where
 
 #include "prelude.inc"
 
-import UI.Butcher.Monadic.Types
+import           UI.Butcher.Internal.Monadic
-import UI.Butcher.Monadic.Internal.Types
+import           UI.Butcher.Internal.MonadicTypes
-import UI.Butcher.Monadic.Command
+import           UI.Butcher.Internal.Interactive
-import UI.Butcher.Monadic.BuiltinCommands
+import           UI.Butcher.Monadic.BuiltinCommands
-import UI.Butcher.Monadic.Internal.Core
+import           UI.Butcher.Monadic.Command
-import UI.Butcher.Monadic.Pretty
+import           UI.Butcher.Monadic.IO
-import UI.Butcher.Monadic.IO
+import           UI.Butcher.Monadic.Pretty
-import UI.Butcher.Monadic.Interactive
+import           UI.Butcher.Monadic.Types
 
 import qualified Text.PrettyPrint as PP
 
@@ -68,7 +66,7 @@ import qualified Text.PrettyPrint as PP
 -- to a knot-tied complete CommandDesc for this full command. Useful in
 -- combination with 'UI.Butcher.Monadic.BuiltinCommands.addHelpCommand'.
 --
--- Note that the @CommandDesc ()@ in the output is _not_ the same value as the
+-- Note that the @CommandDesc@ in the output is _not_ the same value as the
 -- parameter passed to the parser function: The output value contains a more
 -- "shallow" description. This is more efficient for complex CmdParsers when
 -- used interactively, because non-relevant parts of the CmdParser are not
@@ -76,27 +74,78 @@ import qualified Text.PrettyPrint as PP
 runCmdParserWithHelpDesc
   :: Maybe String -- ^ program name to be used for the top-level @CommandDesc@
   -> Input -- ^ input to be processed
-  -> (CommandDesc () -> CmdParser Identity out ()) -- ^ parser to use
+  -> (CommandDesc -> CmdParser Identity out ()) -- ^ parser to use
-  -> (CommandDesc (), Either ParsingError (CommandDesc out))
+  -> (CommandDesc, Input, Either ParsingError (Maybe out))
 runCmdParserWithHelpDesc mProgName input cmdF =
   let (checkResult, fullDesc)
         -- knot-tying at its finest..
-        = ( checkCmdParser mProgName (cmdF fullDesc)
+        = ( toCmdDesc mProgName (cmdF fullDesc)
           , either (const emptyCommandDesc) id $ checkResult
           )
-  in runCmdParser mProgName input (cmdF fullDesc)
+  in runCmdParserCoreFromDesc fullDesc input (cmdF fullDesc)
 
 
 -- | Wrapper around 'runCmdParser' for very simple usage: Accept a @String@
 -- input and return only the output from the parser, or a plain error string
 -- on failure.
-runCmdParserSimple :: String -> CmdParser Identity out () -> Either String out
+runCmdParserSimpleString :: String -> CmdParser Identity out () -> Either String out
-runCmdParserSimple s p = case snd $ runCmdParser Nothing (InputString s) p of
+runCmdParserSimpleString s p = case toCmdDesc Nothing p of
-  Left e -> Left $ parsingErrorString e
+  Left err -> Left err
-  Right desc ->
+  Right fullDesc -> 
-    maybe (Left "command has no implementation") Right $ _cmd_out desc
+    case runCmdParserCoreFromDesc fullDesc (InputString s) p of
+      (_, _, Left e) -> Left $ parsingErrorString e
+      (_, _, Right outM) ->
+        maybe (Left "command has no implementation") Right $ outM
 
 
+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
+
+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
+
+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
+
+runCmdParserAFromDesc
+  :: forall f out
+   . Applicative f
+  => CommandDesc
+  -> Input
+  -> CmdParser f out ()
+  -> f (PartialParseInfo out)
+runCmdParserAFromDesc topDesc input parser =
+  let mapper (localDesc, remainingInput, result) =
+        combinedCompletion input topDesc localDesc remainingInput result
+  in  mapper <$> runCmdParserCoreFromDescA topDesc input parser
+
 --------------------------------------
 -- all below is for testing purposes
 --------------------------------------
@@ -155,22 +204,23 @@ data Sample = Sample
 -- test s = OPA.execParserPure OPA.defaultPrefs (OPA.ParserInfo sample True mempty mempty mempty (-13) True) (List.words s)
 
 _test2 :: IO ()
-_test2 = case checkCmdParser (Just "butcher") _cmds of
+_test2 = case toCmdDesc (Just "butcher") _cmds of
   Left e -> putStrLn $ "LEFT: " ++ e
   Right desc -> do
     print $ ppUsage desc
     print $ maybe undefined id $ ppUsageAt ["hello"] desc
 
 _test3 :: String -> IO ()
-_test3 s = case runCmdParser (Just "butcher") (InputString s) _cmds of
+_test3 s = do
-  (desc, Left e) -> do
+  case _ppi_value info of
-    print e
+    Left err -> do
-    print $ ppHelpShallow desc
+      print err
-    _cmd_mParent desc `forM_` \(_, d) -> do
+      print $ ppHelpShallow (_ppi_localDesc info)
-      print $ ppUsage d
+      _cmd_mParent (_ppi_localDesc info) `forM_` \(_, d) -> do
-  (desc, Right out) -> do
+        print $ ppUsage d
-    case _cmd_out out of
+    Right Nothing -> do
-      Nothing -> do
+      putStrLn "command is missing implementation!"
-        putStrLn "command is missing implementation!"
+      print $ ppHelpShallow (_ppi_localDesc info)
-        print $ ppHelpShallow desc
+    Right (Just f) -> f
-      Just f -> f
+ where
+  info = runCmdParser Nothing (InputString s) _cmds

src/UI/Butcher/Monadic/BuiltinCommands.hs

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

src/UI/Butcher/Monadic/Command.hs

@@ -62,6 +62,7 @@ module UI.Butcher.Monadic.Command
   , reorderStart
   , reorderStop
   , withReorder
+  , traverseBarbie
   , peekCmdDesc
   , peekInput
     -- * Building CmdParsers - myprog -v --input PATH
@@ -83,10 +84,8 @@ where
 
 #include "prelude.inc"
 
-
+import           UI.Butcher.Internal.MonadicTypes
-
+import           UI.Butcher.Internal.Monadic
-import           UI.Butcher.Monadic.Internal.Types
-import           UI.Butcher.Monadic.Internal.Core
 import           UI.Butcher.Monadic.Flag
 import           UI.Butcher.Monadic.Param
 

src/UI/Butcher/Monadic/Flag.hs

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

src/UI/Butcher/Monadic/IO.hs

@@ -9,17 +9,19 @@ where
 
 #include "prelude.inc"
 import           Control.Monad.Free
-import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
+import qualified Control.Monad.Trans.MultiRWS.Strict
-import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS
+                                               as MultiRWSS
+import qualified Control.Monad.Trans.MultiState.Strict
+                                               as MultiStateS
 
-import qualified Text.PrettyPrint as PP
+import qualified Text.PrettyPrint              as PP
 
 import           Data.HList.ContainsType
 
-import           UI.Butcher.Monadic.Internal.Types
+import           UI.Butcher.Internal.Monadic
-import           UI.Butcher.Monadic.Internal.Core
+import           UI.Butcher.Internal.MonadicTypes
-import           UI.Butcher.Monadic.Pretty
 import           UI.Butcher.Monadic.Param
+import           UI.Butcher.Monadic.Pretty
 
 import           System.IO
 
@@ -37,74 +39,77 @@ import           System.IO
 mainFromCmdParser :: CmdParser Identity (IO ()) () -> IO ()
 mainFromCmdParser cmd = do
   progName <- System.Environment.getProgName
-  case checkCmdParser (Just progName) cmd of
+  case toCmdDesc (Just progName) cmd of
-    Left  e -> do
+    Left e -> do
       putStrErrLn
         $ progName
         ++ ": internal error: failed sanity check for butcher main command parser!"
       putStrErrLn $ "(" ++ e ++ ")"
       putStrErrLn $ "aborting."
-    Right _ -> do
+    Right fullDesc -> do
       args <- System.Environment.getArgs
-      case runCmdParser (Just progName) (InputArgs args) cmd of
+      case runCmdParserCoreFromDesc fullDesc (InputArgs args) cmd of
-        (desc, Left (ParsingError mess remaining)) -> do
+        (desc, _, Left err) -> do
           putStrErrLn
             $  progName
             ++ ": error parsing arguments: "
-            ++ case mess of
+            ++ case _pe_messages err of
-                 []    -> ""
+                 []      -> ""
-                 (m:_) -> m
+                 (m : _) -> m
-          putStrErrLn $ case remaining of
+          putStrErrLn $ case _pe_remaining err of
             InputString ""  -> "at the end of input."
             InputString str -> case show str of
               s | length s < 42 -> "at: " ++ s ++ "."
               s                 -> "at: " ++ take 40 s ++ "..\"."
-            InputArgs   []  -> "at the end of input"
+            InputArgs [] -> "at the end of input"
-            InputArgs   xs  -> case List.unwords $ show <$> xs of
+            InputArgs xs -> case List.unwords $ show <$> xs of
               s | length s < 42 -> "at: " ++ s ++ "."
               s                 -> "at: " ++ take 40 s ++ "..\"."
           putStrErrLn $ "usage:"
           printErr $ ppUsage desc
-        (desc, Right out                         ) -> case _cmd_out out of
+        (desc, _, Right out) -> case out of
           Nothing -> do
             putStrErrLn $ "usage:"
             printErr $ ppUsage desc
-          Just a  -> a
+          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 ()
+  :: (CommandDesc -> CmdParser Identity (IO ()) ()) -> IO ()
 mainFromCmdParserWithHelpDesc cmdF = do
   progName <- System.Environment.getProgName
-  let (checkResult, fullDesc)
+  let (checkResult, optimisticFullDesc) =
+        ( toCmdDesc (Just progName) (cmdF optimisticFullDesc)
+        , either (const emptyCommandDesc) id $ checkResult
+        )
         -- 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
+        $ progName
+        ++ ": internal error: failed sanity check for butcher main command parser!"
       putStrErrLn $ "(" ++ e ++ ")"
       putStrErrLn $ "aborting."
-    Right _ -> do
+    Right fullDesc -> do
       args <- System.Environment.getArgs
-      case runCmdParser (Just progName) (InputArgs args) (cmdF fullDesc) of
+      case runCmdParserCoreFromDesc fullDesc (InputArgs args) (cmdF fullDesc) of
-        (desc, Left (ParsingError mess remaining)) -> do
+        (desc, _, Left err) -> do
-          putStrErrLn $ progName ++ ": error parsing arguments: " ++ head mess
+          putStrErrLn $ progName ++ ": error parsing arguments: " ++ head
-          putStrErrLn $ case remaining of
+            (_pe_messages err)
-            InputString "" -> "at the end of input."
+          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 ++ "..\"."
+              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 ++ "..\"."
+              s                 -> "at: " ++ take 40 s ++ "..\"."
           putStrErrLn $ "usage:"
           printErr $ ppUsage desc
-        (desc, Right out) -> case _cmd_out out of
+        (desc, _, Right out) -> case out of
           Nothing -> do
             putStrErrLn $ "usage:"
             printErr $ ppUsage desc

src/UI/Butcher/Monadic/Interactive.hs

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

src/UI/Butcher/Monadic/Param.hs

@@ -35,23 +35,25 @@ where
 
 #include "prelude.inc"
 import           Control.Monad.Free
-import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
+import qualified Control.Monad.Trans.MultiRWS.Strict
-import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS
+                                               as MultiRWSS
+import qualified Control.Monad.Trans.MultiState.Strict
+                                               as MultiStateS
 
-import qualified Text.PrettyPrint as PP
+import qualified Text.PrettyPrint              as PP
 
 import           Data.HList.ContainsType
 
-import           UI.Butcher.Monadic.Internal.Types
+import           UI.Butcher.Internal.Monadic
-import           UI.Butcher.Monadic.Internal.Core
+import           UI.Butcher.Internal.MonadicTypes
 
 
 
 -- | param-description monoid. You probably won't need to use the constructor;
 -- mzero or any (<>) of param(Help|Default|Suggestion) works well.
 data Param p = Param
-  { _param_default :: Maybe p
+  { _param_default     :: Maybe p
-  , _param_help :: Maybe PP.Doc
+  , _param_help        :: Maybe PP.Doc
   , _param_suggestions :: Maybe [CompletionItem]
   }
 
@@ -67,7 +69,7 @@ instance Semigroup (Param p) where
   (<>) = appendParam
 
 instance Monoid (Param p) where
-  mempty = Param Nothing Nothing Nothing
+  mempty  = Param Nothing Nothing Nothing
   mappend = (<>)
 
 -- | Create a 'Param' with just a help text.
@@ -99,116 +101,129 @@ paramDirectory = mempty { _param_suggestions = Just [CompletionDirectory] }
 -- instance. Take care not to use this to return Strings unless you really
 -- want that, because it will require the quotation marks and escaping as
 -- is normal for the Show/Read instances for String.
-addParamRead :: forall f out a
+addParamRead
-              . (Applicative f, Typeable a, Show a, Text.Read.Read a)
+  :: forall f out a
-             => String -- ^ paramater name, for use in usage/help texts
+   . (Applicative f, Typeable a, Show a, Text.Read.Read a)
-             -> Param a -- ^ properties
+  => String -- ^ paramater name, for use in usage/help texts
-             -> CmdParser f out a
+  -> Param a -- ^ properties
+  -> CmdParser f out a
 addParamRead = addReadParam
 {-# DEPRECATED addReadParam "use 'addParamRead'" #-}
-addReadParam :: forall f out a
+addReadParam
-              . (Applicative f, Typeable a, Show a, Text.Read.Read a)
+  :: forall f out a
-             => String -- ^ paramater name, for use in usage/help texts
+   . (Applicative f, Typeable a, Show a, Text.Read.Read a)
-             -> Param a -- ^ properties
+  => String -- ^ paramater name, for use in usage/help texts
-             -> CmdParser f out a
+  -> Param a -- ^ properties
+  -> CmdParser f out a
 addReadParam name par = addCmdPart desc parseF
-  where
+ where
-    desc :: PartDesc
+  desc :: PartDesc
-    desc = addSuggestion (_param_suggestions par)
+  desc =
-         $ (maybe id PartWithHelp $ _param_help par)
+    addSuggestion (_param_suggestions par)
-         $ (maybe id (PartDefault . show) $ _param_default par)
+      $ (maybe id PartWithHelp $ _param_help par)
-         $ PartVariable name
+      $ (maybe id (PartDefault . show) $ _param_default par)
-    parseF :: String -> Maybe (a, String)
+      $ PartVariable name
-    parseF s = case Text.Read.reads s of
+  parseF :: PartParser a String
-      ((x, ' ':r):_) -> Just (x, dropWhile Char.isSpace r)
+  parseF s = resultFromMaybe $ case Text.Read.reads s of
-      ((x, []):_)    -> Just (x, [])
+    ((x, ' ' : r) : _) -> Just (x, dropWhile Char.isSpace r)
-      _ -> _param_default par <&> \x -> (x, s)
+    ((x, []     ) : _) -> Just (x, [])
+    _                  -> _param_default par <&> \x -> (x, s)
 
 -- | Like addReadParam, but optional. I.e. if reading fails, returns Nothing.
-addParamReadOpt :: forall f out a
+addParamReadOpt
-                 . (Applicative f, Typeable a, Text.Read.Read a)
+  :: forall f out a
-                => String -- ^ paramater name, for use in usage/help texts
+   . (Applicative f, Typeable a, Text.Read.Read a)
-                -> Param a -- ^ properties
+  => String -- ^ paramater name, for use in usage/help texts
-                -> CmdParser f out (Maybe a)
+  -> Param a -- ^ properties
+  -> CmdParser f out (Maybe a)
 addParamReadOpt = addReadParamOpt
 {-# DEPRECATED addReadParamOpt "use 'addParamReadOpt'" #-}
-addReadParamOpt :: forall f out a
+addReadParamOpt
-                 . (Applicative f, Typeable a, Text.Read.Read a)
+  :: forall f out a
-                => String -- ^ paramater name, for use in usage/help texts
+   . (Applicative f, Typeable a, Text.Read.Read a)
-                -> Param a -- ^ properties
+  => String -- ^ paramater name, for use in usage/help texts
-                -> CmdParser f out (Maybe a)
+  -> Param a -- ^ properties
+  -> CmdParser f out (Maybe a)
 addReadParamOpt name par = addCmdPart desc parseF
-  where
+ where
-    desc :: PartDesc
+  desc :: PartDesc
-    desc = addSuggestion (_param_suggestions par)
+  desc =
-         $ PartOptional
+    addSuggestion (_param_suggestions par)
-         $ (maybe id PartWithHelp $ _param_help par)
+      $ PartOptional
-         $ PartVariable name
+      $ (maybe id PartWithHelp $ _param_help par)
-    parseF :: String -> Maybe (Maybe a, String)
+      $ PartVariable name
-    parseF s = case Text.Read.reads s of
+  parseF :: PartParser (Maybe a) String
-      ((x, ' ':r):_) -> Just (Just x, dropWhile Char.isSpace r)
+  parseF s = resultFromMaybe $ case Text.Read.reads s of
-      ((x, []):_)    -> Just (Just x, [])
+    ((x, ' ' : r) : _) -> Just (Just x, dropWhile Char.isSpace r)
-      _ -> Just (Nothing, s) -- TODO: we could warn about a default..
+    ((x, []     ) : _) -> Just (Just x, [])
+    _                  -> Just (Nothing, s) -- TODO: we could warn about a default..
 
 -- | Add a parameter that matches any string of non-space characters if
 -- input==String, or one full argument if input==[String]. See the 'Input' doc
 -- for this distinction.
 addParamString
-  :: forall f out . (Applicative f)
+  :: forall f out
+   . (Applicative f)
   => String
   -> Param String
   -> CmdParser f out String
 addParamString = addStringParam
 {-# DEPRECATED addStringParam "use 'addParamString'" #-}
 addStringParam
-  :: forall f out . (Applicative f)
+  :: forall f out
+   . (Applicative f)
   => String
   -> Param String
   -> CmdParser f out String
 addStringParam name par = addCmdPartInp desc parseF
-  where
+ where
-    desc :: PartDesc
+  desc :: PartDesc
-    desc = addSuggestion (_param_suggestions par)
+  desc =
-         $ (maybe id PartWithHelp $ _param_help par)
+    addSuggestion (_param_suggestions par)
-         $ PartVariable name
+      $ (maybe id PartWithHelp $ _param_help par)
-    parseF :: Input -> Maybe (String, Input)
+      $ PartVariable name
-    parseF (InputString str)
+  parseF :: PartParser String Input
-      = case break Char.isSpace $ dropWhile Char.isSpace str of
+  parseF (InputString str) =
-          ("", rest) -> _param_default par <&> \x -> (x, InputString rest)
+    case break Char.isSpace $ dropWhile Char.isSpace str of
-          (x, rest) -> Just (x, InputString rest)
+      ("", rest) ->
-    parseF (InputArgs args) = case args of
+        resultFromMaybe $ _param_default par <&> \x -> (x, InputString rest)
-      (s1:sR) -> Just (s1, InputArgs sR)
+      (x, rest) -> Success x (InputString rest)
-      []      -> _param_default par <&> \x -> (x, InputArgs args)
+  parseF (InputArgs args) = case args of
+    (s1 : sR) -> Success s1 (InputArgs sR)
+    [] -> resultFromMaybe $ _param_default par <&> \x -> (x, InputArgs args)
 
 -- | Like 'addParamString', but optional, I.e. succeeding with Nothing if
 -- there is no remaining input.
 addParamStringOpt
-  :: forall f out . (Applicative f)
+  :: forall f out
+   . (Applicative f)
   => String
   -> Param Void
   -> CmdParser f out (Maybe String)
 addParamStringOpt = addStringParamOpt
 {-# DEPRECATED addStringParamOpt "use 'addParamStringOpt'" #-}
 addStringParamOpt
-  :: forall f out . (Applicative f)
+  :: forall f out
+   . (Applicative f)
   => String
   -> Param Void
   -> CmdParser f out (Maybe String)
 addStringParamOpt name par = addCmdPartInp desc parseF
-  where
+ where
-    desc :: PartDesc
+  desc :: PartDesc
-    desc = addSuggestion (_param_suggestions par)
+  desc =
-         $ PartOptional
+    addSuggestion (_param_suggestions par)
-         $ (maybe id PartWithHelp $ _param_help par)
+      $ PartOptional
-         $ PartVariable name
+      $ (maybe id PartWithHelp $ _param_help par)
-    parseF :: Input -> Maybe (Maybe String, Input)
+      $ PartVariable name
-    parseF (InputString str)
+  parseF :: PartParser (Maybe String) Input
-      = case break Char.isSpace $ dropWhile Char.isSpace str of
+  parseF (InputString str) =
-          ("", rest) -> Just (Nothing, InputString rest)
+    case break Char.isSpace $ dropWhile Char.isSpace str of
-          (x, rest) -> Just (Just x, InputString rest)
+      ("", rest) -> Success Nothing (InputString rest)
-    parseF (InputArgs args) = case args of
+      (x , rest) -> Success (Just x) (InputString rest)
-      (s1:sR) -> Just (Just s1, InputArgs sR)
+  parseF (InputArgs args) = case args of
-      []      -> Just (Nothing, InputArgs [])
+    (s1 : sR) -> Success (Just s1) (InputArgs sR)
+    []        -> Success Nothing (InputArgs [])
 
 
 -- | Add a parameter that matches any string of non-space characters if
@@ -235,20 +250,21 @@ addStringParams name par = addCmdPartManyInp ManyUpperBoundN desc parseF
     addSuggestion (_param_suggestions par)
       $ (maybe id PartWithHelp $ _param_help par)
       $ PartVariable name
-  parseF :: Input -> Maybe (String, Input)
+  parseF :: PartParser String Input
   parseF (InputString str) =
     case break Char.isSpace $ dropWhile Char.isSpace str of
-      ("", _   ) -> Nothing
+      ("", _   ) -> Failure Nothing
-      (x , rest) -> Just (x, InputString rest)
+      (x , rest) -> Success x (InputString rest)
   parseF (InputArgs args) = case args of
-    (s1:sR) -> Just (s1, InputArgs sR)
+    (s1 : sR) -> Success s1 (InputArgs sR)
-    []      -> Nothing
+    []        -> Failure Nothing
 
 
 -- | Like 'addParamString' but does not match strings starting with a dash.
 -- This prevents misinterpretation of flags as params.
 addParamNoFlagString
-  :: forall f out . (Applicative f)
+  :: forall f out
+   . (Applicative f)
   => String
   -> Param String
   -> CmdParser f out String
@@ -259,16 +275,16 @@ addParamNoFlagString name par = addCmdPartInp desc parseF
     addSuggestion (_param_suggestions par)
       $ (maybe id PartWithHelp $ _param_help par)
       $ PartVariable name
-  parseF :: Input -> Maybe (String, Input)
+  parseF :: PartParser String Input
   parseF (InputString str) =
-    case break Char.isSpace $ dropWhile Char.isSpace str of
+    resultFromMaybe $ case break Char.isSpace $ dropWhile Char.isSpace str of
-      (""   , rest) -> _param_default par <&> \x -> (x, InputString rest)
+      (""     , rest) -> _param_default par <&> \x -> (x, InputString rest)
-      ('-':_, _   ) -> _param_default par <&> \x -> (x, InputString str)
+      ('-' : _, _   ) -> _param_default par <&> \x -> (x, InputString str)
-      (x    , rest) -> Just (x, InputString rest)
+      (x      , rest) -> Just (x, InputString rest)
-  parseF (InputArgs args) = case args of
+  parseF (InputArgs args) = resultFromMaybe $ case args of
-    []           -> _param_default par <&> \x -> (x, InputArgs args)
+    []               -> _param_default par <&> \x -> (x, InputArgs args)
-    (('-':_):_ ) -> _param_default par <&> \x -> (x, InputArgs args)
+    (('-' : _) : _ ) -> _param_default par <&> \x -> (x, InputArgs args)
-    (s1     :sR) -> Just (s1, InputArgs sR)
+    (s1        : sR) -> Just (s1, InputArgs sR)
 
 -- | Like 'addParamStringOpt' but does not match strings starting with a dash.
 -- This prevents misinterpretation of flags as params.
@@ -283,16 +299,16 @@ addParamNoFlagStringOpt name par = addCmdPartInp desc parseF
   desc :: PartDesc
   desc =
     PartOptional $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name
-  parseF :: Input -> Maybe (Maybe String, Input)
+  parseF :: PartParser (Maybe String) Input
   parseF (InputString str) =
     case break Char.isSpace $ dropWhile Char.isSpace str of
-      (""   , rest) -> Just (Nothing, InputString rest)
+      (""     , rest) -> Success Nothing (InputString rest)
-      ('-':_, _   ) -> Just (Nothing, InputString str)
+      ('-' : _, _   ) -> Success Nothing (InputString str)
-      (x    , rest) -> Just (Just x, InputString rest)
+      (x      , rest) -> Success (Just x) (InputString rest)
   parseF (InputArgs args) = case args of
-    []           -> Just (Nothing, InputArgs [])
+    []               -> Success Nothing (InputArgs [])
-    (('-':_):_ ) -> Just (Nothing, InputArgs args)
+    (('-' : _) : _ ) -> Success Nothing (InputArgs args)
-    (s1     :sR) -> Just (Just s1, InputArgs sR)
+    (s1        : sR) -> Success (Just s1) (InputArgs sR)
 
 -- | Like 'addParamStrings' but does not match strings starting with a dash.
 -- This prevents misinterpretation of flags as params.
@@ -309,22 +325,23 @@ addParamNoFlagStrings name par = addCmdPartManyInp ManyUpperBoundN desc parseF
     addSuggestion (_param_suggestions par)
       $ (maybe id PartWithHelp $ _param_help par)
       $ PartVariable name
-  parseF :: Input -> Maybe (String, Input)
+  parseF :: PartParser String Input
   parseF (InputString str) =
     case break Char.isSpace $ dropWhile Char.isSpace str of
-      (""   , _   ) -> Nothing
+      (""     , _   ) -> Failure Nothing
-      ('-':_, _   ) -> Nothing
+      ('-' : _, _   ) -> Failure Nothing
-      (x    , rest) -> Just (x, InputString rest)
+      (x      , rest) -> Success x (InputString rest)
   parseF (InputArgs args) = case args of
-    []           -> Nothing
+    []               -> Failure Nothing
-    (('-':_):_ ) -> Nothing
+    (('-' : _) : _ ) -> Failure Nothing
-    (s1     :sR) -> Just (s1, InputArgs sR)
+    (s1        : sR) -> Success s1 (InputArgs sR)
 
 
 -- | Add a parameter that consumes _all_ remaining input. Typical usecase is
 -- after a "--" as common in certain (unix?) commandline tools.
 addParamRestOfInput
-  :: forall f out . (Applicative f)
+  :: forall f out
+   . (Applicative f)
   => String
   -> Param Void
   -> CmdParser f out String
@@ -343,15 +360,16 @@ addRestOfInputStringParam name par = addCmdPartInp desc parseF
     addSuggestion (_param_suggestions par)
       $ (maybe id PartWithHelp $ _param_help par)
       $ PartVariable name
-  parseF :: Input -> Maybe (String, Input)
+  parseF :: PartParser String Input
-  parseF (InputString str ) = Just (str, InputString "")
+  parseF (InputString str ) = Success str (InputString "")
-  parseF (InputArgs   args) = Just (List.unwords args, InputArgs [])
+  parseF (InputArgs   args) = Success (List.unwords args) (InputArgs [])
 
 
 -- | Add a parameter that consumes _all_ remaining input, returning a raw
 -- 'Input' value.
 addParamRestOfInputRaw
-  :: forall f out . (Applicative f)
+  :: forall f out
+   . (Applicative f)
   => String
   -> Param Void
   -> CmdParser f out Input
@@ -362,7 +380,7 @@ addParamRestOfInputRaw name par = addCmdPartInp desc parseF
     addSuggestion (_param_suggestions par)
       $ (maybe id PartWithHelp $ _param_help par)
       $ PartVariable name
-  parseF :: Input -> Maybe (Input, Input)
+  parseF :: PartParser Input Input
-  parseF i@InputString{} = Just (i, InputString "")
+  parseF i@InputString{} = Success i (InputString "")
-  parseF i@InputArgs{}   = Just (i, InputArgs [])
+  parseF i@InputArgs{}   = Success i (InputArgs [])
 

src/UI/Butcher/Monadic/Pretty.hs

@@ -42,351 +42,4 @@ where
 
 
 
-#include "prelude.inc"
+import           UI.Butcher.Internal.Pretty
-import           Control.Monad.Free
-import qualified Control.Monad.Trans.MultiRWS.Strict
-                                               as MultiRWSS
-import qualified Control.Monad.Trans.MultiState.Strict
-                                               as MultiStateS
-
-import qualified Text.PrettyPrint              as PP
-import           Text.PrettyPrint               ( (<+>)
-                                                , ($$)
-                                                , ($+$)
-                                                )
-
-import           Data.HList.ContainsType
-
-import           UI.Butcher.Monadic.Internal.Types
-import           UI.Butcher.Monadic.Internal.Core
-
-
-
--- | ppUsage exampleDesc yields:
---
--- > example [--short] NAME [version | help]
-ppUsage :: CommandDesc a -> PP.Doc
-ppUsage (CommandDesc mParent _syn _help parts out children _hidden) =
-  pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]
- where
-  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-  pparents Nothing              = PP.empty
-  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
-  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
-  partDocs = Maybe.mapMaybe ppPartDescUsage parts
-  visibleChildren =
-    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
-  subsDoc = case out of
-    _ | null visibleChildren -> PP.empty
-    Nothing | null parts -> subDoc
-            | otherwise  -> PP.parens $ subDoc
-    Just{} -> PP.brackets $ subDoc
-  subDoc =
-    PP.fcat
-      $   PP.punctuate (PP.text " | ")
-      $   Data.Foldable.toList
-      $   (PP.text . fst)
-      <$> visibleChildren
-
--- | ppUsageShortSub exampleDesc yields:
---
--- > example [--short] NAME <command>
---
--- I.e. Subcommands are abbreviated using the @<command>@ label, instead
--- of being listed.
-ppUsageShortSub :: CommandDesc a -> PP.Doc
-ppUsageShortSub (CommandDesc mParent _syn _help parts out children _hidden) =
-  pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]
- where
-  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-  pparents Nothing              = PP.empty
-  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
-  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
-  partDocs = Maybe.mapMaybe ppPartDescUsage parts
-  visibleChildren =
-    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
-  subsDoc = case out of
-    _ | null visibleChildren -> PP.empty
-    Nothing                  -> subDoc
-    Just{}                   -> PP.brackets $ subDoc
-  subDoc = if null visibleChildren then PP.empty else PP.text "<command>"
-
--- | ppUsageWithHelp exampleDesc yields:
---
--- > example [--short] NAME
--- >         [version | help]: a simple butcher example program
---
--- And yes, the line break is not optimal in this instance with default print.
-ppUsageWithHelp :: CommandDesc a -> PP.Doc
-ppUsageWithHelp (CommandDesc mParent _syn help parts out children _hidden) =
-  pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc
- where
-  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-  pparents Nothing              = PP.empty
-  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
-  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
-  partDocs = Maybe.mapMaybe ppPartDescUsage parts
-  subsDoc  = case out of
-    _ | null children -> PP.empty -- TODO: remove debug
-    Nothing | null parts -> subDoc
-            | otherwise  -> PP.parens $ subDoc
-    Just{} -> PP.brackets $ subDoc
-  subDoc =
-    PP.fcat
-      $ PP.punctuate (PP.text " | ")
-      $ Data.Foldable.toList
-      $ [ PP.text n | (Just n, c) <- children, _cmd_visibility c == Visible ]
-  helpDoc = case help of
-    Nothing -> PP.empty
-    Just h  -> PP.text ":" PP.<+> h
-
--- | > ppUsageAt [] = ppUsage
---
--- fromJust $ ppUsageAt ["version"] exampleDesc yields:
---
--- > example version [--porcelain]
-ppUsageAt
-  :: [String] -- (sub)command sequence
-  -> CommandDesc a
-  -> Maybe PP.Doc
-ppUsageAt strings desc = ppUsage <$> descendDescTo strings desc
-
--- | Access a child command's CommandDesc.
-descendDescTo :: [String] -> CommandDesc a -> Maybe (CommandDesc a)
-descendDescTo strings desc = case strings of
-  [] -> Just desc
-  (s : sr) -> do -- Maybe
-    (_, childDesc) <- find ((Just s ==) . fst) (_cmd_children desc)
-    descendDescTo sr childDesc
-
--- | ppHelpShallow exampleDesc yields:
---
--- > NAME
--- > 
--- >   example - a simple butcher example program
--- > 
--- > USAGE
--- > 
--- >   example [--short] NAME [version | help]
--- > 
--- > DESCRIPTION
--- > 
--- >   a very long help document
--- > 
--- > ARGUMENTS
--- > 
--- >   --short             make the greeting short
--- >   NAME                your name, so you can be greeted properly
-ppHelpShallow :: CommandDesc a -> PP.Doc
-ppHelpShallow desc =
-  nameSection
-    $+$ usageSection
-    $+$ descriptionSection
-    $+$ partsSection
-    $+$ PP.text ""
- where
-  CommandDesc mParent syn help parts _out _children _hidden = desc
-  nameSection = case mParent of
-    Nothing -> PP.empty
-    Just{} ->
-      PP.text "NAME"
-        $+$ PP.text ""
-        $+$ PP.nest
-              2
-              (case syn of
-                Nothing -> pparents mParent
-                Just s  -> pparents mParent <+> PP.text "-" <+> s
-              )
-        $+$ PP.text ""
-  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-  pparents Nothing              = PP.empty
-  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
-  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
-  usageSection = PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsage desc)
-  descriptionSection = case help of
-    Nothing -> PP.empty
-    Just h ->
-      PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h
-  partsSection = if null partsTuples
-    then PP.empty
-    else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest
-      2
-      (PP.vcat partsTuples)
-  partsTuples :: [PP.Doc]
-  partsTuples = parts >>= go
-   where
-    go = \case
-      PartLiteral{}      -> []
-      PartVariable{}     -> []
-      PartOptional p     -> go p
-      PartAlts     ps    -> ps >>= go
-      PartSeq      ps    -> ps >>= go
-      PartDefault    _ p -> go p
-      PartSuggestion _ p -> go p
-      PartRedirect s p ->
-        [PP.text s $$ PP.nest 20 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)]
-          ++ (PP.nest 2 <$> go p)
-      PartReorder ps     -> ps >>= go
-      PartMany    p      -> go p
-      PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
-      PartHidden{}       -> []
-
--- | ppHelpDepthOne exampleDesc yields:
---
--- > NAME
--- > 
--- >   example - a simple butcher example program
--- > 
--- > USAGE
--- > 
--- >   example [--short] NAME <command>
--- > 
--- > DESCRIPTION
--- > 
--- >   a very long help document
--- > 
--- > COMMANDS
--- > 
--- >   version
--- >   help
--- > 
--- > ARGUMENTS
--- > 
--- >   --short             make the greeting short
--- >   NAME                your name, so you can be greeted properly
-ppHelpDepthOne :: CommandDesc a -> PP.Doc
-ppHelpDepthOne desc =
-  nameSection
-    $+$ usageSection
-    $+$ descriptionSection
-    $+$ commandSection
-    $+$ partsSection
-    $+$ PP.text ""
- where
-  CommandDesc mParent syn help parts _out children _hidden = desc
-  nameSection = case mParent of
-    Nothing -> PP.empty
-    Just{} ->
-      PP.text "NAME"
-        $+$ PP.text ""
-        $+$ PP.nest
-              2
-              (case syn of
-                Nothing -> pparents mParent
-                Just s  -> pparents mParent <+> PP.text "-" <+> s
-              )
-        $+$ PP.text ""
-  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-  pparents Nothing              = PP.empty
-  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
-  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
-  usageSection =
-    PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsageShortSub desc)
-  descriptionSection = case help of
-    Nothing -> PP.empty
-    Just h ->
-      PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h
-  visibleChildren =
-    [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
-  childDescs = visibleChildren <&> \(n, c) ->
-    PP.text n $$ PP.nest 20 (Maybe.fromMaybe PP.empty (_cmd_synopsis c))
-  commandSection = if null visibleChildren
-    then PP.empty
-    else PP.text "" $+$ PP.text "COMMANDS" $+$ PP.text "" $+$ PP.nest
-      2
-      (PP.vcat $ Data.Foldable.toList childDescs)
-  partsSection = if null partsTuples
-    then PP.empty
-    else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest
-      2
-      (PP.vcat partsTuples)
-  partsTuples :: [PP.Doc]
-  partsTuples = parts >>= go
-   where
-    go = \case
-      PartLiteral{}      -> []
-      PartVariable{}     -> []
-      PartOptional p     -> go p
-      PartAlts     ps    -> ps >>= go
-      PartSeq      ps    -> ps >>= go
-      PartDefault    _ p -> go p
-      PartSuggestion _ p -> go p
-      PartRedirect s p ->
-        [PP.text s $$ PP.nest 20 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)]
-          ++ (PP.nest 2 <$> go p)
-      PartReorder ps     -> ps >>= go
-      PartMany    p      -> go p
-      PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
-      PartHidden{}       -> []
-
--- | Internal helper; users probably won't need this.
-ppPartDescUsage :: PartDesc -> Maybe PP.Doc
-ppPartDescUsage = \case
-  PartLiteral  s -> Just $ PP.text s
-  PartVariable s -> Just $ PP.text s
-  PartOptional p -> PP.brackets <$> rec p
-  PartAlts ps ->
-    [ PP.fcat $ PP.punctuate (PP.text ",") ds
-    | let ds = Maybe.mapMaybe rec ps
-    , not (null ds)
-    ]
-  PartSeq ps -> [ PP.fsep ds | let ds = Maybe.mapMaybe rec ps, not (null ds) ]
-  PartDefault    _   p -> PP.brackets <$> rec p
-  PartSuggestion sgs p -> rec p <&> \d ->
-    case [ PP.text s | CompletionString s <- sgs ] of
-      [] -> d
-      sgsDocs ->
-        PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ sgsDocs ++ [d]
-  PartRedirect s _ -> Just $ PP.text s
-  PartMany p       -> rec p <&> (PP.<> PP.text "+")
-  PartWithHelp _ p -> rec p
-  PartReorder ps ->
-    let flags  = [ d | PartMany d <- ps ]
-        params = filter
-          (\case
-            PartMany{} -> False
-            _          -> True
-          )
-          ps
-    in  Just $ PP.sep
-          [ (PP.fsep $ PP.brackets <$> Maybe.mapMaybe rec flags)
-          , PP.fsep (Maybe.mapMaybe rec params)
-          ]
-  PartHidden{} -> Nothing
-  where rec = ppPartDescUsage
-
--- | Internal helper; users probably won't need this.
-ppPartDescHeader :: PartDesc -> PP.Doc
-ppPartDescHeader = \case
-  PartLiteral  s     -> PP.text s
-  PartVariable s     -> PP.text s
-  PartOptional ds'   -> rec ds'
-  PartAlts     alts  -> PP.hcat $ List.intersperse (PP.text ",") $ rec <$> alts
-  PartDefault    _ d -> rec d
-  PartSuggestion _ d -> rec d
-  PartRedirect   s _ -> PP.text s
-  PartMany ds        -> rec ds
-  PartWithHelp _ d   -> rec d
-  PartSeq     ds     -> PP.hsep $ rec <$> ds
-  PartReorder ds     -> PP.vcat $ rec <$> ds
-  PartHidden  d      -> rec d
-  where rec = ppPartDescHeader
-
--- | Simple conversion from 'ParsingError' to 'String'.
-parsingErrorString :: ParsingError -> String
-parsingErrorString (ParsingError mess remaining) =
-  "error parsing arguments: " ++ messStr ++ remainingStr
- where
-  messStr = case mess of
-    []      -> ""
-    (m : _) -> m ++ " "
-  remainingStr = case remaining of
-    InputString ""  -> "at the end of input."
-    InputString str -> case show str of
-      s | length s < 42 -> "at: " ++ s ++ "."
-      s                 -> "at: " ++ take 40 s ++ "..\"."
-    InputArgs [] -> "at the end of input"
-    InputArgs xs -> case List.unwords $ show <$> xs of
-      s | length s < 42 -> "at: " ++ s ++ "."
-      s                 -> "at: " ++ take 40 s ++ "..\"."
-

src/UI/Butcher/Monadic/Types.hs

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

srcinc/prelude.inc

@@ -103,18 +103,20 @@ import qualified Control.Monad.Trans.State as State
 import qualified Control.Monad.Trans.State.Lazy as StateL
 import qualified Control.Monad.Trans.State.Strict as StateS
 
+import qualified Control.Monad.Trans.Except as Except
+
 import Data.Functor.Identity ( Identity(..) )
 import Control.Concurrent.Chan ( Chan )
 -- import Control.Concurrent.MVar ( MVar )
 -- import Control.Monad.ST ( ST )
 -- import Data.IORef ( IORef )
-import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), First(..), Last(..), Alt(..), )
+import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), Alt(..), )
 -- import Data.Ord ( Ordering(..), Down(..) )
 -- import Data.Ratio ( Ratio, Rational )
 import Data.Void ( Void )
 -- import Data.Proxy ( Proxy(..) )
 import Data.Sequence ( Seq )
-import Data.Semigroup ( Semigroup(..) )
+import Data.Semigroup ( Semigroup(..), Option )
 
 import Data.Map ( Map )
 import Data.Set ( Set )
@@ -160,6 +162,7 @@ import Prelude                            ( Char
                                           , putStrLn
                                           , putStr
                                           , Show (..)
+                                          , Read (..)
                                           , print
                                           , fst
                                           , snd

stack-8-10.yaml

@@ -38,7 +38,8 @@ packages:
 # - git: https://github.com/commercialhaskell/stack.git
 #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
 #
-# extra-deps: []
+extra-deps:
+  - barbies-2.0.2.0
 
 # Override default flag values for local packages and extra-deps
 # flags: {}

stack-8-4.yaml

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

stack-8-6.yaml

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