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

Fix too-shallow descs for "siblings"

pull/5/head
Lennart Spitzner 2018-12-02 14:08:09 +01:00
parent 6e70709e67
commit 593d903a53
1 changed files with 17 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -732,28 +732,31 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
Just $ (Just name, child, act, vis, InputArgs strr) Just $ (Just name, child, act, vis, InputArgs strr)
(Nothing, _) -> Just $ (Nothing, child, act, vis, input) (Nothing, _) -> Just $ (Nothing, child, act, vis, input)
_ -> Nothing _ -> Nothing
combined_child_list `forM_` \(child_name, (vis, child, _)) -> do
let initialDesc :: CommandDesc out = emptyCommandDesc
-- get the shallow desc for the child in a separate env.
let (subCmd, subStack) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateSA initialDesc
$ MultiRWSS.withMultiStateS (StackBottom mempty)
$ iterM processCmdShallow child
cmd_children %=+ Deque.snoc
( child_name
, postProcessCmd subStack subCmd { _cmd_visibility = vis }
)
case mRest of case mRest of
Nothing -> do -- a child not matching what we have in the input 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. -- get the shallow desc for the child in a separate env.
combined_child_list `forM_` \(child_name, (vis, child, _)) -> do
let (subCmd, subStack) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateSA initialDesc
$ MultiRWSS.withMultiStateS (StackBottom mempty)
$ iterM processCmdShallow child
cmd_children %=+ Deque.snoc
( child_name
, postProcessCmd subStack subCmd { _cmd_visibility = vis }
)
-- proceed regularly on the same layer -- proceed regularly on the same layer
processMain $ restCmdParser processMain $ restCmdParser
Just (name, vis, child, act, rest) -> do -- matching child -> descend Just (name, vis, child, act, rest) -> do -- matching child -> descend
-- process all remaining stuff on the same layer shallowly, -- process all remaining stuff on the same layer shallowly,
-- including the current node. This will be replaced later. -- including the current node. This will walk over the child
-- definition(s) again, but that is harmless because we do not
-- overwrite them.
iterM processCmdShallow f iterM processCmdShallow f
-- so the descend -- do the descend
cmd <- do cmd <- do
c :: CommandDesc out <- mGet c :: CommandDesc out <- mGet
prevStack :: CmdDescStack <- mGet prevStack :: CmdDescStack <- mGet