hexagoxel
/
butcher
1
0
Fork 0
Code Issues 2 Pull Requests Packages Projects Releases Wiki Activity

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.
devtest
Lennart Spitzner 2020-04-18 16:50:15 +02:00
parent 6eb306cfd0
commit 5d67167c87
29 changed files with 3146 additions and 1554 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
butcher.cabal
View File

@ -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.Monadic.Internal.Core
UI.Butcher.Applicative.Command
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

258
src-tests/TestMain.hs
View File

@ -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.Types
import UI.Butcher.Monadic.Interactive
import UI.Butcher.Monadic
import UI.Butcher.Monadic.Types
@ -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
`shouldSatisfy` Data.Either.isLeft . snd
it "toplevel" $ (testParse testCmd1 "" >>= _cmd_out)
`shouldSatisfy` Maybe.isNothing
it "hasImpl 001" $ (testParse testCmd1 "abc" >>= _cmd_out)
`shouldSatisfy` Maybe.isJust
it "hasImpl 002" $ (testParse testCmd1 "def" >>= _cmd_out)
`shouldSatisfy` Maybe.isJust
it "failed parse 001"
$ let r = runCmdParserSimpleString "foo" testCmd1
in r `shouldSatisfy` Data.Either.isLeft
it "toplevel" $ (testParse testCmd1 "") `shouldBe` Nothing
it "hasImpl 001" $ (testParse testCmd1 "abc") `shouldSatisfy` Maybe.isJust
it "hasImpl 002" $ (testParse testCmd1 "def") `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 2" $ testRun testCmd1 "def" `shouldBe` Right (Just 200)
it "flag 1" $ testRun testCmd1 "abc -f" `shouldBe` Right (Just 101)
it "flag 2" $ testRun testCmd1 "abc --flong" `shouldBe` Right (Just 101)
it "flag 3" $ testRun testCmd1 "abc -f -f" `shouldBe` Right (Just 101)
it "flag 4" $ testRun testCmd1 "abc -f -g" `shouldBe` Right (Just 103)
it "flag 5" $ testRun testCmd1 "abc -f -g -f" `shouldSatisfy` Data.Either.isLeft -- no reordering
it "flag 6" $ testRun testCmd1 "abc -g -f" `shouldSatisfy` Data.Either.isLeft -- no reordering
it "flag 7" $ testRun testCmd1 "abc -g -g" `shouldBe` Right (Just 102)
it "cmd 1" $ testRun testCmd1 "abc" `shouldBeRight` (Just 100)
it "cmd 2" $ testRun testCmd1 "def" `shouldBeRight` (Just 200)
it "flag 1" $ testRun testCmd1 "abc -f" `shouldBeRight` (Just 101)
it "flag 2" $ testRun testCmd1 "abc --flong" `shouldBeRight` (Just 101)
it "flag 3" $ testRun testCmd1 "abc -f -f" `shouldBeRight` (Just 101)
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 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 2" $ testRun testCmd2 "def" `shouldBe` Right (Just 200)
it "flag 1" $ testRun testCmd2 "abc -f" `shouldBe` Right (Just 101)
it "flag 2" $ testRun testCmd2 "abc --flong" `shouldBe` Right (Just 101)
it "flag 3" $ testRun testCmd2 "abc -f -f" `shouldBe` Right (Just 101)
it "flag 4" $ testRun testCmd2 "abc -f -g" `shouldBe` Right (Just 103)
it "flag 5" $ testRun testCmd2 "abc -f -g -f" `shouldBe` Right (Just 103)
it "flag 6" $ testRun testCmd2 "abc -g -f" `shouldBe` Right (Just 103)
it "flag 7" $ testRun testCmd2 "abc -g -g" `shouldBe` Right (Just 102)
it "cmd 1" $ testRun testCmd2 "abc" `shouldBeRight` (Just 100)
it "cmd 2" $ testRun testCmd2 "def" `shouldBeRight` (Just 200)
it "flag 1" $ testRun testCmd2 "abc -f" `shouldBeRight` (Just 101)
it "flag 2" $ testRun testCmd2 "abc --flong" `shouldBeRight` (Just 101)
it "flag 3" $ testRun testCmd2 "abc -f -f" `shouldBeRight` (Just 101)
it "flag 4" $ testRun testCmd2 "abc -f -g" `shouldBeRight` (Just 103)
it "flag 5" $ testRun testCmd2 "abc -f -g -f" `shouldBeRight` (Just 103)
it "flag 6" $ testRun testCmd2 "abc -g -f" `shouldBeRight` (Just 103)
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 2" $ testRunA testCmd3 "abc -f" `shouldBe` Right 1
it "flag 3" $ testRunA testCmd3 "abc -g" `shouldBe` Right 2
it "flag 4" $ testRunA testCmd3 "abc -f -g" `shouldBe` Right 3
it "flag 5" $ testRunA testCmd3 "abc -g -f" `shouldBe` Right 3
describe "separated children" $ do
it "case 1" $ testRun testCmd4 "a aa" `shouldBe` Right (Just 1)
it "case 2" $ testRun testCmd4 "a ab" `shouldBe` Right (Just 2)
it "case 3" $ testRun testCmd4 "b ba" `shouldBe` Right (Just 3)
it "case 4" $ testRun testCmd4 "b bb" `shouldBe` Right (Just 4)
it "doc" $ show (ppHelpShallow (getDoc "" testCmd4)) `shouldBe`
List.unlines
[ "NAME"
, ""
, " test"
, ""
, "USAGE"
, ""
, " test a | b"
]
it "doc" $ show (ppHelpShallow (getDoc "a" testCmd4)) `shouldBe`
List.unlines
[ "NAME"
, ""
, " test a"
, ""
, "USAGE"
, ""
, " test a aa | ab"
]
it "flag 1" $ testRunA testCmd3 "abc" `shouldBeRight` 0
it "flag 2" $ testRunA testCmd3 "abc -f" `shouldBeRight` 1
it "flag 3" $ testRunA testCmd3 "abc -g" `shouldBeRight` 2
it "flag 4" $ testRunA testCmd3 "abc -f -g" `shouldBeRight` 3
it "flag 5" $ testRunA testCmd3 "abc -g -f" `shouldBeRight` 3
describe "read flags" $ do
it "flag 1" $ testRun testCmd5 "abc" `shouldBe` Right (Just 10)
it "flag 2" $ testRun testCmd5 "abc -f 2" `shouldBe` Right (Just 2)
it "flag 3" $ testRun testCmd5 "abc --flag 3" `shouldBe` Right (Just 3)
it "flag 4" $ testRun testCmd5 "abc -f=4" `shouldBe` Right (Just 4)
it "flag 5" $ testRun testCmd5 "abc --flag=5" `shouldBe` Right (Just 5)
it "flag 1" $ testRun testCmd5 "abc" `shouldBeRight` (Just 10)
it "flag 2" $ testRun testCmd5 "abc -f 2" `shouldBeRight` (Just 2)
it "flag 3" $ testRun testCmd5 "abc --flag 3" `shouldBeRight` (Just 3)
it "flag 4" $ testRun testCmd5 "abc -f=4" `shouldBeRight` (Just 4)
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 6" $ testRun testCmd5 "abc --f 0" `shouldSatisfy` Data.Either.isLeft
it "flag 7"
$ 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 2" $ testRun' testCmd6 "-f" `shouldBe` Right (Just ([], 1))
it "case 3" $ testRun' testCmd6 "abc" `shouldBe` Right (Just (["abc"], 0))
it "case 4" $ testRun' testCmd6 "abc def" `shouldBe` Right (Just (["abc", "def"], 0))
it "case 5" $ testRun' testCmd6 "-g abc def" `shouldBe` Right (Just (["abc", "def"], 2))
it "case 6" $ testRun' testCmd6 "-f -g def" `shouldBe` Right (Just (["def"], 3))
it "case 1" $ testRun' testCmd6 "" `shouldBeRight` (Just ([], 0))
it "case 2" $ testRun' testCmd6 "-f" `shouldBeRight` (Just ([], 1))
it "case 3" $ testRun' testCmd6 "abc" `shouldBeRight` (Just (["abc"], 0))
it "case 4"
$ testRun' testCmd6 "abc def"
`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 2" $ testRun' testCmd7 "-f" `shouldBe` Right (Just ([], 1))
it "case 3" $ testRun' testCmd7 "abc" `shouldBe` Right (Just (["abc"], 0))
it "case 4" $ testRun' testCmd7 "abc -f" `shouldBe` Right (Just (["abc"], 1))
it "case 5" $ testRun' testCmd7 "-g abc -f" `shouldBe` Right (Just (["abc"], 3))
it "case 6" $ testRun' testCmd7 "abc -g def" `shouldBe` Right (Just (["abc", "def"], 2))
it "case 1" $ testRun' testCmd7 "" `shouldBeRight` (Just ([], 0))
it "case 2" $ testRun' testCmd7 "-f" `shouldBeRight` (Just ([], 1))
it "case 3" $ testRun' testCmd7 "abc" `shouldBeRight` (Just (["abc"], 0))
it "case 4" $ testRun' testCmd7 "abc -f" `shouldBeRight` (Just (["abc"], 1))
it "case 5"
$ 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 5" $ testRun testCmdParam "False y" `shouldBe` Right (Just 310)
it "case 6" $ testRun testCmdParam "True n" `shouldBe` Right (Just 1110)
it "case 7" $ testRun testCmdParam "True y" `shouldBe` Right (Just 1310)
it "case 8" $ testRun testCmdParam "1 False y" `shouldBe` Right (Just 301)
it "case 9" $ testRun testCmdParam "1 False y def" `shouldBe` Right (Just 201)
it "case 10" $ testRun testCmdParam "1 False 2 y def" `shouldBe` Right (Just 203)
it "case 11" $ testRun testCmdParam "1 True 2 y def" `shouldBe` Right (Just 1203)
it "case 4" $ testRun testCmdParam "False n" `shouldBeRight` (Just 110)
it "case 5" $ testRun testCmdParam "False y" `shouldBeRight` (Just 310)
it "case 6" $ testRun testCmdParam "True n" `shouldBeRight` (Just 1110)
it "case 7" $ testRun testCmdParam "True y" `shouldBeRight` (Just 1310)
it "case 8" $ testRun testCmdParam "1 False y" `shouldBeRight` (Just 301)
it "case 9"
$ testRun testCmdParam "1 False y def"
`shouldBeRight` (Just 201)
it "case 10"
$ testRun testCmdParam "1 False 2 y def"
`shouldBeRight` (Just 203)
it "case 11"
$ testRun testCmdParam "1 True 2 y def"
`shouldBeRight` (Just 1203)
describe "completions" $ do
it "case 1" $ testCompletion completionTestCmd "" `shouldBe` ""
it "case 2" $ testCompletion completionTestCmd "a" `shouldBe` "bc"
@ -177,8 +173,8 @@ testCmd3 :: CmdParser (StateS.State Int) () ()
testCmd3 = do
addCmd "abc" $ do
reorderStart
addSimpleFlagA "f" ["flong"] mempty (StateS.modify (+1))
addSimpleFlagA "g" ["glong"] mempty (StateS.modify (+2))
addSimpleFlagA "f" ["flong"] mempty (StateS.modify (+ 1))
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
g <- addSimpleBoolFlag "g" ["glong"] mempty
f <- addSimpleBoolFlag "f" ["flong"] 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
g <- addSimpleBoolFlag "g" ["glong"] mempty
f <- addSimpleBoolFlag "f" ["flong"] 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
r <- addParamReadOpt "MAY1" (paramDefault 20)
s <- addParamString "MAND" mempty
q <- addParamString "STR" (paramDefault "abc")
b <- addParamRead "MANDR" mempty
r <- addParamReadOpt "MAY1" (paramDefault 20)
s <- addParamString "MAND" mempty
q <- addParamString "STR" (paramDefault "abc")
addCmdImpl $ do
WriterS.tell (Sum p)
when (q=="abc") $ WriterS.tell 100
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
(cDesc, InputString cRest, _) -> simpleCompletion inp cDesc cRest
_ -> error "wut"
testCompletion p inp =
_ppi_inputSugg $ runCmdParser Nothing (InputString inp) p
testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out)
testParse cmd s = either (const Nothing) Just
$ snd
$ runCmdParser Nothing (InputString s) cmd
testParse :: CmdParser Identity out () -> String -> Maybe out
testParse cmd s = case runCmdParserSimpleString s cmd of
Left{} -> Nothing
Right o -> Just o
testRun :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () -> String -> Either ParsingError (Maybe Int)
testRun cmd s = fmap (fmap (getSum . WriterS.execWriter) . _cmd_out)
$ snd
$ runCmdParser Nothing (InputString s) cmd
testRun' :: CmdParser Identity (WriterS.Writer (Sum Int) a) () -> String -> Either ParsingError (Maybe (a, Int))
testRun' cmd s =
fmap (fmap (fmap getSum . WriterS.runWriter) . _cmd_out) $ snd $ runCmdParser
testRun
:: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
-> String
-> Either ParsingError (Maybe Int)
testRun cmd s =
fmap (fmap (getSum . WriterS.execWriter)) $ _ppi_value $ runCmdParser
Nothing
(InputString s)
cmd
testRunA :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError Int
testRunA cmd str = (\((_, e), s) -> e $> s)
$ flip StateS.runState (0::Int)
$ runCmdParserA Nothing (InputString str) cmd
testRun'
:: CmdParser Identity (WriterS.Writer (Sum Int) a) ()
-> String
-> Either ParsingError (Maybe (a, Int))
testRun' cmd s =
fmap (fmap (fmap getSum . WriterS.runWriter)) $ _ppi_value $ runCmdParser
Nothing
(InputString s)
cmd
getDoc :: String -> CmdParser Identity out () -> CommandDesc ()
getDoc s = fst . runCmdParser (Just "test") (InputString s)
testRunA
:: 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

