{- |
Name: Data.Merge
Description: To describe merging of data types.
License: MIT
Copyright: Samuel Schlesinger 2021 (c)
-}
{-# LANGUAGE BlockArguments #-}
module Data.Merge where

import Control.Monad (join)
import Control.Applicative (Alternative (..))
import Data.Profunctor (Profunctor (..))

-- | Describes the merging of two values of the same type
-- into some other type. Represented as a 'Maybe' valued
-- function, one can also think of this as a predicate
-- showing which pairs of values can be merged in this way.
--
-- > data Example = Whatever { a :: Int, b :: Maybe Bool }
-- > mergeExamples :: Merge Example Example
-- > mergeExamples = Example <$> required a <*> optional b
newtype Merge x a = Merge { Merge x a -> x -> x -> Maybe a
runMerge :: x -> x -> Maybe a }

-- | The most general combinator for constructing 'Merge's.
merge :: (x -> x -> Maybe a) -> Merge x a
merge :: (x -> x -> Maybe a) -> Merge x a
merge = (x -> x -> Maybe a) -> Merge x a
forall x a. (x -> x -> Maybe a) -> Merge x a
Merge

instance Profunctor Merge where
  dimap :: (a -> b) -> (c -> d) -> Merge b c -> Merge a d
dimap a -> b
l c -> d
r (Merge b -> b -> Maybe c
f) = (a -> a -> Maybe d) -> Merge a d
forall x a. (x -> x -> Maybe a) -> Merge x a
Merge \a
x a
x' -> c -> d
r (c -> d) -> Maybe c -> Maybe d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> b -> Maybe c
f (a -> b
l a
x) (a -> b
l a
x')

instance Functor (Merge x) where
  fmap :: (a -> b) -> Merge x a -> Merge x b
fmap = (a -> b) -> Merge x a -> Merge x b
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap

instance Applicative (Merge x) where
  pure :: a -> Merge x a
pure a
x = (x -> x -> Maybe a) -> Merge x a
forall x a. (x -> x -> Maybe a) -> Merge x a
Merge (\x
_ x
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x)
  Merge x (a -> b)
fa <*> :: Merge x (a -> b) -> Merge x a -> Merge x b
<*> Merge x a
a = (x -> x -> Maybe b) -> Merge x b
forall x a. (x -> x -> Maybe a) -> Merge x a
Merge \x
x x
x' -> Merge x (a -> b) -> x -> x -> Maybe (a -> b)
forall x a. Merge x a -> x -> x -> Maybe a
runMerge Merge x (a -> b)
fa x
x x
x' Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Merge x a -> x -> x -> Maybe a
forall x a. Merge x a -> x -> x -> Maybe a
runMerge Merge x a
a x
x x
x'

instance Alternative (Merge x) where
  empty :: Merge x a
empty = (x -> x -> Maybe a) -> Merge x a
forall x a. (x -> x -> Maybe a) -> Merge x a
Merge \x
_ x
_ -> Maybe a
forall a. Maybe a
Nothing
  Merge x -> x -> Maybe a
f <|> :: Merge x a -> Merge x a -> Merge x a
<|> Merge x -> x -> Maybe a
g = (x -> x -> Maybe a) -> Merge x a
forall x a. (x -> x -> Maybe a) -> Merge x a
Merge \x
x x
x' -> x -> x -> Maybe a
f x
x x
x' Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> x -> x -> Maybe a
g x
x x
x'

instance Monad (Merge x) where
  Merge x a
a >>= :: Merge x a -> (a -> Merge x b) -> Merge x b
>>= a -> Merge x b
f = (x -> x -> Maybe b) -> Merge x b
forall x a. (x -> x -> Maybe a) -> Merge x a
Merge \x
x x
x' -> Maybe (Maybe b) -> Maybe b
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe b) -> Maybe b) -> Maybe (Maybe b) -> Maybe b
forall a b. (a -> b) -> a -> b
$ (Merge x b -> Maybe b) -> Maybe (Merge x b) -> Maybe (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Merge x b
b -> Merge x b -> x -> x -> Maybe b
forall x a. Merge x a -> x -> x -> Maybe a
runMerge Merge x b
b x
x x
x') (Maybe (Merge x b) -> Maybe (Maybe b))
-> Maybe (Merge x b) -> Maybe (Maybe b)
forall a b. (a -> b) -> a -> b
$ (a -> Merge x b) -> Maybe a -> Maybe (Merge x b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Merge x b
f (Maybe a -> Maybe (Merge x b)) -> Maybe a -> Maybe (Merge x b)
forall a b. (a -> b) -> a -> b
$ Merge x a -> x -> x -> Maybe a
forall x a. Merge x a -> x -> x -> Maybe a
runMerge Merge x a
a x
x x
x'

instance Semigroup a => Semigroup (Merge x a) where
  Merge x a
a <> :: Merge x a -> Merge x a -> Merge x a
<> Merge x a
b = (x -> x -> Maybe a) -> Merge x a
forall x a. (x -> x -> Maybe a) -> Merge x a
Merge \x
x x
x' -> Merge x a -> x -> x -> Maybe a
forall x a. Merge x a -> x -> x -> Maybe a
runMerge Merge x a
a x
x x
x' Maybe a -> Maybe a -> Maybe a
forall a. Semigroup a => a -> a -> a
<> Merge x a -> x -> x -> Maybe a
forall x a. Merge x a -> x -> x -> Maybe a
runMerge Merge x a
b x
x x
x'

instance Semigroup a => Monoid (Merge x a) where
  mempty :: Merge x a
mempty = (x -> x -> Maybe a) -> Merge x a
forall x a. (x -> x -> Maybe a) -> Merge x a
Merge \x
_ x
_ -> Maybe a
forall a. Monoid a => a
mempty  

-- | Meant to be used to merge optional fields in a record.
optional :: Eq a => (x -> Maybe a) -> Merge x (Maybe a)
optional :: (x -> Maybe a) -> Merge x (Maybe a)
optional x -> Maybe a
f = (x -> x -> Maybe (Maybe a)) -> Merge x (Maybe a)
forall x a. (x -> x -> Maybe a) -> Merge x a
Merge (\x
x x
x' -> Maybe a -> Maybe a -> Maybe (Maybe a)
forall a. Eq a => Maybe a -> Maybe a -> Maybe (Maybe a)
go (x -> Maybe a
f x
x) (x -> Maybe a
f x
x'))  where
  go :: Maybe a -> Maybe a -> Maybe (Maybe a)
go (Just a
x) (Just a
x')
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x' = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
    | Bool
otherwise = Maybe (Maybe a)
forall a. Maybe a
Nothing
  go Maybe a
Nothing (Just a
x) = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
  go (Just a
x) Maybe a
Nothing = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
  go Maybe a
Nothing Maybe a
Nothing = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
forall a. Maybe a
Nothing

-- | Meant to be used to merge required fields in a record.
required :: Eq a => (x -> a) -> Merge x a
required :: (x -> a) -> Merge x a
required x -> a
f = (x -> x -> Maybe a) -> Merge x a
forall x a. (x -> x -> Maybe a) -> Merge x a
Merge (\x
x x
x' -> a -> a -> Maybe a
forall a. Eq a => a -> a -> Maybe a
go (x -> a
f x
x) (x -> a
f x
x'))  where
  go :: a -> a -> Maybe a
go a
x a
x'
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x' = a -> Maybe a
forall a. a -> Maybe a
Just a
x
    | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing