module Data.Bimatchable(
Bimatchable(..),
bimapRecovered,
eq2Default,
liftEq2Default
) where
import Control.Applicative
import Data.Bifunctor
import Data.Functor.Classes
import Data.Tagged
class (Eq2 t, Bifunctor t) => Bimatchable t where
bizipMatch :: t a b -> t a' b' -> Maybe (t (a,a') (b,b'))
bizipMatch = forall (t :: * -> * -> *) a a' a'' b b' b''.
Bimatchable t =>
(a -> a' -> Maybe a'')
-> (b -> b' -> Maybe b'') -> t a b -> t a' b' -> Maybe (t a'' b'')
bizipMatchWith (forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a. a -> Maybe a
Just) (forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a. a -> Maybe a
Just)
bizipMatchWith :: (a -> a' -> Maybe a'')
-> (b -> b' -> Maybe b'')
-> t a b -> t a' b' -> Maybe (t a'' b'')
{-# MINIMAL bizipMatchWith #-}
instance Bimatchable Either where
bizipMatchWith :: forall a a' a'' b b' b''.
(a -> a' -> Maybe a'')
-> (b -> b' -> Maybe b'')
-> Either a b
-> Either a' b'
-> Maybe (Either a'' b'')
bizipMatchWith a -> a' -> Maybe a''
u b -> b' -> Maybe b''
_ (Left a
a) (Left a'
a') = forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> a' -> Maybe a''
u a
a a'
a'
bizipMatchWith a -> a' -> Maybe a''
_ b -> b' -> Maybe b''
v (Right b
b) (Right b'
b') = forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> b' -> Maybe b''
v b
b b'
b'
bizipMatchWith a -> a' -> Maybe a''
_ b -> b' -> Maybe b''
_ Either a b
_ Either a' b'
_ = forall a. Maybe a
Nothing
instance Bimatchable (,) where
bizipMatch :: forall a b a' b'. (a, b) -> (a', b') -> Maybe ((a, a'), (b, b'))
bizipMatch (a
a, b
b) (a'
a', b'
b') = forall a. a -> Maybe a
Just ((a
a, a'
a'), (b
b, b'
b'))
bizipMatchWith :: forall a a' a'' b b' b''.
(a -> a' -> Maybe a'')
-> (b -> b' -> Maybe b'') -> (a, b) -> (a', b') -> Maybe (a'', b'')
bizipMatchWith a -> a' -> Maybe a''
u b -> b' -> Maybe b''
v (a
a, b
b) (a'
a', b'
b') = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> a' -> Maybe a''
u a
a a'
a' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> b' -> Maybe b''
v b
b b'
b'
instance Bimatchable Const where
bizipMatch :: forall a b a' b'.
Const a b -> Const a' b' -> Maybe (Const (a, a') (b, b'))
bizipMatch (Const a
a) (Const a'
a') = forall a. a -> Maybe a
Just (forall {k} a (b :: k). a -> Const a b
Const (a
a, a'
a'))
bizipMatchWith :: forall a a' a'' b b' b''.
(a -> a' -> Maybe a'')
-> (b -> b' -> Maybe b'')
-> Const a b
-> Const a' b'
-> Maybe (Const a'' b'')
bizipMatchWith a -> a' -> Maybe a''
u b -> b' -> Maybe b''
_ (Const a
a) (Const a'
a') = forall {k} a (b :: k). a -> Const a b
Const forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> a' -> Maybe a''
u a
a a'
a'
instance Bimatchable Tagged where
bizipMatch :: forall a b a' b'.
Tagged a b -> Tagged a' b' -> Maybe (Tagged (a, a') (b, b'))
bizipMatch (Tagged b
b) (Tagged b'
b') = forall a. a -> Maybe a
Just (forall {k} (s :: k) b. b -> Tagged s b
Tagged (b
b, b'
b'))
bizipMatchWith :: forall a a' a'' b b' b''.
(a -> a' -> Maybe a'')
-> (b -> b' -> Maybe b'')
-> Tagged a b
-> Tagged a' b'
-> Maybe (Tagged a'' b'')
bizipMatchWith a -> a' -> Maybe a''
_ b -> b' -> Maybe b''
v (Tagged b
b) (Tagged b'
b') = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> b' -> Maybe b''
v b
b b'
b'
bimapRecovered :: (Bimatchable t)
=> (a -> a') -> (b -> b') -> t a b -> t a' b'
bimapRecovered :: forall (t :: * -> * -> *) a a' b b'.
Bimatchable t =>
(a -> a') -> (b -> b') -> t a b -> t a' b'
bimapRecovered a -> a'
f b -> b'
g t a b
tab =
case forall (t :: * -> * -> *) a a' a'' b b' b''.
Bimatchable t =>
(a -> a' -> Maybe a'')
-> (b -> b' -> Maybe b'') -> t a b -> t a' b' -> Maybe (t a'' b'')
bizipMatchWith (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a'
f)) (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b'
g)) t a b
tab t a b
tab of
Maybe (t a' b')
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"bimapRecovered: Unlawful instance of Bimatchable"
Just t a' b'
r -> t a' b'
r
eq2Default :: (Bimatchable t, Eq a, Eq b)
=> t a b -> t a b -> Bool
eq2Default :: forall (t :: * -> * -> *) a b.
(Bimatchable t, Eq a, Eq b) =>
t a b -> t a b -> Bool
eq2Default = forall (t :: * -> * -> *) a a' b b'.
Bimatchable t =>
(a -> a' -> Bool) -> (b -> b' -> Bool) -> t a b -> t a' b' -> Bool
liftEq2Default forall a. Eq a => a -> a -> Bool
(==) forall a. Eq a => a -> a -> Bool
(==)
liftEq2Default :: (Bimatchable t)
=> (a -> a' -> Bool)
-> (b -> b' -> Bool)
-> t a b -> t a' b' -> Bool
liftEq2Default :: forall (t :: * -> * -> *) a a' b b'.
Bimatchable t =>
(a -> a' -> Bool) -> (b -> b' -> Bool) -> t a b -> t a' b' -> Bool
liftEq2Default a -> a' -> Bool
pa b -> b' -> Bool
pb t a b
tab t a' b'
tab' =
case forall (t :: * -> * -> *) a a' a'' b b' b''.
Bimatchable t =>
(a -> a' -> Maybe a'')
-> (b -> b' -> Maybe b'') -> t a b -> t a' b' -> Maybe (t a'' b'')
bizipMatchWith a -> a' -> Maybe ()
u b -> b' -> Maybe ()
v t a b
tab t a' b'
tab' of
Maybe (t () ())
Nothing -> Bool
False
Just t () ()
_ -> Bool
True
where u :: a -> a' -> Maybe ()
u a
a a'
a' = if a -> a' -> Bool
pa a
a a'
a' then forall a. a -> Maybe a
Just () else forall a. Maybe a
Nothing
v :: b -> b' -> Maybe ()
v b
b b'
b' = if b -> b' -> Bool
pb b
b b'
b' then forall a. a -> Maybe a
Just () else forall a. Maybe a
Nothing