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

Refactor module structure; Add haddock; Update README

pull/5/head 1.0.0.0
Lennart Spitzner 2017-01-01 14:46:53 +01:00
parent aecef373f9
commit b15f1ae585
17 changed files with 1054 additions and 632 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
README.md
View File

@ -9,12 +9,12 @@ The main differences are:
* Provides a pure interface by default
* Has clearly defined semantics, see the section below.
* Exposes an evil monadic interface, which allows for much nicer binding of
command part results to some variable name, where in `optparse-applicative`
you easily lose track of what field you are modifying after the 5th `<*>`
(admittedly, i think -XRecordWildCards improves on that issue already.)
command part results to some variable name.
In `optparse-applicative` you easily lose track of what field you are
modifying after the 5th `<*>` (admittedly, i think -XRecordWildCards
improves on that issue already.)
Evil, because you are not allowed to use the monad's full power in this
case, i.e. there is a constraint that is not statically enforced.
@ -23,10 +23,52 @@ The main differences are:
* The monadic interface allows much clearer definitions of commandparses
with (nested) subcommands. No pesky sum-types are necessary.
* Additionally, it is possible to wrap everything in _another_ applicative
(chosen by the user) and execute actions whenever specific parts are
parsed successfully. This provides a direct interface for more advanced
features, like `--no-foo` pendants to `--foo` flags.
## Examples
The minimal example is
~~~~.hs
main = mainFromCmdParser $ addCmdImpl $ putStrLn "Hello, World!"
~~~~
But lets look at a more feature-complete example:
~~~~.hs
main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do
addCmdSynopsis "a simple butcher example program"
addCmdHelpStr "a very long help document"
addCmd "version" $ do
porcelain <- addSimpleBoolFlag "" ["porcelain"]
(flagHelpStr "print nothing but the numeric version")
addCmdHelpStr "prints the version of this program"
addCmdImpl $ putStrLn $ if porcelain
then "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!"
~~~~
Further:
- [Full description of the above example, including sample behaviour](example1.md)
- [Example of a pure usage of a CmdParser](example2.md)
- [Example of using a CmdParser on interactive input](example3.md)
- The [brittany](https://github.com/lspitzner/brittany) formatting tool is a
program that uses butcher for implementing its commandline interface. See
its [main module source](https://github.com/lspitzner/brittany/blob/master/src-brittany/Main.hs)
or [the config flag parser](https://github.com/lspitzner/brittany/blob/master/src/Language/Haskell/Brittany/Config.hs).
## The evil monadic interface
@ -60,8 +102,8 @@ when f $ do
~~~~
That means that checking if a combination of flags is allowed must be done
after parsing. (But different commands and their subcommands have separate
sets of flags.)
after parsing. (But different commands and their subcommands (can) have
separate sets of flags.)
## (abstract) Package intentions

29
butcher.cabal
View File

@ -1,8 +1,5 @@
-- Initial cmdparse-applicative.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: butcher
version: 0.2.0.1
version: 1.0.0.0
-- synopsis:
-- description:
license: BSD3
@ -21,15 +18,19 @@ cabal-version: >=1.10
flag butcher-dev
description: dev options
default: False
manual: True
library
exposed-modules: UI.Butcher.Monadic.Types
UI.Butcher.Monadic
UI.Butcher.Monadic.Core
UI.Butcher.Monadic.Command
UI.Butcher.Monadic.Param
UI.Butcher.Monadic.Flag
UI.Butcher.Monadic.Pretty
UI.Butcher.Monadic.IO
UI.Butcher.Monadic.BuiltinCommands
other-modules: UI.Butcher.Monadic.Internal.Types
UI.Butcher.Monadic.Internal.Core
-- other-modules:
-- other-extensions:
build-depends:
@ -70,15 +71,24 @@ library
MultiWayIf
KindSignatures
}
other-extensions: {
DeriveFunctor
ExistentialQuantification
GeneralizedNewtypeDeriving
StandaloneDeriving
DataKinds
TypeOperators
TemplateHaskell
}
ghc-options: {
-Wall
-fprof-auto -fprof-cafs -fno-spec-constr
-fno-spec-constr
-j
-fno-warn-unused-imports
-fno-warn-orphans
}
if flag(butcher-dev) {
ghc-options: -O0 -Werror
ghc-options: -O0 -Werror -fprof-auto -fprof-cafs
}
include-dirs:
srcinc
@ -129,13 +139,12 @@ test-suite tests
}
ghc-options: {
-Wall
-O0
-fprof-auto -fprof-cafs -fno-spec-constr
-fno-spec-constr
-j
-fno-warn-unused-imports
-fno-warn-orphans
}
if flag(butcher-dev) {
ghc-options: -Werror
ghc-options: -Werror -fprof-auto -fprof-cafs -O0
}

81
example1.md Normal file
View File

@ -0,0 +1,81 @@
## CmdParser definition
~~~~.hs
main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do
addCmdSynopsis "a simple butcher example program"
addCmdHelpStr "a very long help document"
addCmd "version" $ do
porcelain <- addSimpleBoolFlag "" ["porcelain"]
(flagHelpStr "print nothing but the numeric version")
addCmdHelpStr "prints the version of this program"
addCmdImpl $ putStrLn $ if porcelain
then "1.0"
else "example, version 1.0"
addCmd "help" $ addCmdImpl $ print $ ppHelpShallow helpDesc
short <- addSimpleBoolFlag "" ["short"]
(flagHelpStr "make the greeting short")
name <- addStringParam "NAME"
(paramHelpStr "your name, so you can be greeted properly")
addCmdImpl $ do
if short
then putStrLn $ "hi, " ++ name ++ "!"
else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!"
~~~~
## Program behaviour (executable is named `example`):
~~~~
> ./example
example: error parsing arguments: could not parse NAME
at the end of input
usage:
example [--short] NAME [version | help]
~~~~
---
~~~~
> ./example help
NAME
example - a simple butcher example program
USAGE
example [--short] NAME [version | help]
DESCRIPTION
a very long help document
ARGUMENTS
--short make the greeting short
NAME your name, so you can be greeted properly
~~~~
---
~~~~
> ./example garfield
hello, garfield, welcome from butcher!
~~~~
---
~~~~
> ./example --short garfield
hi, garfield!
~~~~
---
~~~~
> ./example version --porcelain
1.0
~~~~

24
example2.md Normal file
View File

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

45
example3.md Normal file
View File

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

9
src-tests/TestMain.hs
View File

@ -9,6 +9,7 @@ import Test.Hspec
-- import NeatInterpolation
import UI.Butcher.Monadic
import UI.Butcher.Monadic.Types
@ -29,7 +30,7 @@ checkTests = do
simpleParseTest :: Spec
simpleParseTest = do
it "failed parse 001" $ cmdRunParser Nothing (InputString "foo") testCmd1
it "failed parse 001" $ runCmdParser Nothing (InputString "foo") testCmd1
`shouldSatisfy` Data.Either.Combinators.isLeft . snd
it "toplevel" $ (testParse testCmd1 "" >>= _cmd_out)
`shouldSatisfy` Maybe.isNothing
@ -112,14 +113,14 @@ testCmd3 = do
testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out)
testParse cmd s = either (const Nothing) Just
$ snd
$ cmdRunParser Nothing (InputString s) cmd
$ runCmdParser Nothing (InputString s) cmd
testRun :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () -> String -> Either ParsingError (Maybe Int)
testRun cmd s = fmap (fmap (getSum . WriterS.execWriter) . _cmd_out)
$ snd
$ cmdRunParser Nothing (InputString s) cmd
$ 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)
$ cmdRunParserA Nothing (InputString str) cmd
$ runCmdParserA Nothing (InputString str) cmd

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

