diff options
| -rw-r--r-- | TreeZipperUtils.hs | 40 | ||||
| -rw-r--r-- | test5.hs | 11 |
2 files changed, 47 insertions, 4 deletions
diff --git a/TreeZipperUtils.hs b/TreeZipperUtils.hs index b6410a3..0c6dc00 100644 --- a/TreeZipperUtils.hs +++ b/TreeZipperUtils.hs @@ -1,5 +1,6 @@ module TreeZipperUtils where +import Data.Maybe import Data.Tree import Data.Tree.Zipper @@ -10,3 +11,42 @@ path loc = toParent loc : parents loc -- Return parent stack compatible form of loc. toParent :: TreePos Full a -> (Forest a, a, Forest a) toParent loc = (before loc, label loc, after loc) + + +modifyFirstParentLabelWhere + :: (a -> Bool) + -> (a -> a) + -> TreePos Full a + -> TreePos Full a +modifyFirstParentLabelWhere p f loc0 = + case parent loc0 of + Nothing -> loc0 + Just loc0' -> go (byChildIndex loc0) loc0' + where + + go rewind loc = + if p (label loc) + then + rewind (modifyLabel f loc) + else + case parent loc of + Nothing -> rewind loc + Just loc' -> + go (rewind . byChildIndex loc) loc' + + -- generator for a rewind step + byChildIndex :: TreePos Full a -> (TreePos Full a -> TreePos Full a) + byChildIndex loc = + -- The use of fromJust is safe here because we're only modifying + -- labels and not the tree structure and thus the index is valid. + fromJust . childAt (childIndex loc) + + +-- XXX This could be named more general, like countPrevSiblings? +-- XXX Can we kill the recursion? +childIndex :: TreePos Full a -> Int +childIndex = + go 0 + where + go index = + maybe index (go $ index + 1) . prev @@ -35,6 +35,7 @@ import TagUtils import Trammel import TreeSearch import TreeView +import TreeZipperUtils (modifyFirstParentLabelWhere) import Utils @@ -430,19 +431,21 @@ toggleTagAtCursor tag q@State{..} = case Z.label cursor of else AddTag tagOps = [tagOp tag] Notmuch.notmuchTag tagOps sr - -- TODO reload or patch whole thread - let cursor' = Z.modifyTree (patchRootLabelTags tagOps) cursor + let cursor' = Z.modifyTree (patchTreeTags tagOps) cursor return q { cursor = cursor' } TVMessage m -> do - -- TODO modify search result tags let tagOp = if tag `elem` Notmuch.messageTags m then DelTag else AddTag tagOps = [tagOp tag] Notmuch.notmuchTag tagOps m - let cursor' = Z.modifyTree (patchRootLabelTags tagOps) cursor + let cursor' = + -- TODO this needs a nice name + modifyFirstParentLabelWhere isTVSearchResult f $ + Z.modifyLabel f cursor + f = patchTags tagOps return q { cursor = cursor' } _ -> return q { flashMessage = "nothing happened" } |