f.hs

alterF :: forall k f a.
          (Functor f, Hashable k, Eq k)
       => ([k] -> f ()) -- ^ Called with the key of the missing intermediate node
       -> (Maybe a -> f (Maybe a)) -- ^ Will use `f prevNodeValues new old`
       -> [k] -- ^ Key of where the alter the tree.
       -> Tree k a -- ^ Tree to alter
       -> f (Tree k a)
alterF ne fun path t = go [] path t
  where
    go :: [k] -> [k] -> Tree k a -> f (Tree k a)
    go _ps [k]    tree = alterChildrenF f k tree
      where
        f :: Maybe (Tree k a) -> f (Maybe (Tree k a))
        f Nothing              = fun Nothing <&> fmap singleton
        f (Just sub) = let old = rootValue sub
                        in fun (Just old) <&> fmap (`setRootValue` sub)
    go ps (k:ks) tree  = alterChildrenF f k tree
      where
        f :: Maybe (Tree k a) -> f (Maybe (Tree k a))
        f Nothing    = ne ps <&> \_ -> Nothing
        f (Just sub) = Just <$> go (k:ps) ks sub
    go _ps []     tree = fun (Just (rootValue tree)) <&> \x' -> case x' of
      Nothing  -> error "alterF: cannot delete root node"
      Just x'' -> setRootValue x'' tree