How can I make this fold more generic

Question

I've written this function:

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
module Hierarchy where

import           Control.Applicative
import qualified Control.Foldl       as CF
import           Control.Foldl (Fold(..))
import           Control.Lens hiding (Fold)
import qualified Data.Foldable       as F
import qualified Data.Map.Lazy       as M
import           Data.Monoid         (Monoid (..), Sum (Sum))
import           Data.Profunctor
import           Data.Set (Set)
import           Data.Maybe
import           Data.Text           (Text)

overMaps :: (Ord k) => Fold a b -> Fold (M.Map k a) (M.Map k b)
overMaps (Fold step begin done) = Fold step' M.empty (fmap done)   
  where
  step' acc m = M.foldrWithKey insert acc m
  insert k el acc = M.insert k (step (fromMaybe begin $ M.lookup k acc) el) acc

I feel like I'm missing some fundamental abstraction that could make this more general, and more succinct.

Can anyone give me some pointers as to how I could use any modern Haskellisms here to make this better?

edit The code is here https://github.com/boothead/hierarchy/blob/master/src/Hierarchy.hs

and I've included the imports

edit Perhaps I can use ifoldr to get closer to @cdk's idea?

edit

Here's the closest I've got.

--overFoldable :: (Ord k) => Fold a b -> Fold (M.Map k a) (M.Map k b)
overFoldable :: (Ord i, At (f i a), FoldableWithIndex i (f i), Monoid (f i x))
             => Fold a b -> Fold (f i a) (f i b)
overFoldable (Fold step begin done) = Fold step' mempty (fmap done)
  where
  step' acc m = Lens.ifoldr insert acc m
  insert k el acc = Lens.at k %~ return . flip step el . fromMaybe begin $ acc

Here the first (commented) type signature works. Now the problem lies in the existential x in the type signature of Fold :: (x -> a -> x) -> x -> (x -> b) -> Fold a b I can't figure out what to put in the begin position of my new fold. It needs to be of Type f i x but I don't know how to tell Haskell how to take x to be the same type as begin.

Answer 1

Mainly for my own understanding (and that of my beloved rubber duck):

Suppose I have a Fold sumLengths that adds the lengths of strings (so fold sumLengths ["a","bbb"] yields 4)

I want overMaps sumLengths to be a Fold that takes say a French and a Dutch dictionary, and makes a new dictionary D such that lookup D "bread" is 9 (length("pain") + length("brood"))

The problem of course is that some words may not occur in all dictionaries: lookup D "sex" is length("sexe") as we Dutch are very prudish :-) So we need the begin value of our fold not only at the beginning of our fold, but possibly at any moment.

This means it won't do to just lift the step function to Map k (in that case we could use any instance of Applicative instead of our Map, see below), we have to take our begin value all along the way.

This "lift plus default value" is the member fuseWith of a new class Fusable below. It is the step' in your original code, but (slightly) generalised so that we also have an overF sumLengths for lists of lists, for example.

import Data.Map as M hiding (map)
import qualified Control.Foldl       as CF
import Control.Foldl (Fold(..))
import Control.Applicative
import Data.Foldable as F
import Data.Maybe

--- the Fusable class:
class Functor f => Fusable f where
  fuseWith :: x -> (x -> a -> x) -> f x -> f a -> f x 
  emptyf   :: f a 

--- Map k is a Fusable (whenever k has an ordering)
instance (Ord k) => Fusable (Map k) where
   fuseWith x f xmap amap = M.foldrWithKey insert xmap amap where    
      insert k el xmap = M.insert k (f (fromMaybe x $ M.lookup k xmap) el) xmap 
   emptyf = M.empty

--- Lists are Fusable
instance Fusable [] where
  fuseWith  = zipWithDefault where
    zipWithDefault dx f [] ys = zipWith f (repeat dx) ys
    zipWithDefault dx f xs [] = xs
    zipWithDefault dx f (x:xs) (y:ys) = (f x y) : zipWithDefault dx f xs ys
  emptyf = []

--- The generalised overMaps:
overF :: (Fusable f) => Fold a b  -> Fold (f a) (f b)
overF (Fold step begin done) = Fold (fuseWith begin step) emptyf (fmap done)

--- some tests
testlist = [(1,4),(3,99),(7,999)]
testlist2 = [(1,15),(2,88)]

test  = CF.fold (overF CF.sum)  $ map fromList [testlist, testlist2] 
-- fromList [(1,19),(2,88),(3,99),(7,999)]
test2 = CF.fold (overF $ CF.premap snd CF.sum) [testlist, testlist2] 
-- [19,187,999]

If we don't worry about taking the begin value along, we can use any Applicative (Map k is not Applicative!)

overA :: (Applicative f) => Fold a b -> Fold (f a) (f b)
overA (Fold step begin done) = Fold (liftA2 step) (pure begin) (fmap done)

It certainly looks a lot like overF. But it gives different results: when folding over a list of lists, as soon as a list comes along that is too short, the result is truncated

test3 = CF.fold (overA $ CF.premap snd CF.sum) $  map ZipList [testlist, testlist2] 
-- ZipList [19,187]  -- *where* is my third element :-(