210
src/UI/Butcher/Applicative.hs Normal file
View File

@ -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)

28
src/UI/Butcher/Applicative/Command.hs Normal file
View File

@ -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

295
src/UI/Butcher/Applicative/Flag.hs Normal file
View File

@ -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 ]

94
src/UI/Butcher/Applicative/IO.hs Normal file
View File

@ -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

298
src/UI/Butcher/Applicative/Param.hs Normal file
View File

@ -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 [])

45
src/UI/Butcher/Applicative/Pretty.hs Normal file
View File

@ -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

378
src/UI/Butcher/Internal/Applicative.hs Normal file
View File

@ -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))

97
src/UI/Butcher/Internal/ApplicativeTypes.hs Normal file
View File

@ -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

42
src/UI/Butcher/Internal/BasicStringParser.hs Normal file
View File

@ -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 ()

78
src/UI/Butcher/Monadic/Internal/Types.hs → src/UI/Butcher/Internal/CommonTypes.hs
View File

@ -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_remaining :: Input
{ _pe_messages :: [String]
, _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
{ _cmd_mParent :: Maybe (Maybe String, CommandDesc out)
data CommandDesc = CommandDesc
{ _cmd_mParent :: Maybe (Maybe String, CommandDesc)
, _cmd_synopsis :: Maybe PP.Doc
, _cmd_help :: Maybe PP.Doc
, _cmd_parts :: [PartDesc]
, _cmd_out :: Maybe out
, _cmd_children :: Deque (Maybe String, CommandDesc out)
, _cmd_hasImpl :: Bool
, _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

157
src/UI/Butcher/Internal/Interactive.hs Normal file
View File

@ -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

861
src/UI/Butcher/Monadic/Internal/Core.hs → src/UI/Butcher/Internal/Monadic.hs
View File

File diff suppressed because it is too large Load Diff

141
src/UI/Butcher/Internal/MonadicTypes.hs Normal file
View File

@ -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"

394
src/UI/Butcher/Internal/Pretty.hs Normal file
View File

@ -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 ++ "..\"."

128
src/UI/Butcher/Monadic.hs
View File

@ -4,24 +4,22 @@ module UI.Butcher.Monadic
Input (..)
, CmdParser
, ParsingError (..)
, CommandDesc(_cmd_out)
, cmd_out
, PartialParseInfo (..)
, 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.Monadic.Internal.Types
import UI.Butcher.Monadic.Command
import UI.Butcher.Monadic.BuiltinCommands
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Monadic.Pretty
import UI.Butcher.Monadic.IO
import UI.Butcher.Monadic.Interactive
import UI.Butcher.Internal.Monadic
import UI.Butcher.Internal.MonadicTypes
import UI.Butcher.Internal.Interactive
import UI.Butcher.Monadic.BuiltinCommands
import UI.Butcher.Monadic.Command
import UI.Butcher.Monadic.IO
import UI.Butcher.Monadic.Pretty
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 (), Either ParsingError (CommandDesc out))
-> (CommandDesc -> CmdParser Identity out ()) -- ^ parser to use
-> (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
runCmdParserSimple s p = case snd $ runCmdParser Nothing (InputString s) p of
Left e -> Left $ parsingErrorString e
Right desc ->
maybe (Left "command has no implementation") Right $ _cmd_out desc
runCmdParserSimpleString :: String -> CmdParser Identity out () -> Either String out
runCmdParserSimpleString s p = case toCmdDesc Nothing p of
Left err -> Left err
Right fullDesc ->
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
(desc, Left e) -> do
print e
print $ ppHelpShallow desc
_cmd_mParent desc `forM_` \(_, d) -> do
print $ ppUsage d
(desc, Right out) -> do
case _cmd_out out of
Nothing -> do
putStrLn "command is missing implementation!"
print $ ppHelpShallow desc
Just f -> f
_test3 s = do
case _ppi_value info of
Left err -> do
print err
print $ ppHelpShallow (_ppi_localDesc info)
_cmd_mParent (_ppi_localDesc info) `forM_` \(_, d) -> do
print $ ppUsage d
Right Nothing -> do
putStrLn "command is missing implementation!"
print $ ppHelpShallow (_ppi_localDesc info)
Right (Just f) -> f
where
info = runCmdParser Nothing (InputString s) _cmds

31
src/UI/Butcher/Monadic/BuiltinCommands.hs
View File

@ -21,11 +21,11 @@ import qualified Text.PrettyPrint as PP
import Data.HList.ContainsType
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Internal.MonadicTypes
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 a
=> (CommandDesc -> IO String)
-> 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) =
runCmdParserExt Nothing rest mainCmdParser
let (cdesc, remaining, result) =
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)

7
src/UI/Butcher/Monadic/Command.hs
View File

@ -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.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Internal.MonadicTypes
import UI.Butcher.Internal.Monadic
import UI.Butcher.Monadic.Flag
import UI.Butcher.Monadic.Param

246
src/UI/Butcher/Monadic/Flag.hs
View File

@ -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.MultiState.Strict as MultiStateS
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 qualified Text.PrettyPrint as PP
import Data.HList.ContainsType
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Internal.Monadic
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
= void $ addSimpleBoolFlagAll shorts longs flag act
addSimpleFlagA shorts longs flag act =
void $ addSimpleBoolFlagAll shorts longs flag act
addSimpleBoolFlagAll
:: String
-> [String]
-> Flag Void
-> f ()
-> CmdParser f out Bool
:: String -> [String] -> Flag Void -> f () -> CmdParser f out Bool
addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
$ addCmdPartManyA ManyUpperBound1 (wrapHidden flag desc) parseF (\() -> a)
where
@ -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)
<|> ( firstJust
( \s ->
resultFromMaybe
$ (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
<|> (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
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> Flag Void -- ^ properties
-> CmdParser f out Int
addSimpleCountFlag
:: Applicative f
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> Flag Void -- ^ properties
-> CmdParser f out Int
addSimpleCountFlag shorts longs flag = fmap length
$ addCmdPartMany ManyUpperBoundN (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)
<|> ( firstJust
( \s ->
resultFromMaybe
$ (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
<|> (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 =
addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())
addFlagReadParam shorts longs name flag = addCmdPartInpA
(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 ->
maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)
$ parseResult
InputString str -> case parseResult of
Nothing -> resultFromMaybe $ _flag_default flag <&> \x -> (x, inp)
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, "" ):_) -> StateS.put "" $> x
_ -> mzero
InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
((x, ' ' : r) : _) ->
StateS.put (dropWhile Char.isSpace r) $> Right x
((x, "") : _) -> StateS.put "" $> Right x
_ -> pure $ Left desc2
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 -> _flag_default flag <&> \d -> (d, inp)
[] -> Failure Nothing
(arg2 : rest) -> case Text.Read.readMaybe arg2 of
Just x -> Success x (InputArgs rest)
Nothing -> Failure (Just desc2)
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
= addFlagReadParamsAll shorts longs name flag (\_ -> pure ())
addFlagReadParams shorts longs name flag =
addFlagReadParamsAll shorts longs name flag (\_ -> pure ())
-- TODO: this implementation is wrong, because it uses addCmdPartManyInpA
-- while this really is no Many.
@ -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
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- ^ param name
-> Flag p -- ^ properties
-> (p -> f ()) -- ^ action to execute when ths param matches
-> CmdParser f out [p]
:: forall f p out
. (Typeable p, Text.Read.Read p, Show p)
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- ^ param name
-> Flag p -- ^ properties
-> (p -> f ()) -- ^ action to execute when ths param matches
-> CmdParser f out [p]
addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA
ManyUpperBoundN
(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 ->
fmap (second InputString) $ parseResult
InputString str -> case parseResult of
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, "" ):_) -> StateS.put "" $> x
_ -> lift $ _flag_default flag
InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
((x, ' ' : r) : _) ->
StateS.put (dropWhile Char.isSpace r) $> Right x
((x, "") : _) -> StateS.put "" $> Right x
_ -> 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
(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
[] -> mdef
(arg2 : rest) -> case Text.Read.readMaybe arg2 of
Just x -> Success x (InputArgs rest)
Nothing -> mdef
where
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
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- ^ param name
-> Flag String -- ^ properties
-> CmdParser f out String
addFlagStringParam shorts longs name flag =
addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())
:: forall f out
. (Applicative f)
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- ^ param name
-> Flag String -- ^ properties
-> CmdParser f out String
addFlagStringParam shorts longs name flag = addCmdPartInpA
(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 ->
maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)
$ parseResult
InputString str -> case parseResult of
Nothing -> resultFromMaybe $ _flag_default flag <&> \x -> (x, inp)
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
InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
pure $ Right x
InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of
Just ((), "") -> case argR of
[] -> Nothing
(x:rest) -> Just (x, InputArgs rest)
Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)
Nothing -> _flag_default flag <&> \d -> (d, inp)
[] -> Failure Nothing
(x : rest) -> Success x (InputArgs rest)
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 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
= addFlagStringParamsAll shorts longs name flag (\_ -> pure ())
addFlagStringParams shorts longs name flag =
addFlagStringParamsAll shorts longs name flag (\_ -> pure ())
-- TODO: this implementation is wrong, because it uses addCmdPartManyInpA
-- while this really is no Many.
@ -405,13 +445,14 @@ addFlagStringParams shorts longs name flag
-- = void $ addFlagStringParamsAll shorts longs name flag act
addFlagStringParamsAll
:: forall f out . String
-> [String]
-> String
-> Flag Void -- we forbid the default because it has bad interaction
:: forall f out
. String
-> [String]
-> String
-> Flag Void -- we forbid the default because it has bad interaction
-- with the eat-anything behaviour of the string parser.
-> (String -> f ())
-> CmdParser f out [String]
-> (String -> f ())
-> 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
Just ((), "" ) -> case argR of
[] -> Nothing
(x:rest) -> Just (x, InputArgs rest)
Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)
Nothing -> Nothing
InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of
Just ((), "") -> case argR of
[] -> Failure Nothing
(x : rest) -> Success x (InputArgs rest)
Just ((), remainingStr) -> Success remainingStr (InputArgs argR)
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

73
src/UI/Butcher/Monadic/IO.hs
View File

@ -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.MultiState.Strict as MultiStateS
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 qualified Text.PrettyPrint as PP
import Data.HList.ContainsType
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Monadic.Pretty
import UI.Butcher.Internal.Monadic
import UI.Butcher.Internal.MonadicTypes
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
Left e -> do
case toCmdDesc (Just progName) cmd of
Left e -> do
putStrErrLn
$ progName
++ ": internal error: failed sanity check for butcher main command parser!"
putStrErrLn $ "(" ++ e ++ ")"
putStrErrLn $ "aborting."
Right _ -> do
Right fullDesc -> do
args <- System.Environment.getArgs
case runCmdParser (Just progName) (InputArgs args) cmd of
(desc, Left (ParsingError mess remaining)) -> do
case runCmdParserCoreFromDesc fullDesc (InputArgs args) cmd of
(desc, _, Left err) -> do
putStrErrLn
$ progName
++ ": error parsing arguments: "
++ case mess of
[] -> ""
(m:_) -> m
putStrErrLn $ case remaining of
++ 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
InputArgs [] -> "at the end of input"
InputArgs xs -> case List.unwords $ show <$> xs of
s | length s < 42 -> "at: " ++ s ++ "."
s -> "at: " ++ take 40 s ++ "..\"."
putStrErrLn $ "usage:"
printErr $ ppUsage desc
(desc, Right out ) -> case _cmd_out out of
(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
(desc, Left (ParsingError mess remaining)) -> do
putStrErrLn $ progName ++ ": error parsing arguments: " ++ head mess
putStrErrLn $ case remaining of
InputString "" -> "at the end of input."
case runCmdParserCoreFromDesc fullDesc (InputArgs args) (cmdF fullDesc) 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 ++ "..\"."
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

201
src/UI/Butcher/Monadic/Interactive.hs
View File

@ -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{} -> []

254
src/UI/Butcher/Monadic/Param.hs
View File

@ -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.MultiState.Strict as MultiStateS
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 qualified Text.PrettyPrint as PP
import Data.HList.ContainsType
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Internal.Monadic
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_help :: Maybe PP.Doc
{ _param_default :: Maybe p
, _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
. (Applicative f, Typeable a, Show a, Text.Read.Read a)
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out a
addParamRead
:: forall f out a
. (Applicative f, Typeable a, Show a, Text.Read.Read a)
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out a
addParamRead = addReadParam
{-# DEPRECATED addReadParam "use 'addParamRead'" #-}
addReadParam :: forall f out a
. (Applicative f, Typeable a, Show a, Text.Read.Read a)
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out a
addReadParam
:: forall f out a
. (Applicative f, Typeable a, Show a, Text.Read.Read a)
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out a
addReadParam name par = addCmdPart desc parseF
where
desc :: PartDesc
desc = addSuggestion (_param_suggestions par)
$ (maybe id PartWithHelp $ _param_help par)
$ (maybe id (PartDefault . show) $ _param_default par)
$ PartVariable name
parseF :: String -> Maybe (a, String)
parseF s = case Text.Read.reads s of
((x, ' ':r):_) -> Just (x, dropWhile Char.isSpace r)
((x, []):_) -> Just (x, [])
_ -> _param_default par <&> \x -> (x, s)
where
desc :: PartDesc
desc =
addSuggestion (_param_suggestions par)
$ (maybe id PartWithHelp $ _param_help par)
$ (maybe id (PartDefault . show) $ _param_default par)
$ PartVariable name
parseF :: PartParser a String
parseF s = resultFromMaybe $ case Text.Read.reads s of
((x, ' ' : r) : _) -> Just (x, dropWhile Char.isSpace r)
((x, [] ) : _) -> Just (x, [])
_ -> _param_default par <&> \x -> (x, s)
-- | Like addReadParam, but optional. I.e. if reading fails, returns Nothing.
addParamReadOpt :: forall f out a
. (Applicative f, Typeable a, Text.Read.Read a)
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out (Maybe a)
addParamReadOpt
:: forall f out a
. (Applicative f, Typeable a, Text.Read.Read a)
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out (Maybe a)
addParamReadOpt = addReadParamOpt
{-# DEPRECATED addReadParamOpt "use 'addParamReadOpt'" #-}
addReadParamOpt :: forall f out a
. (Applicative f, Typeable a, Text.Read.Read a)
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out (Maybe a)
addReadParamOpt
:: forall f out a
. (Applicative f, Typeable a, Text.Read.Read a)
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out (Maybe a)
addReadParamOpt name par = addCmdPart desc parseF
where
desc :: PartDesc
desc = addSuggestion (_param_suggestions par)
$ PartOptional
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: String -> Maybe (Maybe a, String)
parseF s = case Text.Read.reads s of
((x, ' ':r):_) -> Just (Just x, dropWhile Char.isSpace r)
((x, []):_) -> Just (Just x, [])
_ -> Just (Nothing, s) -- TODO: we could warn about a default..
where
desc :: PartDesc
desc =
addSuggestion (_param_suggestions par)
$ PartOptional
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: PartParser (Maybe a) String
parseF s = resultFromMaybe $ case Text.Read.reads s of
((x, ' ' : r) : _) -> Just (Just x, dropWhile Char.isSpace r)
((x, [] ) : _) -> Just (Just x, [])
_ -> Just (Nothing, s) -- TODO: we could warn about a default..
-- | Add a parameter that matches any string of non-space characters if
-- input==String, or one full argument if input==[String]. See the 'Input' doc
-- for this distinction.
addParamString
:: forall f out . (Applicative f)
:: forall f out
. (Applicative f)
=> String
-> Param String
-> CmdParser f out String
addParamString = addStringParam
{-# 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
desc :: PartDesc
desc = addSuggestion (_param_suggestions par)
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: Input -> Maybe (String, Input)
parseF (InputString str)
= case break Char.isSpace $ dropWhile Char.isSpace str of
("", rest) -> _param_default par <&> \x -> (x, InputString rest)
(x, rest) -> Just (x, InputString rest)
parseF (InputArgs args) = case args of
(s1:sR) -> Just (s1, InputArgs sR)
[] -> _param_default par <&> \x -> (x, InputArgs args)
where
desc :: PartDesc
desc =
addSuggestion (_param_suggestions par)
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: PartParser String Input
parseF (InputString str) =
case break Char.isSpace $ dropWhile Char.isSpace str of
("", rest) ->
resultFromMaybe $ _param_default par <&> \x -> (x, InputString rest)
(x, rest) -> Success x (InputString rest)
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
desc :: PartDesc
desc = addSuggestion (_param_suggestions par)
$ PartOptional
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: Input -> Maybe (Maybe String, Input)
parseF (InputString str)
= case break Char.isSpace $ dropWhile Char.isSpace str of
("", rest) -> Just (Nothing, InputString rest)
(x, rest) -> Just (Just x, InputString rest)
parseF (InputArgs args) = case args of
(s1:sR) -> Just (Just s1, InputArgs sR)
[] -> Just (Nothing, InputArgs [])
where
desc :: PartDesc
desc =
addSuggestion (_param_suggestions par)
$ PartOptional
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: PartParser (Maybe String) Input
parseF (InputString str) =
case break Char.isSpace $ dropWhile Char.isSpace str of
("", rest) -> Success Nothing (InputString rest)
(x , rest) -> Success (Just x) (InputString rest)
parseF (InputArgs args) = case args of
(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
(x , rest) -> Just (x, InputString rest)
("", _ ) -> Failure Nothing
(x , rest) -> Success x (InputString rest)
parseF (InputArgs args) = case args of
(s1:sR) -> Just (s1, InputArgs sR)
[] -> Nothing
(s1 : sR) -> Success s1 (InputArgs sR)
[] -> 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
("" , rest) -> _param_default par <&> \x -> (x, InputString rest)
('-':_, _ ) -> _param_default par <&> \x -> (x, InputString str)
(x , rest) -> Just (x, InputString rest)
parseF (InputArgs args) = case args of
[] -> _param_default par <&> \x -> (x, InputArgs args)
(('-':_):_ ) -> _param_default par <&> \x -> (x, InputArgs args)
(s1 :sR) -> Just (s1, InputArgs sR)
resultFromMaybe $ case break Char.isSpace $ dropWhile Char.isSpace str of
("" , rest) -> _param_default par <&> \x -> (x, InputString rest)
('-' : _, _ ) -> _param_default par <&> \x -> (x, InputString str)
(x , rest) -> Just (x, InputString rest)
parseF (InputArgs args) = resultFromMaybe $ case args of
[] -> _param_default par <&> \x -> (x, InputArgs args)
(('-' : _) : _ ) -> _param_default par <&> \x -> (x, InputArgs args)
(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)
('-':_, _ ) -> Just (Nothing, InputString str)
(x , rest) -> Just (Just x, InputString rest)
("" , rest) -> Success Nothing (InputString rest)
('-' : _, _ ) -> Success Nothing (InputString str)
(x , rest) -> Success (Just x) (InputString rest)
parseF (InputArgs args) = case args of
[] -> Just (Nothing, InputArgs [])
(('-':_):_ ) -> Just (Nothing, InputArgs args)
(s1 :sR) -> Just (Just s1, InputArgs sR)
[] -> Success Nothing (InputArgs [])
(('-' : _) : _ ) -> Success Nothing (InputArgs args)
(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
('-':_, _ ) -> Nothing
(x , rest) -> Just (x, InputString rest)
("" , _ ) -> Failure Nothing
('-' : _, _ ) -> Failure Nothing
(x , rest) -> Success x (InputString rest)
parseF (InputArgs args) = case args of
[] -> Nothing
(('-':_):_ ) -> Nothing
(s1 :sR) -> Just (s1, InputArgs sR)
[] -> Failure Nothing
(('-' : _) : _ ) -> Failure Nothing
(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 (InputString str ) = Just (str, InputString "")
parseF (InputArgs args) = Just (List.unwords args, InputArgs [])
parseF :: PartParser String Input
parseF (InputString str ) = Success str (InputString "")
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 i@InputString{} = Just (i, InputString "")
parseF i@InputArgs{} = Just (i, InputArgs [])
parseF :: PartParser Input Input
parseF i@InputString{} = Success i (InputString "")
parseF i@InputArgs{} = Success i (InputArgs [])

349
src/UI/Butcher/Monadic/Pretty.hs
View File

@ -42,351 +42,4 @@ where
#include "prelude.inc"
import Control.Monad.Free
import qualified Control.Monad.Trans.MultiRWS.Strict
as MultiRWSS
import qualified Control.Monad.Trans.MultiState.Strict
as MultiStateS
import qualified Text.PrettyPrint as PP
import Text.PrettyPrint ( (<+>)
, ($$)
, ($+$)
)
import Data.HList.ContainsType
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
-- | ppUsage exampleDesc yields:
--
-- > 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 ++ "..\"."
import UI.Butcher.Internal.Pretty

3
src/UI/Butcher/Monadic/Types.hs
View File

@ -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

7
srcinc/prelude.inc
View File

@ -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

3
stack-8-10.yaml
View File

@ -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: {}

2
stack-8-4.yaml
View File

@ -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

1
stack-8-6.yaml
View File

@ -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: {}