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

Implement mapOut, peekInput, cmd child merging

pull/5/head
Lennart Spitzner 2017-05-16 12:22:28 +02:00
parent b15f1ae585
commit c1cbc77e5b
9 changed files with 295 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
butcher.cabal
View File

@ -49,6 +49,7 @@ library
, nats , nats
, void , void
, bifunctors , bifunctors
, deque
} }
if flag(butcher-dev) { if flag(butcher-dev) {
build-depends: build-depends:
@ -110,6 +111,7 @@ test-suite tests
, transformers , transformers
, mtl , mtl
, extra , extra
, deque
} }
if flag(butcher-dev) { if flag(butcher-dev) {
buildable: True buildable: True

45
src-tests/TestMain.hs
View File

@ -69,6 +69,33 @@ simpleRunTest = do
it "flag 3" $ testRunA testCmd3 "abc -g" `shouldBe` Right 2 it "flag 3" $ testRunA testCmd3 "abc -g" `shouldBe` Right 2
it "flag 4" $ testRunA testCmd3 "abc -f -g" `shouldBe` Right 3 it "flag 4" $ testRunA testCmd3 "abc -f -g" `shouldBe` Right 3
it "flag 5" $ testRunA testCmd3 "abc -g -f" `shouldBe` Right 3 it "flag 5" $ testRunA testCmd3 "abc -g -f" `shouldBe` Right 3
describe "separated children" $ do
it "case 1" $ testRun testCmd4 "a aa" `shouldBe` Right (Just 1)
it "case 2" $ testRun testCmd4 "a ab" `shouldBe` Right (Just 2)
it "case 3" $ testRun testCmd4 "b ba" `shouldBe` Right (Just 3)
it "case 4" $ testRun testCmd4 "b bb" `shouldBe` Right (Just 4)
it "doc" $ show (ppHelpShallow (getDoc "" testCmd4)) `shouldBe`
List.unlines
[ "NAME"
, ""
, " test"
, ""
, "USAGE"
, ""
, " test a | b"
]
it "doc" $ show (ppHelpShallow (getDoc "a" testCmd4)) `shouldBe`
List.unlines
[ "NAME"
, ""
, " test a"
, ""
, "USAGE"
, ""
, " test a aa | ab"
]
testCmd1 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () testCmd1 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
@ -110,6 +137,21 @@ testCmd3 = do
addCmd "def" $ do addCmd "def" $ do
addCmdImpl () addCmdImpl ()
testCmd4 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
testCmd4 = do
addCmd "a" $ do
addCmd "aa" $ do
addCmdImpl $ WriterS.tell 1
addCmd "b" $ do
addCmd "bb" $ do
addCmdImpl $ WriterS.tell 4
addCmd "a" $ do
addCmd "ab" $ do
addCmdImpl $ WriterS.tell 2
addCmd "b" $ do
addCmd "ba" $ do
addCmdImpl $ WriterS.tell 3
testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out) testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out)
testParse cmd s = either (const Nothing) Just testParse cmd s = either (const Nothing) Just
$ snd $ snd
@ -124,3 +166,6 @@ testRunA :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError
testRunA cmd str = (\((_, e), s) -> e $> s) testRunA cmd str = (\((_, e), s) -> e $> s)
$ flip StateS.runState (0::Int) $ flip StateS.runState (0::Int)
$ runCmdParserA Nothing (InputString str) cmd $ runCmdParserA Nothing (InputString str) cmd
getDoc :: String -> CmdParser Identity out () -> CommandDesc ()
getDoc s = fst . runCmdParser (Just "test") (InputString s)

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

@ -28,6 +28,7 @@ module UI.Butcher.Monadic
-- * Builtin commands -- * Builtin commands
, addHelpCommand , addHelpCommand
, addButcherDebugCommand , addButcherDebugCommand
, mapOut
) )
where where

9
src/UI/Butcher/Monadic/BuiltinCommands.hs
View File

@ -34,12 +34,13 @@ addHelpCommand desc = addCmd "help" $ do
rest <- addRestOfInputStringParam "SUBCOMMAND(s)" mempty rest <- addRestOfInputStringParam "SUBCOMMAND(s)" mempty
addCmdImpl $ do addCmdImpl $ do
let parentDesc = maybe undefined snd (_cmd_mParent desc) let parentDesc = maybe undefined snd (_cmd_mParent desc)
let restWords = List.words rest let restWords = List.words rest
let descent :: [String] -> CommandDesc a -> CommandDesc a let descent :: [String] -> CommandDesc a -> CommandDesc a
descent [] curDesc = curDesc descent [] curDesc = curDesc
descent (w:wr) curDesc = case List.lookup w $ _cmd_children curDesc of descent (w:wr) curDesc =
Nothing -> curDesc case List.lookup w $ Data.Foldable.toList $ _cmd_children curDesc of
Just child -> descent wr child Nothing -> curDesc
Just child -> descent wr child
print $ ppHelpShallow $ descent restWords parentDesc print $ ppHelpShallow $ descent restWords parentDesc
-- | Adds a help command that prints help for the command currently in context. -- | Adds a help command that prints help for the command currently in context.

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

