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
parent
6eb306cfd0
commit
5d67167c87
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -10,7 +10,6 @@ import Test.Hspec
|
|||
|
||||
import UI.Butcher.Monadic
|
||||
import UI.Butcher.Monadic.Types
|
||||
import UI.Butcher.Monadic.Interactive
|
||||
|
||||
|
||||
|
||||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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 ]
|
||||
|
|
@ -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
|
||||
|
|
@ -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 [])
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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))
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ()
|
||||
|
||||
|
|
@ -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_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
|
||||
|
||||
|
|
@ -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
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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"
|
||||
|
|
@ -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 ++ "..\"."
|
||||
|
||||
|
|
@ -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.Internal.Monadic
|
||||
import UI.Butcher.Internal.MonadicTypes
|
||||
import UI.Butcher.Internal.Interactive
|
||||
import UI.Butcher.Monadic.BuiltinCommands
|
||||
import UI.Butcher.Monadic.Internal.Core
|
||||
import UI.Butcher.Monadic.Pretty
|
||||
import UI.Butcher.Monadic.Command
|
||||
import UI.Butcher.Monadic.IO
|
||||
import UI.Butcher.Monadic.Interactive
|
||||
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
|
||||
_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
|
||||
(desc, Right out) -> do
|
||||
case _cmd_out out of
|
||||
Nothing -> do
|
||||
Right Nothing -> do
|
||||
putStrLn "command is missing implementation!"
|
||||
print $ ppHelpShallow desc
|
||||
Just f -> f
|
||||
print $ ppHelpShallow (_ppi_localDesc info)
|
||||
Right (Just f) -> f
|
||||
where
|
||||
info = runCmdParser Nothing (InputString s) _cmds
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -32,15 +32,17 @@ 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 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 )
|
||||
|
||||
|
|
@ -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,9 +154,10 @@ addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
|
|||
$ PartAlts
|
||||
$ PartLiteral
|
||||
<$> allStrs
|
||||
parseF :: String -> Maybe ((), String)
|
||||
parseF :: PartParser () String
|
||||
parseF (dropWhile Char.isSpace -> str) =
|
||||
(firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
|
||||
resultFromMaybe
|
||||
$ (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
|
||||
<|> (firstJust
|
||||
(\s ->
|
||||
[ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ]
|
||||
|
|
@ -168,7 +167,8 @@ addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
|
|||
|
||||
-- | A no-parameter flag that can occur multiple times. Returns the number of
|
||||
-- occurences (0 or more).
|
||||
addSimpleCountFlag :: Applicative f
|
||||
addSimpleCountFlag
|
||||
:: Applicative f
|
||||
=> String -- ^ short flag chars, i.e. "v" for -v
|
||||
-> [String] -- ^ list of long names, i.e. ["verbose"]
|
||||
-> Flag Void -- ^ properties
|
||||
|
|
@ -185,9 +185,10 @@ addSimpleCountFlag shorts longs flag = fmap length
|
|||
$ PartAlts
|
||||
$ PartLiteral
|
||||
<$> allStrs
|
||||
parseF :: String -> Maybe ((), String)
|
||||
parseF :: PartParser () String
|
||||
parseF (dropWhile Char.isSpace -> str) =
|
||||
(firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
|
||||
resultFromMaybe
|
||||
$ (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
|
||||
<|> (firstJust
|
||||
(\s ->
|
||||
[ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ]
|
||||
|
|
@ -195,6 +196,11 @@ addSimpleCountFlag shorts longs flag = fmap length
|
|||
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
|
||||
((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,7 +293,9 @@ addFlagReadParams shorts longs name flag
|
|||
-- = void $ addFlagReadParamsAll shorts longs name flag act
|
||||
|
||||
addFlagReadParamsAll
|
||||
:: forall f p out . (Typeable p, Text.Read.Read p, Show p) => String -- ^ short flag chars, i.e. "v" for -v
|
||||
:: forall f p out
|
||||
. (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
|
||||
|
|
@ -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
|
||||
((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
|
||||
(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
|
||||
:: 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 ())
|
||||
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
|
||||
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,7 +445,8 @@ addFlagStringParams shorts longs name flag
|
|||
-- = void $ addFlagStringParamsAll shorts longs name flag act
|
||||
|
||||
addFlagStringParamsAll
|
||||
:: forall f out . String
|
||||
:: forall f out
|
||||
. String
|
||||
-> [String]
|
||||
-> String
|
||||
-> Flag Void -- we forbid the default because it has bad interaction
|
||||
|
|
@ -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
|
||||
|
|
@ -440,14 +482,14 @@ addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA
|
|||
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
|
||||
[] -> 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
|
||||
|
|
|
|||
|
|
@ -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 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,24 +39,24 @@ import System.IO
|
|||
mainFromCmdParser :: CmdParser Identity (IO ()) () -> IO ()
|
||||
mainFromCmdParser cmd = do
|
||||
progName <- System.Environment.getProgName
|
||||
case checkCmdParser (Just progName) cmd of
|
||||
case toCmdDesc (Just progName) cmd of
|
||||
Left e -> do
|
||||
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
|
||||
++ case _pe_messages err of
|
||||
[] -> ""
|
||||
(m : _) -> m
|
||||
putStrErrLn $ case remaining of
|
||||
putStrErrLn $ case _pe_remaining err of
|
||||
InputString "" -> "at the end of input."
|
||||
InputString str -> case show str of
|
||||
s | length s < 42 -> "at: " ++ s ++ "."
|
||||
|
|
@ -65,7 +67,7 @@ mainFromCmdParser cmd = do
|
|||
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
|
||||
|
|
@ -75,25 +77,28 @@ mainFromCmdParser cmd = do
|
|||
-- 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)
|
||||
-- knot-tying at its finest..
|
||||
= ( checkCmdParser (Just progName) (cmdF fullDesc)
|
||||
let (checkResult, optimisticFullDesc) =
|
||||
( toCmdDesc (Just progName) (cmdF optimisticFullDesc)
|
||||
, either (const emptyCommandDesc) id $ checkResult
|
||||
)
|
||||
-- knot-tying at its finest..
|
||||
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
|
||||
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 ++ "."
|
||||
|
|
@ -104,7 +109,7 @@ mainFromCmdParserWithHelpDesc cmdF = do
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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{} -> []
|
||||
|
|
@ -35,15 +35,17 @@ 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 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
|
||||
|
||||
|
||||
|
||||
|
|
@ -99,14 +101,16 @@ paramDirectory = mempty { _param_suggestions = Just [CompletionDirectory] }
|
|||
-- instance. Take care not to use this to return Strings unless you really
|
||||
-- want that, because it will require the quotation marks and escaping as
|
||||
-- is normal for the Show/Read instances for String.
|
||||
addParamRead :: forall f out a
|
||||
addParamRead
|
||||
:: 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
|
||||
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
|
||||
|
|
@ -114,25 +118,28 @@ addReadParam :: forall f out a
|
|||
addReadParam name par = addCmdPart desc parseF
|
||||
where
|
||||
desc :: PartDesc
|
||||
desc = addSuggestion (_param_suggestions par)
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
|
|
@ -140,12 +147,13 @@ addReadParamOpt :: forall f out a
|
|||
addReadParamOpt name par = addCmdPart desc parseF
|
||||
where
|
||||
desc :: PartDesc
|
||||
desc = addSuggestion (_param_suggestions par)
|
||||
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
|
||||
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..
|
||||
|
|
@ -154,61 +162,68 @@ addReadParamOpt name par = addCmdPart desc parseF
|
|||
-- 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)
|
||||
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 :: 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) -> Just (s1, InputArgs sR)
|
||||
[] -> _param_default par <&> \x -> (x, InputArgs args)
|
||||
(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)
|
||||
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 :: 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) -> Just (Just s1, InputArgs sR)
|
||||
[] -> Just (Nothing, InputArgs [])
|
||||
(s1 : sR) -> Success (Just s1) (InputArgs sR)
|
||||
[] -> Success Nothing (InputArgs [])
|
||||
|
||||
|
||||
-- | Add a parameter that matches any string of non-space characters if
|
||||
|
|
@ -235,20 +250,21 @@ addStringParams name par = addCmdPartManyInp ManyUpperBoundN desc parseF
|
|||
addSuggestion (_param_suggestions par)
|
||||
$ (maybe id PartWithHelp $ _param_help par)
|
||||
$ PartVariable name
|
||||
parseF :: Input -> Maybe (String, Input)
|
||||
parseF :: PartParser String Input
|
||||
parseF (InputString str) =
|
||||
case break Char.isSpace $ dropWhile Char.isSpace str of
|
||||
("", _ ) -> Nothing
|
||||
(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,13 +275,13 @@ addParamNoFlagString name par = addCmdPartInp desc parseF
|
|||
addSuggestion (_param_suggestions par)
|
||||
$ (maybe id PartWithHelp $ _param_help par)
|
||||
$ PartVariable name
|
||||
parseF :: Input -> Maybe (String, Input)
|
||||
parseF :: PartParser String Input
|
||||
parseF (InputString str) =
|
||||
case break Char.isSpace $ dropWhile Char.isSpace str of
|
||||
resultFromMaybe $ case break Char.isSpace $ dropWhile Char.isSpace str of
|
||||
("" , rest) -> _param_default par <&> \x -> (x, InputString rest)
|
||||
('-' : _, _ ) -> _param_default par <&> \x -> (x, InputString str)
|
||||
(x , rest) -> Just (x, InputString rest)
|
||||
parseF (InputArgs args) = case args of
|
||||
parseF (InputArgs args) = resultFromMaybe $ case args of
|
||||
[] -> _param_default par <&> \x -> (x, InputArgs args)
|
||||
(('-' : _) : _ ) -> _param_default par <&> \x -> (x, InputArgs args)
|
||||
(s1 : sR) -> Just (s1, InputArgs sR)
|
||||
|
|
@ -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 [])
|
||||
|
||||
|
|
|
|||
|
|
@ -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,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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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: {}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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: {}
|
||||
|
|
|
|||
Loading…
Reference in New Issue