traverseNubOf

traverseNubOf.hs

-- | Traverse the structure using the traversal but memoize the
-- results of the transforming function; this means that the function
-- is called once for every unique element.
--
-- NB: I can't work out how to do this with only one optic argument,
-- but it should be possible.
--
-- prop> traverseNubOf (traverse._1) (traverse._1) (\x -> do print x; return (-x)) [(2,10),(2,20),(1,30),(1,40),(3,50),(3,60)]
-- 1
-- 2
-- 3
-- [(-2,10),(-2,20),(-1,30),(-1,40),(-3,50),(-3,60)]
traverseNubOf :: (Applicative f, Ord a)
              => L.Getting (Data.Monoid.Endo [a]) s a
              -> L.ASetter s t a b
              -> (a -> f b)
              -> s
              -> f t
traverseNubOf t1 t2 f s =
  let tagMap = (traverse f
                . Map.fromList
                . map (\x -> (x, x))
                . L.toListOf t1)
               s

      lookup' m k = let e = error "traverseNubOf: Missing value in map"
                    in Map.findWithDefault e k m

  in (\m -> L.over t2 (lookup' m) s) <$> tagMap