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

Add addAlternatives, Add/Expose varPartDesc

pull/5/head
Lennart Spitzner 2018-04-17 18:11:41 +02:00
parent 2e245432a5
commit 7d56c9ae1d
3 changed files with 79 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/UI/Butcher/Monadic/Command.hs
View File

@ -73,7 +73,9 @@ module UI.Butcher.Monadic.Command
, addCmdPartMany
, addCmdPartInp
, addCmdPartManyInp
, addAlternatives
, ManyUpperBound (..)
, varPartDesc
)
where

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

@ -23,6 +23,7 @@ module UI.Butcher.Monadic.Internal.Core
, addCmdHidden
, addNullCmd
, addCmdImpl
, addAlternatives
, reorderStart
, reorderStop
, checkCmdParser
@ -31,6 +32,7 @@ module UI.Butcher.Monadic.Internal.Core
, runCmdParserA
, runCmdParserAExt
, mapOut
, varPartDesc
)
where
@ -236,6 +238,25 @@ addCmdHidden
addCmdHidden str sub =
liftF $ CmdParserChild (Just str) Hidden sub (pure ()) ()
-- | Add a list of sub-parsers one of which will be selected and used based
-- on the provided predicate function. The input elements consist of:
-- a) a name used for the command description of the output,
-- b) a predicate function; the first True predicate determines which element
-- to apply
-- c) a CmdParser.
addAlternatives
:: Typeable p
=> [(String, String -> Bool, CmdParser f out p)]
-> CmdParser f out p
addAlternatives elems = liftF $ CmdParserAlternatives desc alts id
where
desc = PartAlts $ [PartVariable s | (s, _, _) <- elems]
alts = [(a, b) | (_, a, b) <- elems]
-- | Create a simple PartDesc from a string.
varPartDesc :: String -> PartDesc
varPartDesc = PartVariable
-- | 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
@ -334,13 +355,13 @@ checkCmdParser mTopLevel cmdParser =
<$ desc { _cmd_parts = Data.Foldable.toList descs }
StackLayer _ _ _ -> Left "unclosed ReorderStart or GroupStart"
processMain
:: CmdParser f out ()
:: CmdParser f out a
-> MultiRWSS.MultiRWST
'[]
'[]
'[CommandDesc out, CmdDescStack]
(Either String)
()
a
processMain = \case
Pure x -> return x
Free (CmdParserHelp h next) -> do
@ -428,6 +449,21 @@ checkCmdParser mTopLevel cmdParser =
stackCur <- mGet
mSet $ StackLayer mempty "" stackCur
processMain next
Free (CmdParserAlternatives desc alts nextF) -> do
mModify (descStackAdd desc)
states <- MultiRWSS.mGetRawS
let go
:: [(String -> Bool, CmdParser f out p)]
-> MultiRWSS.MultiRWST
'[] '[] '[CommandDesc out, CmdDescStack] (Either String) p
go [] = lift $ Left $ "Empty alternatives"
go [(_, alt)] = processMain alt
go ((_, alt1):altr) = do
case MultiRWSS.runMultiRWSTNil $ MultiRWSS.withMultiStates states (processMain alt1) of
Left{} -> go altr
Right (p, states') -> MultiRWSS.mPutRawS states' $> p
p <- go alts
processMain $ nextF p
monadMisuseError :: a
monadMisuseError =
@ -530,7 +566,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
res =
if null errs' then Right cmd' else Left $ ParsingError errs' inputRest
processMain
:: CmdParser f out ()
:: -- forall a
CmdParser f out ()
-> MultiRWSS.MultiRWS
'[]
'[[String]]
@ -540,7 +577,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
()]
(f ())
processMain = \case
Pure () -> return $ pure $ ()
Pure () -> return $ pure ()
Free (CmdParserHelp h next) -> do
cmd :: CommandDesc out <- mGet
mSet $ cmd { _cmd_help = Just h }
@ -551,7 +588,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
$ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s }
processMain next
Free (CmdParserPeekDesc nextF) -> do
parser <- mGet
parser :: CmdParser f out () <- mGet
-- partialDesc :: CommandDesc out <- mGet
-- partialStack :: CmdDescStack <- mGet
-- run the rest without affecting the actual stack
@ -813,6 +850,18 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
actRest <- processMain fr
return $ acts *> actRest
else monadMisuseError
Free (CmdParserAlternatives desc alts nextF) -> do
input :: Input <- mGet
case input of
InputString str
| Just (_, sub) <- find (\(predicate, _sub) -> predicate str) alts ->
processMain $ sub >>= nextF
InputArgs (str:_)
| Just (_, sub) <- find (\(predicate, _sub) -> predicate str) alts ->
processMain $ sub >>= nextF
_ -> do
mTell ["could not parse any of " ++ getPartSeqDescPositionName desc]
processMain $ nextF monadMisuseError
reorderPartGather
:: ( MonadMultiState Int m
@ -854,6 +903,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
CmdParserReorderStart{} -> restCase
CmdParserGrouped{} -> restCase
CmdParserGroupEnd{} -> restCase
CmdParserAlternatives{} -> restCase
where
restCase = do
mTell ["Did not find expected ReorderStop after the reordered parts"]
@ -873,7 +923,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
Free (CmdParserPeekInput nextF) -> do
childrenGather $ nextF $ inputToString inputInitial
Free (CmdParserPeekDesc nextF) -> do
parser <- mGet
parser :: CmdParser f out () <- mGet
-- partialDesc :: CommandDesc out <- mGet
-- partialStack :: CmdDescStack <- mGet
-- run the rest without affecting the actual stack
@ -1010,8 +1060,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
-- user needs to use check for that purpose instead.
processCmdShallow
:: (MonadMultiState (CommandDesc out) m, MonadMultiState CmdDescStack m)
=> CmdParserF f out (m ())
-> m ()
=> CmdParserF f out (m a)
-> m a
processCmdShallow = \case
CmdParserHelp h next -> do
cmd :: CommandDesc out <- mGet
@ -1062,10 +1112,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
CmdParserGroupEnd next -> do
stackCur <- mGet
case stackCur of
StackBottom{} -> do
return ()
StackLayer _descs "" _up -> do
return ()
StackBottom{} -> pure ()
StackLayer _descs "" _up -> pure ()
StackLayer descs groupName up -> do
mSet $ descStackAdd
(PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))
@ -1083,6 +1131,10 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
stackCur <- mGet
mSet $ StackLayer mempty "" stackCur
next
CmdParserAlternatives _ [] _ -> error "empty alternatives"
CmdParserAlternatives desc ((_, alt):_) nextF -> do
mModify (descStackAdd desc)
nextF =<< iterM processCmdShallow alt
failureCurrentShallowRerun
:: ( m ~ MultiRWSS.MultiRWST r w s m0
@ -1093,7 +1145,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
)
=> m ()
failureCurrentShallowRerun = do
parser <- mGet
parser :: CmdParser f out () <- mGet
cmd :: CommandDesc out <-
MultiRWSS.withMultiStateS emptyCommandDesc
$ iterM processCmdShallow parser
@ -1161,7 +1213,7 @@ takeCommandChild key = do
return r
-- | map over the @out@ type argument
mapOut :: (outa -> outb) -> CmdParser f outa () -> CmdParser f outb ()
mapOut :: (outa -> outb) -> CmdParser f outa a -> CmdParser f outb a
mapOut f = hoistFree $ \case
CmdParserHelp doc r -> CmdParserHelp doc r
CmdParserSynopsis s r -> CmdParserSynopsis s r
@ -1180,6 +1232,10 @@ mapOut f = hoistFree $ \case
CmdParserReorderStop r -> CmdParserReorderStop r
CmdParserGrouped s r -> CmdParserGrouped s r
CmdParserGroupEnd r -> CmdParserGroupEnd r
CmdParserAlternatives desc alts r -> CmdParserAlternatives
desc
[ (predicate, mapOut f sub) | (predicate, sub) <- alts ]
r
-- cmdActionPartial :: CommandDesc out -> Either String out
-- cmdActionPartial = maybe (Left err) Right . _cmd_out

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

@ -80,6 +80,7 @@ data CmdParserF f out a
| CmdParserReorderStop a
| CmdParserGrouped String a
| CmdParserGroupEnd a
| forall p . Typeable p => CmdParserAlternatives PartDesc [((String -> Bool), CmdParser f out p)] (p -> a)
-- | The CmdParser monad type. It is a free monad over some functor but users
-- of butcher don't need to know more than that 'CmdParser' is a 'Monad'.