{- | If a type derives 'Generic' and all of its fields have 'PartialSemigroup'
instances, you can get a 'PartialSemigroup' for free using
'genericPartialSemigroupOp'.

== Example

For this demonstration we'll define a contrived example type @T@ with two
constructors, @A@ and @B@.

>>> data T = A String (Either String String) | B String deriving (Generic, Show)

And then define its 'PartialSemigroup' instance using
'genericPartialSemigroupOp'.

>>> instance PartialSemigroup T where (<>?) = genericPartialSemigroupOp

This gives us an implementation of '<>?' which combines values only if they have
the same structure.

>>> A "s" (Left "x") <>? A "t" (Left "y")
Just (A "st" (Left "xy"))

>>> B "x" <>? B "y"
Just (B "xy")

For values that do /not/ have the same structure, '<>?' produces 'Nothing'.

>>> A "s" (Left "x") <>? A "t" (Right "y")
Nothing

>>> A "x" (Left "y") <>? B "z"
Nothing

-}

module Data.PartialSemigroup.Generics
  (
  -- * The generic PartialSemigroup operator
    genericPartialSemigroupOp

  -- * Implementation details
  , PartialSemigroupRep (..)

  -- * Re-exports
  , Generic
  , PartialSemigroup (..)

  ) where

import Data.PartialSemigroup

-- base
import Control.Applicative ((<$>), (<*>))
import Data.Maybe          (Maybe (..))
import GHC.Generics        ((:*:) (..), (:+:) (..), Generic, K1 (..), M1 (..),
                            Rep, from, to)

{- $setup

>>> :set -XDeriveGeneric

>>> import Data.Either (Either (..))
>>> import Data.String (String)
>>> import Text.Show (Show)

-}

genericPartialSemigroupOp :: (Generic a, PartialSemigroupRep (Rep a))
  => a -> a -> Maybe a
genericPartialSemigroupOp :: forall a.
(Generic a, PartialSemigroupRep (Rep a)) =>
a -> a -> Maybe a
genericPartialSemigroupOp a
x a
y =
  forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) a.
PartialSemigroupRep rep =>
rep a -> rep a -> Maybe (rep a)
repPartialSemigroupOp (forall a x. Generic a => a -> Rep a x
from a
x) (forall a x. Generic a => a -> Rep a x
from a
y)

{- |

The class of generic type 'Rep's for which we can automatically derive
'PartialSemigroup':

  * 'K1' - a single value
  * 'M1' - a value with some additional metadata (which we simply discard)
  * ':+:' - sum types
  * ':*:' - product types

-}

class PartialSemigroupRep rep
  where
    repPartialSemigroupOp :: rep a -> rep a -> Maybe (rep a)

instance PartialSemigroup a => PartialSemigroupRep (K1 i a)
  where
    repPartialSemigroupOp :: forall a. K1 i a a -> K1 i a a -> Maybe (K1 i a a)
repPartialSemigroupOp (K1 a
x) (K1 a
y) = forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a
x forall a. PartialSemigroup a => a -> a -> Maybe a
<>? a
y)

instance PartialSemigroupRep rep => PartialSemigroupRep (M1 i meta rep)
  where
    repPartialSemigroupOp :: forall a.
M1 i meta rep a -> M1 i meta rep a -> Maybe (M1 i meta rep a)
repPartialSemigroupOp (M1 rep a
x) (M1 rep a
y) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) a.
PartialSemigroupRep rep =>
rep a -> rep a -> Maybe (rep a)
repPartialSemigroupOp rep a
x rep a
y

instance (PartialSemigroupRep rep1, PartialSemigroupRep rep2) =>
  PartialSemigroupRep (rep1 :*: rep2)
  where
    repPartialSemigroupOp :: forall a.
(:*:) rep1 rep2 a -> (:*:) rep1 rep2 a -> Maybe ((:*:) rep1 rep2 a)
repPartialSemigroupOp (rep1 a
x1 :*: rep2 a
x2) (rep1 a
y1 :*: rep2 a
y2) =
      forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) a.
PartialSemigroupRep rep =>
rep a -> rep a -> Maybe (rep a)
repPartialSemigroupOp rep1 a
x1 rep1 a
y1
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (rep :: * -> *) a.
PartialSemigroupRep rep =>
rep a -> rep a -> Maybe (rep a)
repPartialSemigroupOp rep2 a
x2 rep2 a
y2

instance (PartialSemigroupRep rep1, PartialSemigroupRep rep2) =>
  PartialSemigroupRep (rep1 :+: rep2)
  where
    repPartialSemigroupOp :: forall a.
(:+:) rep1 rep2 a -> (:+:) rep1 rep2 a -> Maybe ((:+:) rep1 rep2 a)
repPartialSemigroupOp (L1 rep1 a
x) (L1 rep1 a
y) = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) a.
PartialSemigroupRep rep =>
rep a -> rep a -> Maybe (rep a)
repPartialSemigroupOp rep1 a
x rep1 a
y
    repPartialSemigroupOp (R1 rep2 a
x) (R1 rep2 a
y) = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) a.
PartialSemigroupRep rep =>
rep a -> rep a -> Maybe (rep a)
repPartialSemigroupOp rep2 a
x rep2 a
y
    repPartialSemigroupOp (:+:) rep1 rep2 a
_ (:+:) rep1 rep2 a
_ = forall a. Maybe a
Nothing