From a116e371f7366e3fdd0989df4871de40cccecac8 Mon Sep 17 00:00:00 2001
From: Joris Dral <joris@well-typed.com>
Date: Wed, 26 Oct 2022 11:45:49 +0000
Subject: [PATCH] Keybindings for multi-expansion.

---
 ghc-debug-brick/src/IOTree.hs | 17 ++++++++++++++++-
 1 file changed, 16 insertions(+), 1 deletion(-)

diff --git a/ghc-debug-brick/src/IOTree.hs b/ghc-debug-brick/src/IOTree.hs
index 33fb1d2..8943521 100644
--- a/ghc-debug-brick/src/IOTree.hs
+++ b/ghc-debug-brick/src/IOTree.hs
@@ -143,6 +143,7 @@ handleIOTreeEvent e tree
         (view', cs) <- viewExpand view
         return $ if null cs then view' else viewUnsafeDown view' 0
     Vty.EvKey KDown _ -> return $ next view
+    Vty.EvKey KLeft [Vty.MShift] -> return $ viewCollapseAll view
     Vty.EvKey KLeft _ -> return $ viewCollapse $ fromMaybe view (viewUp' view)
     Vty.EvKey KUp _ -> return $ prev view
     Vty.EvKey KPageDown _ -> return $ List.foldl' (flip ($)) view (replicate 15 next)
@@ -282,7 +283,21 @@ viewCollapse t = case t of
     Left _ -> t
     Right cs -> Node mkParent i t'{_children = Left (return cs)}
 
--- | Expand the current node. Returns the children
+-- | Collapse the current node and all the nodes in the the subtree rooted at
+-- the current node.
+viewCollapseAll :: HasCallStack => IOTreeView node name -> IOTreeView node name
+viewCollapseAll tv = case tv of
+    Root t            -> Root (t {_roots = fmap go (_roots t)})
+    Node mkParent i t -> case _children t of
+      Left cs  -> Node mkParent i t {_children = Left $ fmap go <$> cs}
+      Right cs -> Node mkParent i t {_children = Left . pure $ fmap go cs }
+  where
+    go :: IOTreeNode node name -> IOTreeNode node name
+    go tn = case _children tn of
+      Left cs  -> tn {_children = Left $ fmap go <$> cs }
+      Right cs -> tn {_children = Left . pure $ fmap go cs}
+
+-- | Expand the current node. Returns the children of the current node.
 viewExpand :: HasCallStack => IOTreeView node name -> IO (IOTreeView node name, [IOTreeNode node name])
 viewExpand t = case t of
   Root t' -> return (t, _roots t')
-- 
GitLab