From 5d67167c8797271b2a1560967455e6ca1d120859 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 18 Apr 2020 16:50:15 +0200 Subject: [PATCH] Major changeset: Add applicative, Refactor monadic interface - monadic interface now uses two-phase setup: First step is to create a full CommandDesc value, second is running the parser on input while the CommandDesc is chained along - applicative interface has a somewhat nicer/cleaner implementation, is more secure by avoiding any demands on the API user that are not encoded in types, but is slightly less expressive and requires ApplicativeDo to get readable code. - The applicative interface is *NOT* finished and the test-suite does not cover it. - Add the `traverseBarbie` construct which introduces a dependency on the `barbies` library. This also effectively: - Stop support for ghc < 8.4. - Refactor the module structure a bit, and change the API of the central `runCmdParser` function. It now returns a `PartialParseInfo`. Essentially, `runCmdParser` is a combination of the previous `runCmdParser` and the previous `simpleCompletion`. This API design is a curious advantage to laziness: Returning a complex struct is harmless as fields that the user does not use won't be evaluated. The downside is that the core function now looks like a complex beast, but the upside is that there is no need to expose multiple functions that are supposed to be chained in a certain way to get all functionality (if desired), and we still _can_ provide simpler versions that are just projections on the `PartialParseInfo`. - Stop support for an anti-feature: The implicit merging of multiple sub-commands definitions with the same name. --- butcher.cabal | 19 +- src-tests/TestMain.hs | 258 +++--- src/UI/Butcher/Applicative.hs | 210 +++++ src/UI/Butcher/Applicative/Command.hs | 28 + src/UI/Butcher/Applicative/Flag.hs | 295 ++++++ src/UI/Butcher/Applicative/IO.hs | 94 ++ src/UI/Butcher/Applicative/Param.hs | 298 ++++++ src/UI/Butcher/Applicative/Pretty.hs | 45 + src/UI/Butcher/Internal/Applicative.hs | 378 ++++++++ src/UI/Butcher/Internal/ApplicativeTypes.hs | 97 ++ src/UI/Butcher/Internal/BasicStringParser.hs | 42 + .../Types.hs => Internal/CommonTypes.hs} | 78 +- src/UI/Butcher/Internal/Interactive.hs | 157 ++++ .../Internal/Core.hs => Internal/Monadic.hs} | 861 +++++++----------- src/UI/Butcher/Internal/MonadicTypes.hs | 141 +++ src/UI/Butcher/Internal/Pretty.hs | 394 ++++++++ src/UI/Butcher/Monadic.hs | 128 ++- src/UI/Butcher/Monadic/BuiltinCommands.hs | 31 +- src/UI/Butcher/Monadic/Command.hs | 7 +- src/UI/Butcher/Monadic/Flag.hs | 246 ++--- src/UI/Butcher/Monadic/IO.hs | 73 +- src/UI/Butcher/Monadic/Interactive.hs | 201 ---- src/UI/Butcher/Monadic/Param.hs | 254 +++--- src/UI/Butcher/Monadic/Pretty.hs | 349 +------ src/UI/Butcher/Monadic/Types.hs | 3 +- srcinc/prelude.inc | 7 +- stack-8-10.yaml | 3 +- stack-8-4.yaml | 2 +- stack-8-6.yaml | 1 + 29 files changed, 3146 insertions(+), 1554 deletions(-) create mode 100644 src/UI/Butcher/Applicative.hs create mode 100644 src/UI/Butcher/Applicative/Command.hs create mode 100644 src/UI/Butcher/Applicative/Flag.hs create mode 100644 src/UI/Butcher/Applicative/IO.hs create mode 100644 src/UI/Butcher/Applicative/Param.hs create mode 100644 src/UI/Butcher/Applicative/Pretty.hs create mode 100644 src/UI/Butcher/Internal/Applicative.hs create mode 100644 src/UI/Butcher/Internal/ApplicativeTypes.hs create mode 100644 src/UI/Butcher/Internal/BasicStringParser.hs rename src/UI/Butcher/{Monadic/Internal/Types.hs => Internal/CommonTypes.hs} (72%) create mode 100644 src/UI/Butcher/Internal/Interactive.hs rename src/UI/Butcher/{Monadic/Internal/Core.hs => Internal/Monadic.hs} (58%) create mode 100644 src/UI/Butcher/Internal/MonadicTypes.hs create mode 100644 src/UI/Butcher/Internal/Pretty.hs delete mode 100644 src/UI/Butcher/Monadic/Interactive.hs diff --git a/butcher.cabal b/butcher.cabal index 21984db..d20b2bb 100644 --- a/butcher.cabal +++ b/butcher.cabal @@ -32,10 +32,21 @@ library UI.Butcher.Monadic.Flag UI.Butcher.Monadic.Pretty UI.Butcher.Monadic.IO - UI.Butcher.Monadic.Interactive UI.Butcher.Monadic.BuiltinCommands - other-modules: UI.Butcher.Monadic.Internal.Types - UI.Butcher.Monadic.Internal.Core + UI.Butcher.Applicative.Command + UI.Butcher.Applicative.Param + UI.Butcher.Applicative.Flag + UI.Butcher.Applicative.Pretty + UI.Butcher.Applicative.IO + UI.Butcher.Applicative + other-modules: UI.Butcher.Internal.CommonTypes + UI.Butcher.Internal.MonadicTypes + UI.Butcher.Internal.Monadic + UI.Butcher.Internal.ApplicativeTypes + UI.Butcher.Internal.Applicative + UI.Butcher.Internal.BasicStringParser + UI.Butcher.Internal.Pretty + UI.Butcher.Internal.Interactive build-depends: { base >=4.11 && <4.15 , free < 5.2 @@ -51,6 +62,8 @@ library , void <0.8 , bifunctors <5.6 , deque >=0.3 && <0.5 + , barbies >= 2.0.2.0 && <2.1 + , semigroups } hs-source-dirs: src default-language: Haskell2010 diff --git a/src-tests/TestMain.hs b/src-tests/TestMain.hs index 6f66f08..03e34f1 100644 --- a/src-tests/TestMain.hs +++ b/src-tests/TestMain.hs @@ -4,13 +4,12 @@ module Main where #include "prelude.inc" -import Test.Hspec +import Test.Hspec -- import NeatInterpolation -import UI.Butcher.Monadic -import UI.Butcher.Monadic.Types -import UI.Butcher.Monadic.Interactive +import UI.Butcher.Monadic +import UI.Butcher.Monadic.Types @@ -19,9 +18,9 @@ main = hspec $ tests tests :: Spec tests = do - describe "checkTests" checkTests + describe "checkTests" checkTests describe "simpleParseTest" simpleParseTest - describe "simpleRunTest" simpleRunTest + describe "simpleRunTest" simpleRunTest checkTests :: Spec @@ -31,105 +30,102 @@ checkTests = do simpleParseTest :: Spec simpleParseTest = do - it "failed parse 001" $ runCmdParser Nothing (InputString "foo") testCmd1 - `shouldSatisfy` Data.Either.isLeft . snd - it "toplevel" $ (testParse testCmd1 "" >>= _cmd_out) - `shouldSatisfy` Maybe.isNothing - it "hasImpl 001" $ (testParse testCmd1 "abc" >>= _cmd_out) - `shouldSatisfy` Maybe.isJust - it "hasImpl 002" $ (testParse testCmd1 "def" >>= _cmd_out) - `shouldSatisfy` Maybe.isJust + it "failed parse 001" + $ let r = runCmdParserSimpleString "foo" testCmd1 + in r `shouldSatisfy` Data.Either.isLeft + it "toplevel" $ (testParse testCmd1 "") `shouldBe` Nothing + it "hasImpl 001" $ (testParse testCmd1 "abc") `shouldSatisfy` Maybe.isJust + it "hasImpl 002" $ (testParse testCmd1 "def") `shouldSatisfy` Maybe.isJust simpleRunTest :: Spec simpleRunTest = do - it "failed run" $ testRun testCmd1 "" `shouldBe` Right Nothing + it "failed run" $ testRun testCmd1 "" `shouldBeRight` Nothing describe "no reordering" $ do - it "cmd 1" $ testRun testCmd1 "abc" `shouldBe` Right (Just 100) - it "cmd 2" $ testRun testCmd1 "def" `shouldBe` Right (Just 200) - it "flag 1" $ testRun testCmd1 "abc -f" `shouldBe` Right (Just 101) - it "flag 2" $ testRun testCmd1 "abc --flong" `shouldBe` Right (Just 101) - it "flag 3" $ testRun testCmd1 "abc -f -f" `shouldBe` Right (Just 101) - it "flag 4" $ testRun testCmd1 "abc -f -g" `shouldBe` Right (Just 103) - it "flag 5" $ testRun testCmd1 "abc -f -g -f" `shouldSatisfy` Data.Either.isLeft -- no reordering - it "flag 6" $ testRun testCmd1 "abc -g -f" `shouldSatisfy` Data.Either.isLeft -- no reordering - it "flag 7" $ testRun testCmd1 "abc -g -g" `shouldBe` Right (Just 102) + it "cmd 1" $ testRun testCmd1 "abc" `shouldBeRight` (Just 100) + it "cmd 2" $ testRun testCmd1 "def" `shouldBeRight` (Just 200) + it "flag 1" $ testRun testCmd1 "abc -f" `shouldBeRight` (Just 101) + it "flag 2" $ testRun testCmd1 "abc --flong" `shouldBeRight` (Just 101) + it "flag 3" $ testRun testCmd1 "abc -f -f" `shouldBeRight` (Just 101) + it "flag 4" $ testRun testCmd1 "abc -f -g" `shouldBeRight` (Just 103) + it "flag 5" + $ testRun testCmd1 "abc -f -g -f" + `shouldSatisfy` Data.Either.isLeft -- no reordering + it "flag 6" + $ testRun testCmd1 "abc -g -f" + `shouldSatisfy` Data.Either.isLeft -- no reordering + it "flag 7" $ testRun testCmd1 "abc -g -g" `shouldBeRight` (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) + it "cmd 1" $ testRun testCmd2 "abc" `shouldBeRight` (Just 100) + it "cmd 2" $ testRun testCmd2 "def" `shouldBeRight` (Just 200) + it "flag 1" $ testRun testCmd2 "abc -f" `shouldBeRight` (Just 101) + it "flag 2" $ testRun testCmd2 "abc --flong" `shouldBeRight` (Just 101) + it "flag 3" $ testRun testCmd2 "abc -f -f" `shouldBeRight` (Just 101) + it "flag 4" $ testRun testCmd2 "abc -f -g" `shouldBeRight` (Just 103) + it "flag 5" $ testRun testCmd2 "abc -f -g -f" `shouldBeRight` (Just 103) + it "flag 6" $ testRun testCmd2 "abc -g -f" `shouldBeRight` (Just 103) + it "flag 7" $ testRun testCmd2 "abc -g -g" `shouldBeRight` (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" - ] + it "flag 1" $ testRunA testCmd3 "abc" `shouldBeRight` 0 + it "flag 2" $ testRunA testCmd3 "abc -f" `shouldBeRight` 1 + it "flag 3" $ testRunA testCmd3 "abc -g" `shouldBeRight` 2 + it "flag 4" $ testRunA testCmd3 "abc -f -g" `shouldBeRight` 3 + it "flag 5" $ testRunA testCmd3 "abc -g -f" `shouldBeRight` 3 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 1" $ testRun testCmd5 "abc" `shouldBeRight` (Just 10) + it "flag 2" $ testRun testCmd5 "abc -f 2" `shouldBeRight` (Just 2) + it "flag 3" $ testRun testCmd5 "abc --flag 3" `shouldBeRight` (Just 3) + it "flag 4" $ testRun testCmd5 "abc -f=4" `shouldBeRight` (Just 4) + it "flag 5" $ testRun testCmd5 "abc --flag=5" `shouldBeRight` (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 + it "flag 7" + $ testRun testCmd5 "abc -flag 0" + `shouldSatisfy` Data.Either.isLeft + it "flag 8" + $ testRun testCmd5 "abc --f 0" + `shouldSatisfy` Data.Either.isLeft describe "addParamStrings" $ do - it "case 1" $ testRun' testCmd6 "" `shouldBe` Right (Just ([], 0)) - it "case 2" $ testRun' testCmd6 "-f" `shouldBe` Right (Just ([], 1)) - it "case 3" $ testRun' testCmd6 "abc" `shouldBe` Right (Just (["abc"], 0)) - it "case 4" $ testRun' testCmd6 "abc def" `shouldBe` Right (Just (["abc", "def"], 0)) - it "case 5" $ testRun' testCmd6 "-g abc def" `shouldBe` Right (Just (["abc", "def"], 2)) - it "case 6" $ testRun' testCmd6 "-f -g def" `shouldBe` Right (Just (["def"], 3)) + it "case 1" $ testRun' testCmd6 "" `shouldBeRight` (Just ([], 0)) + it "case 2" $ testRun' testCmd6 "-f" `shouldBeRight` (Just ([], 1)) + it "case 3" $ testRun' testCmd6 "abc" `shouldBeRight` (Just (["abc"], 0)) + it "case 4" + $ testRun' testCmd6 "abc def" + `shouldBeRight` (Just (["abc", "def"], 0)) + it "case 5" + $ testRun' testCmd6 "-g abc def" + `shouldBeRight` (Just (["abc", "def"], 2)) + it "case 6" + $ testRun' testCmd6 "-f -g def" + `shouldBeRight` (Just (["def"], 3)) describe "addParamNoFlagStrings" $ do - it "case 1" $ testRun' testCmd7 "" `shouldBe` Right (Just ([], 0)) - it "case 2" $ testRun' testCmd7 "-f" `shouldBe` Right (Just ([], 1)) - it "case 3" $ testRun' testCmd7 "abc" `shouldBe` Right (Just (["abc"], 0)) - it "case 4" $ testRun' testCmd7 "abc -f" `shouldBe` Right (Just (["abc"], 1)) - it "case 5" $ testRun' testCmd7 "-g abc -f" `shouldBe` Right (Just (["abc"], 3)) - it "case 6" $ testRun' testCmd7 "abc -g def" `shouldBe` Right (Just (["abc", "def"], 2)) + it "case 1" $ testRun' testCmd7 "" `shouldBeRight` (Just ([], 0)) + it "case 2" $ testRun' testCmd7 "-f" `shouldBeRight` (Just ([], 1)) + it "case 3" $ testRun' testCmd7 "abc" `shouldBeRight` (Just (["abc"], 0)) + it "case 4" $ testRun' testCmd7 "abc -f" `shouldBeRight` (Just (["abc"], 1)) + it "case 5" + $ testRun' testCmd7 "-g abc -f" + `shouldBeRight` (Just (["abc"], 3)) + it "case 6" + $ testRun' testCmd7 "abc -g def" + `shouldBeRight` (Just (["abc", "def"], 2)) describe "defaultParam" $ do it "case 1" $ testRun testCmdParam "" `shouldSatisfy` Data.Either.isLeft it "case 2" $ testRun testCmdParam "n" `shouldSatisfy` Data.Either.isLeft it "case 3" $ testRun testCmdParam "y" `shouldSatisfy` Data.Either.isLeft - it "case 4" $ testRun testCmdParam "False n" `shouldBe` Right (Just 110) - it "case 5" $ testRun testCmdParam "False y" `shouldBe` Right (Just 310) - it "case 6" $ testRun testCmdParam "True n" `shouldBe` Right (Just 1110) - it "case 7" $ testRun testCmdParam "True y" `shouldBe` Right (Just 1310) - it "case 8" $ testRun testCmdParam "1 False y" `shouldBe` Right (Just 301) - it "case 9" $ testRun testCmdParam "1 False y def" `shouldBe` Right (Just 201) - it "case 10" $ testRun testCmdParam "1 False 2 y def" `shouldBe` Right (Just 203) - it "case 11" $ testRun testCmdParam "1 True 2 y def" `shouldBe` Right (Just 1203) + it "case 4" $ testRun testCmdParam "False n" `shouldBeRight` (Just 110) + it "case 5" $ testRun testCmdParam "False y" `shouldBeRight` (Just 310) + it "case 6" $ testRun testCmdParam "True n" `shouldBeRight` (Just 1110) + it "case 7" $ testRun testCmdParam "True y" `shouldBeRight` (Just 1310) + it "case 8" $ testRun testCmdParam "1 False y" `shouldBeRight` (Just 301) + it "case 9" + $ testRun testCmdParam "1 False y def" + `shouldBeRight` (Just 201) + it "case 10" + $ testRun testCmdParam "1 False 2 y def" + `shouldBeRight` (Just 203) + it "case 11" + $ testRun testCmdParam "1 True 2 y def" + `shouldBeRight` (Just 1203) describe "completions" $ do it "case 1" $ testCompletion completionTestCmd "" `shouldBe` "" it "case 2" $ testCompletion completionTestCmd "a" `shouldBe` "bc" @@ -177,8 +173,8 @@ 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)) + addSimpleFlagA "f" ["flong"] mempty (StateS.modify (+ 1)) + addSimpleFlagA "g" ["glong"] mempty (StateS.modify (+ 2)) reorderStop addCmdImpl () addCmd "def" $ do @@ -202,13 +198,13 @@ testCmd4 = do testCmd5 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () testCmd5 = do addCmd "abc" $ do - x <- addFlagReadParam "f" ["flag"] "flag" (flagDefault (10::Int)) + x <- addFlagReadParam "f" ["flag"] "flag" (flagDefault (10 :: Int)) addCmdImpl $ WriterS.tell (Sum x) testCmd6 :: CmdParser Identity (WriterS.Writer (Sum Int) [String]) () testCmd6 = do - f <- addSimpleBoolFlag "f" ["flong"] mempty - g <- addSimpleBoolFlag "g" ["glong"] mempty + f <- addSimpleBoolFlag "f" ["flong"] mempty + g <- addSimpleBoolFlag "g" ["glong"] mempty args <- addParamStrings "ARGS" mempty addCmdImpl $ do when f $ WriterS.tell 1 @@ -218,8 +214,8 @@ testCmd6 = do testCmd7 :: CmdParser Identity (WriterS.Writer (Sum Int) [String]) () testCmd7 = do reorderStart - f <- addSimpleBoolFlag "f" ["flong"] mempty - g <- addSimpleBoolFlag "g" ["glong"] mempty + f <- addSimpleBoolFlag "f" ["flong"] mempty + g <- addSimpleBoolFlag "g" ["glong"] mempty args <- addParamNoFlagStrings "ARGS" mempty reorderStop addCmdImpl $ do @@ -230,16 +226,16 @@ testCmd7 = do testCmdParam :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () testCmdParam = do p :: Int <- addParamRead "INT" (paramDefault 10) - b <- addParamRead "MANDR" mempty - r <- addParamReadOpt "MAY1" (paramDefault 20) - s <- addParamString "MAND" mempty - q <- addParamString "STR" (paramDefault "abc") + b <- addParamRead "MANDR" mempty + r <- addParamReadOpt "MAY1" (paramDefault 20) + s <- addParamString "MAND" mempty + q <- addParamString "STR" (paramDefault "abc") addCmdImpl $ do WriterS.tell (Sum p) - when (q=="abc") $ WriterS.tell 100 + when (q == "abc") $ WriterS.tell 100 r `forM_` (WriterS.tell . Sum) when b $ WriterS.tell $ Sum 1000 - when (s=="y") $ WriterS.tell 200 + when (s == "y") $ WriterS.tell 200 pure () completionTestCmd :: CmdParser Identity () () @@ -255,32 +251,46 @@ completionTestCmd = do addCmdImpl () testCompletion :: CmdParser Identity a () -> String -> String -testCompletion p inp = case runCmdParserExt Nothing (InputString inp) p of - (cDesc, InputString cRest, _) -> simpleCompletion inp cDesc cRest - _ -> error "wut" +testCompletion p inp = + _ppi_inputSugg $ runCmdParser Nothing (InputString inp) p -testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out) -testParse cmd s = either (const Nothing) Just - $ snd - $ runCmdParser Nothing (InputString s) cmd +testParse :: CmdParser Identity out () -> String -> Maybe out +testParse cmd s = case runCmdParserSimpleString s cmd of + Left{} -> Nothing + Right o -> Just o -testRun :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () -> String -> Either ParsingError (Maybe Int) -testRun cmd s = fmap (fmap (getSum . WriterS.execWriter) . _cmd_out) - $ snd - $ runCmdParser Nothing (InputString s) cmd - -testRun' :: CmdParser Identity (WriterS.Writer (Sum Int) a) () -> String -> Either ParsingError (Maybe (a, Int)) -testRun' cmd s = - fmap (fmap (fmap getSum . WriterS.runWriter) . _cmd_out) $ snd $ runCmdParser +testRun + :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () + -> String + -> Either ParsingError (Maybe Int) +testRun cmd s = + fmap (fmap (getSum . WriterS.execWriter)) $ _ppi_value $ 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 +testRun' + :: CmdParser Identity (WriterS.Writer (Sum Int) a) () + -> String + -> Either ParsingError (Maybe (a, Int)) +testRun' cmd s = + fmap (fmap (fmap getSum . WriterS.runWriter)) $ _ppi_value $ runCmdParser + Nothing + (InputString s) + cmd -getDoc :: String -> CmdParser Identity out () -> CommandDesc () -getDoc s = fst . runCmdParser (Just "test") (InputString s) +testRunA + :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError Int +testRunA cmd str = case StateS.runState act (0 :: Int) of + (info, s) -> _ppi_value info $> s + where act = runCmdParserA Nothing (InputString str) cmd + +getDoc :: String -> CmdParser Identity out () -> CommandDesc +getDoc s p = _ppi_mainDesc $ runCmdParser (Just "test") (InputString s) p + + +shouldBeRight :: (Show l, Show r, Eq r) => Either l r -> r -> Expectation +shouldBeRight x y = x `shouldSatisfy` \case + Left{} -> False + Right r -> r == y diff --git a/src/UI/Butcher/Applicative.hs b/src/UI/Butcher/Applicative.hs new file mode 100644 index 0000000..45cfa7f --- /dev/null +++ b/src/UI/Butcher/Applicative.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} + + +module UI.Butcher.Applicative + ( -- * Types + Input(..) + , CmdParser + , ParsingError(..) + , PartialParseInfo(..) + , CommandDesc + , PartDesc(..) + , Visibility(..) + -- * Run CmdParsers + , runCmdParserSimpleString + , runCmdParserSimpleArgv + , runCmdParser + , runCmdParserFromDesc + -- * Building CmdParsers + , module UI.Butcher.Applicative.Command + , module UI.Butcher.Applicative.Param + , module UI.Butcher.Applicative.Flag + -- * PrettyPrinting CommandDescs (usage/help) + , module UI.Butcher.Applicative.Pretty + -- * Wrapper around System.Environment.getArgs + , module UI.Butcher.Applicative.IO + -- * Advanced usage + , emptyCommandDesc + ) +where + + + +#include "prelude.inc" + +import qualified Barbies +import qualified Barbies.Bare as Barbies +import Data.Kind +import Data.List.Extra ( firstJust ) +import Data.Semigroup ( Last(..) ) +import Data.Semigroup.Generic +import GHC.Generics ( Generic ) + +import UI.Butcher.Applicative.Command +import UI.Butcher.Applicative.Flag +import UI.Butcher.Applicative.IO +import UI.Butcher.Applicative.Param +import UI.Butcher.Applicative.Pretty +import UI.Butcher.Internal.Applicative +import UI.Butcher.Internal.ApplicativeTypes +import UI.Butcher.Internal.CommonTypes +import UI.Butcher.Internal.Interactive + + + +-- runCmdParser +-- :: forall out +-- . Input +-- -> CmdParser out out +-- -> (CommandDesc, Either ParsingError out) +-- runCmdParser initialInput initialParser = +-- let topDesc = toCmdDesc initialParser +-- in (topDesc, runCmdParserCoreFromDesc initialInput topDesc initialParser) + +-- | Run a parser on the given input, and return a struct with all kinds of +-- output. The input does not need to be complete, i.e. if you have a command +-- "clean" then on input "cle" you will not get a successful parse +-- (@_ppi_value@ will be @Left{}@) but other fields will be useful nonetheless. +-- For example @_ppi_inputSugg@ might be "an". Depends on what other commands +-- exist, of course. +-- +-- On successful parses, @_ppi_value@ will be @Right{}@ but the other fields +-- still might be useful as well - for example to display the description of +-- the command about to be executed (once user presses enter). +-- +-- Note that with haskell's laziness there is no performance cost to +-- using this function - the fields you are not interested in will not be +-- computed. +runCmdParser :: forall out . Input -> CmdParser out out -> PartialParseInfo out +runCmdParser input parser = + let topDesc = toCmdDesc parser in runCmdParserFromDesc topDesc input parser + +-- | This function is the part of the @runCmdParser@ functionality that +-- depends on the input. For interactive use this avoids recomputing the +-- commandDesc. +-- +-- For usage see the source of 'runCmdParser'. +runCmdParserFromDesc + :: forall out + . CommandDesc + -> Input + -> CmdParser out out + -> PartialParseInfo out +runCmdParserFromDesc topDesc input parser = + let (localDesc, remainingInput, result) = + runCmdParserCoreFromDesc input topDesc parser + in combinedCompletion input + topDesc + localDesc + remainingInput + (fmap Just result) + + +-- | Wrapper around 'runCmdParser' for very simple usage: Accept a @String@ +-- input and return only the output from the parser, or a plain error string +-- on failure. +runCmdParserSimpleString :: String -> CmdParser out out -> Either String out +runCmdParserSimpleString s p = + let info = runCmdParser (InputString s) p + in + case _ppi_value info of + Left e -> Left $ parsingErrorString e + Right (Just desc) -> Right desc + Right Nothing -> + error "Applicative parser should not return Right Nothing" + +-- | Wrapper around 'runCmdParser' for very simple usage: Accept a list of +-- @String@s (args)and return only the output from the parser, or a plain +-- error string on failure. +runCmdParserSimpleArgv :: [String] -> CmdParser out out -> Either String out +runCmdParserSimpleArgv s p = + let info = runCmdParser (InputArgs s) p + in + case _ppi_value info of + Left e -> Left $ parsingErrorString e + Right (Just desc) -> Right desc + Right Nothing -> + error "Applicative parser should not return Right Nothing" + +-- | Like 'runCmdParser', but with one additional twist: You get access +-- to a knot-tied complete CommandDesc for this full command. +-- runCmdParserWithHelpDesc +-- :: Input -- ^ input to be processed +-- -> (CommandDesc -> CmdParser out out) -- ^ parser to use +-- -> (CommandDesc, Either ParsingError out) +-- runCmdParserWithHelpDesc input cmdF = +-- -- knot-tying at its finest.. +-- let (desc, parser) = (toCmdDesc parser, cmdF desc) +-- in (desc, runCmdParserCoreFromDesc input desc parser) + + +data MyFlagStruct (c :: Type) (f :: Type -> Type) = MyFlagStruct + { _userName :: Barbies.Wear c f String + , _shout :: Barbies.WearTwo c f Last Bool + , _dryrun :: Barbies.WearTwo c f Last Bool + } + deriving Generic + +instance Barbies.FunctorB (MyFlagStruct Barbies.Covered) +instance Barbies.BareB MyFlagStruct +instance Barbies.TraversableB (MyFlagStruct Barbies.Covered) +instance Semigroup (MyFlagStruct Barbies.Covered Option) where + (<>) = gmappend + +_test :: IO () +_test = do + let parser = do + addCmd "help" $ pure $ do + putStrLn "help: print helpful help" + arg :: Int <- addParamRead "SOMEARG" mempty + -- addCmd "dryrun-arg" $ pure $ do + -- putStrLn $ "arg = " ++ show arg + reorderStart + flags <- traverseBarbie MyFlagStruct + { _userName = addFlagStringParam "u" + ["user"] + "USERNAME" + (flagDefault "user") + , _shout = Last <$> addSimpleBoolFlag "s" ["shout"] mempty + , _dryrun = Last <$> addSimpleBoolFlag "d" ["dryrun"] mempty + } + reorderStop + pure $ do + print arg + let shoutOrNot = if _shout flags then map Char.toUpper else id + if (_dryrun flags) + then do + putStrLn "would print greeting" + else do + putStrLn $ shoutOrNot $ "hello, " ++ _userName flags + + let info = runCmdParser (InputArgs ["42", "--shout", "-u=lsp"]) parser + -- runCmdParser (InputArgs ["help"]) parser + let desc = _ppi_mainDesc info + print desc + print $ ppHelpDepthOne desc + case _ppi_value info of + Left err -> do + putStrLn "parsing error" + print err + Right Nothing -> putStrLn "no implementation" + Right (Just f) -> f + + +-- butcherMain :: ButcherA (IO ()) -> IO () +-- +-- type ButcherA out = Writer [ButcherCmd out] () +-- type ButcherCmd = Ap ButcherCmdF out +-- data ButcherCmdF a +-- = ButcherCmdHelp String (() -> a) +-- | ButcherCmdParamString (String -> a) + diff --git a/src/UI/Butcher/Applicative/Command.hs b/src/UI/Butcher/Applicative/Command.hs new file mode 100644 index 0000000..a8e7300 --- /dev/null +++ b/src/UI/Butcher/Applicative/Command.hs @@ -0,0 +1,28 @@ +module UI.Butcher.Applicative.Command + ( addCmd + , addCmdHidden + , peekCmdDesc + , reorderStart + , reorderStop + , withReorder + , traverseBarbie + -- * Low-level part functions + , addCmdPart + , addCmdPartMany + , addCmdPartInp + , addCmdPartManyInp + ) +where + +#include "prelude.inc" + +import UI.Butcher.Internal.ApplicativeTypes +import UI.Butcher.Internal.Applicative + + + +-- | Safe wrapper around 'reorderStart'/'reorderStop' for cases where reducing +-- to a single binding is possible/preferable. +withReorder :: CmdParser out a -> CmdParser out a +withReorder x = reorderStart *> x <* reorderStop + diff --git a/src/UI/Butcher/Applicative/Flag.hs b/src/UI/Butcher/Applicative/Flag.hs new file mode 100644 index 0000000..6497cc1 --- /dev/null +++ b/src/UI/Butcher/Applicative/Flag.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + + +module UI.Butcher.Applicative.Flag + ( Flag(..) + , flagDefault + , flagHelp + , flagHelpStr + , addSimpleBoolFlag + , addSimpleCountFlag + , addFlagReadParam + , addFlagReadParams + , addFlagStringParam + ) +where + + + +#include "prelude.inc" + +import Control.Applicative.Free +import Control.Monad.ST +import Data.Kind +import Data.List.Extra ( firstJust ) +import Data.STRef +import qualified Text.PrettyPrint as PP + +import UI.Butcher.Applicative.Param +import UI.Butcher.Internal.ApplicativeTypes +import UI.Butcher.Internal.Applicative +import UI.Butcher.Internal.BasicStringParser +import UI.Butcher.Internal.Pretty + +import Debug.Trace + + + +data Flag a = Flag + { _flag_help :: Maybe PP.Doc + , _flag_default :: Maybe a + , _flag_visibility :: Visibility + } + + +appendFlag :: Flag p -> Flag p -> Flag p +appendFlag (Flag a1 b1 c1) (Flag a2 b2 c2) = Flag (a1 <|> a2) + (b1 <|> b2) + (appVis c1 c2) + where + appVis Visible Visible = Visible + appVis _ _ = Hidden + +instance Semigroup (Flag p) where + (<>) = appendFlag + +instance Monoid (Flag a) where + mempty = Flag Nothing Nothing Visible + mappend = (<>) + +-- | Create a 'Flag' with just a help text. +flagHelp :: PP.Doc -> Flag p +flagHelp h = mempty { _flag_help = Just h } + +-- | Create a 'Flag' with just a help text. +flagHelpStr :: String -> Flag p +flagHelpStr s = + mempty { _flag_help = Just $ PP.fsep $ fmap PP.text $ List.words s } + +-- | Create a 'Flag' with just a default value. +flagDefault :: p -> Flag p +flagDefault d = mempty { _flag_default = Just d } + +wrapHidden :: Flag p -> PartDesc -> PartDesc +wrapHidden f = case _flag_visibility f of + Visible -> id + Hidden -> PartHidden + + +addSimpleBoolFlag :: String -> [String] -> Flag Void -> CmdParser out Bool +addSimpleBoolFlag shorts longs opts = fmap (not . null) + $ addCmdPartMany ManyUpperBound1 (wrapHidden opts desc) parseF + where + allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs + desc :: PartDesc + desc = + (maybe id PartWithHelp $ _flag_help opts) + $ PartAlts + $ PartLiteral + <$> allStrs + parseF :: String -> EpsilonFlag -> Maybe ((), String) + parseF (dropWhile Char.isSpace -> str) _ = + (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs) + <|> (firstJust + (\s -> + [ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ] + ) + allStrs + ) + + +-- | A no-parameter flag that can occur multiple times. Returns the number of +-- occurences (0 or more). +addSimpleCountFlag + :: String -- ^ short flag chars, i.e. "v" for -v + -> [String] -- ^ list of long names, i.e. ["verbose"] + -> Flag Void -- ^ properties + -> CmdParser out Int +addSimpleCountFlag shorts longs flag = fmap length + $ addCmdPartMany ManyUpperBoundN (wrapHidden flag desc) parseF + where + -- we _could_ allow this to parse repeated short flags, like "-vvv" + -- (meaning "-v -v -v") correctly. + allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs + desc :: PartDesc + desc = + (maybe id PartWithHelp $ _flag_help flag) + $ PartAlts + $ PartLiteral + <$> allStrs + parseF :: String -> EpsilonFlag -> Maybe ((), String) + parseF (dropWhile Char.isSpace -> str) _ = + (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs) + <|> (firstJust + (\s -> + [ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ] + ) + allStrs + ) + + +addFlagReadParam + :: forall out p + . (Typeable p, 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 out p +addFlagReadParam shorts longs name opts = addCmdPartInp + (wrapHidden opts desc) + parseF + where + allStrs = + [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ] + desc = + (maybe id PartWithHelp $ _flag_help opts) + $ maybe id (PartDefault . show) (_flag_default opts) + $ PartSeq [desc1, desc2] + desc1 :: PartDesc + desc1 = PartAlts $ PartLiteral . either id id <$> allStrs + desc2 = PartVariable name + parseF :: Input -> EpsilonFlag -> Maybe (p, Input) + parseF inp e = case inp of + InputString str -> case parseResult of + Just (x, rest) -> Just (x, InputString rest) + Nothing -> viaDef + where + parseResult = runInpParseString (dropWhile Char.isSpace str) $ do + Data.Foldable.msum $ allStrs <&> \case + Left s -> pExpect s *> pOption (pExpect " " <|> pExpect "=") + Right s -> pExpect s *> (pExpect " " <|> pExpect "=") + InpParseString $ do + i <- StateS.get + case Text.Read.reads i of + ((x, ' ' : r) : _) -> StateS.put (dropWhile Char.isSpace r) $> x + ((x, "" ) : _) -> StateS.put "" $> x + _ -> mzero + InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of + Just ((), "") -> case argR of + [] -> Nothing + (arg2 : rest) -> Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest) + Just ((), remainingStr) -> + Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR) + Nothing -> viaDef + where + parser :: InpParseString () + parser = do + Data.Foldable.msum $ allStrs <&> \case + Left s -> pExpect s *> pOption (pExpect "=") + Right s -> pExpect s *> (pExpect "=" <|> pExpectEof) + InputArgs _ -> viaDef + where viaDef = [ (x, inp) | x <- _flag_default opts, e == AllowEpsilon ] + + +-- | 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 p out + . (Typeable p, 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 out [p] +addFlagReadParams shorts longs name flag = addCmdPartManyInp + ManyUpperBoundN + (wrapHidden flag desc) + parseF + 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 -> EpsilonFlag -> Maybe (p, Input) + parseF inp _ = case inp of + InputString str -> fmap (second InputString) $ parseResult + where + parseResult = runInpParseString (dropWhile Char.isSpace str) $ do + Data.Foldable.msum $ allStrs <&> \case + Left s -> pExpect s *> pOption (pExpect " " <|> pExpect "=") + Right s -> pExpect s *> (pExpect " " <|> pExpect "=") + InpParseString $ do + i <- StateS.get + case Text.Read.reads i of + ((x, ' ' : r) : _) -> StateS.put (dropWhile Char.isSpace r) $> x + ((x, "" ) : _) -> StateS.put "" $> x + _ -> lift $ _flag_default flag + InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of + Just ((), "") -> case argR of + [] -> mdef + (arg2 : rest) -> + (Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest)) <|> mdef + where mdef = _flag_default flag <&> \p -> (p, InputArgs argR) + Just ((), remainingStr) -> + Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR) + Nothing -> Nothing + where + parser :: InpParseString () + parser = do + Data.Foldable.msum $ allStrs <&> \case + Left s -> pExpect s *> pOption (pExpect "=") + Right s -> pExpect s *> (pExpect "=" <|> pExpectEof) + InputArgs _ -> Nothing + + +-- | One-argument flag where the argument can be an arbitrary string. +addFlagStringParam + :: forall out + . String -- ^ short flag chars, i.e. "v" for -v + -> [String] -- ^ list of long names, i.e. ["verbose"] + -> String -- ^ param name + -> Flag String -- ^ properties + -> CmdParser out String +addFlagStringParam shorts longs name opts = addCmdPartInp + (wrapHidden opts desc) + parseF + where + allStrs = + [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ] + desc = (maybe id PartWithHelp $ _flag_help opts) $ PartSeq [desc1, desc2] + desc1 :: PartDesc + desc1 = PartAlts $ PartLiteral . either id id <$> allStrs + desc2 = PartVariable name + parseF :: Input -> EpsilonFlag -> Maybe (String, Input) + parseF inp e = case inp of + InputString str -> case parseResult of + Just (x, rest) -> Just (x, InputString rest) + Nothing -> viaDef + where + parseResult = runInpParseString (dropWhile Char.isSpace str) $ do + Data.Foldable.msum $ allStrs <&> \case + Left s -> pExpect s *> pOption (pExpect " " <|> pExpect "=") + Right s -> pExpect s *> (pExpect " " <|> pExpect "=") + InpParseString $ do + i <- StateS.get + let (x, rest) = break Char.isSpace $ dropWhile Char.isSpace i + StateS.put rest + pure x + InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of + Just ((), "") -> case argR of + [] -> Nothing + (x : rest) -> Just (x, InputArgs rest) + Just ((), remainingStr) -> Just (remainingStr, InputArgs argR) + Nothing -> viaDef + where + parser :: InpParseString () + parser = do + Data.Foldable.msum $ allStrs <&> \case + Left s -> pExpect s *> pOption (pExpect "=") + Right s -> pExpect s *> (pExpect "=" <|> pExpectEof) + InputArgs _ -> viaDef + where viaDef = [ (x, inp) | x <- _flag_default opts, e == AllowEpsilon ] diff --git a/src/UI/Butcher/Applicative/IO.hs b/src/UI/Butcher/Applicative/IO.hs new file mode 100644 index 0000000..af5da1d --- /dev/null +++ b/src/UI/Butcher/Applicative/IO.hs @@ -0,0 +1,94 @@ +-- | Turn your CmdParser into an IO () to be used as your program @main@. +module UI.Butcher.Applicative.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.Internal.Applicative +import UI.Butcher.Internal.ApplicativeTypes +import UI.Butcher.Monadic.Param +import UI.Butcher.Monadic.Pretty + +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 (IO ()) (IO ()) -> IO () +mainFromCmdParser cmd = do + progName <- System.Environment.getProgName + args <- System.Environment.getArgs + let topDesc = toCmdDesc cmd + case runCmdParserCoreFromDesc (InputArgs args) topDesc cmd of + (desc, _remaining, Left err) -> do + putStrErrLn + $ progName + ++ ": error parsing arguments: " + ++ case _pe_messages err of + [] -> "" + (m : _) -> m + putStrErrLn $ case _pe_remaining err 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, _remaining, Right out) -> out + +-- | 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 (IO ()) (IO ())) -> IO () +-- mainFromCmdParserWithHelpDesc cmdF = do +-- progName <- System.Environment.getProgName +-- args <- System.Environment.getArgs +-- case runCmdParserWithHelpDesc (InputArgs args) cmdF of +-- (desc, Left err) -> do +-- putStrErrLn $ progName ++ ": error parsing arguments: " ++ head +-- (_pe_messages err) +-- putStrErrLn $ case _pe_remaining err 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) -> out + +putStrErrLn :: String -> IO () +putStrErrLn s = hPutStrLn stderr s + +printErr :: Show a => a -> IO () +printErr = putStrErrLn . show diff --git a/src/UI/Butcher/Applicative/Param.hs b/src/UI/Butcher/Applicative/Param.hs new file mode 100644 index 0000000..a3fcd00 --- /dev/null +++ b/src/UI/Butcher/Applicative/Param.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + + +module UI.Butcher.Applicative.Param + ( Param(..) + , paramHelp + , paramHelpStr + , paramDefault + , paramSuggestions + , paramFile + , paramDirectory + , addParamRead + , addParamReadOpt + , addParamString + , addParamStringOpt + , addParamStrings + , addParamNoFlagString + , addParamNoFlagStringOpt + , addParamNoFlagStrings + , addParamRestOfInput + , addParamRestOfInputRaw + ) +where + + + +#include "prelude.inc" + +import Control.Applicative.Free +import Control.Monad.ST +import Data.Kind +import Data.List.Extra ( firstJust ) +import Data.STRef +import qualified Text.PrettyPrint as PP + +import UI.Butcher.Internal.ApplicativeTypes +import UI.Butcher.Internal.Applicative +import UI.Butcher.Internal.Pretty + + +data Param p = Param + { _param_default :: Maybe p + , _param_help :: Maybe PP.Doc + , _param_suggestions :: Maybe [CompletionItem] + } + +appendParam :: Param p -> Param p -> Param p +appendParam (Param a1 b1 c1) (Param a2 b2 c2) = + Param (a1 <|> a2) (b1 <> b2) (c1 <> c2) + +instance Semigroup (Param p) where + (<>) = appendParam + +instance Monoid (Param p) where + mempty = Param Nothing Nothing Nothing + mappend = (<>) + +-- | Create a 'Param' with just a help text. +paramHelpStr :: String -> Param p +paramHelpStr s = mempty { _param_help = Just $ PP.text s } + +-- | Create a 'Param' with just a help text. +paramHelp :: PP.Doc -> Param p +paramHelp h = mempty { _param_help = Just h } + +-- | Create a 'Param' with just a default value. +paramDefault :: p -> Param p +paramDefault d = mempty { _param_default = Just d } + +-- | Create a 'Param' with just a list of suggestion values. +paramSuggestions :: [String] -> Param p +paramSuggestions ss = + mempty { _param_suggestions = Just $ CompletionString <$> ss } + +-- | Create a 'Param' that is a file path. +paramFile :: Param p +paramFile = mempty { _param_suggestions = Just [CompletionFile] } + +-- | Create a 'Param' that is a directory path. +paramDirectory :: Param p +paramDirectory = mempty { _param_suggestions = Just [CompletionDirectory] } + + +-- | Add a parameter to the 'CmdParser' by making use of a 'Text.Read.Read' +-- instance. Take care not to use this to return Strings unless you really +-- want that, because it will require the quotation marks and escaping as +-- is normal for the Show/Read instances for String. +addParamRead + :: forall out a + . (Typeable a, Show a, Text.Read.Read a) + => String -- ^ paramater name, for use in usage/help texts + -> Param a -- ^ properties + -> CmdParser out a +addParamRead name par = addCmdPart desc parseF + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ (maybe id (PartDefault . show) $ _param_default par) + $ PartVariable name + parseF :: String -> EpsilonFlag -> Maybe (a, String) + parseF s e = case (Text.Read.reads s, e) of + (((x, ' ' : r) : _), _ ) -> Just (x, dropWhile Char.isSpace r) + (((x, [] ) : _), _ ) -> Just (x, []) + (_ , AllowEpsilon) -> _param_default par <&> \x -> (x, s) + (_ , DenyEpsilon ) -> Nothing + +addSuggestion :: Maybe [CompletionItem] -> PartDesc -> PartDesc +addSuggestion Nothing = id +addSuggestion (Just sugs) = PartSuggestion sugs + +-- | Like addReadParam, but optional. I.e. if reading fails, returns Nothing. +addParamReadOpt + :: forall out a + . (Typeable a, Text.Read.Read a) + => String -- ^ paramater name, for use in usage/help texts + -> Param a -- ^ properties + -> CmdParser out (Maybe a) +addParamReadOpt name par = addCmdPart desc parseF + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ PartOptional + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: String -> EpsilonFlag -> Maybe (Maybe a, String) + parseF s e = case Text.Read.reads s of + ((x, ' ' : r) : _) -> Just (Just x, dropWhile Char.isSpace r) + ((x, [] ) : _) -> Just (Just x, []) + _ -> [ (Nothing, s) | e == AllowEpsilon ] + + +-- | Add a parameter that matches any string of non-space characters if +-- input==String, or one full argument if input==[String]. See the 'Input' doc +-- for this distinction. +addParamString :: String -> Param String -> CmdParser out String +addParamString name par = addCmdPartInp desc parseF + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: Input -> EpsilonFlag -> Maybe (String, Input) + parseF (InputString str) e = + case break Char.isSpace $ dropWhile Char.isSpace str of + ("", rest) -> + [ (x, InputString rest) | x <- _param_default par, e == AllowEpsilon ] + (x, rest) -> Just (x, InputString rest) + parseF (InputArgs args) e = case args of + (s1 : sR) -> Just (s1, InputArgs sR) + [] -> [ (x, InputArgs args) | x <- _param_default par, e == AllowEpsilon ] + +-- | Like 'addParamString', but optional, I.e. succeeding with Nothing if +-- there is no remaining input. +addParamStringOpt :: String -> Param Void -> CmdParser out (Maybe String) +addParamStringOpt name par = addCmdPartInp desc parseF + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ PartOptional + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: Input -> EpsilonFlag -> Maybe (Maybe String, Input) + parseF (InputString str) e = + case break Char.isSpace $ dropWhile Char.isSpace str of + ("", rest) -> [ (Nothing, InputString rest) | e == AllowEpsilon ] + (x , rest) -> Just (Just x, InputString rest) + parseF (InputArgs args) e = case args of + (s1 : sR) -> Just (Just s1, InputArgs sR) + [] -> [ (Nothing, InputArgs []) | e == AllowEpsilon ] + + +-- | Add a parameter that matches any string of non-space characters if +-- input==String, or one full argument if input==[String]. See the 'Input' doc +-- for this distinction. +addParamStrings :: String -> Param Void -> CmdParser out [String] +addParamStrings name par = addCmdPartManyInp ManyUpperBoundN desc parseF + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: Input -> EpsilonFlag -> Maybe (String, Input) + parseF (InputString str) _e = + case break Char.isSpace $ dropWhile Char.isSpace str of + ("", _ ) -> Nothing + (x , rest) -> Just (x, InputString rest) + parseF (InputArgs args) _e = case args of + (s1 : sR) -> Just (s1, InputArgs sR) + [] -> Nothing + + +-- | Like 'addParamString' but does not match strings starting with a dash. +-- This prevents misinterpretation of flags as params. +addParamNoFlagString :: String -> Param String -> CmdParser out String +addParamNoFlagString name par = addCmdPartInp desc parseF + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: Input -> EpsilonFlag -> Maybe (String, Input) + parseF (InputString str) e = + case break Char.isSpace $ dropWhile Char.isSpace str of + ("", rest) -> + [ (x, InputString rest) | x <- _param_default par, e == AllowEpsilon ] + ('-' : _, _) -> + [ (x, InputString str) | x <- _param_default par, e == AllowEpsilon ] + (x, rest) -> Just (x, InputString rest) + parseF (InputArgs args) e = case args of + [] -> [ (x, InputArgs args) | x <- _param_default par, e == AllowEpsilon ] + (('-' : _) : _) -> + [ (x, InputArgs args) | x <- _param_default par, e == AllowEpsilon ] + (s1 : sR) -> Just (s1, InputArgs sR) + +-- | Like 'addParamStringOpt' but does not match strings starting with a dash. +-- This prevents misinterpretation of flags as params. +addParamNoFlagStringOpt :: String -> Param Void -> CmdParser out (Maybe String) +addParamNoFlagStringOpt name par = addCmdPartInp desc parseF + where + desc :: PartDesc + desc = + PartOptional $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name + parseF :: Input -> EpsilonFlag -> Maybe (Maybe String, Input) + parseF (InputString str) e = + case break Char.isSpace $ dropWhile Char.isSpace str of + ("" , rest) -> [ (Nothing, InputString rest) | e == AllowEpsilon ] + ('-' : _, _ ) -> [ (Nothing, InputString str) | e == AllowEpsilon ] + (x , rest) -> Just (Just x, InputString rest) + parseF (InputArgs args) e = case args of + [] -> [ (Nothing, InputArgs []) | e == AllowEpsilon ] + (('-' : _) : _ ) -> [ (Nothing, InputArgs args) | e == AllowEpsilon ] + (s1 : sR) -> Just (Just s1, InputArgs sR) + +-- | Like 'addParamStrings' but does not match strings starting with a dash. +-- This prevents misinterpretation of flags as params. +addParamNoFlagStrings :: String -> Param Void -> CmdParser out [String] +addParamNoFlagStrings name par = addCmdPartManyInp ManyUpperBoundN desc parseF + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: Input -> EpsilonFlag -> Maybe (String, Input) + parseF (InputString str) _e = + case break Char.isSpace $ dropWhile Char.isSpace str of + ("" , _ ) -> Nothing + ('-' : _, _ ) -> Nothing + (x , rest) -> Just (x, InputString rest) + parseF (InputArgs args) _e = case args of + [] -> Nothing + (('-' : _) : _ ) -> Nothing + (s1 : sR) -> Just (s1, InputArgs sR) + + +-- | Add a parameter that consumes _all_ remaining input. Typical usecase is +-- after a "--" as common in certain (unix?) commandline tools. +addParamRestOfInput :: String -> Param Void -> CmdParser out String +addParamRestOfInput name par = addCmdPartInp desc parseF + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: Input -> EpsilonFlag -> Maybe (String, Input) + parseF (InputString str ) _e = Just (str, InputString "") + parseF (InputArgs args) _e = Just (List.unwords args, InputArgs []) + + +-- | Add a parameter that consumes _all_ remaining input, returning a raw +-- 'Input' value. +addParamRestOfInputRaw :: String -> Param Void -> CmdParser out Input +addParamRestOfInputRaw name par = addCmdPartInp desc parseF + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: Input -> EpsilonFlag -> Maybe (Input, Input) + parseF i@InputString{} _e = Just (i, InputString "") + parseF i@InputArgs{} _e = Just (i, InputArgs []) + diff --git a/src/UI/Butcher/Applicative/Pretty.hs b/src/UI/Butcher/Applicative/Pretty.hs new file mode 100644 index 0000000..8be4cab --- /dev/null +++ b/src/UI/Butcher/Applicative/Pretty.hs @@ -0,0 +1,45 @@ + +-- | 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.Applicative.Pretty + ( ppUsage + , ppUsageShortSub + , ppUsageAt + , ppHelpShallow + , ppHelpDepthOne + , ppUsageWithHelp + , ppPartDescUsage + , ppPartDescHeader + , parsingErrorString + , descendDescTo + ) +where + + + +import UI.Butcher.Internal.Pretty diff --git a/src/UI/Butcher/Internal/Applicative.hs b/src/UI/Butcher/Internal/Applicative.hs new file mode 100644 index 0000000..237d083 --- /dev/null +++ b/src/UI/Butcher/Internal/Applicative.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} + +module UI.Butcher.Internal.Applicative + ( -- runCmdParser + -- , runCmdParserWithHelpDesc + -- , runCmdParserSimple + runCmdParserCoreFromDesc + , toCmdDesc + , traverseBarbie + , addCmd + , addCmdHidden + , addCmdPart + , addCmdPartMany + , addCmdPartInp + , addCmdPartManyInp + , peekCmdDesc + , reorderStart + , reorderStop + ) +where + + + + +#include "prelude.inc" + +import qualified Barbies +import qualified Barbies.Bare as Barbies +import Control.Applicative.Free +import Control.Monad.ST +import Data.STRef +import qualified Text.PrettyPrint as PP + +import UI.Butcher.Internal.ApplicativeTypes +import UI.Butcher.Internal.CommonTypes +import UI.Butcher.Internal.Interactive +import UI.Butcher.Internal.Pretty + + + +data DescState = DescState + { parts :: Deque PartDesc + , children :: Deque (String, CommandDesc) + , help :: Maybe PP.Doc + , reorder :: Maybe (Deque PartDesc) + } + +toCmdDesc :: forall out . CmdParser out out -> CommandDesc +toCmdDesc cmdParser = + let final = appEndo (runAp_ f cmdParser) initialState + in CommandDesc { _cmd_mParent = Nothing + , _cmd_synopsis = Nothing + , _cmd_help = help final + , _cmd_parts = Data.Foldable.toList $ parts final + , _cmd_hasImpl = True -- all applicatives have an impl atm + , _cmd_children = fmap (first Just) $ children final + , _cmd_visibility = Visible + } + where + f :: CmdParserF out a -> Endo (DescState) + f x = Endo $ \s -> case x of + CmdParserHelp doc _ -> s { help = Just doc } + CmdParserSynopsis _ _ -> error "todo" + CmdParserPeekDesc _ -> s + CmdParserPeekInput _ -> s + -- CmdParserPart desc _ _ -> appendPart s desc + -- CmdParserPartMany _ desc _ _ -> appendPart s desc + CmdParserPartInp desc _ _ -> appendPart s desc + CmdParserPartManyInp _ desc _ _ -> appendPart s desc + CmdParserChild name vis parser _ -> + appendChild s $ (name, (toCmdDesc parser) { _cmd_visibility = vis }) + CmdParserReorderStart _ -> s { reorder = reorder s <|> Just empty } + CmdParserReorderStop _ -> case reorder s of + Nothing -> s + Just ps -> s { parts = parts s <> ps, reorder = Nothing } + where + appendPart s p = s { parts = Deque.cons p (parts s) } + appendChild s c = s { children = Deque.cons c (children s) } + initialState = DescState { parts = mempty + , children = mempty + , help = Nothing + , reorder = mempty + } + +data ParserState out = ParserState + { p_parts :: Deque PartDesc + , p_children :: Deque (String, CommandDesc) + , p_help :: Maybe PP.Doc + , p_reorder :: Maybe (Deque PartDesc) + , p_input :: Input + , p_currentDesc :: CommandDesc + } + +runCmdParserCoreFromDesc + :: forall out + . Input + -> CommandDesc + -> CmdParser out out + -> (CommandDesc, Input, Either ParsingError out) +runCmdParserCoreFromDesc input desc parser = + let initialState = ParserState { p_parts = mempty + , p_children = mempty + , p_help = Nothing + , p_reorder = mempty + , p_input = input + , p_currentDesc = desc + } + (result, finalState) = runST $ StateS.runStateT (iter parser) initialState + in (desc, p_input finalState, result) + where + iter + :: forall s + . CmdParser out out + -> StateS.StateT (ParserState out) (ST s) (Either ParsingError out) + iter = \case + Pure x -> pure $ Right x + Ap (CmdParserHelp _ x) next -> continue next x + Ap (CmdParserSynopsis _ x) next -> continue next x + Ap (CmdParserPeekDesc f) next -> do + s <- StateS.get + iter $ next <*> Pure (f (p_currentDesc s)) + Ap (CmdParserPeekInput f ) next -> do + s <- StateS.get + iter $ next <*> Pure (f (inputToString $ p_input s)) + Ap (CmdParserPartInp _d parseF f) next -> do + s <- StateS.get + case parseF (p_input s) AllowEpsilon of + Just (x, rest) -> do + StateS.put s { p_input = rest } + iter $ next <&> \g -> g (f x) + Nothing -> pure $ Left $ ParsingError + { _pe_messages = ["could not parse"] + , _pe_remaining = p_input s + , _pe_expectedDesc = Nothing -- TODO + } + Ap (CmdParserPartManyInp _ _ parseF f) next -> do + let loop = do + dropSpaces + s <- StateS.get + case parseF (p_input s) AllowEpsilon of + Just (x, rest) -> do + StateS.put s { p_input = rest } + (x :) <$> loop + Nothing -> pure $ [] + ps <- loop + iter $ next <&> \g -> g (f ps) + Ap (CmdParserChild name _ childParser x) next -> do + dropSpaces + s <- StateS.get + let childDesc = case find ((== Just name) . fst) (_cmd_children desc) of + Just (_, d) -> d + Nothing -> error "inconsistent child name map" + case p_input s of + InputString str -> if + | str == name -> do + StateS.put ParserState { p_parts = mempty + , p_children = mempty + , p_help = Nothing + , p_reorder = mempty + , p_input = InputString "" + , p_currentDesc = childDesc + } + iter childParser + | +-- TODO str prefix + otherwise -> continue next x + InputArgs (a1 : ar) | a1 == name -> do + StateS.put ParserState { p_parts = mempty + , p_children = mempty + , p_help = Nothing + , p_reorder = mempty + , p_input = InputArgs ar + , p_currentDesc = childDesc + } + iter childParser + InputArgs{} -> continue next x + Ap (CmdParserReorderStart startX) next -> Except.runExceptT $ do + let + enrich + :: forall a + . CmdParser out a + -> StateS.StateT + (ParserState out) + (ST s) + (Ap (EnrichedCmdParserF s out) a, [ReorderUnit s]) + enrich = \case + Ap (CmdParserPartInp _ parseF f) n -> do + ref <- lift $ newSTRef Nothing + (n', units) <- enrich n + pure (Ap (ViaRef ref f) n', ReorderUnit ref parseF : units) + Ap (CmdParserPartManyInp bound _ parseF f) n -> do + ref <- lift $ newSTRef [] + (n', units) <- enrich n + pure + ( Ap (ViaRefMany ref f) n' + , ReorderUnitMany bound ref parseF : units + ) + Ap (CmdParserReorderStop x) n -> do + pure $ (liftAp $ Final (n <*> Pure x), []) + Ap x n -> do + (n', units) <- enrich n + pure (Ap (Lifted x) n', units) + Pure x -> do + pure (Pure x, []) + consumeReordered + :: [ReorderUnit s] + -> StateS.StateT (ParserState out) (ST s) [ReorderUnit s] + consumeReordered units = do + s <- StateS.get + let + matchF = \case + ReorderUnit ref parseF -> + case parseF (p_input s) DenyEpsilon of + Nothing -> Nothing + Just (x, rest) -> Just $ \newUnits -> do + lift $ writeSTRef ref (Just x) + StateS.put s { p_input = rest } + consumeReordered newUnits + ReorderUnitMany bound ref parseF -> + case parseF (p_input s) DenyEpsilon of + Nothing -> Nothing + Just (x, rest) -> Just $ \newUnits -> do + lift $ modifySTRef ref (x :) + StateS.put s { p_input = rest } + consumeReordered + $ if bound == ManyUpperBound1 then newUnits else units + let (newUnits, mAct) = extract matchF units + case mAct of + Nothing -> pure units + Just act -> act newUnits + derich + :: forall a + . Ap (EnrichedCmdParserF s out) a + -> ST s (CmdParser out a) + derich = \case + Ap (ViaRef ref f) n -> do + m <- readSTRef ref + case m of + Nothing -> error "butcher intenal error - reorder ref Nothing" + Just x -> derich $ n <*> Pure (f x) + Ap (ViaRefMany ref f) n -> do + x <- readSTRef ref + derich $ n <*> Pure (f $ reverse x) + Ap (Lifted l) n -> Ap l <$> derich n + Ap (Final f) n -> do + n' <- derich n + pure $ n' <*> f + Pure x -> pure $ Pure x + + (e, units) <- lift $ enrich (next <*> Pure startX) + remainingUnits <- lift $ consumeReordered units + remainingUnits `forM_` \case + ReorderUnit ref parseF -> case parseF (InputArgs []) AllowEpsilon of + Nothing -> do + s <- State.Class.get + Except.throwE ParsingError { _pe_messages = ["could not parse"] + , _pe_remaining = p_input s + , _pe_expectedDesc = Nothing -- TODO + } + Just (x, _) -> do + lift $ lift $ writeSTRef ref (Just x) + ReorderUnitMany{} -> pure () + Except.ExceptT $ iter =<< lift (derich e) + Ap (CmdParserReorderStop _) next -> error "TODO" next + where + continue + :: Ap (CmdParserF out) (a -> out) + -> a + -> StateS.StateT (ParserState out) (ST s1) (Either ParsingError out) + continue next x = iter (next <*> Pure x) + inputToString :: Input -> String + inputToString (InputString s ) = s + inputToString (InputArgs ss) = List.unwords ss + dropSpaces :: forall m . Monad m => StateS.StateT (ParserState out) m () + dropSpaces = do + st <- StateS.get + case p_input st of + InputString s -> + StateS.put $ st { p_input = InputString $ dropWhile Char.isSpace s } + InputArgs{} -> return () + + +traverseBarbie + :: (Barbies.BareB c, Barbies.TraversableB (c Barbies.Covered)) + => c Barbies.Covered (CmdParser out) + -> CmdParser out (c Barbies.Bare Identity) +traverseBarbie k = do + r <- Barbies.btraverse (fmap Identity) k + pure $ Barbies.bstrip r + + +addCmdPart + :: Typeable p + => PartDesc + -> (String -> EpsilonFlag -> Maybe (p, String)) + -> CmdParser out p +addCmdPart p f = liftAp $ CmdParserPartInp p (convertStringToInputParse f) id + +addCmdPartMany + :: Typeable p + => ManyUpperBound + -> PartDesc + -> (String -> EpsilonFlag -> Maybe (p, String)) + -> CmdParser out [p] +addCmdPartMany b p f = + liftAp $ CmdParserPartManyInp b p (convertStringToInputParse f) id + +addCmdPartInp + :: Typeable p + => PartDesc + -> (Input -> EpsilonFlag -> Maybe (p, Input)) + -> CmdParser out p +addCmdPartInp p f = liftAp $ CmdParserPartInp p f id + +addCmdPartManyInp + :: Typeable p + => ManyUpperBound + -> PartDesc + -> (Input -> EpsilonFlag -> Maybe (p, Input)) + -> CmdParser out [p] +addCmdPartManyInp b p f = liftAp $ CmdParserPartManyInp b p f id + +reorderStart :: CmdParser out () +reorderStart = liftAp $ CmdParserReorderStart () + +reorderStop :: CmdParser out () +reorderStop = liftAp $ CmdParserReorderStop () + +-- | Add a new child command in the current context. +addCmd + :: String -- ^ command name + -> CmdParser out out -- ^ subcommand + -> CmdParser out () +addCmd str sub = liftAp $ CmdParserChild str Visible sub () + +-- | Add a new child command in the current context, but make it hidden. It +-- will not appear in docs/help generated by e.g. the functions in the +-- @Pretty@ module. +-- +-- This feature is not well tested yet. +addCmdHidden + :: String -- ^ command name + -> CmdParser out out -- ^ subcommand + -> CmdParser out () +addCmdHidden str sub = liftAp $ CmdParserChild str Hidden sub () + + +-- | Get the CommandDesc on the current level of the parser +-- (i.e. for a command child, you get the child's CommandDesc). +peekCmdDesc :: CmdParser out CommandDesc +peekCmdDesc = liftAp $ CmdParserPeekDesc id + + +extract :: (a -> Maybe b) -> [a] -> ([a], Maybe b) +extract _ [] = ([], Nothing) +extract f (x : xs) = case f x of + Nothing -> let ~(l, m) = extract f xs in (x : l, m) + Just b -> (xs, Just b) + +-- I don't believe this version is any more efficient. It _can_ be one tad +-- easier to use if it matches this pattern, but you _cannot_ get a non-strict +-- delete out of this any longer. +-- extractCont :: (a -> Maybe ([a] -> b)) -> [a] -> Maybe b +-- extractCont f = go id +-- where +-- go _ [] = Nothing +-- go startList (x : xs) = case f x of +-- Nothing -> go ((x :) . startList) xs +-- Just g -> Just (g (startList xs)) diff --git a/src/UI/Butcher/Internal/ApplicativeTypes.hs b/src/UI/Butcher/Internal/ApplicativeTypes.hs new file mode 100644 index 0000000..bdb25bf --- /dev/null +++ b/src/UI/Butcher/Internal/ApplicativeTypes.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeOperators #-} +-- {-# LANGUAGE PolyKinds #-} + +module UI.Butcher.Internal.ApplicativeTypes + ( PartDesc(..) + , EpsilonFlag(..) + , CmdParser + , ManyUpperBound(..) + , Input(..) + , CommandDesc(..) + , CmdParserF(..) + , convertStringToInputParse + , Visibility(..) + , CompletionItem(..) + , ParsingError(..) + , EnrichedCmdParserF(..) + , ReorderUnit(..) + ) +where + + + +#include "prelude.inc" +import Control.Applicative.Free +import qualified Control.Monad.Trans.MultiState.Strict + as MultiStateS +import Data.STRef + +import Data.Coerce ( coerce ) +import GHC.TypeLits ( Nat ) + +import qualified Text.PrettyPrint as PP + +import UI.Butcher.Internal.CommonTypes + as CommonTypes + + + +data CmdParserF out a + = CmdParserHelp PP.Doc a + | CmdParserSynopsis String a + | CmdParserPeekDesc (CommandDesc -> a) + | CmdParserPeekInput (String -> a) + | forall p . Typeable p => CmdParserPartInp + PartDesc + (Input -> EpsilonFlag -> Maybe (p, Input)) + (p -> a) + | forall p . Typeable p => CmdParserPartManyInp + ManyUpperBound + PartDesc + (Input -> EpsilonFlag -> Maybe (p, Input)) + ([p] -> a) + | CmdParserChild String Visibility (CmdParser out out) a + | CmdParserReorderStart a + | CmdParserReorderStop a + +type CmdParser out = Ap (CmdParserF out) + +data EnrichedCmdParserF s out a + = forall p . Typeable p => ViaRef (STRef s (Maybe p)) (p -> a) + | forall p . Typeable p => ViaRefMany (STRef s [p]) ([p] -> a) + | Lifted (CmdParserF out a) + | Final (CmdParser out a) + +data ReorderUnit s + = forall p . ReorderUnit (STRef s (Maybe p)) + (Input -> EpsilonFlag -> Maybe (p, Input)) + | forall p . ReorderUnitMany ManyUpperBound + (STRef s [p]) + (Input -> EpsilonFlag -> Maybe (p, Input)) + +convertStringToInputParse + :: (String -> EpsilonFlag -> (Maybe (p, String))) + -> (Input -> EpsilonFlag -> Maybe (p, Input)) +convertStringToInputParse f i e = case i of + InputString s -> case f s e of + Nothing -> Nothing + Just (p, rest) -> Just (p, InputString rest) + input@(InputArgs (a1 : ar)) -> case f a1 e of + Just (p, "") -> Just (p, InputArgs ar) + Just (p, rest) | rest == a1 -> Just (p, input) + _ -> Nothing + InputArgs [] -> case f "" e of + Just (p, "") -> Just (p, InputArgs []) + _ -> Nothing diff --git a/src/UI/Butcher/Internal/BasicStringParser.hs b/src/UI/Butcher/Internal/BasicStringParser.hs new file mode 100644 index 0000000..d31cdb2 --- /dev/null +++ b/src/UI/Butcher/Internal/BasicStringParser.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module UI.Butcher.Internal.BasicStringParser + ( InpParseString(..) + , runInpParseString + , pExpect + , pExpectEof + , pDropSpace + , pOption + ) +where + + + +#include "prelude.inc" + + + +-- 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 () + diff --git a/src/UI/Butcher/Monadic/Internal/Types.hs b/src/UI/Butcher/Internal/CommonTypes.hs similarity index 72% rename from src/UI/Butcher/Monadic/Internal/Types.hs rename to src/UI/Butcher/Internal/CommonTypes.hs index c1ca40e..6a01699 100644 --- a/src/UI/Butcher/Monadic/Internal/Types.hs +++ b/src/UI/Butcher/Internal/CommonTypes.hs @@ -5,25 +5,25 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} -module UI.Butcher.Monadic.Internal.Types +module UI.Butcher.Internal.CommonTypes ( CommandDesc (..) , cmd_mParent , cmd_help , cmd_synopsis , cmd_parts - , cmd_out + , cmd_hasImpl , cmd_children , cmd_visibility , emptyCommandDesc - , CmdParserF (..) - , CmdParser , PartDesc (..) , Input (..) + , EpsilonFlag (..) , ParsingError (..) , addSuggestion , ManyUpperBound (..) , Visibility (..) , CompletionItem (..) + , PartialParseInfo (..) ) where @@ -47,45 +47,26 @@ import qualified Text.PrettyPrint as PP data Input = InputString String | InputArgs [String] deriving (Show, Eq) +data EpsilonFlag = AllowEpsilon | DenyEpsilon deriving 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 + { _pe_messages :: [String] + , _pe_remaining :: Input + , _pe_expectedDesc :: Maybe PartDesc } - deriving (Show, Eq) + deriving (Show) -- | Specifies whether we accept 0-1 or 0-n for @CmdParserPart@s. data ManyUpperBound = ManyUpperBound1 | ManyUpperBoundN + deriving Eq data Visibility = Visible | Hidden deriving (Show, Eq) -data CmdParserF f out a - = CmdParserHelp PP.Doc a - | CmdParserSynopsis String a - | CmdParserPeekDesc (CommandDesc () -> a) - | CmdParserPeekInput (String -> a) - -- TODO: we can clean up this duplication by providing - -- a function (String -> Maybe (p, String)) -> (Input -> Maybe (p, Input)). - | forall p . Typeable p => CmdParserPart PartDesc (String -> Maybe (p, String)) (p -> f ()) (p -> a) - | forall p . Typeable p => CmdParserPartMany ManyUpperBound PartDesc (String -> Maybe (p, String)) (p -> f ()) ([p] -> a) - | forall p . Typeable p => CmdParserPartInp PartDesc (Input -> Maybe (p, Input)) (p -> f ()) (p -> a) - | forall p . Typeable p => CmdParserPartManyInp ManyUpperBound PartDesc (Input -> Maybe (p, Input)) (p -> f ()) ([p] -> a) - | CmdParserChild (Maybe String) Visibility (CmdParser f out ()) (f ()) a - | CmdParserImpl out a - | CmdParserReorderStart a - | CmdParserReorderStop a - | CmdParserGrouped String a - | CmdParserGroupEnd a - | forall p . Typeable p => CmdParserAlternatives PartDesc [((String -> Bool), CmdParser f out p)] (p -> a) - --- | The CmdParser monad type. It is a free monad over some functor but users --- of butcher don't need to know more than that 'CmdParser' is a 'Monad'. -type CmdParser f out = Free (CmdParserF f out) - -- type CmdParser a = CmdParserM a a @@ -115,13 +96,13 @@ type CmdParser f out = Free (CmdParserF f out) -- -- Note that there is the '_cmd_out' accessor that contains @Maybe out@ which -- might be useful after successful parsing. -data CommandDesc out = CommandDesc - { _cmd_mParent :: Maybe (Maybe String, CommandDesc out) +data CommandDesc = CommandDesc + { _cmd_mParent :: Maybe (Maybe String, CommandDesc) , _cmd_synopsis :: Maybe PP.Doc , _cmd_help :: Maybe PP.Doc , _cmd_parts :: [PartDesc] - , _cmd_out :: Maybe out - , _cmd_children :: Deque (Maybe String, CommandDesc out) + , _cmd_hasImpl :: Bool + , _cmd_children :: Deque (Maybe String, CommandDesc) -- we don't use a Map here because we'd like to -- retain the order. , _cmd_visibility :: Visibility @@ -179,27 +160,38 @@ command documentation structure -- -deriving instance Functor (CmdParserF f out) -deriving instance Functor CommandDesc - --- - -- | Empty 'CommandDesc' value. Mostly for butcher-internal usage. -emptyCommandDesc :: CommandDesc out +emptyCommandDesc :: CommandDesc emptyCommandDesc = - CommandDesc Nothing Nothing Nothing [] Nothing mempty Visible + CommandDesc Nothing Nothing Nothing [] False mempty Visible -instance Show (CommandDesc out) where +instance Show CommandDesc 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) -- +data PartialParseInfo out = PartialParseInfo + { _ppi_mainDesc :: CommandDesc + , _ppi_localDesc :: CommandDesc + , _ppi_value :: Either ParsingError (Maybe out) + , _ppi_line :: Input + , _ppi_rest :: Input + , _ppi_lastword :: String + , _ppi_choices :: [CompletionItem] + , _ppi_choicesHelp :: [(CompletionItem, Maybe String)] + , _ppi_choiceCommon :: String + , _ppi_inputSugg :: String + , _ppi_prioDesc :: Maybe PartDesc + , _ppi_interactiveHelp :: Int -> PP.Doc + } + +-- + LensTH.makeLenses ''CommandDesc LensTH.makeLenses ''PartDesc diff --git a/src/UI/Butcher/Internal/Interactive.hs b/src/UI/Butcher/Internal/Interactive.hs new file mode 100644 index 0000000..e5e9209 --- /dev/null +++ b/src/UI/Butcher/Internal/Interactive.hs @@ -0,0 +1,157 @@ +-- | Utilities when writing interactive programs that interpret commands, +-- e.g. a REPL. +module UI.Butcher.Internal.Interactive + ( partDescStrings + , CompletionItem(..) + , PartialParseInfo(..) + , combinedCompletion + ) +where + + + +#include "prelude.inc" + +import qualified Text.PrettyPrint as PP + +import UI.Butcher.Internal.Monadic +import UI.Butcher.Internal.MonadicTypes +import UI.Butcher.Monadic.Pretty + + + +combinedCompletion + :: Input + -> CommandDesc + -> CommandDesc + -> Input + -> Either ParsingError (Maybe out) + -> PartialParseInfo out +combinedCompletion line topDesc localDesc pcRest e = PartialParseInfo + { _ppi_mainDesc = topDesc + , _ppi_localDesc = localDesc + , _ppi_value = e + , _ppi_line = line + , _ppi_rest = pcRest + , _ppi_lastword = lastWord + , _ppi_choices = fst <$> choices + , _ppi_choicesHelp = choices + , _ppi_choiceCommon = longestCommonPrefix + , _ppi_inputSugg = compl + , _ppi_prioDesc = prioDesc + , _ppi_interactiveHelp = interactiveHelp + } + where + lastWord = case line of + InputString s -> reverse $ takeWhile (not . Char.isSpace) $ reverse s + InputArgs ss -> List.last ss + nullRest = case pcRest of + InputString s -> null s + InputArgs ss -> null ss + nameDesc = case _cmd_mParent localDesc of + Nothing -> localDesc + Just (_, parent) | nullRest && not (null lastWord) -> parent + -- not finished writing a command. if we have commands abc and abcdef, + -- we may want "def" as a completion after "abc". + Just{} -> localDesc + choicesViaParent :: [(CompletionItem, Maybe String)] -- input, help + choicesViaParent = join + [ [ (CompletionString r, fmap show $ _cmd_synopsis c) + | (Just r, c) <- Data.Foldable.toList (_cmd_children nameDesc) + , lastWord `isPrefixOf` r + -- , lastWord /= r + ] + , [ (CompletionString s, h) -- TODO we might not want to restrict to + -- CompletionString here + | (CompletionString s, h) <- partDescComplsWithHelp Nothing + =<< _cmd_parts nameDesc + , lastWord `isPrefixOf` s + -- , lastWord /= s + ] + ] + prioDesc = case e of + Left err -> _pe_expectedDesc err + Right{} -> Nothing + choices = case prioDesc of + Just d -> partDescComplsWithHelp Nothing d + Nothing -> choicesViaParent + complStrs = [ s | (CompletionString s, _) <- choices ] + longestCommonPrefix = case complStrs of + [] -> "" + (c1 : cr) -> + case + find (\s -> List.all (s `isPrefixOf`) cr) $ reverse $ List.inits c1 + of + Nothing -> "" + Just x -> x + compl = List.drop (List.length lastWord) longestCommonPrefix + nullLine = case line of + InputString "" -> True + InputArgs [] -> True + _ -> False + interactiveHelp maxLines = if + | nullLine -> helpStrShort + | null lastWord -> helpStrShort + | nullRest -> helpStr maxLines + | otherwise -> helpStr maxLines + helpStr maxLines = if List.length choices > maxLines + then PP.fcat $ List.intersperse (PP.text "|") $ PP.text <$> complStrs + else PP.vcat $ choices >>= \case + (CompletionString s, Nothing) -> [PP.text s] + (CompletionString s, Just h ) -> [PP.text s PP.<+> PP.text h] + (_ , Nothing) -> [] + (_ , Just h ) -> [PP.text h] + helpStrShort = ppUsageWithHelp localDesc + + +partDescComplsWithHelp + :: Maybe String -> PartDesc -> [(CompletionItem, Maybe String)] +partDescComplsWithHelp mHelp = \case + PartLiteral s -> [(CompletionString s, mHelp)] + PartVariable _ -> [] + -- TODO: we could handle seq of optional and such much better + PartOptional x -> rec x + PartAlts alts -> alts >>= rec + PartSeq [] -> [] + PartSeq (x : _) -> rec x + PartDefault _ x -> rec x + PartSuggestion ss x -> [ (c, mHelp) | c <- ss ] ++ rec x + PartRedirect _ x -> rec x + PartReorder xs -> xs >>= rec + PartMany x -> rec x + PartWithHelp h x -> partDescComplsWithHelp (Just $ show h) x + PartHidden{} -> [] + where rec = partDescComplsWithHelp mHelp + + +-- | Obtains a list of "expected"/potential strings for a command part +-- described in the 'PartDesc'. In constrast to the 'simpleCompletion' +-- function this function does not take into account any current input, and +-- consequently the output elements can in general not be appended to partial +-- input to form valid input. +partDescStrings :: PartDesc -> [String] +partDescStrings = \case + PartLiteral s -> [s] + PartVariable _ -> [] + -- TODO: we could handle seq of optional and such much better + PartOptional x -> partDescStrings x + PartAlts alts -> alts >>= partDescStrings + PartSeq [] -> [] + PartSeq (x : _) -> partDescStrings x + PartDefault _ x -> partDescStrings x + PartSuggestion ss x -> [ s | CompletionString s <- ss ] ++ partDescStrings x + PartRedirect _ x -> partDescStrings x + PartReorder xs -> xs >>= partDescStrings + PartMany x -> partDescStrings x + PartWithHelp _h x -> partDescStrings x -- TODO: handle help + PartHidden{} -> [] + + +-- | Obtains a list of "expected"/potential strings for a command part +-- described in the 'PartDesc'. In constrast to the 'simpleCompletion' +-- function this function does not take into account any current input, and +-- consequently the output elements can in general not be appended to partial +-- input to form valid input. +-- This is currently not properly implemented +_partDescCompletions :: PartDesc -> [CompletionItem] +_partDescCompletions = fmap CompletionString . partDescStrings diff --git a/src/UI/Butcher/Monadic/Internal/Core.hs b/src/UI/Butcher/Internal/Monadic.hs similarity index 58% rename from src/UI/Butcher/Monadic/Internal/Core.hs rename to src/UI/Butcher/Internal/Monadic.hs index 8061a26..7c7c17e 100644 --- a/src/UI/Butcher/Monadic/Internal/Core.hs +++ b/src/UI/Butcher/Internal/Monadic.hs @@ -5,7 +5,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TemplateHaskell #-} -module UI.Butcher.Monadic.Internal.Core +{-# LANGUAGE TypeApplications #-} +module UI.Butcher.Internal.Monadic ( addCmdSynopsis , addCmdHelp , addCmdHelpStr @@ -26,11 +27,14 @@ module UI.Butcher.Monadic.Internal.Core , addAlternatives , reorderStart , reorderStop - , checkCmdParser - , runCmdParser - , runCmdParserExt - , runCmdParserA - , runCmdParserAExt + , toCmdDesc + , traverseBarbie + -- , runCmdParser + -- , runCmdParserA + -- , runCmdParserCore + -- , runCmdParserCoreA + , runCmdParserCoreFromDesc + , runCmdParserCoreFromDescA , mapOut , varPartDesc ) @@ -39,28 +43,32 @@ where #include "prelude.inc" + +import qualified Barbies +import qualified Barbies.Bare as Barbies import Control.Monad.Free import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS +import Data.Monoid ( First(..) ) import qualified Lens.Micro as Lens import Lens.Micro ( (%~) , (.~) ) import qualified Text.PrettyPrint as PP -import Text.PrettyPrint ( (<+>) - , ($$) +import Text.PrettyPrint ( ($$) , ($+$) + , (<+>) ) import Data.HList.ContainsType import Data.Dynamic -import UI.Butcher.Monadic.Internal.Types +import UI.Butcher.Internal.MonadicTypes @@ -75,11 +83,11 @@ mModify f = mGet >>= mSet . f -- 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) +-- (.=+) :: 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 @@ -117,15 +125,9 @@ addCmdHelp s = liftF $ CmdParserHelp s () 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 ()) +-- | Get the CommandDesc on the current level of the parser +-- (i.e. for a command child, you get the child's CommandDesc). +peekCmdDesc :: CmdParser f out CommandDesc peekCmdDesc = liftF $ CmdParserPeekDesc id -- | Semi-hacky way of accessing the current input that is not yet processed. @@ -144,14 +146,14 @@ peekInput = liftF $ CmdParserPeekInput id addCmdPart :: (Applicative f, Typeable p) => PartDesc - -> (String -> Maybe (p, String)) + -> PartParser p String -> CmdParser f out p addCmdPart p f = liftF $ CmdParserPart p f (\_ -> pure ()) id addCmdPartA :: (Typeable p) => PartDesc - -> (String -> Maybe (p, String)) + -> PartParser p String -> (p -> f ()) -> CmdParser f out p addCmdPartA p f a = liftF $ CmdParserPart p f a id @@ -162,7 +164,7 @@ addCmdPartMany :: (Applicative f, Typeable p) => ManyUpperBound -> PartDesc - -> (String -> Maybe (p, String)) + -> PartParser p String -> CmdParser f out [p] addCmdPartMany b p f = liftF $ CmdParserPartMany b p f (\_ -> pure ()) id @@ -170,7 +172,7 @@ addCmdPartManyA :: (Typeable p) => ManyUpperBound -> PartDesc - -> (String -> Maybe (p, String)) + -> PartParser p String -> (p -> f ()) -> CmdParser f out [p] addCmdPartManyA b p f a = liftF $ CmdParserPartMany b p f a id @@ -183,14 +185,14 @@ addCmdPartManyA b p f a = liftF $ CmdParserPartMany b p f a id addCmdPartInp :: (Applicative f, Typeable p) => PartDesc - -> (Input -> Maybe (p, Input)) + -> PartParser p Input -> CmdParser f out p addCmdPartInp p f = liftF $ CmdParserPartInp p f (\_ -> pure ()) id addCmdPartInpA :: (Typeable p) => PartDesc - -> (Input -> Maybe (p, Input)) + -> PartParser p Input -> (p -> f ()) -> CmdParser f out p addCmdPartInpA p f a = liftF $ CmdParserPartInp p f a id @@ -204,7 +206,7 @@ addCmdPartManyInp :: (Applicative f, Typeable p) => ManyUpperBound -> PartDesc - -> (Input -> Maybe (p, Input)) + -> PartParser p Input -> CmdParser f out [p] addCmdPartManyInp b p f = liftF $ CmdParserPartManyInp b p f (\_ -> pure ()) id @@ -212,7 +214,7 @@ addCmdPartManyInpA :: (Typeable p) => ManyUpperBound -> PartDesc - -> (Input -> Maybe (p, Input)) + -> PartParser p Input -> (p -> f ()) -> CmdParser f out [p] addCmdPartManyInpA b p f a = liftF $ CmdParserPartManyInp b p f a id @@ -250,8 +252,8 @@ addAlternatives -> CmdParser f out p addAlternatives elems = liftF $ CmdParserAlternatives desc alts id where - desc = PartAlts $ [PartVariable s | (s, _, _) <- elems] - alts = [(a, b) | (_, a, b) <- elems] + desc = PartAlts $ [ PartVariable s | (s, _, _) <- elems ] + alts = [ (a, b) | (_, a, b) <- elems ] -- | Create a simple PartDesc from a string. varPartDesc :: String -> PartDesc @@ -292,6 +294,17 @@ reorderStart = liftF $ CmdParserReorderStart () reorderStop :: CmdParser f out () reorderStop = liftF $ CmdParserReorderStop () +-- | Takes a barbie over a parser and returns a parser that returns parsed +-- values, in the same structure. +traverseBarbie + :: (Barbies.BareB c, Barbies.TraversableB (c Barbies.Covered)) + => c Barbies.Covered (CmdParser f out) + -> CmdParser f out (c Barbies.Bare Identity) +traverseBarbie k = do + r <- Barbies.btraverse (fmap Identity) k + pure $ Barbies.bstrip r + + -- addPartHelp :: String -> CmdPartParser () -- addPartHelp s = liftF $ CmdPartParserHelp s () -- @@ -301,18 +314,13 @@ reorderStop = liftF $ CmdParserReorderStop () -- addPartParserOptionalBasic :: CmdPartParser p -> CmdPartParser (Maybe p) -- addPartParserOptionalBasic p = liftF $ CmdPartParserOptional p id -data PartGatherData f - = forall p . Typeable p => PartGatherData - { _pgd_id :: Int - , _pgd_desc :: PartDesc - , _pgd_parseF :: Either (String -> Maybe (p, String)) - (Input -> Maybe (p, Input)) - , _pgd_act :: p -> f () - , _pgd_many :: Bool - } - -data ChildGather f out = - ChildGather (Maybe String) Visibility (CmdParser f out ()) (f ()) +data PartGatherData f = forall p . Typeable p => PartGatherData + { _pgd_id :: Int + , _pgd_desc :: PartDesc + , _pgd_parseF :: Either (PartParser p String) (PartParser p Input) + , _pgd_act :: p -> f () + , _pgd_many :: Bool + } type PartParsedData = Map Int [Dynamic] @@ -334,43 +342,42 @@ descStackAdd d = \case -- 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 +toCmdDesc :: forall f out . Maybe String -- ^ top-level command name -> CmdParser f out () -- ^ parser to check - -> Either String (CommandDesc ()) -checkCmdParser mTopLevel cmdParser = + -> Either String CommandDesc +toCmdDesc mTopLevel cmdParser = (>>= final) $ MultiRWSS.runMultiRWSTNil $ MultiRWSS.withMultiStateAS (StackBottom mempty) $ MultiRWSS.withMultiStateS emptyCommandDesc $ processMain cmdParser where - final :: (CommandDesc out, CmdDescStack) -> Either String (CommandDesc ()) + final :: (CommandDesc, CmdDescStack) -> Either String CommandDesc final (desc, stack) = case stack of StackBottom descs -> Right - $ descFixParentsWithTopM - (mTopLevel <&> \n -> (Just n, emptyCommandDesc)) - $ () - <$ desc { _cmd_parts = Data.Foldable.toList descs } + $ descFixParentsWithTopM + (mTopLevel <&> \n -> (Just n, emptyCommandDesc)) + $ desc { _cmd_parts = Data.Foldable.toList descs } StackLayer _ _ _ -> Left "unclosed ReorderStart or GroupStart" processMain :: CmdParser f out a -> MultiRWSS.MultiRWST '[] '[] - '[CommandDesc out, CmdDescStack] + '[CommandDesc , CmdDescStack] (Either String) a processMain = \case Pure x -> return x Free (CmdParserHelp h next) -> do - cmd :: CommandDesc out <- mGet + cmd :: CommandDesc <- mGet mSet $ cmd { _cmd_help = Just h } processMain next Free (CmdParserSynopsis s next) -> do - cmd :: CommandDesc out <- mGet + cmd :: CommandDesc <- mGet mSet $ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s } processMain next @@ -399,11 +406,11 @@ checkCmdParser mTopLevel cmdParser = mSet $ descStackAdd (wrapBoundDesc bound desc) descStack processMain $ nextF monadMisuseError Free (CmdParserChild cmdStr vis sub _act next) -> do - mInitialDesc <- takeCommandChild cmdStr - cmd :: CommandDesc out <- mGet - subCmd <- do + mInitialDesc <- takeCommandChild cmdStr + cmd :: CommandDesc <- mGet + subCmd <- do stackCur :: CmdDescStack <- mGet - mSet $ Maybe.fromMaybe (emptyCommandDesc :: CommandDesc out) mInitialDesc + mSet $ Maybe.fromMaybe (emptyCommandDesc :: CommandDesc) mInitialDesc mSet $ StackBottom mempty processMain sub c <- mGet @@ -418,8 +425,9 @@ checkCmdParser mTopLevel cmdParser = { _cmd_children = (cmdStr, subCmd) `Deque.snoc` _cmd_children cmd } processMain next - Free (CmdParserImpl out next) -> do - cmd_out .=+ Just out + Free (CmdParserImpl _out next) -> do + -- no need to process _out when we just construct the CommandDesc. + -- it would be full of monadmisuse-errors anyway. processMain $ next Free (CmdParserGrouped groupName next) -> do stackCur <- mGet @@ -456,13 +464,20 @@ checkCmdParser mTopLevel cmdParser = let go :: [(String -> Bool, CmdParser f out p)] -> MultiRWSS.MultiRWST - '[] '[] '[CommandDesc out, CmdDescStack] (Either String) p - go [] = lift $ Left $ "Empty alternatives" - go [(_, alt)] = processMain alt - go ((_, alt1):altr) = do - case MultiRWSS.runMultiRWSTNil $ MultiRWSS.withMultiStates states (processMain alt1) of - Left{} -> go altr - Right (p, states') -> MultiRWSS.mPutRawS states' $> p + '[] + '[] + '[CommandDesc , CmdDescStack] + (Either String) + p + go [] = lift $ Left $ "Empty alternatives" + go [(_, alt) ] = processMain alt + go ((_, alt1) : altr) = do + case + MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiStates states (processMain alt1) + of + Left{} -> go altr + Right (p, states') -> MultiRWSS.mPutRawS states' $> p p <- go alts processMain $ nextF p @@ -472,8 +487,67 @@ checkCmdParser mTopLevel cmdParser = $ "CmdParser definition error -" ++ " used Monad powers where only Applicative/Arrow is allowed" -newtype PastCommandInput = PastCommandInput Input +data CoreInterpreterState f out = CoreInterpreterState + { _cis_remainingInput :: Input + , _cis_pastCommandInput :: Input + , _cis_output :: Maybe out + , _cis_currentParser :: CmdParser f out () + , _cis_currentDesc :: CommandDesc + , _cis_expectedPartDesc :: Maybe PartDesc + } + + +{- +runCmdParser + :: forall out + . Maybe String -- ^ top-level command name + -> Input + -> CmdParser Identity out () + -> Either ParsingError (Maybe out) +runCmdParser mTopLevel initialInput initialParser = + let (_, _, _, r) = runCmdParserCore mTopLevel initialInput initialParser + in r + +runCmdParserA + :: forall f out + . Applicative f + => Maybe String -- ^ top-level command name + -> Input + -> CmdParser f out () + -> f (Either ParsingError (Maybe out)) +runCmdParserA mTopLevel initialInput initialParser = + let f (_, _, r) = r + in f <$> snd (runCmdParserCoreA mTopLevel initialInput initialParser) + + +runCmdParserCore + :: forall out + . Maybe String -- ^ top-level command name + -> Input + -> CmdParser Identity out () + -> (CommandDesc, CommandDesc, Input, Either ParsingError (Maybe out)) +runCmdParserCore mTopLevel initialInput initialParser = + let topDesc = case toCmdDesc mTopLevel initialParser of + Left err -> error err + Right d -> d + (finalDesc, finalInput, result) = + runCmdParserCoreFromDesc topDesc initialInput initialParser + in (topDesc, finalDesc, finalInput, result) + +runCmdParserCoreA + :: forall f out + . Applicative f + => Maybe String -- ^ top-level command name + -> Input + -> CmdParser f out () + -> (CommandDesc, f (CommandDesc, Input, Either ParsingError (Maybe out))) +runCmdParserCoreA mTopLevel initialInput initialParser = + let topDesc = case toCmdDesc mTopLevel initialParser of + Left err -> error err + Right d -> d + in (topDesc, runCmdParserCoreFromDescA topDesc initialInput initialParser) +-} -- | Run a @CmdParser@ on the given input, returning: -- @@ -484,316 +558,207 @@ newtype PastCommandInput = PastCommandInput Input -- 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@ +runCmdParserCoreFromDesc + :: CommandDesc -- ^ cached desc -> 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 + -> (CommandDesc, Input, Either ParsingError (Maybe out)) +runCmdParserCoreFromDesc topDesc inputInitial cmdParser = + runIdentity $ runCmdParserCoreFromDescA topDesc inputInitial cmdParser --- | The Applicative-enabled version of 'runCmdParser'. -runCmdParserA +-- | The Applicative-enabled version of 'runCmdParserCoreFromDesc'. +runCmdParserCoreFromDescA :: forall f out . Applicative f - => Maybe String -- ^ program name to be used for the top-level @CommandDesc@ + => CommandDesc -- ^ cached desc -> 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 = + -> f (CommandDesc, Input, Either ParsingError (Maybe out)) +runCmdParserCoreFromDescA topDesc inputInitial cmdParser = runIdentity $ MultiRWSS.runMultiRWSTNil - $ (<&> captureFinal) + $ fmap captureFinal $ MultiRWSS.withMultiWriterWA - $ MultiRWSS.withMultiStateA cmdParser - $ MultiRWSS.withMultiStateSA (StackBottom mempty) - $ MultiRWSS.withMultiStateSA inputInitial - $ MultiRWSS.withMultiStateSA (PastCommandInput inputInitial) - $ MultiRWSS.withMultiStateSA initialCommandDesc + $ MultiRWSS.withMultiStateSA initialState $ processMain cmdParser where - initialCommandDesc = emptyCommandDesc - { _cmd_mParent = mTopLevel <&> \n -> (Just n, emptyCommandDesc) - } + initialState = CoreInterpreterState { _cis_remainingInput = inputInitial + , _cis_pastCommandInput = inputInitial + , _cis_output = Nothing + , _cis_currentParser = cmdParser + , _cis_currentDesc = topDesc + , _cis_expectedPartDesc = Nothing + } captureFinal - :: ( [String] - , (CmdDescStack, (Input, (PastCommandInput, (CommandDesc out, f ())))) - ) - -> f (CommandDesc (), Input, Either ParsingError (CommandDesc out)) - captureFinal tuple1 = act $> (() <$ cmd', pastCmdInput, res) + :: ([String], (CoreInterpreterState f out, f ())) + -> f (CommandDesc, Input, Either ParsingError (Maybe out)) + captureFinal (errs, (finalState, act)) = + act $> (_cis_currentDesc finalState, _cis_pastCommandInput finalState, res) where - (errs , tuple2) = tuple1 - (descStack , tuple3) = tuple2 - (inputRest , tuple4) = tuple3 - (PastCommandInput pastCmdInput, tuple5) = tuple4 - (cmd , act ) = tuple5 - errs' = errs ++ inputErrs ++ stackErrs - inputErrs = case inputRest of + errs' = errs ++ inputErrs + inputErrs = case _cis_remainingInput finalState 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 + res = if null errs' + then Right (_cis_output finalState) + else Left $ ParsingError + { _pe_messages = errs' + , _pe_remaining = _cis_remainingInput finalState + , _pe_expectedDesc = _cis_expectedPartDesc finalState + } processMain :: -- forall a CmdParser f out () -> MultiRWSS.MultiRWS '[] '[[String]] - '[CommandDesc out, PastCommandInput, Input, CmdDescStack, CmdParser - f - out - ()] + '[CoreInterpreterState f out] (f ()) processMain = \case - Pure () -> return $ pure () - Free (CmdParserHelp h next) -> do - cmd :: CommandDesc out <- mGet - mSet $ cmd { _cmd_help = Just h } + Pure () -> return $ pure () + Free (CmdParserHelp _h next) -> do processMain next - Free (CmdParserSynopsis s next) -> do - cmd :: CommandDesc out <- mGet - mSet - $ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s } + Free (CmdParserSynopsis _s next) -> do processMain next Free (CmdParserPeekDesc nextF) -> do - parser :: CmdParser f out () <- mGet - -- partialDesc :: CommandDesc out <- mGet - -- partialStack :: CmdDescStack <- mGet - -- run the rest without affecting the actual stack - -- to retrieve the complete cmddesc. - cmdCur :: CommandDesc out <- mGet - let (cmd :: CommandDesc out, stack) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiStateSA emptyCommandDesc - { _cmd_mParent = _cmd_mParent cmdCur - } -- partialDesc - $ MultiRWSS.withMultiStateS (StackBottom mempty) -- partialStack - $ iterM processCmdShallow - $ parser - processMain $ nextF $ () <$ postProcessCmd stack cmd + cis :: CoreInterpreterState f out <- mGet + processMain $ nextF (_cis_currentDesc cis) 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 + cis :: CoreInterpreterState f out <- mGet + case _cis_remainingInput cis of InputString str -> case parseF str of - Just (x, rest) -> do - mSet $ InputString rest + Success x rest -> do + mSet $ cis { _cis_remainingInput = InputString rest } actRest <- processMain $ nextF x return $ actF x *> actRest - Nothing -> do + Failure errPDesc -> do mTell ["could not parse " ++ getPartSeqDescPositionName desc] + trySetErrDesc errPDesc processMain $ nextF monadMisuseError - InputArgs (str:strr) -> case parseF str of - Just (x, "") -> do - mSet $ InputArgs strr + InputArgs (str : strr) -> case parseF str of + Success x "" -> do + mSet $ cis { _cis_remainingInput = InputArgs strr } actRest <- processMain $ nextF x return $ actF x *> actRest - Just (x, rest) | str == rest -> do + Success x rest | str == rest -> do -- no input consumed, default applied actRest <- processMain $ nextF x return $ actF x *> actRest - _ -> do + Success{} -> do mTell ["could not parse " ++ getPartSeqDescPositionName desc] processMain $ nextF monadMisuseError + Failure errPDesc -> do + mTell ["could not parse " ++ getPartSeqDescPositionName desc] + trySetErrDesc errPDesc + 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 + cis :: CoreInterpreterState f out <- mGet + case parseF (_cis_remainingInput cis) of + Success x rest -> do + mSet $ cis { _cis_remainingInput = rest } actRest <- processMain $ nextF x return $ actF x *> actRest - Nothing -> do + Failure errPDesc -> do mTell ["could not parse " ++ getPartSeqDescPositionName desc] + trySetErrDesc errPDesc processMain $ nextF monadMisuseError - Free (CmdParserPartMany bound desc parseF actF nextF) -> do - do - descStack <- mGet - mSet $ descStackAdd (wrapBoundDesc bound desc) descStack + Free (CmdParserPartMany _bound _desc parseF actF nextF) -> do let proc = do dropSpaces - input <- mGet - case input of + cis :: CoreInterpreterState f out <- mGet + case _cis_remainingInput cis of InputString str -> case parseF str of - Just (x, r) -> do - mSet $ InputString r + Success x r -> do + mSet $ cis { _cis_remainingInput = InputString r } xr <- proc return $ x : xr - Nothing -> return [] - InputArgs (str:strr) -> case parseF str of - Just (x, "") -> do - mSet $ InputArgs strr + Failure errPDesc -> do + trySetErrDesc errPDesc + return [] + InputArgs (str : strr) -> case parseF str of + Success x "" -> do + mSet $ cis { _cis_remainingInput = InputArgs strr } xr <- proc return $ x : xr - _ -> return [] + Success{} -> do + return [] + Failure errPDesc -> do + trySetErrDesc errPDesc + 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 + Free (CmdParserPartManyInp _bound _desc parseF actF nextF) -> do let proc = do dropSpaces - input <- mGet - case parseF input of - Just (x, r) -> do - mSet $ r + cis :: CoreInterpreterState f out <- mGet + case parseF (_cis_remainingInput cis) of + Success x r -> do + mSet $ cis { _cis_remainingInput = r } xr <- proc return $ x : xr - Nothing -> return [] + Failure errPDesc -> do + trySetErrDesc errPDesc + return [] r <- proc let act = traverse actF r (act *>) <$> processMain (nextF $ r) - f@(Free (CmdParserChild _ _ _ _ _)) -> do + Free (CmdParserChild mName _vis inner act next) -> do dropSpaces - input <- mGet - (gatheredChildren :: [ChildGather f out], restCmdParser) <- - MultiRWSS.withMultiWriterWA $ childrenGather f - let - child_fold - :: ( Deque (Maybe String) - , Map (Maybe String) (Visibility, CmdParser f out (), f ()) - ) - -> ChildGather f out - -> ( Deque (Maybe String) - , Map (Maybe String) (Visibility, CmdParser f out (), f ()) - ) - child_fold (c_names, c_map) (ChildGather name vis child act) = - case name `MapS.lookup` c_map of - Nothing -> - ( Deque.snoc name c_names - , MapS.insert name (vis, child, act) c_map - ) - Just (vis', child', act') -> - ( c_names - , MapS.insert name (vis', child' >> child, act') c_map - -- we intentionally override/ignore act here. - -- TODO: it should be documented that we expect the same act - -- on different child nodes with the same name. - ) - (child_name_list, child_map) = - foldl' child_fold (mempty, MapS.empty) gatheredChildren - combined_child_list = - Data.Foldable.toList child_name_list <&> \n -> (n, child_map MapS.! n) - let - mRest = asum $ combined_child_list <&> \(mname, (child, act, vis)) -> - case (mname, input) of + input <- mGet @(CoreInterpreterState f out) <&> _cis_remainingInput + let mRest = case (mName, input) of (Just name, InputString str) | name == str -> - Just $ (Just name, child, act, vis, InputString "") + Just $ (Just name, InputString "") (Just name, InputString str) | (name ++ " ") `isPrefixOf` str -> - Just - $ ( Just name - , child - , act - , vis - , InputString $ drop (length name + 1) str - ) - (Just name, InputArgs (str:strr)) | name == str -> - Just $ (Just name, child, act, vis, InputArgs strr) - (Nothing, _) -> Just $ (Nothing, child, act, vis, input) + Just $ (Just name, InputString $ drop (length name + 1) str) + (Just name, InputArgs (str : strr)) | name == str -> + Just $ (Just name, InputArgs strr) + (Nothing, _) -> Just $ (Nothing, input) _ -> Nothing - combined_child_list `forM_` \(child_name, (vis, child, _)) -> do - let initialDesc :: CommandDesc out = emptyCommandDesc - -- get the shallow desc for the child in a separate env. - let (subCmd, subStack) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiStateSA initialDesc - $ MultiRWSS.withMultiStateS (StackBottom mempty) - $ iterM processCmdShallow child - cmd_children %=+ Deque.snoc - ( child_name - , postProcessCmd subStack subCmd { _cmd_visibility = vis } - ) case mRest of Nothing -> do -- a child not matching what we have in the input -- get the shallow desc for the child in a separate env. -- proceed regularly on the same layer - processMain $ restCmdParser - Just (name, vis, child, act, rest) -> do -- matching child -> descend - -- process all remaining stuff on the same layer shallowly, - -- including the current node. This will walk over the child - -- definition(s) again, but that is harmless because we do not - -- overwrite them. - iterM processCmdShallow f + processMain next + Just (name, rest) -> do -- matching child -> descend -- do the descend - cmd <- do - c :: CommandDesc out <- mGet - prevStack :: CmdDescStack <- mGet - return $ postProcessCmd prevStack c - mSet $ rest - mSet $ PastCommandInput rest - mSet $ emptyCommandDesc { _cmd_mParent = Just (name, cmd) - , _cmd_visibility = vis - } - mSet $ child - mSet $ StackBottom mempty - childAct <- processMain child + mModify $ \cis -> cis + { _cis_remainingInput = rest + , _cis_pastCommandInput = rest + , _cis_currentDesc = + case + List.find + (\(n, _) -> name == n) + (Data.Foldable.toList $ _cmd_children $ _cis_currentDesc cis) + of + Nothing -> + error "butcher internal error: inconsistent child desc" + Just (_, childDesc) -> childDesc + , _cis_currentParser = inner + } + childAct <- processMain inner -- check that descending yielded return $ act *> childAct Free (CmdParserImpl out next) -> do - cmd_out .=+ Just out + mModify @(CoreInterpreterState f out) + $ \cis -> cis { _cis_output = Just out } processMain $ next - Free (CmdParserGrouped groupName next) -> do - stackCur <- mGet - mSet $ StackLayer mempty groupName stackCur + Free (CmdParserGrouped _groupName next) -> do 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 + processMain $ next Free (CmdParserReorderStop next) -> do mTell $ ["butcher interface error: reorder stop without reorder start"] processMain next @@ -809,43 +774,57 @@ runCmdParserAExt mTopLevel inputInitial cmdParser = 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 + -> First (Either PartDesc (Int, Dynamic, Input, Bool, f ())) + tryParsePartData input (PartGatherData pid _ pfe act allowMany) = + 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 + Success x r | r /= str -> + pure $ Right (pid, toDyn x, InputString r, allowMany, act x) + Failure (Just pDesc) -> pure $ Left pDesc + _ -> mempty + InputArgs (str : strr) -> case pfStr str of + Success x "" -> + pure $ Right (pid, toDyn x, InputArgs strr, allowMany, act x) + Failure (Just pDesc) -> pure $ Left pDesc + _ -> First Nothing + InputArgs [] -> First Nothing Right pfInp -> case pfInp input of - Just (x, r) | r /= input -> Just (x, r) - _ -> Nothing - ] + Success x r | r /= input -> + pure $ Right (pid, toDyn x, r, allowMany, act x) + Failure (Just pDesc) -> pure $ Left pDesc + _ -> First Nothing + + -- First + -- [ (pid, toDyn r, rest, allowMany, act r) + -- | (r, rest) <- + -- ] parseLoop = do - input <- mGet - m :: Map Int (PartGatherData f) <- mGet - case getFirst $ Data.Foldable.foldMap (tryParsePartData input) m of + cis :: CoreInterpreterState f out <- mGet + m :: Map Int (PartGatherData f) <- mGet + case + getFirst $ Data.Foldable.foldMap + (tryParsePartData $ _cis_remainingInput cis) + 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 + Nothing -> return $ pure () + Just (Right (pid, x, rest, more, act)) -> do + mSet cis { _cis_remainingInput = rest } + mModify $ MapS.insertWith (++) pid [x] + when (not more) $ do + mSet $ MapS.delete pid m + actRest <- parseLoop + return $ act *> actRest + Just (Left err) -> do + trySetErrDesc (Just err) + return $ pure () (finalMap, (fr, acts)) <- MultiRWSS.withMultiStateSA (MapS.empty :: PartParsedData) $ MultiRWSS.withMultiStateA reorderMapInit $ do - acts <- parseLoop -- filling the map - stackCur <- mGet - mSet $ StackLayer mempty "" stackCur + acts <- parseLoop -- filling the map fr <- MultiRWSS.withMultiStateA (1 :: Int) $ processParsedParts next return (fr, acts) -- we check that all data placed in the map has been consumed while @@ -859,18 +838,26 @@ runCmdParserAExt mTopLevel inputInitial cmdParser = return $ acts *> actRest else monadMisuseError Free (CmdParserAlternatives desc alts nextF) -> do - input :: Input <- mGet - case input of + cis :: CoreInterpreterState f out <- mGet + case _cis_remainingInput cis of InputString str - | Just (_, sub) <- find (\(predicate, _sub) -> predicate str) alts -> - processMain $ sub >>= nextF - InputArgs (str:_) - | Just (_, sub) <- find (\(predicate, _sub) -> predicate str) alts -> - processMain $ sub >>= nextF + | Just (_, sub) <- find (\(predicate, _sub) -> predicate str) alts + -> processMain $ sub >>= nextF + InputArgs (str : _) + | Just (_, sub) <- find (\(predicate, _sub) -> predicate str) alts + -> processMain $ sub >>= nextF _ -> do mTell ["could not parse any of " ++ getPartSeqDescPositionName desc] processMain $ nextF monadMisuseError + trySetErrDesc + :: (MonadMultiState (CoreInterpreterState f out) m) + => Maybe PartDesc + -> m () + trySetErrDesc errPDescMay = do + mModify $ \(cis :: CoreInterpreterState f out) -> cis + { _cis_expectedPartDesc = _cis_expectedPartDesc cis <|> errPDescMay + } reorderPartGather :: ( MonadMultiState Int m , MonadMultiWriter [PartGatherData f] m @@ -917,49 +904,15 @@ runCmdParserAExt mTopLevel inputInitial cmdParser = mTell ["Did not find expected ReorderStop after the reordered parts"] return () - childrenGather - :: ( MonadMultiWriter [ChildGather f out] m - , MonadMultiState (CmdParser f out ()) m - , MonadMultiState (CommandDesc out) m - ) - => CmdParser f out a - -> m (CmdParser f out a) - childrenGather = \case - Free (CmdParserChild cmdStr vis sub act next) -> do - mTell [ChildGather cmdStr vis sub act] - childrenGather next - Free (CmdParserPeekInput nextF) -> do - childrenGather $ nextF $ inputToString inputInitial - Free (CmdParserPeekDesc nextF) -> do - parser :: CmdParser f out () <- mGet - -- partialDesc :: CommandDesc out <- mGet - -- partialStack :: CmdDescStack <- mGet - -- run the rest without affecting the actual stack - -- to retrieve the complete cmddesc. - cmdCur :: CommandDesc out <- mGet - let (cmd :: CommandDesc out, stack) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiStateSA emptyCommandDesc - { _cmd_mParent = _cmd_mParent cmdCur - } -- partialDesc - $ MultiRWSS.withMultiStateS (StackBottom mempty) -- partialStack - $ iterM processCmdShallow - $ parser - childrenGather $ nextF $ () <$ postProcessCmd stack cmd - something -> return something - processParsedParts :: forall m r w s m0 a . ( MonadMultiState Int m , MonadMultiState PartParsedData m , MonadMultiState (Map Int (PartGatherData f)) m - , MonadMultiState Input m - , MonadMultiState (CommandDesc out) m + , MonadMultiState (CoreInterpreterState f out) m , MonadMultiWriter [[Char]] m + -- , ContainsType (CoreInterpreterState f out) s , m ~ MultiRWSS.MultiRWST r w s m0 - , ContainsType (CmdParser f out ()) s - , ContainsType CmdDescStack s , Monad m0 ) => CmdParser f out a @@ -973,28 +926,11 @@ runCmdParserAExt mTopLevel inputInitial cmdParser = 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 + Free (CmdParserGrouped _groupName next) -> do 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 + processParsedParts $ next Pure x -> return $ return $ x f -> do mTell ["Did not find expected ReorderStop after the reordered parts"] @@ -1007,22 +943,19 @@ runCmdParserAExt mTopLevel inputInitial cmdParser = -> (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 + cis :: CoreInterpreterState f out <- mGet let errorResult = do mTell [ "could not parse expected input " ++ getPartSeqDescPositionName desc ++ " with remaining input: " - ++ show input + ++ show (_cis_remainingInput cis) ] processParsedParts $ nextF monadMisuseError continueOrMisuse :: Maybe p -> m (CmdParser f out a) @@ -1035,11 +968,11 @@ runCmdParserAExt mTopLevel inputInitial cmdParser = -- previous parsedMap Nothing lookup. Just (PartGatherData _ _ pfe _ _) -> case pfe of Left pf -> case pf "" of - Nothing -> errorResult - Just (dx, _) -> continueOrMisuse $ cast dx + Success dx _ -> continueOrMisuse $ cast dx + Failure _ -> errorResult Right pf -> case pf (InputArgs []) of - Nothing -> errorResult - Just (dx, _) -> continueOrMisuse $ cast dx + Success dx _ -> continueOrMisuse $ cast dx + Failure _ -> errorResult Just [dx] -> continueOrMisuse $ fromDynamic dx Just _ -> monadMisuseError partMany @@ -1048,10 +981,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser = -> 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 + partMany _bound _desc nextF = do pid <- mGet mSet $ pid + 1 m :: PartParsedData <- mGet @@ -1063,112 +993,12 @@ runCmdParserAExt mTopLevel inputInitial cmdParser = Nothing -> monadMisuseError Just xs -> processParsedParts $ nextF xs - -- this does no error reporting at all. - -- user needs to use check for that purpose instead. - processCmdShallow - :: (MonadMultiState (CommandDesc out) m, MonadMultiState CmdDescStack m) - => CmdParserF f out (m a) - -> m a - processCmdShallow = \case - CmdParserHelp h next -> do - cmd :: CommandDesc out <- mGet - mSet $ cmd { _cmd_help = Just h } - next - CmdParserSynopsis s next -> do - cmd :: CommandDesc out <- mGet - mSet - $ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s } - next - CmdParserPeekDesc nextF -> do - mGet >>= nextF . fmap (\(_ :: out) -> ()) - CmdParserPeekInput nextF -> do - nextF $ inputToString inputInitial - CmdParserPart desc _parseF _act nextF -> do - do - stackCur <- mGet - mSet $ descStackAdd desc stackCur - nextF monadMisuseError - CmdParserPartInp desc _parseF _act nextF -> do - do - stackCur <- mGet - mSet $ descStackAdd desc stackCur - nextF monadMisuseError - CmdParserPartMany bound desc _parseF _act nextF -> do - do - stackCur <- mGet - mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur - nextF monadMisuseError - CmdParserPartManyInp bound desc _parseF _act nextF -> do - do - stackCur <- mGet - mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur - nextF monadMisuseError - CmdParserChild cmdStr vis _sub _act next -> do - mExisting <- takeCommandChild cmdStr - let childDesc :: CommandDesc out = - Maybe.fromMaybe emptyCommandDesc { _cmd_visibility = vis } mExisting - cmd_children %=+ Deque.snoc (cmdStr, childDesc) - next - CmdParserImpl out next -> do - cmd_out .=+ Just out - next - CmdParserGrouped groupName next -> do - stackCur <- mGet - mSet $ StackLayer mempty groupName stackCur - next - CmdParserGroupEnd next -> do - stackCur <- mGet - case stackCur of - StackBottom{} -> pure () - StackLayer _descs "" _up -> pure () - StackLayer descs groupName up -> do - mSet $ descStackAdd - (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) - up - next - CmdParserReorderStop next -> do - stackCur <- mGet - case stackCur of - StackBottom{} -> return () - StackLayer descs "" up -> do - mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up - StackLayer{} -> return () - next - CmdParserReorderStart next -> do - stackCur <- mGet - mSet $ StackLayer mempty "" stackCur - next - CmdParserAlternatives _ [] _ -> error "empty alternatives" - CmdParserAlternatives desc ((_, alt):_) nextF -> do - mModify (descStackAdd desc) - nextF =<< iterM processCmdShallow alt - - -- currently unused; was previously used during failure in - -- processParsedParts. Using this leads to duplicated descs, but I fear - -- that not using it also leads to certain problems (missing children?). - -- Probably want to re-write into proper two-phase 1) obtain desc 2) run - -- parser, like the applicative approach. - _failureCurrentShallowRerun - :: ( m ~ MultiRWSS.MultiRWST r w s m0 - , MonadMultiState (CmdParser f out ()) m - , MonadMultiState (CommandDesc out) m - , ContainsType CmdDescStack s - , Monad m0 - ) - => m () - _failureCurrentShallowRerun = do - parser :: CmdParser f out () <- mGet - cmd :: CommandDesc out <- - MultiRWSS.withMultiStateS emptyCommandDesc - $ iterM processCmdShallow parser - mSet cmd - - postProcessCmd :: CmdDescStack -> CommandDesc out -> CommandDesc out - postProcessCmd descStack cmd = descFixParents $ cmd - { _cmd_parts = case descStack of - StackBottom l -> Data.Foldable.toList l - StackLayer{} -> [] - } + -- 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 = @@ -1194,12 +1024,13 @@ runCmdParserAExt mTopLevel inputInitial cmdParser = PartHidden d -> f d where f = getPartSeqDescPositionName - dropSpaces :: MonadMultiState Input m => m () + dropSpaces :: MonadMultiState (CoreInterpreterState f out) m => m () dropSpaces = do - inp <- mGet - case inp of - InputString s -> mSet $ InputString $ dropWhile Char.isSpace s - InputArgs{} -> return () + cis :: CoreInterpreterState f out <- mGet + case _cis_remainingInput cis of + InputString s -> mSet + $ cis { _cis_remainingInput = InputString $ dropWhile Char.isSpace s } + InputArgs{} -> return () inputToString :: Input -> String inputToString (InputString s ) = s @@ -1215,9 +1046,7 @@ dequeLookupRemove key deque = case Deque.uncons deque of in (r, Deque.cons (k, v) rest') takeCommandChild - :: MonadMultiState (CommandDesc out) m - => Maybe String - -> m (Maybe (CommandDesc out)) + :: MonadMultiState CommandDesc m => Maybe String -> m (Maybe CommandDesc) takeCommandChild key = do cmd <- mGet let (r, children') = dequeLookupRemove key $ _cmd_children cmd @@ -1275,33 +1104,29 @@ wrapBoundDesc ManyUpperBound1 = PartOptional wrapBoundDesc ManyUpperBoundN = PartMany -descFixParents :: CommandDesc a -> CommandDesc a -descFixParents = descFixParentsWithTopM Nothing +_descFixParents :: CommandDesc -> CommandDesc +_descFixParents = descFixParentsWithTopM Nothing -- descFixParentsWithTop :: String -> CommandDesc a -> CommandDesc a -- descFixParentsWithTop s = descFixParentsWithTopM (Just (s, emptyCommandDesc)) descFixParentsWithTopM - :: Maybe (Maybe String, CommandDesc a) -> CommandDesc a -> CommandDesc a + :: Maybe (Maybe String, CommandDesc) -> CommandDesc -> CommandDesc descFixParentsWithTopM mTop topDesc = Data.Function.fix $ \fixed -> topDesc { _cmd_mParent = goUp fixed <$> (mTop <|> _cmd_mParent topDesc) , _cmd_children = _cmd_children topDesc <&> goDown fixed } where goUp - :: CommandDesc a - -> (Maybe String, CommandDesc a) - -> (Maybe String, CommandDesc a) + :: CommandDesc -> (Maybe String, CommandDesc) -> (Maybe String, CommandDesc) 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) + , _cmd_children = _cmd_children parent <&> \(n, c) -> + if n == childName then (n, child) else (n, c) } goDown - :: CommandDesc a - -> (Maybe String, CommandDesc a) - -> (Maybe String, CommandDesc a) + :: CommandDesc -> (Maybe String, CommandDesc) -> (Maybe String, CommandDesc) goDown parent (childName, child) = (,) childName $ Data.Function.fix $ \fixed -> child { _cmd_mParent = Just (childName, parent) diff --git a/src/UI/Butcher/Internal/MonadicTypes.hs b/src/UI/Butcher/Internal/MonadicTypes.hs new file mode 100644 index 0000000..0dcdc77 --- /dev/null +++ b/src/UI/Butcher/Internal/MonadicTypes.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module UI.Butcher.Internal.MonadicTypes + ( CommandDesc(..) + , cmd_mParent + , cmd_help + , cmd_synopsis + , cmd_parts + , cmd_children + , cmd_visibility + , emptyCommandDesc + , CmdParserF(..) + , CmdParser + , PartDesc(..) + , Input(..) + , ParsingError(..) + , addSuggestion + , ManyUpperBound(..) + , Visibility(..) + , CompletionItem(..) + , PartParseResult(..) + , PartParser + , PartialParseInfo(..) + , resultFromMaybe + ) +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 + +import UI.Butcher.Internal.CommonTypes + + + +data PartParseResult val input + = Success val input -- value, remaining input + | Failure (Maybe PartDesc) -- desc of the expected part, if appropriate + +type PartParser val input = input -> PartParseResult val input + +resultFromMaybe :: Maybe (val, input) -> PartParseResult val input +resultFromMaybe = \case + Just (x, r) -> Success x r + Nothing -> Failure Nothing + +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 (PartParser p String) (p -> f ()) (p -> a) + | forall p . Typeable p => CmdParserPartMany ManyUpperBound PartDesc (PartParser p String) (p -> f ()) ([p] -> a) + | forall p . Typeable p => CmdParserPartInp PartDesc (PartParser p Input) (p -> f ()) (p -> a) + | forall p . Typeable p => CmdParserPartManyInp ManyUpperBound PartDesc (PartParser p Input) (p -> f ()) ([p] -> a) + | CmdParserChild (Maybe String) Visibility (CmdParser f out ()) (f ()) a + | CmdParserImpl out a + | CmdParserReorderStart a + | CmdParserReorderStop a + | CmdParserGrouped String a + | CmdParserGroupEnd a + | forall p . Typeable p => CmdParserAlternatives PartDesc [((String -> Bool), CmdParser f out p)] (p -> a) + +-- | The CmdParser monad type. It is a free monad over some functor but users +-- of butcher don't need to know more than that 'CmdParser' is a 'Monad'. +type CmdParser f out = Free (CmdParserF f out) + + +-- type CmdParser a = CmdParserM a a + +-- data CmdPartParserF a +-- = CmdPartParserHelp String a +-- | forall p . CmdPartParserCore (String -> Maybe (p, String)) -- parser +-- (Maybe p) -- optional default value +-- (p -> a) +-- | forall p . CmdPartParserOptional (CmdPartParser p) +-- (Maybe p -> a) +-- -- the idea here was to allow adding some dynamic data to each "node" of +-- -- the output CommandDesc so the user can potentially add custom additional +-- -- information, and write a custom pretty-printer for e.g. help output +-- -- from that dynamically-enriched CommandDesc structure. +-- -- disabled for now, because i am not sure what exactly "adding to every +-- -- node" involves, because the mapping from Functor to Desc is nontrivial. +-- -- (and because i don't have a direct use-case at the moment..) +-- -- | CmdPartParserCustom Dynamic a +-- +-- type CmdPartParser = Free CmdPartParserF + +--------- + +{- +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) + +-- 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/Internal/Pretty.hs b/src/UI/Butcher/Internal/Pretty.hs new file mode 100644 index 0000000..280fc10 --- /dev/null +++ b/src/UI/Butcher/Internal/Pretty.hs @@ -0,0 +1,394 @@ + +-- | 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.Internal.Pretty + ( ppUsage + , ppUsageShortSub + , ppUsageAt + , ppHelpShallow + , ppHelpDepthOne + , ppUsageWithHelp + , ppPartDescUsage + , ppPartDescHeader + , parsingErrorString + , descendDescTo + ) +where + + + +#include "prelude.inc" +import Control.Monad.Free +import qualified Control.Monad.Trans.MultiRWS.Strict + as MultiRWSS +import qualified Control.Monad.Trans.MultiState.Strict + as MultiStateS + +import qualified Text.PrettyPrint as PP +import Text.PrettyPrint ( ($$) + , ($+$) + , (<+>) + ) + +import Data.HList.ContainsType + +import UI.Butcher.Internal.Monadic +import UI.Butcher.Internal.MonadicTypes + + + +-- | ppUsage exampleDesc yields: +-- +-- > example [--short] NAME [version | help] +ppUsage :: CommandDesc -> PP.Doc +ppUsage (CommandDesc mParent _syn _help parts hasImpl children _hidden) = + pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc] + where + pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc + pparents Nothing = PP.empty + pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n + pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) + partDocs = Maybe.mapMaybe ppPartDescUsage parts + visibleChildren = + [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ] + subsDoc = if + | null visibleChildren -> PP.empty + | hasImpl -> PP.brackets $ subDoc + | null parts -> subDoc + | otherwise -> PP.parens $ subDoc + subDoc = + PP.fcat + $ PP.punctuate (PP.text " | ") + $ Data.Foldable.toList + $ (PP.text . fst) + <$> visibleChildren + +-- | ppUsageShortSub exampleDesc yields: +-- +-- > example [--short] NAME +-- +-- I.e. Subcommands are abbreviated using the @@ label, instead +-- of being listed. +ppUsageShortSub :: CommandDesc -> PP.Doc +ppUsageShortSub (CommandDesc mParent _syn _help parts hasImpl children _hidden) + = pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc] + where + pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc + pparents Nothing = PP.empty + pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n + pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) + partDocs = Maybe.mapMaybe ppPartDescUsage parts + visibleChildren = + [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ] + subsDoc = if + | null visibleChildren -> PP.empty + | hasImpl -> PP.brackets $ subDoc + | otherwise -> subDoc + subDoc = if null visibleChildren then PP.empty else PP.text "" + +-- | ppUsageWithHelp exampleDesc yields: +-- +-- > example [--short] NAME +-- > [version | help]: a simple butcher example program +-- +-- And yes, the line break is not optimal in this instance with default print. +ppUsageWithHelp :: CommandDesc -> PP.Doc +ppUsageWithHelp (CommandDesc mParent _syn help parts hasImpl children _hidden) + = pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc + where + pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc + pparents Nothing = PP.empty + pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n + pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) + partDocs = Maybe.mapMaybe ppPartDescUsage parts + subsDoc = if + | null children -> PP.empty + | -- TODO: remove debug + hasImpl -> PP.brackets $ subDoc + | null parts -> subDoc + | otherwise -> PP.parens $ subDoc + subDoc = + PP.fcat + $ PP.punctuate (PP.text " | ") + $ Data.Foldable.toList + $ [ PP.text n | (Just n, c) <- children, _cmd_visibility c == Visible ] + helpDoc = case help of + Nothing -> PP.empty + Just h -> PP.text ":" PP.<+> h + +-- | > ppUsageAt [] = ppUsage +-- +-- fromJust $ ppUsageAt ["version"] exampleDesc yields: +-- +-- > example version [--porcelain] +ppUsageAt + :: [String] -- (sub)command sequence + -> CommandDesc + -> Maybe PP.Doc +ppUsageAt strings desc = ppUsage <$> descendDescTo strings desc + +-- | Access a child command's CommandDesc. +descendDescTo :: [String] -> CommandDesc -> Maybe (CommandDesc) +descendDescTo strings desc = case strings of + [] -> Just desc + (s : sr) -> do -- Maybe + (_, childDesc) <- find ((Just s ==) . fst) (_cmd_children desc) + descendDescTo sr childDesc + +-- | ppHelpShallow exampleDesc yields: +-- +-- > NAME +-- > +-- > example - a simple butcher example program +-- > +-- > USAGE +-- > +-- > example [--short] NAME [version | help] +-- > +-- > DESCRIPTION +-- > +-- > a very long help document +-- > +-- > ARGUMENTS +-- > +-- > --short make the greeting short +-- > NAME your name, so you can be greeted properly +ppHelpShallow :: CommandDesc -> PP.Doc +ppHelpShallow desc = + nameSection + $+$ usageSection + $+$ descriptionSection + $+$ partsSection + $+$ PP.text "" + where + CommandDesc mParent syn help parts _out _children _hidden = desc + nameSection = case mParent of + Nothing -> PP.empty + Just{} -> + PP.text "NAME" + $+$ PP.text "" + $+$ PP.nest + 2 + (case syn of + Nothing -> pparents mParent + Just s -> pparents mParent <+> PP.text "-" <+> s + ) + $+$ PP.text "" + pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc + pparents Nothing = PP.empty + pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n + pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) + usageSection = PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsage desc) + descriptionSection = case help of + Nothing -> PP.empty + Just h -> + PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h + partsSection = if null partsTuples + then PP.empty + else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest + 2 + (PP.vcat partsTuples) + partsTuples :: [PP.Doc] + partsTuples = parts >>= go + where + go = \case + PartLiteral{} -> [] + PartVariable{} -> [] + PartOptional p -> go p + PartAlts ps -> ps >>= go + PartSeq ps -> ps >>= go + PartDefault _ p -> go p + PartSuggestion _ p -> go p + PartRedirect s p -> + [PP.text s $$ PP.nest 20 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)] + ++ (PP.nest 2 <$> go p) + PartReorder ps -> ps >>= go + PartMany p -> go p + PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p + PartHidden{} -> [] + +-- | ppHelpDepthOne exampleDesc yields: +-- +-- > NAME +-- > +-- > example - a simple butcher example program +-- > +-- > USAGE +-- > +-- > example [--short] NAME +-- > +-- > DESCRIPTION +-- > +-- > a very long help document +-- > +-- > COMMANDS +-- > +-- > version +-- > help +-- > +-- > ARGUMENTS +-- > +-- > --short make the greeting short +-- > NAME your name, so you can be greeted properly +ppHelpDepthOne :: CommandDesc -> PP.Doc +ppHelpDepthOne desc = + nameSection + $+$ usageSection + $+$ descriptionSection + $+$ commandSection + $+$ partsSection + $+$ PP.text "" + where + CommandDesc mParent syn help parts _out children _hidden = desc + nameSection = case mParent of + Nothing -> PP.empty + Just{} -> + PP.text "NAME" + $+$ PP.text "" + $+$ PP.nest + 2 + (case syn of + Nothing -> pparents mParent + Just s -> pparents mParent <+> PP.text "-" <+> s + ) + $+$ PP.text "" + pparents :: Maybe (Maybe String, CommandDesc) -> PP.Doc + pparents Nothing = PP.empty + pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n + pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) + usageSection = + PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsageShortSub desc) + descriptionSection = case help of + Nothing -> PP.empty + Just h -> + PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h + visibleChildren = + [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ] + childDescs = visibleChildren <&> \(n, c) -> + PP.text n $$ PP.nest 20 (Maybe.fromMaybe PP.empty (_cmd_synopsis c)) + commandSection = if null visibleChildren + then PP.empty + else PP.text "" $+$ PP.text "COMMANDS" $+$ PP.text "" $+$ PP.nest + 2 + (PP.vcat $ Data.Foldable.toList childDescs) + partsSection = if null partsTuples + then PP.empty + else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest + 2 + (PP.vcat partsTuples) + partsTuples :: [PP.Doc] + partsTuples = parts >>= go + where + go = \case + PartLiteral{} -> [] + PartVariable{} -> [] + PartOptional p -> go p + PartAlts ps -> ps >>= go + PartSeq ps -> ps >>= go + PartDefault _ p -> go p + PartSuggestion _ p -> go p + PartRedirect s p -> + [PP.text s $$ PP.nest 20 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)] + ++ (PP.nest 2 <$> go p) + PartReorder ps -> ps >>= go + PartMany p -> go p + PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p + PartHidden{} -> [] + +-- | Internal helper; users probably won't need this. +ppPartDescUsage :: PartDesc -> Maybe PP.Doc +ppPartDescUsage = \case + PartLiteral s -> Just $ PP.text s + PartVariable s -> Just $ PP.text s + PartOptional p -> PP.brackets <$> rec p + PartAlts ps -> + [ PP.fcat $ PP.punctuate (PP.text ",") ds + | let ds = Maybe.mapMaybe rec ps + , not (null ds) + ] + PartSeq ps -> [ PP.fsep ds | let ds = Maybe.mapMaybe rec ps, not (null ds) ] + PartDefault _ p -> PP.brackets <$> rec p + PartSuggestion sgs p -> rec p <&> \d -> + case [ PP.text s | CompletionString s <- sgs ] of + [] -> d + sgsDocs -> + PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ sgsDocs ++ [d] + PartRedirect s _ -> Just $ PP.text s + PartMany p -> rec p <&> (PP.<> PP.text "+") + PartWithHelp _ p -> rec p + PartReorder ps -> + let flags = [ d | PartMany d <- ps ] + params = filter + (\case + PartMany{} -> False + _ -> True + ) + ps + in Just $ PP.sep + [ (PP.fsep $ PP.brackets <$> Maybe.mapMaybe rec flags) + , PP.fsep (Maybe.mapMaybe rec params) + ] + PartHidden{} -> Nothing + where rec = ppPartDescUsage + +-- | Internal helper; users probably won't need this. +ppPartDescHeader :: PartDesc -> PP.Doc +ppPartDescHeader = \case + PartLiteral s -> PP.text s + PartVariable s -> PP.text s + PartOptional ds' -> rec ds' + PartAlts alts -> PP.hcat $ List.intersperse (PP.text ",") $ rec <$> alts + PartDefault _ d -> rec d + PartSuggestion _ d -> rec d + PartRedirect s _ -> PP.text s + PartMany ds -> rec ds + PartWithHelp _ d -> rec d + PartSeq ds -> PP.hsep $ rec <$> ds + PartReorder ds -> PP.vcat $ rec <$> ds + PartHidden d -> rec d + where rec = ppPartDescHeader + +-- | Simple conversion from 'ParsingError' to 'String'. +parsingErrorString :: ParsingError -> String +parsingErrorString pe = "error parsing arguments: " ++ messStr ++ remainingStr + where + mess = _pe_messages pe + remaining = _pe_remaining pe + 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.hs b/src/UI/Butcher/Monadic.hs index 2d1a756..a4ddb98 100644 --- a/src/UI/Butcher/Monadic.hs +++ b/src/UI/Butcher/Monadic.hs @@ -4,24 +4,22 @@ module UI.Butcher.Monadic Input (..) , CmdParser , ParsingError (..) - , CommandDesc(_cmd_out) - , cmd_out + , PartialParseInfo (..) + , CommandDesc , -- * Run or Check CmdParsers - runCmdParserSimple + runCmdParserSimpleString , runCmdParser - , runCmdParserExt , runCmdParserA - , runCmdParserAExt + , runCmdParserFromDesc + , runCmdParserAFromDesc , runCmdParserWithHelpDesc - , checkCmdParser + , toCmdDesc , -- * Building CmdParsers module UI.Butcher.Monadic.Command -- * PrettyPrinting CommandDescs (usage/help) , module UI.Butcher.Monadic.Pretty -- * Wrapper around System.Environment.getArgs , module UI.Butcher.Monadic.IO - -- * Utilities for interactive feedback of commandlines (completions etc.) - , module UI.Butcher.Monadic.Interactive -- , cmds -- , sample -- , test @@ -45,14 +43,14 @@ where #include "prelude.inc" -import UI.Butcher.Monadic.Types -import UI.Butcher.Monadic.Internal.Types -import UI.Butcher.Monadic.Command -import UI.Butcher.Monadic.BuiltinCommands -import UI.Butcher.Monadic.Internal.Core -import UI.Butcher.Monadic.Pretty -import UI.Butcher.Monadic.IO -import UI.Butcher.Monadic.Interactive +import UI.Butcher.Internal.Monadic +import UI.Butcher.Internal.MonadicTypes +import UI.Butcher.Internal.Interactive +import UI.Butcher.Monadic.BuiltinCommands +import UI.Butcher.Monadic.Command +import UI.Butcher.Monadic.IO +import UI.Butcher.Monadic.Pretty +import UI.Butcher.Monadic.Types import qualified Text.PrettyPrint as PP @@ -68,7 +66,7 @@ import qualified Text.PrettyPrint as PP -- 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 +-- 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 @@ -76,27 +74,78 @@ import qualified Text.PrettyPrint as PP 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)) + -> (CommandDesc -> CmdParser Identity out ()) -- ^ parser to use + -> (CommandDesc, Input, Either ParsingError (Maybe out)) runCmdParserWithHelpDesc mProgName input cmdF = let (checkResult, fullDesc) -- knot-tying at its finest.. - = ( checkCmdParser mProgName (cmdF fullDesc) + = ( toCmdDesc mProgName (cmdF fullDesc) , either (const emptyCommandDesc) id $ checkResult ) - in runCmdParser mProgName input (cmdF fullDesc) + in runCmdParserCoreFromDesc fullDesc input (cmdF fullDesc) -- | Wrapper around 'runCmdParser' for very simple usage: Accept a @String@ -- input and return only the output from the parser, or a plain error string -- on failure. -runCmdParserSimple :: String -> CmdParser Identity out () -> Either String out -runCmdParserSimple s p = case snd $ runCmdParser Nothing (InputString s) p of - Left e -> Left $ parsingErrorString e - Right desc -> - maybe (Left "command has no implementation") Right $ _cmd_out desc +runCmdParserSimpleString :: String -> CmdParser Identity out () -> Either String out +runCmdParserSimpleString s p = case toCmdDesc Nothing p of + Left err -> Left err + Right fullDesc -> + case runCmdParserCoreFromDesc fullDesc (InputString s) p of + (_, _, Left e) -> Left $ parsingErrorString e + (_, _, Right outM) -> + maybe (Left "command has no implementation") Right $ outM +runCmdParser + :: forall out + . Maybe String -- ^ top-level command name + -> Input + -> CmdParser Identity out () + -> PartialParseInfo out +runCmdParser mTopLevel input parser = + let topDesc = case toCmdDesc mTopLevel parser of + Left err -> error err + Right d -> d + in runCmdParserFromDesc topDesc input parser + +runCmdParserFromDesc + :: forall out + . CommandDesc + -> Input + -> CmdParser Identity out () + -> PartialParseInfo out +runCmdParserFromDesc topDesc input parser = + let (localDesc, remainingInput, result) = + runCmdParserCoreFromDesc topDesc input parser + in combinedCompletion input topDesc localDesc remainingInput result + +runCmdParserA + :: forall f out + . Applicative f + => Maybe String -- ^ top-level command name + -> Input + -> CmdParser f out () + -> f (PartialParseInfo out) +runCmdParserA mTopLevel input parser = + let topDesc = case toCmdDesc mTopLevel parser of + Left err -> error err + Right d -> d + in runCmdParserAFromDesc topDesc input parser + +runCmdParserAFromDesc + :: forall f out + . Applicative f + => CommandDesc + -> Input + -> CmdParser f out () + -> f (PartialParseInfo out) +runCmdParserAFromDesc topDesc input parser = + let mapper (localDesc, remainingInput, result) = + combinedCompletion input topDesc localDesc remainingInput result + in mapper <$> runCmdParserCoreFromDescA topDesc input parser + -------------------------------------- -- all below is for testing purposes -------------------------------------- @@ -155,22 +204,23 @@ data Sample = 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 +_test2 = case toCmdDesc (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 +_test3 s = do + case _ppi_value info of + Left err -> do + print err + print $ ppHelpShallow (_ppi_localDesc info) + _cmd_mParent (_ppi_localDesc info) `forM_` \(_, d) -> do + print $ ppUsage d + Right Nothing -> do + putStrLn "command is missing implementation!" + print $ ppHelpShallow (_ppi_localDesc info) + Right (Just f) -> f + where + info = runCmdParser Nothing (InputString s) _cmds diff --git a/src/UI/Butcher/Monadic/BuiltinCommands.hs b/src/UI/Butcher/Monadic/BuiltinCommands.hs index bc4ae92..e26c1c4 100644 --- a/src/UI/Butcher/Monadic/BuiltinCommands.hs +++ b/src/UI/Butcher/Monadic/BuiltinCommands.hs @@ -21,11 +21,11 @@ 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.Internal.MonadicTypes +import UI.Butcher.Internal.Monadic +import UI.Butcher.Internal.Interactive import UI.Butcher.Monadic.Pretty import UI.Butcher.Monadic.Param -import UI.Butcher.Monadic.Interactive import System.IO @@ -37,7 +37,7 @@ import System.IO -- -- > addHelpCommand = addHelpCommandWith -- > (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpShallow) -addHelpCommand :: Applicative f => CommandDesc a -> CmdParser f (IO ()) () +addHelpCommand :: Applicative f => CommandDesc -> CmdParser f (IO ()) () addHelpCommand = addHelpCommandWith (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpShallow) @@ -51,7 +51,7 @@ addHelpCommand = addHelpCommandWith -- -- > addHelpCommand2 = addHelpCommandWith -- > (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpDepthOne) -addHelpCommand2 :: Applicative f => CommandDesc a -> CmdParser f (IO ()) () +addHelpCommand2 :: Applicative f => CommandDesc -> CmdParser f (IO ()) () addHelpCommand2 = addHelpCommandWith (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpDepthOne) @@ -59,8 +59,8 @@ addHelpCommand2 = addHelpCommandWith -- the relevant subcommand's 'CommandDesc' into a String. addHelpCommandWith :: Applicative f - => (CommandDesc a -> IO String) - -> CommandDesc a + => (CommandDesc -> IO String) + -> CommandDesc -> CmdParser f (IO ()) () addHelpCommandWith f desc = addCmd "help" $ do addCmdSynopsis "print help about this command" @@ -68,7 +68,7 @@ addHelpCommandWith f desc = addCmd "help" $ do addCmdImpl $ do let restWords = List.words rest let - descent :: [String] -> CommandDesc a -> CommandDesc a + descent :: [String] -> CommandDesc -> CommandDesc descent [] curDesc = curDesc descent (w:wr) curDesc = case @@ -110,6 +110,7 @@ addButcherDebugCommand = addCmd "butcherdebug" $ do addShellCompletionCommand :: CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) () addShellCompletionCommand mainCmdParser = do + desc <- peekCmdDesc addCmdHidden "completion" $ do addCmdSynopsis "utilites to enable bash-completion" addCmd "bash-script" $ do @@ -122,16 +123,18 @@ addShellCompletionCommand mainCmdParser = do "generate possible completions for given input arguments" rest <- addParamRestOfInputRaw "REALCOMMAND" mempty addCmdImpl $ do - let (cdesc, remaining, _result) = - runCmdParserExt Nothing rest mainCmdParser + let (cdesc, remaining, result) = + runCmdParserCoreFromDesc desc rest mainCmdParser let - compls = shellCompletionWords (inputString rest) + info = combinedCompletion rest + desc cdesc - (inputString remaining) + remaining + result let lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ inputString rest - putStrLn $ List.unlines $ compls <&> \case + putStrLn $ List.unlines $ _ppi_choices info <&> \case CompletionString s -> s CompletionFile -> "$(compgen -f -- " ++ lastWord ++ ")" CompletionDirectory -> "$(compgen -d -- " ++ lastWord ++ ")" @@ -145,7 +148,7 @@ addShellCompletionCommand mainCmdParser = do -- -- > $ source <(foo completion bash-script foo) addShellCompletionCommand' - :: (CommandDesc out -> CmdParser Identity (IO ()) ()) + :: (CommandDesc -> CmdParser Identity (IO ()) ()) -> CmdParser Identity (IO ()) () addShellCompletionCommand' f = addShellCompletionCommand (f emptyCommandDesc) diff --git a/src/UI/Butcher/Monadic/Command.hs b/src/UI/Butcher/Monadic/Command.hs index 2214673..6521f21 100644 --- a/src/UI/Butcher/Monadic/Command.hs +++ b/src/UI/Butcher/Monadic/Command.hs @@ -62,6 +62,7 @@ module UI.Butcher.Monadic.Command , reorderStart , reorderStop , withReorder + , traverseBarbie , peekCmdDesc , peekInput -- * Building CmdParsers - myprog -v --input PATH @@ -83,10 +84,8 @@ where #include "prelude.inc" - - -import UI.Butcher.Monadic.Internal.Types -import UI.Butcher.Monadic.Internal.Core +import UI.Butcher.Internal.MonadicTypes +import UI.Butcher.Internal.Monadic import UI.Butcher.Monadic.Flag import UI.Butcher.Monadic.Param diff --git a/src/UI/Butcher/Monadic/Flag.hs b/src/UI/Butcher/Monadic/Flag.hs index 1c3a507..dd0d58f 100644 --- a/src/UI/Butcher/Monadic/Flag.hs +++ b/src/UI/Butcher/Monadic/Flag.hs @@ -32,17 +32,19 @@ 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 Control.Monad.Trans.MultiRWS.Strict + as MultiRWSS +import qualified Control.Monad.Trans.MultiState.Strict + as MultiStateS -import qualified Text.PrettyPrint as PP +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.Internal.Monadic +import UI.Butcher.Internal.MonadicTypes -import Data.List.Extra ( firstJust ) +import Data.List.Extra ( firstJust ) @@ -57,7 +59,7 @@ pExpect :: String -> InpParseString () pExpect s = InpParseString $ do inp <- StateS.get case List.stripPrefix s inp of - Nothing -> mzero + Nothing -> mzero Just rest -> StateS.put rest pExpectEof :: InpParseString () @@ -92,7 +94,7 @@ instance Semigroup (Flag p) where (<>) = appendFlag instance Monoid (Flag p) where - mempty = Flag Nothing Nothing Visible + mempty = Flag Nothing Nothing Visible mappend = (<>) -- | Create a 'Flag' with just a help text. @@ -137,15 +139,11 @@ addSimpleFlagA -> Flag Void -- ^ properties -> f () -- ^ action to execute whenever this matches -> CmdParser f out () -addSimpleFlagA shorts longs flag act - = void $ addSimpleBoolFlagAll shorts longs flag act +addSimpleFlagA shorts longs flag act = + void $ addSimpleBoolFlagAll shorts longs flag act addSimpleBoolFlagAll - :: String - -> [String] - -> Flag Void - -> f () - -> CmdParser f out Bool + :: String -> [String] -> Flag Void -> f () -> CmdParser f out Bool addSimpleBoolFlagAll shorts longs flag a = fmap (not . null) $ addCmdPartManyA ManyUpperBound1 (wrapHidden flag desc) parseF (\() -> a) where @@ -156,11 +154,12 @@ addSimpleBoolFlagAll shorts longs flag a = fmap (not . null) $ PartAlts $ PartLiteral <$> allStrs - parseF :: String -> Maybe ((), String) + parseF :: PartParser () String parseF (dropWhile Char.isSpace -> str) = - (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs) - <|> ( firstJust - ( \s -> + resultFromMaybe + $ (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs) + <|> (firstJust + (\s -> [ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ] ) allStrs @@ -168,11 +167,12 @@ addSimpleBoolFlagAll shorts longs flag a = fmap (not . null) -- | 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 + :: Applicative f + => String -- ^ short flag chars, i.e. "v" for -v + -> [String] -- ^ list of long names, i.e. ["verbose"] + -> Flag Void -- ^ properties + -> CmdParser f out Int addSimpleCountFlag shorts longs flag = fmap length $ addCmdPartMany ManyUpperBoundN (wrapHidden flag desc) parseF where @@ -185,16 +185,22 @@ addSimpleCountFlag shorts longs flag = fmap length $ PartAlts $ PartLiteral <$> allStrs - parseF :: String -> Maybe ((), String) + parseF :: PartParser () String parseF (dropWhile Char.isSpace -> str) = - (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs) - <|> ( firstJust - ( \s -> + resultFromMaybe + $ (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs) + <|> (firstJust + (\s -> [ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ] ) allStrs ) + +-- can have one of +-- 1) no default 2) default is nothing + just value 3) default value +-- inner default only makes sense if there is an outer default + -- | One-argument flag, where the argument is parsed via its Read instance. addFlagReadParam :: forall f p out @@ -204,8 +210,10 @@ addFlagReadParam -> String -- ^ param name -> Flag p -- ^ properties -> CmdParser f out p -addFlagReadParam shorts longs name flag = - addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ()) +addFlagReadParam shorts longs name flag = addCmdPartInpA + (wrapHidden flag desc) + parseF + (\_ -> pure ()) where allStrs = [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ] @@ -216,11 +224,13 @@ addFlagReadParam shorts longs name flag = desc1 :: PartDesc desc1 = PartAlts $ PartLiteral . either id id <$> allStrs desc2 = PartVariable name - parseF :: Input -> Maybe (p, Input) + parseF :: PartParser p Input parseF inp = case inp of - InputString str -> - maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString) - $ parseResult + InputString str -> case parseResult of + Nothing -> resultFromMaybe $ _flag_default flag <&> \x -> (x, inp) + Just (descOrVal, r) -> case descOrVal of + Left e -> Failure (Just e) + Right val -> Success val (InputString r) where parseResult = runInpParseString (dropWhile Char.isSpace str) $ do Data.Foldable.msum $ allStrs <&> \case @@ -229,23 +239,27 @@ addFlagReadParam shorts longs name flag = 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 + ((x, ' ' : r) : _) -> + StateS.put (dropWhile Char.isSpace r) $> Right x + ((x, "") : _) -> StateS.put "" $> Right x + _ -> pure $ Left desc2 + InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of Just ((), "") -> case argR of - [] -> Nothing - (arg2:rest) -> Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest) - Just ((), remainingStr) -> - Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR) - Nothing -> _flag_default flag <&> \d -> (d, inp) + [] -> Failure Nothing + (arg2 : rest) -> case Text.Read.readMaybe arg2 of + Just x -> Success x (InputArgs rest) + Nothing -> Failure (Just desc2) + Just ((), remainingStr) -> case Text.Read.readMaybe remainingStr of + Just x -> Success x (InputArgs argR) + Nothing -> Failure (Just desc2) + Nothing -> resultFromMaybe $ _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) + InputArgs _ -> resultFromMaybe $ _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 @@ -260,8 +274,8 @@ addFlagReadParams -> String -- ^ param name -> Flag p -- ^ properties -> CmdParser f out [p] -addFlagReadParams shorts longs name flag - = addFlagReadParamsAll shorts longs name flag (\_ -> pure ()) +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. @@ -279,12 +293,14 @@ addFlagReadParams shorts longs name flag -- = 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] + :: forall f p out + . (Typeable p, Text.Read.Read p, Show p) + => String -- ^ short flag chars, i.e. "v" for -v + -> [String] -- ^ list of long names, i.e. ["verbose"] + -> String -- ^ param name + -> Flag p -- ^ properties + -> (p -> f ()) -- ^ action to execute when ths param matches + -> CmdParser f out [p] addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA ManyUpperBoundN (wrapHidden flag desc) @@ -298,10 +314,13 @@ addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA desc1 = PartAlts $ PartLiteral . either id id <$> allStrs desc2 = (maybe id (PartDefault . show) $ _flag_default flag) $ PartVariable name - parseF :: Input -> Maybe (p, Input) + parseF :: PartParser p Input parseF inp = case inp of - InputString str -> - fmap (second InputString) $ parseResult + InputString str -> case parseResult of + Just (descOrVal, r) -> case descOrVal of + Right val -> Success val (InputString r) + Left err -> Failure (Just err) + Nothing -> Failure Nothing where parseResult = runInpParseString (dropWhile Char.isSpace str) $ do Data.Foldable.msum $ allStrs <&> \case @@ -310,46 +329,65 @@ addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA 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 + ((x, ' ' : r) : _) -> + StateS.put (dropWhile Char.isSpace r) $> Right x + ((x, "") : _) -> StateS.put "" $> Right x + _ -> pure $ case _flag_default flag of + Nothing -> Left desc2 + Just val -> Right val + InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of Just ((), "") -> case argR of - [] -> mdef - (arg2:rest) -> (Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest)) <|> mdef - where mdef = _flag_default flag <&> \p -> (p, InputArgs argR) - Just ((), remainingStr) -> - Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR) - Nothing -> Nothing + [] -> mdef + (arg2 : rest) -> case Text.Read.readMaybe arg2 of + Just x -> Success x (InputArgs rest) + Nothing -> mdef + where + mdef = case _flag_default flag of + Nothing -> Failure (Just desc2) + Just val -> Success val (InputArgs argR) + Just ((), remainingStr) -> case Text.Read.readMaybe remainingStr of + Just x -> Success x (InputArgs argR) + Nothing -> Failure (Just desc2) -- this is a bit questionable, + -- could also make it Nothing. + Nothing -> Failure 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 + InputArgs _ -> Failure Nothing -- | One-argument flag where the argument can be an arbitrary string. addFlagStringParam - :: forall f out . (Applicative f) => String -- ^ short flag chars, i.e. "v" for -v - -> [String] -- ^ list of long names, i.e. ["verbose"] - -> String -- ^ param name - -> Flag String -- ^ properties - -> CmdParser f out String -addFlagStringParam shorts longs name flag = - addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ()) + :: forall f out + . (Applicative f) + => String -- ^ short flag chars, i.e. "v" for -v + -> [String] -- ^ list of long names, i.e. ["verbose"] + -> String -- ^ param name + -> Flag String -- ^ properties + -> CmdParser f out String +addFlagStringParam shorts longs name flag = addCmdPartInpA + (wrapHidden flag desc) + parseF + (\_ -> pure ()) where allStrs = [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ] - desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2] + 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 (String, Input) + parseF :: PartParser String Input parseF inp = case inp of - InputString str -> - maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString) - $ parseResult + InputString str -> case parseResult of + Nothing -> resultFromMaybe $ _flag_default flag <&> \x -> (x, inp) + Just (descOrVal, r) -> case descOrVal of + Left e -> Failure (Just e) + Right val -> Success val (InputString r) where parseResult = runInpParseString (dropWhile Char.isSpace str) $ do Data.Foldable.msum $ allStrs <&> \case @@ -359,20 +397,22 @@ addFlagStringParam shorts longs name flag = 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 + pure $ Right 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) + [] -> Failure Nothing + (x : rest) -> Success x (InputArgs rest) + Just ((), remainingStr) -> case Text.Read.readMaybe remainingStr of + Just x -> Success x (InputArgs argR) + Nothing -> Failure (Just desc2) + Nothing -> resultFromMaybe $ _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) + InputArgs _ -> resultFromMaybe $ _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 @@ -387,8 +427,8 @@ addFlagStringParams -> String -- ^ param name -> Flag Void -- ^ properties -> CmdParser f out [String] -addFlagStringParams shorts longs name flag - = addFlagStringParamsAll shorts longs name flag (\_ -> pure ()) +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. @@ -405,13 +445,14 @@ addFlagStringParams shorts longs name flag -- = 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 + :: 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] + -> (String -> f ()) + -> CmdParser f out [String] addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA ManyUpperBoundN (wrapHidden flag desc) @@ -425,9 +466,10 @@ addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA desc1 = PartAlts $ PartLiteral . either id id <$> allStrs desc2 = (maybe id (PartDefault . show) $ _flag_default flag) $ PartVariable name - parseF :: Input -> Maybe (String, Input) + parseF :: PartParser String Input parseF inp = case inp of - InputString str -> fmap (second InputString) $ parseResult + InputString str -> + resultFromMaybe $ fmap (second InputString) $ parseResult where parseResult = runInpParseString (dropWhile Char.isSpace str) $ do Data.Foldable.msum $ allStrs <&> \case @@ -438,16 +480,16 @@ addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA 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 + InputArgs (arg1 : argR) -> case runInpParseString arg1 parser of + Just ((), "") -> case argR of + [] -> Failure Nothing + (x : rest) -> Success x (InputArgs rest) + Just ((), remainingStr) -> Success remainingStr (InputArgs argR) + Nothing -> Failure 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 + InputArgs _ -> Failure Nothing diff --git a/src/UI/Butcher/Monadic/IO.hs b/src/UI/Butcher/Monadic/IO.hs index a35c8d5..0fe123e 100644 --- a/src/UI/Butcher/Monadic/IO.hs +++ b/src/UI/Butcher/Monadic/IO.hs @@ -9,17 +9,19 @@ 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 Control.Monad.Trans.MultiRWS.Strict + as MultiRWSS +import qualified Control.Monad.Trans.MultiState.Strict + as MultiStateS -import qualified Text.PrettyPrint as PP +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.Internal.Monadic +import UI.Butcher.Internal.MonadicTypes import UI.Butcher.Monadic.Param +import UI.Butcher.Monadic.Pretty import System.IO @@ -37,74 +39,77 @@ import System.IO mainFromCmdParser :: CmdParser Identity (IO ()) () -> IO () mainFromCmdParser cmd = do progName <- System.Environment.getProgName - case checkCmdParser (Just progName) cmd of - Left e -> do + case toCmdDesc (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 + Right fullDesc -> do args <- System.Environment.getArgs - case runCmdParser (Just progName) (InputArgs args) cmd of - (desc, Left (ParsingError mess remaining)) -> do + case runCmdParserCoreFromDesc fullDesc (InputArgs args) cmd of + (desc, _, Left err) -> do putStrErrLn $ progName ++ ": error parsing arguments: " - ++ case mess of - [] -> "" - (m:_) -> m - putStrErrLn $ case remaining of + ++ case _pe_messages err of + [] -> "" + (m : _) -> m + putStrErrLn $ case _pe_remaining err 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 + 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 + (desc, _, Right out) -> case out of Nothing -> do putStrErrLn $ "usage:" printErr $ ppUsage desc - Just a -> a + 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 () + :: (CommandDesc -> CmdParser Identity (IO ()) ()) -> IO () mainFromCmdParserWithHelpDesc cmdF = do progName <- System.Environment.getProgName - let (checkResult, fullDesc) + let (checkResult, optimisticFullDesc) = + ( toCmdDesc (Just progName) (cmdF optimisticFullDesc) + , either (const emptyCommandDesc) id $ checkResult + ) -- 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 + $ progName + ++ ": internal error: failed sanity check for butcher main command parser!" putStrErrLn $ "(" ++ e ++ ")" putStrErrLn $ "aborting." - Right _ -> do + Right fullDesc -> 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." + case runCmdParserCoreFromDesc fullDesc (InputArgs args) (cmdF fullDesc) of + (desc, _, Left err) -> do + putStrErrLn $ progName ++ ": error parsing arguments: " ++ head + (_pe_messages err) + putStrErrLn $ case _pe_remaining err of + InputString "" -> "at the end of input." InputString str -> case show str of s | length s < 42 -> "at: " ++ s ++ "." - s -> "at: " ++ take 40 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 ++ "..\"." + s -> "at: " ++ take 40 s ++ "..\"." putStrErrLn $ "usage:" printErr $ ppUsage desc - (desc, Right out) -> case _cmd_out out of + (desc, _, Right out) -> case out of Nothing -> do putStrErrLn $ "usage:" printErr $ ppUsage desc diff --git a/src/UI/Butcher/Monadic/Interactive.hs b/src/UI/Butcher/Monadic/Interactive.hs deleted file mode 100644 index 77025b5..0000000 --- a/src/UI/Butcher/Monadic/Interactive.hs +++ /dev/null @@ -1,201 +0,0 @@ --- | Utilities when writing interactive programs that interpret commands, --- e.g. a REPL. -module UI.Butcher.Monadic.Interactive - ( simpleCompletion - , shellCompletionWords - , interactiveHelpDoc - , partDescStrings - ) -where - - - -#include "prelude.inc" - -import qualified Text.PrettyPrint as PP - -import UI.Butcher.Monadic.Internal.Types -import UI.Butcher.Monadic.Internal.Core -import UI.Butcher.Monadic.Pretty - - - --- | Derives a potential completion from a given input string and a given --- 'CommandDesc'. Considers potential subcommands and where available the --- completion info present in 'PartDesc's. -simpleCompletion - :: String -- ^ input string - -> CommandDesc () -- ^ CommandDesc obtained on that input string - -> String -- ^ "remaining" input after the last successfully parsed - -- subcommand. See 'UI.Butcher.Monadic.runCmdParserExt'. - -> String -- ^ completion, i.e. a string that might be appended - -- to the current prompt when user presses tab. -simpleCompletion line cdesc pcRest = case reverse line of - [] -> compl - ' ' : _ -> compl - _ | null pcRest -> "" -- necessary to prevent subcommand completion - -- appearing before space that is, if you have command - -- "aaa" with subcommand "sss", we want completion - -- "sss" on "aaa " but not on "aaa". - _ -> compl - where - compl = List.drop (List.length lastWord) (longestCommonPrefix choices) - longestCommonPrefix [] = "" - longestCommonPrefix (c1 : cr) = - case find (\s -> List.all (s `isPrefixOf`) cr) $ reverse $ List.inits c1 of - Nothing -> "" - Just x -> x - nameDesc = case _cmd_mParent cdesc of - Nothing -> cdesc - Just (_, parent) | null pcRest && not (null lastWord) -> parent - -- not finished writing a command. if we have commands abc and abcdef, - -- we may want "def" as a completion after "abc". - Just{} -> cdesc - lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ line - choices :: [String] - choices = join - [ [ r - | (Just r, _) <- Data.Foldable.toList (_cmd_children nameDesc) - , lastWord `isPrefixOf` r - , lastWord /= r - ] - , [ s - | s <- partDescStrings =<< _cmd_parts nameDesc - , lastWord `isPrefixOf` s - , lastWord /= s - ] - ] - - --- | Derives a list of completion items from a given input string and a given --- 'CommandDesc'. Considers potential subcommands and where available the --- completion info present in 'PartDesc's. --- --- See 'addShellCompletion' which uses this. -shellCompletionWords - :: String -- ^ input string - -> CommandDesc () -- ^ CommandDesc obtained on that input string - -> String -- ^ "remaining" input after the last successfully parsed - -- subcommand. See 'UI.Butcher.Monadic.runCmdParserExt'. - -> [CompletionItem] -shellCompletionWords line cdesc pcRest = choices - where - nameDesc = case _cmd_mParent cdesc of - Nothing -> cdesc - Just (_, parent) | null pcRest && not (null lastWord) -> parent - -- not finished writing a command. if we have commands abc and abcdef, - -- we may want "def" as a completion after "abc". - Just{} -> cdesc - lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ line - choices :: [CompletionItem] - choices = join - [ [ CompletionString r - | (Just r, _) <- Data.Foldable.toList (_cmd_children nameDesc) - , lastWord `isPrefixOf` r - , lastWord /= r - ] - , [ c - | c <- partDescCompletions =<< _cmd_parts cdesc - , case c of - CompletionString s -> lastWord `isPrefixOf` s && lastWord /= s - _ -> True - ] - ] - - --- | Produces a 'PP.Doc' as a hint for the user during interactive command --- input. Takes the current (incomplete) prompt line into account. For example --- when you have commands (among others) \'config set-email\' and --- \'config get-email\', then on empty prompt there will be an item \'config\'; --- on the partial prompt \'config \' the help doc will contain the --- \'set-email\' and \'get-email\' items. -interactiveHelpDoc - :: String -- ^ input string - -> CommandDesc () -- ^ CommandDesc obtained on that input string - -> String -- ^ "remaining" input after the last successfully parsed - -- subcommand. See 'UI.Butcher.Monadic.runCmdParserExt'. - -> Int -- ^ max length of help text - -> PP.Doc -interactiveHelpDoc cmdline desc pcRest maxLines = if - | null cmdline -> helpStrShort - | List.last cmdline == ' ' -> helpStrShort - | otherwise -> helpStr - where - helpStr = if List.length optionLines > maxLines - then - PP.fcat $ List.intersperse (PP.text "|") $ PP.text . fst <$> optionLines - else PP.vcat $ optionLines <&> \case - (s, "") -> PP.text s - (s, h ) -> PP.text s PP.<> PP.text h - where - nameDesc = case _cmd_mParent desc of - Nothing -> desc - Just (_, parent) | null pcRest -> parent - Just{} -> desc - - lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ cmdline - optionLines :: [(String, String)] - optionLines = -- a list of potential words that make sense, given - -- the current input. - join - [ [ (s, e) - | (Just s, c) <- Data.Foldable.toList (_cmd_children nameDesc) - , lastWord `isPrefixOf` s - , let e = join $ join - [ [ " ARGS" | not $ null $ _cmd_parts c ] - , [ " CMDS" | not $ null $ _cmd_children c ] - , [ ": " ++ show h | Just h <- [_cmd_help c] ] - ] - ] - , [ (s, "") - | s <- partDescStrings =<< _cmd_parts nameDesc - , lastWord `isPrefixOf` s - ] - ] - helpStrShort = ppUsageWithHelp desc - - --- | Obtains a list of "expected"/potential strings for a command part --- described in the 'PartDesc'. In constrast to the 'simpleCompletion' --- function this function does not take into account any current input, and --- consequently the output elements can in general not be appended to partial --- input to form valid input. -partDescStrings :: PartDesc -> [String] -partDescStrings = \case - PartLiteral s -> [s] - PartVariable _ -> [] - -- TODO: we could handle seq of optional and such much better - PartOptional x -> partDescStrings x - PartAlts alts -> alts >>= partDescStrings - PartSeq [] -> [] - PartSeq (x:_) -> partDescStrings x - PartDefault _ x -> partDescStrings x - PartSuggestion ss x -> [ s | CompletionString s <- ss ] ++ partDescStrings x - PartRedirect _ x -> partDescStrings x - PartReorder xs -> xs >>= partDescStrings - PartMany x -> partDescStrings x - PartWithHelp _h x -> partDescStrings x -- TODO: handle help - PartHidden{} -> [] - - --- | Obtains a list of "expected"/potential strings for a command part --- described in the 'PartDesc'. In constrast to the 'simpleCompletion' --- function this function does not take into account any current input, and --- consequently the output elements can in general not be appended to partial --- input to form valid input. -partDescCompletions :: PartDesc -> [CompletionItem] -partDescCompletions = \case - PartLiteral s -> [CompletionString s] - PartVariable _ -> [] - -- TODO: we could handle seq of optional and such much better - PartOptional x -> partDescCompletions x - PartAlts alts -> alts >>= partDescCompletions - PartSeq [] -> [] - PartSeq (x:_) -> partDescCompletions x - PartDefault _ x -> partDescCompletions x - PartSuggestion ss x -> ss ++ partDescCompletions x - PartRedirect _ x -> partDescCompletions x - PartReorder xs -> xs >>= partDescCompletions - PartMany x -> partDescCompletions x - PartWithHelp _h x -> partDescCompletions x -- TODO: handle help - PartHidden{} -> [] diff --git a/src/UI/Butcher/Monadic/Param.hs b/src/UI/Butcher/Monadic/Param.hs index 3274ce5..c3b920c 100644 --- a/src/UI/Butcher/Monadic/Param.hs +++ b/src/UI/Butcher/Monadic/Param.hs @@ -35,23 +35,25 @@ 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 Control.Monad.Trans.MultiRWS.Strict + as MultiRWSS +import qualified Control.Monad.Trans.MultiState.Strict + as MultiStateS -import qualified Text.PrettyPrint as PP +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.Internal.Monadic +import UI.Butcher.Internal.MonadicTypes -- | 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_default :: Maybe p + , _param_help :: Maybe PP.Doc , _param_suggestions :: Maybe [CompletionItem] } @@ -67,7 +69,7 @@ instance Semigroup (Param p) where (<>) = appendParam instance Monoid (Param p) where - mempty = Param Nothing Nothing Nothing + mempty = Param Nothing Nothing Nothing mappend = (<>) -- | Create a 'Param' with just a help text. @@ -99,116 +101,129 @@ paramDirectory = mempty { _param_suggestions = Just [CompletionDirectory] } -- instance. Take care not to use this to return Strings unless you really -- want that, because it will require the quotation marks and escaping as -- is normal for the Show/Read instances for String. -addParamRead :: forall f out a - . (Applicative f, Typeable a, Show a, Text.Read.Read a) - => String -- ^ paramater name, for use in usage/help texts - -> Param a -- ^ properties - -> CmdParser f out a +addParamRead + :: forall f out a + . (Applicative f, Typeable a, Show a, Text.Read.Read a) + => String -- ^ paramater name, for use in usage/help texts + -> Param a -- ^ properties + -> CmdParser f out a addParamRead = addReadParam {-# DEPRECATED addReadParam "use 'addParamRead'" #-} -addReadParam :: forall f out a - . (Applicative f, Typeable a, Show a, Text.Read.Read a) - => String -- ^ paramater name, for use in usage/help texts - -> Param a -- ^ properties - -> CmdParser f out a +addReadParam + :: forall f out a + . (Applicative f, Typeable a, Show a, Text.Read.Read a) + => String -- ^ paramater name, for use in usage/help texts + -> Param a -- ^ properties + -> CmdParser f out a addReadParam name par = addCmdPart desc parseF - where - desc :: PartDesc - desc = addSuggestion (_param_suggestions par) - $ (maybe id PartWithHelp $ _param_help par) - $ (maybe id (PartDefault . show) $ _param_default par) - $ PartVariable name - parseF :: String -> Maybe (a, String) - parseF s = case Text.Read.reads s of - ((x, ' ':r):_) -> Just (x, dropWhile Char.isSpace r) - ((x, []):_) -> Just (x, []) - _ -> _param_default par <&> \x -> (x, s) + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ (maybe id (PartDefault . show) $ _param_default par) + $ PartVariable name + parseF :: PartParser a String + parseF s = resultFromMaybe $ case Text.Read.reads s of + ((x, ' ' : r) : _) -> Just (x, dropWhile Char.isSpace r) + ((x, [] ) : _) -> Just (x, []) + _ -> _param_default par <&> \x -> (x, s) -- | Like addReadParam, but optional. I.e. if reading fails, returns Nothing. -addParamReadOpt :: forall f out a - . (Applicative f, Typeable a, Text.Read.Read a) - => String -- ^ paramater name, for use in usage/help texts - -> Param a -- ^ properties - -> CmdParser f out (Maybe a) +addParamReadOpt + :: forall f out a + . (Applicative f, Typeable a, Text.Read.Read a) + => String -- ^ paramater name, for use in usage/help texts + -> Param a -- ^ properties + -> CmdParser f out (Maybe a) addParamReadOpt = addReadParamOpt {-# DEPRECATED addReadParamOpt "use 'addParamReadOpt'" #-} -addReadParamOpt :: forall f out a - . (Applicative f, Typeable a, Text.Read.Read a) - => String -- ^ paramater name, for use in usage/help texts - -> Param a -- ^ properties - -> CmdParser f out (Maybe a) +addReadParamOpt + :: forall f out a + . (Applicative f, Typeable a, Text.Read.Read a) + => String -- ^ paramater name, for use in usage/help texts + -> Param a -- ^ properties + -> CmdParser f out (Maybe a) addReadParamOpt name par = addCmdPart desc parseF - where - desc :: PartDesc - desc = addSuggestion (_param_suggestions par) - $ PartOptional - $ (maybe id PartWithHelp $ _param_help par) - $ PartVariable name - parseF :: String -> Maybe (Maybe a, String) - parseF s = case Text.Read.reads s of - ((x, ' ':r):_) -> Just (Just x, dropWhile Char.isSpace r) - ((x, []):_) -> Just (Just x, []) - _ -> Just (Nothing, s) -- TODO: we could warn about a default.. + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ PartOptional + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: PartParser (Maybe a) String + parseF s = resultFromMaybe $ case Text.Read.reads s of + ((x, ' ' : r) : _) -> Just (Just x, dropWhile Char.isSpace r) + ((x, [] ) : _) -> Just (Just x, []) + _ -> Just (Nothing, s) -- TODO: we could warn about a default.. -- | Add a parameter that matches any string of non-space characters if -- input==String, or one full argument if input==[String]. See the 'Input' doc -- for this distinction. addParamString - :: forall f out . (Applicative f) + :: forall f out + . (Applicative f) => String -> Param String -> CmdParser f out String addParamString = addStringParam {-# DEPRECATED addStringParam "use 'addParamString'" #-} addStringParam - :: forall f out . (Applicative f) + :: 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) + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: PartParser String Input + parseF (InputString str) = + case break Char.isSpace $ dropWhile Char.isSpace str of + ("", rest) -> + resultFromMaybe $ _param_default par <&> \x -> (x, InputString rest) + (x, rest) -> Success x (InputString rest) + parseF (InputArgs args) = case args of + (s1 : sR) -> Success s1 (InputArgs sR) + [] -> resultFromMaybe $ _param_default par <&> \x -> (x, InputArgs args) -- | Like 'addParamString', but optional, I.e. succeeding with Nothing if -- there is no remaining input. addParamStringOpt - :: forall f out . (Applicative f) + :: forall f out + . (Applicative f) => String -> Param Void -> CmdParser f out (Maybe String) addParamStringOpt = addStringParamOpt {-# DEPRECATED addStringParamOpt "use 'addParamStringOpt'" #-} addStringParamOpt - :: forall f out . (Applicative f) + :: forall f out + . (Applicative f) => String -> Param Void -> CmdParser f out (Maybe String) addStringParamOpt name par = addCmdPartInp desc parseF - where - desc :: PartDesc - desc = addSuggestion (_param_suggestions par) - $ PartOptional - $ (maybe id PartWithHelp $ _param_help par) - $ PartVariable name - parseF :: Input -> Maybe (Maybe String, Input) - parseF (InputString str) - = case break Char.isSpace $ dropWhile Char.isSpace str of - ("", rest) -> Just (Nothing, InputString rest) - (x, rest) -> Just (Just x, InputString rest) - parseF (InputArgs args) = case args of - (s1:sR) -> Just (Just s1, InputArgs sR) - [] -> Just (Nothing, InputArgs []) + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ PartOptional + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: PartParser (Maybe String) Input + parseF (InputString str) = + case break Char.isSpace $ dropWhile Char.isSpace str of + ("", rest) -> Success Nothing (InputString rest) + (x , rest) -> Success (Just x) (InputString rest) + parseF (InputArgs args) = case args of + (s1 : sR) -> Success (Just s1) (InputArgs sR) + [] -> Success Nothing (InputArgs []) -- | Add a parameter that matches any string of non-space characters if @@ -235,20 +250,21 @@ addStringParams name par = addCmdPartManyInp ManyUpperBoundN desc parseF addSuggestion (_param_suggestions par) $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name - parseF :: Input -> Maybe (String, Input) + parseF :: PartParser String Input parseF (InputString str) = case break Char.isSpace $ dropWhile Char.isSpace str of - ("", _ ) -> Nothing - (x , rest) -> Just (x, InputString rest) + ("", _ ) -> Failure Nothing + (x , rest) -> Success x (InputString rest) parseF (InputArgs args) = case args of - (s1:sR) -> Just (s1, InputArgs sR) - [] -> Nothing + (s1 : sR) -> Success s1 (InputArgs sR) + [] -> Failure Nothing -- | Like 'addParamString' but does not match strings starting with a dash. -- This prevents misinterpretation of flags as params. addParamNoFlagString - :: forall f out . (Applicative f) + :: forall f out + . (Applicative f) => String -> Param String -> CmdParser f out String @@ -259,16 +275,16 @@ addParamNoFlagString name par = addCmdPartInp desc parseF addSuggestion (_param_suggestions par) $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name - parseF :: Input -> Maybe (String, Input) + parseF :: PartParser String Input parseF (InputString str) = - case break Char.isSpace $ dropWhile Char.isSpace str of - ("" , rest) -> _param_default par <&> \x -> (x, InputString rest) - ('-':_, _ ) -> _param_default par <&> \x -> (x, InputString str) - (x , rest) -> Just (x, InputString rest) - parseF (InputArgs args) = case args of - [] -> _param_default par <&> \x -> (x, InputArgs args) - (('-':_):_ ) -> _param_default par <&> \x -> (x, InputArgs args) - (s1 :sR) -> Just (s1, InputArgs sR) + resultFromMaybe $ case break Char.isSpace $ dropWhile Char.isSpace str of + ("" , rest) -> _param_default par <&> \x -> (x, InputString rest) + ('-' : _, _ ) -> _param_default par <&> \x -> (x, InputString str) + (x , rest) -> Just (x, InputString rest) + parseF (InputArgs args) = resultFromMaybe $ case args of + [] -> _param_default par <&> \x -> (x, InputArgs args) + (('-' : _) : _ ) -> _param_default par <&> \x -> (x, InputArgs args) + (s1 : sR) -> Just (s1, InputArgs sR) -- | Like 'addParamStringOpt' but does not match strings starting with a dash. -- This prevents misinterpretation of flags as params. @@ -283,16 +299,16 @@ addParamNoFlagStringOpt name par = addCmdPartInp desc parseF desc :: PartDesc desc = PartOptional $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name - parseF :: Input -> Maybe (Maybe String, Input) + parseF :: PartParser (Maybe String) Input parseF (InputString str) = case break Char.isSpace $ dropWhile Char.isSpace str of - ("" , rest) -> Just (Nothing, InputString rest) - ('-':_, _ ) -> Just (Nothing, InputString str) - (x , rest) -> Just (Just x, InputString rest) + ("" , rest) -> Success Nothing (InputString rest) + ('-' : _, _ ) -> Success Nothing (InputString str) + (x , rest) -> Success (Just x) (InputString rest) parseF (InputArgs args) = case args of - [] -> Just (Nothing, InputArgs []) - (('-':_):_ ) -> Just (Nothing, InputArgs args) - (s1 :sR) -> Just (Just s1, InputArgs sR) + [] -> Success Nothing (InputArgs []) + (('-' : _) : _ ) -> Success Nothing (InputArgs args) + (s1 : sR) -> Success (Just s1) (InputArgs sR) -- | Like 'addParamStrings' but does not match strings starting with a dash. -- This prevents misinterpretation of flags as params. @@ -309,22 +325,23 @@ addParamNoFlagStrings name par = addCmdPartManyInp ManyUpperBoundN desc parseF addSuggestion (_param_suggestions par) $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name - parseF :: Input -> Maybe (String, Input) + parseF :: PartParser String Input parseF (InputString str) = case break Char.isSpace $ dropWhile Char.isSpace str of - ("" , _ ) -> Nothing - ('-':_, _ ) -> Nothing - (x , rest) -> Just (x, InputString rest) + ("" , _ ) -> Failure Nothing + ('-' : _, _ ) -> Failure Nothing + (x , rest) -> Success x (InputString rest) parseF (InputArgs args) = case args of - [] -> Nothing - (('-':_):_ ) -> Nothing - (s1 :sR) -> Just (s1, InputArgs sR) + [] -> Failure Nothing + (('-' : _) : _ ) -> Failure Nothing + (s1 : sR) -> Success s1 (InputArgs sR) -- | Add a parameter that consumes _all_ remaining input. Typical usecase is -- after a "--" as common in certain (unix?) commandline tools. addParamRestOfInput - :: forall f out . (Applicative f) + :: forall f out + . (Applicative f) => String -> Param Void -> CmdParser f out String @@ -343,15 +360,16 @@ addRestOfInputStringParam name par = addCmdPartInp desc parseF addSuggestion (_param_suggestions par) $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name - parseF :: Input -> Maybe (String, Input) - parseF (InputString str ) = Just (str, InputString "") - parseF (InputArgs args) = Just (List.unwords args, InputArgs []) + parseF :: PartParser String Input + parseF (InputString str ) = Success str (InputString "") + parseF (InputArgs args) = Success (List.unwords args) (InputArgs []) -- | Add a parameter that consumes _all_ remaining input, returning a raw -- 'Input' value. addParamRestOfInputRaw - :: forall f out . (Applicative f) + :: forall f out + . (Applicative f) => String -> Param Void -> CmdParser f out Input @@ -362,7 +380,7 @@ addParamRestOfInputRaw name par = addCmdPartInp desc parseF addSuggestion (_param_suggestions par) $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name - parseF :: Input -> Maybe (Input, Input) - parseF i@InputString{} = Just (i, InputString "") - parseF i@InputArgs{} = Just (i, InputArgs []) + parseF :: PartParser Input Input + parseF i@InputString{} = Success i (InputString "") + parseF i@InputArgs{} = Success i (InputArgs []) diff --git a/src/UI/Butcher/Monadic/Pretty.hs b/src/UI/Butcher/Monadic/Pretty.hs index bcf912f..d81aedd 100644 --- a/src/UI/Butcher/Monadic/Pretty.hs +++ b/src/UI/Butcher/Monadic/Pretty.hs @@ -42,351 +42,4 @@ where -#include "prelude.inc" -import Control.Monad.Free -import qualified Control.Monad.Trans.MultiRWS.Strict - as MultiRWSS -import qualified Control.Monad.Trans.MultiState.Strict - as MultiStateS - -import qualified Text.PrettyPrint as PP -import Text.PrettyPrint ( (<+>) - , ($$) - , ($+$) - ) - -import Data.HList.ContainsType - -import UI.Butcher.Monadic.Internal.Types -import UI.Butcher.Monadic.Internal.Core - - - --- | ppUsage exampleDesc yields: --- --- > example [--short] NAME [version | help] -ppUsage :: CommandDesc a -> PP.Doc -ppUsage (CommandDesc mParent _syn _help parts out children _hidden) = - pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc] - where - pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc - pparents Nothing = PP.empty - pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n - pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) - partDocs = Maybe.mapMaybe ppPartDescUsage parts - visibleChildren = - [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ] - subsDoc = case out of - _ | null visibleChildren -> PP.empty - Nothing | null parts -> subDoc - | otherwise -> PP.parens $ subDoc - Just{} -> PP.brackets $ subDoc - subDoc = - PP.fcat - $ PP.punctuate (PP.text " | ") - $ Data.Foldable.toList - $ (PP.text . fst) - <$> visibleChildren - --- | ppUsageShortSub exampleDesc yields: --- --- > example [--short] NAME --- --- I.e. Subcommands are abbreviated using the @@ label, instead --- of being listed. -ppUsageShortSub :: CommandDesc a -> PP.Doc -ppUsageShortSub (CommandDesc mParent _syn _help parts out children _hidden) = - pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc] - where - pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc - pparents Nothing = PP.empty - pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n - pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) - partDocs = Maybe.mapMaybe ppPartDescUsage parts - visibleChildren = - [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ] - subsDoc = case out of - _ | null visibleChildren -> PP.empty - Nothing -> subDoc - Just{} -> PP.brackets $ subDoc - subDoc = if null visibleChildren then PP.empty else PP.text "" - --- | ppUsageWithHelp exampleDesc yields: --- --- > example [--short] NAME --- > [version | help]: a simple butcher example program --- --- And yes, the line break is not optimal in this instance with default print. -ppUsageWithHelp :: CommandDesc a -> PP.Doc -ppUsageWithHelp (CommandDesc mParent _syn help parts out children _hidden) = - pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc - where - pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc - pparents Nothing = PP.empty - pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n - pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) - partDocs = Maybe.mapMaybe ppPartDescUsage parts - subsDoc = case out of - _ | null children -> PP.empty -- TODO: remove debug - Nothing | null parts -> subDoc - | otherwise -> PP.parens $ subDoc - Just{} -> PP.brackets $ subDoc - subDoc = - PP.fcat - $ PP.punctuate (PP.text " | ") - $ Data.Foldable.toList - $ [ PP.text n | (Just n, c) <- children, _cmd_visibility c == Visible ] - helpDoc = case help of - Nothing -> PP.empty - Just h -> PP.text ":" PP.<+> h - --- | > ppUsageAt [] = ppUsage --- --- fromJust $ ppUsageAt ["version"] exampleDesc yields: --- --- > example version [--porcelain] -ppUsageAt - :: [String] -- (sub)command sequence - -> CommandDesc a - -> Maybe PP.Doc -ppUsageAt strings desc = ppUsage <$> descendDescTo strings desc - --- | Access a child command's CommandDesc. -descendDescTo :: [String] -> CommandDesc a -> Maybe (CommandDesc a) -descendDescTo strings desc = case strings of - [] -> Just desc - (s : sr) -> do -- Maybe - (_, childDesc) <- find ((Just s ==) . fst) (_cmd_children desc) - descendDescTo sr childDesc - --- | ppHelpShallow exampleDesc yields: --- --- > NAME --- > --- > example - a simple butcher example program --- > --- > USAGE --- > --- > example [--short] NAME [version | help] --- > --- > DESCRIPTION --- > --- > a very long help document --- > --- > ARGUMENTS --- > --- > --short make the greeting short --- > NAME your name, so you can be greeted properly -ppHelpShallow :: CommandDesc a -> PP.Doc -ppHelpShallow desc = - nameSection - $+$ usageSection - $+$ descriptionSection - $+$ partsSection - $+$ PP.text "" - where - CommandDesc mParent syn help parts _out _children _hidden = desc - nameSection = case mParent of - Nothing -> PP.empty - Just{} -> - PP.text "NAME" - $+$ PP.text "" - $+$ PP.nest - 2 - (case syn of - Nothing -> pparents mParent - Just s -> pparents mParent <+> PP.text "-" <+> s - ) - $+$ PP.text "" - pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc - pparents Nothing = PP.empty - pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n - pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) - usageSection = PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsage desc) - descriptionSection = case help of - Nothing -> PP.empty - Just h -> - PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h - partsSection = if null partsTuples - then PP.empty - else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest - 2 - (PP.vcat partsTuples) - partsTuples :: [PP.Doc] - partsTuples = parts >>= go - where - go = \case - PartLiteral{} -> [] - PartVariable{} -> [] - PartOptional p -> go p - PartAlts ps -> ps >>= go - PartSeq ps -> ps >>= go - PartDefault _ p -> go p - PartSuggestion _ p -> go p - PartRedirect s p -> - [PP.text s $$ PP.nest 20 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)] - ++ (PP.nest 2 <$> go p) - PartReorder ps -> ps >>= go - PartMany p -> go p - PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p - PartHidden{} -> [] - --- | ppHelpDepthOne exampleDesc yields: --- --- > NAME --- > --- > example - a simple butcher example program --- > --- > USAGE --- > --- > example [--short] NAME --- > --- > DESCRIPTION --- > --- > a very long help document --- > --- > COMMANDS --- > --- > version --- > help --- > --- > ARGUMENTS --- > --- > --short make the greeting short --- > NAME your name, so you can be greeted properly -ppHelpDepthOne :: CommandDesc a -> PP.Doc -ppHelpDepthOne desc = - nameSection - $+$ usageSection - $+$ descriptionSection - $+$ commandSection - $+$ partsSection - $+$ PP.text "" - where - CommandDesc mParent syn help parts _out children _hidden = desc - nameSection = case mParent of - Nothing -> PP.empty - Just{} -> - PP.text "NAME" - $+$ PP.text "" - $+$ PP.nest - 2 - (case syn of - Nothing -> pparents mParent - Just s -> pparents mParent <+> PP.text "-" <+> s - ) - $+$ PP.text "" - pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc - pparents Nothing = PP.empty - pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n - pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) - usageSection = - PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsageShortSub desc) - descriptionSection = case help of - Nothing -> PP.empty - Just h -> - PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h - visibleChildren = - [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ] - childDescs = visibleChildren <&> \(n, c) -> - PP.text n $$ PP.nest 20 (Maybe.fromMaybe PP.empty (_cmd_synopsis c)) - commandSection = if null visibleChildren - then PP.empty - else PP.text "" $+$ PP.text "COMMANDS" $+$ PP.text "" $+$ PP.nest - 2 - (PP.vcat $ Data.Foldable.toList childDescs) - partsSection = if null partsTuples - then PP.empty - else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest - 2 - (PP.vcat partsTuples) - partsTuples :: [PP.Doc] - partsTuples = parts >>= go - where - go = \case - PartLiteral{} -> [] - PartVariable{} -> [] - PartOptional p -> go p - PartAlts ps -> ps >>= go - PartSeq ps -> ps >>= go - PartDefault _ p -> go p - PartSuggestion _ p -> go p - PartRedirect s p -> - [PP.text s $$ PP.nest 20 (Maybe.fromMaybe PP.empty $ ppPartDescUsage p)] - ++ (PP.nest 2 <$> go p) - PartReorder ps -> ps >>= go - PartMany p -> go p - PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p - PartHidden{} -> [] - --- | Internal helper; users probably won't need this. -ppPartDescUsage :: PartDesc -> Maybe PP.Doc -ppPartDescUsage = \case - PartLiteral s -> Just $ PP.text s - PartVariable s -> Just $ PP.text s - PartOptional p -> PP.brackets <$> rec p - PartAlts ps -> - [ PP.fcat $ PP.punctuate (PP.text ",") ds - | let ds = Maybe.mapMaybe rec ps - , not (null ds) - ] - PartSeq ps -> [ PP.fsep ds | let ds = Maybe.mapMaybe rec ps, not (null ds) ] - PartDefault _ p -> PP.brackets <$> rec p - PartSuggestion sgs p -> rec p <&> \d -> - case [ PP.text s | CompletionString s <- sgs ] of - [] -> d - sgsDocs -> - PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ sgsDocs ++ [d] - PartRedirect s _ -> Just $ PP.text s - PartMany p -> rec p <&> (PP.<> PP.text "+") - PartWithHelp _ p -> rec p - PartReorder ps -> - let flags = [ d | PartMany d <- ps ] - params = filter - (\case - PartMany{} -> False - _ -> True - ) - ps - in Just $ PP.sep - [ (PP.fsep $ PP.brackets <$> Maybe.mapMaybe rec flags) - , PP.fsep (Maybe.mapMaybe rec params) - ] - PartHidden{} -> Nothing - where rec = ppPartDescUsage - --- | Internal helper; users probably won't need this. -ppPartDescHeader :: PartDesc -> PP.Doc -ppPartDescHeader = \case - PartLiteral s -> PP.text s - PartVariable s -> PP.text s - PartOptional ds' -> rec ds' - PartAlts alts -> PP.hcat $ List.intersperse (PP.text ",") $ rec <$> alts - PartDefault _ d -> rec d - PartSuggestion _ d -> rec d - PartRedirect s _ -> PP.text s - PartMany ds -> rec ds - PartWithHelp _ d -> rec d - PartSeq ds -> PP.hsep $ rec <$> ds - PartReorder ds -> PP.vcat $ rec <$> ds - PartHidden d -> rec d - where rec = ppPartDescHeader - --- | Simple conversion from 'ParsingError' to 'String'. -parsingErrorString :: ParsingError -> String -parsingErrorString (ParsingError mess remaining) = - "error parsing arguments: " ++ messStr ++ remainingStr - where - messStr = case mess of - [] -> "" - (m : _) -> m ++ " " - remainingStr = case remaining of - InputString "" -> "at the end of input." - InputString str -> case show str of - s | length s < 42 -> "at: " ++ s ++ "." - s -> "at: " ++ take 40 s ++ "..\"." - InputArgs [] -> "at the end of input" - InputArgs xs -> case List.unwords $ show <$> xs of - s | length s < 42 -> "at: " ++ s ++ "." - s -> "at: " ++ take 40 s ++ "..\"." - +import UI.Butcher.Internal.Pretty diff --git a/src/UI/Butcher/Monadic/Types.hs b/src/UI/Butcher/Monadic/Types.hs index 1d9cde4..dbe9aca 100644 --- a/src/UI/Butcher/Monadic/Types.hs +++ b/src/UI/Butcher/Monadic/Types.hs @@ -3,7 +3,6 @@ -- | Types used in the butcher interface. module UI.Butcher.Monadic.Types ( CommandDesc(..) - , cmd_out , CmdParser , Input (..) , ParsingError (..) @@ -19,4 +18,4 @@ where -import UI.Butcher.Monadic.Internal.Types +import UI.Butcher.Internal.MonadicTypes diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc index af80fb5..9b98510 100644 --- a/srcinc/prelude.inc +++ b/srcinc/prelude.inc @@ -103,18 +103,20 @@ import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.State.Lazy as StateL import qualified Control.Monad.Trans.State.Strict as StateS +import qualified Control.Monad.Trans.Except as Except + import Data.Functor.Identity ( Identity(..) ) import Control.Concurrent.Chan ( Chan ) -- import Control.Concurrent.MVar ( MVar ) -- import Control.Monad.ST ( ST ) -- import Data.IORef ( IORef ) -import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), First(..), Last(..), Alt(..), ) +import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), Alt(..), ) -- import Data.Ord ( Ordering(..), Down(..) ) -- import Data.Ratio ( Ratio, Rational ) import Data.Void ( Void ) -- import Data.Proxy ( Proxy(..) ) import Data.Sequence ( Seq ) -import Data.Semigroup ( Semigroup(..) ) +import Data.Semigroup ( Semigroup(..), Option ) import Data.Map ( Map ) import Data.Set ( Set ) @@ -160,6 +162,7 @@ import Prelude ( Char , putStrLn , putStr , Show (..) + , Read (..) , print , fst , snd diff --git a/stack-8-10.yaml b/stack-8-10.yaml index ec7e7e1..df25683 100644 --- a/stack-8-10.yaml +++ b/stack-8-10.yaml @@ -38,7 +38,8 @@ packages: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -# extra-deps: [] +extra-deps: + - barbies-2.0.2.0 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/stack-8-4.yaml b/stack-8-4.yaml index d839e5a..b2d3eb2 100644 --- a/stack-8-4.yaml +++ b/stack-8-4.yaml @@ -42,7 +42,7 @@ extra-deps: - deque-0.4.2.3 - extra-1.7.1 - strict-list-0.1.5 -- barbies-2.0.1.0 +- barbies-2.0.2.0 - hsc2hs-0.68.7 # Override default flag values for local packages and extra-deps diff --git a/stack-8-6.yaml b/stack-8-6.yaml index 4f9b75e..24d7644 100644 --- a/stack-8-6.yaml +++ b/stack-8-6.yaml @@ -42,6 +42,7 @@ extra-deps: - base-orphans-0.8.1@sha256:defd0057b5db93257528d89b5b01a0fee9738e878c121c686948ac4aa5dded63,2927 - hashable-1.3.0.0 - unordered-containers-0.2.10.0 +- barbies-2.0.2.0 # Override default flag values for local packages and extra-deps # flags: {}