From b11663d91063097849524d966b7c2e938fdb2850 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 30 Dec 2016 22:05:52 +0100 Subject: [PATCH] Add 'suggestion' functionality i.e. possible additional input that could make the input valid (or at least less invalid). --- src/UI/Butcher/Monadic/Core.hs | 1 + src/UI/Butcher/Monadic/Param.hs | 17 +++++++-- src/UI/Butcher/Monadic/Pretty.hs | 64 ++++++++++++++++++-------------- src/UI/Butcher/Monadic/Types.hs | 6 +++ 4 files changed, 57 insertions(+), 31 deletions(-) diff --git a/src/UI/Butcher/Monadic/Core.hs b/src/UI/Butcher/Monadic/Core.hs index 5bece5a..67c0361 100644 --- a/src/UI/Butcher/Monadic/Core.hs +++ b/src/UI/Butcher/Monadic/Core.hs @@ -876,6 +876,7 @@ cmdRunParserAExt mTopLevel inputInitial cmdParser PartAlts alts -> f $ head alts -- this is not optimal, but probably -- does not matter. PartDefault _ d -> f d + PartSuggestion _ d -> f d PartRedirect s _ -> s PartMany ds -> f ds PartWithHelp _ d -> f d diff --git a/src/UI/Butcher/Monadic/Param.hs b/src/UI/Butcher/Monadic/Param.hs index 241abd3..101127b 100644 --- a/src/UI/Butcher/Monadic/Param.hs +++ b/src/UI/Butcher/Monadic/Param.hs @@ -3,10 +3,12 @@ module UI.Butcher.Monadic.Param , paramHelp , paramHelpStr , paramDefault + , paramSuggestions , addReadParam , addReadParamOpt , addStringParam , addStringParamOpt + , addRestOfInputStringParam ) where @@ -29,11 +31,17 @@ import UI.Butcher.Monadic.Core data Param p = Param { _param_default :: Maybe p , _param_help :: Maybe PP.Doc + , _param_suggestions :: Maybe [p] } instance Monoid (Param p) where - mempty = Param Nothing Nothing - Param a1 b1 `mappend` Param a2 b2 = Param (a1 `f` a2) (b1 `mappend` b2) + mempty = Param Nothing Nothing Nothing + mappend (Param a1 b1 c1) + (Param a2 b2 c2) + = Param + (a1 `f` a2) + (b1 `mappend` b2) + (c1 `mappend` c2) where f Nothing x = x f x _ = x @@ -47,6 +55,9 @@ paramHelp h = mempty { _param_help = Just h } paramDefault :: p -> Param p paramDefault d = mempty { _param_default = Just d } +paramSuggestions :: [p] -> Param p +paramSuggestions ss = mempty { _param_suggestions = Just ss } + addReadParam :: forall f out a . (Applicative f, Typeable a, Show a, Text.Read.Read a) => String @@ -89,7 +100,7 @@ addStringParam addStringParam name par = addCmdPartInp desc parseF where desc :: PartDesc - desc = PartOptional + desc = addSuggestion (_param_suggestions par) $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name parseF :: Input -> Maybe (String, Input) diff --git a/src/UI/Butcher/Monadic/Pretty.hs b/src/UI/Butcher/Monadic/Pretty.hs index cc35361..6da7c16 100644 --- a/src/UI/Butcher/Monadic/Pretty.hs +++ b/src/UI/Butcher/Monadic/Pretty.hs @@ -107,6 +107,7 @@ ppHelpShallow desc@(CommandDesc mParent syn help parts _out _children) = PartAlts ps -> ps >>= go PartSeq ps -> ps >>= go PartDefault _ p -> go p + PartSuggestion _ p -> go p PartRedirect s p -> [PP.text s $$ PP.nest 20 (ppPartDescUsage p)] ++ (PP.nest 2 <$> go p) PartReorder ps -> ps >>= go @@ -116,34 +117,41 @@ ppHelpShallow desc@(CommandDesc mParent syn help parts _out _children) = ppPartDescUsage :: PartDesc -> PP.Doc ppPartDescUsage = \case - PartLiteral s -> PP.text s - PartVariable s -> PP.text s - PartOptional p -> PP.brackets $ rec p - PartAlts ps -> PP.fcat $ PP.punctuate (PP.text ",") $ rec <$> ps - PartSeq ps -> PP.fsep $ rec <$> ps - PartDefault _ p -> PP.brackets $ rec p - PartRedirect s _ -> PP.text s - PartMany p -> rec p <> PP.text "+" - PartWithHelp _ p -> rec p - PartReorder ps -> - let flags = [d | PartMany d <- ps] - params = filter (\case PartMany{} -> False; _ -> True) ps - in PP.brackets (PP.fsep $ rec <$> flags) - <+> PP.fsep (rec <$> params) - where - rec = ppPartDescUsage + PartLiteral s -> PP.text s + PartVariable s -> PP.text s + PartOptional p -> PP.brackets $ rec p + PartAlts ps -> PP.fcat $ PP.punctuate (PP.text ",") $ rec <$> ps + PartSeq ps -> PP.fsep $ rec <$> ps + PartDefault _ p -> PP.brackets $ rec p + PartSuggestion s p -> + PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ fmap PP.text s ++ [rec p] + PartRedirect s _ -> PP.text s + PartMany p -> rec p <> PP.text "+" + PartWithHelp _ p -> rec p + PartReorder ps -> + let flags = [ d | PartMany d <- ps ] + params = filter ( \case + PartMany{} -> False + _ -> True + ) + ps + in PP.brackets (PP.fsep $ rec <$> flags) <+> PP.fsep (rec <$> params) + where + rec = ppPartDescUsage 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 - PartRedirect s _ -> PP.text s - PartMany ds -> rec ds - PartWithHelp _ d -> rec d - PartSeq ds -> PP.hsep $ rec <$> ds - PartReorder ds -> PP.vcat $ rec <$> ds - where - rec = ppPartDescHeader + PartLiteral s -> PP.text s + PartVariable s -> PP.text s + PartOptional ds' -> rec ds' + PartAlts alts -> PP.hcat $ List.intersperse (PP.text ",") $ rec <$> alts + PartDefault _ d -> rec d + PartSuggestion _ d -> rec d + PartRedirect s _ -> PP.text s + PartMany ds -> rec ds + PartWithHelp _ d -> rec d + PartSeq ds -> PP.hsep $ rec <$> ds + PartReorder ds -> PP.vcat $ rec <$> ds + where + rec = ppPartDescHeader + diff --git a/src/UI/Butcher/Monadic/Types.hs b/src/UI/Butcher/Monadic/Types.hs index 41bee93..7833f70 100644 --- a/src/UI/Butcher/Monadic/Types.hs +++ b/src/UI/Butcher/Monadic/Types.hs @@ -22,6 +22,7 @@ module UI.Butcher.Monadic.Types , PartDesc(..) , Input (..) , ParsingError (..) + , addSuggestion ) where @@ -109,6 +110,7 @@ data PartDesc | PartSeq [PartDesc] | PartDefault String -- default representation PartDesc + | PartSuggestion [String] PartDesc | PartRedirect String -- name for the redirection PartDesc | PartReorder [PartDesc] @@ -116,6 +118,10 @@ data PartDesc | PartWithHelp PP.Doc PartDesc deriving Show +addSuggestion :: Maybe [String] -> PartDesc -> PartDesc +addSuggestion Nothing = id +addSuggestion (Just sugs) = PartSuggestion sugs + {- command documentation structure 1. terminals. e.g. "--dry-run"