module Data.Bimatchable(
  Bimatchable(..),
  bimapRecovered,
  eq2Default,
  liftEq2Default
) where

import           Control.Applicative

import           Data.Bifunctor
import           Data.Functor.Classes

import           Data.Tagged

-- | Containers that allows exact structural matching of two containers.
--   
--   @Bimatchable@ is 'Bifunctor'-version of 'Matchable'.
--   It can compare and zip containers with two parameters.
class (Eq2 t, Bifunctor t) => Bimatchable t where
  {- |
  
  'bizipMatch' is to 'Data.Matchable.zipMatch' what 'bimap' is to 'fmap'.
  
  Decides if two structures match exactly. If they match, return zipped version of them.

  ==== Law

  Forall @x :: t a b@, @y :: t a' b'@, @z :: t (a,a') (b,b')@,
  
  > bizipMatch x y = Just z
  
  holds if and only if both of
  
  > x = bimap fst fst z
  > y = bimap snd snd z
  
  holds. Otherwise, @bizipMatch x y = Nothing@.
  
  ==== Example
  >>> bizipMatch (Left 1) (Left 'a')
  Just (Left (1,'a'))
  >>> bizipMatch (Right 1) (Right False)
  Just (Right (1,False))
  >>> bizipMatch (Left 1) (Right False)
  Nothing
  -}
  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' is to 'Data.Matchable.zipMatchWith' what 'bimap' is to 'fmap'.
  
  Match two structures. If they match, zip them with given functions
  @(a -> a' -> Maybe a'')@ and @(b -> b -> Maybe b'')@.
  Passed functions can make whole match failby returning @Nothing@.

  ==== Law

  For any

  > x :: t a b
  > y :: t a' b'
  > f :: a -> a' -> Maybe a''
  > g :: b -> b' -> Maybe b''
  
  'bizipMatchWith' must satisfy the following.

      - If there is a pair @(z :: t (a,a') (b,b'), w :: t a'' b'')@ such that
        fulfills all of the following three conditions, then
        @bizipMatchWith f g x y = Just w@.

            1. @x = bimap fst fst z@
            2. @y = bimap snd snd z@
            3. @bimap (uncurry f) (uncurry g) z = bimap Just Just w@

      - If there are no such pair, @bizipMatchWith f g x y = Nothing@.
  
  -}
  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