-- | A class to match term structures

{-# LANGUAGE FlexibleContexts #-}

module Hyper.Class.ZipMatch
    ( ZipMatch(..)
    , zipMatch2
    , zipMatchA
    , zipMatch_, zipMatch1_
    ) where

import GHC.Generics
import Hyper.Class.Foldable (HFoldable, htraverse_, htraverse1_)
import Hyper.Class.Functor (HFunctor(..))
import Hyper.Class.Nodes (HNodes(..), HWitness)
import Hyper.Class.Traversable (HTraversable, htraverse)
import Hyper.Type (type (#))
import Hyper.Type.Pure (Pure(..), _Pure)

import Hyper.Internal.Prelude

-- | A class to match term structures.
--
-- Similar to a partial version of 'Hyper.Class.Apply.Apply' but the semantics are different -
-- when the terms contain plain values, 'Hyper.Class.Apply.hzip' would append them,
-- but 'zipMatch' would compare them and only produce a result if they match.
--
-- The @TemplateHaskell@ generators 'Hyper.TH.Apply.makeHApply' and 'Hyper.TH.ZipMatch.makeZipMatch'
-- create the instances according to these semantics.
class ZipMatch h where
    -- | Compare two structures
    --
    -- >>> zipMatch (NewPerson p0) (NewPerson p1)
    -- Just (NewPerson (Pair p0 p1))
    -- >>> zipMatch (NewPerson p) (NewCake c)
    -- Nothing
    zipMatch :: h # p -> h # q -> Maybe (h # (p :*: q))
    default zipMatch ::
        (Generic1 h, ZipMatch (Rep1 h)) =>
        h # p -> h # q -> Maybe (h # (p :*: q))
    zipMatch h # p
x =
        ((Rep1 h # (p :*: q)) -> h # (p :*: q))
-> Maybe (Rep1 h # (p :*: q)) -> Maybe (h # (p :*: q))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rep1 h # (p :*: q)) -> h # (p :*: q)
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Maybe (Rep1 h # (p :*: q)) -> Maybe (h # (p :*: q)))
-> ((h # q) -> Maybe (Rep1 h # (p :*: q)))
-> (h # q)
-> Maybe (h # (p :*: q))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rep1 h # p) -> (Rep1 h # q) -> Maybe (Rep1 h # (p :*: q))
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch ((h # p) -> Rep1 h # p
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 h # p
x) ((Rep1 h # q) -> Maybe (Rep1 h # (p :*: q)))
-> ((h # q) -> Rep1 h # q) -> (h # q) -> Maybe (Rep1 h # (p :*: q))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (h # q) -> Rep1 h # q
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1

instance ZipMatch Pure where
    {-# INLINE zipMatch #-}
    zipMatch :: (Pure # p) -> (Pure # q) -> Maybe (Pure # (p :*: q))
zipMatch (Pure 'AHyperType p :# Pure
x) (Pure 'AHyperType q :# Pure
y) = Tagged ((p :*: q) # Pure) (Identity ((p :*: q) # Pure))
-> Tagged (Pure # (p :*: q)) (Identity (Pure # (p :*: q)))
forall (h :: AHyperType -> *) (j :: AHyperType -> *).
Iso (Pure # h) (Pure # j) (h # Pure) (j # Pure)
_Pure (Tagged ((p :*: q) # Pure) (Identity ((p :*: q) # Pure))
 -> Tagged (Pure # (p :*: q)) (Identity (Pure # (p :*: q))))
-> ((p :*: q) # Pure) -> Pure # (p :*: q)
forall t b. AReview t b -> b -> t
# (p ('AHyperType Pure)
'AHyperType p :# Pure
x p ('AHyperType Pure) -> q ('AHyperType Pure) -> (p :*: q) # Pure
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: q ('AHyperType Pure)
'AHyperType q :# Pure
y) (Pure # (p :*: q))
-> ((Pure # (p :*: q)) -> Maybe (Pure # (p :*: q)))
-> Maybe (Pure # (p :*: q))
forall a b. a -> (a -> b) -> b
& (Pure # (p :*: q)) -> Maybe (Pure # (p :*: q))
forall a. a -> Maybe a
Just

instance Eq a => ZipMatch (Const a) where
    {-# INLINE zipMatch #-}
    zipMatch :: (Const a # p) -> (Const a # q) -> Maybe (Const a # (p :*: q))
zipMatch (Const a
x) (Const a
y) = a -> Const a # (p :*: q)
forall k a (b :: k). a -> Const a b
Const a
x (Const a # (p :*: q)) -> Maybe () -> Maybe (Const a # (p :*: q))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y)

instance (ZipMatch a, ZipMatch b) => ZipMatch (a :*: b) where
    {-# INLINE zipMatch #-}
    zipMatch :: ((a :*: b) # p) -> ((a :*: b) # q) -> Maybe ((a :*: b) # (p :*: q))
zipMatch (a ('AHyperType p)
a0 :*: b ('AHyperType p)
b0) (a ('AHyperType q)
a1 :*: b ('AHyperType q)
b1) = a ('AHyperType (p :*: q))
-> b ('AHyperType (p :*: q)) -> (a :*: b) # (p :*: q)
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a ('AHyperType (p :*: q))
 -> b ('AHyperType (p :*: q)) -> (a :*: b) # (p :*: q))
-> Maybe (a ('AHyperType (p :*: q)))
-> Maybe (b ('AHyperType (p :*: q)) -> (a :*: b) # (p :*: q))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a ('AHyperType p)
-> a ('AHyperType q) -> Maybe (a ('AHyperType (p :*: q)))
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch a ('AHyperType p)
a0 a ('AHyperType q)
a1 Maybe (b ('AHyperType (p :*: q)) -> (a :*: b) # (p :*: q))
-> Maybe (b ('AHyperType (p :*: q)))
-> Maybe ((a :*: b) # (p :*: q))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b ('AHyperType p)
-> b ('AHyperType q) -> Maybe (b ('AHyperType (p :*: q)))
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch b ('AHyperType p)
b0 b ('AHyperType q)
b1

instance (ZipMatch a, ZipMatch b) => ZipMatch (a :+: b) where
    {-# INLINE zipMatch #-}
    zipMatch :: ((a :+: b) # p) -> ((a :+: b) # q) -> Maybe ((a :+: b) # (p :*: q))
zipMatch (L1 a ('AHyperType p)
x) (L1 a ('AHyperType q)
y) = a ('AHyperType p) -> a ('AHyperType q) -> Maybe (a # (p :*: q))
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch a ('AHyperType p)
x a ('AHyperType q)
y Maybe (a # (p :*: q))
-> ((a # (p :*: q)) -> (a :+: b) # (p :*: q))
-> Maybe ((a :+: b) # (p :*: q))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (a # (p :*: q)) -> (a :+: b) # (p :*: q)
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1
    zipMatch (R1 b ('AHyperType p)
x) (R1 b ('AHyperType q)
y) = b ('AHyperType p) -> b ('AHyperType q) -> Maybe (b # (p :*: q))
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch b ('AHyperType p)
x b ('AHyperType q)
y Maybe (b # (p :*: q))
-> ((b # (p :*: q)) -> (a :+: b) # (p :*: q))
-> Maybe ((a :+: b) # (p :*: q))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (b # (p :*: q)) -> (a :+: b) # (p :*: q)
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1
    zipMatch L1{} R1{} = Maybe ((a :+: b) # (p :*: q))
forall a. Maybe a
Nothing
    zipMatch R1{} L1{} = Maybe ((a :+: b) # (p :*: q))
forall a. Maybe a
Nothing

deriving newtype instance ZipMatch h => ZipMatch (M1 i m h)
deriving newtype instance ZipMatch h => ZipMatch (Rec1 h)

-- | 'ZipMatch' variant of 'Control.Applicative.liftA2'
{-# INLINE zipMatch2 #-}
zipMatch2 ::
    (ZipMatch h, HFunctor h) =>
    (forall n. HWitness h n -> p # n -> q # n -> r # n) ->
    h # p -> h # q -> Maybe (h # r)
zipMatch2 :: (forall (n :: AHyperType -> *).
 HWitness h n -> (p # n) -> (q # n) -> r # n)
-> (h # p) -> (h # q) -> Maybe (h # r)
zipMatch2 forall (n :: AHyperType -> *).
HWitness h n -> (p # n) -> (q # n) -> r # n
f h # p
x h # q
y = (h # p) -> (h # q) -> Maybe (h # (p :*: q))
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch h # p
x h # q
y Maybe (h # (p :*: q))
-> ((h # (p :*: q)) -> h # r) -> Maybe (h # r)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall (n :: AHyperType -> *).
 HWitness h n -> ((p :*: q) # n) -> r # n)
-> (h # (p :*: q)) -> h # r
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
HFunctor h =>
(forall (n :: AHyperType -> *). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (\HWitness h n
w (a :*: b) -> HWitness h n -> (p # n) -> (q # n) -> r # n
forall (n :: AHyperType -> *).
HWitness h n -> (p # n) -> (q # n) -> r # n
f HWitness h n
w p # n
a q # n
b)

-- | An 'Applicative' variant of 'zipMatch2'
{-# INLINE zipMatchA #-}
zipMatchA ::
    (Applicative f, ZipMatch h, HTraversable h) =>
    (forall n. HWitness h n -> p # n -> q # n -> f (r # n)) ->
    h # p -> h # q -> Maybe (f (h # r))
zipMatchA :: (forall (n :: AHyperType -> *).
 HWitness h n -> (p # n) -> (q # n) -> f (r # n))
-> (h # p) -> (h # q) -> Maybe (f (h # r))
zipMatchA forall (n :: AHyperType -> *).
HWitness h n -> (p # n) -> (q # n) -> f (r # n)
f h # p
x h # q
y = (h # p) -> (h # q) -> Maybe (h # (p :*: q))
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch h # p
x h # q
y Maybe (h # (p :*: q))
-> ((h # (p :*: q)) -> f (h # r)) -> Maybe (f (h # r))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall (n :: AHyperType -> *).
 HWitness h n -> ((p :*: q) # n) -> f (r # n))
-> (h # (p :*: q)) -> f (h # r)
forall (f :: * -> *) (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
(Applicative f, HTraversable h) =>
(forall (n :: AHyperType -> *).
 HWitness h n -> (p # n) -> f (q # n))
-> (h # p) -> f (h # q)
htraverse (\HWitness h n
w (a :*: b) -> HWitness h n -> (p # n) -> (q # n) -> f (r # n)
forall (n :: AHyperType -> *).
HWitness h n -> (p # n) -> (q # n) -> f (r # n)
f HWitness h n
w p # n
a q # n
b)

-- | A variant of 'zipMatchA' where the 'Applicative' actions do not contain results
{-# INLINE zipMatch_ #-}
zipMatch_ ::
    (Applicative f, ZipMatch h, HFoldable h) =>
    (forall n. HWitness h n -> p # n -> q # n -> f ()) ->
    h # p -> h # q -> Maybe (f ())
zipMatch_ :: (forall (n :: AHyperType -> *).
 HWitness h n -> (p # n) -> (q # n) -> f ())
-> (h # p) -> (h # q) -> Maybe (f ())
zipMatch_ forall (n :: AHyperType -> *).
HWitness h n -> (p # n) -> (q # n) -> f ()
f h # p
x h # q
y = (h # p) -> (h # q) -> Maybe (h # (p :*: q))
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch h # p
x h # q
y Maybe (h # (p :*: q)) -> ((h # (p :*: q)) -> f ()) -> Maybe (f ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall (c :: AHyperType -> *).
 HWitness h c -> ((p :*: q) # c) -> f ())
-> (h # (p :*: q)) -> f ()
forall (f :: * -> *) (h :: AHyperType -> *) (m :: AHyperType -> *).
(Applicative f, HFoldable h) =>
(forall (c :: AHyperType -> *). HWitness h c -> (m # c) -> f ())
-> (h # m) -> f ()
htraverse_ (\HWitness h c
w (a :*: b) -> HWitness h c -> (p # c) -> (q # c) -> f ()
forall (n :: AHyperType -> *).
HWitness h n -> (p # n) -> (q # n) -> f ()
f HWitness h c
w p # c
a q # c
b)

-- | A variant of 'zipMatch_' for 'Hyper.Type.HyperType's with a single node type (avoids using @RankNTypes@)
{-# INLINE zipMatch1_ #-}
zipMatch1_ ::
    (Applicative f, ZipMatch h, HFoldable h, HNodesConstraint h ((~) n)) =>
    (p # n -> q # n -> f ()) ->
    h # p -> h # q -> Maybe (f ())
zipMatch1_ :: ((p # n) -> (q # n) -> f ()) -> (h # p) -> (h # q) -> Maybe (f ())
zipMatch1_ (p # n) -> (q # n) -> f ()
f h # p
x h # q
y = (h # p) -> (h # q) -> Maybe (h # (p :*: q))
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch h # p
x h # q
y Maybe (h # (p :*: q)) -> ((h # (p :*: q)) -> f ()) -> Maybe (f ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (((p :*: q) # n) -> f ()) -> (h # (p :*: q)) -> f ()
forall (f :: * -> *) (h :: AHyperType -> *) (n :: AHyperType -> *)
       (p :: AHyperType -> *).
(Applicative f, HFoldable h, HNodesConstraint h ((~) n)) =>
((p # n) -> f ()) -> (h # p) -> f ()
htraverse1_ (\(p # n
a :*: q # n
b) -> (p # n) -> (q # n) -> f ()
f p # n
a q # n
b)