diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for cmdparse-applicative + +## 1.1.0.0 -- May 2017 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Lennart Spitzner + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Lennart Spitzner nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,241 @@ +# 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 + + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/butcher.cabal b/butcher.cabal new file mode 100644 --- /dev/null +++ b/butcher.cabal @@ -0,0 +1,158 @@ +name: butcher +version: 1.1.0.0 +synopsis: Chops a command or program invocation into digestable pieces. +description: See the README (it is properly formatted on github) +license: BSD3 +license-file: LICENSE +author: Lennart Spitzner +maintainer: lsp@informatik.uni-kiel.de +copyright: Copyright (C) 2016-2017 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 +} + +flag butcher-dev + description: dev options + default: False + manual: True + +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.BuiltinCommands + other-modules: UI.Butcher.Monadic.Internal.Types + UI.Butcher.Monadic.Internal.Core + build-depends: + { base >=4.8 && <4.10 + , free + , unsafe + , microlens + , microlens-th + , multistate + , pretty + , containers + , either + , transformers + , mtl + , extra + , void + , bifunctors + , deque + } + if flag(butcher-dev) { + build-depends: + hspec + } + 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 + -fno-spec-constr + -j + -fno-warn-unused-imports + -fno-warn-orphans + } + if flag(butcher-dev) { + ghc-options: -O0 -Werror -fprof-auto -fprof-cafs + } + include-dirs: + srcinc + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: + { base >=4.8 && <4.10 + , butcher + , free + , unsafe + , microlens + , microlens-th + , multistate + , pretty + , containers + , either + , transformers + , mtl + , extra + , deque + } + if flag(butcher-dev) { + buildable: True + build-depends: + hspec + } else { + buildable: False + } + ghc-options: -Wall + main-is: TestMain.hs + other-modules: + hs-source-dirs: src-tests + default-extensions: { + CPP + + NoImplicitPrelude + + GADTs + + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + } + ghc-options: { + -Wall + -fno-spec-constr + -j + -fno-warn-unused-imports + -fno-warn-orphans + } + if flag(butcher-dev) { + ghc-options: -Werror -fprof-auto -fprof-cafs -O0 + } + diff --git a/src-tests/TestMain.hs b/src-tests/TestMain.hs new file mode 100644 --- /dev/null +++ b/src-tests/TestMain.hs @@ -0,0 +1,187 @@ +module Main where + + + +#include "prelude.inc" + +import Test.Hspec + +-- import NeatInterpolation + +import UI.Butcher.Monadic +import UI.Butcher.Monadic.Types + + + +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.Combinators.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.Combinators.isLeft -- no reordering + it "flag 6" $ testRun testCmd1 "abc -g -f" `shouldSatisfy` Data.Either.Combinators.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 + + + + +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) + + +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 + +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) diff --git a/src/UI/Butcher/Monadic.hs b/src/UI/Butcher/Monadic.hs new file mode 100644 --- /dev/null +++ b/src/UI/Butcher/Monadic.hs @@ -0,0 +1,167 @@ +-- | Main module of the butcher interface. It reexports 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 + -- , cmds + -- , sample + -- , test + -- , test2 + -- , test3 + -- * Builtin commands + , addHelpCommand + , addButcherDebugCommand + , mapOut + ) +where + + + +#include "prelude.inc" + +import UI.Butcher.Monadic.Types +import UI.Butcher.Monadic.Internal.Types +import UI.Butcher.Monadic.Command +import UI.Butcher.Monadic.BuiltinCommands +import UI.Butcher.Monadic.Internal.Core +import UI.Butcher.Monadic.Pretty +import UI.Butcher.Monadic.IO + +import qualified Text.PrettyPrint as PP + + + +#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, returning @Nothing@ in +-- any error case. +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 <- addReadParam "STRING" (paramHelpStr "the string to print") + addCmdImpl $ do + putStrLn str + addCmd "hello" $ do + addCmdHelpStr "greet the user" + reorderStart + short <- addSimpleBoolFlag "" ["short"] mempty + name <- addReadParam "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 diff --git a/src/UI/Butcher/Monadic/BuiltinCommands.hs b/src/UI/Butcher/Monadic/BuiltinCommands.hs new file mode 100644 --- /dev/null +++ b/src/UI/Butcher/Monadic/BuiltinCommands.hs @@ -0,0 +1,68 @@ +-- | Some CmdParser actions that add predefined commands. +module UI.Butcher.Monadic.BuiltinCommands + ( addHelpCommand + , addHelpCommandShallow + , addButcherDebugCommand + ) +where + + + +#include "prelude.inc" +import Control.Monad.Free +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS + +import qualified Text.PrettyPrint as PP + +import Data.HList.ContainsType + +import UI.Butcher.Monadic.Internal.Types +import UI.Butcher.Monadic.Internal.Core +import UI.Butcher.Monadic.Pretty +import UI.Butcher.Monadic.Param + +import System.IO + + + +-- | Adds a proper full help command. To obtain the 'CommandDesc' value, see +-- 'UI.Butcher.Monadic.cmdRunParserWithHelpDesc' or +-- 'UI.Butcher.Monadic.IO.mainFromCmdParserWithHelpDesc'. +addHelpCommand :: Applicative f => CommandDesc () -> CmdParser f (IO ()) () +addHelpCommand desc = addCmd "help" $ do + rest <- addRestOfInputStringParam "SUBCOMMAND(s)" mempty + addCmdImpl $ do + let parentDesc = maybe undefined snd (_cmd_mParent desc) + let restWords = List.words rest + let descent :: [String] -> CommandDesc a -> CommandDesc a + descent [] curDesc = curDesc + descent (w:wr) curDesc = + case List.lookup w $ Data.Foldable.toList $ _cmd_children curDesc of + Nothing -> curDesc + Just child -> descent wr child + print $ ppHelpShallow $ descent restWords parentDesc + +-- | Adds a help command that prints help for the command currently in context. +-- +-- This version does _not_ include further childcommands, i.e. "help foo" will +-- not print the help for subcommand "foo". +-- +-- This also yields slightly different output depending on if it is used +-- before or after adding other subcommands. In general 'addHelpCommand' +-- should be preferred. +addHelpCommandShallow :: Applicative f => CmdParser f (IO ()) () +addHelpCommandShallow = addCmd "help" $ do + desc <- peekCmdDesc + _rest <- addRestOfInputStringParam "SUBCOMMAND(s)" mempty + addCmdImpl $ do + let parentDesc = maybe undefined snd (_cmd_mParent desc) + print $ ppHelpShallow $ parentDesc + +-- | Prints the raw CommandDesc structure. +addButcherDebugCommand :: Applicative f => CmdParser f (IO ()) () +addButcherDebugCommand = addCmd "butcherdebug" $ do + desc <- peekCmdDesc + addCmdImpl $ do + print $ maybe undefined snd (_cmd_mParent desc) + diff --git a/src/UI/Butcher/Monadic/Command.hs b/src/UI/Butcher/Monadic/Command.hs new file mode 100644 --- /dev/null +++ b/src/UI/Butcher/Monadic/Command.hs @@ -0,0 +1,95 @@ +-- this module only re-exports the appropriate user-facing stuff from some +-- other modules. +-- | Building-blocks of a CmdParser. +-- +-- The simplest sensible CmdParser is just +-- +-- > addCmdImpl $ putStrLn "hello, world!" +-- +-- (assuming out is IO ()). +-- +-- The empty CmdParser is also valid: +-- +-- > return () +-- +-- But not very interesting - you won't get an 'out' value from this (e.g. an +-- IO-action to execute) when this matches (on the empty input). +-- +-- > do +-- > addCmd "sub" $ do +-- > addCmdImpl $ putStrLn "sub successful" +-- +-- Here, note that there is no implementation at the top-level. This means that +-- on the empty input the resulting CommandDesc has no out-value, but on "sub" +-- it has. Executed as a program, the user would be shown the usage on empty +-- input, and the putStrLn would happen on "sub". +-- +-- More than one subcommand? easy: +-- +-- > do +-- > addCmd "foo" $ do {..} +-- > addCmd "bar" $ do {..} +-- +-- Basic flag usage: +-- +-- > do +-- > shouldVerbose <- addSimpleBoolFlag "v" ["verbose"] mzero +-- > addCmdImpl $ if shouldVerbose +-- > then putStrLn "Hello, World!!!!!" +-- > else putStrLn "hi." +-- +-- Basic param usage: +-- +-- > addCmd "echo" $ do +-- > addCmdHelpStr "print its parameter to output" +-- > str <- addRestOfInputStringParam "STRING" (paramHelpStr "the string to print") +-- > addCmdImpl $ putStrLn str +-- > addCmd "echoInt" $ do +-- > i <- addReadParam "INT" mempty +-- > addCmdImpl $ print (i::Int) -- need to disambiguate via typesig. +-- +-- There are some other flag/param methods in the respective modules. +-- Also note the example at 'reorderStart'. + +module UI.Butcher.Monadic.Command + ( addCmd + , addCmdImpl + , addCmdSynopsis + , addCmdHelp + , addCmdHelpStr + , reorderStart + , reorderStop + , 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 + , ManyUpperBound (..) + ) +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 + diff --git a/src/UI/Butcher/Monadic/Flag.hs b/src/UI/Butcher/Monadic/Flag.hs new file mode 100644 --- /dev/null +++ b/src/UI/Butcher/Monadic/Flag.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Flags are arguments to your current command that are prefixed with "-" or +-- "--", for example "-v" or "--verbose". These flags can have zero or one +-- argument. (Butcher internally has more general concept of "CmdPart" that +-- could handle any number of arguments, so take this as what this module aims +-- to provide, not what you could theoretically implement on top of butcher). + +-- Note that the current implementation only accepts "--foo param" but not +-- "--foo=param". Someone really ought to implement support for the latter +-- at some point :) +module UI.Butcher.Monadic.Flag + ( Flag(..) + , flagHelp + , flagHelpStr + , flagDefault + , addSimpleBoolFlag + , addSimpleCountFlag + , addSimpleFlagA + , addFlagReadParam + , addFlagReadParams + -- , addFlagReadParamA + , 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 + } + +instance Monoid (Flag p) where + mempty = Flag Nothing Nothing + Flag a1 b1 `mappend` Flag a2 b2 = Flag (a1 <|> a2) (b1 <|> b2) + +-- | Create a 'Flag' with just a help text. +flagHelp :: PP.Doc -> Flag p +flagHelp h = mempty { _flag_help = Just h } + +-- | Create a 'Flag' with just a help text. +flagHelpStr :: String -> Flag p +flagHelpStr s = mempty { _flag_help = Just $ PP.text s } + +-- | Create a 'Flag' with just a default value. +flagDefault :: p -> Flag p +flagDefault d = mempty { _flag_default = Just d } + +-- | A no-parameter flag where non-occurence means False, occurence means True. +addSimpleBoolFlag + :: Applicative f + => String -- ^ 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 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 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 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 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 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 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) -> readMaybe arg2 <&> \x -> (x, InputArgs rest) + Just ((), remainingStr) -> + 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 + 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 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) -> (readMaybe arg2 <&> \x -> (x, InputArgs rest)) <|> mdef + where mdef = _flag_default flag <&> \p -> (p, InputArgs argR) + Just ((), remainingStr) -> + 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 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 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 + 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 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 diff --git a/src/UI/Butcher/Monadic/IO.hs b/src/UI/Butcher/Monadic/IO.hs new file mode 100644 --- /dev/null +++ b/src/UI/Butcher/Monadic/IO.hs @@ -0,0 +1,117 @@ +-- | 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 diff --git a/src/UI/Butcher/Monadic/Internal/Core.hs b/src/UI/Butcher/Monadic/Internal/Core.hs new file mode 100644 --- /dev/null +++ b/src/UI/Butcher/Monadic/Internal/Core.hs @@ -0,0 +1,1147 @@ +{-# 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 + , addCmdImpl + , reorderStart + , reorderStop + , checkCmdParser + , runCmdParser + , runCmdParserExt + , runCmdParserA + , runCmdParserAExt + , mapOut + ) +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 str sub (pure ()) () + +-- | Add an implementation to the current command. +addCmdImpl :: out -> CmdParser f out () +addCmdImpl o = liftF $ CmdParserImpl o () + +-- | Best explained via example: +-- +-- > do +-- > reorderStart +-- > bright <- addSimpleBoolFlag "" ["bright"] mempty +-- > yellow <- addSimpleBoolFlag "" ["yellow"] mempty +-- > reorderStop +-- > .. +-- +-- will accept any inputs "" "--bright" "--yellow" "--bright --yellow" "--yellow --bright". +-- +-- This works for any flags/params, but bear in mind that the results might +-- be unexpected because params may match on any input. +-- +-- Note that start/stop must occur in pairs, and it will be a runtime error +-- if you mess this up. Use 'checkCmdParser' if you want to check all parts +-- of your 'CmdParser' without providing inputs that provide 100% coverage. +reorderStart :: CmdParser f out () +reorderStart = liftF $ CmdParserReorderStart () + +-- | See 'reorderStart' +reorderStop :: CmdParser f out () +reorderStop = liftF $ CmdParserReorderStop () + +-- 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 String (CmdParser f out ()) (f ()) + +type PartParsedData = Map Int [Dynamic] + +data CmdDescStack = StackBottom (Deque PartDesc) + | StackLayer (Deque PartDesc) String CmdDescStack + +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 -> (n, emptyCommandDesc)) + $ () <$ desc + { _cmd_parts = Data.Foldable.toList descs + } + StackLayer _ _ _ -> Left "unclosed ReorderStart or GroupStart" + processMain :: CmdParser f out () + -> MultiRWSS.MultiRWST '[] '[] '[CommandDesc out, CmdDescStack] (Either String) () + 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.text 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 sub _act next) -> do + mInitialDesc <- takeCommandChild cmdStr + cmd :: CommandDesc out <- mGet + subCmd <- do + stackCur :: CmdDescStack <- mGet + mSet $ 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 } + 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 + + 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 -> (n, emptyCommandDesc) } + captureFinal + :: ([String], (CmdDescStack, (Input, (PastCommandInput, (CommandDesc out, f()))))) + -> f (CommandDesc (), Input, Either ParsingError (CommandDesc out)) + captureFinal (errs, (descStack, (inputRest, (PastCommandInput pastCmdInput, (cmd, act))))) = + act $> (() <$ cmd', pastCmdInput, res) + where + 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 :: 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.text s } + processMain next + Free (CmdParserPeekDesc nextF) -> do + parser <- 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 + _ -> 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 String, Map String (CmdParser f out (), f ())) + -> ChildGather f out + -> (Deque String, Map String (CmdParser f out (), f ())) + child_fold (c_names, c_map) (ChildGather name child act) = + case name `MapS.lookup` c_map of + Nothing -> + ( Deque.snoc name c_names + , MapS.insert name (child, act) c_map + ) + Just (child', act') -> + ( c_names + , MapS.insert name (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 <&> \(name, (child, act)) -> + case input of + InputString str | name == str -> + Just $ (name, child, act, InputString "") + InputString str | (name++" ") `isPrefixOf` str -> + Just $ (name, child, act, InputString $ drop (length name + 1) str) + InputArgs (str:strr) | name == str -> + Just $ (name, child, act, InputArgs strr) + _ -> Nothing + case mRest of + Nothing -> do -- a child not matching what we have in the input + let initialDesc :: CommandDesc out = emptyCommandDesc + -- get the shallow desc for the child in a separate env. + combined_child_list `forM_` \(child_name, (child, _)) -> do + 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) + -- proceed regularly on the same layer + processMain $ restCmdParser + Just (name, child, act, rest) -> do -- matching child -> descend + -- process all remaining stuff on the same layer shallowly, + -- including the current node. This will be replaced later. + iterM processCmdShallow f + -- so 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) + } + 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 + + 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 + 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 sub act next) -> do + mTell [ChildGather cmdStr sub act] + childrenGather next + Free (CmdParserPeekInput nextF) -> do + childrenGather $ nextF $ inputToString inputInitial + Free (CmdParserPeekDesc nextF) -> do + parser <- 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 + ] + failureCurrentShallowRerun + 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 ()) + -> m () + 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.text 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 _sub _act next -> do + mExisting <- takeCommandChild cmdStr + let childDesc :: CommandDesc out = fromMaybe emptyCommandDesc 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{} -> do + return () + StackLayer _descs "" _up -> do + return () + 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 + + 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 <- 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 + + 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 :: String -> Deque (String, a) -> (Maybe a, Deque (String, 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 + => 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 () -> CmdParser f outb () +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 child act r -> CmdParserChild s (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 + +-- 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 (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 -> (String, CommandDesc a) -> (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 -> (String, CommandDesc a) -> (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 diff --git a/src/UI/Butcher/Monadic/Internal/Types.hs b/src/UI/Butcher/Monadic/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/UI/Butcher/Monadic/Internal/Types.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module UI.Butcher.Monadic.Internal.Types + ( CommandDesc (..) + , cmd_mParent + , cmd_help + , cmd_synopsis + , cmd_parts + , cmd_out + , cmd_children + , emptyCommandDesc + , CmdParserF (..) + , CmdParser + , PartDesc (..) + , Input (..) + , ParsingError (..) + , addSuggestion + , ManyUpperBound (..) + ) +where + + + +#include "prelude.inc" +import Control.Monad.Free +import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS + +import qualified Lens.Micro.TH as LensTH + +import qualified Text.PrettyPrint as PP + + + +-- | Butcher supports two input modi: @String@ and @[String]@. Program +-- arguments have the latter form, while parsing interactive command input +-- (e.g. when you implement a terminal of sorts) is easier when you can +-- process the full @String@ without having to wordify it first by some +-- means (and List.words is not the right approach in many situations.) +data Input = InputString String | InputArgs [String] + deriving (Show, Eq) + +-- | Information about an error that occured when trying to parse some @Input@ +-- using some @CmdParser@. +data ParsingError = ParsingError + { _pe_messages :: [String] + , _pe_remaining :: Input + } + deriving (Show, Eq) + +-- | Specifies whether we accept 0-1 or 0-n for @CmdParserPart@s. +data ManyUpperBound + = ManyUpperBound1 + | ManyUpperBoundN + +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 String (CmdParser f out ()) (f ()) a + | CmdParserImpl out a + | CmdParserReorderStart a + | CmdParserReorderStop a + | CmdParserGrouped String a + | CmdParserGroupEnd a + +-- | The CmdParser monad type. It is a free monad over some functor but users +-- of butcher don't need to know more than that 'CmdParser' is a 'Monad'. +type CmdParser f out = Free (CmdParserF f out) + + +-- type CmdParser a = CmdParserM a a + +-- data CmdPartParserF a +-- = CmdPartParserHelp String a +-- | forall p . CmdPartParserCore (String -> Maybe (p, String)) -- parser +-- (Maybe p) -- optional default value +-- (p -> a) +-- | forall p . CmdPartParserOptional (CmdPartParser p) +-- (Maybe p -> a) +-- -- the idea here was to allow adding some dynamic data to each "node" of +-- -- the output CommandDesc so the user can potentially add custom additional +-- -- information, and write a custom pretty-printer for e.g. help output +-- -- from that dynamically-enriched CommandDesc structure. +-- -- disabled for now, because i am not sure what exactly "adding to every +-- -- node" involves, because the mapping from Functor to Desc is nontrivial. +-- -- (and because i don't have a direct use-case at the moment..) +-- -- | CmdPartParserCustom Dynamic a +-- +-- type CmdPartParser = Free CmdPartParserF + +--------- + +-- | A representation/description of a command parser built via the +-- 'CmdParser' monad. Can be transformed into a pretty Doc to display +-- as usage/help via 'ppUsage' and related functions. +-- +-- Note that there is the '_cmd_out' accessor that contains @Maybe out@ which +-- might be useful after successful parsing. +data CommandDesc out = CommandDesc + { _cmd_mParent :: Maybe (String, CommandDesc out) + , _cmd_synopsis :: Maybe PP.Doc + , _cmd_help :: Maybe PP.Doc + , _cmd_parts :: [PartDesc] + , _cmd_out :: Maybe out + , _cmd_children :: Deque (String, CommandDesc out) -- we don't use a Map here + -- because we'd like to + -- retain the order. + } + +-- type PartSeqDesc = [PartDesc] + +-- | A representation/description of a command's parts, i.e. flags or params. +-- As a butcher user, the higher-level pretty-printing functions for +-- 'CommandDesc' are probably sufficient. +data PartDesc + = PartLiteral String -- expect a literal string, like "--dry-run" + | PartVariable String -- expect some user-provided input. The + -- string represents the name for the variable + -- used in the documentation, e.g. "FILE" + | PartOptional PartDesc + | PartAlts [PartDesc] + | PartSeq [PartDesc] + | PartDefault String -- default representation + PartDesc + | PartSuggestion [String] PartDesc + | PartRedirect String -- name for the redirection + PartDesc + | PartReorder [PartDesc] + | PartMany PartDesc + | PartWithHelp PP.Doc PartDesc + deriving Show + +addSuggestion :: Maybe [String] -> PartDesc -> PartDesc +addSuggestion Nothing = id +addSuggestion (Just sugs) = PartSuggestion sugs + +{- +command documentation structure +1. terminals. e.g. "--dry-run" +2. non-terminals, e.g. "FILES" +3. sequences, e.g. " FLAGS NUMBER PATH" +-- 4. alternatives, e.g. "--date=(relative|local|iso|rfc|..)" +5. sub-commands: git (init|commit|push|clone|..) + compared to 4, the subcommands have their own flags and params; + they essentially "take over". +6. optional, e.g. "cabal run [COMPONENT]" +7. default, e.g. "-O(LEVEL=1)" +8. indirection, e.g. "cabal COMMAND\n\nCOMMAND: ..." +-} + +-- + +deriving instance Functor (CmdParserF f out) +deriving instance Functor CommandDesc + +-- + +emptyCommandDesc :: CommandDesc out +emptyCommandDesc = CommandDesc Nothing Nothing Nothing [] Nothing mempty + +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" + diff --git a/src/UI/Butcher/Monadic/Param.hs b/src/UI/Butcher/Monadic/Param.hs new file mode 100644 --- /dev/null +++ b/src/UI/Butcher/Monadic/Param.hs @@ -0,0 +1,171 @@ + +-- | 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 + , addReadParam + , addReadParamOpt + , addStringParam + , addStringParamOpt + , 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 [p] + } + +instance Monoid (Param p) where + mempty = Param Nothing Nothing Nothing + mappend (Param a1 b1 c1) + (Param a2 b2 c2) + = Param + (a1 `f` a2) + (b1 `mappend` b2) + (c1 `mappend` c2) + where + f Nothing x = x + f x _ = x + +-- | Create a 'Param' with just a help text. +paramHelpStr :: String -> Param p +paramHelpStr s = mempty { _param_help = Just $ PP.text s } + +-- | Create a 'Param' with just a help text. +paramHelp :: PP.Doc -> Param p +paramHelp h = mempty { _param_help = Just h } + +-- | Create a 'Param' with just a default value. +paramDefault :: p -> Param p +paramDefault d = mempty { _param_default = Just d } + +-- | Create a 'Param' with just a list of suggestion values. +paramSuggestions :: [p] -> Param p +paramSuggestions ss = mempty { _param_suggestions = Just ss } + +-- | Add a parameter to the 'CmdParser' by making use of a 'Text.Read.Read' +-- instance. Take care not to use this to return Strings unless you really +-- want that, because it will require the quotation marks and escaping as +-- is normal for the Show/Read instances for String. +addReadParam :: forall f out a + . (Applicative f, Typeable a, Show a, Text.Read.Read a) + => String -- ^ 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 = (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. +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 = 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 is [String]. See the 'Input' doc for +-- this distinction. +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 'addStringParam', but optional, I.e. succeeding with Nothing if +-- there is no remaining input. +addStringParamOpt + :: forall f out . (Applicative f) + => String + -> Param Void + -> CmdParser f out (Maybe String) +addStringParamOpt 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) + (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 consumes _all_ remaining input. Typical usecase is +-- after a "--" as common in certain (unix?) commandline tools. +addRestOfInputStringParam + :: forall f out . (Applicative f) + => String + -> Param Void + -> CmdParser f out String +addRestOfInputStringParam name par = addCmdPartInp desc parseF + where + desc :: PartDesc + desc = (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 []) diff --git a/src/UI/Butcher/Monadic/Pretty.hs b/src/UI/Butcher/Monadic/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/UI/Butcher/Monadic/Pretty.hs @@ -0,0 +1,254 @@ + +-- | Pretty-print of CommandDescs. To explain what the different functions +-- do, we will use an example CmdParser. The CommandDesc derived from that +-- CmdParser will serve as example input to the functions in this module. +-- +-- > main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do +-- > +-- > addCmdSynopsis "a simple butcher example program" +-- > addCmdHelpStr "a very long help document" +-- > +-- > addCmd "version" $ do +-- > porcelain <- addSimpleBoolFlag "" ["porcelain"] +-- > (flagHelpStr "print nothing but the numeric version") +-- > addCmdHelpStr "prints the version of this program" +-- > addCmdImpl $ putStrLn $ if porcelain +-- > then "0.0.0.999" +-- > else "example, version 0.0.0.999" +-- > +-- > addCmd "help" $ addCmdImpl $ print $ ppHelpShallow helpDesc +-- > +-- > short <- addSimpleBoolFlag "" ["short"] (flagHelpStr "make the greeting short") +-- > name <- addStringParam "NAME" +-- > (paramHelpStr "your name, so you can be greeted properly") +-- > +-- > addCmdImpl $ do +-- > if short +-- > then putStrLn $ "hi, " ++ name ++ "!" +-- > else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!" +module UI.Butcher.Monadic.Pretty + ( ppUsage + , ppUsageAt + , ppHelpShallow + , ppUsageWithHelp + , ppPartDescUsage + , ppPartDescHeader + , parsingErrorString + ) +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: +-- +-- > playground [--short] NAME [version | help] +ppUsage :: CommandDesc a -> PP.Doc +ppUsage (CommandDesc mParent _help _syn parts out children) = pparents mParent + <+> PP.fsep (partDocs ++ [subsDoc]) + where + pparents :: Maybe (String, CommandDesc out) -> PP.Doc + pparents Nothing = PP.empty + pparents (Just (n, cd)) = pparents (_cmd_mParent cd) <+> PP.text n + partDocs = parts <&> ppPartDescUsage + 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 + $ children + <&> \(n, _) -> PP.text n + +-- | ppUsageWithHelp exampleDesc yields: +-- +-- > playground [--short] NAME +-- > [version | help]: a simple butcher example program +-- +-- And yes, the line break is not optimal in this instance with default print. +ppUsageWithHelp :: CommandDesc a -> PP.Doc +ppUsageWithHelp (CommandDesc mParent help _syn parts out children) = + pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc + where + pparents :: Maybe (String, CommandDesc out) -> PP.Doc + pparents Nothing = PP.empty + pparents (Just (n, cd)) = pparents (_cmd_mParent cd) <+> PP.text n + partDocs = parts <&> ppPartDescUsage + 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 + $ children + <&> \(n, _) -> PP.text n + 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 = + case strings of + [] -> Just $ ppUsage desc + (s:sr) -> find ((s==) . fst) (_cmd_children desc) >>= ppUsageAt sr . snd + +-- | ppHelpShalloe exampleDesc yields: +-- +-- > NAME +-- > +-- > example - a simple butcher example program +-- > +-- > USAGE +-- > +-- > example [--short] NAME [version | help] +-- > +-- > DESCRIPTION +-- > +-- > a very long help document +-- > +-- > ARGUMENTS +-- > +-- > --short make the greeting short +-- > NAME your name, so you can be greeted properly +ppHelpShallow :: CommandDesc a + -> PP.Doc +ppHelpShallow desc@(CommandDesc mParent syn help parts _out _children) = + nameSection + $+$ usageSection + $+$ descriptionSection + $+$ partsSection + $+$ PP.text "" + where + 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 (String, CommandDesc out) -> PP.Doc + pparents Nothing = PP.empty + pparents (Just (n, cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n + 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 (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 + +-- | Internal helper; users probably won't need this. +ppPartDescUsage :: PartDesc -> PP.Doc +ppPartDescUsage = \case + PartLiteral s -> PP.text s + PartVariable s -> PP.text s + PartOptional p -> PP.brackets $ rec p + PartAlts ps -> PP.fcat $ PP.punctuate (PP.text ",") $ rec <$> ps + PartSeq ps -> PP.fsep $ rec <$> ps + PartDefault _ p -> PP.brackets $ rec p + PartSuggestion s p -> + PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ fmap PP.text s ++ [rec p] + PartRedirect s _ -> PP.text s + PartMany p -> rec p <> PP.text "+" + PartWithHelp _ p -> rec p + PartReorder ps -> + let flags = [ d | PartMany d <- ps ] + params = filter ( \case + PartMany{} -> False + _ -> True + ) + ps + in PP.brackets (PP.fsep $ rec <$> flags) <+> PP.fsep (rec <$> params) + 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 + 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 ++ "..\"." + diff --git a/src/UI/Butcher/Monadic/Types.hs b/src/UI/Butcher/Monadic/Types.hs new file mode 100644 --- /dev/null +++ b/src/UI/Butcher/Monadic/Types.hs @@ -0,0 +1,20 @@ +-- 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(..) + ) +where + + + +#include "prelude.inc" + + + +import UI.Butcher.Monadic.Internal.Types diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc new file mode 100644 --- /dev/null +++ b/srcinc/prelude.inc @@ -0,0 +1,409 @@ +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 Data.Either.Combinators + +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 Data.Int ( Int ) +import Data.Word ( Word ) +import Prelude ( Integer, Float, Double ) +import Control.Monad.ST ( ST ) +import Data.Bool ( Bool(..) ) +import Data.Char ( Char ) +import Data.Either ( Either(..) ) +import Data.IORef ( IORef ) +import Data.Maybe ( Maybe(..) ) +import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), First(..), Last(..), Alt(..), ) +import Data.Ord ( Ordering(..), Down(..) ) +import Data.Ratio ( Ratio, Rational ) +import Data.String ( String ) +import Data.Void ( Void ) +import System.IO ( IO ) +import Data.Proxy ( Proxy(..) ) +import Data.Sequence ( Seq ) + +import Data.Map ( Map ) +import Data.Set ( Set ) + +import Deque ( Deque ) + +import qualified Deque + +import Prelude ( Char + , String + , Int + , Integer + , 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 + ) + +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.Maybe ( fromMaybe + , maybe + , listToMaybe + , maybeToList + , catMaybes + ) + +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 ( (<>) + , mconcat + , Monoid (..) + ) + +import Data.Bifunctor ( bimap ) +import Data.Functor ( (<$), ($>) ) +import Data.Function ( (&) ) +import System.IO ( hFlush + , stdout + ) + +import Data.Typeable ( Typeable + ) + +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(..) + ) + +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 ( (<&>) + )