@ -1,10 +1,33 @@
-- | Main module of the butcher interface. It reexports everything that is
-- exposed in the submodules.
module UI.Butcher.Monadic
( module Export
, cmds
( -- * Types
Input (..)
, CmdParser
, ParsingError (..)
, CommandDesc(_cmd_out)
, cmd_out
, -- * Run or Check CmdParsers
runCmdParser
, runCmdParserExt
, runCmdParserA
, runCmdParserAExt
, runCmdParserWithHelpDesc
, checkCmdParser
, -- * Building CmdParsers
module UI.Butcher.Monadic.Command
-- * PrettyPrinting CommandDescs (usage/help)
, module UI.Butcher.Monadic.Pretty
-- * Wrapper around System.Environment.getArgs
, module UI.Butcher.Monadic.IO
-- , cmds
-- , sample
-- , test
, test2
, test3
-- , test2
-- , test3
-- * Builtin commands
, addHelpCommand
, addButcherDebugCommand
)
where
@ -12,20 +35,54 @@ where
#include "prelude.inc"
import UI.Butcher.Monadic.Types
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Command
import UI.Butcher.Monadic.BuiltinCommands
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Monadic.Pretty
import UI.Butcher.Monadic.IO
import qualified Text.PrettyPrint as PP
import UI.Butcher.Monadic.Types as Export
import UI.Butcher.Monadic.Core as Export
import UI.Butcher.Monadic.Flag as Export
import UI.Butcher.Monadic.Param as Export
import UI.Butcher.Monadic.Pretty as Export
import UI.Butcher.Monadic.IO as Export
-- import qualified Options.Applicative as OPA
cmds :: CmdParser Identity (IO ()) ()
cmds = do
#ifdef HLINT
{-# ANN module "HLint: ignore Use import/export shortcut" #-}
#endif
-- | Like 'runCmdParser', 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'.
--
-- 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
-- traversed unless the parser function argument is forced.
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))
runCmdParserWithHelpDesc mProgName input cmdF =
let (checkResult, fullDesc)
-- knot-tying at its finest..
= ( checkCmdParser mProgName (cmdF fullDesc)
, either (const emptyCommandDesc) id $ checkResult
)
in runCmdParser mProgName input (cmdF fullDesc)
--------------------------------------
-- all below is for testing purposes
--------------------------------------
_cmds :: CmdParser Identity (IO ()) ()
_cmds = do
addCmd "echo" $ do
addCmdHelpStr "print its parameter to output"
str <- addReadParam "STRING" (paramHelpStr "the string to print")
@ -76,15 +133,15 @@ data Sample = Sample
-- test :: String -> OPA.ParserResult Sample
-- test s = OPA.execParserPure OPA.defaultPrefs (OPA.ParserInfo sample True mempty mempty mempty (-13) True) (List.words s)
test2 :: IO ()
test2 = case cmdCheckParser (Just "butcher") cmds of
_test2 :: IO ()
_test2 = case checkCmdParser (Just "butcher") _cmds of
Left e -> putStrLn $ "LEFT: " ++ e
Right desc -> do
print $ ppUsage desc
print $ maybe undefined id $ ppUsageAt ["hello"] desc
test3 :: String -> IO ()
test3 s = case cmdRunParser (Just "butcher") (InputString s) cmds of
_test3 :: String -> IO ()
_test3 s = case runCmdParser (Just "butcher") (InputString s) _cmds of
(desc, Left e) -> do
print e
print $ ppHelpShallow desc

67
src/UI/Butcher/Monadic/BuiltinCommands.hs Normal file
View File

@ -0,0 +1,67 @@
-- | Some CmdParser actions that add predefined commands.
module UI.Butcher.Monadic.BuiltinCommands
( addHelpCommand
, addHelpCommandShallow
, addButcherDebugCommand
)
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.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Monadic.Pretty
import UI.Butcher.Monadic.Param
import System.IO
-- | Adds a proper full help command. To obtain the 'CommandDesc' value, see
-- 'UI.Butcher.Monadic.cmdRunParserWithHelpDesc' or
-- 'UI.Butcher.Monadic.IO.mainFromCmdParserWithHelpDesc'.
addHelpCommand :: Applicative f => CommandDesc () -> CmdParser f (IO ()) ()
addHelpCommand desc = addCmd "help" $ do
rest <- addRestOfInputStringParam "SUBCOMMAND(s)" mempty
addCmdImpl $ do
let parentDesc = maybe undefined snd (_cmd_mParent desc)
let restWords = List.words rest
let descent :: [String] -> CommandDesc a -> CommandDesc a
descent [] curDesc = curDesc
descent (w:wr) curDesc = case List.lookup w $ _cmd_children curDesc of
Nothing -> curDesc
Just child -> descent wr child
print $ ppHelpShallow $ descent restWords parentDesc
-- | Adds a help command that prints help for the command currently in context.
--
-- This version does _not_ include further childcommands, i.e. "help foo" will
-- not print the help for subcommand "foo".
--
-- This also yields slightly different output depending on if it is used
-- before or after adding other subcommands. In general 'addHelpCommand'
-- should be preferred.
addHelpCommandShallow :: Applicative f => CmdParser f (IO ()) ()
addHelpCommandShallow = addCmd "help" $ do
desc <- peekCmdDesc
_rest <- addRestOfInputStringParam "SUBCOMMAND(s)" mempty
addCmdImpl $ do
let parentDesc = maybe undefined snd (_cmd_mParent desc)
print $ ppHelpShallow $ parentDesc
-- | Prints the raw CommandDesc structure.
addButcherDebugCommand :: Applicative f => CmdParser f (IO ()) ()
addButcherDebugCommand = addCmd "butcherdebug" $ do
desc <- peekCmdDesc
addCmdImpl $ do
print $ maybe undefined snd (_cmd_mParent desc)

79
src/UI/Butcher/Monadic/Command.hs Normal file
View File

@ -0,0 +1,79 @@
-- this module only re-exports the appropriate user-facing stuff from some
-- other modules.
-- | Building-blocks of a CmdParser.
--
-- The simplest sensible CmdParser is just
--
-- > addCmdImpl $ putStrLn "hello, world!"
--
-- (assuming out is IO ()).
--
-- The empty CmdParser is also valid:
--
-- > return ()
--
-- But not very interesting - you won't get an 'out' value from this (e.g. an
-- IO-action to execute) when this matches (on the empty input).
--
-- > do
-- > addCmd "sub" $ do
-- > addCmdImpl $ putStrLn "sub successful"
--
-- Here, note that there is no implementation at the top-level. This means that
-- on the empty input the resulting CommandDesc has no out-value, but on "sub"
-- it has. Executed as a program, the user would be shown the usage on empty
-- input, and the putStrLn would happen on "sub".
--
-- More than one subcommand? easy:
--
-- > do
-- > addCmd "foo" $ do {..}
-- > addCmd "bar" $ do {..}
--
-- Basic flag usage:
--
-- > do
-- > shouldVerbose <- addSimpleBoolFlag "v" ["verbose"] mzero
-- > addCmdImpl $ if shouldVerbose
-- > then putStrLn "Hello, World!!!!!"
-- > else putStrLn "hi."
--
-- Basic param usage:
--
-- > addCmd "echo" $ do
-- > addCmdHelpStr "print its parameter to output"
-- > str <- addRestOfInputStringParam "STRING" (paramHelpStr "the string to print")
-- > addCmdImpl $ putStrLn str
-- > addCmd "echoInt" $ do
-- > i <- addReadParam "INT" mempty
-- > addCmdImpl $ print (i::Int) -- need to disambiguate via typesig.
--
-- There are some other flag/param methods in the respective modules.
-- Also note the example at 'reorderStart'.
module UI.Butcher.Monadic.Command
( addCmd
, addCmdImpl
, addCmdSynopsis
, addCmdHelp
, addCmdHelpStr
, reorderStart
, reorderStop
, peekCmdDesc
-- * Building CmdParsers - myprog -v --input PATH
, module UI.Butcher.Monadic.Flag
-- * Building CmdParsers - myprog SOME_INT
, module UI.Butcher.Monadic.Param
)
where
#include "prelude.inc"
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Monadic.Flag
import UI.Butcher.Monadic.Param

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

