diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/butcher.cabal b/butcher.cabal --- a/butcher.cabal +++ b/butcher.cabal @@ -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 (it is properly formatted on github). license: BSD3 license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner -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 diff --git a/src-tests/TestMain.hs b/src-tests/TestMain.hs --- a/src-tests/TestMain.hs +++ b/src-tests/TestMain.hs @@ -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 diff --git a/src/UI/Butcher/Applicative.hs b/src/UI/Butcher/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/UI/Butcher/Applicative.hs @@ -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 ++ "!" +-} diff --git a/src/UI/Butcher/Applicative/Types.hs b/src/UI/Butcher/Applicative/Types.hs new file mode 100644 --- /dev/null +++ b/src/UI/Butcher/Applicative/Types.hs @@ -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) diff --git a/src/UI/Butcher/Monadic/Flag.hs b/src/UI/Butcher/Monadic/Flag.hs --- a/src/UI/Butcher/Monadic/Flag.hs +++ b/src/UI/Butcher/Monadic/Flag.hs @@ -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 () diff --git a/src/UI/Butcher/Monadic/Internal/Core.hs b/src/UI/Butcher/Monadic/Internal/Core.hs --- a/src/UI/Butcher/Monadic/Internal/Core.hs +++ b/src/UI/Butcher/Monadic/Internal/Core.hs @@ -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 diff --git a/src/UI/Butcher/Monadic/Pretty.hs b/src/UI/Butcher/Monadic/Pretty.hs --- a/src/UI/Butcher/Monadic/Pretty.hs +++ b/src/UI/Butcher/Monadic/Pretty.hs @@ -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 ++ "..\"." diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc --- a/srcinc/prelude.inc +++ b/srcinc/prelude.inc @@ -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 ( (<&>) )