{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
module Data.PartialSemigroup.Generics
(
genericPartialSemigroupOp
, PartialSemigroupRep (..)
, Generic
, PartialSemigroup (..)
) where
import Data.PartialSemigroup
import Control.Applicative ((<$>), (<*>))
import Data.Maybe (Maybe (..))
import GHC.Generics ((:*:) (..), (:+:) (..), Generic, K1 (..), M1 (..),
Rep, from, to)
genericPartialSemigroupOp :: (Generic a, PartialSemigroupRep (Rep a))
=> a -> a -> Maybe a
genericPartialSemigroupOp x y =
to <$> repPartialSemigroupOp (from x) (from y)
class PartialSemigroupRep rep
where
repPartialSemigroupOp :: rep a -> rep a -> Maybe (rep a)
instance PartialSemigroup a => PartialSemigroupRep (K1 i a)
where
repPartialSemigroupOp (K1 x) (K1 y) = K1 <$> (x <>? y)
instance PartialSemigroupRep rep => PartialSemigroupRep (M1 i meta rep)
where
repPartialSemigroupOp (M1 x) (M1 y) = M1 <$> repPartialSemigroupOp x y
instance (PartialSemigroupRep rep1, PartialSemigroupRep rep2) =>
PartialSemigroupRep (rep1 :*: rep2)
where
repPartialSemigroupOp (x1 :*: x2) (y1 :*: y2) =
(:*:) <$> repPartialSemigroupOp x1 y1
<*> repPartialSemigroupOp x2 y2
instance (PartialSemigroupRep rep1, PartialSemigroupRep rep2) =>
PartialSemigroupRep (rep1 :+: rep2)
where
repPartialSemigroupOp (L1 x) (L1 y) = L1 <$> repPartialSemigroupOp x y
repPartialSemigroupOp (R1 x) (R1 y) = R1 <$> repPartialSemigroupOp x y
repPartialSemigroupOp _ _ = Nothing