@ -60,10 +60,16 @@ module UI.Butcher.Monadic.Command
, reorderStart , reorderStart
, reorderStop , reorderStop
, peekCmdDesc , peekCmdDesc
, peekInput
-- * Building CmdParsers - myprog -v --input PATH -- * Building CmdParsers - myprog -v --input PATH
, module UI.Butcher.Monadic.Flag , module UI.Butcher.Monadic.Flag
-- * Building CmdParsers - myprog SOME_INT -- * Building CmdParsers - myprog SOME_INT
, module UI.Butcher.Monadic.Param , module UI.Butcher.Monadic.Param
-- * Low-level part functions
, addCmdPart
, addCmdPartMany
, addCmdPartInp
, addCmdPartManyInp
) )
where where

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

@ -11,6 +11,7 @@ module UI.Butcher.Monadic.Internal.Core
, addCmdHelp , addCmdHelp
, addCmdHelpStr , addCmdHelpStr
, peekCmdDesc , peekCmdDesc
, peekInput
, addCmdPart , addCmdPart
, addCmdPartA , addCmdPartA
, addCmdPartMany , addCmdPartMany
@ -28,6 +29,7 @@ module UI.Butcher.Monadic.Internal.Core
, runCmdParserExt , runCmdParserExt
, runCmdParserA , runCmdParserA
, runCmdParserAExt , runCmdParserAExt
, mapOut
) )
where where
@ -114,9 +116,12 @@ addCmdHelpStr s = liftF $ CmdParserHelp (PP.text s) ()
-- For best results, use this "below" -- For best results, use this "below"
-- any 'addCmd' invocations in the current context, e.g. directly before -- any 'addCmd' invocations in the current context, e.g. directly before
-- the 'addCmdImpl' invocation. -- the 'addCmdImpl' invocation.
peekCmdDesc :: CmdParser f out (CommandDesc out) peekCmdDesc :: CmdParser f out (CommandDesc ())
peekCmdDesc = liftF $ CmdParserPeekDesc id peekCmdDesc = liftF $ CmdParserPeekDesc id
peekInput :: CmdParser f out String
peekInput = liftF $ CmdParserPeekInput id
addCmdPart addCmdPart
:: (Applicative f, Typeable p) :: (Applicative f, Typeable p)
=> PartDesc => PartDesc
@ -236,15 +241,17 @@ data PartGatherData f
, _pgd_many :: Bool , _pgd_many :: Bool
} }
data ChildGather f out = ChildGather String (CmdParser f out ()) (f ())
type PartParsedData = Map Int [Dynamic] type PartParsedData = Map Int [Dynamic]
data CmdDescStack = StackBottom [PartDesc] data CmdDescStack = StackBottom (Deque PartDesc)
| StackLayer [PartDesc] String CmdDescStack | StackLayer (Deque PartDesc) String CmdDescStack
descStackAdd :: PartDesc -> CmdDescStack -> CmdDescStack descStackAdd :: PartDesc -> CmdDescStack -> CmdDescStack
descStackAdd d = \case descStackAdd d = \case
StackBottom l -> StackBottom $ d:l StackBottom l -> StackBottom $ Deque.snoc d l
StackLayer l s u -> StackLayer (d:l) s u StackLayer l s u -> StackLayer (Deque.snoc d l) s u
-- | Because butcher is evil (i.e. has constraints not encoded in the types; -- | Because butcher is evil (i.e. has constraints not encoded in the types;
@ -262,7 +269,7 @@ checkCmdParser :: forall f out
checkCmdParser mTopLevel cmdParser checkCmdParser mTopLevel cmdParser
= (>>= final) = (>>= final)
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateAS (StackBottom []) $ MultiRWSS.withMultiStateAS (StackBottom mempty)
$ MultiRWSS.withMultiStateS emptyCommandDesc $ MultiRWSS.withMultiStateS emptyCommandDesc
$ processMain cmdParser $ processMain cmdParser
where where
@ -273,8 +280,7 @@ checkCmdParser mTopLevel cmdParser
StackBottom descs -> Right StackBottom descs -> Right
$ descFixParentsWithTopM (mTopLevel <&> \n -> (n, emptyCommandDesc)) $ descFixParentsWithTopM (mTopLevel <&> \n -> (n, emptyCommandDesc))
$ () <$ desc $ () <$ desc
{ _cmd_parts = reverse descs { _cmd_parts = Data.Foldable.toList descs
, _cmd_children = reverse $ _cmd_children desc
} }
StackLayer _ _ _ -> Left "unclosed ReorderStart or GroupStart" StackLayer _ _ _ -> Left "unclosed ReorderStart or GroupStart"
processMain :: CmdParser f out () processMain :: CmdParser f out ()
@ -291,6 +297,8 @@ checkCmdParser mTopLevel cmdParser
processMain next processMain next
Free (CmdParserPeekDesc nextF) -> do Free (CmdParserPeekDesc nextF) -> do
processMain $ nextF monadMisuseError processMain $ nextF monadMisuseError
Free (CmdParserPeekInput nextF) -> do
processMain $ nextF monadMisuseError
Free (CmdParserPart desc _parseF _act nextF) -> do Free (CmdParserPart desc _parseF _act nextF) -> do
do do
descStack <- mGet descStack <- mGet
@ -312,25 +320,23 @@ checkCmdParser mTopLevel cmdParser
mSet $ descStackAdd (wrapBoundDesc bound desc) descStack mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
processMain $ nextF monadMisuseError processMain $ nextF monadMisuseError
Free (CmdParserChild cmdStr sub _act next) -> do Free (CmdParserChild cmdStr sub _act next) -> do
mInitialDesc <- takeCommandChild cmdStr
cmd :: CommandDesc out <- mGet cmd :: CommandDesc out <- mGet
subCmd <- do subCmd <- do
stackCur :: CmdDescStack <- mGet stackCur :: CmdDescStack <- mGet
mSet (emptyCommandDesc :: CommandDesc out) mSet $ fromMaybe (emptyCommandDesc :: CommandDesc out) mInitialDesc
mSet $ StackBottom [] mSet $ StackBottom mempty
processMain sub processMain sub
c <- mGet c <- mGet
stackBelow <- mGet stackBelow <- mGet
mSet cmd mSet cmd
mSet stackCur mSet stackCur
subParts <- case stackBelow of subParts <- case stackBelow of
StackBottom descs -> return $ reverse descs StackBottom descs -> return $ Data.Foldable.toList descs
StackLayer _ _ _ -> lift $ Left "unclosed ReorderStart or GroupStart" StackLayer _ _ _ -> lift $ Left "unclosed ReorderStart or GroupStart"
return c return c { _cmd_parts = subParts }
{ _cmd_children = reverse $ _cmd_children c
, _cmd_parts = subParts
}
mSet $ cmd mSet $ cmd
{ _cmd_children = (cmdStr, subCmd) : _cmd_children cmd { _cmd_children = (cmdStr, subCmd) `Deque.snoc` _cmd_children cmd
} }
processMain next processMain next
Free (CmdParserImpl out next) -> do Free (CmdParserImpl out next) -> do
@ -338,7 +344,7 @@ checkCmdParser mTopLevel cmdParser
processMain $ next processMain $ next
Free (CmdParserGrouped groupName next) -> do Free (CmdParserGrouped groupName next) -> do
stackCur <- mGet stackCur <- mGet
mSet $ StackLayer [] groupName stackCur mSet $ StackLayer mempty groupName stackCur
processMain $ next processMain $ next
Free (CmdParserGroupEnd next) -> do Free (CmdParserGroupEnd next) -> do
stackCur <- mGet stackCur <- mGet
@ -348,19 +354,19 @@ checkCmdParser mTopLevel cmdParser
StackLayer _descs "" _up -> do StackLayer _descs "" _up -> do
lift $ Left $ "GroupEnd found, but expected ReorderStop first" lift $ Left $ "GroupEnd found, but expected ReorderStop first"
StackLayer descs groupName up -> do StackLayer descs groupName up -> do
mSet $ descStackAdd (PartRedirect groupName (PartSeq (reverse descs))) up mSet $ descStackAdd (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) up
processMain $ next processMain $ next
Free (CmdParserReorderStop next) -> do Free (CmdParserReorderStop next) -> do
stackCur <- mGet stackCur <- mGet
case stackCur of case stackCur of
StackBottom{} -> lift $ Left $ "ReorderStop without reorderStart" StackBottom{} -> lift $ Left $ "ReorderStop without reorderStart"
StackLayer descs "" up -> do StackLayer descs "" up -> do
mSet $ descStackAdd (PartReorder (reverse descs)) up mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up
StackLayer{} -> lift $ Left $ "Found ReorderStop, but need GroupEnd first" StackLayer{} -> lift $ Left $ "Found ReorderStop, but need GroupEnd first"
processMain next processMain next
Free (CmdParserReorderStart next) -> do Free (CmdParserReorderStart next) -> do
stackCur <- mGet stackCur <- mGet
mSet $ StackLayer [] "" stackCur mSet $ StackLayer mempty "" stackCur
processMain next processMain next
monadMisuseError :: a monadMisuseError :: a
@ -425,7 +431,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
$ (<&> captureFinal) $ (<&> captureFinal)
$ MultiRWSS.withMultiWriterWA $ MultiRWSS.withMultiWriterWA
$ MultiRWSS.withMultiStateA cmdParser $ MultiRWSS.withMultiStateA cmdParser
$ MultiRWSS.withMultiStateSA (StackBottom []) $ MultiRWSS.withMultiStateSA (StackBottom mempty)
$ MultiRWSS.withMultiStateSA inputInitial $ MultiRWSS.withMultiStateSA inputInitial
$ MultiRWSS.withMultiStateSA (PastCommandInput inputInitial) $ MultiRWSS.withMultiStateSA (PastCommandInput inputInitial)
$ MultiRWSS.withMultiStateSA initialCommandDesc $ MultiRWSS.withMultiStateSA initialCommandDesc
@ -480,9 +486,11 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateSA emptyCommandDesc $ MultiRWSS.withMultiStateSA emptyCommandDesc
{ _cmd_mParent = _cmd_mParent cmdCur } -- partialDesc { _cmd_mParent = _cmd_mParent cmdCur } -- partialDesc
$ MultiRWSS.withMultiStateS (StackBottom []) -- partialStack $ MultiRWSS.withMultiStateS (StackBottom mempty) -- partialStack
$ iterM processCmdShallow $ parser $ iterM processCmdShallow $ parser
processMain $ nextF $ postProcessCmd stack cmd processMain $ nextF $ () <$ postProcessCmd stack cmd
Free (CmdParserPeekInput nextF) -> do
processMain $ nextF $ inputToString inputInitial
Free (CmdParserPart desc parseF actF nextF) -> do Free (CmdParserPart desc parseF actF nextF) -> do
do do
descStack <- mGet descStack <- mGet
@ -561,53 +569,81 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
r <- proc r <- proc
let act = traverse actF r let act = traverse actF r
(act *>) <$> processMain (nextF $ r) (act *>) <$> processMain (nextF $ r)
f@(Free (CmdParserChild cmdStr sub act next)) -> do f@(Free (CmdParserChild _ _ _ _)) -> do
dropSpaces dropSpaces
input <- mGet input <- mGet
(gatheredChildren :: [ChildGather f out], restCmdParser) <-
MultiRWSS.withMultiWriterWA $ childrenGather f
let let
mRest = case input of child_fold
InputString str | cmdStr == str -> :: (Deque String, Map String (CmdParser f out (), f ()))
Just $ InputString "" -> ChildGather f out
InputString str | (cmdStr++" ") `isPrefixOf` str -> -> (Deque String, Map String (CmdParser f out (), f ()))
Just $ InputString $ drop (length cmdStr + 1) str child_fold (c_names, c_map) (ChildGather name child act) =
InputArgs (str:strr) | cmdStr == str -> case name `MapS.lookup` c_map of
Just $ InputArgs strr Nothing ->
_ -> Nothing ( Deque.snoc name c_names
, MapS.insert name (child, act) c_map
)
Just (child', act') ->
( c_names
, MapS.insert name (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.
)
(child_name_list, child_map) =
foldl' child_fold (mempty, MapS.empty) gatheredChildren
combined_child_list = Data.Foldable.toList child_name_list <&> \n ->
(n, child_map MapS.! n)
let mRest = asum $ combined_child_list <&> \(name, (child, act)) ->
case input of
InputString str | name == str ->
Just $ (name, child, act, InputString "")
InputString str | (name++" ") `isPrefixOf` str ->
Just $ (name, child, act, InputString $ drop (length name + 1) str)
InputArgs (str:strr) | name == str ->
Just $ (name, child, act, InputArgs strr)
_ -> Nothing
case mRest of case mRest of
Nothing -> do Nothing -> do -- a child not matching what we have in the input
cmd :: CommandDesc out <- mGet let initialDesc :: CommandDesc out = emptyCommandDesc
let (subCmd, subStack) -- get the shallow desc for the child in a separate env.
= runIdentity combined_child_list `forM_` \(child_name, (child, _)) -> do
$ MultiRWSS.runMultiRWSTNil let (subCmd, subStack)
$ MultiRWSS.withMultiStateSA (emptyCommandDesc :: CommandDesc out) = runIdentity
$ MultiRWSS.withMultiStateS (StackBottom []) $ MultiRWSS.runMultiRWSTNil
$ iterM processCmdShallow sub $ MultiRWSS.withMultiStateSA initialDesc
mSet $ cmd $ MultiRWSS.withMultiStateS (StackBottom mempty)
{ _cmd_children = (cmdStr, postProcessCmd subStack subCmd) $ iterM processCmdShallow child
: _cmd_children cmd cmd_children %=+ Deque.snoc (child_name, postProcessCmd subStack subCmd)
} -- proceed regularly on the same layer
processMain next processMain $ restCmdParser
Just rest -> do Just (name, 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 iterM processCmdShallow f
-- so the descend
cmd <- do cmd <- do
c :: CommandDesc out <- mGet c :: CommandDesc out <- mGet
prevStack :: CmdDescStack <- mGet prevStack :: CmdDescStack <- mGet
return $ postProcessCmd prevStack c return $ postProcessCmd prevStack c
mSet $ rest mSet $ rest
mSet $ PastCommandInput rest mSet $ PastCommandInput rest
mSet $ (emptyCommandDesc :: CommandDesc out) mSet $ emptyCommandDesc
{ _cmd_mParent = Just (cmdStr, cmd) { _cmd_mParent = Just (name, cmd)
} }
mSet $ sub mSet $ child
mSet $ StackBottom [] mSet $ StackBottom mempty
subAct <- processMain sub childAct <- processMain child
return $ act *> subAct -- check that descending yielded
return $ act *> childAct
Free (CmdParserImpl out next) -> do Free (CmdParserImpl out next) -> do
cmd_out .=+ Just out cmd_out .=+ Just out
processMain $ next processMain $ next
Free (CmdParserGrouped groupName next) -> do Free (CmdParserGrouped groupName next) -> do
stackCur <- mGet stackCur <- mGet
mSet $ StackLayer [] groupName stackCur mSet $ StackLayer mempty groupName stackCur
processMain $ next processMain $ next
Free (CmdParserGroupEnd next) -> do Free (CmdParserGroupEnd next) -> do
stackCur <- mGet stackCur <- mGet
@ -616,7 +652,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
mTell $ ["butcher interface error: group end without group start"] mTell $ ["butcher interface error: group end without group start"]
return $ pure () -- hard abort should be fine for this case. return $ pure () -- hard abort should be fine for this case.
StackLayer descs groupName up -> do StackLayer descs groupName up -> do
mSet $ descStackAdd (PartRedirect groupName (PartSeq (reverse descs))) up mSet $ descStackAdd (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) up
processMain $ next processMain $ next
Free (CmdParserReorderStop next) -> do Free (CmdParserReorderStop next) -> do
mTell $ ["butcher interface error: reorder stop without reorder start"] mTell $ ["butcher interface error: reorder stop without reorder start"]
@ -627,7 +663,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
$ iterM reorderPartGather $ next $ iterM reorderPartGather $ next
let let
reorderMapInit :: Map Int (PartGatherData f) reorderMapInit :: Map Int (PartGatherData f)
reorderMapInit = Map.fromList $ reorderData <&> \d -> (_pgd_id d, d) reorderMapInit = MapS.fromList $ reorderData <&> \d -> (_pgd_id d, d)
tryParsePartData :: Input -> PartGatherData f -> First (Int, Dynamic, Input, Bool, f ()) tryParsePartData :: Input -> PartGatherData f -> First (Int, Dynamic, Input, Bool, f ())
tryParsePartData input (PartGatherData pid _ pfe act allowMany) = tryParsePartData input (PartGatherData pid _ pfe act allowMany) =
First [ (pid, toDyn r, rest, allowMany, act r) First [ (pid, toDyn r, rest, allowMany, act r)
@ -653,17 +689,17 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
Nothing -> return $ pure () Nothing -> return $ pure ()
Just (pid, x, rest, more, act) -> do Just (pid, x, rest, more, act) -> do
mSet rest mSet rest
mModify $ Map.insertWith (++) pid [x] mModify $ MapS.insertWith (++) pid [x]
when (not more) $ do when (not more) $ do
mSet $ Map.delete pid m mSet $ MapS.delete pid m
actRest <- parseLoop actRest <- parseLoop
return $ act *> actRest return $ act *> actRest
(finalMap, (fr, acts)) <- MultiRWSS.withMultiStateSA (Map.empty :: PartParsedData) (finalMap, (fr, acts)) <- MultiRWSS.withMultiStateSA (MapS.empty :: PartParsedData)
$ MultiRWSS.withMultiStateA reorderMapInit $ MultiRWSS.withMultiStateA reorderMapInit
$ do $ do
acts <- parseLoop -- filling the map acts <- parseLoop -- filling the map
stackCur <- mGet stackCur <- mGet
mSet $ StackLayer [] "" stackCur mSet $ StackLayer mempty "" stackCur
fr <- MultiRWSS.withMultiStateA (1::Int) $ processParsedParts next fr <- MultiRWSS.withMultiStateA (1::Int) $ processParsedParts next
return (fr, acts) return (fr, acts)
-- we check that all data placed in the map has been consumed while -- we check that all data placed in the map has been consumed while
@ -671,7 +707,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
-- there can only be any rest if the collection of parts changed -- there can only be any rest if the collection of parts changed
-- between the reorderPartGather traversal and the processParsedParts -- between the reorderPartGather traversal and the processParsedParts
-- consumption. -- consumption.
if Map.null finalMap if MapS.null finalMap
then do then do
actRest <- processMain fr actRest <- processMain fr
return $ acts *> actRest return $ acts *> actRest
@ -711,6 +747,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
CmdParserHelp{} -> restCase CmdParserHelp{} -> restCase
CmdParserSynopsis{} -> restCase CmdParserSynopsis{} -> restCase
CmdParserPeekDesc{} -> restCase CmdParserPeekDesc{} -> restCase
CmdParserPeekInput{} -> restCase
CmdParserChild{} -> restCase CmdParserChild{} -> restCase
CmdParserImpl{} -> restCase CmdParserImpl{} -> restCase
CmdParserReorderStart{} -> restCase CmdParserReorderStart{} -> restCase
@ -721,6 +758,36 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
mTell ["Did not find expected ReorderStop after the reordered parts"] mTell ["Did not find expected ReorderStop after the reordered parts"]
return () return ()
childrenGather
:: ( MonadMultiWriter [ChildGather f out] m
, MonadMultiState (CmdParser f out ()) m
, MonadMultiState (CommandDesc out) m
)
=> CmdParser f out a
-> m (CmdParser f out a)
childrenGather = \case
Free (CmdParserChild cmdStr sub act next) -> do
mTell [ChildGather cmdStr sub act]
childrenGather next
Free (CmdParserPeekInput nextF) -> do
childrenGather $ nextF $ inputToString inputInitial
Free (CmdParserPeekDesc nextF) -> do
parser <- mGet
-- partialDesc :: CommandDesc out <- mGet
-- partialStack :: CmdDescStack <- mGet
-- run the rest without affecting the actual stack
-- to retrieve the complete cmddesc.
cmdCur :: CommandDesc out <- mGet
let (cmd :: CommandDesc out, stack)
= runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateSA emptyCommandDesc
{ _cmd_mParent = _cmd_mParent cmdCur } -- partialDesc
$ MultiRWSS.withMultiStateS (StackBottom mempty) -- partialStack
$ iterM processCmdShallow $ parser
childrenGather $ nextF $ () <$ postProcessCmd stack cmd
something -> return something
processParsedParts processParsedParts
:: forall m r w s m0 a :: forall m r w s m0 a
. ( MonadMultiState Int m . ( MonadMultiState Int m
@ -747,11 +814,11 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
StackBottom{} -> do StackBottom{} -> do
mTell ["unexpected stackBottom"] mTell ["unexpected stackBottom"]
StackLayer descs _ up -> do StackLayer descs _ up -> do
mSet $ descStackAdd (PartReorder (reverse descs)) up mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up
return next return next
Free (CmdParserGrouped groupName next) -> do Free (CmdParserGrouped groupName next) -> do
stackCur <- mGet stackCur <- mGet
mSet $ StackLayer [] groupName stackCur mSet $ StackLayer mempty groupName stackCur
processParsedParts $ next processParsedParts $ next
Free (CmdParserGroupEnd next) -> do Free (CmdParserGroupEnd next) -> do
stackCur <- mGet stackCur <- mGet
@ -760,7 +827,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
mTell $ ["butcher interface error: group end without group start"] mTell $ ["butcher interface error: group end without group start"]
return $ next -- hard abort should be fine for this case. return $ next -- hard abort should be fine for this case.
StackLayer descs groupName up -> do StackLayer descs groupName up -> do
mSet $ descStackAdd (PartRedirect groupName (PartSeq (reverse descs))) up mSet $ descStackAdd (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) up
processParsedParts $ next processParsedParts $ next
Pure x -> return $ return $ x Pure x -> return $ return $ x
f -> do f -> do
@ -780,7 +847,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
pid <- mGet pid <- mGet
mSet $ pid + 1 mSet $ pid + 1
parsedMap :: PartParsedData <- mGet parsedMap :: PartParsedData <- mGet
mSet $ Map.delete pid parsedMap mSet $ MapS.delete pid parsedMap
partMap :: Map Int (PartGatherData f) <- mGet partMap :: Map Int (PartGatherData f) <- mGet
input :: Input <- mGet input :: Input <- mGet
let errorResult = do let errorResult = do
@ -795,8 +862,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
continueOrMisuse :: Maybe p -> m (CmdParser f out a) continueOrMisuse :: Maybe p -> m (CmdParser f out a)
continueOrMisuse = maybe monadMisuseError continueOrMisuse = maybe monadMisuseError
(processParsedParts . nextF) (processParsedParts . nextF)
case Map.lookup pid parsedMap of case MapS.lookup pid parsedMap of
Nothing -> case Map.lookup pid partMap of Nothing -> case MapS.lookup pid partMap of
Nothing -> monadMisuseError -- it would still be in the map Nothing -> monadMisuseError -- it would still be in the map
-- if it never had been successfully -- if it never had been successfully
-- parsed, as indicicated by the -- parsed, as indicicated by the
@ -823,8 +890,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
pid <- mGet pid <- mGet
mSet $ pid + 1 mSet $ pid + 1
m :: PartParsedData <- mGet m :: PartParsedData <- mGet
mSet $ Map.delete pid m mSet $ MapS.delete pid m
let partDyns = case Map.lookup pid m of let partDyns = case MapS.lookup pid m of
Nothing -> [] Nothing -> []
Just r -> r Just r -> r
case mapM fromDynamic partDyns of case mapM fromDynamic partDyns of
@ -848,7 +915,9 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
mSet $ cmd { _cmd_synopsis = Just $ PP.text s } mSet $ cmd { _cmd_synopsis = Just $ PP.text s }
next next
CmdParserPeekDesc nextF -> do CmdParserPeekDesc nextF -> do
mGet >>= nextF mGet >>= nextF . fmap (\(_ :: out) -> ())
CmdParserPeekInput nextF -> do
nextF $ inputToString inputInitial
CmdParserPart desc _parseF _act nextF -> do CmdParserPart desc _parseF _act nextF -> do
do do
stackCur <- mGet stackCur <- mGet
@ -870,14 +939,16 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
nextF monadMisuseError nextF monadMisuseError
CmdParserChild cmdStr _sub _act next -> do CmdParserChild cmdStr _sub _act next -> do
cmd_children %=+ ((cmdStr, emptyCommandDesc :: CommandDesc out):) mExisting <- takeCommandChild cmdStr
let childDesc :: CommandDesc out = fromMaybe emptyCommandDesc mExisting
cmd_children %=+ Deque.snoc (cmdStr, childDesc)
next next
CmdParserImpl out next -> do CmdParserImpl out next -> do
cmd_out .=+ Just out cmd_out .=+ Just out
next next
CmdParserGrouped groupName next -> do CmdParserGrouped groupName next -> do
stackCur <- mGet stackCur <- mGet
mSet $ StackLayer [] groupName stackCur mSet $ StackLayer mempty groupName stackCur
next next
CmdParserGroupEnd next -> do CmdParserGroupEnd next -> do
stackCur <- mGet stackCur <- mGet
@ -887,19 +958,19 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
StackLayer _descs "" _up -> do StackLayer _descs "" _up -> do
return () return ()
StackLayer descs groupName up -> do StackLayer descs groupName up -> do
mSet $ descStackAdd (PartRedirect groupName (PartSeq (reverse descs))) up mSet $ descStackAdd (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) up
next next
CmdParserReorderStop next -> do CmdParserReorderStop next -> do
stackCur <- mGet stackCur <- mGet
case stackCur of case stackCur of
StackBottom{} -> return () StackBottom{} -> return ()
StackLayer descs "" up -> do StackLayer descs "" up -> do
mSet $ descStackAdd (PartReorder (reverse descs)) up mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up
StackLayer{} -> return () StackLayer{} -> return ()
next next
CmdParserReorderStart next -> do CmdParserReorderStart next -> do
stackCur <- mGet stackCur <- mGet
mSet $ StackLayer [] "" stackCur mSet $ StackLayer mempty "" stackCur
next next
failureCurrentShallowRerun failureCurrentShallowRerun
@ -921,9 +992,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
postProcessCmd descStack cmd postProcessCmd descStack cmd
= descFixParents = descFixParents
$ cmd { _cmd_parts = case descStack of $ cmd { _cmd_parts = case descStack of
StackBottom l -> reverse l StackBottom l -> Data.Foldable.toList l
StackLayer{} -> [] StackLayer{} -> []
, _cmd_children = reverse $ _cmd_children cmd
} }
monadMisuseError :: a monadMisuseError :: a
@ -955,6 +1025,45 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
InputString s -> mSet $ InputString $ dropWhile Char.isSpace s InputString s -> mSet $ InputString $ dropWhile Char.isSpace s
InputArgs{} -> return () InputArgs{} -> return ()
inputToString :: Input -> String
inputToString (InputString s) = s
inputToString (InputArgs ss) = List.unwords ss
dequeLookupRemove :: String -> Deque (String, a) -> (Maybe a, Deque (String, a))
dequeLookupRemove key deque = case Deque.uncons deque of
Nothing -> (Nothing, mempty)
Just ((k, v), rest) -> if k==key
then (Just v, rest)
else let (r, rest') = dequeLookupRemove key rest
in (r, Deque.cons (k, v) rest')
takeCommandChild
:: MonadMultiState (CommandDesc out) m
=> String
-> m (Maybe (CommandDesc out))
takeCommandChild key = do
cmd <- mGet
let (r, children') = dequeLookupRemove key $ _cmd_children cmd
mSet cmd { _cmd_children = children' }
return r
mapOut :: (outa -> outb) -> CmdParser f outa () -> CmdParser f outb ()
mapOut f = hoistFree $ \case
CmdParserHelp doc r -> CmdParserHelp doc r
CmdParserSynopsis s r -> CmdParserSynopsis s r
CmdParserPeekDesc fr -> CmdParserPeekDesc fr
CmdParserPeekInput fr -> CmdParserPeekInput fr
CmdParserPart desc fp fa fr -> CmdParserPart desc fp fa fr
CmdParserPartMany bound desc fp fa fr -> CmdParserPartMany bound desc fp fa fr
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 r -> CmdParserChild s (mapOut f child) act r
CmdParserImpl out r -> CmdParserImpl (f out) r
CmdParserReorderStart r -> CmdParserReorderStart r
CmdParserReorderStop r -> CmdParserReorderStop r
CmdParserGrouped s r -> CmdParserGrouped s r
CmdParserGroupEnd r -> CmdParserGroupEnd r
-- cmdActionPartial :: CommandDesc out -> Either String out -- cmdActionPartial :: CommandDesc out -> Either String out
-- cmdActionPartial = maybe (Left err) Right . _cmd_out -- cmdActionPartial = maybe (Left err) Right . _cmd_out

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

@ -59,7 +59,8 @@ data ManyUpperBound
data CmdParserF f out a data CmdParserF f out a
= CmdParserHelp PP.Doc a = CmdParserHelp PP.Doc a
| CmdParserSynopsis String a | CmdParserSynopsis String a
| CmdParserPeekDesc (CommandDesc out -> a) | CmdParserPeekDesc (CommandDesc () -> a)
| CmdParserPeekInput (String -> a)
-- TODO: we can clean up this duplication by providing -- TODO: we can clean up this duplication by providing
-- a function (String -> Maybe (p, String)) -> (Input -> Maybe (p, Input)). -- a function (String -> Maybe (p, String)) -> (Input -> Maybe (p, Input)).
| forall p . Typeable p => CmdParserPart PartDesc (String -> Maybe (p, String)) (p -> f ()) (p -> a) | forall p . Typeable p => CmdParserPart PartDesc (String -> Maybe (p, String)) (p -> f ()) (p -> a)
@ -112,7 +113,9 @@ data CommandDesc out = CommandDesc
, _cmd_help :: Maybe PP.Doc , _cmd_help :: Maybe PP.Doc
, _cmd_parts :: [PartDesc] , _cmd_parts :: [PartDesc]
, _cmd_out :: Maybe out , _cmd_out :: Maybe out
, _cmd_children :: [(String, CommandDesc out)] , _cmd_children :: Deque (String, CommandDesc out) -- we don't use a Map here
-- because we'd like to
-- retain the order.
} }
-- type PartSeqDesc = [PartDesc] -- type PartSeqDesc = [PartDesc]
@ -164,7 +167,7 @@ deriving instance Functor CommandDesc
-- --
emptyCommandDesc :: CommandDesc out emptyCommandDesc :: CommandDesc out
emptyCommandDesc = CommandDesc Nothing Nothing Nothing [] Nothing [] emptyCommandDesc = CommandDesc Nothing Nothing Nothing [] Nothing mempty
instance Show (CommandDesc out) where instance Show (CommandDesc out) where
show c = "Command help=" ++ show (_cmd_help c) show c = "Command help=" ++ show (_cmd_help c)

71
src/UI/Butcher/Monadic/Pretty.hs
View File

@ -56,22 +56,25 @@ import UI.Butcher.Monadic.Internal.Core
-- | ppUsage exampleDesc yields: -- | ppUsage exampleDesc yields:
-- --
-- > playground [--short] NAME [version | help] -- > playground [--short] NAME [version | help]
ppUsage :: CommandDesc a ppUsage :: CommandDesc a -> PP.Doc
-> PP.Doc ppUsage (CommandDesc mParent _help _syn parts out children) = pparents mParent
ppUsage (CommandDesc mParent _help _syn parts out children) = <+> PP.fsep (partDocs ++ [subsDoc])
pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) where
where pparents :: Maybe (String, CommandDesc out) -> PP.Doc
pparents :: Maybe (String, CommandDesc out) -> PP.Doc pparents Nothing = PP.empty
pparents Nothing = PP.empty pparents (Just (n, cd)) = pparents (_cmd_mParent cd) <+> PP.text n
pparents (Just (n, cd)) = pparents (_cmd_mParent cd) <+> PP.text n partDocs = parts <&> ppPartDescUsage
partDocs = parts <&> ppPartDescUsage subsDoc = case out of
subsDoc = case out of _ | null children -> PP.empty -- TODO: remove debug
_ | null children -> PP.empty -- TODO: remove debug Nothing | null parts -> subDoc
Nothing | null parts -> subDoc | otherwise -> PP.parens $ subDoc
| otherwise -> PP.parens $ subDoc Just{} -> PP.brackets $ subDoc
Just{} -> PP.brackets $ subDoc subDoc =
subDoc = PP.fcat $ PP.punctuate (PP.text " | ") $ children <&> \(n, _) -> PP.fcat
PP.text n $ PP.punctuate (PP.text " | ")
$ Data.Foldable.toList
$ children
<&> \(n, _) -> PP.text n
-- | ppUsageWithHelp exampleDesc yields: -- | ppUsageWithHelp exampleDesc yields:
-- --
@ -81,22 +84,26 @@ ppUsage (CommandDesc mParent _help _syn parts out children) =
-- And yes, the line break is not optimal in this instance with default print. -- And yes, the line break is not optimal in this instance with default print.
ppUsageWithHelp :: CommandDesc a -> PP.Doc ppUsageWithHelp :: CommandDesc a -> PP.Doc
ppUsageWithHelp (CommandDesc mParent help _syn parts out children) = ppUsageWithHelp (CommandDesc mParent help _syn parts out children) =
pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc
where where
pparents :: Maybe (String, CommandDesc out) -> PP.Doc pparents :: Maybe (String, CommandDesc out) -> PP.Doc
pparents Nothing = PP.empty pparents Nothing = PP.empty
pparents (Just (n, cd)) = pparents (_cmd_mParent cd) <+> PP.text n pparents (Just (n, cd)) = pparents (_cmd_mParent cd) <+> PP.text n
partDocs = parts <&> ppPartDescUsage partDocs = parts <&> ppPartDescUsage
subsDoc = case out of subsDoc = case out of
_ | null children -> PP.empty -- TODO: remove debug _ | null children -> PP.empty -- TODO: remove debug
Nothing | null parts -> subDoc Nothing | null parts -> subDoc
| otherwise -> PP.parens $ subDoc | otherwise -> PP.parens $ subDoc
Just{} -> PP.brackets $ subDoc Just{} -> PP.brackets $ subDoc
subDoc = PP.fcat $ PP.punctuate (PP.text " | ") $ children <&> \(n, _) -> subDoc =
PP.text n PP.fcat
helpDoc = case help of $ PP.punctuate (PP.text " | ")
Nothing -> PP.empty $ Data.Foldable.toList
Just h -> PP.text ":" PP.<+> h $ children
<&> \(n, _) -> PP.text n
helpDoc = case help of
Nothing -> PP.empty
Just h -> PP.text ":" PP.<+> h
-- | > ppUsageAt [] = ppUsage -- | > ppUsageAt [] = ppUsage
-- --

7
srcinc/prelude.inc
View File

@ -91,7 +91,8 @@ import qualified Data.List as List
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
import qualified Data.IntMap.Strict as IntMapS import qualified Data.IntMap.Strict as IntMapS
import qualified Data.Map as Map import qualified Data.Map.Strict as MapS
import qualified Data.Map.Lazy as MapL
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
@ -128,6 +129,10 @@ import Data.Sequence ( Seq )
import Data.Map ( Map ) import Data.Map ( Map )
import Data.Set ( Set ) import Data.Set ( Set )
import Deque ( Deque )
import qualified Deque
import Prelude ( Char import Prelude ( Char
, String , String
, Int , Int