@ -1,17 +1,27 @@
-- | Flags are arguments to your current command that are prefixed with "-" or
-- "--", for example "-v" or "--verbose". These flags can have zero or one
-- argument. (Butcher internally has more general concept of "CmdPart" that
-- could handle any number of arguments, so take this as what this module aims
-- to provide, not what you could theoretically implement on top of butcher).
-- Note that the current implementation only accepts "--foo param" but not
-- "--foo=param". Someone really ought to implement support for the latter
-- at some point :)
module UI.Butcher.Monadic.Flag
( Flag(..)
, flagHelp
, flagHelpStr
, flagDefault
, addSimpleBoolFlag
, addSimpleCountFlag
, addSimpleFlagA
, addFlagReadParam
, addFlagReadParams
, addFlagReadParamA
-- , addFlagReadParamA
, addFlagStringParam
, addFlagStringParams
, addFlagStringParamA
, flagHelp
, flagHelpStr
, flagDefault
-- , addFlagStringParamA
)
where
@ -26,13 +36,15 @@ import qualified Text.PrettyPrint as PP
import Data.HList.ContainsType
import UI.Butcher.Monadic.Types
import UI.Butcher.Monadic.Core
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
import Data.List.Extra ( firstJust )
-- | flag-description monoid. You probably won't need to use the constructor;
-- mzero or any (<>) of flag(Help|Default) works well.
data Flag p = Flag
{ _flag_help :: Maybe PP.Doc
, _flag_default :: Maybe p
@ -42,34 +54,47 @@ instance Monoid (Flag p) where
mempty = Flag Nothing Nothing
Flag a1 b1 `mappend` Flag a2 b2 = Flag (a1 <|> a2) (b1 <|> b2)
-- | 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.text s }
-- | Create a 'Flag' with just a default value.
flagDefault :: p -> Flag p
flagDefault d = mempty { _flag_default = Just d }
-- | A no-parameter flag where non-occurence means False, occurence means True.
addSimpleBoolFlag
:: Applicative f
=> String -> [String] -> Flag Void -> CmdParser f out Bool
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, e.g. ["verbose"]
-> Flag Void -- ^ properties
-> CmdParser f out Bool
addSimpleBoolFlag shorts longs flag =
addSimpleBoolFlagAll shorts longs flag (pure ())
-- | Applicative-enabled version of 'addSimpleFlag'
addSimpleFlagA
:: String -> [String] -> Flag Void -> f () -> CmdParser f out ()
:: String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, e.g. ["verbose"]
-> Flag Void -- ^ properties
-> f () -- ^ action to execute whenever this matches
-> CmdParser f out ()
addSimpleFlagA shorts longs flag act
= void $ addSimpleBoolFlagAll shorts longs flag act
addSimpleBoolFlagAll
:: String -- short flag chars, i.e. "v" for -v
-> [String] -- list of long names, i.e. ["verbose"]
:: String
-> [String]
-> Flag Void
-> f ()
-> CmdParser f out Bool
addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
$ addCmdPartManyA desc parseF (\() -> a)
addSimpleBoolFlagAll shorts longs flag a
= fmap (not . null)
$ addCmdPartManyA ManyUpperBound1 desc parseF (\() -> a)
where
allStrs = fmap (\c -> "-"++[c]) shorts
++ fmap (\s -> "--"++s) longs
@ -83,13 +108,16 @@ addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
| (s ++ " ") `isPrefixOf` str ])
allStrs)
-- | A no-parameter flag that can occur multiple times. Returns the number of
-- occurences (0 or more).
addSimpleCountFlag :: Applicative f
=> String -- short flag chars, i.e. "v" for -v
-> [String] -- list of long names, i.e. ["verbose"]
-> Flag Void
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> Flag Void -- ^ properties
-> CmdParser f out Int
addSimpleCountFlag shorts longs flag = fmap length
$ addCmdPartMany desc parseF
addSimpleCountFlag shorts longs flag
= fmap length
$ addCmdPartMany ManyUpperBoundN desc parseF
where
-- we _could_ allow this to parse repeated short flags, like "-vvv"
-- (meaning "-v -v -v") correctly.
@ -105,14 +133,14 @@ addSimpleCountFlag shorts longs flag = fmap length
| (s ++ " ") `isPrefixOf` str ])
allStrs)
-- | One-argument flag, where the argument is parsed via its Read instance.
addFlagReadParam
:: forall f p out
. (Applicative f, Typeable p, Text.Read.Read p, Show p)
=> String
-> [String]
-> String -- param name
-> Flag 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 f out p
addFlagReadParam shorts longs name flag = addCmdPartInpA desc parseF (\_ -> pure ())
where
@ -139,39 +167,48 @@ addFlagReadParam shorts longs name flag = addCmdPartInpA desc parseF (\_ -> pure
(arg2:rest) -> readMaybe arg2 <&> \x -> (x, InputArgs rest)
InputArgs _ -> _flag_default flag <&> \d -> (d, inp)
-- | One-argument flag, where the argument is parsed via its Read instance.
-- This version can accumulate multiple values by using the same flag with
-- different arguments multiple times.
--
-- E.g. "--foo 3 --foo 5" yields [3,5].
addFlagReadParams
:: forall f p out
. (Applicative f, Typeable p, Text.Read.Read p, Show p)
=> String
-> [String]
-> String -- param name
-> Flag 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 f out [p]
addFlagReadParams shorts longs name flag
= addFlagReadParamsAll shorts longs name flag (\_ -> pure ())
addFlagReadParamA
:: forall f p out
. (Typeable p, Text.Read.Read p, Show p)
=> String
-> [String]
-> String -- param name
-> Flag p
-> (p -> f ())
-> CmdParser f out ()
addFlagReadParamA shorts longs name flag act
= void $ addFlagReadParamsAll shorts longs name flag act
-- TODO: this implementation is wrong, because it uses addCmdPartManyInpA
-- while this really is no Many.
-- | Applicative-enabled version of 'addFlagReadParam'
-- addFlagReadParamA
-- :: forall f p out
-- . (Typeable p, Text.Read.Read p, Show p)
-- => String -- ^ short flag chars, i.e. "v" for -v
-- -> [String] -- ^ list of long names, i.e. ["verbose"]
-- -> String -- ^ param name
-- -> Flag p -- ^ properties
-- -> (p -> f ()) -- ^ action to execute when ths param matches
-- -> CmdParser f out ()
-- addFlagReadParamA shorts longs name flag act
-- = void $ addFlagReadParamsAll shorts longs name flag act
addFlagReadParamsAll
:: forall f p out
. (Typeable p, Text.Read.Read p, Show p)
=> String
-> [String]
-> String -- param name
-> Flag p
-> (p -> f ())
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- ^ param name
-> Flag p -- ^ properties
-> (p -> f ()) -- ^ action to execute when ths param matches
-> CmdParser f out [p]
addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA desc parseF act
addFlagReadParamsAll shorts longs name flag act =
addCmdPartManyInpA ManyUpperBoundN desc parseF act
where
allStrs = fmap (\c -> "-"++[c]) shorts
++ fmap (\s -> "--"++s) longs
@ -200,13 +237,14 @@ addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA desc parseF
InputArgs _ -> Nothing
-- | One-argument flag where the argument can be an arbitrary string.
addFlagStringParam
:: forall f out
. (Applicative f)
=> String
-> [String]
-> String -- param name
-> Flag String
=> 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 desc parseF (\_ -> pure ())
where
@ -227,38 +265,47 @@ addFlagStringParam shorts longs name flag = addCmdPartInpA desc parseF (\_ -> pu
parseF (InputArgs (s1:s2:sr)) | any (==s1) allStrs = Just (s2, InputArgs sr)
parseF inp@(InputArgs _) = _flag_default flag <&> \x -> (x, inp)
-- | One-argument flag where the argument can be an arbitrary string.
-- This version can accumulate multiple values by using the same flag with
-- different arguments multiple times.
--
-- E.g. "--foo abc --foo def" yields ["abc", "def"].
addFlagStringParams
:: forall f out
. (Applicative f)
=> String
-> [String]
-> String -- param name
-> Flag Void
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- ^ param name
-> Flag Void -- ^ properties
-> CmdParser f out [String]
addFlagStringParams shorts longs name flag
= addFlagStringParamsAll shorts longs name flag (\_ -> pure ())
addFlagStringParamA
:: forall f out
. String
-> [String]
-> String -- param name
-> Flag Void
-> (String -> f ())
-> CmdParser f out ()
addFlagStringParamA shorts longs name flag act
= void $ addFlagStringParamsAll shorts longs name flag act
-- TODO: this implementation is wrong, because it uses addCmdPartManyInpA
-- while this really is no Many.
-- -- | Applicative-enabled version of 'addFlagStringParam'
-- addFlagStringParamA
-- :: forall f out
-- . String -- ^ short flag chars, i.e. "v" for -v
-- -> [String] -- ^ list of long names, i.e. ["verbose"]
-- -> String -- ^ param name
-- -> Flag Void -- ^ properties
-- -> (String -> f ()) -- ^ action to execute when ths param matches
-- -> CmdParser f out ()
-- addFlagStringParamA shorts longs name flag act
-- = void $ addFlagStringParamsAll shorts longs name flag act
addFlagStringParamsAll
:: forall f out
. String
-> [String]
-> String -- param name
-> String
-> Flag Void -- we forbid the default because it has bad interaction
-- with the eat-anything behaviour of the string parser.
-> (String -> f ())
-> CmdParser f out [String]
addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA desc parseF act
addFlagStringParamsAll shorts longs name flag act =
addCmdPartManyInpA ManyUpperBoundN desc parseF act
where
allStrs = fmap (\c -> "-"++[c]) shorts
++ fmap (\s -> "--"++s) longs

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

@ -1,7 +1,7 @@
-- | Turn your CmdParser into an IO () to be used as your program @main@.
module UI.Butcher.Monadic.IO
( mainFromCmdParser
, addHelpCommand
, addButcherDebugCommand
, mainFromCmdParserWithHelpDesc
)
where
@ -16,8 +16,8 @@ import qualified Text.PrettyPrint as PP
import Data.HList.ContainsType
import UI.Butcher.Monadic.Types
import UI.Butcher.Monadic.Core
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Monadic.Pretty
import UI.Butcher.Monadic.Param
@ -25,17 +25,26 @@ 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 Identity (IO ()) () -> IO ()
mainFromCmdParser cmd = do
progName <- System.Environment.getProgName
case cmdCheckParser (Just progName) cmd of
case checkCmdParser (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
args <- System.Environment.getArgs
case cmdRunParser (Just progName) (InputArgs args) cmd of
case runCmdParser (Just progName) (InputArgs args) cmd of
(desc, Left (ParsingError mess remaining)) -> do
putStrErrLn $ progName ++ ": error parsing arguments: " ++ head mess
putStrErrLn $ case remaining of
@ -55,25 +64,44 @@ mainFromCmdParser cmd = do
printErr $ ppUsage desc
Just a -> a
addHelpCommand :: Applicative f => CmdParser f (IO ()) ()
addHelpCommand = addCmd "help" $ do
desc <- peekCmdDesc
rest <- addRestOfInputStringParam "SUBCOMMAND(s)" mempty
addCmdImpl $ do
let parentDesc = maybe undefined snd (_cmd_mParent desc)
let restWords = List.words rest
let descent :: [String] -> CommandDesc a -> CommandDesc a
descent [] curDesc = curDesc
descent (w:wr) curDesc = case List.lookup w $ _cmd_children curDesc of
Nothing -> curDesc
Just child -> descent wr child
print $ ppHelpShallow $ descent restWords parentDesc
addButcherDebugCommand :: Applicative f => CmdParser f (IO ()) ()
addButcherDebugCommand = addCmd "butcherdebug" $ do
desc <- peekCmdDesc
addCmdImpl $ do
print $ maybe undefined snd (_cmd_mParent desc)
-- | Same as mainFromCmdParser, but with one additional twist: You get access
-- to a knot-tied complete CommandDesc for this full command. Useful in
-- combination with 'UI.Butcher.Monadic.BuiltinCommands.addHelpCommand'
mainFromCmdParserWithHelpDesc
:: (CommandDesc () -> CmdParser Identity (IO ()) ()) -> IO ()
mainFromCmdParserWithHelpDesc cmdF = do
progName <- System.Environment.getProgName
let (checkResult, fullDesc)
-- knot-tying at its finest..
= ( checkCmdParser (Just progName) (cmdF fullDesc)
, either (const emptyCommandDesc) id $ checkResult
)
case checkResult of
Left e -> do
putStrErrLn $ progName ++ ": internal error: failed sanity check for butcher main command parser!"
putStrErrLn $ "(" ++ e ++ ")"
putStrErrLn $ "aborting."
Right _ -> do
args <- System.Environment.getArgs
case runCmdParser (Just progName) (InputArgs args) (cmdF fullDesc) of
(desc, Left (ParsingError mess remaining)) -> do
putStrErrLn $ progName ++ ": error parsing arguments: " ++ head mess
putStrErrLn $ case remaining of
InputString "" -> "at the end of input."
InputString str -> case show str of
s | length s < 42 -> "at: " ++ s ++ "."
s -> "at: " ++ take 40 s ++ "..\"."
InputArgs [] -> "at the end of input"
InputArgs xs -> case List.unwords $ show <$> xs of
s | length s < 42 -> "at: " ++ s ++ "."
s -> "at: " ++ take 40 s ++ "..\"."
putStrErrLn $ "usage:"
printErr $ ppUsage desc
(desc, Right out) -> case _cmd_out out of
Nothing -> do
putStrErrLn $ "usage:"
printErr $ ppUsage desc
Just a -> a
putStrErrLn :: String -> IO ()
putStrErrLn s = hPutStrLn stderr s

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

@ -1,16 +1,12 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE MultiWayIf #-}
module UI.Butcher.Monadic.Core
module UI.Butcher.Monadic.Internal.Core
( addCmdSynopsis
, addCmdHelp
, addCmdHelpStr
@ -27,11 +23,11 @@ module UI.Butcher.Monadic.Core
, addCmdImpl
, reorderStart
, reorderStop
, cmdCheckParser
, cmdRunParser
, cmdRunParserExt
, cmdRunParserA
, cmdRunParserAExt
, checkCmdParser
, runCmdParser
, runCmdParserExt
, runCmdParserA
, runCmdParserAExt
)
where
@ -52,7 +48,7 @@ import Data.HList.ContainsType
import Data.Dynamic
import UI.Butcher.Monadic.Types
import UI.Butcher.Monadic.Internal.Types
@ -91,15 +87,33 @@ l %=+ f = mModify (l %~ f)
-- instance IsHelpBuilder FlagBuilder where
-- help s = liftF $ FlagBuilderHelp s ()
-- | Add a synopsis to the command currently in scope; at top level this will
-- be the implicit top-level command.
--
-- Adding a second synopsis will overwrite a previous synopsis;
-- 'checkCmdParser' will check that you don't (accidentally) do this however.
addCmdSynopsis :: String -> CmdParser f out ()
addCmdSynopsis s = liftF $ CmdParserSynopsis s ()
-- | Add a help document to the command currently in scope; at top level this
-- will be the implicit top-level command.
--
-- Adding a second document will overwrite a previous document;
-- 'checkCmdParser' will check that you don't (accidentally) do this however.
addCmdHelp :: PP.Doc -> CmdParser f out ()
addCmdHelp s = liftF $ CmdParserHelp s ()
-- | Like @'addCmdHelp' . PP.text@
addCmdHelpStr :: String -> CmdParser f out ()
addCmdHelpStr s = liftF $ CmdParserHelp (PP.text s) ()
-- | Semi-hacky way of accessing the output CommandDesc from inside of a
-- 'CmdParser'. This is not implemented via knot-tying, i.e. the CommandDesc
-- you get is _not_ equivalent to the CommandDesc returned by 'runCmdParser'.
--
-- For best results, use this "below"
-- any 'addCmd' invocations in the current context, e.g. directly before
-- the 'addCmdImpl' invocation.
peekCmdDesc :: CmdParser f out (CommandDesc out)
peekCmdDesc = liftF $ CmdParserPeekDesc id
@ -120,18 +134,20 @@ addCmdPartA p f a = liftF $ CmdParserPart p f a id
addCmdPartMany
:: (Applicative f, Typeable p)
=> PartDesc
=> ManyUpperBound
-> PartDesc
-> (String -> Maybe (p, String))
-> CmdParser f out [p]
addCmdPartMany p f = liftF $ CmdParserPartMany p f (\_ -> pure ()) id
addCmdPartMany b p f = liftF $ CmdParserPartMany b p f (\_ -> pure ()) id
addCmdPartManyA
:: (Typeable p)
=> PartDesc
=> ManyUpperBound
-> PartDesc
-> (String -> Maybe (p, String))
-> (p -> f ())
-> CmdParser f out [p]
addCmdPartManyA p f a = liftF $ CmdParserPartMany p f a id
addCmdPartManyA b p f a = liftF $ CmdParserPartMany b p f a id
addCmdPartInp
:: (Applicative f, Typeable p)
@ -150,32 +166,54 @@ addCmdPartInpA p f a = liftF $ CmdParserPartInp p f a id
addCmdPartManyInp
:: (Applicative f, Typeable p)
=> PartDesc
=> ManyUpperBound
-> PartDesc
-> (Input -> Maybe (p, Input))
-> CmdParser f out [p]
addCmdPartManyInp p f = liftF $ CmdParserPartManyInp p f (\_ -> pure ()) id
addCmdPartManyInp b p f = liftF $ CmdParserPartManyInp b p f (\_ -> pure ()) id
addCmdPartManyInpA
:: (Typeable p)
=> PartDesc
=> ManyUpperBound
-> PartDesc
-> (Input -> Maybe (p, Input))
-> (p -> f ())
-> CmdParser f out [p]
addCmdPartManyInpA p f a = liftF $ CmdParserPartManyInp p f a id
addCmdPartManyInpA b p f a = liftF $ CmdParserPartManyInp b p f a id
-- | Add a new child command in the current context.
addCmd
:: Applicative f
=> String
-> CmdParser f out ()
=> String -- ^ command name
-> CmdParser f out () -- ^ subcommand
-> CmdParser f out ()
addCmd str sub = liftF $ CmdParserChild str sub (pure ()) ()
-- | Add an implementation to the current command.
addCmdImpl :: out -> CmdParser f out ()
addCmdImpl o = liftF $ CmdParserImpl o ()
-- | Best explained via example:
--
-- > do
-- > reorderStart
-- > bright <- addSimpleBoolFlag "" ["bright"] mempty
-- > yellow <- addSimpleBoolFlag "" ["yellow"] mempty
-- > reorderStop
-- > ..
--
-- will accept any inputs "" "--bright" "--yellow" "--bright --yellow" "--yellow --bright".
--
-- This works for any flags/params, but bear in mind that the results might
-- be unexpected because params may match on any input.
--
-- Note that start/stop must occur in pairs, and it will be a runtime error
-- if you mess this up. Use 'checkCmdParser' if you want to check all parts
-- of your 'CmdParser' without providing inputs that provide 100% coverage.
reorderStart :: CmdParser f out ()
reorderStart = liftF $ CmdParserReorderStart ()
-- | See 'reorderStart'
reorderStop :: CmdParser f out ()
reorderStop = liftF $ CmdParserReorderStop ()
@ -209,11 +247,19 @@ descStackAdd d = \case
StackLayer l s u -> StackLayer (d:l) s u
cmdCheckParser :: forall f out
. Maybe String -- top-level command name
-> CmdParser f out ()
-- | Because butcher is evil (i.e. has constraints not encoded in the types;
-- see the README), this method can be used as a rough check that you did not
-- mess up. It traverses all possible parts of the 'CmdParser' thereby
-- ensuring that the 'CmdParser' has a valid structure.
--
-- This method also yields a _complete_ @CommandDesc@ output, where the other
-- runCmdParser* functions all traverse only a shallow structure around the
-- parts of the 'CmdParser' touched while parsing the current input.
checkCmdParser :: forall f out
. Maybe String -- ^ top-level command name
-> CmdParser f out () -- ^ parser to check
-> Either String (CommandDesc ())
cmdCheckParser mTopLevel cmdParser
checkCmdParser mTopLevel cmdParser
= (>>= final)
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateAS (StackBottom [])
@ -255,15 +301,15 @@ cmdCheckParser mTopLevel cmdParser
descStack <- mGet
mSet $ descStackAdd desc descStack
processMain $ nextF monadMisuseError
Free (CmdParserPartMany desc _parseF _act nextF) -> do
Free (CmdParserPartMany bound desc _parseF _act nextF) -> do
do
descStack <- mGet
mSet $ descStackAdd (PartMany desc) descStack
mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
processMain $ nextF monadMisuseError
Free (CmdParserPartManyInp desc _parseF _act nextF) -> do
Free (CmdParserPartManyInp bound desc _parseF _act nextF) -> do
do
descStack <- mGet
mSet $ descStackAdd (PartMany desc) descStack
mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
processMain $ nextF monadMisuseError
Free (CmdParserChild cmdStr sub _act next) -> do
cmd :: CommandDesc out <- mGet
@ -320,46 +366,60 @@ cmdCheckParser mTopLevel cmdParser
monadMisuseError :: a
monadMisuseError = error "CmdParser definition error - used Monad powers where only Applicative/Arrow is allowed"
newtype PastCommandInput = PastCommandInput Input
cmdRunParser
:: Maybe String
-> Input
-> CmdParser Identity out ()
-- | Run a @CmdParser@ on the given input, returning:
--
-- a) A @CommandDesc ()@ that accurately represents the subcommand that was
-- reached, even if parsing failed. Because this is returned always, the
-- argument is @()@ because "out" requires a successful parse.
--
-- b) Either an error or the result of a successful parse, including a proper
-- "CommandDesc out" from which an "out" can be extracted (presuming that
-- the command has an implementation).
runCmdParser
:: Maybe String -- ^ program name to be used for the top-level @CommandDesc@
-> Input -- ^ input to be processed
-> CmdParser Identity out () -- ^ parser to use
-> (CommandDesc (), Either ParsingError (CommandDesc out))
cmdRunParser mTopLevel inputInitial cmdParser
runCmdParser mTopLevel inputInitial cmdParser
= runIdentity
$ cmdRunParserA mTopLevel inputInitial cmdParser
$ runCmdParserA mTopLevel inputInitial cmdParser
cmdRunParserExt
:: Maybe String
-> Input
-> CmdParser Identity out ()
-- | Like 'runCmdParser', but also returning all input after the last
-- successfully parsed subcommand. E.g. for some input
-- "myprog foo bar -v --wrong" where parsing fails at "--wrong", this will
-- contain the full "-v --wrong". Useful for interactive feedback stuff.
runCmdParserExt
:: Maybe String -- ^ program name to be used for the top-level @CommandDesc@
-> Input -- ^ input to be processed
-> CmdParser Identity out () -- ^ parser to use
-> (CommandDesc (), Input, Either ParsingError (CommandDesc out))
cmdRunParserExt mTopLevel inputInitial cmdParser
runCmdParserExt mTopLevel inputInitial cmdParser
= runIdentity
$ cmdRunParserAExt mTopLevel inputInitial cmdParser
$ runCmdParserAExt mTopLevel inputInitial cmdParser
cmdRunParserA :: forall f out
-- | The Applicative-enabled version of 'runCmdParser'.
runCmdParserA :: forall f out
. Applicative f
=> Maybe String
-> Input
-> CmdParser f out ()
=> Maybe String -- ^ program name to be used for the top-level @CommandDesc@
-> Input -- ^ input to be processed
-> CmdParser f out () -- ^ parser to use
-> f ( CommandDesc ()
, Either ParsingError (CommandDesc out)
)
cmdRunParserA mTopLevel inputInitial cmdParser =
(\(x, _, z) -> (x, z)) <$> cmdRunParserAExt mTopLevel inputInitial cmdParser
runCmdParserA mTopLevel inputInitial cmdParser =
(\(x, _, z) -> (x, z)) <$> runCmdParserAExt mTopLevel inputInitial cmdParser
cmdRunParserAExt
-- | The Applicative-enabled version of 'runCmdParserExt'.
runCmdParserAExt
:: forall f out . Applicative f
=> Maybe String
-> Input
-> CmdParser f out ()
=> Maybe String -- ^ program name to be used for the top-level @CommandDesc@
-> Input -- ^ input to be processed
-> CmdParser f out () -- ^ parser to use
-> f (CommandDesc (), Input, Either ParsingError (CommandDesc out))
cmdRunParserAExt mTopLevel inputInitial cmdParser
runCmdParserAExt mTopLevel inputInitial cmdParser
= runIdentity
$ MultiRWSS.runMultiRWSTNil
$ (<&> captureFinal)
@ -461,10 +521,10 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
Nothing -> do
mTell ["could not parse " ++ getPartSeqDescPositionName desc]
processMain $ nextF monadMisuseError
Free (CmdParserPartMany desc parseF actF nextF) -> do
Free (CmdParserPartMany bound desc parseF actF nextF) -> do
do
descStack <- mGet
mSet $ descStackAdd desc descStack
mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
let proc = do
dropSpaces
input <- mGet
@ -485,10 +545,10 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
r <- proc
let act = traverse actF r
(act *>) <$> processMain (nextF $ r)
Free (CmdParserPartManyInp desc parseF actF nextF) -> do
Free (CmdParserPartManyInp bound desc parseF actF nextF) -> do
do
descStack <- mGet
mSet $ descStackAdd desc descStack
mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
let proc = do
dropSpaces
input <- mGet
@ -625,6 +685,7 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
=> CmdParserF f out (m ())
-> m ()
reorderPartGather = \case
-- TODO: why do PartGatherData contain desc?
CmdParserPart desc parseF actF nextF -> do
pid <- mGet
mSet $ pid + 1
@ -635,12 +696,12 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
mSet $ pid + 1
mTell [PartGatherData pid desc (Right parseF) actF False]
nextF $ monadMisuseError
CmdParserPartMany desc parseF actF nextF -> do
CmdParserPartMany _ desc parseF actF nextF -> do
pid <- mGet
mSet $ pid + 1
mTell [PartGatherData pid desc (Left parseF) actF True]
nextF $ monadMisuseError
CmdParserPartManyInp desc parseF actF nextF -> do
CmdParserPartManyInp _ desc parseF actF nextF -> do
pid <- mGet
mSet $ pid + 1
mTell [PartGatherData pid desc (Right parseF) actF True]
@ -678,8 +739,8 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
processParsedParts = \case
Free (CmdParserPart desc _ _ (nextF :: p -> CmdParser f out a)) -> part desc nextF
Free (CmdParserPartInp desc _ _ (nextF :: p -> CmdParser f out a)) -> part desc nextF
Free (CmdParserPartMany desc _ _ nextF) -> partMany desc nextF
Free (CmdParserPartManyInp desc _ _ nextF) -> partMany desc nextF
Free (CmdParserPartMany bound desc _ _ nextF) -> partMany bound desc nextF
Free (CmdParserPartManyInp bound desc _ _ nextF) -> partMany bound desc nextF
Free (CmdParserReorderStop next) -> do
stackCur <- mGet
case stackCur of
@ -751,13 +812,14 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
Just _ -> monadMisuseError
partMany
:: Typeable p
=> PartDesc
=> ManyUpperBound
-> PartDesc
-> ([p] -> CmdParser f out a)
-> m (CmdParser f out a)
partMany desc nextF = do
partMany bound desc nextF = do
do
stackCur <- mGet
mSet $ descStackAdd (PartMany desc) stackCur
mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
pid <- mGet
mSet $ pid + 1
m :: PartParsedData <- mGet
@ -797,15 +859,15 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
stackCur <- mGet
mSet $ descStackAdd desc stackCur
nextF monadMisuseError
CmdParserPartMany desc _parseF _act nextF -> do
CmdParserPartMany bound desc _parseF _act nextF -> do
do
stackCur <- mGet
mSet $ descStackAdd (PartMany desc) stackCur
mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
nextF monadMisuseError
CmdParserPartManyInp desc _parseF _act nextF -> do
CmdParserPartManyInp bound desc _parseF _act nextF -> do
do
stackCur <- mGet
mSet $ descStackAdd (PartMany desc) stackCur
mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
nextF monadMisuseError
CmdParserChild cmdStr _sub _act next -> do
cmd_children %=+ ((cmdStr, emptyCommandDesc :: CommandDesc out):)
@ -900,7 +962,7 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
-- err = "command is missing implementation!"
--
-- cmdAction :: CmdParser out () -> String -> Either String out
-- cmdAction b s = case cmdRunParser Nothing s b of
-- cmdAction b s = case runCmdParser Nothing s b of
-- (_, Right cmd) -> cmdActionPartial cmd
-- (_, Left (ParsingError (out:_) _)) -> Left $ out
-- _ -> error "whoops"
@ -909,12 +971,17 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
-- -> CmdParser out ()
-- -> String
-- -> out
-- cmdActionRun f p s = case cmdRunParser Nothing s p of
-- cmdActionRun f p s = case runCmdParser Nothing s p of
-- (cmd, Right out) -> case _cmd_out out of
-- Just o -> o
-- Nothing -> f cmd (ParsingError ["command is missing implementation!"] "")
-- (cmd, Left err) -> f cmd err
wrapBoundDesc :: ManyUpperBound -> PartDesc -> PartDesc
wrapBoundDesc ManyUpperBound1 = PartOptional
wrapBoundDesc ManyUpperBoundN = PartMany
descFixParents :: CommandDesc a -> CommandDesc a
descFixParents = descFixParentsWithTopM Nothing

206
src/UI/Butcher/Monadic/Internal/Types.hs Normal file
View File

@ -0,0 +1,206 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
module UI.Butcher.Monadic.Internal.Types
( CommandDesc (..)
, cmd_mParent
, cmd_help
, cmd_synopsis
, cmd_parts
, cmd_out
, cmd_children
, emptyCommandDesc
, CmdParserF (..)
, CmdParser
, PartDesc (..)
, Input (..)
, ParsingError (..)
, addSuggestion
, ManyUpperBound (..)
)
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
-- | Butcher supports two input modi: @String@ and @[String]@. Program
-- arguments have the latter form, while parsing interactive command input
-- (e.g. when you implement a terminal of sorts) is easier when you can
-- process the full @String@ without having to wordify it first by some
-- means (and List.words is not the right approach in many situations.)
data Input = InputString String | InputArgs [String]
deriving (Show, 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
}
deriving (Show, Eq)
data ManyUpperBound
= ManyUpperBound1
| ManyUpperBoundN
data CmdParserF f out a
= CmdParserHelp PP.Doc a
| CmdParserSynopsis String a
| CmdParserPeekDesc (CommandDesc out -> 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 String (CmdParser f out ()) (f ()) a
| CmdParserImpl out a
| CmdParserReorderStart a
| CmdParserReorderStop a
| CmdParserGrouped String a
| CmdParserGroupEnd 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
---------
-- | A representation/description of a command parser built via the
-- 'CmdParser' monad. Can be transformed into a pretty Doc to display
-- as usage/help via 'ppUsage' and related functions.
--
-- 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 (String, CommandDesc out)
, _cmd_synopsis :: Maybe PP.Doc
, _cmd_help :: Maybe PP.Doc
, _cmd_parts :: [PartDesc]
, _cmd_out :: Maybe out
, _cmd_children :: [(String, CommandDesc out)]
}
-- type PartSeqDesc = [PartDesc]
-- | A representation/description of a command's parts, i.e. flags or params.
-- As a butcher user, the higher-level pretty-printing functions for
-- 'CommandDesc' are probably sufficient.
data PartDesc
= PartLiteral String -- expect a literal string, like "--dry-run"
| PartVariable String -- expect some user-provided input. The
-- string represents the name for the variable
-- used in the documentation, e.g. "FILE"
| PartOptional PartDesc
| PartAlts [PartDesc]
| PartSeq [PartDesc]
| PartDefault String -- default representation
PartDesc
| PartSuggestion [String] PartDesc
| PartRedirect String -- name for the redirection
PartDesc
| PartReorder [PartDesc]
| PartMany PartDesc
| PartWithHelp PP.Doc PartDesc
deriving Show
addSuggestion :: Maybe [String] -> PartDesc -> PartDesc
addSuggestion Nothing = id
addSuggestion (Just sugs) = PartSuggestion sugs
{-
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)
deriving instance Functor CommandDesc
--
emptyCommandDesc :: CommandDesc out
emptyCommandDesc = CommandDesc Nothing Nothing Nothing [] Nothing []
instance Show (CommandDesc out) 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)
--
LensTH.makeLenses ''CommandDesc
LensTH.makeLenses ''PartDesc
--
-- 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"

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

