Add 'suggestion' functionality

i.e. possible additional input that could make the input valid
(or at least less invalid).
pull/5/head
Lennart Spitzner 2016-12-30 22:05:52 +01:00
parent a3ff58c682
commit b11663d910
4 changed files with 57 additions and 31 deletions

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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"