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

src/UI/Butcher/Monadic/Core.hs

@@ -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 =
+descFixParentsWithTopM mTop topDesc = Data.Function.fix $ \fixed -> topDesc
-    go $ case mTop of
+        { _cmd_mParent  = goUp fixed <$> (mTop <|> _cmd_mParent topDesc)
-      Nothing  -> topDesc
+        , _cmd_children = _cmd_children topDesc <&> goDown fixed
-      Just top -> topDesc { _cmd_mParent = Just top }
+        }
   where
-    go :: CommandDesc a -> CommandDesc a
+    goUp :: CommandDesc a -> (String, CommandDesc a) -> (String, CommandDesc a)
-    go desc =
+    goUp child (childName, parent) = (,) childName $ Data.Function.fix $ \fixed -> parent
-      let fixedDesc = desc { _cmd_children = _cmd_children desc <&> \(n, sd) ->
+      { _cmd_mParent = goUp fixed <$> _cmd_mParent parent
-                               (n, go $ sd { _cmd_mParent = Just (n, fixedDesc)})
+      , _cmd_children = _cmd_children parent <&> \(n, c) -> if n==childName
-                           }
+          then (n, child)
-      in fixedDesc
+          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