butcher-1.3.3.2/ 0000755 0000000 0000000 00000000000 07346545000 011503 5 ustar 00 0000000 0000000 butcher-1.3.3.2/ChangeLog.md 0000755 0000000 0000000 00000004527 07346545000 013667 0 ustar 00 0000000 0000000 # Revision history for butcher
## 1.3.3.2 -- June 2020
* Support ghc-8.10
* Drop support for ghc < 8.4
* Fix a somewhat hidden issue in the cabal file
* Add support for building / testing via haskell.nix nixpkgs overlay
## 1.3.3.1 -- April 2020
* Fix a cabal file mistake
## 1.3.3.0 -- April 2020
* Fix bug with params with default when parsing from commandline
* Add the `descendDescTo` function
## 1.3.2.3 -- June 2019
* Fix broken build when using deque>=0.3
## 1.3.2.2 -- June 2019 (broken, disabled on hackage)
* Fix too-shallow descriptions on siblings for partial parses returned
for interactive usage
## 1.3.2.1 -- October 2018
* Adapt/Use latest version of `deque` to fix ghc-8.6 problems
## 1.3.2.0 -- October 2018
* Fix for simpleCompletion
* Expose some bindings that were forgotten in previous release
* Bounds fixed for ghc-8.6 (also via revision in 1.3.1.1)
## 1.3.1.1 -- April 2018
* Fixup version bound
## 1.3.1.0 -- April 2018
* Add/Expose two more functions: addAlternatives and varPartDesc
## 1.3.0.1 -- April 2018
* Support ghc-8.4
* Drop support for ghc<8
## 1.3.0.0 -- February 2018
* Experimental: Hidden commandparts (do not appear in help)
* Experimental: Bash completion
* Add addHelpCommandWith to support user-defined column count
* Fix help document printing (ribbons)
* Fix completion behaviour
## 1.2.1.0 -- November 2017
* Fix bug in 'ppUsageWithHelp'
* some utilities for interactive usage in new module
`UI.Butcher.Monadic.Interactive`
## 1.2.0.0 -- October 2017
* Rename some `Monadic.Param.*`, deprecate old versions.
- `addReadParam` -> `addParamRead`
- `addReadParamOpt` -> `addParamReadOpt`
- `addStringParam` -> `addParamString`
- `addStringParamOpt` -> `addParamStringOpt`
- `addStringParams` -> `addParamStrings`
- `addRestOfInputStringParam` -> `addParamRestOfInput`
* Add functions `addParamNoFlagString`, `addParamNoFlagStringOpt`,
`addParamNoFlagStrings`
* Fix flag parsing behaviour (ignore initial spaces)
## 1.1.1.0 -- October 2017
* Add `addNullCmd` function that descends into childcommand on an epsilon match
* Add `addStringParams` function that reads all remaining words
## 1.1.0.2 -- September 2017
* Improve 'usage' pretty-printing
## 1.1.0.1 -- August 2017
* Adapt for ghc-8.2
## 1.1.0.0 -- May 2017
* First version. Released on an unsuspecting world.
butcher-1.3.3.2/LICENSE 0000644 0000000 0000000 00000002772 07346545000 012520 0 ustar 00 0000000 0000000 Copyright (c) 2016, Lennart Spitzner
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Lennart Spitzner nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
butcher-1.3.3.2/README.md 0000755 0000000 0000000 00000017657 07346545000 013005 0 ustar 00 0000000 0000000 # butcher
#### Chops a command or program invocation into digestable pieces.
Similar to the `optparse-applicative` package, but less features,
more flexibility and more evil.
The main differences are:
* Provides a pure interface by default
* Exposes an evil monadic interface, which allows for much nicer binding of
command part results to some variable name.
In `optparse-applicative` you easily lose track of what field you are
modifying after the 5th `<*>` (admittedly, i think -XRecordWildCards
improves on that issue already.)
Evil, because you are not allowed to use the monad's full power in this
case, i.e. there is a constraint that is not statically enforced.
See below.
* The monadic interface allows much clearer definitions of commandparses
with (nested) subcommands. No pesky sum-types are necessary.
## Examples
The minimal example is
~~~~.hs
main = mainFromCmdParser $ addCmdImpl $ putStrLn "Hello, World!"
~~~~
But lets look at a more feature-complete example:
~~~~.hs
main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do
addCmdSynopsis "a simple butcher example program"
addCmdHelpStr "a very long help document"
addCmd "version" $ do
porcelain <- addSimpleBoolFlag "" ["porcelain"]
(flagHelpStr "print nothing but the numeric version")
addCmdHelpStr "prints the version of this program"
addCmdImpl $ putStrLn $ if porcelain
then "0.0.0.999"
else "example, version 0.0.0.999"
addCmd "help" $ addCmdImpl $ print $ ppHelpShallow helpDesc
short <- addSimpleBoolFlag "" ["short"]
(flagHelpStr "make the greeting short")
name <- addStringParam "NAME"
(paramHelpStr "your name, so you can be greeted properly")
addCmdImpl $ do
if short
then putStrLn $ "hi, " ++ name ++ "!"
else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!"
~~~~
Further:
- [Full description of the above example, including sample behaviour](example1.md)
- [Example of a pure usage of a CmdParser](example2.md)
- [Example of using a CmdParser on interactive input](example3.md)
- The [brittany](https://github.com/lspitzner/brittany) formatting tool is a
program that uses butcher for implementing its commandline interface. See
its [main module source](https://github.com/lspitzner/brittany/blob/master/src-brittany/Main.hs)
or [the config flag parser](https://github.com/lspitzner/brittany/blob/master/src/Language/Haskell/Brittany/Config.hs).
## The evil monadic interface
As long as you only use Applicative or (Kleisli) Arrow, you can use the
interface freely. When you use Monad, there is one rule: Whenever you read
any command-parts like in
~~~~
f <- addFlag ...
p <- addParam ...
~~~~
you are only allowed to use bindings bound thusly in any command's
implemenation, i.e. inside the parameter to `addCmdImpl`. You are _not_
allowed to force/inspect/patternmatch on them before that. _good_ usage is:
~~~~
addCmdImpl $ do
print x
print y
~~~~
while _bad_ would be
~~~~
f <- addFlag
when f $ do
p <- addParam
-- evil: the existence of the param `p`
-- depends on parse result for the flag `f`.
~~~~
That means that checking if a combination of flags is allowed must be done
after parsing. (But different commands and their subcommands (can) have
separate sets of flags.)
## (abstract) Package intentions
Consider a commandline invocation like "ghc -O -i src -Main.hs -o Main". This
package provides a way for the programmer to simultaneously define the
semantics of your program based on its arguments and retrieve documentation
for the user. More specifically, i had three goals in mind:
1. Straight-forward description of (sub)command and flag-specific behaviour
2. Extract understandable usage/help commandline documents/texts from that
descriptions, think of `ghc --help` or `stack init --help`.
3. Extract necessary information to compute commandline completion results
from any partial input. (This is not implemented to any serious degree.)
## Semantics
Basic elements of a command are flags, parameters and subcommands. These can
be composed in certain ways, i.e. flags can have a (or possibly multiple?)
parameters; parameters can be grouped into sequences, and commands can have
subcommands.
Commands are essentially `String -> Either ParseError out` where `out` can
be chosen by the user. It could for example be `IO ()`.
To allow more flexible composition, the parts of a command have the "classic"
parser's type: `String -> Maybe (p, String)` where `p` depends on the part.
Parse a prefix of the input and return something and the remaining input, or
fail with `Nothing`.
A command-parser contains a sequence of parts and then a number of subcommands
and/or some implementation.
### Commands and Child-Commands
- ~~~~ .hs
myParser :: CmdParser Identity Int ()
myParser = return ()
~~~~
input | `runCmdParserSimple input myParser`
----- | -------------
"" | Left "command has no implementation"
"x" | Left "error parsing arguments: could not parse input/unprocessed input at: \"x\"."
- ~~~~ .hs
myParser :: CmdParser Identity Int ()
myParser = do
addCmd "foo" $ addCmdImpl 2
addCmd "bar" $ addCmdImpl 3
addCmd "noimpl" $ pure ()
addCmd "twoimpls" $ do
addCmdImpl 4
addCmdImpl 5
addCmdImpl 1
~~~~
input | `runCmdParserSimple input myParser`
----- | -------------
"" | Right 1
"x" | Left "error parsing arguments: could not parse input/unprocessed input at: \"x\"."
"foo" | Right 2
"bar" | Right 3
"foo bar" | Left "error parsing arguments: could not parse input/unprocessed input at: \"bar\"."
"noimpl" | Left "command has no implementation"
"twoimpls" | Right 5
### Flags
- without any annotation, no reodering is allowed and the flags must appear in order:
~~~~ .hs
myParser :: CmdParser Identity (Bool, Int, Int) ()
myParser = do
b <- addSimpleBoolFlag "b" [] mempty
c <- addSimpleCountFlag "c" [] mempty
i <- addFlagReadParam "i" [] "number" (flagDefault 42)
addCmdImpl $ (b, c, i)
~~~~
input | `runCmdParserSimple input myParser`
----- | -------------
"" | Right (False,0,42)
"-b -c -i 3" | Right (True,1,3)
"-c -b" | Left "error parsing arguments: could not parse input/unprocessed input at: \"-b\"."
"-c -c -c" | Right (False,3,42)
- this time with reordering; also "j" has no default and thus becomes mandatory, still it must not
occur more than once:
~~~~ .hs
myParser :: CmdParser Identity (Bool, Int, Int, Int) ()
myParser = do
reorderStart -- this time with reordering
b <- addSimpleBoolFlag "b" [] mempty
c <- addSimpleCountFlag "c" [] mempty
i <- addFlagReadParam "i" [] "number" (flagDefault 42)
j <- addFlagReadParam "j" [] "number" mempty -- no default: flag mandatory
reorderStop
addCmdImpl $ (b, c, i, j)
~~~~
input | `runCmdParserSimple input myParser`
---------------------------- | -------------
"-b" | Left "error parsing arguments:
could not parse expected input -j number with remaining input:
InputString \"\" at the end of input."
"-j=5" | Right (False,0,42,5)
"-c -b -b -j=5" | Right (True,1,42,5)
"-j=5 -i=1 -c -b" | Right (True,1,1,5)
"-c -j=5 -c -i=5 -c" | Right (False,3,5,5)
"-j=5 -j=5" | Left "error parsing arguments: could not parse input/unprocessed input at: \"-j=5\"."
- addFlagReadParams - these can occur more than once. Note that defaults have slightly different semantics:
~~~~ .hs
myParser :: CmdParser Identity (Int, [Int]) ()
myParser = do
reorderStart
i <- addFlagReadParam "i" [] "number" (flagDefault 42)
js <- addFlagReadParams "j" [] "number" (flagDefault 50)
reorderStop
addCmdImpl $ (i, js)
~~~~
input | `runCmdParserSimple input myParser`
---------------------------- | -------------
"" | Right (42,[])
"-i" | Left "error parsing arguments: could not parse input/unprocessed input at: \"-i\"."
"-j=1 -j=2 -j=3" | Right (42,[1,2,3])
"-j" | Right (42,[50])
"-i=1" | Right (1,[])
"-j=2" | Right (42,[2])
"-j=2 -i=1 -j=3" | Right (1,[2,3])
### Params
TODO
butcher-1.3.3.2/Setup.hs 0000644 0000000 0000000 00000000056 07346545000 013140 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
butcher-1.3.3.2/butcher.cabal 0000644 0000000 0000000 00000006116 07346545000 014127 0 ustar 00 0000000 0000000 name: butcher
version: 1.3.3.2
synopsis: Chops a command or program invocation into digestable pieces.
description: See the (it is properly formatted on github).
license: BSD3
license-file: LICENSE
author: Lennart Spitzner
maintainer: Lennart Spitzner
copyright: Copyright (C) 2016-2020 Lennart Spitzner
category: UI
build-type: Simple
Stability: experimental
extra-source-files: {
ChangeLog.md
srcinc/prelude.inc
README.md
}
cabal-version: >=1.10
homepage: https://github.com/lspitzner/butcher/
bug-reports: https://github.com/lspitzner/butcher/issues
source-repository head {
type: git
location: https://github.com/lspitzner/butcher.git
}
library
exposed-modules: UI.Butcher.Monadic.Types
UI.Butcher.Monadic
UI.Butcher.Monadic.Command
UI.Butcher.Monadic.Param
UI.Butcher.Monadic.Flag
UI.Butcher.Monadic.Pretty
UI.Butcher.Monadic.IO
UI.Butcher.Monadic.Interactive
UI.Butcher.Monadic.BuiltinCommands
other-modules: UI.Butcher.Monadic.Internal.Types
UI.Butcher.Monadic.Internal.Core
build-depends:
{ base >=4.11 && <4.15
, free < 5.2
, unsafe < 0.1
, microlens <0.5
, microlens-th <0.5
, multistate >=0.7 && <0.9
, pretty <1.2
, containers <0.7
, transformers <0.6
, mtl <2.3
, extra <1.8
, void <0.8
, bifunctors <5.6
, deque >=0.3 && <0.5
}
hs-source-dirs: src
default-language: Haskell2010
default-extensions: {
CPP
NoImplicitPrelude
GADTs
FlexibleContexts
FlexibleInstances
ScopedTypeVariables
MonadComprehensions
LambdaCase
MultiWayIf
KindSignatures
}
other-extensions: {
DeriveFunctor
ExistentialQuantification
GeneralizedNewtypeDeriving
StandaloneDeriving
DataKinds
TypeOperators
TemplateHaskell
}
ghc-options: {
-Wall
-Wcompat
-fno-spec-constr
-fno-warn-unused-imports
-fno-warn-orphans
}
include-dirs:
srcinc
test-suite tests
type: exitcode-stdio-1.0
default-language: Haskell2010
build-depends:
{ base <999
, butcher
, free
, unsafe
, microlens
, microlens-th
, multistate
, pretty
, containers
, transformers
, mtl
, extra
, deque
, hspec
}
ghc-options: -Wall -rtsopts
main-is: TestMain.hs
other-modules:
hs-source-dirs: src-tests
include-dirs:
srcinc
default-extensions: {
CPP
NoImplicitPrelude
GADTs
FlexibleContexts
FlexibleInstances
ScopedTypeVariables
MonadComprehensions
LambdaCase
MultiWayIf
KindSignatures
}
ghc-options: {
-Wall
-fno-spec-constr
-fno-warn-unused-imports
-fno-warn-orphans
}
butcher-1.3.3.2/src-tests/ 0000755 0000000 0000000 00000000000 07346545000 013432 5 ustar 00 0000000 0000000 butcher-1.3.3.2/src-tests/TestMain.hs 0000644 0000000 0000000 00000026257 07346545000 015526 0 ustar 00 0000000 0000000 module Main where
#include "prelude.inc"
import Test.Hspec
-- import NeatInterpolation
import UI.Butcher.Monadic
import UI.Butcher.Monadic.Types
import UI.Butcher.Monadic.Interactive
main :: IO ()
main = hspec $ tests
tests :: Spec
tests = do
describe "checkTests" checkTests
describe "simpleParseTest" simpleParseTest
describe "simpleRunTest" simpleRunTest
checkTests :: Spec
checkTests = do
before_ pending $ it "check001" $ True `shouldBe` True
simpleParseTest :: Spec
simpleParseTest = do
it "failed parse 001" $ runCmdParser Nothing (InputString "foo") testCmd1
`shouldSatisfy` Data.Either.isLeft . snd
it "toplevel" $ (testParse testCmd1 "" >>= _cmd_out)
`shouldSatisfy` Maybe.isNothing
it "hasImpl 001" $ (testParse testCmd1 "abc" >>= _cmd_out)
`shouldSatisfy` Maybe.isJust
it "hasImpl 002" $ (testParse testCmd1 "def" >>= _cmd_out)
`shouldSatisfy` Maybe.isJust
simpleRunTest :: Spec
simpleRunTest = do
it "failed run" $ testRun testCmd1 "" `shouldBe` Right Nothing
describe "no reordering" $ do
it "cmd 1" $ testRun testCmd1 "abc" `shouldBe` Right (Just 100)
it "cmd 2" $ testRun testCmd1 "def" `shouldBe` Right (Just 200)
it "flag 1" $ testRun testCmd1 "abc -f" `shouldBe` Right (Just 101)
it "flag 2" $ testRun testCmd1 "abc --flong" `shouldBe` Right (Just 101)
it "flag 3" $ testRun testCmd1 "abc -f -f" `shouldBe` Right (Just 101)
it "flag 4" $ testRun testCmd1 "abc -f -g" `shouldBe` Right (Just 103)
it "flag 5" $ testRun testCmd1 "abc -f -g -f" `shouldSatisfy` Data.Either.isLeft -- no reordering
it "flag 6" $ testRun testCmd1 "abc -g -f" `shouldSatisfy` Data.Either.isLeft -- no reordering
it "flag 7" $ testRun testCmd1 "abc -g -g" `shouldBe` Right (Just 102)
describe "with reordering" $ do
it "cmd 1" $ testRun testCmd2 "abc" `shouldBe` Right (Just 100)
it "cmd 2" $ testRun testCmd2 "def" `shouldBe` Right (Just 200)
it "flag 1" $ testRun testCmd2 "abc -f" `shouldBe` Right (Just 101)
it "flag 2" $ testRun testCmd2 "abc --flong" `shouldBe` Right (Just 101)
it "flag 3" $ testRun testCmd2 "abc -f -f" `shouldBe` Right (Just 101)
it "flag 4" $ testRun testCmd2 "abc -f -g" `shouldBe` Right (Just 103)
it "flag 5" $ testRun testCmd2 "abc -f -g -f" `shouldBe` Right (Just 103)
it "flag 6" $ testRun testCmd2 "abc -g -f" `shouldBe` Right (Just 103)
it "flag 7" $ testRun testCmd2 "abc -g -g" `shouldBe` Right (Just 102)
describe "with action" $ do
it "flag 1" $ testRunA testCmd3 "abc" `shouldBe` Right 0
it "flag 2" $ testRunA testCmd3 "abc -f" `shouldBe` Right 1
it "flag 3" $ testRunA testCmd3 "abc -g" `shouldBe` Right 2
it "flag 4" $ testRunA testCmd3 "abc -f -g" `shouldBe` Right 3
it "flag 5" $ testRunA testCmd3 "abc -g -f" `shouldBe` Right 3
describe "separated children" $ do
it "case 1" $ testRun testCmd4 "a aa" `shouldBe` Right (Just 1)
it "case 2" $ testRun testCmd4 "a ab" `shouldBe` Right (Just 2)
it "case 3" $ testRun testCmd4 "b ba" `shouldBe` Right (Just 3)
it "case 4" $ testRun testCmd4 "b bb" `shouldBe` Right (Just 4)
it "doc" $ show (ppHelpShallow (getDoc "" testCmd4)) `shouldBe`
List.unlines
[ "NAME"
, ""
, " test"
, ""
, "USAGE"
, ""
, " test a | b"
]
it "doc" $ show (ppHelpShallow (getDoc "a" testCmd4)) `shouldBe`
List.unlines
[ "NAME"
, ""
, " test a"
, ""
, "USAGE"
, ""
, " test a aa | ab"
]
describe "read flags" $ do
it "flag 1" $ testRun testCmd5 "abc" `shouldBe` Right (Just 10)
it "flag 2" $ testRun testCmd5 "abc -f 2" `shouldBe` Right (Just 2)
it "flag 3" $ testRun testCmd5 "abc --flag 3" `shouldBe` Right (Just 3)
it "flag 4" $ testRun testCmd5 "abc -f=4" `shouldBe` Right (Just 4)
it "flag 5" $ testRun testCmd5 "abc --flag=5" `shouldBe` Right (Just 5)
it "flag 6" $ testRun testCmd5 "abc -f" `shouldSatisfy` Data.Either.isLeft
it "flag 6" $ testRun testCmd5 "abc -flag 0" `shouldSatisfy` Data.Either.isLeft
it "flag 6" $ testRun testCmd5 "abc --f 0" `shouldSatisfy` Data.Either.isLeft
describe "addParamStrings" $ do
it "case 1" $ testRun' testCmd6 "" `shouldBe` Right (Just ([], 0))
it "case 2" $ testRun' testCmd6 "-f" `shouldBe` Right (Just ([], 1))
it "case 3" $ testRun' testCmd6 "abc" `shouldBe` Right (Just (["abc"], 0))
it "case 4" $ testRun' testCmd6 "abc def" `shouldBe` Right (Just (["abc", "def"], 0))
it "case 5" $ testRun' testCmd6 "-g abc def" `shouldBe` Right (Just (["abc", "def"], 2))
it "case 6" $ testRun' testCmd6 "-f -g def" `shouldBe` Right (Just (["def"], 3))
describe "addParamNoFlagStrings" $ do
it "case 1" $ testRun' testCmd7 "" `shouldBe` Right (Just ([], 0))
it "case 2" $ testRun' testCmd7 "-f" `shouldBe` Right (Just ([], 1))
it "case 3" $ testRun' testCmd7 "abc" `shouldBe` Right (Just (["abc"], 0))
it "case 4" $ testRun' testCmd7 "abc -f" `shouldBe` Right (Just (["abc"], 1))
it "case 5" $ testRun' testCmd7 "-g abc -f" `shouldBe` Right (Just (["abc"], 3))
it "case 6" $ testRun' testCmd7 "abc -g def" `shouldBe` Right (Just (["abc", "def"], 2))
describe "defaultParam" $ do
it "case 1" $ testRun testCmdParam "" `shouldSatisfy` Data.Either.isLeft
it "case 2" $ testRun testCmdParam "n" `shouldSatisfy` Data.Either.isLeft
it "case 3" $ testRun testCmdParam "y" `shouldSatisfy` Data.Either.isLeft
it "case 4" $ testRun testCmdParam "False n" `shouldBe` Right (Just 110)
it "case 5" $ testRun testCmdParam "False y" `shouldBe` Right (Just 310)
it "case 6" $ testRun testCmdParam "True n" `shouldBe` Right (Just 1110)
it "case 7" $ testRun testCmdParam "True y" `shouldBe` Right (Just 1310)
it "case 8" $ testRun testCmdParam "1 False y" `shouldBe` Right (Just 301)
it "case 9" $ testRun testCmdParam "1 False y def" `shouldBe` Right (Just 201)
it "case 10" $ testRun testCmdParam "1 False 2 y def" `shouldBe` Right (Just 203)
it "case 11" $ testRun testCmdParam "1 True 2 y def" `shouldBe` Right (Just 1203)
describe "completions" $ do
it "case 1" $ testCompletion completionTestCmd "" `shouldBe` ""
it "case 2" $ testCompletion completionTestCmd "a" `shouldBe` "bc"
it "case 3" $ testCompletion completionTestCmd "abc" `shouldBe` ""
it "case 4" $ testCompletion completionTestCmd "abc " `shouldBe` "-"
it "case 5" $ testCompletion completionTestCmd "abc -" `shouldBe` ""
it "case 6" $ testCompletion completionTestCmd "abc --" `shouldBe` "flag"
it "case 7" $ testCompletion completionTestCmd "abc -f" `shouldBe` ""
it "case 8" $ testCompletion completionTestCmd "abcd" `shouldBe` "ef"
it "case 9" $ testCompletion completionTestCmd "gh" `shouldBe` "i"
it "case 10" $ testCompletion completionTestCmd "ghi" `shouldBe` ""
it "case 11" $ testCompletion completionTestCmd "ghi " `shouldBe` "jkl"
testCmd1 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
testCmd1 = do
addCmd "abc" $ do
f <- addSimpleBoolFlag "f" ["flong"] mempty
g <- addSimpleBoolFlag "g" ["glong"] mempty
addCmdImpl $ do
when f $ WriterS.tell 1
when g $ WriterS.tell 2
WriterS.tell 100
addCmd "def" $ do
addCmdImpl $ do
WriterS.tell 200
testCmd2 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
testCmd2 = do
addCmd "abc" $ do
reorderStart
f <- addSimpleBoolFlag "f" ["flong"] mempty
g <- addSimpleBoolFlag "g" ["glong"] mempty
reorderStop
addCmdImpl $ do
when f $ WriterS.tell 1
when g $ WriterS.tell 2
WriterS.tell 100
addCmd "def" $ do
addCmdImpl $ do
WriterS.tell 200
testCmd3 :: CmdParser (StateS.State Int) () ()
testCmd3 = do
addCmd "abc" $ do
reorderStart
addSimpleFlagA "f" ["flong"] mempty (StateS.modify (+1))
addSimpleFlagA "g" ["glong"] mempty (StateS.modify (+2))
reorderStop
addCmdImpl ()
addCmd "def" $ do
addCmdImpl ()
testCmd4 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
testCmd4 = do
addCmd "a" $ do
addCmd "aa" $ do
addCmdImpl $ WriterS.tell 1
addCmd "b" $ do
addCmd "bb" $ do
addCmdImpl $ WriterS.tell 4
addCmd "a" $ do
addCmd "ab" $ do
addCmdImpl $ WriterS.tell 2
addCmd "b" $ do
addCmd "ba" $ do
addCmdImpl $ WriterS.tell 3
testCmd5 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
testCmd5 = do
addCmd "abc" $ do
x <- addFlagReadParam "f" ["flag"] "flag" (flagDefault (10::Int))
addCmdImpl $ WriterS.tell (Sum x)
testCmd6 :: CmdParser Identity (WriterS.Writer (Sum Int) [String]) ()
testCmd6 = do
f <- addSimpleBoolFlag "f" ["flong"] mempty
g <- addSimpleBoolFlag "g" ["glong"] mempty
args <- addParamStrings "ARGS" mempty
addCmdImpl $ do
when f $ WriterS.tell 1
when g $ WriterS.tell 2
pure args
testCmd7 :: CmdParser Identity (WriterS.Writer (Sum Int) [String]) ()
testCmd7 = do
reorderStart
f <- addSimpleBoolFlag "f" ["flong"] mempty
g <- addSimpleBoolFlag "g" ["glong"] mempty
args <- addParamNoFlagStrings "ARGS" mempty
reorderStop
addCmdImpl $ do
when f $ WriterS.tell 1
when g $ WriterS.tell 2
pure args
testCmdParam :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
testCmdParam = do
p :: Int <- addParamRead "INT" (paramDefault 10)
b <- addParamRead "MANDR" mempty
r <- addParamReadOpt "MAY1" (paramDefault 20)
s <- addParamString "MAND" mempty
q <- addParamString "STR" (paramDefault "abc")
addCmdImpl $ do
WriterS.tell (Sum p)
when (q=="abc") $ WriterS.tell 100
r `forM_` (WriterS.tell . Sum)
when b $ WriterS.tell $ Sum 1000
when (s=="y") $ WriterS.tell 200
pure ()
completionTestCmd :: CmdParser Identity () ()
completionTestCmd = do
addCmd "abc" $ do
_ <- addSimpleBoolFlag "f" ["flag"] mempty
addCmdImpl ()
addCmd "abcdef" $ do
_ <- addSimpleBoolFlag "f" ["flag"] mempty
addCmdImpl ()
addCmd "ghi" $ do
addCmd "jkl" $ do
addCmdImpl ()
testCompletion :: CmdParser Identity a () -> String -> String
testCompletion p inp = case runCmdParserExt Nothing (InputString inp) p of
(cDesc, InputString cRest, _) -> simpleCompletion inp cDesc cRest
_ -> error "wut"
testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out)
testParse cmd s = either (const Nothing) Just
$ snd
$ runCmdParser Nothing (InputString s) cmd
testRun :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () -> String -> Either ParsingError (Maybe Int)
testRun cmd s = fmap (fmap (getSum . WriterS.execWriter) . _cmd_out)
$ snd
$ runCmdParser Nothing (InputString s) cmd
testRun' :: CmdParser Identity (WriterS.Writer (Sum Int) a) () -> String -> Either ParsingError (Maybe (a, Int))
testRun' cmd s =
fmap (fmap (fmap getSum . WriterS.runWriter) . _cmd_out) $ snd $ runCmdParser
Nothing
(InputString s)
cmd
testRunA :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError Int
testRunA cmd str = (\((_, e), s) -> e $> s)
$ flip StateS.runState (0::Int)
$ runCmdParserA Nothing (InputString str) cmd
getDoc :: String -> CmdParser Identity out () -> CommandDesc ()
getDoc s = fst . runCmdParser (Just "test") (InputString s)
butcher-1.3.3.2/src/UI/Butcher/ 0000755 0000000 0000000 00000000000 07346545000 014203 5 ustar 00 0000000 0000000 butcher-1.3.3.2/src/UI/Butcher/Monadic.hs 0000644 0000000 0000000 00000012552 07346545000 016116 0 ustar 00 0000000 0000000 -- | Reexports of everything that is exposed in the submodules.
module UI.Butcher.Monadic
( -- * Types
Input (..)
, CmdParser
, ParsingError (..)
, CommandDesc(_cmd_out)
, cmd_out
, -- * Run or Check CmdParsers
runCmdParserSimple
, 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
-- * Utilities for interactive feedback of commandlines (completions etc.)
, module UI.Butcher.Monadic.Interactive
-- , cmds
-- , sample
-- , test
-- , test2
-- , test3
-- * Builtin commands
, addHelpCommand
, addHelpCommand2
, addHelpCommandWith
, addButcherDebugCommand
, addShellCompletionCommand
, addShellCompletionCommand'
-- * Advanced usage
, mapOut
, emptyCommandDesc
, Visibility (..)
)
where
#include "prelude.inc"
import UI.Butcher.Monadic.Types
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Command
import UI.Butcher.Monadic.BuiltinCommands
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Monadic.Pretty
import UI.Butcher.Monadic.IO
import UI.Butcher.Monadic.Interactive
import qualified Text.PrettyPrint as PP
#ifdef HLINT
{-# ANN module "HLint: ignore Use import/export shortcut" #-}
#endif
-- | Like 'runCmdParser', but with one additional twist: You get access
-- to a knot-tied complete CommandDesc for this full command. Useful in
-- combination with 'UI.Butcher.Monadic.BuiltinCommands.addHelpCommand'.
--
-- Note that the @CommandDesc ()@ in the output is _not_ the same value as the
-- parameter passed to the parser function: The output value contains a more
-- "shallow" description. This is more efficient for complex CmdParsers when
-- used interactively, because non-relevant parts of the CmdParser are not
-- traversed unless the parser function argument is forced.
runCmdParserWithHelpDesc
:: Maybe String -- ^ program name to be used for the top-level @CommandDesc@
-> Input -- ^ input to be processed
-> (CommandDesc () -> CmdParser Identity out ()) -- ^ parser to use
-> (CommandDesc (), Either ParsingError (CommandDesc out))
runCmdParserWithHelpDesc mProgName input cmdF =
let (checkResult, fullDesc)
-- knot-tying at its finest..
= ( checkCmdParser mProgName (cmdF fullDesc)
, either (const emptyCommandDesc) id $ checkResult
)
in runCmdParser mProgName input (cmdF fullDesc)
-- | Wrapper around 'runCmdParser' for very simple usage: Accept a @String@
-- input and return only the output from the parser, or a plain error string
-- on failure.
runCmdParserSimple :: String -> CmdParser Identity out () -> Either String out
runCmdParserSimple s p = case snd $ runCmdParser Nothing (InputString s) p of
Left e -> Left $ parsingErrorString e
Right desc ->
maybe (Left "command has no implementation") Right $ _cmd_out desc
--------------------------------------
-- all below is for testing purposes
--------------------------------------
_cmds :: CmdParser Identity (IO ()) ()
_cmds = do
addCmd "echo" $ do
addCmdHelpStr "print its parameter to output"
str <- addParamRead "STRING" (paramHelpStr "the string to print")
addCmdImpl $ do
putStrLn str
addCmd "hello" $ do
addCmdHelpStr "greet the user"
reorderStart
short <- addSimpleBoolFlag "" ["short"] mempty
name <- addParamRead "NAME" (paramHelpStr "your name, so you can be greeted properly"
<> paramDefault "user")
reorderStop
addCmdImpl $ do
if short
then putStrLn $ "hi, " ++ name ++ "!"
else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!"
addCmd "foo" $ do
addCmdHelpStr "foo"
desc <- peekCmdDesc
addCmdImpl $ do
putStrLn "foo"
print $ ppHelpShallow desc
addCmd "help" $ do
desc <- peekCmdDesc
addCmdImpl $ do
print $ ppHelpShallow $ maybe undefined snd (_cmd_mParent desc)
data Sample = Sample
{ _hello :: Int
, _s1 :: String
, _s2 :: String
, _quiet :: Bool
}
deriving Show
-- sample :: OPA.Parser Sample
-- sample = Sample
-- <$> OPA.option OPA.auto
-- ( OPA.long "hello"
-- <> OPA.metavar "TARGET"
-- <> OPA.help "Target for the greeting" )
-- <*> OPA.strArgument (OPA.metavar "S1")
-- <*> OPA.strArgument (OPA.metavar "S2")
-- <*> OPA.switch
-- ( OPA.long "quiet"
-- <> OPA.help "Whether to be quiet" )
--
-- test :: String -> OPA.ParserResult Sample
-- test s = OPA.execParserPure OPA.defaultPrefs (OPA.ParserInfo sample True mempty mempty mempty (-13) True) (List.words s)
_test2 :: IO ()
_test2 = case checkCmdParser (Just "butcher") _cmds of
Left e -> putStrLn $ "LEFT: " ++ e
Right desc -> do
print $ ppUsage desc
print $ maybe undefined id $ ppUsageAt ["hello"] desc
_test3 :: String -> IO ()
_test3 s = case runCmdParser (Just "butcher") (InputString s) _cmds of
(desc, Left e) -> do
print e
print $ ppHelpShallow desc
_cmd_mParent desc `forM_` \(_, d) -> do
print $ ppUsage d
(desc, Right out) -> do
case _cmd_out out of
Nothing -> do
putStrLn "command is missing implementation!"
print $ ppHelpShallow desc
Just f -> f
butcher-1.3.3.2/src/UI/Butcher/Monadic/ 0000755 0000000 0000000 00000000000 07346545000 015555 5 ustar 00 0000000 0000000 butcher-1.3.3.2/src/UI/Butcher/Monadic/BuiltinCommands.hs 0000644 0000000 0000000 00000014067 07346545000 021211 0 ustar 00 0000000 0000000 -- | Some CmdParser actions that add predefined commands.
module UI.Butcher.Monadic.BuiltinCommands
( addHelpCommand
, addHelpCommand2
, addHelpCommandWith
, addHelpCommandShallow
, addButcherDebugCommand
, addShellCompletionCommand
, addShellCompletionCommand'
)
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 UI.Butcher.Monadic.Interactive
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 = addHelpCommandWith
-- > (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpShallow)
addHelpCommand :: Applicative f => CommandDesc a -> CmdParser f (IO ()) ()
addHelpCommand = addHelpCommandWith
(pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpShallow)
-- | Adds a proper full help command. In contrast to 'addHelpCommand',
-- this version is a bit more verbose about available subcommands as it
-- includes their synopses.
--
-- To obtain the 'CommandDesc' value, see
-- 'UI.Butcher.Monadic.cmdRunParserWithHelpDesc' or
-- 'UI.Butcher.Monadic.IO.mainFromCmdParserWithHelpDesc'.
--
-- > addHelpCommand2 = addHelpCommandWith
-- > (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpDepthOne)
addHelpCommand2 :: Applicative f => CommandDesc a -> CmdParser f (IO ()) ()
addHelpCommand2 = addHelpCommandWith
(pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpDepthOne)
-- | Adds a proper full help command, using the specified function to turn
-- the relevant subcommand's 'CommandDesc' into a String.
addHelpCommandWith
:: Applicative f
=> (CommandDesc a -> IO String)
-> CommandDesc a
-> CmdParser f (IO ()) ()
addHelpCommandWith f desc = addCmd "help" $ do
addCmdSynopsis "print help about this command"
rest <- addParamRestOfInput "SUBCOMMAND(s)" mempty
addCmdImpl $ do
let restWords = List.words rest
let
descent :: [String] -> CommandDesc a -> CommandDesc a
descent [] curDesc = curDesc
descent (w:wr) curDesc =
case
List.lookup (Just w) $ Data.Foldable.toList $ _cmd_children curDesc
of
Nothing -> curDesc
Just child -> descent wr child
s <- f $ descent restWords desc
putStrLn s
-- | 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 <- addParamRestOfInput "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)
-- | Adds the "completion" command and several subcommands.
--
-- This command can be used in the following manner:
--
-- > $ source <(foo completion bash-script foo)
addShellCompletionCommand
:: CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
addShellCompletionCommand mainCmdParser = do
addCmdHidden "completion" $ do
addCmdSynopsis "utilites to enable bash-completion"
addCmd "bash-script" $ do
addCmdSynopsis "generate a bash script for completion functionality"
exeName <- addParamString "EXENAME" mempty
addCmdImpl $ do
putStr $ completionScriptBash exeName
addCmd "bash-gen" $ do
addCmdSynopsis
"generate possible completions for given input arguments"
rest <- addParamRestOfInputRaw "REALCOMMAND" mempty
addCmdImpl $ do
let (cdesc, remaining, _result) =
runCmdParserExt Nothing rest mainCmdParser
let
compls = shellCompletionWords (inputString rest)
cdesc
(inputString remaining)
let lastWord =
reverse $ takeWhile (not . Char.isSpace) $ reverse $ inputString
rest
putStrLn $ List.unlines $ compls <&> \case
CompletionString s -> s
CompletionFile -> "$(compgen -f -- " ++ lastWord ++ ")"
CompletionDirectory -> "$(compgen -d -- " ++ lastWord ++ ")"
where
inputString (InputString s ) = s
inputString (InputArgs as) = List.unwords as
-- | Adds the "completion" command and several subcommands
--
-- This command can be used in the following manner:
--
-- > $ source <(foo completion bash-script foo)
addShellCompletionCommand'
:: (CommandDesc out -> CmdParser Identity (IO ()) ())
-> CmdParser Identity (IO ()) ()
addShellCompletionCommand' f = addShellCompletionCommand (f emptyCommandDesc)
completionScriptBash :: String -> String
completionScriptBash exeName =
List.unlines
$ [ "function _" ++ exeName ++ "()"
, "{"
, " local IFS=$'\\n'"
, " COMPREPLY=()"
, " local result=$("
++ exeName
++ " completion bash-gen \"${COMP_WORDS[@]:1}\")"
, " for r in ${result[@]}; do"
, " local IFS=$'\\n '"
, " for s in $(eval echo ${r}); do"
, " COMPREPLY+=(${s})"
, " done"
, " done"
, "}"
, "complete -F _" ++ exeName ++ " " ++ exeName
]
butcher-1.3.3.2/src/UI/Butcher/Monadic/Command.hs 0000644 0000000 0000000 00000005130 07346545000 017466 0 ustar 00 0000000 0000000 -- 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
, addCmdHidden
, addNullCmd
, addCmdImpl
, addCmdSynopsis
, addCmdHelp
, addCmdHelpStr
, reorderStart
, reorderStop
, withReorder
, peekCmdDesc
, peekInput
-- * Building CmdParsers - myprog -v --input PATH
, module UI.Butcher.Monadic.Flag
-- * Building CmdParsers - myprog SOME_INT
, module UI.Butcher.Monadic.Param
-- * Low-level part functions
, addCmdPart
, addCmdPartMany
, addCmdPartInp
, addCmdPartManyInp
, addAlternatives
, ManyUpperBound (..)
, varPartDesc
)
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
-- | Safe wrapper around 'reorderStart'/'reorderStop' for cases where reducing
-- to a single binding is possible/preferable.
withReorder :: CmdParser f out a -> CmdParser f out a
withReorder x = reorderStart *> x <* reorderStop
butcher-1.3.3.2/src/UI/Butcher/Monadic/Flag.hs 0000644 0000000 0000000 00000041227 07346545000 016770 0 ustar 00 0000000 0000000 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ViewPatterns #-}
-- | Flags are arguments to your current command that are prefixed with "-" or
-- "--", for example "-v" or "--verbose". These flags can have zero or one
-- argument. (Butcher internally has more general concept of "CmdPart" that
-- could handle any number of arguments, so take this as what this module aims
-- to provide, not what you could theoretically implement on top of butcher).
-- Note that the current implementation only accepts "--foo param" but not
-- "--foo=param". Someone really ought to implement support for the latter
-- at some point :)
module UI.Butcher.Monadic.Flag
( Flag(..)
, flagHelp
, flagHelpStr
, flagDefault
, flagHidden
, addSimpleBoolFlag
, addSimpleCountFlag
, addSimpleFlagA
, addFlagReadParam
, addFlagReadParams
-- , addFlagReadParamA
, addFlagStringParam
, addFlagStringParams
-- , addFlagStringParamA
)
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 Data.List.Extra ( firstJust )
-- TODO: perhaps move this to Types module and refactor all code to use it
newtype InpParseString a = InpParseString (StateS.StateT String Maybe a)
deriving (Functor, Applicative, Monad, State.Class.MonadState String, Alternative, MonadPlus)
runInpParseString :: String -> InpParseString a -> Maybe (a, String)
runInpParseString s (InpParseString m) = StateS.runStateT m s
pExpect :: String -> InpParseString ()
pExpect s = InpParseString $ do
inp <- StateS.get
case List.stripPrefix s inp of
Nothing -> mzero
Just rest -> StateS.put rest
pExpectEof :: InpParseString ()
pExpectEof =
InpParseString $ StateS.get >>= \inp -> if null inp then pure () else mzero
-- pDropSpace :: InpParseString ()
-- pDropSpace = InpParseString $ StateS.modify (dropWhile (==' '))
pOption :: InpParseString () -> InpParseString ()
pOption m = m <|> return ()
-- | flag-description monoid. You probably won't need to use the constructor;
-- mzero or any (<>) of flag(Help|Default) works well.
data Flag p = Flag
{ _flag_help :: Maybe PP.Doc
, _flag_default :: Maybe p
, _flag_visibility :: Visibility
}
appendFlag :: Flag p -> Flag p -> Flag p
appendFlag (Flag a1 b1 c1) (Flag a2 b2 c2) = Flag (a1 <|> a2)
(b1 <|> b2)
(appVis c1 c2)
where
appVis Visible Visible = Visible
appVis _ _ = Hidden
instance Semigroup (Flag p) where
(<>) = appendFlag
instance Monoid (Flag p) where
mempty = Flag Nothing Nothing Visible
mappend = (<>)
-- | Create a 'Flag' with just a help text.
flagHelp :: PP.Doc -> Flag p
flagHelp h = mempty { _flag_help = Just h }
-- | Create a 'Flag' with just a help text.
flagHelpStr :: String -> Flag p
flagHelpStr s =
mempty { _flag_help = Just $ PP.fsep $ fmap PP.text $ List.words s }
-- | Create a 'Flag' with just a default value.
flagDefault :: p -> Flag p
flagDefault d = mempty { _flag_default = Just d }
-- | Create a 'Flag' marked as hidden. Similar to hidden commands, hidden
-- flags will not included in pretty-printing (help, usage etc.)
--
-- This feature is not well tested yet.
flagHidden :: Flag p
flagHidden = mempty { _flag_visibility = Hidden }
wrapHidden :: Flag p -> PartDesc -> PartDesc
wrapHidden f = case _flag_visibility f of
Visible -> id
Hidden -> PartHidden
-- | A no-parameter flag where non-occurence means False, occurence means True.
addSimpleBoolFlag
:: Applicative f
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, e.g. ["verbose"]
-> Flag Void -- ^ properties
-> CmdParser f out Bool
addSimpleBoolFlag shorts longs flag =
addSimpleBoolFlagAll shorts longs flag (pure ())
-- | Applicative-enabled version of 'addSimpleFlag'
addSimpleFlagA
:: String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, e.g. ["verbose"]
-> Flag Void -- ^ properties
-> f () -- ^ action to execute whenever this matches
-> CmdParser f out ()
addSimpleFlagA shorts longs flag act
= void $ addSimpleBoolFlagAll shorts longs flag act
addSimpleBoolFlagAll
:: String
-> [String]
-> Flag Void
-> f ()
-> CmdParser f out Bool
addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
$ addCmdPartManyA ManyUpperBound1 (wrapHidden flag desc) parseF (\() -> a)
where
allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs
desc :: PartDesc
desc =
(maybe id PartWithHelp $ _flag_help flag)
$ PartAlts
$ PartLiteral
<$> allStrs
parseF :: String -> Maybe ((), String)
parseF (dropWhile Char.isSpace -> str) =
(firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
<|> ( firstJust
( \s ->
[ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ]
)
allStrs
)
-- | A no-parameter flag that can occur multiple times. Returns the number of
-- occurences (0 or more).
addSimpleCountFlag :: Applicative f
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> Flag Void -- ^ properties
-> CmdParser f out Int
addSimpleCountFlag shorts longs flag = fmap length
$ addCmdPartMany ManyUpperBoundN (wrapHidden flag desc) parseF
where
-- we _could_ allow this to parse repeated short flags, like "-vvv"
-- (meaning "-v -v -v") correctly.
allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs
desc :: PartDesc
desc =
(maybe id PartWithHelp $ _flag_help flag)
$ PartAlts
$ PartLiteral
<$> allStrs
parseF :: String -> Maybe ((), String)
parseF (dropWhile Char.isSpace -> str) =
(firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
<|> ( firstJust
( \s ->
[ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ]
)
allStrs
)
-- | One-argument flag, where the argument is parsed via its Read instance.
addFlagReadParam
:: forall f p out
. (Applicative f, Typeable p, Text.Read.Read p, Show p)
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- ^ param name
-> Flag p -- ^ properties
-> CmdParser f out p
addFlagReadParam shorts longs name flag =
addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())
where
allStrs =
[ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
desc =
(maybe id PartWithHelp $ _flag_help flag)
$ maybe id (PartDefault . show) (_flag_default flag)
$ PartSeq [desc1, desc2]
desc1 :: PartDesc
desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
desc2 = PartVariable name
parseF :: Input -> Maybe (p, Input)
parseF inp = case inp of
InputString str ->
maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)
$ parseResult
where
parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
Data.Foldable.msum $ allStrs <&> \case
Left s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")
Right s -> pExpect s *> (pExpect " " <|> pExpect "=")
InpParseString $ do
i <- StateS.get
case Text.Read.reads i of
((x, ' ':r):_) -> StateS.put (dropWhile Char.isSpace r) $> x
((x, "" ):_) -> StateS.put "" $> x
_ -> mzero
InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
Just ((), "") -> case argR of
[] -> Nothing
(arg2:rest) -> Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest)
Just ((), remainingStr) ->
Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR)
Nothing -> _flag_default flag <&> \d -> (d, inp)
where
parser :: InpParseString ()
parser = do
Data.Foldable.msum $ allStrs <&> \case
Left s -> pExpect s *> pOption (pExpect "=")
Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
InputArgs _ -> _flag_default flag <&> \d -> (d, inp)
-- | One-argument flag, where the argument is parsed via its Read instance.
-- This version can accumulate multiple values by using the same flag with
-- different arguments multiple times.
--
-- E.g. "--foo 3 --foo 5" yields [3,5].
addFlagReadParams
:: forall f p out
. (Applicative f, Typeable p, Text.Read.Read p, Show p)
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- ^ param name
-> Flag p -- ^ properties
-> CmdParser f out [p]
addFlagReadParams shorts longs name flag
= addFlagReadParamsAll shorts longs name flag (\_ -> pure ())
-- TODO: this implementation is wrong, because it uses addCmdPartManyInpA
-- while this really is no Many.
-- | Applicative-enabled version of 'addFlagReadParam'
-- addFlagReadParamA
-- :: forall f p out
-- . (Typeable p, Text.Read.Read p, Show p)
-- => String -- ^ short flag chars, i.e. "v" for -v
-- -> [String] -- ^ list of long names, i.e. ["verbose"]
-- -> String -- ^ param name
-- -> Flag p -- ^ properties
-- -> (p -> f ()) -- ^ action to execute when ths param matches
-- -> CmdParser f out ()
-- addFlagReadParamA shorts longs name flag act
-- = void $ addFlagReadParamsAll shorts longs name flag act
addFlagReadParamsAll
:: forall f p out . (Typeable p, Text.Read.Read p, Show p) => String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- ^ param name
-> Flag p -- ^ properties
-> (p -> f ()) -- ^ action to execute when ths param matches
-> CmdParser f out [p]
addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA
ManyUpperBoundN
(wrapHidden flag desc)
parseF
act
where
allStrs =
[ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2]
desc1 :: PartDesc
desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
desc2 =
(maybe id (PartDefault . show) $ _flag_default flag) $ PartVariable name
parseF :: Input -> Maybe (p, Input)
parseF inp = case inp of
InputString str ->
fmap (second InputString) $ parseResult
where
parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
Data.Foldable.msum $ allStrs <&> \case
Left s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")
Right s -> pExpect s *> (pExpect " " <|> pExpect "=")
InpParseString $ do
i <- StateS.get
case Text.Read.reads i of
((x, ' ':r):_) -> StateS.put (dropWhile Char.isSpace r) $> x
((x, "" ):_) -> StateS.put "" $> x
_ -> lift $ _flag_default flag
InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
Just ((), "") -> case argR of
[] -> mdef
(arg2:rest) -> (Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest)) <|> mdef
where mdef = _flag_default flag <&> \p -> (p, InputArgs argR)
Just ((), remainingStr) ->
Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR)
Nothing -> Nothing
where
parser :: InpParseString ()
parser = do
Data.Foldable.msum $ allStrs <&> \case
Left s -> pExpect s *> pOption (pExpect "=")
Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
InputArgs _ -> Nothing
-- | One-argument flag where the argument can be an arbitrary string.
addFlagStringParam
:: forall f out . (Applicative f) => String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- ^ param name
-> Flag String -- ^ properties
-> CmdParser f out String
addFlagStringParam shorts longs name flag =
addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())
where
allStrs =
[ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2]
desc1 :: PartDesc
desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
desc2 = PartVariable name
parseF :: Input -> Maybe (String, Input)
parseF inp = case inp of
InputString str ->
maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)
$ parseResult
where
parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
Data.Foldable.msum $ allStrs <&> \case
Left s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")
Right s -> pExpect s *> (pExpect " " <|> pExpect "=")
InpParseString $ do
i <- StateS.get
let (x, rest) = break Char.isSpace $ dropWhile Char.isSpace i
StateS.put rest
pure x
InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
Just ((), "") -> case argR of
[] -> Nothing
(x:rest) -> Just (x, InputArgs rest)
Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)
Nothing -> _flag_default flag <&> \d -> (d, inp)
where
parser :: InpParseString ()
parser = do
Data.Foldable.msum $ allStrs <&> \case
Left s -> pExpect s *> pOption (pExpect "=")
Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
InputArgs _ -> _flag_default flag <&> \d -> (d, inp)
-- | One-argument flag where the argument can be an arbitrary string.
-- This version can accumulate multiple values by using the same flag with
-- different arguments multiple times.
--
-- E.g. "--foo abc --foo def" yields ["abc", "def"].
addFlagStringParams
:: forall f out
. (Applicative f)
=> String -- ^ short flag chars, i.e. "v" for -v
-> [String] -- ^ list of long names, i.e. ["verbose"]
-> String -- ^ param name
-> Flag Void -- ^ properties
-> CmdParser f out [String]
addFlagStringParams shorts longs name flag
= addFlagStringParamsAll shorts longs name flag (\_ -> pure ())
-- TODO: this implementation is wrong, because it uses addCmdPartManyInpA
-- while this really is no Many.
-- -- | Applicative-enabled version of 'addFlagStringParam'
-- addFlagStringParamA
-- :: forall f out
-- . String -- ^ short flag chars, i.e. "v" for -v
-- -> [String] -- ^ list of long names, i.e. ["verbose"]
-- -> String -- ^ param name
-- -> Flag Void -- ^ properties
-- -> (String -> f ()) -- ^ action to execute when ths param matches
-- -> CmdParser f out ()
-- addFlagStringParamA shorts longs name flag act
-- = void $ addFlagStringParamsAll shorts longs name flag act
addFlagStringParamsAll
:: forall f out . String
-> [String]
-> String
-> Flag Void -- we forbid the default because it has bad interaction
-- with the eat-anything behaviour of the string parser.
-> (String -> f ())
-> CmdParser f out [String]
addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA
ManyUpperBoundN
(wrapHidden flag desc)
parseF
act
where
allStrs =
[ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2]
desc1 :: PartDesc
desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
desc2 =
(maybe id (PartDefault . show) $ _flag_default flag) $ PartVariable name
parseF :: Input -> Maybe (String, Input)
parseF inp = case inp of
InputString str -> fmap (second InputString) $ parseResult
where
parseResult = runInpParseString (dropWhile Char.isSpace str) $ do
Data.Foldable.msum $ allStrs <&> \case
Left s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")
Right s -> pExpect s *> (pExpect " " <|> pExpect "=")
InpParseString $ do
i <- StateS.get
let (x, rest) = break Char.isSpace $ dropWhile Char.isSpace i
StateS.put rest
pure x
InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
Just ((), "" ) -> case argR of
[] -> Nothing
(x:rest) -> Just (x, InputArgs rest)
Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)
Nothing -> Nothing
where
parser :: InpParseString ()
parser = do
Data.Foldable.msum $ allStrs <&> \case
Left s -> pExpect s *> pOption (pExpect "=")
Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
InputArgs _ -> Nothing
butcher-1.3.3.2/src/UI/Butcher/Monadic/IO.hs 0000644 0000000 0000000 00000010674 07346545000 016430 0 ustar 00 0000000 0000000 -- | Turn your CmdParser into an IO () to be used as your program @main@.
module UI.Butcher.Monadic.IO
( mainFromCmdParser
, mainFromCmdParserWithHelpDesc
)
where
#include "prelude.inc"
import Control.Monad.Free
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS
import qualified Text.PrettyPrint as PP
import Data.HList.ContainsType
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Monadic.Pretty
import UI.Butcher.Monadic.Param
import System.IO
-- | Utility method that allows using a 'CmdParser' as your @main@ function:
--
-- > main = mainFromCmdParser $ do
-- > addCmdImpl $ putStrLn "This is a fairly boring program."
--
-- Uses @System.Environment.getProgName@ as program name and
-- @System.Environment.getArgs@ as the input to be parsed. Prints some
-- appropriate messages if parsing fails or if the command has no
-- implementation; if all is well executes the \'out\' action (the IO ()).
mainFromCmdParser :: CmdParser Identity (IO ()) () -> IO ()
mainFromCmdParser cmd = do
progName <- System.Environment.getProgName
case checkCmdParser (Just progName) cmd of
Left e -> do
putStrErrLn
$ progName
++ ": internal error: failed sanity check for butcher main command parser!"
putStrErrLn $ "(" ++ e ++ ")"
putStrErrLn $ "aborting."
Right _ -> do
args <- System.Environment.getArgs
case runCmdParser (Just progName) (InputArgs args) cmd of
(desc, Left (ParsingError mess remaining)) -> do
putStrErrLn
$ progName
++ ": error parsing arguments: "
++ case mess of
[] -> ""
(m:_) -> m
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
-- | Same as mainFromCmdParser, but with one additional twist: You get access
-- to a knot-tied complete CommandDesc for this full command. Useful in
-- combination with 'UI.Butcher.Monadic.BuiltinCommands.addHelpCommand'
mainFromCmdParserWithHelpDesc
:: (CommandDesc () -> CmdParser Identity (IO ()) ()) -> IO ()
mainFromCmdParserWithHelpDesc cmdF = do
progName <- System.Environment.getProgName
let (checkResult, fullDesc)
-- knot-tying at its finest..
= ( checkCmdParser (Just progName) (cmdF fullDesc)
, either (const emptyCommandDesc) id $ checkResult
)
case checkResult of
Left e -> do
putStrErrLn $ progName ++ ": internal error: failed sanity check for butcher main command parser!"
putStrErrLn $ "(" ++ e ++ ")"
putStrErrLn $ "aborting."
Right _ -> do
args <- System.Environment.getArgs
case runCmdParser (Just progName) (InputArgs args) (cmdF fullDesc) of
(desc, Left (ParsingError mess remaining)) -> do
putStrErrLn $ progName ++ ": error parsing arguments: " ++ head mess
putStrErrLn $ case remaining of
InputString "" -> "at the end of input."
InputString str -> case show str of
s | length s < 42 -> "at: " ++ s ++ "."
s -> "at: " ++ take 40 s ++ "..\"."
InputArgs [] -> "at the end of input"
InputArgs xs -> case List.unwords $ show <$> xs of
s | length s < 42 -> "at: " ++ s ++ "."
s -> "at: " ++ take 40 s ++ "..\"."
putStrErrLn $ "usage:"
printErr $ ppUsage desc
(desc, Right out) -> case _cmd_out out of
Nothing -> do
putStrErrLn $ "usage:"
printErr $ ppUsage desc
Just a -> a
putStrErrLn :: String -> IO ()
putStrErrLn s = hPutStrLn stderr s
printErr :: Show a => a -> IO ()
printErr = putStrErrLn . show
butcher-1.3.3.2/src/UI/Butcher/Monadic/Interactive.hs 0000644 0000000 0000000 00000017522 07346545000 020375 0 ustar 00 0000000 0000000 -- | Utilities when writing interactive programs that interpret commands,
-- e.g. a REPL.
module UI.Butcher.Monadic.Interactive
( simpleCompletion
, shellCompletionWords
, interactiveHelpDoc
, partDescStrings
)
where
#include "prelude.inc"
import qualified Text.PrettyPrint as PP
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Monadic.Pretty
-- | Derives a potential completion from a given input string and a given
-- 'CommandDesc'. Considers potential subcommands and where available the
-- completion info present in 'PartDesc's.
simpleCompletion
:: String -- ^ input string
-> CommandDesc () -- ^ CommandDesc obtained on that input string
-> String -- ^ "remaining" input after the last successfully parsed
-- subcommand. See 'UI.Butcher.Monadic.runCmdParserExt'.
-> String -- ^ completion, i.e. a string that might be appended
-- to the current prompt when user presses tab.
simpleCompletion line cdesc pcRest = case reverse line of
[] -> compl
' ' : _ -> compl
_ | null pcRest -> "" -- necessary to prevent subcommand completion
-- appearing before space that is, if you have command
-- "aaa" with subcommand "sss", we want completion
-- "sss" on "aaa " but not on "aaa".
_ -> compl
where
compl = List.drop (List.length lastWord) (longestCommonPrefix choices)
longestCommonPrefix [] = ""
longestCommonPrefix (c1 : cr) =
case find (\s -> List.all (s `isPrefixOf`) cr) $ reverse $ List.inits c1 of
Nothing -> ""
Just x -> x
nameDesc = case _cmd_mParent cdesc of
Nothing -> cdesc
Just (_, parent) | null pcRest && not (null lastWord) -> parent
-- not finished writing a command. if we have commands abc and abcdef,
-- we may want "def" as a completion after "abc".
Just{} -> cdesc
lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ line
choices :: [String]
choices = join
[ [ r
| (Just r, _) <- Data.Foldable.toList (_cmd_children nameDesc)
, lastWord `isPrefixOf` r
, lastWord /= r
]
, [ s
| s <- partDescStrings =<< _cmd_parts nameDesc
, lastWord `isPrefixOf` s
, lastWord /= s
]
]
-- | Derives a list of completion items from a given input string and a given
-- 'CommandDesc'. Considers potential subcommands and where available the
-- completion info present in 'PartDesc's.
--
-- See 'addShellCompletion' which uses this.
shellCompletionWords
:: String -- ^ input string
-> CommandDesc () -- ^ CommandDesc obtained on that input string
-> String -- ^ "remaining" input after the last successfully parsed
-- subcommand. See 'UI.Butcher.Monadic.runCmdParserExt'.
-> [CompletionItem]
shellCompletionWords line cdesc pcRest = choices
where
nameDesc = case _cmd_mParent cdesc of
Nothing -> cdesc
Just (_, parent) | null pcRest && not (null lastWord) -> parent
-- not finished writing a command. if we have commands abc and abcdef,
-- we may want "def" as a completion after "abc".
Just{} -> cdesc
lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ line
choices :: [CompletionItem]
choices = join
[ [ CompletionString r
| (Just r, _) <- Data.Foldable.toList (_cmd_children nameDesc)
, lastWord `isPrefixOf` r
, lastWord /= r
]
, [ c
| c <- partDescCompletions =<< _cmd_parts cdesc
, case c of
CompletionString s -> lastWord `isPrefixOf` s && lastWord /= s
_ -> True
]
]
-- | Produces a 'PP.Doc' as a hint for the user during interactive command
-- input. Takes the current (incomplete) prompt line into account. For example
-- when you have commands (among others) \'config set-email\' and
-- \'config get-email\', then on empty prompt there will be an item \'config\';
-- on the partial prompt \'config \' the help doc will contain the
-- \'set-email\' and \'get-email\' items.
interactiveHelpDoc
:: String -- ^ input string
-> CommandDesc () -- ^ CommandDesc obtained on that input string
-> String -- ^ "remaining" input after the last successfully parsed
-- subcommand. See 'UI.Butcher.Monadic.runCmdParserExt'.
-> Int -- ^ max length of help text
-> PP.Doc
interactiveHelpDoc cmdline desc pcRest maxLines = if
| null cmdline -> helpStrShort
| List.last cmdline == ' ' -> helpStrShort
| otherwise -> helpStr
where
helpStr = if List.length optionLines > maxLines
then
PP.fcat $ List.intersperse (PP.text "|") $ PP.text . fst <$> optionLines
else PP.vcat $ optionLines <&> \case
(s, "") -> PP.text s
(s, h ) -> PP.text s PP.<> PP.text h
where
nameDesc = case _cmd_mParent desc of
Nothing -> desc
Just (_, parent) | null pcRest -> parent
Just{} -> desc
lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ cmdline
optionLines :: [(String, String)]
optionLines = -- a list of potential words that make sense, given
-- the current input.
join
[ [ (s, e)
| (Just s, c) <- Data.Foldable.toList (_cmd_children nameDesc)
, lastWord `isPrefixOf` s
, let e = join $ join
[ [ " ARGS" | not $ null $ _cmd_parts c ]
, [ " CMDS" | not $ null $ _cmd_children c ]
, [ ": " ++ show h | Just h <- [_cmd_help c] ]
]
]
, [ (s, "")
| s <- partDescStrings =<< _cmd_parts nameDesc
, lastWord `isPrefixOf` s
]
]
helpStrShort = ppUsageWithHelp desc
-- | Obtains a list of "expected"/potential strings for a command part
-- described in the 'PartDesc'. In constrast to the 'simpleCompletion'
-- function this function does not take into account any current input, and
-- consequently the output elements can in general not be appended to partial
-- input to form valid input.
partDescStrings :: PartDesc -> [String]
partDescStrings = \case
PartLiteral s -> [s]
PartVariable _ -> []
-- TODO: we could handle seq of optional and such much better
PartOptional x -> partDescStrings x
PartAlts alts -> alts >>= partDescStrings
PartSeq [] -> []
PartSeq (x:_) -> partDescStrings x
PartDefault _ x -> partDescStrings x
PartSuggestion ss x -> [ s | CompletionString s <- ss ] ++ partDescStrings x
PartRedirect _ x -> partDescStrings x
PartReorder xs -> xs >>= partDescStrings
PartMany x -> partDescStrings x
PartWithHelp _h x -> partDescStrings x -- TODO: handle help
PartHidden{} -> []
-- | Obtains a list of "expected"/potential strings for a command part
-- described in the 'PartDesc'. In constrast to the 'simpleCompletion'
-- function this function does not take into account any current input, and
-- consequently the output elements can in general not be appended to partial
-- input to form valid input.
partDescCompletions :: PartDesc -> [CompletionItem]
partDescCompletions = \case
PartLiteral s -> [CompletionString s]
PartVariable _ -> []
-- TODO: we could handle seq of optional and such much better
PartOptional x -> partDescCompletions x
PartAlts alts -> alts >>= partDescCompletions
PartSeq [] -> []
PartSeq (x:_) -> partDescCompletions x
PartDefault _ x -> partDescCompletions x
PartSuggestion ss x -> ss ++ partDescCompletions x
PartRedirect _ x -> partDescCompletions x
PartReorder xs -> xs >>= partDescCompletions
PartMany x -> partDescCompletions x
PartWithHelp _h x -> partDescCompletions x -- TODO: handle help
PartHidden{} -> []
butcher-1.3.3.2/src/UI/Butcher/Monadic/Internal/ 0000755 0000000 0000000 00000000000 07346545000 017331 5 ustar 00 0000000 0000000 butcher-1.3.3.2/src/UI/Butcher/Monadic/Internal/Core.hs 0000644 0000000 0000000 00000140760 07346545000 020565 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
module UI.Butcher.Monadic.Internal.Core
( addCmdSynopsis
, addCmdHelp
, addCmdHelpStr
, peekCmdDesc
, peekInput
, addCmdPart
, addCmdPartA
, addCmdPartMany
, addCmdPartManyA
, addCmdPartInp
, addCmdPartInpA
, addCmdPartManyInp
, addCmdPartManyInpA
, addCmd
, addCmdHidden
, addNullCmd
, addCmdImpl
, addAlternatives
, reorderStart
, reorderStop
, checkCmdParser
, runCmdParser
, runCmdParserExt
, runCmdParserA
, runCmdParserAExt
, mapOut
, varPartDesc
)
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 Lens.Micro as Lens
import Lens.Micro ( (%~)
, (.~)
)
import qualified Text.PrettyPrint as PP
import Text.PrettyPrint ( (<+>)
, ($$)
, ($+$)
)
import Data.HList.ContainsType
import Data.Dynamic
import UI.Butcher.Monadic.Internal.Types
-- general-purpose helpers
----------------------------
mModify :: MonadMultiState s m => (s -> s) -> m ()
mModify f = mGet >>= mSet . f
-- sadly, you need a degree in type inference to know when we can use
-- these operators and when it must be avoided due to type ambiguities
-- arising around s in the signatures below. That's the price of not having
-- the functional dependency in MonadMulti*T.
(.=+) :: MonadMultiState s m => Lens.ASetter s s a b -> b -> m ()
l .=+ b = mModify $ l .~ b
(%=+) :: MonadMultiState s m => Lens.ASetter s s a b -> (a -> b) -> m ()
l %=+ f = mModify (l %~ f)
-- inflateStateProxy :: (Monad m, ContainsType s ss)
-- => p s -> StateS.StateT s m a -> MultiRWSS.MultiRWST r w ss m a
-- inflateStateProxy _ = MultiRWSS.inflateState
-- more on-topic stuff
----------------------------
-- instance IsHelpBuilder (CmdBuilder out) where
-- help s = liftF $ CmdBuilderHelp s ()
--
-- instance IsHelpBuilder (ParamBuilder p) where
-- help s = liftF $ ParamBuilderHelp s ()
--
-- instance IsHelpBuilder FlagBuilder where
-- help s = liftF $ FlagBuilderHelp s ()
-- | Add a synopsis to the command currently in scope; at top level this will
-- be the implicit top-level command.
--
-- Adding a second synopsis will overwrite a previous synopsis;
-- 'checkCmdParser' will check that you don't (accidentally) do this however.
addCmdSynopsis :: String -> CmdParser f out ()
addCmdSynopsis s = liftF $ CmdParserSynopsis s ()
-- | Add a help document to the command currently in scope; at top level this
-- will be the implicit top-level command.
--
-- Adding a second document will overwrite a previous document;
-- 'checkCmdParser' will check that you don't (accidentally) do this however.
addCmdHelp :: PP.Doc -> CmdParser f out ()
addCmdHelp s = liftF $ CmdParserHelp s ()
-- | Like @'addCmdHelp' . PP.text@
addCmdHelpStr :: String -> CmdParser f out ()
addCmdHelpStr s = liftF $ CmdParserHelp (PP.text s) ()
-- | Semi-hacky way of accessing the output CommandDesc from inside of a
-- 'CmdParser'. This is not implemented via knot-tying, i.e. the CommandDesc
-- you get is _not_ equivalent to the CommandDesc returned by 'runCmdParser'.
-- Also see 'runCmdParserWithHelpDesc' which does knot-tying.
--
-- 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 ())
peekCmdDesc = liftF $ CmdParserPeekDesc id
-- | Semi-hacky way of accessing the current input that is not yet processed.
-- This must not be used to do any parsing. The purpose of this function is
-- to provide a String to be used for output to the user, as feedback about
-- what command was executed. For example we may think of an interactive
-- program reacting to commandline input such as
-- "run --delay 60 fire-rockets" which shows a 60 second delay on the
-- "fire-rockets" command. The latter string could have been obtained
-- via 'peekInput' after having parsed "run --delay 60" already.
peekInput :: CmdParser f out String
peekInput = liftF $ CmdParserPeekInput id
-- | Add part that is expected to occur exactly once in the input. May
-- succeed on empty input (e.g. by having a default).
addCmdPart
:: (Applicative f, Typeable p)
=> PartDesc
-> (String -> Maybe (p, String))
-> CmdParser f out p
addCmdPart p f = liftF $ CmdParserPart p f (\_ -> pure ()) id
addCmdPartA
:: (Typeable p)
=> PartDesc
-> (String -> Maybe (p, String))
-> (p -> f ())
-> CmdParser f out p
addCmdPartA p f a = liftF $ CmdParserPart p f a id
-- | Add part that is not required to occur, and can occur as often as
-- indicated by 'ManyUpperBound'. Must not succeed on empty input.
addCmdPartMany
:: (Applicative f, Typeable p)
=> ManyUpperBound
-> PartDesc
-> (String -> Maybe (p, String))
-> CmdParser f out [p]
addCmdPartMany b p f = liftF $ CmdParserPartMany b p f (\_ -> pure ()) id
addCmdPartManyA
:: (Typeable p)
=> ManyUpperBound
-> PartDesc
-> (String -> Maybe (p, String))
-> (p -> f ())
-> CmdParser f out [p]
addCmdPartManyA b p f a = liftF $ CmdParserPartMany b p f a id
-- | Add part that is expected to occur exactly once in the input. May
-- succeed on empty input (e.g. by having a default).
--
-- Only difference to 'addCmdPart' is that it accepts 'Input', i.e. can
-- behave differently for @String@ and @[String]@ input.
addCmdPartInp
:: (Applicative f, Typeable p)
=> PartDesc
-> (Input -> Maybe (p, Input))
-> CmdParser f out p
addCmdPartInp p f = liftF $ CmdParserPartInp p f (\_ -> pure ()) id
addCmdPartInpA
:: (Typeable p)
=> PartDesc
-> (Input -> Maybe (p, Input))
-> (p -> f ())
-> CmdParser f out p
addCmdPartInpA p f a = liftF $ CmdParserPartInp p f a id
-- | Add part that is not required to occur, and can occur as often as
-- indicated by 'ManyUpperBound'. Must not succeed on empty input.
--
-- Only difference to 'addCmdPart' is that it accepts 'Input', i.e. can
-- behave differently for @String@ and @[String]@ input.
addCmdPartManyInp
:: (Applicative f, Typeable p)
=> ManyUpperBound
-> PartDesc
-> (Input -> Maybe (p, Input))
-> CmdParser f out [p]
addCmdPartManyInp b p f = liftF $ CmdParserPartManyInp b p f (\_ -> pure ()) id
addCmdPartManyInpA
:: (Typeable p)
=> ManyUpperBound
-> PartDesc
-> (Input -> Maybe (p, Input))
-> (p -> f ())
-> CmdParser f out [p]
addCmdPartManyInpA b p f a = liftF $ CmdParserPartManyInp b p f a id
-- | Add a new child command in the current context.
addCmd
:: Applicative f
=> String -- ^ command name
-> CmdParser f out () -- ^ subcommand
-> CmdParser f out ()
addCmd str sub = liftF $ CmdParserChild (Just str) Visible sub (pure ()) ()
-- | Add a new child command in the current context, but make it hidden. It
-- will not appear in docs/help generated by e.g. the functions in the
-- @Pretty@ module.
--
-- This feature is not well tested yet.
addCmdHidden
:: Applicative f
=> String -- ^ command name
-> CmdParser f out () -- ^ subcommand
-> CmdParser f out ()
addCmdHidden str sub =
liftF $ CmdParserChild (Just str) Hidden sub (pure ()) ()
-- | Add a list of sub-parsers one of which will be selected and used based
-- on the provided predicate function. The input elements consist of:
-- a) a name used for the command description of the output,
-- b) a predicate function; the first True predicate determines which element
-- to apply
-- c) a CmdParser.
addAlternatives
:: Typeable p
=> [(String, String -> Bool, CmdParser f out p)]
-> CmdParser f out p
addAlternatives elems = liftF $ CmdParserAlternatives desc alts id
where
desc = PartAlts $ [PartVariable s | (s, _, _) <- elems]
alts = [(a, b) | (_, a, b) <- elems]
-- | Create a simple PartDesc from a string.
varPartDesc :: String -> PartDesc
varPartDesc = PartVariable
-- | Add a new nameless child command in the current context. Nameless means
-- that this command matches the empty input, i.e. will always apply.
-- This feature is experimental and CommandDesc pretty-printing might not
-- correctly in presense of nullCmds.
addNullCmd :: Applicative f => CmdParser f out () -> CmdParser f out ()
addNullCmd sub = liftF $ CmdParserChild Nothing Hidden sub (pure ()) ()
-- | Add an implementation to the current command.
addCmdImpl :: out -> CmdParser f out ()
addCmdImpl o = liftF $ CmdParserImpl o ()
-- | Best explained via example:
--
-- > do
-- > reorderStart
-- > bright <- addSimpleBoolFlag "" ["bright"] mempty
-- > yellow <- addSimpleBoolFlag "" ["yellow"] mempty
-- > reorderStop
-- > ..
--
-- will accept any inputs "" "--bright" "--yellow" "--bright --yellow" "--yellow --bright".
--
-- This works for any flags/params, but bear in mind that the results might
-- be unexpected because params may match on any input.
--
-- Note that start/stop must occur in pairs, and it will be a runtime error
-- if you mess this up. Use 'checkCmdParser' if you want to check all parts
-- of your 'CmdParser' without providing inputs that provide 100% coverage.
reorderStart :: CmdParser f out ()
reorderStart = liftF $ CmdParserReorderStart ()
-- | See 'reorderStart'
reorderStop :: CmdParser f out ()
reorderStop = liftF $ CmdParserReorderStop ()
-- addPartHelp :: String -> CmdPartParser ()
-- addPartHelp s = liftF $ CmdPartParserHelp s ()
--
-- addPartParserBasic :: (String -> Maybe (p, String)) -> Maybe p -> CmdPartParser p
-- addPartParserBasic f def = liftF $ CmdPartParserCore f def id
--
-- addPartParserOptionalBasic :: CmdPartParser p -> CmdPartParser (Maybe p)
-- addPartParserOptionalBasic p = liftF $ CmdPartParserOptional p id
data PartGatherData f
= forall p . Typeable p => PartGatherData
{ _pgd_id :: Int
, _pgd_desc :: PartDesc
, _pgd_parseF :: Either (String -> Maybe (p, String))
(Input -> Maybe (p, Input))
, _pgd_act :: p -> f ()
, _pgd_many :: Bool
}
data ChildGather f out =
ChildGather (Maybe String) Visibility (CmdParser f out ()) (f ())
type PartParsedData = Map Int [Dynamic]
data CmdDescStack = StackBottom (Deque PartDesc)
| StackLayer (Deque PartDesc) String CmdDescStack
deriving Show
descStackAdd :: PartDesc -> CmdDescStack -> CmdDescStack
descStackAdd d = \case
StackBottom l -> StackBottom $ Deque.snoc d l
StackLayer l s u -> StackLayer (Deque.snoc d l) s u
-- | Because butcher is evil (i.e. has constraints not encoded in the types;
-- see the README), this method can be used as a rough check that you did not
-- mess up. It traverses all possible parts of the 'CmdParser' thereby
-- ensuring that the 'CmdParser' has a valid structure.
--
-- This method also yields a _complete_ @CommandDesc@ output, where the other
-- runCmdParser* functions all traverse only a shallow structure around the
-- parts of the 'CmdParser' touched while parsing the current input.
checkCmdParser
:: forall f out
. Maybe String -- ^ top-level command name
-> CmdParser f out () -- ^ parser to check
-> Either String (CommandDesc ())
checkCmdParser mTopLevel cmdParser =
(>>= final)
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateAS (StackBottom mempty)
$ MultiRWSS.withMultiStateS emptyCommandDesc
$ processMain cmdParser
where
final :: (CommandDesc out, CmdDescStack) -> Either String (CommandDesc ())
final (desc, stack) = case stack of
StackBottom descs ->
Right
$ descFixParentsWithTopM
(mTopLevel <&> \n -> (Just n, emptyCommandDesc))
$ ()
<$ desc { _cmd_parts = Data.Foldable.toList descs }
StackLayer _ _ _ -> Left "unclosed ReorderStart or GroupStart"
processMain
:: CmdParser f out a
-> MultiRWSS.MultiRWST
'[]
'[]
'[CommandDesc out, CmdDescStack]
(Either String)
a
processMain = \case
Pure x -> return x
Free (CmdParserHelp h next) -> do
cmd :: CommandDesc out <- mGet
mSet $ cmd { _cmd_help = Just h }
processMain next
Free (CmdParserSynopsis s next) -> do
cmd :: CommandDesc out <- mGet
mSet
$ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s }
processMain next
Free (CmdParserPeekDesc nextF) -> do
processMain $ nextF monadMisuseError
Free (CmdParserPeekInput nextF) -> do
processMain $ nextF monadMisuseError
Free (CmdParserPart desc _parseF _act nextF) -> do
do
descStack <- mGet
mSet $ descStackAdd desc descStack
processMain $ nextF monadMisuseError
Free (CmdParserPartInp desc _parseF _act nextF) -> do
do
descStack <- mGet
mSet $ descStackAdd desc descStack
processMain $ nextF monadMisuseError
Free (CmdParserPartMany bound desc _parseF _act nextF) -> do
do
descStack <- mGet
mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
processMain $ nextF monadMisuseError
Free (CmdParserPartManyInp bound desc _parseF _act nextF) -> do
do
descStack <- mGet
mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
processMain $ nextF monadMisuseError
Free (CmdParserChild cmdStr vis sub _act next) -> do
mInitialDesc <- takeCommandChild cmdStr
cmd :: CommandDesc out <- mGet
subCmd <- do
stackCur :: CmdDescStack <- mGet
mSet $ Maybe.fromMaybe (emptyCommandDesc :: CommandDesc out) mInitialDesc
mSet $ StackBottom mempty
processMain sub
c <- mGet
stackBelow <- mGet
mSet cmd
mSet stackCur
subParts <- case stackBelow of
StackBottom descs -> return $ Data.Foldable.toList descs
StackLayer _ _ _ -> lift $ Left "unclosed ReorderStart or GroupStart"
return c { _cmd_parts = subParts, _cmd_visibility = vis }
mSet $ cmd
{ _cmd_children = (cmdStr, subCmd) `Deque.snoc` _cmd_children cmd
}
processMain next
Free (CmdParserImpl out next) -> do
cmd_out .=+ Just out
processMain $ next
Free (CmdParserGrouped groupName next) -> do
stackCur <- mGet
mSet $ StackLayer mempty groupName stackCur
processMain $ next
Free (CmdParserGroupEnd next) -> do
stackCur <- mGet
case stackCur of
StackBottom{} -> do
lift $ Left $ "butcher interface error: group end without group start"
StackLayer _descs "" _up -> do
lift $ Left $ "GroupEnd found, but expected ReorderStop first"
StackLayer descs groupName up -> do
mSet $ descStackAdd
(PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))
up
processMain $ next
Free (CmdParserReorderStop next) -> do
stackCur <- mGet
case stackCur of
StackBottom{} -> lift $ Left $ "ReorderStop without reorderStart"
StackLayer descs "" up -> do
mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up
StackLayer{} ->
lift $ Left $ "Found ReorderStop, but need GroupEnd first"
processMain next
Free (CmdParserReorderStart next) -> do
stackCur <- mGet
mSet $ StackLayer mempty "" stackCur
processMain next
Free (CmdParserAlternatives desc alts nextF) -> do
mModify (descStackAdd desc)
states <- MultiRWSS.mGetRawS
let go
:: [(String -> Bool, CmdParser f out p)]
-> MultiRWSS.MultiRWST
'[] '[] '[CommandDesc out, CmdDescStack] (Either String) p
go [] = lift $ Left $ "Empty alternatives"
go [(_, alt)] = processMain alt
go ((_, alt1):altr) = do
case MultiRWSS.runMultiRWSTNil $ MultiRWSS.withMultiStates states (processMain alt1) of
Left{} -> go altr
Right (p, states') -> MultiRWSS.mPutRawS states' $> p
p <- go alts
processMain $ nextF p
monadMisuseError :: a
monadMisuseError =
error
$ "CmdParser definition error -"
++ " used Monad powers where only Applicative/Arrow is allowed"
newtype PastCommandInput = PastCommandInput Input
-- | Run a @CmdParser@ on the given input, returning:
--
-- a) A @CommandDesc ()@ that accurately represents the subcommand that was
-- reached, even if parsing failed. Because this is returned always, the
-- argument is @()@ because "out" requires a successful parse.
--
-- b) Either an error or the result of a successful parse, including a proper
-- "CommandDesc out" from which an "out" can be extracted (presuming that
-- the command has an implementation).
runCmdParser
:: Maybe String -- ^ program name to be used for the top-level @CommandDesc@
-> Input -- ^ input to be processed
-> CmdParser Identity out () -- ^ parser to use
-> (CommandDesc (), Either ParsingError (CommandDesc out))
runCmdParser mTopLevel inputInitial cmdParser =
runIdentity $ runCmdParserA mTopLevel inputInitial cmdParser
-- | Like 'runCmdParser', but also returning all input after the last
-- successfully parsed subcommand. E.g. for some input
-- "myprog foo bar -v --wrong" where parsing fails at "--wrong", this will
-- contain the full "-v --wrong". Useful for interactive feedback stuff.
runCmdParserExt
:: Maybe String -- ^ program name to be used for the top-level @CommandDesc@
-> Input -- ^ input to be processed
-> CmdParser Identity out () -- ^ parser to use
-> (CommandDesc (), Input, Either ParsingError (CommandDesc out))
runCmdParserExt mTopLevel inputInitial cmdParser =
runIdentity $ runCmdParserAExt mTopLevel inputInitial cmdParser
-- | The Applicative-enabled version of 'runCmdParser'.
runCmdParserA
:: forall f out
. Applicative f
=> Maybe String -- ^ program name to be used for the top-level @CommandDesc@
-> Input -- ^ input to be processed
-> CmdParser f out () -- ^ parser to use
-> f (CommandDesc (), Either ParsingError (CommandDesc out))
runCmdParserA mTopLevel inputInitial cmdParser =
(\(x, _, z) -> (x, z)) <$> runCmdParserAExt mTopLevel inputInitial cmdParser
-- | The Applicative-enabled version of 'runCmdParserExt'.
runCmdParserAExt
:: forall f out
. Applicative f
=> Maybe String -- ^ program name to be used for the top-level @CommandDesc@
-> Input -- ^ input to be processed
-> CmdParser f out () -- ^ parser to use
-> f
( CommandDesc ()
, Input
, Either ParsingError (CommandDesc out)
)
runCmdParserAExt mTopLevel inputInitial cmdParser =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ (<&> captureFinal)
$ MultiRWSS.withMultiWriterWA
$ MultiRWSS.withMultiStateA cmdParser
$ MultiRWSS.withMultiStateSA (StackBottom mempty)
$ MultiRWSS.withMultiStateSA inputInitial
$ MultiRWSS.withMultiStateSA (PastCommandInput inputInitial)
$ MultiRWSS.withMultiStateSA initialCommandDesc
$ processMain cmdParser
where
initialCommandDesc = emptyCommandDesc
{ _cmd_mParent = mTopLevel <&> \n -> (Just n, emptyCommandDesc)
}
captureFinal
:: ( [String]
, (CmdDescStack, (Input, (PastCommandInput, (CommandDesc out, f ()))))
)
-> f (CommandDesc (), Input, Either ParsingError (CommandDesc out))
captureFinal tuple1 = act $> (() <$ cmd', pastCmdInput, res)
where
(errs , tuple2) = tuple1
(descStack , tuple3) = tuple2
(inputRest , tuple4) = tuple3
(PastCommandInput pastCmdInput, tuple5) = tuple4
(cmd , act ) = tuple5
errs' = errs ++ inputErrs ++ stackErrs
inputErrs = case inputRest of
InputString s | all Char.isSpace s -> []
InputString{} -> ["could not parse input/unprocessed input"]
InputArgs [] -> []
InputArgs{} -> ["could not parse input/unprocessed input"]
stackErrs = case descStack of
StackBottom{} -> []
_ -> ["butcher interface error: unclosed group"]
cmd' = postProcessCmd descStack cmd
res =
if null errs' then Right cmd' else Left $ ParsingError errs' inputRest
processMain
:: -- forall a
CmdParser f out ()
-> MultiRWSS.MultiRWS
'[]
'[[String]]
'[CommandDesc out, PastCommandInput, Input, CmdDescStack, CmdParser
f
out
()]
(f ())
processMain = \case
Pure () -> return $ pure ()
Free (CmdParserHelp h next) -> do
cmd :: CommandDesc out <- mGet
mSet $ cmd { _cmd_help = Just h }
processMain next
Free (CmdParserSynopsis s next) -> do
cmd :: CommandDesc out <- mGet
mSet
$ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s }
processMain next
Free (CmdParserPeekDesc nextF) -> do
parser :: CmdParser f out () <- mGet
-- partialDesc :: CommandDesc out <- mGet
-- partialStack :: CmdDescStack <- mGet
-- run the rest without affecting the actual stack
-- to retrieve the complete cmddesc.
cmdCur :: CommandDesc out <- mGet
let (cmd :: CommandDesc out, stack) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateSA emptyCommandDesc
{ _cmd_mParent = _cmd_mParent cmdCur
} -- partialDesc
$ MultiRWSS.withMultiStateS (StackBottom mempty) -- partialStack
$ iterM processCmdShallow
$ parser
processMain $ nextF $ () <$ postProcessCmd stack cmd
Free (CmdParserPeekInput nextF) -> do
processMain $ nextF $ inputToString inputInitial
Free (CmdParserPart desc parseF actF nextF) -> do
do
descStack <- mGet
mSet $ descStackAdd desc descStack
input <- mGet
case input of
InputString str -> case parseF str of
Just (x, rest) -> do
mSet $ InputString rest
actRest <- processMain $ nextF x
return $ actF x *> actRest
Nothing -> do
mTell ["could not parse " ++ getPartSeqDescPositionName desc]
processMain $ nextF monadMisuseError
InputArgs (str:strr) -> case parseF str of
Just (x, "") -> do
mSet $ InputArgs strr
actRest <- processMain $ nextF x
return $ actF x *> actRest
Just (x, rest) | str == rest -> do
-- no input consumed, default applied
actRest <- processMain $ nextF x
return $ actF x *> actRest
_ -> do
mTell ["could not parse " ++ getPartSeqDescPositionName desc]
processMain $ nextF monadMisuseError
InputArgs [] -> do
mTell ["could not parse " ++ getPartSeqDescPositionName desc]
processMain $ nextF monadMisuseError
Free (CmdParserPartInp desc parseF actF nextF) -> do
do
descStack <- mGet
mSet $ descStackAdd desc descStack
input <- mGet
case parseF input of
Just (x, rest) -> do
mSet $ rest
actRest <- processMain $ nextF x
return $ actF x *> actRest
Nothing -> do
mTell ["could not parse " ++ getPartSeqDescPositionName desc]
processMain $ nextF monadMisuseError
Free (CmdParserPartMany bound desc parseF actF nextF) -> do
do
descStack <- mGet
mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
let proc = do
dropSpaces
input <- mGet
case input of
InputString str -> case parseF str of
Just (x, r) -> do
mSet $ InputString r
xr <- proc
return $ x : xr
Nothing -> return []
InputArgs (str:strr) -> case parseF str of
Just (x, "") -> do
mSet $ InputArgs strr
xr <- proc
return $ x : xr
_ -> return []
InputArgs [] -> return []
r <- proc
let act = traverse actF r
(act *>) <$> processMain (nextF $ r)
Free (CmdParserPartManyInp bound desc parseF actF nextF) -> do
do
descStack <- mGet
mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
let proc = do
dropSpaces
input <- mGet
case parseF input of
Just (x, r) -> do
mSet $ r
xr <- proc
return $ x : xr
Nothing -> return []
r <- proc
let act = traverse actF r
(act *>) <$> processMain (nextF $ r)
f@(Free (CmdParserChild _ _ _ _ _)) -> do
dropSpaces
input <- mGet
(gatheredChildren :: [ChildGather f out], restCmdParser) <-
MultiRWSS.withMultiWriterWA $ childrenGather f
let
child_fold
:: ( Deque (Maybe String)
, Map (Maybe String) (Visibility, CmdParser f out (), f ())
)
-> ChildGather f out
-> ( Deque (Maybe String)
, Map (Maybe String) (Visibility, CmdParser f out (), f ())
)
child_fold (c_names, c_map) (ChildGather name vis child act) =
case name `MapS.lookup` c_map of
Nothing ->
( Deque.snoc name c_names
, MapS.insert name (vis, child, act) c_map
)
Just (vis', child', act') ->
( c_names
, MapS.insert name (vis', child' >> child, act') c_map
-- we intentionally override/ignore act here.
-- TODO: it should be documented that we expect the same act
-- on different child nodes with the same name.
)
(child_name_list, child_map) =
foldl' child_fold (mempty, MapS.empty) gatheredChildren
combined_child_list =
Data.Foldable.toList child_name_list <&> \n -> (n, child_map MapS.! n)
let
mRest = asum $ combined_child_list <&> \(mname, (child, act, vis)) ->
case (mname, input) of
(Just name, InputString str) | name == str ->
Just $ (Just name, child, act, vis, InputString "")
(Just name, InputString str) | (name ++ " ") `isPrefixOf` str ->
Just
$ ( Just name
, child
, act
, vis
, InputString $ drop (length name + 1) str
)
(Just name, InputArgs (str:strr)) | name == str ->
Just $ (Just name, child, act, vis, InputArgs strr)
(Nothing, _) -> Just $ (Nothing, child, act, vis, input)
_ -> Nothing
combined_child_list `forM_` \(child_name, (vis, child, _)) -> do
let initialDesc :: CommandDesc out = emptyCommandDesc
-- get the shallow desc for the child in a separate env.
let (subCmd, subStack) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateSA initialDesc
$ MultiRWSS.withMultiStateS (StackBottom mempty)
$ iterM processCmdShallow child
cmd_children %=+ Deque.snoc
( child_name
, postProcessCmd subStack subCmd { _cmd_visibility = vis }
)
case mRest of
Nothing -> do -- a child not matching what we have in the input
-- get the shallow desc for the child in a separate env.
-- proceed regularly on the same layer
processMain $ restCmdParser
Just (name, vis, child, act, rest) -> do -- matching child -> descend
-- process all remaining stuff on the same layer shallowly,
-- including the current node. This will walk over the child
-- definition(s) again, but that is harmless because we do not
-- overwrite them.
iterM processCmdShallow f
-- do the descend
cmd <- do
c :: CommandDesc out <- mGet
prevStack :: CmdDescStack <- mGet
return $ postProcessCmd prevStack c
mSet $ rest
mSet $ PastCommandInput rest
mSet $ emptyCommandDesc { _cmd_mParent = Just (name, cmd)
, _cmd_visibility = vis
}
mSet $ child
mSet $ StackBottom mempty
childAct <- processMain child
-- check that descending yielded
return $ act *> childAct
Free (CmdParserImpl out next) -> do
cmd_out .=+ Just out
processMain $ next
Free (CmdParserGrouped groupName next) -> do
stackCur <- mGet
mSet $ StackLayer mempty groupName stackCur
processMain $ next
Free (CmdParserGroupEnd next) -> do
stackCur <- mGet
case stackCur of
StackBottom{} -> do
mTell $ ["butcher interface error: group end without group start"]
return $ pure () -- hard abort should be fine for this case.
StackLayer descs groupName up -> do
mSet $ descStackAdd
(PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))
up
processMain $ next
Free (CmdParserReorderStop next) -> do
mTell $ ["butcher interface error: reorder stop without reorder start"]
processMain next
Free (CmdParserReorderStart next) -> do
reorderData <-
MultiRWSS.withMultiStateA (1 :: Int)
$ MultiRWSS.withMultiWriterW
$ iterM reorderPartGather
$ next
let
reorderMapInit :: Map Int (PartGatherData f)
reorderMapInit = MapS.fromList $ reorderData <&> \d -> (_pgd_id d, d)
tryParsePartData
:: Input
-> PartGatherData f
-> First (Int, Dynamic, Input, Bool, f ())
tryParsePartData input (PartGatherData pid _ pfe act allowMany) = First
[ (pid, toDyn r, rest, allowMany, act r)
| (r, rest) <- case pfe of
Left pfStr -> case input of
InputString str -> case pfStr str of
Just (x, r) | r /= str -> Just (x, InputString r)
_ -> Nothing
InputArgs (str:strr) -> case pfStr str of
Just (x, "") -> Just (x, InputArgs strr)
_ -> Nothing
InputArgs [] -> Nothing
Right pfInp -> case pfInp input of
Just (x, r) | r /= input -> Just (x, r)
_ -> Nothing
]
parseLoop = do
input <- mGet
m :: Map Int (PartGatherData f) <- mGet
case getFirst $ Data.Foldable.foldMap (tryParsePartData input) m of
-- i will be angry if foldMap ever decides to not fold
-- in order of keys.
Nothing -> return $ pure ()
Just (pid, x, rest, more, act) -> do
mSet rest
mModify $ MapS.insertWith (++) pid [x]
when (not more) $ do
mSet $ MapS.delete pid m
actRest <- parseLoop
return $ act *> actRest
(finalMap, (fr, acts)) <-
MultiRWSS.withMultiStateSA (MapS.empty :: PartParsedData)
$ MultiRWSS.withMultiStateA reorderMapInit
$ do
acts <- parseLoop -- filling the map
stackCur <- mGet
mSet $ StackLayer mempty "" stackCur
fr <- MultiRWSS.withMultiStateA (1 :: Int) $ processParsedParts next
return (fr, acts)
-- we check that all data placed in the map has been consumed while
-- running the parts for which we collected the parseresults.
-- there can only be any rest if the collection of parts changed
-- between the reorderPartGather traversal and the processParsedParts
-- consumption.
if MapS.null finalMap
then do
actRest <- processMain fr
return $ acts *> actRest
else monadMisuseError
Free (CmdParserAlternatives desc alts nextF) -> do
input :: Input <- mGet
case input of
InputString str
| Just (_, sub) <- find (\(predicate, _sub) -> predicate str) alts ->
processMain $ sub >>= nextF
InputArgs (str:_)
| Just (_, sub) <- find (\(predicate, _sub) -> predicate str) alts ->
processMain $ sub >>= nextF
_ -> do
mTell ["could not parse any of " ++ getPartSeqDescPositionName desc]
processMain $ nextF monadMisuseError
reorderPartGather
:: ( MonadMultiState Int m
, MonadMultiWriter [PartGatherData f] m
, MonadMultiWriter [String] m
)
=> CmdParserF f out (m ())
-> m ()
reorderPartGather = \case
-- TODO: why do PartGatherData contain desc?
CmdParserPart desc parseF actF nextF -> do
pid <- mGet
mSet $ pid + 1
mTell [PartGatherData pid desc (Left parseF) actF False]
nextF $ monadMisuseError
CmdParserPartInp desc parseF actF nextF -> do
pid <- mGet
mSet $ pid + 1
mTell [PartGatherData pid desc (Right parseF) actF False]
nextF $ monadMisuseError
CmdParserPartMany _ desc parseF actF nextF -> do
pid <- mGet
mSet $ pid + 1
mTell [PartGatherData pid desc (Left parseF) actF True]
nextF $ monadMisuseError
CmdParserPartManyInp _ desc parseF actF nextF -> do
pid <- mGet
mSet $ pid + 1
mTell [PartGatherData pid desc (Right parseF) actF True]
nextF $ monadMisuseError
CmdParserReorderStop _next -> do
return ()
CmdParserHelp{} -> restCase
CmdParserSynopsis{} -> restCase
CmdParserPeekDesc{} -> restCase
CmdParserPeekInput{} -> restCase
CmdParserChild{} -> restCase
CmdParserImpl{} -> restCase
CmdParserReorderStart{} -> restCase
CmdParserGrouped{} -> restCase
CmdParserGroupEnd{} -> restCase
CmdParserAlternatives{} -> restCase
where
restCase = do
mTell ["Did not find expected ReorderStop after the reordered parts"]
return ()
childrenGather
:: ( MonadMultiWriter [ChildGather f out] m
, MonadMultiState (CmdParser f out ()) m
, MonadMultiState (CommandDesc out) m
)
=> CmdParser f out a
-> m (CmdParser f out a)
childrenGather = \case
Free (CmdParserChild cmdStr vis sub act next) -> do
mTell [ChildGather cmdStr vis sub act]
childrenGather next
Free (CmdParserPeekInput nextF) -> do
childrenGather $ nextF $ inputToString inputInitial
Free (CmdParserPeekDesc nextF) -> do
parser :: CmdParser f out () <- mGet
-- partialDesc :: CommandDesc out <- mGet
-- partialStack :: CmdDescStack <- mGet
-- run the rest without affecting the actual stack
-- to retrieve the complete cmddesc.
cmdCur :: CommandDesc out <- mGet
let (cmd :: CommandDesc out, stack) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateSA emptyCommandDesc
{ _cmd_mParent = _cmd_mParent cmdCur
} -- partialDesc
$ MultiRWSS.withMultiStateS (StackBottom mempty) -- partialStack
$ iterM processCmdShallow
$ parser
childrenGather $ nextF $ () <$ postProcessCmd stack cmd
something -> return something
processParsedParts
:: forall m r w s m0 a
. ( MonadMultiState Int m
, MonadMultiState PartParsedData m
, MonadMultiState (Map Int (PartGatherData f)) m
, MonadMultiState Input m
, MonadMultiState (CommandDesc out) m
, MonadMultiWriter [[Char]] m
, m ~ MultiRWSS.MultiRWST r w s m0
, ContainsType (CmdParser f out ()) s
, ContainsType CmdDescStack s
, Monad m0
)
=> CmdParser f out a
-> m (CmdParser f out a)
processParsedParts = \case
Free (CmdParserPart desc _ _ (nextF :: p -> CmdParser f out a)) ->
part desc nextF
Free (CmdParserPartInp desc _ _ (nextF :: p -> CmdParser f out a)) ->
part desc nextF
Free (CmdParserPartMany bound desc _ _ nextF) -> partMany bound desc nextF
Free (CmdParserPartManyInp bound desc _ _ nextF) ->
partMany bound desc nextF
Free (CmdParserReorderStop next) -> do
stackCur <- mGet
case stackCur of
StackBottom{} -> do
mTell ["unexpected stackBottom"]
StackLayer descs _ up -> do
mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up
return next
Free (CmdParserGrouped groupName next) -> do
stackCur <- mGet
mSet $ StackLayer mempty groupName stackCur
processParsedParts $ next
Free (CmdParserGroupEnd next) -> do
stackCur <- mGet
case stackCur of
StackBottom{} -> do
mTell $ ["butcher interface error: group end without group start"]
return $ next -- hard abort should be fine for this case.
StackLayer descs groupName up -> do
mSet $ descStackAdd
(PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))
up
processParsedParts $ next
Pure x -> return $ return $ x
f -> do
mTell ["Did not find expected ReorderStop after the reordered parts"]
return f
where
part
:: forall p
. Typeable p
=> PartDesc
-> (p -> CmdParser f out a)
-> m (CmdParser f out a)
part desc nextF = do
do
stackCur <- mGet
mSet $ descStackAdd desc stackCur
pid <- mGet
mSet $ pid + 1
parsedMap :: PartParsedData <- mGet
mSet $ MapS.delete pid parsedMap
partMap :: Map Int (PartGatherData f) <- mGet
input :: Input <- mGet
let
errorResult = do
mTell
[ "could not parse expected input "
++ getPartSeqDescPositionName desc
++ " with remaining input: "
++ show input
]
processParsedParts $ nextF monadMisuseError
continueOrMisuse :: Maybe p -> m (CmdParser f out a)
continueOrMisuse = maybe monadMisuseError (processParsedParts . nextF)
case MapS.lookup pid parsedMap of
Nothing -> case MapS.lookup pid partMap of
Nothing -> monadMisuseError -- it would still be in the map
-- if it never had been successfully
-- parsed, as indicicated by the
-- previous parsedMap Nothing lookup.
Just (PartGatherData _ _ pfe _ _) -> case pfe of
Left pf -> case pf "" of
Nothing -> errorResult
Just (dx, _) -> continueOrMisuse $ cast dx
Right pf -> case pf (InputArgs []) of
Nothing -> errorResult
Just (dx, _) -> continueOrMisuse $ cast dx
Just [dx] -> continueOrMisuse $ fromDynamic dx
Just _ -> monadMisuseError
partMany
:: Typeable p
=> ManyUpperBound
-> PartDesc
-> ([p] -> CmdParser f out a)
-> m (CmdParser f out a)
partMany bound desc nextF = do
do
stackCur <- mGet
mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
pid <- mGet
mSet $ pid + 1
m :: PartParsedData <- mGet
mSet $ MapS.delete pid m
let partDyns = case MapS.lookup pid m of
Nothing -> []
Just r -> reverse r
case mapM fromDynamic partDyns of
Nothing -> monadMisuseError
Just xs -> processParsedParts $ nextF xs
-- this does no error reporting at all.
-- user needs to use check for that purpose instead.
processCmdShallow
:: (MonadMultiState (CommandDesc out) m, MonadMultiState CmdDescStack m)
=> CmdParserF f out (m a)
-> m a
processCmdShallow = \case
CmdParserHelp h next -> do
cmd :: CommandDesc out <- mGet
mSet $ cmd { _cmd_help = Just h }
next
CmdParserSynopsis s next -> do
cmd :: CommandDesc out <- mGet
mSet
$ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s }
next
CmdParserPeekDesc nextF -> do
mGet >>= nextF . fmap (\(_ :: out) -> ())
CmdParserPeekInput nextF -> do
nextF $ inputToString inputInitial
CmdParserPart desc _parseF _act nextF -> do
do
stackCur <- mGet
mSet $ descStackAdd desc stackCur
nextF monadMisuseError
CmdParserPartInp desc _parseF _act nextF -> do
do
stackCur <- mGet
mSet $ descStackAdd desc stackCur
nextF monadMisuseError
CmdParserPartMany bound desc _parseF _act nextF -> do
do
stackCur <- mGet
mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
nextF monadMisuseError
CmdParserPartManyInp bound desc _parseF _act nextF -> do
do
stackCur <- mGet
mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
nextF monadMisuseError
CmdParserChild cmdStr vis _sub _act next -> do
mExisting <- takeCommandChild cmdStr
let childDesc :: CommandDesc out =
Maybe.fromMaybe emptyCommandDesc { _cmd_visibility = vis } mExisting
cmd_children %=+ Deque.snoc (cmdStr, childDesc)
next
CmdParserImpl out next -> do
cmd_out .=+ Just out
next
CmdParserGrouped groupName next -> do
stackCur <- mGet
mSet $ StackLayer mempty groupName stackCur
next
CmdParserGroupEnd next -> do
stackCur <- mGet
case stackCur of
StackBottom{} -> pure ()
StackLayer _descs "" _up -> pure ()
StackLayer descs groupName up -> do
mSet $ descStackAdd
(PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))
up
next
CmdParserReorderStop next -> do
stackCur <- mGet
case stackCur of
StackBottom{} -> return ()
StackLayer descs "" up -> do
mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up
StackLayer{} -> return ()
next
CmdParserReorderStart next -> do
stackCur <- mGet
mSet $ StackLayer mempty "" stackCur
next
CmdParserAlternatives _ [] _ -> error "empty alternatives"
CmdParserAlternatives desc ((_, alt):_) nextF -> do
mModify (descStackAdd desc)
nextF =<< iterM processCmdShallow alt
-- currently unused; was previously used during failure in
-- processParsedParts. Using this leads to duplicated descs, but I fear
-- that not using it also leads to certain problems (missing children?).
-- Probably want to re-write into proper two-phase 1) obtain desc 2) run
-- parser, like the applicative approach.
_failureCurrentShallowRerun
:: ( m ~ MultiRWSS.MultiRWST r w s m0
, MonadMultiState (CmdParser f out ()) m
, MonadMultiState (CommandDesc out) m
, ContainsType CmdDescStack s
, Monad m0
)
=> m ()
_failureCurrentShallowRerun = do
parser :: CmdParser f out () <- mGet
cmd :: CommandDesc out <-
MultiRWSS.withMultiStateS emptyCommandDesc
$ iterM processCmdShallow parser
mSet cmd
postProcessCmd :: CmdDescStack -> CommandDesc out -> CommandDesc out
postProcessCmd descStack cmd = descFixParents $ cmd
{ _cmd_parts = case descStack of
StackBottom l -> Data.Foldable.toList l
StackLayer{} -> []
}
monadMisuseError :: a
monadMisuseError =
error
$ "CmdParser definition error -"
++ " used Monad powers where only Applicative/Arrow is allowed"
getPartSeqDescPositionName :: PartDesc -> String
getPartSeqDescPositionName = \case
PartLiteral s -> s
PartVariable s -> s
PartOptional ds' -> f ds'
PartAlts alts -> f $ head alts -- this is not optimal, but probably
-- does not matter.
PartDefault _ d -> f d
PartSuggestion _ d -> f d
PartRedirect s _ -> s
PartMany ds -> f ds
PartWithHelp _ d -> f d
PartSeq ds -> List.unwords $ f <$> ds
PartReorder ds -> List.unwords $ f <$> ds
PartHidden d -> f d
where f = getPartSeqDescPositionName
dropSpaces :: MonadMultiState Input m => m ()
dropSpaces = do
inp <- mGet
case inp of
InputString s -> mSet $ InputString $ dropWhile Char.isSpace s
InputArgs{} -> return ()
inputToString :: Input -> String
inputToString (InputString s ) = s
inputToString (InputArgs ss) = List.unwords ss
dequeLookupRemove :: Eq k => k -> Deque (k, a) -> (Maybe a, Deque (k, a))
dequeLookupRemove key deque = case Deque.uncons deque of
Nothing -> (Nothing, mempty)
Just ((k, v), rest) -> if k == key
then (Just v, rest)
else
let (r, rest') = dequeLookupRemove key rest
in (r, Deque.cons (k, v) rest')
takeCommandChild
:: MonadMultiState (CommandDesc out) m
=> Maybe String
-> m (Maybe (CommandDesc out))
takeCommandChild key = do
cmd <- mGet
let (r, children') = dequeLookupRemove key $ _cmd_children cmd
mSet cmd { _cmd_children = children' }
return r
-- | map over the @out@ type argument
mapOut :: (outa -> outb) -> CmdParser f outa a -> CmdParser f outb a
mapOut f = hoistFree $ \case
CmdParserHelp doc r -> CmdParserHelp doc r
CmdParserSynopsis s r -> CmdParserSynopsis s r
CmdParserPeekDesc fr -> CmdParserPeekDesc fr
CmdParserPeekInput fr -> CmdParserPeekInput fr
CmdParserPart desc fp fa fr -> CmdParserPart desc fp fa fr
CmdParserPartMany bound desc fp fa fr ->
CmdParserPartMany bound desc fp fa fr
CmdParserPartInp desc fp fa fr -> CmdParserPartInp desc fp fa fr
CmdParserPartManyInp bound desc fp fa fr ->
CmdParserPartManyInp bound desc fp fa fr
CmdParserChild s vis child act r ->
CmdParserChild s vis (mapOut f child) act r
CmdParserImpl out r -> CmdParserImpl (f out) r
CmdParserReorderStart r -> CmdParserReorderStart r
CmdParserReorderStop r -> CmdParserReorderStop r
CmdParserGrouped s r -> CmdParserGrouped s r
CmdParserGroupEnd r -> CmdParserGroupEnd r
CmdParserAlternatives desc alts r -> CmdParserAlternatives
desc
[ (predicate, mapOut f sub) | (predicate, sub) <- alts ]
r
-- cmdActionPartial :: CommandDesc out -> Either String out
-- cmdActionPartial = maybe (Left err) Right . _cmd_out
-- where
-- err = "command is missing implementation!"
--
-- cmdAction :: CmdParser out () -> String -> Either String out
-- cmdAction b s = case runCmdParser Nothing s b of
-- (_, Right cmd) -> cmdActionPartial cmd
-- (_, Left (ParsingError (out:_) _)) -> Left $ out
-- _ -> error "whoops"
--
-- cmdActionRun :: (CommandDesc () -> ParsingError -> out)
-- -> CmdParser out ()
-- -> String
-- -> out
-- cmdActionRun f p s = case runCmdParser Nothing s p of
-- (cmd, Right out) -> case _cmd_out out of
-- Just o -> o
-- Nothing -> f cmd (ParsingError ["command is missing implementation!"] "")
-- (cmd, Left err) -> f cmd err
wrapBoundDesc :: ManyUpperBound -> PartDesc -> PartDesc
wrapBoundDesc ManyUpperBound1 = PartOptional
wrapBoundDesc ManyUpperBoundN = PartMany
descFixParents :: CommandDesc a -> CommandDesc a
descFixParents = descFixParentsWithTopM Nothing
-- descFixParentsWithTop :: String -> CommandDesc a -> CommandDesc a
-- descFixParentsWithTop s = descFixParentsWithTopM (Just (s, emptyCommandDesc))
descFixParentsWithTopM
:: Maybe (Maybe String, CommandDesc a) -> CommandDesc a -> CommandDesc a
descFixParentsWithTopM mTop topDesc = Data.Function.fix $ \fixed -> topDesc
{ _cmd_mParent = goUp fixed <$> (mTop <|> _cmd_mParent topDesc)
, _cmd_children = _cmd_children topDesc <&> goDown fixed
}
where
goUp
:: CommandDesc a
-> (Maybe String, CommandDesc a)
-> (Maybe String, CommandDesc a)
goUp child (childName, parent) =
(,) childName $ Data.Function.fix $ \fixed -> parent
{ _cmd_mParent = goUp fixed <$> _cmd_mParent parent
, _cmd_children = _cmd_children parent
<&> \(n, c) -> if n == childName then (n, child) else (n, c)
}
goDown
:: CommandDesc a
-> (Maybe String, CommandDesc a)
-> (Maybe String, CommandDesc a)
goDown parent (childName, child) =
(,) childName $ Data.Function.fix $ \fixed -> child
{ _cmd_mParent = Just (childName, parent)
, _cmd_children = _cmd_children child <&> goDown fixed
}
_tooLongText
:: Int -- max length
-> String -- alternative if actual length is bigger than max.
-> String -- text to print, if length is fine.
-> PP.Doc
_tooLongText i alt s = PP.text $ Bool.bool alt s $ null $ drop i s
butcher-1.3.3.2/src/UI/Butcher/Monadic/Internal/Types.hs 0000644 0000000 0000000 00000020304 07346545000 020770 0 ustar 00 0000000 0000000 {-# 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
, cmd_visibility
, emptyCommandDesc
, CmdParserF (..)
, CmdParser
, PartDesc (..)
, Input (..)
, ParsingError (..)
, addSuggestion
, ManyUpperBound (..)
, Visibility (..)
, CompletionItem (..)
)
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)
-- | Specifies whether we accept 0-1 or 0-n for @CmdParserPart@s.
data ManyUpperBound
= ManyUpperBound1
| ManyUpperBoundN
data Visibility = Visible | Hidden
deriving (Show, Eq)
data CmdParserF f out a
= CmdParserHelp PP.Doc a
| CmdParserSynopsis String a
| CmdParserPeekDesc (CommandDesc () -> a)
| CmdParserPeekInput (String -> a)
-- TODO: we can clean up this duplication by providing
-- a function (String -> Maybe (p, String)) -> (Input -> Maybe (p, Input)).
| forall p . Typeable p => CmdParserPart PartDesc (String -> Maybe (p, String)) (p -> f ()) (p -> a)
| forall p . Typeable p => CmdParserPartMany ManyUpperBound PartDesc (String -> Maybe (p, String)) (p -> f ()) ([p] -> a)
| forall p . Typeable p => CmdParserPartInp PartDesc (Input -> Maybe (p, Input)) (p -> f ()) (p -> a)
| forall p . Typeable p => CmdParserPartManyInp ManyUpperBound PartDesc (Input -> Maybe (p, Input)) (p -> f ()) ([p] -> a)
| CmdParserChild (Maybe String) Visibility (CmdParser f out ()) (f ()) a
| CmdParserImpl out a
| CmdParserReorderStart a
| CmdParserReorderStop a
| CmdParserGrouped String a
| CmdParserGroupEnd a
| forall p . Typeable p => CmdParserAlternatives PartDesc [((String -> Bool), CmdParser f out p)] (p -> a)
-- | The CmdParser monad type. It is a free monad over some functor but users
-- of butcher don't need to know more than that 'CmdParser' is a 'Monad'.
type CmdParser f out = Free (CmdParserF f out)
-- type CmdParser a = CmdParserM a a
-- 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 'UI.Butcher.Monadic.Pretty.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 (Maybe String, CommandDesc out)
, _cmd_synopsis :: Maybe PP.Doc
, _cmd_help :: Maybe PP.Doc
, _cmd_parts :: [PartDesc]
, _cmd_out :: Maybe out
, _cmd_children :: Deque (Maybe String, CommandDesc out)
-- we don't use a Map here because we'd like to
-- retain the order.
, _cmd_visibility :: Visibility
}
-- 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 [CompletionItem] PartDesc
| PartRedirect String -- name for the redirection
PartDesc
| PartReorder [PartDesc]
| PartMany PartDesc
| PartWithHelp PP.Doc PartDesc
| PartHidden PartDesc
deriving Show
addSuggestion :: Maybe [CompletionItem] -> PartDesc -> PartDesc
addSuggestion Nothing = id
addSuggestion (Just sugs) = PartSuggestion sugs
data CompletionItem
= CompletionString String
| CompletionDirectory
| CompletionFile
deriving Show
{-
command documentation structure
1. terminals. e.g. "--dry-run"
2. non-terminals, e.g. "FILES"
3. sequences, e.g. " 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
--
-- | Empty 'CommandDesc' value. Mostly for butcher-internal usage.
emptyCommandDesc :: CommandDesc out
emptyCommandDesc =
CommandDesc Nothing Nothing Nothing [] Nothing mempty Visible
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"
butcher-1.3.3.2/src/UI/Butcher/Monadic/Param.hs 0000644 0000000 0000000 00000031053 07346545000 017153 0 ustar 00 0000000 0000000
-- | Parameters are arguments of your current command that are not prefixed
-- by some flag. Typical commandline interface is something like
-- "PROGRAM [FLAGS] INPUT". Here, FLAGS are Flags in butcher, and INPUT is
-- a Param, in this case a String representing a path, for example.
module UI.Butcher.Monadic.Param
( Param(..)
, paramHelp
, paramHelpStr
, paramDefault
, paramSuggestions
, paramFile
, paramDirectory
, addParamRead
, addParamReadOpt
, addParamString
, addParamStringOpt
, addParamStrings
, addParamNoFlagString
, addParamNoFlagStringOpt
, addParamNoFlagStrings
, addParamRestOfInput
, addParamRestOfInputRaw
, -- * Deprecated for more consistent naming
addReadParam
, addReadParamOpt
, addStringParam
, addStringParamOpt
, addStringParams
, addRestOfInputStringParam
)
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
-- | param-description monoid. You probably won't need to use the constructor;
-- mzero or any (<>) of param(Help|Default|Suggestion) works well.
data Param p = Param
{ _param_default :: Maybe p
, _param_help :: Maybe PP.Doc
, _param_suggestions :: Maybe [CompletionItem]
}
appendParam :: Param p -> Param p -> Param p
appendParam (Param a1 b1 c1) (Param a2 b2 c2) = Param (a1 `f` a2)
(b1 <> b2)
(c1 <> c2)
where
f Nothing x = x
f x _ = x
instance Semigroup (Param p) where
(<>) = appendParam
instance Monoid (Param p) where
mempty = Param Nothing Nothing Nothing
mappend = (<>)
-- | Create a 'Param' with just a help text.
paramHelpStr :: String -> Param p
paramHelpStr s = mempty { _param_help = Just $ PP.text s }
-- | Create a 'Param' with just a help text.
paramHelp :: PP.Doc -> Param p
paramHelp h = mempty { _param_help = Just h }
-- | Create a 'Param' with just a default value.
paramDefault :: p -> Param p
paramDefault d = mempty { _param_default = Just d }
-- | Create a 'Param' with just a list of suggestion values.
paramSuggestions :: [String] -> Param p
paramSuggestions ss =
mempty { _param_suggestions = Just $ CompletionString <$> ss }
-- | Create a 'Param' that is a file path.
paramFile :: Param p
paramFile = mempty { _param_suggestions = Just [CompletionFile] }
-- | Create a 'Param' that is a directory path.
paramDirectory :: Param p
paramDirectory = mempty { _param_suggestions = Just [CompletionDirectory] }
-- | Add a parameter to the 'CmdParser' by making use of a 'Text.Read.Read'
-- instance. Take care not to use this to return Strings unless you really
-- want that, because it will require the quotation marks and escaping as
-- is normal for the Show/Read instances for String.
addParamRead :: forall f out a
. (Applicative f, Typeable a, Show a, Text.Read.Read a)
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out a
addParamRead = addReadParam
{-# DEPRECATED addReadParam "use 'addParamRead'" #-}
addReadParam :: forall f out a
. (Applicative f, Typeable a, Show a, Text.Read.Read a)
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out a
addReadParam name par = addCmdPart desc parseF
where
desc :: PartDesc
desc = addSuggestion (_param_suggestions par)
$ (maybe id PartWithHelp $ _param_help par)
$ (maybe id (PartDefault . show) $ _param_default par)
$ PartVariable name
parseF :: String -> Maybe (a, String)
parseF s = case Text.Read.reads s of
((x, ' ':r):_) -> Just (x, dropWhile Char.isSpace r)
((x, []):_) -> Just (x, [])
_ -> _param_default par <&> \x -> (x, s)
-- | Like addReadParam, but optional. I.e. if reading fails, returns Nothing.
addParamReadOpt :: forall f out a
. (Applicative f, Typeable a, Text.Read.Read a)
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out (Maybe a)
addParamReadOpt = addReadParamOpt
{-# DEPRECATED addReadParamOpt "use 'addParamReadOpt'" #-}
addReadParamOpt :: forall f out a
. (Applicative f, Typeable a, Text.Read.Read a)
=> String -- ^ paramater name, for use in usage/help texts
-> Param a -- ^ properties
-> CmdParser f out (Maybe a)
addReadParamOpt name par = addCmdPart desc parseF
where
desc :: PartDesc
desc = addSuggestion (_param_suggestions par)
$ PartOptional
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: String -> Maybe (Maybe a, String)
parseF s = case Text.Read.reads s of
((x, ' ':r):_) -> Just (Just x, dropWhile Char.isSpace r)
((x, []):_) -> Just (Just x, [])
_ -> Just (Nothing, s) -- TODO: we could warn about a default..
-- | Add a parameter that matches any string of non-space characters if
-- input==String, or one full argument if input==[String]. See the 'Input' doc
-- for this distinction.
addParamString
:: forall f out . (Applicative f)
=> String
-> Param String
-> CmdParser f out String
addParamString = addStringParam
{-# DEPRECATED addStringParam "use 'addParamString'" #-}
addStringParam
:: forall f out . (Applicative f)
=> String
-> Param String
-> CmdParser f out String
addStringParam name par = addCmdPartInp desc parseF
where
desc :: PartDesc
desc = addSuggestion (_param_suggestions par)
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: Input -> Maybe (String, Input)
parseF (InputString str)
= case break Char.isSpace $ dropWhile Char.isSpace str of
("", rest) -> _param_default par <&> \x -> (x, InputString rest)
(x, rest) -> Just (x, InputString rest)
parseF (InputArgs args) = case args of
(s1:sR) -> Just (s1, InputArgs sR)
[] -> _param_default par <&> \x -> (x, InputArgs args)
-- | Like 'addParamString', but optional, I.e. succeeding with Nothing if
-- there is no remaining input.
addParamStringOpt
:: forall f out . (Applicative f)
=> String
-> Param Void
-> CmdParser f out (Maybe String)
addParamStringOpt = addStringParamOpt
{-# DEPRECATED addStringParamOpt "use 'addParamStringOpt'" #-}
addStringParamOpt
:: forall f out . (Applicative f)
=> String
-> Param Void
-> CmdParser f out (Maybe String)
addStringParamOpt name par = addCmdPartInp desc parseF
where
desc :: PartDesc
desc = addSuggestion (_param_suggestions par)
$ PartOptional
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: Input -> Maybe (Maybe String, Input)
parseF (InputString str)
= case break Char.isSpace $ dropWhile Char.isSpace str of
("", rest) -> Just (Nothing, InputString rest)
(x, rest) -> Just (Just x, InputString rest)
parseF (InputArgs args) = case args of
(s1:sR) -> Just (Just s1, InputArgs sR)
[] -> Just (Nothing, InputArgs [])
-- | Add a parameter that matches any string of non-space characters if
-- input==String, or one full argument if input==[String]. See the 'Input' doc
-- for this distinction.
addParamStrings
:: forall f out
. (Applicative f)
=> String
-> Param Void
-> CmdParser f out [String]
addParamStrings = addStringParams
{-# DEPRECATED addStringParams "use 'addParamStrings'" #-}
addStringParams
:: forall f out
. (Applicative f)
=> String
-> Param Void
-> CmdParser f out [String]
addStringParams name par = addCmdPartManyInp ManyUpperBoundN desc parseF
where
desc :: PartDesc
desc =
addSuggestion (_param_suggestions par)
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: Input -> Maybe (String, Input)
parseF (InputString str) =
case break Char.isSpace $ dropWhile Char.isSpace str of
("", _ ) -> Nothing
(x , rest) -> Just (x, InputString rest)
parseF (InputArgs args) = case args of
(s1:sR) -> Just (s1, InputArgs sR)
[] -> Nothing
-- | Like 'addParamString' but does not match strings starting with a dash.
-- This prevents misinterpretation of flags as params.
addParamNoFlagString
:: forall f out . (Applicative f)
=> String
-> Param String
-> CmdParser f out String
addParamNoFlagString name par = addCmdPartInp desc parseF
where
desc :: PartDesc
desc =
addSuggestion (_param_suggestions par)
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: Input -> Maybe (String, Input)
parseF (InputString str) =
case break Char.isSpace $ dropWhile Char.isSpace str of
("" , rest) -> _param_default par <&> \x -> (x, InputString rest)
('-':_, _ ) -> _param_default par <&> \x -> (x, InputString str)
(x , rest) -> Just (x, InputString rest)
parseF (InputArgs args) = case args of
[] -> _param_default par <&> \x -> (x, InputArgs args)
(('-':_):_ ) -> _param_default par <&> \x -> (x, InputArgs args)
(s1 :sR) -> Just (s1, InputArgs sR)
-- | Like 'addParamStringOpt' but does not match strings starting with a dash.
-- This prevents misinterpretation of flags as params.
addParamNoFlagStringOpt
:: forall f out
. (Applicative f)
=> String
-> Param Void
-> CmdParser f out (Maybe String)
addParamNoFlagStringOpt name par = addCmdPartInp desc parseF
where
desc :: PartDesc
desc =
PartOptional $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name
parseF :: Input -> Maybe (Maybe String, Input)
parseF (InputString str) =
case break Char.isSpace $ dropWhile Char.isSpace str of
("" , rest) -> Just (Nothing, InputString rest)
('-':_, _ ) -> Just (Nothing, InputString str)
(x , rest) -> Just (Just x, InputString rest)
parseF (InputArgs args) = case args of
[] -> Just (Nothing, InputArgs [])
(('-':_):_ ) -> Just (Nothing, InputArgs args)
(s1 :sR) -> Just (Just s1, InputArgs sR)
-- | Like 'addParamStrings' but does not match strings starting with a dash.
-- This prevents misinterpretation of flags as params.
addParamNoFlagStrings
:: forall f out
. (Applicative f)
=> String
-> Param Void
-> CmdParser f out [String]
addParamNoFlagStrings name par = addCmdPartManyInp ManyUpperBoundN desc parseF
where
desc :: PartDesc
desc =
addSuggestion (_param_suggestions par)
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: Input -> Maybe (String, Input)
parseF (InputString str) =
case break Char.isSpace $ dropWhile Char.isSpace str of
("" , _ ) -> Nothing
('-':_, _ ) -> Nothing
(x , rest) -> Just (x, InputString rest)
parseF (InputArgs args) = case args of
[] -> Nothing
(('-':_):_ ) -> Nothing
(s1 :sR) -> Just (s1, InputArgs sR)
-- | Add a parameter that consumes _all_ remaining input. Typical usecase is
-- after a "--" as common in certain (unix?) commandline tools.
addParamRestOfInput
:: forall f out . (Applicative f)
=> String
-> Param Void
-> CmdParser f out String
addParamRestOfInput = addRestOfInputStringParam
{-# DEPRECATED addRestOfInputStringParam "use 'addParamRestOfInput'" #-}
addRestOfInputStringParam
:: forall f out
. (Applicative f)
=> String
-> Param Void
-> CmdParser f out String
addRestOfInputStringParam name par = addCmdPartInp desc parseF
where
desc :: PartDesc
desc =
addSuggestion (_param_suggestions par)
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: Input -> Maybe (String, Input)
parseF (InputString str ) = Just (str, InputString "")
parseF (InputArgs args) = Just (List.unwords args, InputArgs [])
-- | Add a parameter that consumes _all_ remaining input, returning a raw
-- 'Input' value.
addParamRestOfInputRaw
:: forall f out . (Applicative f)
=> String
-> Param Void
-> CmdParser f out Input
addParamRestOfInputRaw name par = addCmdPartInp desc parseF
where
desc :: PartDesc
desc =
addSuggestion (_param_suggestions par)
$ (maybe id PartWithHelp $ _param_help par)
$ PartVariable name
parseF :: Input -> Maybe (Input, Input)
parseF i@InputString{} = Just (i, InputString "")
parseF i@InputArgs{} = Just (i, InputArgs [])
butcher-1.3.3.2/src/UI/Butcher/Monadic/Pretty.hs 0000644 0000000 0000000 00000031651 07346545000 017406 0 ustar 00 0000000 0000000
-- | Pretty-print of CommandDescs. To explain what the different functions
-- do, we will use an example CmdParser. The CommandDesc derived from that
-- CmdParser will serve as example input to the functions in this module.
--
-- > main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do
-- >
-- > addCmdSynopsis "a simple butcher example program"
-- > addCmdHelpStr "a very long help document"
-- >
-- > addCmd "version" $ do
-- > porcelain <- addSimpleBoolFlag "" ["porcelain"]
-- > (flagHelpStr "print nothing but the numeric version")
-- > addCmdHelpStr "prints the version of this program"
-- > addCmdImpl $ putStrLn $ if porcelain
-- > then "0.0.0.999"
-- > else "example, version 0.0.0.999"
-- >
-- > addCmd "help" $ addCmdImpl $ print $ ppHelpShallow helpDesc
-- >
-- > short <- addSimpleBoolFlag "" ["short"] (flagHelpStr "make the greeting short")
-- > name <- addStringParam "NAME"
-- > (paramHelpStr "your name, so you can be greeted properly")
-- >
-- > addCmdImpl $ do
-- > if short
-- > then putStrLn $ "hi, " ++ name ++ "!"
-- > else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!"
module UI.Butcher.Monadic.Pretty
( ppUsage
, ppUsageShortSub
, ppUsageAt
, ppHelpShallow
, ppHelpDepthOne
, ppUsageWithHelp
, ppPartDescUsage
, ppPartDescHeader
, parsingErrorString
, descendDescTo
)
where
#include "prelude.inc"
import Control.Monad.Free
import qualified Control.Monad.Trans.MultiRWS.Strict
as MultiRWSS
import qualified Control.Monad.Trans.MultiState.Strict
as MultiStateS
import qualified Text.PrettyPrint as PP
import Text.PrettyPrint ( (<+>)
, ($$)
, ($+$)
)
import Data.HList.ContainsType
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
-- | ppUsage exampleDesc yields:
--
-- > example [--short] NAME [version | help]
ppUsage :: CommandDesc a -> PP.Doc
ppUsage (CommandDesc mParent _syn _help parts out children _hidden) =
pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]
where
pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
pparents Nothing = PP.empty
pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
partDocs = Maybe.mapMaybe ppPartDescUsage parts
visibleChildren =
[ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
subsDoc = case out of
_ | null visibleChildren -> PP.empty
Nothing | null parts -> subDoc
| otherwise -> PP.parens $ subDoc
Just{} -> PP.brackets $ subDoc
subDoc =
PP.fcat
$ PP.punctuate (PP.text " | ")
$ Data.Foldable.toList
$ (PP.text . fst)
<$> visibleChildren
-- | ppUsageShortSub exampleDesc yields:
--
-- > example [--short] NAME
--
-- I.e. Subcommands are abbreviated using the @@ label, instead
-- of being listed.
ppUsageShortSub :: CommandDesc a -> PP.Doc
ppUsageShortSub (CommandDesc mParent _syn _help parts out children _hidden) =
pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]
where
pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
pparents Nothing = PP.empty
pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
partDocs = Maybe.mapMaybe ppPartDescUsage parts
visibleChildren =
[ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
subsDoc = case out of
_ | null visibleChildren -> PP.empty
Nothing -> subDoc
Just{} -> PP.brackets $ subDoc
subDoc = if null visibleChildren then PP.empty else PP.text ""
-- | ppUsageWithHelp exampleDesc yields:
--
-- > example [--short] NAME
-- > [version | help]: a simple butcher example program
--
-- And yes, the line break is not optimal in this instance with default print.
ppUsageWithHelp :: CommandDesc a -> PP.Doc
ppUsageWithHelp (CommandDesc mParent _syn help parts out children _hidden) =
pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc
where
pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
pparents Nothing = PP.empty
pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
partDocs = Maybe.mapMaybe ppPartDescUsage parts
subsDoc = case out of
_ | null children -> PP.empty -- TODO: remove debug
Nothing | null parts -> subDoc
| otherwise -> PP.parens $ subDoc
Just{} -> PP.brackets $ subDoc
subDoc =
PP.fcat
$ PP.punctuate (PP.text " | ")
$ Data.Foldable.toList
$ [ PP.text n | (Just n, c) <- children, _cmd_visibility c == Visible ]
helpDoc = case help of
Nothing -> PP.empty
Just h -> PP.text ":" PP.<+> h
-- | > ppUsageAt [] = ppUsage
--
-- fromJust $ ppUsageAt ["version"] exampleDesc yields:
--
-- > example version [--porcelain]
ppUsageAt
:: [String] -- (sub)command sequence
-> CommandDesc a
-> Maybe PP.Doc
ppUsageAt strings desc = ppUsage <$> descendDescTo strings desc
-- | Access a child command's CommandDesc.
descendDescTo :: [String] -> CommandDesc a -> Maybe (CommandDesc a)
descendDescTo strings desc = case strings of
[] -> Just desc
(s : sr) -> do -- Maybe
(_, childDesc) <- find ((Just s ==) . fst) (_cmd_children desc)
descendDescTo sr childDesc
-- | ppHelpShallow exampleDesc yields:
--
-- > NAME
-- >
-- > example - a simple butcher example program
-- >
-- > USAGE
-- >
-- > example [--short] NAME [version | help]
-- >
-- > DESCRIPTION
-- >
-- > a very long help document
-- >
-- > ARGUMENTS
-- >
-- > --short make the greeting short
-- > NAME your name, so you can be greeted properly
ppHelpShallow :: CommandDesc a -> PP.Doc
ppHelpShallow desc =
nameSection
$+$ usageSection
$+$ descriptionSection
$+$ partsSection
$+$ PP.text ""
where
CommandDesc mParent syn help parts _out _children _hidden = desc
nameSection = case mParent of
Nothing -> PP.empty
Just{} ->
PP.text "NAME"
$+$ PP.text ""
$+$ PP.nest
2
(case syn of
Nothing -> pparents mParent
Just s -> pparents mParent <+> PP.text "-" <+> s
)
$+$ PP.text ""
pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
pparents Nothing = PP.empty
pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
usageSection = PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsage desc)
descriptionSection = case help of
Nothing -> PP.empty
Just h ->
PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h
partsSection = if null partsTuples
then PP.empty
else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest
2
(PP.vcat partsTuples)
partsTuples :: [PP.Doc]
partsTuples = parts >>= go
where
go = \case
PartLiteral{} -> []
PartVariable{} -> []
PartOptional p -> go p
PartAlts ps -> ps >>= go
PartSeq ps -> ps >>= go
PartDefault _ p -> go p
PartSuggestion _ p -> go p
PartRedirect s p ->
[PP.text s $$ PP.nest 20 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)]
++ (PP.nest 2 <$> go p)
PartReorder ps -> ps >>= go
PartMany p -> go p
PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
PartHidden{} -> []
-- | ppHelpDepthOne exampleDesc yields:
--
-- > NAME
-- >
-- > example - a simple butcher example program
-- >
-- > USAGE
-- >
-- > example [--short] NAME
-- >
-- > DESCRIPTION
-- >
-- > a very long help document
-- >
-- > COMMANDS
-- >
-- > version
-- > help
-- >
-- > ARGUMENTS
-- >
-- > --short make the greeting short
-- > NAME your name, so you can be greeted properly
ppHelpDepthOne :: CommandDesc a -> PP.Doc
ppHelpDepthOne desc =
nameSection
$+$ usageSection
$+$ descriptionSection
$+$ commandSection
$+$ partsSection
$+$ PP.text ""
where
CommandDesc mParent syn help parts _out children _hidden = desc
nameSection = case mParent of
Nothing -> PP.empty
Just{} ->
PP.text "NAME"
$+$ PP.text ""
$+$ PP.nest
2
(case syn of
Nothing -> pparents mParent
Just s -> pparents mParent <+> PP.text "-" <+> s
)
$+$ PP.text ""
pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
pparents Nothing = PP.empty
pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
usageSection =
PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsageShortSub desc)
descriptionSection = case help of
Nothing -> PP.empty
Just h ->
PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h
visibleChildren =
[ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ]
childDescs = visibleChildren <&> \(n, c) ->
PP.text n $$ PP.nest 20 (Maybe.fromMaybe PP.empty (_cmd_synopsis c))
commandSection = if null visibleChildren
then PP.empty
else PP.text "" $+$ PP.text "COMMANDS" $+$ PP.text "" $+$ PP.nest
2
(PP.vcat $ Data.Foldable.toList childDescs)
partsSection = if null partsTuples
then PP.empty
else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest
2
(PP.vcat partsTuples)
partsTuples :: [PP.Doc]
partsTuples = parts >>= go
where
go = \case
PartLiteral{} -> []
PartVariable{} -> []
PartOptional p -> go p
PartAlts ps -> ps >>= go
PartSeq ps -> ps >>= go
PartDefault _ p -> go p
PartSuggestion _ p -> go p
PartRedirect s p ->
[PP.text s $$ PP.nest 20 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)]
++ (PP.nest 2 <$> go p)
PartReorder ps -> ps >>= go
PartMany p -> go p
PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
PartHidden{} -> []
-- | Internal helper; users probably won't need this.
ppPartDescUsage :: PartDesc -> Maybe PP.Doc
ppPartDescUsage = \case
PartLiteral s -> Just $ PP.text s
PartVariable s -> Just $ PP.text s
PartOptional p -> PP.brackets <$> rec p
PartAlts ps ->
[ PP.fcat $ PP.punctuate (PP.text ",") ds
| let ds = Maybe.mapMaybe rec ps
, not (null ds)
]
PartSeq ps -> [ PP.fsep ds | let ds = Maybe.mapMaybe rec ps, not (null ds) ]
PartDefault _ p -> PP.brackets <$> rec p
PartSuggestion sgs p -> rec p <&> \d ->
case [ PP.text s | CompletionString s <- sgs ] of
[] -> d
sgsDocs ->
PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ sgsDocs ++ [d]
PartRedirect s _ -> Just $ PP.text s
PartMany p -> rec p <&> (PP.<> PP.text "+")
PartWithHelp _ p -> rec p
PartReorder ps ->
let flags = [ d | PartMany d <- ps ]
params = filter
(\case
PartMany{} -> False
_ -> True
)
ps
in Just $ PP.sep
[ (PP.fsep $ PP.brackets <$> Maybe.mapMaybe rec flags)
, PP.fsep (Maybe.mapMaybe rec params)
]
PartHidden{} -> Nothing
where rec = ppPartDescUsage
-- | Internal helper; users probably won't need this.
ppPartDescHeader :: PartDesc -> PP.Doc
ppPartDescHeader = \case
PartLiteral s -> PP.text s
PartVariable s -> PP.text s
PartOptional ds' -> rec ds'
PartAlts alts -> PP.hcat $ List.intersperse (PP.text ",") $ rec <$> alts
PartDefault _ d -> rec d
PartSuggestion _ d -> rec d
PartRedirect s _ -> PP.text s
PartMany ds -> rec ds
PartWithHelp _ d -> rec d
PartSeq ds -> PP.hsep $ rec <$> ds
PartReorder ds -> PP.vcat $ rec <$> ds
PartHidden d -> rec d
where rec = ppPartDescHeader
-- | Simple conversion from 'ParsingError' to 'String'.
parsingErrorString :: ParsingError -> String
parsingErrorString (ParsingError mess remaining) =
"error parsing arguments: " ++ messStr ++ remainingStr
where
messStr = case mess of
[] -> ""
(m : _) -> m ++ " "
remainingStr = case remaining of
InputString "" -> "at the end of input."
InputString str -> case show str of
s | length s < 42 -> "at: " ++ s ++ "."
s -> "at: " ++ take 40 s ++ "..\"."
InputArgs [] -> "at the end of input"
InputArgs xs -> case List.unwords $ show <$> xs of
s | length s < 42 -> "at: " ++ s ++ "."
s -> "at: " ++ take 40 s ++ "..\"."
butcher-1.3.3.2/src/UI/Butcher/Monadic/Types.hs 0000644 0000000 0000000 00000000625 07346545000 017220 0 ustar 00 0000000 0000000 -- this module only re-exports the appropriate user-facing stuff from the
-- internal Types module.
-- | Types used in the butcher interface.
module UI.Butcher.Monadic.Types
( CommandDesc(..)
, cmd_out
, CmdParser
, Input (..)
, ParsingError (..)
, PartDesc(..)
, emptyCommandDesc
, Visibility (..)
)
where
#include "prelude.inc"
import UI.Butcher.Monadic.Internal.Types
butcher-1.3.3.2/srcinc/ 0000755 0000000 0000000 00000000000 07346545000 012764 5 ustar 00 0000000 0000000 butcher-1.3.3.2/srcinc/prelude.inc 0000755 0000000 0000000 00000041704 07346545000 015130 0 ustar 00 0000000 0000000 -- import qualified Data.Graph
-- import qualified Data.IntMap
-- import qualified Data.IntMap.Lazy
-- import qualified Data.IntMap.Strict
-- import qualified Data.IntSet
-- import qualified Data.Map
-- import qualified Data.Map.Lazy
-- import qualified Data.Map.Strict
-- import qualified Data.Sequence
-- import qualified Data.Set
-- import qualified Data.Tree
-- import qualified Control.Concurrent.Extra
-- import qualified Control.Exception.Extra
-- import qualified Control.Monad.Extra
-- import qualified Data.Either.Extra
-- import qualified Data.IORef.Extra
-- import qualified Data.List.Extra
-- import qualified Data.Tuple.Extra
-- import qualified Data.Version.Extra
-- import qualified Numeric.Extra
-- import qualified System.Directory.Extra
-- import qualified System.Environment.Extra
-- import qualified System.IO.Extra
-- import qualified System.Info.Extra
-- import qualified System.Process.Extra
-- import qualified System.Time.Extra
-- import qualified Control.Monad.Trans.MultiRWS.Lazy
-- import qualified Control.Monad.Trans.MultiRWS.Strict
-- import qualified Control.Monad.Trans.MultiReader
-- import qualified Control.Monad.Trans.MultiReader.Class
-- import qualified Control.Monad.Trans.MultiReader.Lazy
-- import qualified Control.Monad.Trans.MultiReader.Strict
-- import qualified Control.Monad.Trans.MultiState
-- import qualified Control.Monad.Trans.MultiState.Class
-- import qualified Control.Monad.Trans.MultiState.Lazy
-- import qualified Control.Monad.Trans.MultiState.Strict
-- import qualified Control.Monad.Trans.MultiWriter
-- import qualified Control.Monad.Trans.MultiWriter.Class
-- import qualified Control.Monad.Trans.MultiWriter.Lazy
-- import qualified Control.Monad.Trans.MultiWriter.Strict
-- import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
-- import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL
-- import qualified Data.Bifunctor
-- import qualified Data.Bits
-- import qualified Data.Bool
-- import qualified Data.Char
-- import qualified Data.Coerce
-- import qualified Data.Complex
-- import qualified Data.Data
-- import qualified Data.Dynamic
import qualified Data.Either
-- import qualified Data.Eq
-- import qualified Data.Fixed
import qualified Data.Foldable
import qualified Data.Function
-- import qualified Data.Functor
-- import qualified Data.Functor.Identity
-- import qualified Data.IORef
-- import qualified Data.Int
-- import qualified Data.Ix
-- import qualified Data.List
-- import qualified Data.Maybe
import qualified Data.Monoid
-- import qualified Data.Ord
-- import qualified Data.Proxy
-- import qualified Debug.Trace
-- import qualified Numeric
-- import qualified Numeric.Natural
import qualified System.Environment
-- import qualified System.IO
import qualified Text.Read
-- import qualified Text.Show
-- import qualified Unsafe.Coerce
import qualified Data.Bool as Bool
import qualified Data.Char as Char
import qualified Data.Maybe as Maybe
import qualified Control.Monad.Trans.Writer.Strict as WriterS
#if MIN_VERSION_base(4,9,0)
import qualified GHC.OldList as List
#else
import qualified Data.List as List
#endif
-- import qualified Data.IntMap as IntMap
-- import qualified Data.IntMap.Strict as IntMapS
import qualified Data.Map.Strict as MapS
import qualified Data.Map.Lazy as MapL
-- import qualified Data.Sequence as Seq
-- import qualified Data.Set as Set
import qualified Control.Monad.RWS.Class as RWS.Class
import qualified Control.Monad.Reader.Class as Reader.Class
import qualified Control.Monad.State.Class as State.Class
import qualified Control.Monad.Writer.Class as Writer.Class
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.State.Lazy as StateL
import qualified Control.Monad.Trans.State.Strict as StateS
import Data.Functor.Identity ( Identity(..) )
import Control.Concurrent.Chan ( Chan )
-- import Control.Concurrent.MVar ( MVar )
-- import Control.Monad.ST ( ST )
-- import Data.IORef ( IORef )
import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), First(..), Last(..), Alt(..), )
-- import Data.Ord ( Ordering(..), Down(..) )
-- import Data.Ratio ( Ratio, Rational )
import Data.Void ( Void )
-- import Data.Proxy ( Proxy(..) )
import Data.Sequence ( Seq )
import Data.Semigroup ( Semigroup(..) )
import Data.Map ( Map )
import Data.Set ( Set )
import Deque.Lazy ( Deque )
import qualified Deque.Lazy as Deque
import Prelude ( Char
, String
, Int
, Integer
, Word
, Float
, Double
, Bool (..)
, undefined
, Eq (..)
, Ord (..)
, Enum (..)
, Bounded (..)
, Maybe (..)
, Either (..)
, IO
, (<$>)
, (.)
, ($)
, ($!)
, Num (..)
, Integral (..)
, Fractional (..)
, Floating (..)
, RealFrac (..)
, RealFloat (..)
, fromIntegral
, error
, foldr
, foldl
, foldr1
, id
, map
, subtract
, putStrLn
, putStr
, Show (..)
, print
, fst
, snd
, (++)
, not
, (&&)
, (||)
, curry
, uncurry
, Ordering (..)
, flip
, const
, seq
, reverse
, otherwise
, traverse
, realToFrac
, or
, and
, head
, any
, (^)
, Foldable
, Traversable
, mempty
, maybe
, Applicative(..)
, (<$)
, Monoid(..)
, either
)
import Data.Foldable ( foldl'
, foldr'
, fold
, asum
)
import Data.List ( partition
, null
, elem
, notElem
, minimum
, maximum
, length
, all
, take
, drop
, find
, sum
, zip
, zip3
, zipWith
, repeat
, replicate
, iterate
, nub
, filter
, intersperse
, intercalate
, isSuffixOf
, isPrefixOf
, dropWhile
, takeWhile
, unzip
, break
, transpose
, sortBy
, mapAccumL
, mapAccumR
, uncons
)
-- import Data.Tuple ( swap
-- )
-- import Data.Char ( ord
-- , chr
-- )
-- import Data.Word ( Word32
-- )
-- import Data.Ord ( comparing
-- , Down (..)
-- )
-- import Data.Either ( either
-- )
-- import Data.Ratio ( Ratio
-- , (%)
-- , numerator
-- , denominator
-- )
-- import Text.Read ( readMaybe
-- )
import Control.Monad ( Functor (..)
, Monad (..)
, MonadPlus (..)
, mapM
, mapM_
, forM
, forM_
, sequence
, sequence_
, (=<<)
, (>=>)
, (<=<)
, forever
, void
, join
, replicateM
, replicateM_
, guard
, when
, unless
, liftM
, liftM2
, liftM3
, liftM4
, liftM5
, filterM
, (<$!>)
)
import Control.Applicative ( Applicative (..)
, Alternative (..)
)
-- import Foreign.Storable ( Storable )
-- import GHC.Exts ( Constraint )
-- import Control.Concurrent ( threadDelay
-- , forkIO
-- , forkOS
-- )
-- import Control.Concurrent.MVar ( MVar
-- , newEmptyMVar
-- , newMVar
-- , putMVar
-- , readMVar
-- , takeMVar
-- , swapMVar
-- )
-- import Control.Exception ( evaluate
-- , bracket
-- , assert
-- )
-- import Debug.Trace ( trace
-- , traceId
-- , traceShowId
-- , traceShow
-- , traceStack
-- , traceShowId
-- , traceIO
-- , traceM
-- , traceShowM
-- )
-- import Foreign.ForeignPtr ( ForeignPtr
-- )
-- import Data.Monoid ( Monoid
-- , mempty
-- , mconcat
-- )
-- import Data.Bifunctor ( bimap )
import Data.Functor ( (<$), ($>) )
-- import Data.Function ( (&) )
-- import System.IO ( hFlush
-- , stdout
-- )
import Data.Typeable ( Typeable
, cast
, Proxy(..)
)
import Control.Arrow ( first
, second
, (***)
, (&&&)
, (>>>)
, (<<<)
)
-- import Data.Functor.Identity ( Identity (..)
-- )
-- import Data.Proxy ( Proxy (..)
-- )
-- import Data.Version ( showVersion
-- )
-- import Data.List.Extra ( nubOrd
-- , stripSuffix
-- )
-- import Control.Monad.Extra ( whenM
-- , unlessM
-- , ifM
-- , notM
-- , orM
-- , andM
-- , anyM
-- , allM
-- )
-- import Data.Tree ( Tree(..)
-- )
import Control.Monad.Trans.MultiRWS ( MonadMultiReader(..)
, MonadMultiWriter(..)
, MonadMultiState(..)
, mGet
)
-- import Control.Monad.Trans.MultiReader ( runMultiReaderTNil
-- , runMultiReaderTNil_
-- , MultiReaderT (..)
-- , MultiReader
-- , MultiReaderTNull
-- )
-- import Control.Monad.IO.Class ( MonadIO (..)
-- )
import Control.Monad.Trans.Class ( lift
)
-- import Control.Monad.Trans.Maybe ( MaybeT (..)
-- )
import Lens.Micro ( (<&>)
)