{-# LANGUAGE CPP                        #-}
{-# LANGUAGE ConstrainedClassMethods    #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}


module Control.Functor.Expansive
  (
  -- * Expand
    Expansive (..)
  , uniteDichotomy
  ) where


import           Control.Applicative               (ZipList (ZipList))
import           Control.Functor.Dichotomous       (Dichotomous (ymotohcid),
                                                    These (..))
import           Data.Foldable                     (toList)
import           Data.Functor.Contravariant        (Contravariant (contramap))
import           Data.Functor.Product              (Product (..))
import qualified Data.IntMap                       as IntMap
import           Data.Kind                         (Type)
import qualified Data.Map                          as Map
import           Data.Maybe                        (isJust)
import           Data.Proxy                        (Proxy (Proxy))
import           Data.Semigroup                    (Option (..))
import qualified Data.Sequence                     as Seq
import qualified Data.Sequence.Internal            as Seq
import qualified Data.Vector                       as V
import           Data.Vector.Fusion.Bundle.Monadic (Bundle (..))
import qualified Data.Vector.Fusion.Bundle.Monadic as Bundle
import qualified Data.Vector.Fusion.Bundle.Size    as Bundle
import           Data.Vector.Fusion.Stream.Monadic (Step (..), Stream (..))
import           Data.Vector.Generic               (stream, unstream)


uniteDichotomy
  :: (Functor f, Expansive f, Dichotomous g)
  => f l -> f r -> f (Maybe (g l r))
uniteDichotomy :: f l -> f r -> f (Maybe (g l r))
uniteDichotomy f l
x f r
y = Maybe (These l r) -> Maybe (g l r)
forall (f :: * -> * -> *) a b.
Dichotomous f =>
Maybe (These a b) -> Maybe (f a b)
ymotohcid (Maybe (These l r) -> Maybe (g l r))
-> (These l r -> Maybe (These l r)) -> These l r -> Maybe (g l r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. These l r -> Maybe (These l r)
forall a. a -> Maybe a
Just (These l r -> Maybe (g l r)) -> f (These l r) -> f (Maybe (g l r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f l -> f r -> f (These l r)
forall (f :: * -> *) l r.
Expansive f =>
f l -> f r -> f (These l r)
unite f l
x f r
y


-- | Partial inverse of Compactable
--
-- prop> expand (unite x y) = uniteDichotomy x y
-- prop> unite = emapThese id
-- prop> map Just = expand
-- prop> (\x -> unite x x) = map (\x -> These x x)
-- prop> emapThese f a b = map f (unite a b)
-- prop> unite (f <$> x) (g <$> y) = bimap f g <$> unite x y
-- prop> expand (unite x y) = swap <$> unite y x
-- prop> emapThese f a b = f <$> unite a b
-- prop> unite empty = map That
-- prop> flip unite empty = map This
-- prop> unite mempty = map That
-- prop> flip unite mempty = map This
class Expansive (f :: Type -> Type) where
  {-# MINIMAL unite | emapThese #-}

  expand :: f a -> f (Maybe a)
  default expand :: Functor f => f a -> f (Maybe a)
  expand = (a -> Maybe a) -> f a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just
  {-# INLINABLE expand #-}

  unite :: f l -> f r -> f (These l r)
  unite = (These l r -> These l r) -> f l -> f r -> f (These l r)
forall (f :: * -> *) l r a.
Expansive f =>
(These l r -> a) -> f l -> f r -> f a
emapThese These l r -> These l r
forall a. a -> a
id
  {-# INLINABLE unite #-}

  unfilter :: (Bool -> a) -> f a -> f a
  unfilter Bool -> a
f = (Maybe a -> a) -> f a -> f a
forall (f :: * -> *) b a.
Expansive f =>
(Maybe b -> a) -> f b -> f a
emapMaybe ((Maybe a -> a) -> f a -> f a) -> (Maybe a -> a) -> f a -> f a
forall a b. (a -> b) -> a -> b
$ Bool -> a
f (Bool -> a) -> (Maybe a -> Bool) -> Maybe a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> Bool
forall a. Maybe a -> Bool
isJust
  {-# INLINABLE unfilter #-}

  emapMaybe :: (Maybe b -> a) -> f b -> f a
  default emapMaybe :: Functor f => (Maybe b -> a) -> f b -> f a
  emapMaybe Maybe b -> a
f = (Maybe b -> a) -> f (Maybe b) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe b -> a
f (f (Maybe b) -> f a) -> (f b -> f (Maybe b)) -> f b -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f b -> f (Maybe b)
forall (f :: * -> *) a. Expansive f => f a -> f (Maybe a)
expand
  {-# INLINABLE emapMaybe #-}

  econtramapMaybe :: Contravariant f => (a -> Maybe b) -> f b -> f a
  econtramapMaybe a -> Maybe b
f = (a -> Maybe b) -> f (Maybe b) -> f a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> Maybe b
f (f (Maybe b) -> f a) -> (f b -> f (Maybe b)) -> f b -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f b -> f (Maybe b)
forall (f :: * -> *) a. Expansive f => f a -> f (Maybe a)
expand
  {-# INLINABLE econtramapMaybe #-}

  emapThese :: (These l r -> a) -> f l -> f r -> f a
  default emapThese :: Functor f => (These l r -> a) -> f l -> f r -> f a
  emapThese These l r -> a
f f l
a f r
b = These l r -> a
f (These l r -> a) -> f (These l r) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f l -> f r -> f (These l r)
forall (f :: * -> *) l r.
Expansive f =>
f l -> f r -> f (These l r)
unite f l
a f r
b
  {-# INLINABLE emapThese #-}

  econtramapThese :: Contravariant f => (a -> These l r) -> f l -> f r -> f a
  econtramapThese a -> These l r
f f l
l f r
r = (a -> These l r) -> f (These l r) -> f a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> These l r
f (f (These l r) -> f a) -> f (These l r) -> f a
forall a b. (a -> b) -> a -> b
$ f l -> f r -> f (These l r)
forall (f :: * -> *) l r.
Expansive f =>
f l -> f r -> f (These l r)
unite f l
l f r
r
  {-# INLINABLE econtramapThese #-}

  eapplyMaybe :: Applicative f => f (Maybe a -> b) -> f a -> f b
  eapplyMaybe f (Maybe a -> b)
fa = (f (Maybe a -> b)
fa f (Maybe a -> b) -> f (Maybe a) -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>) (f (Maybe a) -> f b) -> (f a -> f (Maybe a)) -> f a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> f (Maybe a)
forall (f :: * -> *) a. Expansive f => f a -> f (Maybe a)
expand
  {-# INLINABLE eapplyMaybe #-}

  eapplyThese :: Applicative f => f (These l r -> a) -> f l -> f r -> f a
  eapplyThese f (These l r -> a)
fa = (f (These l r) -> f a) -> (f r -> f (These l r)) -> f r -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f (These l r -> a)
fa f (These l r -> a) -> f (These l r) -> f a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>) ((f r -> f (These l r)) -> f r -> f a)
-> (f l -> f r -> f (These l r)) -> f l -> f r -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f l -> f r -> f (These l r)
forall (f :: * -> *) l r.
Expansive f =>
f l -> f r -> f (These l r)
unite
  {-# INLINABLE eapplyThese #-}

  ebindMaybe :: Applicative f => (f (Maybe b) -> a) -> f b -> f a
  ebindMaybe f (Maybe b) -> a
f f b
x = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a) -> (f (Maybe b) -> a) -> f (Maybe b) -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Maybe b) -> a
f (f (Maybe b) -> f a) -> f (Maybe b) -> f a
forall a b. (a -> b) -> a -> b
$ f b -> f (Maybe b)
forall (f :: * -> *) a. Expansive f => f a -> f (Maybe a)
expand f b
x
  {-# INLINABLE ebindMaybe #-}

  ebindThese :: Applicative f => (f (These l r) -> a) -> f l -> f r -> f a
  ebindThese f (These l r) -> a
f f l
x f r
y = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a) -> (f (These l r) -> a) -> f (These l r) -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (These l r) -> a
f (f (These l r) -> f a) -> f (These l r) -> f a
forall a b. (a -> b) -> a -> b
$ f l -> f r -> f (These l r)
forall (f :: * -> *) l r.
Expansive f =>
f l -> f r -> f (These l r)
unite f l
x f r
y
  {-# INLINABLE ebindThese #-}


instance Expansive Maybe where
  unite :: Maybe l -> Maybe r -> Maybe (These l r)
unite (Just l
x) (Just r
y) = These l r -> Maybe (These l r)
forall a. a -> Maybe a
Just (These l r -> Maybe (These l r)) -> These l r -> Maybe (These l r)
forall a b. (a -> b) -> a -> b
$ l -> r -> These l r
forall a b. a -> b -> These a b
These l
x r
y
  unite (Just l
x) Maybe r
_        = These l r -> Maybe (These l r)
forall a. a -> Maybe a
Just (These l r -> Maybe (These l r)) -> These l r -> Maybe (These l r)
forall a b. (a -> b) -> a -> b
$ l -> These l r
forall a b. a -> These a b
This l
x
  unite Maybe l
_ (Just r
y)        = These l r -> Maybe (These l r)
forall a. a -> Maybe a
Just (These l r -> Maybe (These l r)) -> These l r -> Maybe (These l r)
forall a b. (a -> b) -> a -> b
$ r -> These l r
forall a b. b -> These a b
That r
y
  unite Maybe l
_ Maybe r
_               = Maybe (These l r)
forall a. Maybe a
Nothing
  {-# INLINABLE unite #-}


instance Expansive [] where
  unite :: [l] -> [r] -> [These l r]
unite [l]
xs []         = l -> These l r
forall a b. a -> These a b
This (l -> These l r) -> [l] -> [These l r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [l]
xs
  unite [] [r]
ys         = r -> These l r
forall a b. b -> These a b
That (r -> These l r) -> [r] -> [These l r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [r]
ys
  unite (l
x:[l]
xs) (r
y:[r]
ys) = l -> r -> These l r
forall a b. a -> b -> These a b
These l
x r
y These l r -> [These l r] -> [These l r]
forall a. a -> [a] -> [a]
: [l] -> [r] -> [These l r]
forall (f :: * -> *) l r.
Expansive f =>
f l -> f r -> f (These l r)
unite [l]
xs [r]
ys
  {-# INLINABLE unite #-}


instance Expansive ZipList where
  unite :: ZipList l -> ZipList r -> ZipList (These l r)
unite (ZipList [l]
xs) (ZipList [r]
ys) = [These l r] -> ZipList (These l r)
forall a. [a] -> ZipList a
ZipList ([These l r] -> ZipList (These l r))
-> [These l r] -> ZipList (These l r)
forall a b. (a -> b) -> a -> b
$ [l] -> [r] -> [These l r]
forall (f :: * -> *) l r.
Expansive f =>
f l -> f r -> f (These l r)
unite [l]
xs [r]
ys
  {-# INLINABLE unite #-}


instance Expansive Proxy where
  unite :: Proxy l -> Proxy r -> Proxy (These l r)
unite Proxy l
_ Proxy r
_ = Proxy (These l r)
forall k (t :: k). Proxy t
Proxy
  {-# INLINABLE unite #-}


instance Expansive Option where
  unite :: Option l -> Option r -> Option (These l r)
unite (Option Maybe l
a) (Option Maybe r
b) = Maybe (These l r) -> Option (These l r)
forall a. Maybe a -> Option a
Option (Maybe (These l r) -> Option (These l r))
-> Maybe (These l r) -> Option (These l r)
forall a b. (a -> b) -> a -> b
$ Maybe l -> Maybe r -> Maybe (These l r)
forall (f :: * -> *) l r.
Expansive f =>
f l -> f r -> f (These l r)
unite Maybe l
a Maybe r
b
  {-# INLINABLE unite #-}


-- instance (Applicative f, Applicative g) => Expansive (FP.Product f g) where
-- instance (Applicative f, Applicative g) => Expansive (Compose f g) where

instance Expansive Seq.Seq where
  unite :: Seq l -> Seq r -> Seq (These l r)
unite Seq l
xs (Seq.Seq FingerTree (Elem r)
Seq.EmptyT) = (l -> These l r) -> Seq l -> Seq (These l r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap l -> These l r
forall a b. a -> These a b
This Seq l
xs
  unite (Seq.Seq FingerTree (Elem l)
Seq.EmptyT) Seq r
ys = (r -> These l r) -> Seq r -> Seq (These l r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> These l r
forall a b. b -> These a b
That Seq r
ys
  unite Seq l
xs Seq r
ys                   = [These l r] -> Seq (These l r)
forall a. [a] -> Seq a
Seq.fromList ([These l r] -> Seq (These l r)) -> [These l r] -> Seq (These l r)
forall a b. (a -> b) -> a -> b
$ [l] -> [r] -> [These l r]
forall (f :: * -> *) l r.
Expansive f =>
f l -> f r -> f (These l r)
unite (Seq l -> [l]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq l
xs) (Seq r -> [r]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq r
ys)
  {-# INLINABLE unite #-}


instance Monad m => Expansive (Bundle m v) where
  emapThese :: (These l r -> a) -> Bundle m v l -> Bundle m v r -> Bundle m v a
emapThese These l r -> a
f Bundle{sElems :: forall (m :: * -> *) (v :: * -> *) a. Bundle m v a -> Stream m a
sElems = Stream m l
sa, sSize :: forall (m :: * -> *) (v :: * -> *) a. Bundle m v a -> Size
sSize = Size
na} Bundle{sElems :: forall (m :: * -> *) (v :: * -> *) a. Bundle m v a -> Stream m a
sElems = Stream m r
sb, sSize :: forall (m :: * -> *) (v :: * -> *) a. Bundle m v a -> Size
sSize = Size
nb}
    = Stream m a -> Size -> Bundle m v a
forall (m :: * -> *) a (v :: * -> *).
Monad m =>
Stream m a -> Size -> Bundle m v a
Bundle.fromStream ((These l r -> a) -> Stream m l -> Stream m r -> Stream m a
forall (f :: * -> *) l r a.
Expansive f =>
(These l r -> a) -> f l -> f r -> f a
emapThese These l r -> a
f Stream m l
sa Stream m r
sb) (Size -> Size -> Size
Bundle.larger Size
na Size
nb)
  {-# INLINABLE emapThese #-}


instance Monad m => Expansive (Stream m) where
  emapThese :: (These l r -> a) -> Stream m l -> Stream m r -> Stream m a
emapThese  These l r -> a
f (Stream s -> m (Step s l)
stepa s
ta) (Stream s -> m (Step s r)
stepb s
tb) = ((s, s, Maybe l, Bool) -> m (Step (s, s, Maybe l, Bool) a))
-> (s, s, Maybe l, Bool) -> Stream m a
forall (m :: * -> *) a s. (s -> m (Step s a)) -> s -> Stream m a
Stream (s, s, Maybe l, Bool) -> m (Step (s, s, Maybe l, Bool) a)
step (s
ta, s
tb, Maybe l
forall a. Maybe a
Nothing, Bool
False)
    where
    step :: (s, s, Maybe l, Bool) -> m (Step (s, s, Maybe l, Bool) a)
step (s
sa, s
sb, Maybe l
Nothing, Bool
False) = do
      Step s l
r <- s -> m (Step s l)
stepa s
sa
      Step (s, s, Maybe l, Bool) a -> m (Step (s, s, Maybe l, Bool) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (s, s, Maybe l, Bool) a -> m (Step (s, s, Maybe l, Bool) a))
-> Step (s, s, Maybe l, Bool) a -> m (Step (s, s, Maybe l, Bool) a)
forall a b. (a -> b) -> a -> b
$ case Step s l
r of
        Yield l
x s
sa' -> (s, s, Maybe l, Bool) -> Step (s, s, Maybe l, Bool) a
forall s a. s -> Step s a
Skip (s
sa', s
sb, l -> Maybe l
forall a. a -> Maybe a
Just l
x,  Bool
False)
        Skip    s
sa' -> (s, s, Maybe l, Bool) -> Step (s, s, Maybe l, Bool) a
forall s a. s -> Step s a
Skip (s
sa', s
sb, Maybe l
forall a. Maybe a
Nothing, Bool
False)
        Step s l
Done        -> (s, s, Maybe l, Bool) -> Step (s, s, Maybe l, Bool) a
forall s a. s -> Step s a
Skip (s
sa,  s
sb, Maybe l
forall a. Maybe a
Nothing, Bool
True)

    step (s
sa, s
sb, Maybe l
av, Bool
adone) = do
      Step s r
r <- s -> m (Step s r)
stepb s
sb
      Step (s, s, Maybe l, Bool) a -> m (Step (s, s, Maybe l, Bool) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (s, s, Maybe l, Bool) a -> m (Step (s, s, Maybe l, Bool) a))
-> Step (s, s, Maybe l, Bool) a -> m (Step (s, s, Maybe l, Bool) a)
forall a b. (a -> b) -> a -> b
$ case Step s r
r of
        Yield r
y s
sb' -> a -> (s, s, Maybe l, Bool) -> Step (s, s, Maybe l, Bool) a
forall a s. a -> s -> Step s a
Yield (These l r -> a
f (These l r -> a) -> These l r -> a
forall a b. (a -> b) -> a -> b
$ These l r -> (l -> These l r) -> Maybe l -> These l r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (r -> These l r
forall a b. b -> These a b
That r
y) (l -> r -> These l r
forall a b. a -> b -> These a b
`These` r
y) Maybe l
av)
                             (s
sa, s
sb', Maybe l
forall a. Maybe a
Nothing, Bool
adone)
        Skip s
sb'    -> (s, s, Maybe l, Bool) -> Step (s, s, Maybe l, Bool) a
forall s a. s -> Step s a
Skip (s
sa, s
sb', Maybe l
av, Bool
adone)
        Step s r
Done -> case (Maybe l
av, Bool
adone) of
          (Just l
x, Bool
False) -> a -> (s, s, Maybe l, Bool) -> Step (s, s, Maybe l, Bool) a
forall a s. a -> s -> Step s a
Yield (These l r -> a
f (These l r -> a) -> These l r -> a
forall a b. (a -> b) -> a -> b
$ l -> These l r
forall a b. a -> These a b
This l
x) (s
sa, s
sb, Maybe l
forall a. Maybe a
Nothing, Bool
adone)
          (Maybe l
_, Bool
True)       -> Step (s, s, Maybe l, Bool) a
forall s a. Step s a
Done
          (Maybe l, Bool)
_               -> (s, s, Maybe l, Bool) -> Step (s, s, Maybe l, Bool) a
forall s a. s -> Step s a
Skip (s
sa, s
sb, Maybe l
forall a. Maybe a
Nothing, Bool
False)


instance Expansive V.Vector where
  emapThese :: (These l r -> a) -> Vector l -> Vector r -> Vector a
emapThese = (These l r -> a) -> Vector l -> Vector r -> Vector a
forall l r a. (These l r -> a) -> Vector l -> Vector r -> Vector a
emapThese'
    where
    emapThese' :: (These a b -> c) -> V.Vector a -> V.Vector b -> V.Vector c
    emapThese' :: (These a b -> c) -> Vector a -> Vector b -> Vector c
emapThese' These a b -> c
f Vector a
x Vector b
y = Bundle Vector c -> Vector c
forall (v :: * -> *) a. Vector v a => Bundle v a -> v a
unstream (Bundle Vector c -> Vector c) -> Bundle Vector c -> Vector c
forall a b. (a -> b) -> a -> b
$ (These a b -> c)
-> Bundle Id Vector a -> Bundle Id Vector b -> Bundle Vector c
forall (f :: * -> *) l r a.
Expansive f =>
(These l r -> a) -> f l -> f r -> f a
emapThese These a b -> c
f (Vector a -> Bundle Id Vector a
forall (v :: * -> *) a. Vector v a => v a -> Bundle v a
stream Vector a
x) (Vector b -> Bundle Id Vector b
forall (v :: * -> *) a. Vector v a => v a -> Bundle v a
stream Vector b
y)
  {-# INLINABLE emapThese #-}


instance Expansive IntMap.IntMap where
  unite :: IntMap l -> IntMap r -> IntMap (These l r)
unite IntMap l
m IntMap r
n = (These l r -> These l r -> These l r)
-> IntMap (These l r) -> IntMap (These l r) -> IntMap (These l r)
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith These l r -> These l r -> These l r
forall a b a b. These a b -> These a b -> These a b
merge ((l -> These l r) -> IntMap l -> IntMap (These l r)
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map l -> These l r
forall a b. a -> These a b
This IntMap l
m) ((r -> These l r) -> IntMap r -> IntMap (These l r)
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map r -> These l r
forall a b. b -> These a b
That IntMap r
n)
    where merge :: These a b -> These a b -> These a b
merge (This a
a) (That b
b) = a -> b -> These a b
forall a b. a -> b -> These a b
These a
a b
b
          merge These a b
_ These a b
_               = [Char] -> These a b
forall a. HasCallStack => [Char] -> a
error [Char]
"kimpossible"
  {-# INLINE unite #-}


instance Ord k => Expansive (Map.Map k) where
  unite :: Map k l -> Map k r -> Map k (These l r)
unite Map k l
m Map k r
n = (These l r -> These l r -> These l r)
-> Map k (These l r) -> Map k (These l r) -> Map k (These l r)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith These l r -> These l r -> These l r
forall a b a b. These a b -> These a b -> These a b
merge ((l -> These l r) -> Map k l -> Map k (These l r)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map l -> These l r
forall a b. a -> These a b
This Map k l
m) ((r -> These l r) -> Map k r -> Map k (These l r)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map r -> These l r
forall a b. b -> These a b
That Map k r
n)
    where merge :: These a b -> These a b -> These a b
merge (This a
a) (That b
b) = a -> b -> These a b
forall a b. a -> b -> These a b
These a
a b
b
          merge These a b
_ These a b
_               = [Char] -> These a b
forall a. HasCallStack => [Char] -> a
error [Char]
"kimpossible"
  {-# INLINE unite #-}


instance (Functor f, Functor g, Expansive f, Expansive g)
  => Expansive (Product f g) where
  unite :: Product f g l -> Product f g r -> Product f g (These l r)
unite (Pair f l
a g l
b) (Pair f r
c g r
d) = f (These l r) -> g (These l r) -> Product f g (These l r)
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (f l -> f r -> f (These l r)
forall (f :: * -> *) l r.
Expansive f =>
f l -> f r -> f (These l r)
unite f l
a f r
c) (g l -> g r -> g (These l r)
forall (f :: * -> *) l r.
Expansive f =>
f l -> f r -> f (These l r)
unite g l
b g r
d)
  {-# INLINE unite #-}