@ -1,3 +1,8 @@
-- | Parameters are arguments of your current command that are not prefixed
-- by some flag. Typical commandline interface is something like
-- "PROGRAM [FLAGS] INPUT". Here, FLAGS are Flags in butcher, and INPUT is
-- a Param, in this case a String representing a path, for example.
module UI.Butcher.Monadic.Param
( Param(..)
, paramHelp
@ -23,11 +28,13 @@ import qualified Text.PrettyPrint as PP
import Data.HList.ContainsType
import UI.Butcher.Monadic.Types
import UI.Butcher.Monadic.Core
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
-- | param-description monoid. You probably won't need to use the constructor;
-- mzero or any (<>) of param(Help|Default|Suggestion) works well.
data Param p = Param
{ _param_default :: Maybe p
, _param_help :: Maybe PP.Doc
@ -46,22 +53,30 @@ instance Monoid (Param p) where
f Nothing x = x
f x _ = x
-- | 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 :: [p] -> Param p
paramSuggestions ss = mempty { _param_suggestions = Just ss }
-- | 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.
addReadParam :: forall f out a
. (Applicative f, Typeable a, Show a, Text.Read.Read a)
=> String
-> Param a
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out a
addReadParam name par = addCmdPart desc parseF
where
@ -75,10 +90,11 @@ addReadParam name par = addCmdPart desc parseF
((x, []):_) -> Just (x, [])
_ -> _param_default par <&> \x -> (x, s)
-- | Like addReadParam, but optional. I.e. if reading fails, returns Nothing.
addReadParamOpt :: forall f out a
. (Applicative f, Typeable a, Text.Read.Read a)
=> String
-> Param a
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out (Maybe a)
addReadParamOpt name par = addCmdPart desc parseF
where
@ -92,6 +108,9 @@ addReadParamOpt name par = addCmdPart desc parseF
((x, []):_) -> Just (Just x, [])
_ -> Just (Nothing, s) -- TODO: we could warn about a default..
-- | Add a parameter that matches any string of non-space characters if input
-- String, or one full argument if input is [String]. See the 'Input' doc for
-- this distinction.
addStringParam
:: forall f out . (Applicative f)
=> String
@ -112,6 +131,8 @@ addStringParam name par = addCmdPartInp desc parseF
(s1:sR) -> Just (s1, InputArgs sR)
[] -> _param_default par <&> \x -> (x, InputArgs args)
-- | Like 'addStringParam', but optional, I.e. succeeding with Nothing if
-- there is no remaining input.
addStringParamOpt
:: forall f out . (Applicative f)
=> String
@ -133,6 +154,8 @@ addStringParamOpt name par = addCmdPartInp desc parseF
[] -> Just (Nothing, InputArgs [])
-- | Add a parameter that consumes _all_ remaining input. Typical usecase is
-- after a "--" as common in certain (unix?) commandline tools.
addRestOfInputStringParam
:: forall f out . (Applicative f)
=> String

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

@ -1,22 +1,38 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE MultiWayIf #-}
-- | 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.Monadic.Pretty
( ppUsage
, ppUsageAt
, ppHelpShallow
, ppUsageWithHelp
, ppPartDescUsage
, ppPartDescHeader
, ppUsageWithHelp
)
where
@ -32,11 +48,14 @@ import Text.PrettyPrint ( (<+>), ($$), ($+$) )
import Data.HList.ContainsType
import UI.Butcher.Monadic.Types
import UI.Butcher.Monadic.Core
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
-- | ppUsage exampleDesc yields:
--
-- > playground [--short] NAME [version | help]
ppUsage :: CommandDesc a
-> PP.Doc
ppUsage (CommandDesc mParent _help _syn parts out children) =
@ -54,6 +73,12 @@ ppUsage (CommandDesc mParent _help _syn parts out children) =
subDoc = PP.fcat $ PP.punctuate (PP.text " | ") $ children <&> \(n, _) ->
PP.text n
-- | ppUsageWithHelp exampleDesc yields:
--
-- > playground [--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 help _syn parts out children) =
pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc
@ -73,6 +98,11 @@ ppUsageWithHelp (CommandDesc mParent help _syn parts out children) =
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
@ -81,6 +111,24 @@ ppUsageAt strings desc =
[] -> Just $ ppUsage desc
(s:sr) -> find ((s==) . fst) (_cmd_children desc) >>= ppUsageAt sr . snd
-- | ppHelpShalloe 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@(CommandDesc mParent syn help parts _out _children) =
@ -136,6 +184,7 @@ ppHelpShallow desc@(CommandDesc mParent syn help parts _out _children) =
PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc]
++ go p
-- | Internal helper; users probably won't need this.
ppPartDescUsage :: PartDesc -> PP.Doc
ppPartDescUsage = \case
PartLiteral s -> PP.text s
@ -160,6 +209,7 @@ ppPartDescUsage = \case
where
rec = ppPartDescUsage
-- | Internal helper; users probably won't need this.
ppPartDescHeader :: PartDesc -> PP.Doc
ppPartDescHeader = \case
PartLiteral s -> PP.text s

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

@ -1,186 +1,20 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MonadComprehensions #-}
-- this module only re-exports the appropriate user-facing stuff from the
-- internal Types module.
-- | Types used in the butcher interface.
module UI.Butcher.Monadic.Types
( CommandDesc(..)
, cmd_mParent
, cmd_help
, cmd_synopsis
, cmd_parts
, cmd_out
, cmd_children
, emptyCommandDesc
, CmdParserF(..)
, CmdParser
, PartDesc(..)
, Input (..)
, ParsingError (..)
, addSuggestion
, PartDesc(..)
)
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
data Input = InputString String | InputArgs [String]
deriving (Show, Eq)
data ParsingError = ParsingError
{ _pe_messages :: [String]
, _pe_remaining :: Input
}
deriving (Show, Eq)
data CmdParserF f out a
= CmdParserHelp PP.Doc a
| CmdParserSynopsis String a
| CmdParserPeekDesc (CommandDesc out -> 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 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 PartDesc (Input -> Maybe (p, Input)) (p -> f ()) ([p] -> a)
| CmdParserChild String (CmdParser f out ()) (f ()) a
| CmdParserImpl out a
| CmdParserReorderStart a
| CmdParserReorderStop a
| CmdParserGrouped String a
| CmdParserGroupEnd a
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
---------
data CommandDesc out = CommandDesc
{ _cmd_mParent :: Maybe (String, CommandDesc out)
, _cmd_synopsis :: Maybe PP.Doc
, _cmd_help :: Maybe PP.Doc
, _cmd_parts :: [PartDesc]
, _cmd_out :: Maybe out
, _cmd_children :: [(String, CommandDesc out)]
}
-- type PartSeqDesc = [PartDesc]
data PartDesc
= PartLiteral String -- expect a literal string, like "--dry-run"
| PartVariable String -- expect some user-provided input. The
-- string represents the name for the variable
-- used in the documentation, e.g. "FILE"
| PartOptional PartDesc
| PartAlts [PartDesc]
| PartSeq [PartDesc]
| PartDefault String -- default representation
PartDesc
| PartSuggestion [String] PartDesc
| PartRedirect String -- name for the redirection
PartDesc
| PartReorder [PartDesc]
| PartMany PartDesc
| PartWithHelp PP.Doc PartDesc
deriving Show
addSuggestion :: Maybe [String] -> PartDesc -> PartDesc
addSuggestion Nothing = id
addSuggestion (Just sugs) = PartSuggestion sugs
{-
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)
deriving instance Functor CommandDesc
--
emptyCommandDesc :: CommandDesc out
emptyCommandDesc = CommandDesc Nothing Nothing Nothing [] Nothing []
instance Show (CommandDesc out) 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)
--
LensTH.makeLenses ''CommandDesc
LensTH.makeLenses ''PartDesc
--
-- 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"
import UI.Butcher.Monadic.Internal.Types

240
srcinc/prelude.inc
View File

@ -28,63 +28,6 @@ import qualified System.Time.Extra
import qualified Data.Either.Combinators
-- import qualified Control.Lens
-- import qualified Control.Monad.Error.Lens
-- import qualified Control.Parallel.Strategies.Lens
-- import qualified Control.Seq.Lens
-- import qualified Data.Array.Lens
-- import qualified Data.Bits.Lens
-- import qualified Data.ByteString.Lazy.Lens
-- import qualified Data.ByteString.Lens
-- import qualified Data.ByteString.Strict.Lens
-- import qualified Data.Complex.Lens
-- import qualified Data.Data.Lens
-- import qualified Data.Dynamic.Lens
-- import qualified Data.HashSet.Lens
-- import qualified Data.IntSet.Lens
-- import qualified Data.List.Lens
-- import qualified Data.Map.Lens
-- import qualified Data.Sequence.Lens
-- import qualified Data.Set.Lens
-- import qualified Data.Text.Lazy.Lens
-- import qualified Data.Text.Lens
-- import qualified Data.Text.Strict.Lens
-- import qualified Data.Tree.Lens
-- import qualified Data.Typeable.Lens
-- import qualified Data.Vector.Generic.Lens
-- import qualified Data.Vector.Lens
-- import qualified GHC.Generics.Lens
-- import qualified Generics.Deriving.Lens
-- import qualified Language.Haskell.TH.Lens
-- import qualified Numeric.Lens
-- import qualified System.Exit.Lens
-- import qualified System.FilePath.Lens
-- import qualified System.IO.Error.Lens
-- import qualified Control.Monad.Cont
-- import qualified Control.Monad.Cont.Class
-- import qualified Control.Monad.Error.Class
-- import qualified Control.Monad.Except
-- import qualified Control.Monad.Identity
-- import qualified Control.Monad.List
-- import qualified Control.Monad.RWS
-- import qualified Control.Monad.RWS.Class
-- import qualified Control.Monad.RWS.Lazy
-- import qualified Control.Monad.RWS.Strict
-- import qualified Control.Monad.Reader
-- import qualified Control.Monad.Reader.Class
-- import qualified Control.Monad.State
-- import qualified Control.Monad.State.Class
-- import qualified Control.Monad.State.Lazy
-- import qualified Control.Monad.State.Strict
-- import qualified Control.Monad.Trans
-- import qualified Control.Monad.Writer
-- import qualified Control.Monad.Writer.Class
-- import qualified Control.Monad.Writer.Lazy
-- import qualified Control.Monad.Writer.Strict
-- import qualified Control.Monad.Trans.MultiRWS
import qualified Control.Monad.Trans.MultiRWS.Lazy
import qualified Control.Monad.Trans.MultiRWS.Strict
import qualified Control.Monad.Trans.MultiReader
@ -103,52 +46,6 @@ import qualified Control.Monad.Trans.MultiWriter.Strict
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL
-- import qualified Control.Applicative.Backwards
-- import qualified Control.Applicative.Lift
-- import qualified Control.Monad.IO.Class
-- import qualified Control.Monad.Signatures
-- import qualified Control.Monad.Trans.Class
-- import qualified Control.Monad.Trans.Cont
-- import qualified Control.Monad.Trans.Except
-- import qualified Control.Monad.Trans.Identity
-- import qualified Control.Monad.Trans.List
-- import qualified Control.Monad.Trans.Maybe
-- import qualified Control.Monad.Trans.RWS
-- import qualified Control.Monad.Trans.RWS.Lazy
-- import qualified Control.Monad.Trans.RWS.Strict
-- import qualified Control.Monad.Trans.Reader
-- import qualified Control.Monad.Trans.State
-- import qualified Control.Monad.Trans.State.Lazy
-- import qualified Control.Monad.Trans.State.Strict
-- import qualified Control.Monad.Trans.Writer
-- import qualified Control.Monad.Trans.Writer.Lazy
-- import qualified Control.Monad.Trans.Writer.Strict
-- import qualified Data.Functor.Classes
-- import qualified Data.Functor.Compose
-- import qualified Data.Functor.Constant
-- import qualified Data.Functor.Product
-- import qualified Data.Functor.Reverse
-- import qualified Data.Functor.Sum
-- import qualified Prelude
-- import qualified Control.Applicative
-- import qualified Control.Arrow
-- import qualified Control.Category
-- import qualified Control.Concurrent
-- import qualified Control.Concurrent.Chan
-- import qualified Control.Concurrent.MVar
-- import qualified Control.Concurrent.QSem
-- import qualified Control.Concurrent.QSemN
-- import qualified Control.Exception
-- import qualified Control.Exception.Base
-- import qualified Control.Monad
-- import qualified Control.Monad.Fix
-- import qualified Control.Monad.ST
-- import qualified Control.Monad.ST.Lazy
-- import qualified Control.Monad.ST.Lazy.Unsafe
-- import qualified Control.Monad.ST.Strict
-- import qualified Control.Monad.ST.Unsafe
-- import qualified Control.Monad.Zip
import qualified Data.Bifunctor
import qualified Data.Bits
import qualified Data.Bool
@ -172,90 +69,18 @@ import qualified Data.Maybe
import qualified Data.Monoid
import qualified Data.Ord
import qualified Data.Proxy
-- import qualified Data.Ratio
-- import qualified Data.STRef
-- import qualified Data.STRef.Lazy
-- import qualified Data.STRef.Strict
-- import qualified Data.String
-- import qualified Data.Traversable
-- import qualified Data.Tuple
-- import qualified Data.Type.Bool
-- import qualified Data.Type.Coercion
-- import qualified Data.Type.Equality
-- import qualified Data.Typeable
-- import qualified Data.Typeable.Internal
-- import qualified Data.Unique
-- import qualified Data.Version
-- import qualified Data.Void
-- import qualified Data.Word
import qualified Debug.Trace
-- import qualified Foreign.C
-- import qualified Foreign.C.Error
-- import qualified Foreign.C.String
-- import qualified Foreign.C.Types
-- import qualified Foreign.Concurrent
-- import qualified Foreign.ForeignPtr
-- import qualified Foreign.ForeignPtr.Unsafe
-- import qualified Foreign.Marshal
-- import qualified Foreign.Marshal.Alloc
-- import qualified Foreign.Marshal.Array
-- import qualified Foreign.Marshal.Error
-- import qualified Foreign.Marshal.Pool
-- import qualified Foreign.Marshal.Unsafe
-- import qualified Foreign.Marshal.Utils
-- import qualified Foreign.Ptr
-- import qualified Foreign.StablePtr
-- import qualified Foreign.Storable
import qualified Numeric
import qualified Numeric.Natural
-- import qualified System.CPUTime
-- import qualified System.Console.GetOpt
import qualified System.Environment
-- import qualified System.Exit
import qualified System.IO
-- import qualified System.IO.Error
-- import qualified System.IO.Unsafe
-- import qualified System.Info
-- import qualified System.Mem
-- import qualified System.Mem.StableName
-- import qualified System.Mem.Weak
-- import qualified System.Posix.Types
-- import qualified System.Timeout
-- import qualified Text.ParserCombinators.ReadP
-- import qualified Text.ParserCombinators.ReadPrec
-- import qualified Text.Printf
import qualified Text.Read
-- import qualified Text.Read.Lex
import qualified Text.Show
-- import qualified Text.Show.Functions
import qualified Unsafe.Coerce
-- import qualified Control.Arrow as Arrow
-- import qualified Control.Category as Category
-- import qualified Control.Concurrent as Concurrent
-- import qualified Control.Concurrent.Chan as Chan
-- import qualified Control.Concurrent.MVar as MVar
-- import qualified Control.Exception as Exception
-- import qualified Control.Exception.Base as Exception.Base
-- import qualified Control.Monad as Monad
-- import qualified Data.Bits as Bits
import qualified Data.Bool as Bool
import qualified Data.Char as Char
-- import qualified Data.Complex as Complex
-- import qualified Data.Either as Either
-- import qualified Data.Eq as Eq
-- import qualified Data.Foldable as Foldable
-- import qualified Data.Fixed as Fixed
-- import qualified Data.Functor.Identity as Identity
-- import qualified Data.IORef as IORef
-- import qualified Data.Int as Int
-- import qualified Data.Ix as Ix
import qualified Data.Maybe as Maybe
-- import qualified Data.Monoid as Monoid
-- import qualified Data.Ord as Ord
-- import qualified Data.Proxy as Proxy
-- import qualified Data.Traversable as Traversable
-- import qualified Data.Void as Void
import qualified Control.Monad.Trans.Writer.Strict as WriterS
#if MIN_VERSION_base(4,9,0)
@ -264,15 +89,9 @@ import qualified GHC.OldList as List
import qualified Data.List as List
#endif
-- import qualified Text.Printf as Printf
import qualified Data.IntMap as IntMap
-- import qualified Data.IntMap.Lazy as IntMapL
import qualified Data.IntMap.Strict as IntMapS
-- import qualified Data.IntSet as IntSet
import qualified Data.Map as Map
-- import qualified Data.Map.Lazy as MapL
-- import qualified Data.Map.Strict as MapS
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
@ -281,18 +100,9 @@ import qualified Control.Monad.Reader.Class as Reader.Class
import qualified Control.Monad.State.Class as State.Class
import qualified Control.Monad.Writer.Class as Writer.Class
-- import qualified Control.Monad.Trans.Class as Trans.Class
-- import qualified Control.Monad.Trans.Maybe as Trans.Maybe
-- import qualified Control.Monad.Trans.RWS as RWS
-- import qualified Control.Monad.Trans.RWS.Lazy as RWSL
-- import qualified Control.Monad.Trans.RWS.Strict as RWSS
-- import qualified Control.Monad.Trans.Reader as Reader
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.Writer as Writer
-- import qualified Control.Monad.Trans.Writer.Lazy as WriterL
-- import qualified Control.Monad.Trans.Writer.Strict as Writer
import Data.Functor.Identity ( Identity(..) )
import Control.Concurrent.Chan ( Chan )
@ -571,57 +381,9 @@ import Control.Monad.Extra ( whenM
import Data.Tree ( Tree(..)
)
import Control.Monad.Trans.MultiRWS ( -- MultiRWST (..)
-- , MultiRWSTNull
-- , MultiRWS
-- ,
MonadMultiReader(..)
import Control.Monad.Trans.MultiRWS ( MonadMultiReader(..)
, MonadMultiWriter(..)
, MonadMultiState(..)
-- , runMultiRWST
-- , runMultiRWSTASW
-- , runMultiRWSTW
-- , runMultiRWSTAW
-- , runMultiRWSTSW
-- , runMultiRWSTNil
-- , runMultiRWSTNil_
-- , withMultiReader
-- , withMultiReader_
-- , withMultiReaders
-- , withMultiReaders_
-- , withMultiWriter
-- , withMultiWriterAW
-- , withMultiWriterWA
-- , withMultiWriterW
-- , withMultiWriters
-- , withMultiWritersAW
-- , withMultiWritersWA
-- , withMultiWritersW
-- , withMultiState
-- , withMultiStateAS
-- , withMultiStateSA
-- , withMultiStateA
-- , withMultiStateS
-- , withMultiState_
-- , withMultiStates
-- , withMultiStatesAS
-- , withMultiStatesSA
-- , withMultiStatesA
-- , withMultiStatesS
-- , withMultiStates_
-- , inflateReader
-- , inflateMultiReader
-- , inflateWriter
-- , inflateMultiWriter
-- , inflateState
-- , inflateMultiState
-- , mapMultiRWST
-- , mGetRawR
-- , mGetRawW
-- , mGetRawS
-- , mPutRawR
-- , mPutRawW
-- , mPutRawS
)
import Control.Monad.Trans.MultiReader ( runMultiReaderTNil