Fix/Implement knot-tying of the CommandDesc cyclic graph structure

pull/5/head
Lennart Spitzner 2016-12-30 22:07:11 +01:00
parent b11663d910
commit f35ebb733a
1 changed files with 16 additions and 10 deletions
src/UI/Butcher/Monadic

View File

@ -922,17 +922,23 @@ descFixParents = descFixParentsWithTopM Nothing
-- descFixParentsWithTop s = descFixParentsWithTopM (Just (s, emptyCommandDesc))
descFixParentsWithTopM :: Maybe (String, CommandDesc a) -> CommandDesc a -> CommandDesc a
descFixParentsWithTopM mTop topDesc =
go $ case mTop of
Nothing -> topDesc
Just top -> topDesc { _cmd_mParent = Just top }
descFixParentsWithTopM mTop topDesc = Data.Function.fix $ \fixed -> topDesc
{ _cmd_mParent = goUp fixed <$> (mTop <|> _cmd_mParent topDesc)
, _cmd_children = _cmd_children topDesc <&> goDown fixed
}
where
go :: CommandDesc a -> CommandDesc a
go desc =
let fixedDesc = desc { _cmd_children = _cmd_children desc <&> \(n, sd) ->
(n, go $ sd { _cmd_mParent = Just (n, fixedDesc)})
}
in fixedDesc
goUp :: CommandDesc a -> (String, CommandDesc a) -> (String, CommandDesc a)
goUp child (childName, parent) = (,) childName $ Data.Function.fix $ \fixed -> parent
{ _cmd_mParent = goUp fixed <$> _cmd_mParent parent
, _cmd_children = _cmd_children parent <&> \(n, c) -> if n==childName
then (n, child)
else (n, c)
}
goDown :: CommandDesc a -> (String, CommandDesc a) -> (String, CommandDesc a)
goDown parent (childName, child) = (,) childName $ Data.Function.fix $ \fixed -> child
{ _cmd_mParent = Just (childName, parent)
, _cmd_children = _cmd_children child <&> goDown fixed
}
_tooLongText :: Int -- max length