{-# LANGUAGE BlockArguments #-}
module Data.Merge where
import Control.Monad (join)
import Control.Applicative (Alternative (..))
import Data.Profunctor (Profunctor (..))
newtype Merge x a = Merge { Merge x a -> x -> x -> Maybe a
runMerge :: x -> x -> Maybe a }
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
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
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