Combining Maps using the Applicative idiom: f <$$> map1 <**> map2 <**> map3

ApplicativeMap.hs

-- Combining Maps using the Applicative idiom.
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
module ApplicativeMap where

import Data.Map.Strict (Map)
import qualified Data.Map as Map

-- When combining multiple Applicative computations, a common Haskell idiom is
-- to use (<$>) and (<*>) to combine the results using a function:

foo :: Applicative f
    => (a -> b -> c -> d)
    -> f a -> f b -> f c -> f d
foo f makeA makeB makeC = f <$> makeA <*> makeB <*> makeC

-- This module defines (<$$>) and (<**>), which can be used similarly to
-- combine the values of multiple Maps using a function. The function receives
-- Maybes in order to account for keys which are present in one Map but absent
-- in another.

bar :: Ord k
    => (Maybe a -> Maybe b -> Maybe c -> d)
    -> Map k a -> Map k b -> Map k c -> Map k d
bar f mapA mapB mapC = underlyingMap (f <$$> mapA <**> mapB <**> mapC)


-- The trick is to keep track of one extra value: 'defaultValue', the result of
-- only giving Nothings to the function. Since most use cases of combining Maps
-- only care about the keys which are present in at least one of the Maps, this
-- extra value is discarded at the end of the computation by calling
-- 'underlyingMap'.

data ApplicativeMap k a = ApplicativeMap
  { underlyingMap :: Map k a
  , defaultValue  :: a
  }
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

instance Ord k => Applicative (ApplicativeMap k) where
  pure  = ApplicativeMap mempty
  ApplicativeMap kfs defaultF <*> ApplicativeMap kxs defaultX
    = ApplicativeMap yfs defaultY
    where
      yfs = Map.mergeWithKey (\_ f x -> Just (f x))
                             (Map.map ($ defaultX))
                             (Map.map (defaultF $))
                             kfs
                             kxs
      defaultY = defaultF defaultX

infixl 4 <$$>
(<$$>) :: (Maybe a -> b)
       -> Map k a
       -> ApplicativeMap k b
f <$$> kxs = ApplicativeMap kys defaultY
  where
    kys = f . Just <$> kxs
    defaultY = f Nothing

infixl 4 <**>
(<**>) :: Ord k
       => ApplicativeMap k (Maybe a -> b)
       -> Map k a
       -> ApplicativeMap k b
ApplicativeMap kfs defaultF <**> kxs = ApplicativeMap kys defaultY
  where
    kys = Map.intersectionWith (\f x -> f (Just x)) kfs kxs
    defaultY = defaultF Nothing