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 = (a -> a' -> Maybe (a, a'))
-> (b -> b' -> Maybe (b, b'))
-> t a b
-> t a' b'
-> Maybe (t (a, a') (b, b'))
forall a a' a'' b b' b''.
(a -> a' -> Maybe a'')
-> (b -> b' -> Maybe b'') -> t a b -> t a' b' -> Maybe (t a'' b'')
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 (a, a')) -> a -> a' -> Maybe (a, a')
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (a, a') -> Maybe (a, a')
forall a. a -> Maybe a
Just) (((b, b') -> Maybe (b, b')) -> b -> b' -> Maybe (b, b')
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (b, b') -> Maybe (b, b')
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')  = a'' -> Either a'' b''
forall a b. a -> Either a b
Left (a'' -> Either a'' b'') -> Maybe a'' -> Maybe (Either a'' b'')
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') = b'' -> Either a'' b''
forall a b. b -> Either a b
Right (b'' -> Either a'' b'') -> Maybe b'' -> Maybe (Either a'' b'')
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'
_          = Maybe (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') = ((a, a'), (b, b')) -> Maybe ((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') = (,) (a'' -> b'' -> (a'', b''))
-> Maybe a'' -> Maybe (b'' -> (a'', b''))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> a' -> Maybe a''
u a
a a'
a' Maybe (b'' -> (a'', b'')) -> Maybe b'' -> Maybe (a'', b'')
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
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') = Const (a, a') (b, b') -> Maybe (Const (a, a') (b, b'))
forall a. a -> Maybe a
Just ((a, a') -> Const (a, a') (b, b')
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') = a'' -> Const a'' b''
forall {k} a (b :: k). a -> Const a b
Const (a'' -> Const a'' b'') -> Maybe a'' -> Maybe (Const a'' b'')
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') = Tagged (a, a') (b, b') -> Maybe (Tagged (a, a') (b, b'))
forall a. a -> Maybe a
Just ((b, b') -> Tagged (a, a') (b, b')
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') = b'' -> Tagged a'' b''
forall {k} (s :: k) b. b -> Tagged s b
Tagged (b'' -> Tagged a'' b'') -> Maybe b'' -> Maybe (Tagged a'' b'')
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 (a -> a -> Maybe a')
-> (b -> b -> Maybe b') -> t a b -> t a b -> Maybe (t a' b')
forall a a' a'' b b' b''.
(a -> a' -> Maybe a'')
-> (b -> b' -> Maybe b'') -> t a b -> t a' b' -> Maybe (t a'' b'')
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 -> Maybe a') -> a -> a -> Maybe a'
forall a b. a -> b -> a
const (a' -> Maybe a'
forall a. a -> Maybe a
Just (a' -> Maybe a') -> (a -> a') -> a -> Maybe a'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a'
f)) ((b -> Maybe b') -> b -> b -> Maybe b'
forall a b. a -> b -> a
const (b' -> Maybe b'
forall a. a -> Maybe a
Just (b' -> Maybe b') -> (b -> b') -> b -> Maybe b'
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 -> [Char] -> t a' b'
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 = (a -> a -> Bool) -> (b -> b -> Bool) -> t a b -> t a b -> Bool
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
forall a. Eq a => a -> a -> Bool
(==) b -> b -> 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 (a -> a' -> Maybe ())
-> (b -> b' -> Maybe ()) -> t a b -> t a' b' -> Maybe (t () ())
forall a a' a'' b b' b''.
(a -> a' -> Maybe a'')
-> (b -> b' -> Maybe b'') -> t a b -> t a' b' -> Maybe (t a'' b'')
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 () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing
        v :: b -> b' -> Maybe ()
v b
b b'
b' = if b -> b' -> Bool
pb b
b b'
b' then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing