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 * 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 * Exposes an evil monadic interface, which allows for much nicer binding of
command part results to some variable name, where in `optparse-applicative` command part results to some variable name.
you easily lose track of what field you are modifying after the 5th `<*>`
(admittedly, i think -XRecordWildCards improves on that issue already.) 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 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. 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 * The monadic interface allows much clearer definitions of commandparses
with (nested) subcommands. No pesky sum-types are necessary. with (nested) subcommands. No pesky sum-types are necessary.
* Additionally, it is possible to wrap everything in _another_ applicative ## Examples
(chosen by the user) and execute actions whenever specific parts are
parsed successfully. This provides a direct interface for more advanced The minimal example is
features, like `--no-foo` pendants to `--foo` flags.
~~~~.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 ## 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 That means that checking if a combination of flags is allowed must be done
after parsing. (But different commands and their subcommands have separate after parsing. (But different commands and their subcommands (can) have
sets of flags.) separate sets of flags.)
## (abstract) Package intentions ## (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 name: butcher
version: 0.2.0.1 version: 1.0.0.0
-- synopsis: -- synopsis:
-- description: -- description:
license: BSD3 license: BSD3
@ -21,15 +18,19 @@ cabal-version: >=1.10
flag butcher-dev flag butcher-dev
description: dev options description: dev options
default: False default: False
manual: True
library library
exposed-modules: UI.Butcher.Monadic.Types exposed-modules: UI.Butcher.Monadic.Types
UI.Butcher.Monadic UI.Butcher.Monadic
UI.Butcher.Monadic.Core UI.Butcher.Monadic.Command
UI.Butcher.Monadic.Param UI.Butcher.Monadic.Param
UI.Butcher.Monadic.Flag UI.Butcher.Monadic.Flag
UI.Butcher.Monadic.Pretty UI.Butcher.Monadic.Pretty
UI.Butcher.Monadic.IO UI.Butcher.Monadic.IO
UI.Butcher.Monadic.BuiltinCommands
other-modules: UI.Butcher.Monadic.Internal.Types
UI.Butcher.Monadic.Internal.Core
-- other-modules: -- other-modules:
-- other-extensions: -- other-extensions:
build-depends: build-depends:
@ -70,15 +71,24 @@ library
MultiWayIf MultiWayIf
KindSignatures KindSignatures
} }
other-extensions: {
DeriveFunctor
ExistentialQuantification
GeneralizedNewtypeDeriving
StandaloneDeriving
DataKinds
TypeOperators
TemplateHaskell
}
ghc-options: { ghc-options: {
-Wall -Wall
-fprof-auto -fprof-cafs -fno-spec-constr -fno-spec-constr
-j -j
-fno-warn-unused-imports -fno-warn-unused-imports
-fno-warn-orphans -fno-warn-orphans
} }
if flag(butcher-dev) { if flag(butcher-dev) {
ghc-options: -O0 -Werror ghc-options: -O0 -Werror -fprof-auto -fprof-cafs
} }
include-dirs: include-dirs:
srcinc srcinc
@ -129,13 +139,12 @@ test-suite tests
} }
ghc-options: { ghc-options: {
-Wall -Wall
-O0 -fno-spec-constr
-fprof-auto -fprof-cafs -fno-spec-constr
-j -j
-fno-warn-unused-imports -fno-warn-unused-imports
-fno-warn-orphans -fno-warn-orphans
} }
if flag(butcher-dev) { 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 NeatInterpolation
import UI.Butcher.Monadic import UI.Butcher.Monadic
import UI.Butcher.Monadic.Types
@ -29,7 +30,7 @@ checkTests = do
simpleParseTest :: Spec simpleParseTest :: Spec
simpleParseTest = do 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 `shouldSatisfy` Data.Either.Combinators.isLeft . snd
it "toplevel" $ (testParse testCmd1 "" >>= _cmd_out) it "toplevel" $ (testParse testCmd1 "" >>= _cmd_out)
`shouldSatisfy` Maybe.isNothing `shouldSatisfy` Maybe.isNothing
@ -112,14 +113,14 @@ testCmd3 = do
testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out) testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out)
testParse cmd s = either (const Nothing) Just testParse cmd s = either (const Nothing) Just
$ snd $ snd
$ cmdRunParser Nothing (InputString s) cmd $ runCmdParser Nothing (InputString s) cmd
testRun :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () -> String -> Either ParsingError (Maybe Int) testRun :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () -> String -> Either ParsingError (Maybe Int)
testRun cmd s = fmap (fmap (getSum . WriterS.execWriter) . _cmd_out) testRun cmd s = fmap (fmap (getSum . WriterS.execWriter) . _cmd_out)
$ snd $ snd
$ cmdRunParser Nothing (InputString s) cmd $ runCmdParser Nothing (InputString s) cmd
testRunA :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError Int testRunA :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError Int
testRunA cmd str = (\((_, e), s) -> e $> s) testRunA cmd str = (\((_, e), s) -> e $> s)
$ flip StateS.runState (0::Int) $ 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 UI.Butcher.Monadic
( module Export ( -- * Types
, cmds 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 -- , sample
-- , test -- , test
, test2 -- , test2
, test3 -- , test3
-- * Builtin commands
, addHelpCommand
, addButcherDebugCommand
) )
where where
@ -12,20 +35,54 @@ where
#include "prelude.inc" #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 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 ()) () #ifdef HLINT
cmds = do {-# 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 addCmd "echo" $ do
addCmdHelpStr "print its parameter to output" addCmdHelpStr "print its parameter to output"
str <- addReadParam "STRING" (paramHelpStr "the string to print") str <- addReadParam "STRING" (paramHelpStr "the string to print")
@ -76,15 +133,15 @@ data Sample = Sample
-- test :: String -> OPA.ParserResult Sample -- test :: String -> OPA.ParserResult Sample
-- test s = OPA.execParserPure OPA.defaultPrefs (OPA.ParserInfo sample True mempty mempty mempty (-13) True) (List.words s) -- test s = OPA.execParserPure OPA.defaultPrefs (OPA.ParserInfo sample True mempty mempty mempty (-13) True) (List.words s)
test2 :: IO () _test2 :: IO ()
test2 = case cmdCheckParser (Just "butcher") cmds of _test2 = case checkCmdParser (Just "butcher") _cmds of
Left e -> putStrLn $ "LEFT: " ++ e Left e -> putStrLn $ "LEFT: " ++ e
Right desc -> do Right desc -> do
print $ ppUsage desc print $ ppUsage desc
print $ maybe undefined id $ ppUsageAt ["hello"] desc print $ maybe undefined id $ ppUsageAt ["hello"] desc
test3 :: String -> IO () _test3 :: String -> IO ()
test3 s = case cmdRunParser (Just "butcher") (InputString s) cmds of _test3 s = case runCmdParser (Just "butcher") (InputString s) _cmds of
(desc, Left e) -> do (desc, Left e) -> do
print e print e
print $ ppHelpShallow desc 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 module UI.Butcher.Monadic.Flag
( Flag(..) ( Flag(..)
, flagHelp
, flagHelpStr
, flagDefault
, addSimpleBoolFlag , addSimpleBoolFlag
, addSimpleCountFlag , addSimpleCountFlag
, addSimpleFlagA , addSimpleFlagA
, addFlagReadParam , addFlagReadParam
, addFlagReadParams , addFlagReadParams
, addFlagReadParamA -- , addFlagReadParamA
, addFlagStringParam , addFlagStringParam
, addFlagStringParams , addFlagStringParams
, addFlagStringParamA -- , addFlagStringParamA
, flagHelp
, flagHelpStr
, flagDefault
) )
where where
@ -26,13 +36,15 @@ import qualified Text.PrettyPrint as PP
import Data.HList.ContainsType import Data.HList.ContainsType
import UI.Butcher.Monadic.Types import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Core import UI.Butcher.Monadic.Internal.Core
import Data.List.Extra ( firstJust ) 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 data Flag p = Flag
{ _flag_help :: Maybe PP.Doc { _flag_help :: Maybe PP.Doc
, _flag_default :: Maybe p , _flag_default :: Maybe p
@ -42,34 +54,47 @@ instance Monoid (Flag p) where
mempty = Flag Nothing Nothing mempty = Flag Nothing Nothing
Flag a1 b1 `mappend` Flag a2 b2 = Flag (a1 <|> a2) (b1 <|> b2) 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 :: PP.Doc -> Flag p
flagHelp h = mempty { _flag_help = Just h } flagHelp h = mempty { _flag_help = Just h }
-- | Create a 'Flag' with just a help text.
flagHelpStr :: String -> Flag p flagHelpStr :: String -> Flag p
flagHelpStr s = mempty { _flag_help = Just $ PP.text s } flagHelpStr s = mempty { _flag_help = Just $ PP.text s }
-- | Create a 'Flag' with just a default value.
flagDefault :: p -> Flag p flagDefault :: p -> Flag p
flagDefault d = mempty { _flag_default = Just d } flagDefault d = mempty { _flag_default = Just d }
-- | A no-parameter flag where non-occurence means False, occurence means True.
addSimpleBoolFlag addSimpleBoolFlag
:: Applicative f :: 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 = addSimpleBoolFlag shorts longs flag =
addSimpleBoolFlagAll shorts longs flag (pure ()) addSimpleBoolFlagAll shorts longs flag (pure ())
-- | Applicative-enabled version of 'addSimpleFlag'
addSimpleFlagA 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 addSimpleFlagA shorts longs flag act
= void $ addSimpleBoolFlagAll shorts longs flag act = void $ addSimpleBoolFlagAll shorts longs flag act
addSimpleBoolFlagAll addSimpleBoolFlagAll
:: String -- short flag chars, i.e. "v" for -v :: String
-> [String] -- list of long names, i.e. ["verbose"] -> [String]
-> Flag Void -> Flag Void
-> f () -> f ()
-> CmdParser f out Bool -> CmdParser f out Bool
addSimpleBoolFlagAll shorts longs flag a = fmap (not . null) addSimpleBoolFlagAll shorts longs flag a
$ addCmdPartManyA desc parseF (\() -> a) = fmap (not . null)
$ addCmdPartManyA ManyUpperBound1 desc parseF (\() -> a)
where where
allStrs = fmap (\c -> "-"++[c]) shorts allStrs = fmap (\c -> "-"++[c]) shorts
++ fmap (\s -> "--"++s) longs ++ fmap (\s -> "--"++s) longs
@ -83,13 +108,16 @@ addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
| (s ++ " ") `isPrefixOf` str ]) | (s ++ " ") `isPrefixOf` str ])
allStrs) allStrs)
-- | 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 -- ^ short flag chars, i.e. "v" for -v
-> [String] -- list of long names, i.e. ["verbose"] -> [String] -- ^ list of long names, i.e. ["verbose"]
-> Flag Void -> Flag Void -- ^ properties
-> CmdParser f out Int -> CmdParser f out Int
addSimpleCountFlag shorts longs flag = fmap length addSimpleCountFlag shorts longs flag
$ addCmdPartMany desc parseF = fmap length
$ addCmdPartMany ManyUpperBoundN desc parseF
where where
-- we _could_ allow this to parse repeated short flags, like "-vvv" -- we _could_ allow this to parse repeated short flags, like "-vvv"
-- (meaning "-v -v -v") correctly. -- (meaning "-v -v -v") correctly.
@ -105,14 +133,14 @@ addSimpleCountFlag shorts longs flag = fmap length
| (s ++ " ") `isPrefixOf` str ]) | (s ++ " ") `isPrefixOf` str ])
allStrs) allStrs)
-- | One-argument flag, where the argument is parsed via its Read instance.
addFlagReadParam addFlagReadParam
:: forall f p out :: forall f p out
. (Applicative f, Typeable p, Text.Read.Read p, Show p) . (Applicative f, Typeable p, Text.Read.Read p, Show p)
=> String => String -- ^ short flag chars, i.e. "v" for -v
-> [String] -> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- param name -> String -- ^ param name
-> Flag p -> Flag p -- ^ properties
-> CmdParser f out p -> CmdParser f out p
addFlagReadParam shorts longs name flag = addCmdPartInpA desc parseF (\_ -> pure ()) addFlagReadParam shorts longs name flag = addCmdPartInpA desc parseF (\_ -> pure ())
where where
@ -139,39 +167,48 @@ addFlagReadParam shorts longs name flag = addCmdPartInpA desc parseF (\_ -> pure
(arg2:rest) -> readMaybe arg2 <&> \x -> (x, InputArgs rest) (arg2:rest) -> readMaybe arg2 <&> \x -> (x, InputArgs rest)
InputArgs _ -> _flag_default flag <&> \d -> (d, inp) InputArgs _ -> _flag_default flag <&> \d -> (d, inp)
-- | One-argument flag, where the argument is parsed via its Read instance.
-- This version can accumulate multiple values by using the same flag with
-- different arguments multiple times.
--
-- E.g. "--foo 3 --foo 5" yields [3,5].
addFlagReadParams addFlagReadParams
:: forall f p out :: forall f p out
. (Applicative f, Typeable p, Text.Read.Read p, Show p) . (Applicative f, Typeable p, Text.Read.Read p, Show p)
=> String => String -- ^ short flag chars, i.e. "v" for -v
-> [String] -> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- param name -> String -- ^ param name
-> Flag p -> Flag p -- ^ properties
-> CmdParser f out [p] -> CmdParser f out [p]
addFlagReadParams shorts longs name flag addFlagReadParams shorts longs name flag
= addFlagReadParamsAll shorts longs name flag (\_ -> pure ()) = addFlagReadParamsAll shorts longs name flag (\_ -> pure ())
addFlagReadParamA -- TODO: this implementation is wrong, because it uses addCmdPartManyInpA
:: forall f p out -- while this really is no Many.
. (Typeable p, Text.Read.Read p, Show p) -- | Applicative-enabled version of 'addFlagReadParam'
=> String -- addFlagReadParamA
-> [String] -- :: forall f p out
-> String -- param name -- . (Typeable p, Text.Read.Read p, Show p)
-> Flag p -- => String -- ^ short flag chars, i.e. "v" for -v
-> (p -> f ()) -- -> [String] -- ^ list of long names, i.e. ["verbose"]
-> CmdParser f out () -- -> String -- ^ param name
addFlagReadParamA shorts longs name flag act -- -> Flag p -- ^ properties
= void $ addFlagReadParamsAll shorts longs name flag act -- -> (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 addFlagReadParamsAll
:: forall f p out :: forall f p out
. (Typeable p, Text.Read.Read p, Show p) . (Typeable p, Text.Read.Read p, Show p)
=> String => String -- ^ short flag chars, i.e. "v" for -v
-> [String] -> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- param name -> String -- ^ param name
-> Flag p -> Flag p -- ^ properties
-> (p -> f ()) -> (p -> f ()) -- ^ action to execute when ths param matches
-> CmdParser f out [p] -> 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 where
allStrs = fmap (\c -> "-"++[c]) shorts allStrs = fmap (\c -> "-"++[c]) shorts
++ fmap (\s -> "--"++s) longs ++ fmap (\s -> "--"++s) longs
@ -200,13 +237,14 @@ addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA desc parseF
InputArgs _ -> Nothing InputArgs _ -> Nothing
-- | One-argument flag where the argument can be an arbitrary string.
addFlagStringParam addFlagStringParam
:: forall f out :: forall f out
. (Applicative f) . (Applicative f)
=> String => String -- ^ short flag chars, i.e. "v" for -v
-> [String] -> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- param name -> String -- ^ param name
-> Flag String -> Flag String -- ^ properties
-> CmdParser f out String -> CmdParser f out String
addFlagStringParam shorts longs name flag = addCmdPartInpA desc parseF (\_ -> pure ()) addFlagStringParam shorts longs name flag = addCmdPartInpA desc parseF (\_ -> pure ())
where 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 (InputArgs (s1:s2:sr)) | any (==s1) allStrs = Just (s2, InputArgs sr)
parseF inp@(InputArgs _) = _flag_default flag <&> \x -> (x, inp) 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 addFlagStringParams
:: forall f out :: forall f out
. (Applicative f) . (Applicative f)
=> String => String -- ^ short flag chars, i.e. "v" for -v
-> [String] -> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- param name -> String -- ^ param name
-> Flag Void -> Flag Void -- ^ properties
-> CmdParser f out [String] -> CmdParser f out [String]
addFlagStringParams shorts longs name flag addFlagStringParams shorts longs name flag
= addFlagStringParamsAll shorts longs name flag (\_ -> pure ()) = addFlagStringParamsAll shorts longs name flag (\_ -> pure ())
addFlagStringParamA -- TODO: this implementation is wrong, because it uses addCmdPartManyInpA
:: forall f out -- while this really is no Many.
. String -- -- | Applicative-enabled version of 'addFlagStringParam'
-> [String] -- addFlagStringParamA
-> String -- param name -- :: forall f out
-> Flag Void -- . String -- ^ short flag chars, i.e. "v" for -v
-> (String -> f ()) -- -> [String] -- ^ list of long names, i.e. ["verbose"]
-> CmdParser f out () -- -> String -- ^ param name
addFlagStringParamA shorts longs name flag act -- -> Flag Void -- ^ properties
= void $ addFlagStringParamsAll shorts longs name flag act -- -> (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 addFlagStringParamsAll
:: forall f out :: forall f out
. String . String
-> [String] -> [String]
-> String -- param name -> String
-> Flag Void -- we forbid the default because it has bad interaction -> Flag Void -- we forbid the default because it has bad interaction
-- with the eat-anything behaviour of the string parser. -- with the eat-anything behaviour of the string parser.
-> (String -> f ()) -> (String -> f ())
-> CmdParser f out [String] -> CmdParser f out [String]
addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA desc parseF act addFlagStringParamsAll shorts longs name flag act =
addCmdPartManyInpA ManyUpperBoundN desc parseF act
where where
allStrs = fmap (\c -> "-"++[c]) shorts allStrs = fmap (\c -> "-"++[c]) shorts
++ fmap (\s -> "--"++s) longs ++ 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 module UI.Butcher.Monadic.IO
( mainFromCmdParser ( mainFromCmdParser
, addHelpCommand , mainFromCmdParserWithHelpDesc
, addButcherDebugCommand
) )
where where
@ -16,8 +16,8 @@ import qualified Text.PrettyPrint as PP
import Data.HList.ContainsType import Data.HList.ContainsType
import UI.Butcher.Monadic.Types import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Core import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Monadic.Pretty import UI.Butcher.Monadic.Pretty
import UI.Butcher.Monadic.Param 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 :: CmdParser Identity (IO ()) () -> IO ()
mainFromCmdParser cmd = do mainFromCmdParser cmd = do
progName <- System.Environment.getProgName progName <- System.Environment.getProgName
case cmdCheckParser (Just progName) cmd of case checkCmdParser (Just progName) cmd of
Left e -> do Left e -> do
putStrErrLn $ progName ++ ": internal error: failed sanity check for butcher main command parser!" putStrErrLn $ progName ++ ": internal error: failed sanity check for butcher main command parser!"
putStrErrLn $ "(" ++ e ++ ")" putStrErrLn $ "(" ++ e ++ ")"
putStrErrLn $ "aborting." putStrErrLn $ "aborting."
Right _ -> do Right _ -> do
args <- System.Environment.getArgs 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 (desc, Left (ParsingError mess remaining)) -> do
putStrErrLn $ progName ++ ": error parsing arguments: " ++ head mess putStrErrLn $ progName ++ ": error parsing arguments: " ++ head mess
putStrErrLn $ case remaining of putStrErrLn $ case remaining of
@ -55,25 +64,44 @@ mainFromCmdParser cmd = do
printErr $ ppUsage desc printErr $ ppUsage desc
Just a -> a Just a -> a
addHelpCommand :: Applicative f => CmdParser f (IO ()) () -- | Same as mainFromCmdParser, but with one additional twist: You get access
addHelpCommand = addCmd "help" $ do -- to a knot-tied complete CommandDesc for this full command. Useful in
desc <- peekCmdDesc -- combination with 'UI.Butcher.Monadic.BuiltinCommands.addHelpCommand'
rest <- addRestOfInputStringParam "SUBCOMMAND(s)" mempty mainFromCmdParserWithHelpDesc
addCmdImpl $ do :: (CommandDesc () -> CmdParser Identity (IO ()) ()) -> IO ()
let parentDesc = maybe undefined snd (_cmd_mParent desc) mainFromCmdParserWithHelpDesc cmdF = do
let restWords = List.words rest progName <- System.Environment.getProgName
let descent :: [String] -> CommandDesc a -> CommandDesc a let (checkResult, fullDesc)
descent [] curDesc = curDesc -- knot-tying at its finest..
descent (w:wr) curDesc = case List.lookup w $ _cmd_children curDesc of = ( checkCmdParser (Just progName) (cmdF fullDesc)
Nothing -> curDesc , either (const emptyCommandDesc) id $ checkResult
Just child -> descent wr child )
print $ ppHelpShallow $ descent restWords parentDesc case checkResult of
Left e -> do
addButcherDebugCommand :: Applicative f => CmdParser f (IO ()) () putStrErrLn $ progName ++ ": internal error: failed sanity check for butcher main command parser!"
addButcherDebugCommand = addCmd "butcherdebug" $ do putStrErrLn $ "(" ++ e ++ ")"
desc <- peekCmdDesc putStrErrLn $ "aborting."
addCmdImpl $ do Right _ -> do
print $ maybe undefined snd (_cmd_mParent desc) 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 :: String -> IO ()
putStrErrLn s = hPutStrLn stderr s 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 DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE MultiWayIf #-}
module UI.Butcher.Monadic.Core module UI.Butcher.Monadic.Internal.Core
( addCmdSynopsis ( addCmdSynopsis
, addCmdHelp , addCmdHelp
, addCmdHelpStr , addCmdHelpStr
@ -27,11 +23,11 @@ module UI.Butcher.Monadic.Core
, addCmdImpl , addCmdImpl
, reorderStart , reorderStart
, reorderStop , reorderStop
, cmdCheckParser , checkCmdParser
, cmdRunParser , runCmdParser
, cmdRunParserExt , runCmdParserExt
, cmdRunParserA , runCmdParserA
, cmdRunParserAExt , runCmdParserAExt
) )
where where
@ -52,7 +48,7 @@ import Data.HList.ContainsType
import Data.Dynamic 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 -- instance IsHelpBuilder FlagBuilder where
-- help s = liftF $ FlagBuilderHelp s () -- 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 :: String -> CmdParser f out ()
addCmdSynopsis s = liftF $ CmdParserSynopsis s () 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 :: PP.Doc -> CmdParser f out ()
addCmdHelp s = liftF $ CmdParserHelp s () addCmdHelp s = liftF $ CmdParserHelp s ()
-- | Like @'addCmdHelp' . PP.text@
addCmdHelpStr :: String -> CmdParser f out () addCmdHelpStr :: String -> CmdParser f out ()
addCmdHelpStr s = liftF $ CmdParserHelp (PP.text s) () 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 :: CmdParser f out (CommandDesc out)
peekCmdDesc = liftF $ CmdParserPeekDesc id peekCmdDesc = liftF $ CmdParserPeekDesc id
@ -120,18 +134,20 @@ addCmdPartA p f a = liftF $ CmdParserPart p f a id
addCmdPartMany addCmdPartMany
:: (Applicative f, Typeable p) :: (Applicative f, Typeable p)
=> PartDesc => ManyUpperBound
-> PartDesc
-> (String -> Maybe (p, String)) -> (String -> Maybe (p, String))
-> CmdParser f out [p] -> 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 addCmdPartManyA
:: (Typeable p) :: (Typeable p)
=> PartDesc => ManyUpperBound
-> PartDesc
-> (String -> Maybe (p, String)) -> (String -> Maybe (p, String))
-> (p -> f ()) -> (p -> f ())
-> CmdParser f out [p] -> 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 addCmdPartInp
:: (Applicative f, Typeable p) :: (Applicative f, Typeable p)
@ -150,32 +166,54 @@ addCmdPartInpA p f a = liftF $ CmdParserPartInp p f a id
addCmdPartManyInp addCmdPartManyInp
:: (Applicative f, Typeable p) :: (Applicative f, Typeable p)
=> PartDesc => ManyUpperBound
-> PartDesc
-> (Input -> Maybe (p, Input)) -> (Input -> Maybe (p, Input))
-> CmdParser f out [p] -> 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 addCmdPartManyInpA
:: (Typeable p) :: (Typeable p)
=> PartDesc => ManyUpperBound
-> PartDesc
-> (Input -> Maybe (p, Input)) -> (Input -> Maybe (p, Input))
-> (p -> f ()) -> (p -> f ())
-> CmdParser f out [p] -> 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 addCmd
:: Applicative f :: Applicative f
=> String => String -- ^ command name
-> CmdParser f out () -> CmdParser f out () -- ^ subcommand
-> CmdParser f out () -> CmdParser f out ()
addCmd str sub = liftF $ CmdParserChild str sub (pure ()) () addCmd str sub = liftF $ CmdParserChild str sub (pure ()) ()
-- | Add an implementation to the current command.
addCmdImpl :: out -> CmdParser f out () addCmdImpl :: out -> CmdParser f out ()
addCmdImpl o = liftF $ CmdParserImpl o () 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 :: CmdParser f out ()
reorderStart = liftF $ CmdParserReorderStart () reorderStart = liftF $ CmdParserReorderStart ()
-- | See 'reorderStart'
reorderStop :: CmdParser f out () reorderStop :: CmdParser f out ()
reorderStop = liftF $ CmdParserReorderStop () reorderStop = liftF $ CmdParserReorderStop ()
@ -209,11 +247,19 @@ descStackAdd d = \case
StackLayer l s u -> StackLayer (d:l) s u StackLayer l s u -> StackLayer (d:l) s u
cmdCheckParser :: forall f out -- | Because butcher is evil (i.e. has constraints not encoded in the types;
. Maybe String -- top-level command name -- see the README), this method can be used as a rough check that you did not
-> CmdParser f out () -- 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 ()) -> Either String (CommandDesc ())
cmdCheckParser mTopLevel cmdParser checkCmdParser mTopLevel cmdParser
= (>>= final) = (>>= final)
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateAS (StackBottom []) $ MultiRWSS.withMultiStateAS (StackBottom [])
@ -255,15 +301,15 @@ cmdCheckParser mTopLevel cmdParser
descStack <- mGet descStack <- mGet
mSet $ descStackAdd desc descStack mSet $ descStackAdd desc descStack
processMain $ nextF monadMisuseError processMain $ nextF monadMisuseError
Free (CmdParserPartMany desc _parseF _act nextF) -> do Free (CmdParserPartMany bound desc _parseF _act nextF) -> do
do do
descStack <- mGet descStack <- mGet
mSet $ descStackAdd (PartMany desc) descStack mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
processMain $ nextF monadMisuseError processMain $ nextF monadMisuseError
Free (CmdParserPartManyInp desc _parseF _act nextF) -> do Free (CmdParserPartManyInp bound desc _parseF _act nextF) -> do
do do
descStack <- mGet descStack <- mGet
mSet $ descStackAdd (PartMany desc) descStack mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
processMain $ nextF monadMisuseError processMain $ nextF monadMisuseError
Free (CmdParserChild cmdStr sub _act next) -> do Free (CmdParserChild cmdStr sub _act next) -> do
cmd :: CommandDesc out <- mGet cmd :: CommandDesc out <- mGet
@ -320,46 +366,60 @@ cmdCheckParser mTopLevel cmdParser
monadMisuseError :: a monadMisuseError :: a
monadMisuseError = error "CmdParser definition error - used Monad powers where only Applicative/Arrow is allowed" monadMisuseError = error "CmdParser definition error - used Monad powers where only Applicative/Arrow is allowed"
newtype PastCommandInput = PastCommandInput Input newtype PastCommandInput = PastCommandInput Input
cmdRunParser -- | Run a @CmdParser@ on the given input, returning:
:: Maybe String --
-> Input -- a) A @CommandDesc ()@ that accurately represents the subcommand that was
-> CmdParser Identity out () -- 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)) -> (CommandDesc (), Either ParsingError (CommandDesc out))
cmdRunParser mTopLevel inputInitial cmdParser runCmdParser mTopLevel inputInitial cmdParser
= runIdentity = runIdentity
$ cmdRunParserA mTopLevel inputInitial cmdParser $ runCmdParserA mTopLevel inputInitial cmdParser
cmdRunParserExt -- | Like 'runCmdParser', but also returning all input after the last
:: Maybe String -- successfully parsed subcommand. E.g. for some input
-> Input -- "myprog foo bar -v --wrong" where parsing fails at "--wrong", this will
-> CmdParser Identity out () -- 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)) -> (CommandDesc (), Input, Either ParsingError (CommandDesc out))
cmdRunParserExt mTopLevel inputInitial cmdParser runCmdParserExt mTopLevel inputInitial cmdParser
= runIdentity = 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 . Applicative f
=> Maybe String => Maybe String -- ^ program name to be used for the top-level @CommandDesc@
-> Input -> Input -- ^ input to be processed
-> CmdParser f out () -> CmdParser f out () -- ^ parser to use
-> f ( CommandDesc () -> f ( CommandDesc ()
, Either ParsingError (CommandDesc out) , Either ParsingError (CommandDesc out)
) )
cmdRunParserA mTopLevel inputInitial cmdParser = runCmdParserA mTopLevel inputInitial cmdParser =
(\(x, _, z) -> (x, z)) <$> cmdRunParserAExt mTopLevel inputInitial cmdParser (\(x, _, z) -> (x, z)) <$> runCmdParserAExt mTopLevel inputInitial cmdParser
cmdRunParserAExt -- | The Applicative-enabled version of 'runCmdParserExt'.
runCmdParserAExt
:: forall f out . Applicative f :: forall f out . Applicative f
=> Maybe String => Maybe String -- ^ program name to be used for the top-level @CommandDesc@
-> Input -> Input -- ^ input to be processed
-> CmdParser f out () -> CmdParser f out () -- ^ parser to use
-> f (CommandDesc (), Input, Either ParsingError (CommandDesc out)) -> f (CommandDesc (), Input, Either ParsingError (CommandDesc out))
cmdRunParserAExt mTopLevel inputInitial cmdParser runCmdParserAExt mTopLevel inputInitial cmdParser
= runIdentity = runIdentity
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.runMultiRWSTNil
$ (<&> captureFinal) $ (<&> captureFinal)
@ -461,10 +521,10 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
Nothing -> do Nothing -> do
mTell ["could not parse " ++ getPartSeqDescPositionName desc] mTell ["could not parse " ++ getPartSeqDescPositionName desc]
processMain $ nextF monadMisuseError processMain $ nextF monadMisuseError
Free (CmdParserPartMany desc parseF actF nextF) -> do Free (CmdParserPartMany bound desc parseF actF nextF) -> do
do do
descStack <- mGet descStack <- mGet
mSet $ descStackAdd desc descStack mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
let proc = do let proc = do
dropSpaces dropSpaces
input <- mGet input <- mGet
@ -485,10 +545,10 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
r <- proc r <- proc
let act = traverse actF r let act = traverse actF r
(act *>) <$> processMain (nextF $ r) (act *>) <$> processMain (nextF $ r)
Free (CmdParserPartManyInp desc parseF actF nextF) -> do Free (CmdParserPartManyInp bound desc parseF actF nextF) -> do
do do
descStack <- mGet descStack <- mGet
mSet $ descStackAdd desc descStack mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
let proc = do let proc = do
dropSpaces dropSpaces
input <- mGet input <- mGet
@ -625,6 +685,7 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
=> CmdParserF f out (m ()) => CmdParserF f out (m ())
-> m () -> m ()
reorderPartGather = \case reorderPartGather = \case
-- TODO: why do PartGatherData contain desc?
CmdParserPart desc parseF actF nextF -> do CmdParserPart desc parseF actF nextF -> do
pid <- mGet pid <- mGet
mSet $ pid + 1 mSet $ pid + 1
@ -635,12 +696,12 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
mSet $ pid + 1 mSet $ pid + 1
mTell [PartGatherData pid desc (Right parseF) actF False] mTell [PartGatherData pid desc (Right parseF) actF False]
nextF $ monadMisuseError nextF $ monadMisuseError
CmdParserPartMany desc parseF actF nextF -> do CmdParserPartMany _ desc parseF actF nextF -> do
pid <- mGet pid <- mGet
mSet $ pid + 1 mSet $ pid + 1
mTell [PartGatherData pid desc (Left parseF) actF True] mTell [PartGatherData pid desc (Left parseF) actF True]
nextF $ monadMisuseError nextF $ monadMisuseError
CmdParserPartManyInp desc parseF actF nextF -> do CmdParserPartManyInp _ desc parseF actF nextF -> do
pid <- mGet pid <- mGet
mSet $ pid + 1 mSet $ pid + 1
mTell [PartGatherData pid desc (Right parseF) actF True] mTell [PartGatherData pid desc (Right parseF) actF True]
@ -678,8 +739,8 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
processParsedParts = \case processParsedParts = \case
Free (CmdParserPart desc _ _ (nextF :: p -> CmdParser f out a)) -> part desc nextF 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 (CmdParserPartInp desc _ _ (nextF :: p -> CmdParser f out a)) -> part desc nextF
Free (CmdParserPartMany desc _ _ nextF) -> partMany desc nextF Free (CmdParserPartMany bound desc _ _ nextF) -> partMany bound desc nextF
Free (CmdParserPartManyInp desc _ _ nextF) -> partMany desc nextF Free (CmdParserPartManyInp bound desc _ _ nextF) -> partMany bound desc nextF
Free (CmdParserReorderStop next) -> do Free (CmdParserReorderStop next) -> do
stackCur <- mGet stackCur <- mGet
case stackCur of case stackCur of
@ -751,13 +812,14 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
Just _ -> monadMisuseError Just _ -> monadMisuseError
partMany partMany
:: Typeable p :: Typeable p
=> PartDesc => ManyUpperBound
-> PartDesc
-> ([p] -> CmdParser f out a) -> ([p] -> CmdParser f out a)
-> m (CmdParser f out a) -> m (CmdParser f out a)
partMany desc nextF = do partMany bound desc nextF = do
do do
stackCur <- mGet stackCur <- mGet
mSet $ descStackAdd (PartMany desc) stackCur mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
pid <- mGet pid <- mGet
mSet $ pid + 1 mSet $ pid + 1
m :: PartParsedData <- mGet m :: PartParsedData <- mGet
@ -797,15 +859,15 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
stackCur <- mGet stackCur <- mGet
mSet $ descStackAdd desc stackCur mSet $ descStackAdd desc stackCur
nextF monadMisuseError nextF monadMisuseError
CmdParserPartMany desc _parseF _act nextF -> do CmdParserPartMany bound desc _parseF _act nextF -> do
do do
stackCur <- mGet stackCur <- mGet
mSet $ descStackAdd (PartMany desc) stackCur mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
nextF monadMisuseError nextF monadMisuseError
CmdParserPartManyInp desc _parseF _act nextF -> do CmdParserPartManyInp bound desc _parseF _act nextF -> do
do do
stackCur <- mGet stackCur <- mGet
mSet $ descStackAdd (PartMany desc) stackCur mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
nextF monadMisuseError nextF monadMisuseError
CmdParserChild cmdStr _sub _act next -> do CmdParserChild cmdStr _sub _act next -> do
cmd_children %=+ ((cmdStr, emptyCommandDesc :: CommandDesc out):) cmd_children %=+ ((cmdStr, emptyCommandDesc :: CommandDesc out):)
@ -900,7 +962,7 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
-- err = "command is missing implementation!" -- err = "command is missing implementation!"
-- --
-- cmdAction :: CmdParser out () -> String -> Either String out -- 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 -- (_, Right cmd) -> cmdActionPartial cmd
-- (_, Left (ParsingError (out:_) _)) -> Left $ out -- (_, Left (ParsingError (out:_) _)) -> Left $ out
-- _ -> error "whoops" -- _ -> error "whoops"
@ -909,12 +971,17 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser
-- -> CmdParser out () -- -> CmdParser out ()
-- -> String -- -> String
-- -> out -- -> 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 -- (cmd, Right out) -> case _cmd_out out of
-- Just o -> o -- Just o -> o
-- Nothing -> f cmd (ParsingError ["command is missing implementation!"] "") -- Nothing -> f cmd (ParsingError ["command is missing implementation!"] "")
-- (cmd, Left err) -> f cmd err -- (cmd, Left err) -> f cmd err
wrapBoundDesc :: ManyUpperBound -> PartDesc -> PartDesc
wrapBoundDesc ManyUpperBound1 = PartOptional
wrapBoundDesc ManyUpperBoundN = PartMany
descFixParents :: CommandDesc a -> CommandDesc a descFixParents :: CommandDesc a -> CommandDesc a
descFixParents = descFixParentsWithTopM Nothing 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 module UI.Butcher.Monadic.Param
( Param(..) ( Param(..)
, paramHelp , paramHelp
@ -23,11 +28,13 @@ import qualified Text.PrettyPrint as PP
import Data.HList.ContainsType import Data.HList.ContainsType
import UI.Butcher.Monadic.Types import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Core 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 data Param p = Param
{ _param_default :: Maybe p { _param_default :: Maybe p
, _param_help :: Maybe PP.Doc , _param_help :: Maybe PP.Doc
@ -46,22 +53,30 @@ instance Monoid (Param p) where
f Nothing x = x f Nothing x = x
f x _ = x f x _ = x
-- | Create a 'Param' with just a help text.
paramHelpStr :: String -> Param p paramHelpStr :: String -> Param p
paramHelpStr s = mempty { _param_help = Just $ PP.text s } paramHelpStr s = mempty { _param_help = Just $ PP.text s }
-- | Create a 'Param' with just a help text.
paramHelp :: PP.Doc -> Param p paramHelp :: PP.Doc -> Param p
paramHelp h = mempty { _param_help = Just h } paramHelp h = mempty { _param_help = Just h }
-- | Create a 'Param' with just a default value.
paramDefault :: p -> Param p paramDefault :: p -> Param p
paramDefault d = mempty { _param_default = Just d } paramDefault d = mempty { _param_default = Just d }
-- | Create a 'Param' with just a list of suggestion values.
paramSuggestions :: [p] -> Param p paramSuggestions :: [p] -> Param p
paramSuggestions ss = mempty { _param_suggestions = Just ss } 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 addReadParam :: forall f out a
. (Applicative f, Typeable a, Show a, Text.Read.Read a) . (Applicative f, Typeable a, Show a, Text.Read.Read a)
=> String => String -- ^ paramater name, for use in usage/help texts
-> Param a -> Param a -- ^ properties
-> CmdParser f out a -> CmdParser f out a
addReadParam name par = addCmdPart desc parseF addReadParam name par = addCmdPart desc parseF
where where
@ -75,10 +90,11 @@ addReadParam name par = addCmdPart desc parseF
((x, []):_) -> Just (x, []) ((x, []):_) -> Just (x, [])
_ -> _param_default par <&> \x -> (x, s) _ -> _param_default par <&> \x -> (x, s)
-- | Like addReadParam, but optional. I.e. if reading fails, returns Nothing.
addReadParamOpt :: forall f out a addReadParamOpt :: forall f out a
. (Applicative f, Typeable a, Text.Read.Read a) . (Applicative f, Typeable a, Text.Read.Read a)
=> String => String -- ^ paramater name, for use in usage/help texts
-> Param a -> Param a -- ^ properties
-> CmdParser f out (Maybe a) -> CmdParser f out (Maybe a)
addReadParamOpt name par = addCmdPart desc parseF addReadParamOpt name par = addCmdPart desc parseF
where where
@ -92,6 +108,9 @@ addReadParamOpt name par = addCmdPart desc parseF
((x, []):_) -> Just (Just x, []) ((x, []):_) -> Just (Just x, [])
_ -> Just (Nothing, s) -- TODO: we could warn about a default.. _ -> 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 addStringParam
:: forall f out . (Applicative f) :: forall f out . (Applicative f)
=> String => String
@ -112,6 +131,8 @@ addStringParam name par = addCmdPartInp desc parseF
(s1:sR) -> Just (s1, InputArgs sR) (s1:sR) -> Just (s1, InputArgs sR)
[] -> _param_default par <&> \x -> (x, InputArgs args) [] -> _param_default par <&> \x -> (x, InputArgs args)
-- | Like 'addStringParam', but optional, I.e. succeeding with Nothing if
-- there is no remaining input.
addStringParamOpt addStringParamOpt
:: forall f out . (Applicative f) :: forall f out . (Applicative f)
=> String => String
@ -133,6 +154,8 @@ addStringParamOpt name par = addCmdPartInp desc parseF
[] -> Just (Nothing, InputArgs []) [] -> Just (Nothing, InputArgs [])
-- | Add a parameter that consumes _all_ remaining input. Typical usecase is
-- after a "--" as common in certain (unix?) commandline tools.
addRestOfInputStringParam addRestOfInputStringParam
:: forall f out . (Applicative f) :: forall f out . (Applicative f)
=> String => 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 module UI.Butcher.Monadic.Pretty
( ppUsage ( ppUsage
, ppUsageAt , ppUsageAt
, ppHelpShallow , ppHelpShallow
, ppUsageWithHelp
, ppPartDescUsage , ppPartDescUsage
, ppPartDescHeader , ppPartDescHeader
, ppUsageWithHelp
) )
where where
@ -32,11 +48,14 @@ import Text.PrettyPrint ( (<+>), ($$), ($+$) )
import Data.HList.ContainsType import Data.HList.ContainsType
import UI.Butcher.Monadic.Types import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Core import UI.Butcher.Monadic.Internal.Core
-- | ppUsage exampleDesc yields:
--
-- > playground [--short] NAME [version | help]
ppUsage :: CommandDesc a ppUsage :: CommandDesc a
-> PP.Doc -> PP.Doc
ppUsage (CommandDesc mParent _help _syn parts out children) = 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, _) -> subDoc = PP.fcat $ PP.punctuate (PP.text " | ") $ children <&> \(n, _) ->
PP.text 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 a -> PP.Doc
ppUsageWithHelp (CommandDesc mParent help _syn parts out children) = ppUsageWithHelp (CommandDesc mParent help _syn parts out children) =
pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc
@ -73,6 +98,11 @@ ppUsageWithHelp (CommandDesc mParent help _syn parts out children) =
Nothing -> PP.empty Nothing -> PP.empty
Just h -> PP.text ":" PP.<+> h Just h -> PP.text ":" PP.<+> h
-- | > ppUsageAt [] = ppUsage
--
-- fromJust $ ppUsageAt ["version"] exampleDesc yields:
--
-- > example version [--porcelain]
ppUsageAt :: [String] -- (sub)command sequence ppUsageAt :: [String] -- (sub)command sequence
-> CommandDesc a -> CommandDesc a
-> Maybe PP.Doc -> Maybe PP.Doc
@ -81,6 +111,24 @@ ppUsageAt strings desc =
[] -> Just $ ppUsage desc [] -> Just $ ppUsage desc
(s:sr) -> find ((s==) . fst) (_cmd_children desc) >>= ppUsageAt sr . snd (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 ppHelpShallow :: CommandDesc a
-> PP.Doc -> PP.Doc
ppHelpShallow desc@(CommandDesc mParent syn help parts _out _children) = 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] PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc]
++ go p ++ go p
-- | Internal helper; users probably won't need this.
ppPartDescUsage :: PartDesc -> PP.Doc ppPartDescUsage :: PartDesc -> PP.Doc
ppPartDescUsage = \case ppPartDescUsage = \case
PartLiteral s -> PP.text s PartLiteral s -> PP.text s
@ -160,6 +209,7 @@ ppPartDescUsage = \case
where where
rec = ppPartDescUsage rec = ppPartDescUsage
-- | Internal helper; users probably won't need this.
ppPartDescHeader :: PartDesc -> PP.Doc ppPartDescHeader :: PartDesc -> PP.Doc
ppPartDescHeader = \case ppPartDescHeader = \case
PartLiteral s -> PP.text s PartLiteral s -> PP.text s

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

@ -1,186 +1,20 @@
{-# LANGUAGE DeriveFunctor #-} -- this module only re-exports the appropriate user-facing stuff from the
{-# LANGUAGE ScopedTypeVariables #-} -- internal Types module.
{-# LANGUAGE ExistentialQuantification #-} -- | Types used in the butcher interface.
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MonadComprehensions #-}
module UI.Butcher.Monadic.Types module UI.Butcher.Monadic.Types
( CommandDesc(..) ( CommandDesc(..)
, cmd_mParent
, cmd_help
, cmd_synopsis
, cmd_parts
, cmd_out , cmd_out
, cmd_children
, emptyCommandDesc
, CmdParserF(..)
, CmdParser , CmdParser
, PartDesc(..)
, Input (..) , Input (..)
, ParsingError (..) , ParsingError (..)
, addSuggestion , PartDesc(..)
) )
where where
#include "prelude.inc" #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] import UI.Butcher.Monadic.Internal.Types
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"

240
srcinc/prelude.inc
View File

@ -28,63 +28,6 @@ import qualified System.Time.Extra
import qualified Data.Either.Combinators 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.Lazy
import qualified Control.Monad.Trans.MultiRWS.Strict import qualified Control.Monad.Trans.MultiRWS.Strict
import qualified Control.Monad.Trans.MultiReader import qualified Control.Monad.Trans.MultiReader
@ -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.Strict as MultiRWSS
import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL 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.Bifunctor
import qualified Data.Bits import qualified Data.Bits
import qualified Data.Bool import qualified Data.Bool
@ -172,90 +69,18 @@ import qualified Data.Maybe
import qualified Data.Monoid import qualified Data.Monoid
import qualified Data.Ord import qualified Data.Ord
import qualified Data.Proxy 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 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
import qualified Numeric.Natural import qualified Numeric.Natural
-- import qualified System.CPUTime
-- import qualified System.Console.GetOpt
import qualified System.Environment import qualified System.Environment
-- import qualified System.Exit
import qualified System.IO 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
-- import qualified Text.Read.Lex
import qualified Text.Show import qualified Text.Show
-- import qualified Text.Show.Functions
import qualified Unsafe.Coerce 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.Bool as Bool
import qualified Data.Char as Char 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.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 import qualified Control.Monad.Trans.Writer.Strict as WriterS
#if MIN_VERSION_base(4,9,0) #if MIN_VERSION_base(4,9,0)
@ -264,15 +89,9 @@ import qualified GHC.OldList as List
import qualified Data.List as List import qualified Data.List as List
#endif #endif
-- import qualified Text.Printf as Printf
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
-- import qualified Data.IntMap.Lazy as IntMapL
import qualified Data.IntMap.Strict as IntMapS import qualified Data.IntMap.Strict as IntMapS
-- import qualified Data.IntSet as IntSet
import qualified Data.Map as Map 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.Sequence as Seq
import qualified Data.Set as Set 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.State.Class as State.Class
import qualified Control.Monad.Writer.Class as Writer.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 as State
import qualified Control.Monad.Trans.State.Lazy as StateL import qualified Control.Monad.Trans.State.Lazy as StateL
import qualified Control.Monad.Trans.State.Strict as StateS 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 Data.Functor.Identity ( Identity(..) )
import Control.Concurrent.Chan ( Chan ) import Control.Concurrent.Chan ( Chan )
@ -571,57 +381,9 @@ import Control.Monad.Extra ( whenM
import Data.Tree ( Tree(..) import Data.Tree ( Tree(..)
) )
import Control.Monad.Trans.MultiRWS ( -- MultiRWST (..) import Control.Monad.Trans.MultiRWS ( MonadMultiReader(..)
-- , MultiRWSTNull
-- , MultiRWS
-- ,
MonadMultiReader(..)
, MonadMultiWriter(..) , MonadMultiWriter(..)
, MonadMultiState(..) , 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 import Control.Monad.Trans.MultiReader ( runMultiReaderTNil