butcher 1.3.2.3 → 1.3.3.0
raw patch · 9 files changed
+722/−217 lines, 9 filesdep ~base
Dependency ranges changed: base
Files
- ChangeLog.md +5/−0
- butcher.cabal +7/−5
- src-tests/TestMain.hs +27/−0
- src/UI/Butcher/Applicative.hs +317/−0
- src/UI/Butcher/Applicative/Types.hs +145/−0
- src/UI/Butcher/Monadic/Flag.hs +4/−4
- src/UI/Butcher/Monadic/Internal/Core.hs +6/−2
- src/UI/Butcher/Monadic/Pretty.hs +38/−25
- srcinc/prelude.inc +173/−181
ChangeLog.md view
@@ -1,5 +1,10 @@ # Revision history for butcher +## 1.3.3.0 -- April 2020++* Fix bug with params with default when parsing from commandline+* Add the `descendDescTo` function+ ## 1.3.2.3 -- June 2019 * Fix broken build when using deque>=0.3
butcher.cabal view
@@ -1,12 +1,12 @@ name: butcher-version: 1.3.2.3+version: 1.3.3.0 synopsis: Chops a command or program invocation into digestable pieces. description: See the <https://github.com/lspitzner/butcher/blob/master/README.md README> (it is properly formatted on github). license: BSD3 license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner <hexagoxel@hexagoxel.de>-copyright: Copyright (C) 2016-2019 Lennart Spitzner+copyright: Copyright (C) 2016-2020 Lennart Spitzner category: UI build-type: Simple Stability: experimental@@ -34,10 +34,12 @@ UI.Butcher.Monadic.IO UI.Butcher.Monadic.Interactive UI.Butcher.Monadic.BuiltinCommands+ UI.Butcher.Applicative.Types+ UI.Butcher.Applicative other-modules: UI.Butcher.Monadic.Internal.Types UI.Butcher.Monadic.Internal.Core build-depends:- { base >=4.9 && <4.13+ { base >=4.9 && <4.14 , free < 5.2 , unsafe < 0.1 , microlens <0.5@@ -47,7 +49,7 @@ , containers <0.7 , transformers <0.6 , mtl <2.3- , extra <1.7+ , extra <1.8 , void <0.8 , bifunctors <5.6 , deque >=0.3 && <0.5@@ -107,7 +109,7 @@ , deque , hspec }- ghc-options: -Wall+ ghc-options: -Wall -rtsopts main-is: TestMain.hs other-modules: hs-source-dirs: src-tests
src-tests/TestMain.hs view
@@ -118,6 +118,18 @@ it "case 4" $ testRun' testCmd7 "abc -f" `shouldBe` Right (Just (["abc"], 1)) it "case 5" $ testRun' testCmd7 "-g abc -f" `shouldBe` Right (Just (["abc"], 3)) it "case 6" $ testRun' testCmd7 "abc -g def" `shouldBe` Right (Just (["abc", "def"], 2))+ describe "defaultParam" $ do+ it "case 1" $ testRun testCmdParam "" `shouldSatisfy` Data.Either.isLeft+ it "case 2" $ testRun testCmdParam "n" `shouldSatisfy` Data.Either.isLeft+ it "case 3" $ testRun testCmdParam "y" `shouldSatisfy` Data.Either.isLeft+ it "case 4" $ testRun testCmdParam "False n" `shouldBe` Right (Just 110)+ it "case 5" $ testRun testCmdParam "False y" `shouldBe` Right (Just 310)+ it "case 6" $ testRun testCmdParam "True n" `shouldBe` Right (Just 1110)+ it "case 7" $ testRun testCmdParam "True y" `shouldBe` Right (Just 1310)+ it "case 8" $ testRun testCmdParam "1 False y" `shouldBe` Right (Just 301)+ it "case 9" $ testRun testCmdParam "1 False y def" `shouldBe` Right (Just 201)+ it "case 10" $ testRun testCmdParam "1 False 2 y def" `shouldBe` Right (Just 203)+ it "case 11" $ testRun testCmdParam "1 True 2 y def" `shouldBe` Right (Just 1203) describe "completions" $ do it "case 1" $ testCompletion completionTestCmd "" `shouldBe` "" it "case 2" $ testCompletion completionTestCmd "a" `shouldBe` "bc"@@ -214,6 +226,21 @@ when f $ WriterS.tell 1 when g $ WriterS.tell 2 pure args++testCmdParam :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()+testCmdParam = do+ p :: Int <- addParamRead "INT" (paramDefault 10)+ b <- addParamRead "MANDR" mempty+ r <- addParamReadOpt "MAY1" (paramDefault 20)+ s <- addParamString "MAND" mempty+ q <- addParamString "STR" (paramDefault "abc")+ addCmdImpl $ do+ WriterS.tell (Sum p)+ when (q=="abc") $ WriterS.tell 100+ r `forM_` (WriterS.tell . Sum)+ when b $ WriterS.tell $ Sum 1000+ when (s=="y") $ WriterS.tell 200+ pure () completionTestCmd :: CmdParser Identity () () completionTestCmd = do
+ src/UI/Butcher/Applicative.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}++module UI.Butcher.Applicative where++++#include "prelude.inc"++import UI.Butcher.Applicative.Types+import Control.Applicative.Free+import qualified Text.PrettyPrint as PP+++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_children = Data.Foldable.toList $ 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"+ CmdParserPeekInput _ -> s+ CmdParserPart desc _ _ -> appendPart s desc+ CmdParserPartMany _ desc _ _ -> appendPart s desc+ CmdParserPartInp desc _ _ -> appendPart s desc+ CmdParserPartManyInp _ desc _ _ -> appendPart s desc+ CmdParserChild name parser _ -> appendChild s $ (name, toCmdDesc parser)+ 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.snoc p (parts s) }+ appendChild s c = s { children = Deque.snoc 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+ }++runCmdParser+ :: Input -> CmdParser out out -> (CommandDesc, Either ParsingError out)+runCmdParser initialInput initialParser =+ let topDesc = toCmdDesc initialParser+ in (topDesc, go initialInput topDesc initialParser)+ where+ go :: Input -> CommandDesc -> CmdParser out out -> Either ParsingError out+ go input desc parser =+ -- TODO use x?+ let initialState = ParserState { p_parts = mempty+ , p_children = mempty+ , p_help = Nothing+ , p_reorder = mempty+ , p_input = input+ }+ (outE, _x) = StateS.runState (iter parser) initialState+ in outE+ where+ iter+ :: CmdParser out out+ -> StateS.State (ParserState out) (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 (CmdParserPeekInput f ) next -> do+ s <- StateS.get+ iter $ next <&> \g -> g $ f (inputToString $ p_input s)+ Ap (CmdParserPart _ parseF f) next -> parseWithStr+ parseF+ (\x -> iter $ next <&> \g -> g (f x))+ (\s -> pure $ Left $ ParsingError { _pe_messages = ["could not parse"]+ , _pe_remaining = p_input s+ }+ )+ Ap (CmdParserPartMany _ _ parseF f) next -> do+ let loop = do+ dropSpaces+ parseWithStr+ parseF+ (\x -> do+ more <- loop+ pure (x : more)+ )+ (\_ -> pure [])+ ps <- loop+ iter $ next <&> \g -> g (f ps)+ Ap (CmdParserPartInp _ parseF f) next -> do+ s <- StateS.get+ case parseF (p_input s) 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+ }+ Ap (CmdParserPartManyInp _ _ parseF f) next -> do+ let loop = do+ dropSpaces+ s <- StateS.get+ case parseF (p_input s) 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 ((== 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+ pure $ go (InputString "") childDesc childParser+ |+-- TODO str prefix+ otherwise -> continue next x+ InputArgs (a1 : ar) | a1 == name -> do+ pure $ go (InputArgs ar) childDesc childParser+ InputArgs{} -> continue next x+ Ap (CmdParserReorderStart _) next -> error "TODO" next+ Ap (CmdParserReorderStop _) next -> error "TODO" next+ where+ continue next x = iter (($x) <$> next)+ parseWithStr f successF failF = do+ s <- StateS.get+ case p_input s of+ InputString str -> case f str of+ Just (x, rest) -> do+ StateS.put s { p_input = InputString rest }+ successF x+ Nothing -> failF s+ InputArgs (a1 : ar) -> case f a1 of+ Just (x, "") -> do+ StateS.put s { p_input = InputArgs ar }+ successF x+ _ -> failF s+ InputArgs [] -> failF s++ inputToString :: Input -> String+ inputToString (InputString s ) = s+ inputToString (InputArgs ss) = List.unwords ss+ dropSpaces = do+ st <- StateS.get+ case p_input st of+ InputString s ->+ StateS.put $ st { p_input = InputString $ dropWhile Char.isSpace s }+ InputArgs{} -> return ()++addCmdPart+ :: Typeable p => PartDesc -> (String -> Maybe (p, String)) -> CmdParser out p+addCmdPart p f = liftAp $ CmdParserPart p f id++addCmdPartMany+ :: Typeable p+ => ManyUpperBound+ -> PartDesc+ -> (String -> Maybe (p, String))+ -> CmdParser out [p]+addCmdPartMany b p f = liftAp $ CmdParserPartMany b p f id++addCmdPartInp+ :: Typeable p => PartDesc -> (Input -> Maybe (p, Input)) -> CmdParser out p+addCmdPartInp p f = liftAp $ CmdParserPartInp p f id++addCmdPartManyInp+ :: Typeable p+ => ManyUpperBound+ -> PartDesc+ -> (Input -> Maybe (p, Input))+ -> CmdParser out [p]+addCmdPartManyInp b p f = liftAp $ CmdParserPartManyInp b p f id++data Param p = Param+ { _param_default :: Maybe p+ , _param_help :: Maybe PP.Doc+ , _param_suggestions :: Maybe [CompletionItem]+ }++addReadParam+ :: 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+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)++addSuggestion :: Maybe [CompletionItem] -> PartDesc -> PartDesc+addSuggestion Nothing = id+addSuggestion (Just sugs) = PartSuggestion sugs+++data Flag a = Flag+ { flag_name :: String+ , flag_short :: String+ , flag_long :: [String]+ , flag_opts :: FlagOpts a+ , flag_parser :: String -> Maybe (Identity a, String)+ }++data FlagOpts a = FlagOpts+ { _flag_help :: Maybe PP.Doc+ , _flag_default :: Maybe a+ , _flag_visibility :: Visibility+ }++traverseFlags+ :: (Covered c, CTraversable Typeable (c 'Wrap))+ => c 'Wrap Flag+ -> CmdParser out (c 'Bare Identity)+traverseFlags k = do+ r <- cTraverse+ (Proxy @Typeable)+ (\f -> addCmdPart (PartVariable (flag_name f)) (flag_parser f))+ k+ pure $ unwrap r++test :: IO ()+test = do+ let parser = do+ arg :: Int <- addReadParam+ "arg"+ Param { _param_default = Nothing+ , _param_help = Nothing+ , _param_suggestions = Nothing+ }+ pure $ print arg+ let (desc, eOut) = runCmdParser (InputArgs ["42"]) parser+ print desc+ case eOut of+ Left err -> do+ putStrLn "parsing error"+ print err+ Right 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)+++{-+stringArg :: UnwrapField ('Just Arg) String+stringArg = mempty++argDef :: a -> UnwrapField ('Just Arg) a+argDef x = mempty { _arg_def = Just x }++fromUnordered+ :: (Covered h, CTraversable (h Wrap))+ => String+ -> h Wrap Arg+ -> CmdParserF out (h Plain Identity)++data Arg a = Arg+ { _arg_def :: Maybe a+ , _arg_help :: Maybe String+ }++instance Monoid (Arg a) where ..++data MyArgs s f = MyArgs+ { greeting :: Wear s f String+ , name :: Wear s f String+ }++main = butcherMain $ do+ args <- fromUnordered MyArgs+ { greeting = stringArg <> argDef "hi"+ , name = stringArg+ }+ pure do+ putStrLn $ greeting args ++ ", " ++ name args ++ "!"+-}
+ src/UI/Butcher/Applicative/Types.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}++module UI.Butcher.Applicative.Types where++++#include "prelude.inc"+import Control.Applicative.Free+import qualified Control.Monad.Trans.MultiState.Strict+ as MultiStateS++-- import qualified Lens.Micro.TH as LensTH++import qualified Text.PrettyPrint as PP++++-- | Butcher supports two input modi: @String@ and @[String]@. Program+-- arguments have the latter form, while parsing interactive command input+-- (e.g. when you implement a terminal of sorts) is easier when you can+-- process the full @String@ without having to wordify it first by some+-- means (and List.words is not the right approach in many situations.)+data Input = InputString String | InputArgs [String]+ deriving (Show, Eq)++-- | Information about an error that occured when trying to parse some @Input@+-- using some @CmdParser@.+data ParsingError = ParsingError+ { _pe_messages :: [String]+ , _pe_remaining :: Input+ }+ deriving (Show, Eq)++-- | Specifies whether we accept 0-1 or 0-n for @CmdParserPart@s.+data ManyUpperBound+ = ManyUpperBound1+ | ManyUpperBoundN++data Visibility = Visible | Hidden+ deriving (Show, Eq)+++data CmdParserF 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 -> a)+ | forall p . Typeable p => CmdParserPartMany+ ManyUpperBound PartDesc+ (String -> Maybe (p, String))+ ([p] -> a)+ | forall p . Typeable p => CmdParserPartInp+ PartDesc+ (Input -> Maybe (p, Input))+ (p -> a)+ | forall p . Typeable p => CmdParserPartManyInp+ ManyUpperBound+ PartDesc+ (Input -> Maybe (p, Input))+ ([p] -> a)+ | CmdParserChild String (CmdParser out out) a+ | CmdParserReorderStart a+ | CmdParserReorderStop a+ -- | CmdParserGrouped String a+ -- | CmdParserGroupEnd a++type CmdParser out = Ap (CmdParserF out)++---------++-- | A representation/description of a command parser built via the+-- 'CmdParser' monad. Can be transformed into a pretty Doc to display+-- as usage/help via 'UI.Butcher.Monadic.Pretty.ppUsage' and related functions.+--+-- Note that there is the '_cmd_out' accessor that contains @Maybe out@ which+-- might be useful after successful parsing.+data CommandDesc = CommandDesc+ { _cmd_mParent :: Maybe (Maybe String, CommandDesc)+ , _cmd_synopsis :: Maybe PP.Doc+ , _cmd_help :: Maybe PP.Doc+ , _cmd_parts :: [PartDesc]+ , _cmd_children :: [(String, CommandDesc)]+ , _cmd_visibility :: Visibility+ }+ deriving Show++-- type PartSeqDesc = [PartDesc]++-- | A representation/description of a command's parts, i.e. flags or params.+-- As a butcher user, the higher-level pretty-printing functions for+-- 'CommandDesc' are probably sufficient.+data PartDesc+ = PartLiteral String -- expect a literal string, like "--dry-run"+ | PartVariable String -- expect some user-provided input. The+ -- string represents the name for the variable+ -- used in the documentation, e.g. "FILE"+ | PartOptional PartDesc+ | PartAlts [PartDesc]+ | PartSeq [PartDesc]+ | PartDefault String -- default representation+ PartDesc+ | PartSuggestion [CompletionItem] PartDesc+ | PartRedirect String -- name for the redirection+ PartDesc+ | PartReorder [PartDesc]+ | PartMany PartDesc+ | PartWithHelp PP.Doc PartDesc+ | PartHidden PartDesc+ deriving Show++data CompletionItem+ = CompletionString String+ | CompletionDirectory+ | CompletionFile+ deriving Show++data Cover+ = Bare+ | Wrap++type family Wear cover f a where+ Wear 'Bare Identity a = a+ Wear 'Wrap f a = f a++class Covered c where+ wrap :: c 'Bare Identity -> c 'Wrap Identity+ unwrap :: c 'Wrap Identity -> c 'Bare Identity++class CTraversable ctx c where+ cTraverse :: Proxy ctx -> (forall a . ctx a => f a -> m (g a)) -> c f -> m (c g)
src/UI/Butcher/Monadic/Flag.hs view
@@ -235,9 +235,9 @@ InputArgs (arg1:argR) -> case runInpParseString arg1 parser of Just ((), "") -> case argR of [] -> Nothing- (arg2:rest) -> readMaybe arg2 <&> \x -> (x, InputArgs rest)+ (arg2:rest) -> Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest) Just ((), remainingStr) ->- readMaybe remainingStr <&> \x -> (x, InputArgs argR)+ Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR) Nothing -> _flag_default flag <&> \d -> (d, inp) where parser :: InpParseString ()@@ -316,10 +316,10 @@ InputArgs (arg1:argR) -> case runInpParseString arg1 parser of Just ((), "") -> case argR of [] -> mdef- (arg2:rest) -> (readMaybe arg2 <&> \x -> (x, InputArgs rest)) <|> mdef+ (arg2:rest) -> (Text.Read.readMaybe arg2 <&> \x -> (x, InputArgs rest)) <|> mdef where mdef = _flag_default flag <&> \p -> (p, InputArgs argR) Just ((), remainingStr) ->- readMaybe remainingStr <&> \x -> (x, InputArgs argR)+ Text.Read.readMaybe remainingStr <&> \x -> (x, InputArgs argR) Nothing -> Nothing where parser :: InpParseString ()
src/UI/Butcher/Monadic/Internal/Core.hs view
@@ -402,7 +402,7 @@ cmd :: CommandDesc out <- mGet subCmd <- do stackCur :: CmdDescStack <- mGet- mSet $ fromMaybe (emptyCommandDesc :: CommandDesc out) mInitialDesc+ mSet $ Maybe.fromMaybe (emptyCommandDesc :: CommandDesc out) mInitialDesc mSet $ StackBottom mempty processMain sub c <- mGet@@ -625,6 +625,10 @@ mSet $ InputArgs strr actRest <- processMain $ nextF x return $ actF x *> actRest+ Just (x, rest) | str == rest -> do+ -- no input consumed, default applied+ actRest <- processMain $ nextF x+ return $ actF x *> actRest _ -> do mTell ["could not parse " ++ getPartSeqDescPositionName desc] processMain $ nextF monadMisuseError@@ -1102,7 +1106,7 @@ CmdParserChild cmdStr vis _sub _act next -> do mExisting <- takeCommandChild cmdStr let childDesc :: CommandDesc out =- fromMaybe emptyCommandDesc { _cmd_visibility = vis } mExisting+ Maybe.fromMaybe emptyCommandDesc { _cmd_visibility = vis } mExisting cmd_children %=+ Deque.snoc (cmdStr, childDesc) next CmdParserImpl out next -> do
src/UI/Butcher/Monadic/Pretty.hs view
@@ -36,6 +36,7 @@ , ppPartDescUsage , ppPartDescHeader , parsingErrorString+ , descendDescTo ) where @@ -43,11 +44,16 @@ #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 Text.PrettyPrint ( (<+>), ($$), ($+$) )+import qualified Text.PrettyPrint as PP+import Text.PrettyPrint ( (<+>)+ , ($$)+ , ($+$)+ ) import Data.HList.ContainsType @@ -77,9 +83,10 @@ Just{} -> PP.brackets $ subDoc subDoc = PP.fcat- $ PP.punctuate (PP.text " | ")- $ Data.Foldable.toList- $ (PP.text . fst) <$> visibleChildren+ $ PP.punctuate (PP.text " | ")+ $ Data.Foldable.toList+ $ (PP.text . fst)+ <$> visibleChildren -- | ppUsageShortSub exampleDesc yields: --@@ -138,14 +145,20 @@ -- fromJust $ ppUsageAt ["version"] exampleDesc yields: -- -- > example version [--porcelain]-ppUsageAt :: [String] -- (sub)command sequence- -> CommandDesc a- -> Maybe PP.Doc-ppUsageAt strings desc =- case strings of- [] -> Just $ ppUsage desc- (s:sr) -> find ((Just s==) . fst) (_cmd_children desc) >>= ppUsageAt sr . snd+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@@ -180,7 +193,7 @@ $+$ PP.text "" $+$ PP.nest 2- ( case syn of+ (case syn of Nothing -> pparents mParent Just s -> pparents mParent <+> PP.text "-" <+> s )@@ -211,7 +224,7 @@ PartDefault _ p -> go p PartSuggestion _ p -> go p PartRedirect s p ->- [PP.text s $$ PP.nest 20 (fromMaybe PP.empty $ ppPartDescUsage 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@@ -258,7 +271,7 @@ $+$ PP.text "" $+$ PP.nest 2- ( case syn of+ (case syn of Nothing -> pparents mParent Just s -> pparents mParent <+> PP.text "-" <+> s )@@ -276,7 +289,7 @@ visibleChildren = [ (n, c) | (Just n, c) <- children, _cmd_visibility c == Visible ] childDescs = visibleChildren <&> \(n, c) ->- PP.text n $$ PP.nest 20 (fromMaybe PP.empty (_cmd_synopsis 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@@ -299,7 +312,7 @@ PartDefault _ p -> go p PartSuggestion _ p -> go p PartRedirect s p ->- [PP.text s $$ PP.nest 20 (fromMaybe PP.empty $ ppPartDescUsage 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@@ -330,7 +343,7 @@ PartReorder ps -> let flags = [ d | PartMany d <- ps ] params = filter- ( \case+ (\case PartMany{} -> False _ -> True )@@ -364,16 +377,16 @@ parsingErrorString (ParsingError mess remaining) = "error parsing arguments: " ++ messStr ++ remainingStr where- messStr = case mess of- [] -> ""- (m:_) -> m ++ " "+ 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+ 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 ++ "..\"."
srcinc/prelude.inc view
@@ -1,80 +1,80 @@-import qualified Data.Graph-import qualified Data.IntMap-import qualified Data.IntMap.Lazy-import qualified Data.IntMap.Strict-import qualified Data.IntSet-import qualified Data.Map-import qualified Data.Map.Lazy-import qualified Data.Map.Strict-import qualified Data.Sequence-import qualified Data.Set-import qualified Data.Tree+-- import qualified Data.Graph+-- import qualified Data.IntMap+-- import qualified Data.IntMap.Lazy+-- import qualified Data.IntMap.Strict+-- import qualified Data.IntSet+-- import qualified Data.Map+-- import qualified Data.Map.Lazy+-- import qualified Data.Map.Strict+-- import qualified Data.Sequence+-- import qualified Data.Set+-- import qualified Data.Tree -import qualified Control.Concurrent.Extra-import qualified Control.Exception.Extra-import qualified Control.Monad.Extra-import qualified Data.Either.Extra-import qualified Data.IORef.Extra-import qualified Data.List.Extra-import qualified Data.Tuple.Extra-import qualified Data.Version.Extra-import qualified Numeric.Extra-import qualified System.Directory.Extra-import qualified System.Environment.Extra-import qualified System.IO.Extra-import qualified System.Info.Extra-import qualified System.Process.Extra-import qualified System.Time.Extra+-- import qualified Control.Concurrent.Extra+-- import qualified Control.Exception.Extra+-- import qualified Control.Monad.Extra+-- import qualified Data.Either.Extra+-- import qualified Data.IORef.Extra+-- import qualified Data.List.Extra+-- import qualified Data.Tuple.Extra+-- import qualified Data.Version.Extra+-- import qualified Numeric.Extra+-- import qualified System.Directory.Extra+-- import qualified System.Environment.Extra+-- import qualified System.IO.Extra+-- import qualified System.Info.Extra+-- import qualified System.Process.Extra+-- import qualified System.Time.Extra -import qualified Control.Monad.Trans.MultiRWS.Lazy-import qualified Control.Monad.Trans.MultiRWS.Strict-import qualified Control.Monad.Trans.MultiReader-import qualified Control.Monad.Trans.MultiReader.Class-import qualified Control.Monad.Trans.MultiReader.Lazy-import qualified Control.Monad.Trans.MultiReader.Strict-import qualified Control.Monad.Trans.MultiState-import qualified Control.Monad.Trans.MultiState.Class-import qualified Control.Monad.Trans.MultiState.Lazy-import qualified Control.Monad.Trans.MultiState.Strict-import qualified Control.Monad.Trans.MultiWriter-import qualified Control.Monad.Trans.MultiWriter.Class-import qualified Control.Monad.Trans.MultiWriter.Lazy-import qualified Control.Monad.Trans.MultiWriter.Strict+-- import qualified Control.Monad.Trans.MultiRWS.Lazy+-- import qualified Control.Monad.Trans.MultiRWS.Strict+-- import qualified Control.Monad.Trans.MultiReader+-- import qualified Control.Monad.Trans.MultiReader.Class+-- import qualified Control.Monad.Trans.MultiReader.Lazy+-- import qualified Control.Monad.Trans.MultiReader.Strict+-- import qualified Control.Monad.Trans.MultiState+-- import qualified Control.Monad.Trans.MultiState.Class+-- import qualified Control.Monad.Trans.MultiState.Lazy+-- import qualified Control.Monad.Trans.MultiState.Strict+-- import qualified Control.Monad.Trans.MultiWriter+-- import qualified Control.Monad.Trans.MultiWriter.Class+-- import qualified Control.Monad.Trans.MultiWriter.Lazy+-- import qualified Control.Monad.Trans.MultiWriter.Strict -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS-import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL+-- import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS+-- import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Data.Bifunctor-import qualified Data.Bits-import qualified Data.Bool-import qualified Data.Char-import qualified Data.Coerce-import qualified Data.Complex-import qualified Data.Data-import qualified Data.Dynamic+-- import qualified Data.Bifunctor+-- import qualified Data.Bits+-- import qualified Data.Bool+-- import qualified Data.Char+-- import qualified Data.Coerce+-- import qualified Data.Complex+-- import qualified Data.Data+-- import qualified Data.Dynamic import qualified Data.Either-import qualified Data.Eq-import qualified Data.Fixed+-- import qualified Data.Eq+-- import qualified Data.Fixed import qualified Data.Foldable import qualified Data.Function-import qualified Data.Functor-import qualified Data.Functor.Identity-import qualified Data.IORef-import qualified Data.Int-import qualified Data.Ix-import qualified Data.List-import qualified Data.Maybe+-- import qualified Data.Functor+-- import qualified Data.Functor.Identity+-- import qualified Data.IORef+-- import qualified Data.Int+-- import qualified Data.Ix+-- import qualified Data.List+-- import qualified Data.Maybe import qualified Data.Monoid-import qualified Data.Ord-import qualified Data.Proxy-import qualified Debug.Trace-import qualified Numeric-import qualified Numeric.Natural+-- import qualified Data.Ord+-- import qualified Data.Proxy+-- import qualified Debug.Trace+-- import qualified Numeric+-- import qualified Numeric.Natural import qualified System.Environment-import qualified System.IO+-- import qualified System.IO import qualified Text.Read-import qualified Text.Show-import qualified Unsafe.Coerce+-- import qualified Text.Show+-- import qualified Unsafe.Coerce import qualified Data.Bool as Bool import qualified Data.Char as Char@@ -87,12 +87,12 @@ import qualified Data.List as List #endif -import qualified Data.IntMap as IntMap-import qualified Data.IntMap.Strict as IntMapS+-- import qualified Data.IntMap as IntMap+-- import qualified Data.IntMap.Strict as IntMapS import qualified Data.Map.Strict as MapS import qualified Data.Map.Lazy as MapL-import qualified Data.Sequence as Seq-import qualified Data.Set as Set+-- import qualified Data.Sequence as Seq+-- import qualified Data.Set as Set import qualified Control.Monad.RWS.Class as RWS.Class import qualified Control.Monad.Reader.Class as Reader.Class@@ -105,23 +105,14 @@ import Data.Functor.Identity ( Identity(..) ) import Control.Concurrent.Chan ( Chan )-import Control.Concurrent.MVar ( MVar )-import Data.Int ( Int )-import Data.Word ( Word )-import Prelude ( Integer, Float, Double )-import Control.Monad.ST ( ST )-import Data.Bool ( Bool(..) )-import Data.Char ( Char )-import Data.Either ( Either(..) )-import Data.IORef ( IORef )-import Data.Maybe ( Maybe(..) )+-- import Control.Concurrent.MVar ( MVar )+-- import Control.Monad.ST ( ST )+-- import Data.IORef ( IORef ) import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), First(..), Last(..), Alt(..), )-import Data.Ord ( Ordering(..), Down(..) )-import Data.Ratio ( Ratio, Rational )-import Data.String ( String )+-- import Data.Ord ( Ordering(..), Down(..) )+-- import Data.Ratio ( Ratio, Rational ) import Data.Void ( Void )-import System.IO ( IO )-import Data.Proxy ( Proxy(..) )+-- import Data.Proxy ( Proxy(..) ) import Data.Sequence ( Seq ) import Data.Semigroup ( Semigroup(..) ) @@ -136,6 +127,7 @@ , String , Int , Integer+ , Word , Float , Double , Bool (..)@@ -192,6 +184,12 @@ , (^) , Foldable , Traversable+ , mempty+ , maybe+ , Applicative(..)+ , (<$)+ , Monoid(..)+ , either ) import Data.Foldable ( foldl'@@ -235,38 +233,31 @@ , uncons ) -import Data.Tuple ( swap- )--import Data.Char ( ord- , chr- )+-- import Data.Tuple ( swap+-- ) -import Data.Maybe ( fromMaybe- , maybe- , listToMaybe- , maybeToList- , catMaybes- )+-- import Data.Char ( ord+-- , chr+-- ) -import Data.Word ( Word32- )+-- import Data.Word ( Word32+-- ) -import Data.Ord ( comparing- , Down (..)- )+-- import Data.Ord ( comparing+-- , Down (..)+-- ) -import Data.Either ( either- )+-- import Data.Either ( either+-- ) -import Data.Ratio ( Ratio- , (%)- , numerator- , denominator- )+-- import Data.Ratio ( Ratio+-- , (%)+-- , numerator+-- , denominator+-- ) -import Text.Read ( readMaybe- )+-- import Text.Read ( readMaybe+-- ) import Control.Monad ( Functor (..) , Monad (..)@@ -301,56 +292,57 @@ , Alternative (..) ) -import Foreign.Storable ( Storable )-import GHC.Exts ( Constraint )+-- import Foreign.Storable ( Storable )+-- import GHC.Exts ( Constraint ) -import Control.Concurrent ( threadDelay- , forkIO- , forkOS- )+-- import Control.Concurrent ( threadDelay+-- , forkIO+-- , forkOS+-- ) -import Control.Concurrent.MVar ( MVar- , newEmptyMVar- , newMVar- , putMVar- , readMVar- , takeMVar- , swapMVar- )+-- import Control.Concurrent.MVar ( MVar+-- , newEmptyMVar+-- , newMVar+-- , putMVar+-- , readMVar+-- , takeMVar+-- , swapMVar+-- ) -import Control.Exception ( evaluate- , bracket- , assert- )+-- import Control.Exception ( evaluate+-- , bracket+-- , assert+-- ) -import Debug.Trace ( trace- , traceId- , traceShowId- , traceShow- , traceStack- , traceShowId- , traceIO- , traceM- , traceShowM- )+-- import Debug.Trace ( trace+-- , traceId+-- , traceShowId+-- , traceShow+-- , traceStack+-- , traceShowId+-- , traceIO+-- , traceM+-- , traceShowM+-- ) -import Foreign.ForeignPtr ( ForeignPtr- )+-- import Foreign.ForeignPtr ( ForeignPtr+-- ) -import Data.Monoid ( Monoid- , mempty- , mconcat- )+-- import Data.Monoid ( Monoid+-- , mempty+-- , mconcat+-- ) -import Data.Bifunctor ( bimap )+-- import Data.Bifunctor ( bimap ) import Data.Functor ( (<$), ($>) )-import Data.Function ( (&) )-import System.IO ( hFlush- , stdout- )+-- import Data.Function ( (&) )+-- import System.IO ( hFlush+-- , stdout+-- ) import Data.Typeable ( Typeable , cast+ , Proxy(..) ) import Control.Arrow ( first@@ -361,30 +353,30 @@ , (<<<) ) -import Data.Functor.Identity ( Identity (..)- )+-- import Data.Functor.Identity ( Identity (..)+-- ) -import Data.Proxy ( Proxy (..)- )+-- import Data.Proxy ( Proxy (..)+-- ) -import Data.Version ( showVersion- )+-- import Data.Version ( showVersion+-- ) -import Data.List.Extra ( nubOrd- , stripSuffix- )-import Control.Monad.Extra ( whenM- , unlessM- , ifM- , notM- , orM- , andM- , anyM- , allM- )+-- import Data.List.Extra ( nubOrd+-- , stripSuffix+-- )+-- import Control.Monad.Extra ( whenM+-- , unlessM+-- , ifM+-- , notM+-- , orM+-- , andM+-- , anyM+-- , allM+-- ) -import Data.Tree ( Tree(..)- )+-- import Data.Tree ( Tree(..)+-- ) import Control.Monad.Trans.MultiRWS ( MonadMultiReader(..) , MonadMultiWriter(..)@@ -392,19 +384,19 @@ , mGet ) -import Control.Monad.Trans.MultiReader ( runMultiReaderTNil- , runMultiReaderTNil_- , MultiReaderT (..)- , MultiReader- , MultiReaderTNull- )+-- import Control.Monad.Trans.MultiReader ( runMultiReaderTNil+-- , runMultiReaderTNil_+-- , MultiReaderT (..)+-- , MultiReader+-- , MultiReaderTNull+-- ) -import Control.Monad.IO.Class ( MonadIO (..)- )+-- import Control.Monad.IO.Class ( MonadIO (..)+-- ) import Control.Monad.Trans.Class ( lift )-import Control.Monad.Trans.Maybe ( MaybeT (..)- )+-- import Control.Monad.Trans.Maybe ( MaybeT (..)+-- ) import Lens.Micro ( (<&>) )