butcher-1.3.3.2/0000755000000000000000000000000007346545000011503 5ustar0000000000000000butcher-1.3.3.2/ChangeLog.md0000755000000000000000000000452707346545000013667 0ustar0000000000000000# 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/LICENSE0000644000000000000000000000277207346545000012520 0ustar0000000000000000Copyright (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.md0000755000000000000000000001765707346545000013005 0ustar0000000000000000# 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.hs0000644000000000000000000000005607346545000013140 0ustar0000000000000000import Distribution.Simple main = defaultMain butcher-1.3.3.2/butcher.cabal0000644000000000000000000000611607346545000014127 0ustar0000000000000000name: 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/0000755000000000000000000000000007346545000013432 5ustar0000000000000000butcher-1.3.3.2/src-tests/TestMain.hs0000644000000000000000000002625707346545000015526 0ustar0000000000000000module 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/0000755000000000000000000000000007346545000014203 5ustar0000000000000000butcher-1.3.3.2/src/UI/Butcher/Monadic.hs0000644000000000000000000001255207346545000016116 0ustar0000000000000000-- | 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/0000755000000000000000000000000007346545000015555 5ustar0000000000000000butcher-1.3.3.2/src/UI/Butcher/Monadic/BuiltinCommands.hs0000644000000000000000000001406707346545000021211 0ustar0000000000000000-- | 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.hs0000644000000000000000000000513007346545000017466 0ustar0000000000000000-- 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.hs0000644000000000000000000004122707346545000016770 0ustar0000000000000000{-# 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.hs0000644000000000000000000001067407346545000016430 0ustar0000000000000000-- | 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.hs0000644000000000000000000001752207346545000020375 0ustar0000000000000000-- | 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/0000755000000000000000000000000007346545000017331 5ustar0000000000000000butcher-1.3.3.2/src/UI/Butcher/Monadic/Internal/Core.hs0000644000000000000000000014076007346545000020565 0ustar0000000000000000{-# 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.hs0000644000000000000000000002030407346545000020770 0ustar0000000000000000{-# 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.hs0000644000000000000000000003105307346545000017153 0ustar0000000000000000 -- | 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.hs0000644000000000000000000003165107346545000017406 0ustar0000000000000000 -- | 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.hs0000644000000000000000000000062507346545000017220 0ustar0000000000000000-- 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/0000755000000000000000000000000007346545000012764 5ustar0000000000000000butcher-1.3.3.2/srcinc/prelude.inc0000755000000000000000000004170407346545000015130 0ustar0000000000000000-- 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 ( (<&>) )