Generic mappend for product-like types using Profunctor analogue of both Decidable and Applicative.

PDividing.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module PDividing where

import Data.Foldable
import Data.Monoid
import Data.Profunctor
import Data.Proxy
import Data.Void
import GHC.Generics

-- | Profunctor analogue of Divisible and Applicative.
class Profunctor p => PDivisible p where
  pconquer  :: b -> p a b
  pdivide   :: (a -> (b, c)) -> (x -> y -> z) -> p b x -> p c y -> p a z

-- | Profunctor analogue of Decidable and Alternative.
class PDivisible p => PDecidable p where
  plose   :: (a -> Void) -> p a b
  pchoose :: (a -> Either b c) -> p b x -> p c x -> p a x

-- | This class allows generic deriving mechanism for methods
-- that require both deconstructing and constructing values.
-- This class only works for product-like types.
class (Generic a, GPDividing q (Rep a)) => PDividing q a where
  pdividing :: PDivisible f => p q -> (forall b. q b => f b b) -> f a a

instance (Generic a, GPDividing q (Rep a)) => PDividing q a where
  pdividing p f = dimap from to $ gpdividing p f

class GPDividing q t where
  gpdividing :: PDivisible f => p q -> (forall b. q b => f b b) -> f (t a) (t a)

instance GPDividing q U1 where
  gpdividing _ _ = pconquer U1

instance (GPDividing q f, GPDividing q g) => GPDividing q (f :*: g) where
  gpdividing p f = pdivide (\(x :*: y) -> (x, y)) (:*:) (gpdividing p f) (gpdividing p f)

instance q a => GPDividing q (K1 i a) where
  gpdividing _ = dimap unK1 K1

instance GPDividing q f => GPDividing q (M1 i c f) where
  gpdividing p f = dimap unM1 M1 $ gpdividing p f

-- | Functions are Divisible in argument type and Applicative in return type.
instance PDivisible (->) where
  pconquer = const
  pdivide f g k h = \a ->
    let (b, c) = f a
        zk = k b
        zh = h c
    in g zk zh

instance PDecidable (->) where
  plose f = absurd . f
  pchoose f k h = \x -> case f x of
    Left  b -> k b
    Right c -> h c

-- | Binary operation.
newtype M a b = M { getM :: a -> a -> b }

instance Profunctor M where
  dimap f g (M k) = M (\x y -> g (k (f x) (f y)))

instance PDivisible M where
  pconquer x = M (\_ _ -> x)
  pdivide f g (M k) (M h) = M $ \x y ->
    let (bx, cx) = f x
        (by, cy) = f y
        zk = k bx by
        zh = h cx cy
    in g zk zh

-- | Generic mappend for product-like types.
gmappend :: PDividing Monoid a => a -> a -> a
gmappend = getM $ pdividing (Proxy :: Proxy Monoid) (M mappend)

-- | Generic abs for product-like types.
gabs :: PDividing Num a => a -> a
gabs = pdividing (Proxy :: Proxy Num) abs

newtype FlipConst a b = FlipConst { getFlipConst :: b }

instance Profunctor FlipConst where
  dimap _ g (FlipConst x) = FlipConst (g x)

instance PDivisible FlipConst where
  pconquer = FlipConst
  pdivide _ g (FlipConst x) (FlipConst y) = FlipConst (g x y)

gmempty :: PDividing Monoid a => a
gmempty = getFlipConst $ pdividing (Proxy :: Proxy Monoid) (FlipConst mempty)