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: {}