Add 'suggestion' functionality
i.e. possible additional input that could make the input valid (or at least less invalid).pull/5/head
parent
a3ff58c682
commit
b11663d910
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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"
|
||||
|
|
Loading…
Reference in New Issue