hexagoxel
/
butcher
1
0
Fork 0
Code Issues 2 Pull Requests Packages Projects Releases Wiki Activity

Support hiding flags

pull/5/head
Lennart Spitzner 2018-01-10 22:39:40 +01:00
parent 92a7339590
commit e1c38e430f
3 changed files with 52 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
src/UI/Butcher/Monadic/Flag.hs
View File

@ -15,6 +15,7 @@ module UI.Butcher.Monadic.Flag
, flagHelp
, flagHelpStr
, flagDefault
, flagHidden
, addSimpleBoolFlag
, addSimpleCountFlag
, addSimpleFlagA
@ -74,13 +75,19 @@ pOption m = m <|> return ()
-- | flag-description monoid. You probably won't need to use the constructor;
-- mzero or any (<>) of flag(Help|Default) works well.
data Flag p = Flag
{ _flag_help :: Maybe PP.Doc
, _flag_default :: Maybe p
{ _flag_help :: Maybe PP.Doc
, _flag_default :: Maybe p
, _flag_visibility :: Visibility
}
instance Monoid (Flag p) where
mempty = Flag Nothing Nothing
Flag a1 b1 `mappend` Flag a2 b2 = Flag (a1 <|> a2) (b1 <|> b2)
mempty = Flag Nothing Nothing Visible
Flag a1 b1 c1 `mappend` Flag a2 b2 c2 = Flag (a1 <|> a2)
(b1 <|> b2)
(appVis c1 c2)
where
appVis Visible Visible = Visible
appVis _ _ = Hidden
-- | Create a 'Flag' with just a help text.
flagHelp :: PP.Doc -> Flag p
@ -94,6 +101,18 @@ flagHelpStr s = mempty { _flag_help = Just $ PP.text s }
flagDefault :: p -> Flag p
flagDefault d = mempty { _flag_default = Just d }
-- | Create a 'Flag' marked as hidden. Similar to hidden commands, hidden
-- flags will not included in pretty-printing (help, usage etc.)
--
-- This feature is not well tested yet.
flagHidden :: Flag p
flagHidden = mempty { _flag_visibility = Hidden }
wrapHidden :: Flag p -> PartDesc -> PartDesc
wrapHidden f = case _flag_visibility f of
Visible -> id
Hidden -> PartHidden
-- | A no-parameter flag where non-occurence means False, occurence means True.
addSimpleBoolFlag
:: Applicative f
@ -121,7 +140,7 @@ addSimpleBoolFlagAll
-> f ()
-> CmdParser f out Bool
addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
$ addCmdPartManyA ManyUpperBound1 desc parseF (\() -> a)
$ addCmdPartManyA ManyUpperBound1 (wrapHidden flag desc) parseF (\() -> a)
where
allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs
desc :: PartDesc
@ -148,7 +167,7 @@ addSimpleCountFlag :: Applicative f
-> Flag Void -- ^ properties
-> CmdParser f out Int
addSimpleCountFlag shorts longs flag = fmap length
$ addCmdPartMany ManyUpperBoundN desc parseF
$ addCmdPartMany ManyUpperBoundN (wrapHidden flag desc) parseF
where
-- we _could_ allow this to parse repeated short flags, like "-vvv"
-- (meaning "-v -v -v") correctly.
@ -179,7 +198,7 @@ addFlagReadParam
-> Flag p -- ^ properties
-> CmdParser f out p
addFlagReadParam shorts longs name flag =
addCmdPartInpA desc parseF (\_ -> pure ())
addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())
where
allStrs =
[ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
@ -261,7 +280,7 @@ addFlagReadParamsAll
-> CmdParser f out [p]
addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA
ManyUpperBoundN
desc
(wrapHidden flag desc)
parseF
act
where
@ -310,9 +329,8 @@ addFlagStringParam
-> String -- ^ param name
-> Flag String -- ^ properties
-> CmdParser f out String
addFlagStringParam shorts longs name flag = addCmdPartInpA desc
parseF
(\_ -> pure ())
addFlagStringParam shorts longs name flag =
addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())
where
allStrs =
[ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
@ -389,7 +407,7 @@ addFlagStringParamsAll
-> CmdParser f out [String]
addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA
ManyUpperBoundN
desc
(wrapHidden flag desc)
parseF
act
where

38
src/UI/Butcher/Monadic/Internal/Core.hs
View File

@ -221,25 +221,27 @@ addCmd
=> String -- ^ command name
-> CmdParser f out () -- ^ subcommand
-> CmdParser f out ()
addCmd str sub = liftF $ CmdParserChild (Just str) sub (pure ()) Visible ()
addCmd str sub = liftF $ CmdParserChild (Just str) Visible sub (pure ()) ()
-- | Add a new child command in the current context, but make it hidden. It
-- will not appear in docs/help generated by e.g. the functions in the
-- @Pretty@ module.
--
-- This feature is not well tested yet.
addCmdHidden
:: Applicative f
=> String -- ^ command name
-> CmdParser f out () -- ^ subcommand
-> CmdParser f out ()
addCmdHidden str sub =
liftF $ CmdParserChild (Just str) sub (pure ()) Hidden ()
liftF $ CmdParserChild (Just str) Hidden sub (pure ()) ()
-- | Add a new nameless child command in the current context. Nameless means
-- that this command matches the empty input, i.e. will always apply.
-- This feature is experimental and CommandDesc pretty-printing might not
-- correctly in presense of nullCmds.
addNullCmd :: Applicative f => CmdParser f out () -> CmdParser f out ()
addNullCmd sub = liftF $ CmdParserChild Nothing sub (pure ()) Hidden ()
addNullCmd sub = liftF $ CmdParserChild Nothing Hidden sub (pure ()) ()
-- | Add an implementation to the current command.
addCmdImpl :: out -> CmdParser f out ()
@ -289,7 +291,7 @@ data PartGatherData f
}
data ChildGather f out =
ChildGather (Maybe String) (CmdParser f out ()) (f ()) Visibility
ChildGather (Maybe String) Visibility (CmdParser f out ()) (f ())
type PartParsedData = Map Int [Dynamic]
@ -373,7 +375,7 @@ checkCmdParser mTopLevel cmdParser =
descStack <- mGet
mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
processMain $ nextF monadMisuseError
Free (CmdParserChild cmdStr sub _act vis next) -> do
Free (CmdParserChild cmdStr vis sub _act next) -> do
mInitialDesc <- takeCommandChild cmdStr
cmd :: CommandDesc out <- mGet
subCmd <- do
@ -651,21 +653,21 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
let
child_fold
:: ( Deque (Maybe String)
, Map (Maybe String) (CmdParser f out (), f (), Visibility)
, Map (Maybe String) (Visibility, CmdParser f out (), f ())
)
-> ChildGather f out
-> ( Deque (Maybe String)
, Map (Maybe String) (CmdParser f out (), f (), Visibility)
, Map (Maybe String) (Visibility, CmdParser f out (), f ())
)
child_fold (c_names, c_map) (ChildGather name child act vis) =
child_fold (c_names, c_map) (ChildGather name vis child act) =
case name `MapS.lookup` c_map of
Nothing ->
( Deque.snoc name c_names
, MapS.insert name (child, act, vis) c_map
, MapS.insert name (vis, child, act) c_map
)
Just (child', act', vis') ->
Just (vis', child', act') ->
( c_names
, MapS.insert name (child' >> child, act', vis') c_map
, MapS.insert name (vis', child' >> child, act') c_map
-- we intentionally override/ignore act here.
-- TODO: it should be documented that we expect the same act
-- on different child nodes with the same name.
@ -695,7 +697,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
Nothing -> do -- a child not matching what we have in the input
let initialDesc :: CommandDesc out = emptyCommandDesc
-- get the shallow desc for the child in a separate env.
combined_child_list `forM_` \(child_name, (child, _, vis)) -> do
combined_child_list `forM_` \(child_name, (vis, child, _)) -> do
let (subCmd, subStack) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
@ -708,7 +710,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
)
-- proceed regularly on the same layer
processMain $ restCmdParser
Just (name, child, act, vis, rest) -> do -- matching child -> descend
Just (name, vis, child, act, rest) -> do -- matching child -> descend
-- process all remaining stuff on the same layer shallowly,
-- including the current node. This will be replaced later.
iterM processCmdShallow f
@ -863,8 +865,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
=> CmdParser f out a
-> m (CmdParser f out a)
childrenGather = \case
Free (CmdParserChild cmdStr sub act vis next) -> do
mTell [ChildGather cmdStr sub act vis]
Free (CmdParserChild cmdStr vis sub act next) -> do
mTell [ChildGather cmdStr vis sub act]
childrenGather next
Free (CmdParserPeekInput nextF) -> do
childrenGather $ nextF $ inputToString inputInitial
@ -1041,7 +1043,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
stackCur <- mGet
mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
nextF monadMisuseError
CmdParserChild cmdStr _sub _act vis next -> do
CmdParserChild cmdStr vis _sub _act next -> do
mExisting <- takeCommandChild cmdStr
let childDesc :: CommandDesc out =
fromMaybe emptyCommandDesc { _cmd_visibility = vis } mExisting
@ -1168,8 +1170,8 @@ mapOut f = hoistFree $ \case
CmdParserPartInp desc fp fa fr -> CmdParserPartInp desc fp fa fr
CmdParserPartManyInp bound desc fp fa fr ->
CmdParserPartManyInp bound desc fp fa fr
CmdParserChild s child act vis r ->
CmdParserChild s (mapOut f child) act vis r
CmdParserChild s vis child act r ->
CmdParserChild s vis (mapOut f child) act r
CmdParserImpl out r -> CmdParserImpl (f out) r
CmdParserReorderStart r -> CmdParserReorderStart r
CmdParserReorderStop r -> CmdParserReorderStop r

7
src/UI/Butcher/Monadic/Internal/Types.hs
View File

@ -73,7 +73,7 @@ data CmdParserF f out a
| forall p . Typeable p => CmdParserPartMany ManyUpperBound PartDesc (String -> Maybe (p, String)) (p -> f ()) ([p] -> a)
| forall p . Typeable p => CmdParserPartInp PartDesc (Input -> Maybe (p, Input)) (p -> f ()) (p -> a)
| forall p . Typeable p => CmdParserPartManyInp ManyUpperBound PartDesc (Input -> Maybe (p, Input)) (p -> f ()) ([p] -> a)
| CmdParserChild (Maybe String) (CmdParser f out ()) (f ()) Visibility a
| CmdParserChild (Maybe String) Visibility (CmdParser f out ()) (f ()) a
| CmdParserImpl out a
| CmdParserReorderStart a
| CmdParserReorderStop a
@ -146,10 +146,7 @@ data PartDesc
| PartReorder [PartDesc]
| PartMany PartDesc
| PartWithHelp PP.Doc PartDesc
| PartHidden PartDesc -- ^ This constructor is currently unused and
-- thus completely untested, even though some
-- of the functions from @Pretty@ module are
-- implemented already.
| PartHidden PartDesc
deriving Show
addSuggestion :: Maybe [String] -> PartDesc -> PartDesc