{-# LANGUAGE FlexibleContexts #-}

-- | A class to match term structures
module Hyper.Class.ZipMatch
    ( ZipMatch (..)
    , zipMatch2
    , zipMatchA
    , zipMatch_
    , zipMatch1_
    ) where

import GHC.Generics
import GHC.Generics.Lens (generic1)
import Hyper.Class.Foldable (HFoldable, htraverse1_, htraverse_)
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 = forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Generic1 f, Generic1 g) =>
Iso (f a) (g b) (Rep1 f a) (Rep1 g b)
generic1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1

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

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

instance (ZipMatch a, ZipMatch b) => ZipMatch (a :*: b) where
    {-# INLINE zipMatch #-}
    zipMatch :: forall (p :: HyperType) (q :: HyperType).
((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) = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch a ('AHyperType p)
a0 a ('AHyperType q)
a1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
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 :: forall (p :: HyperType) (q :: HyperType).
((a :+: b) # p) -> ((a :+: b) # q) -> Maybe ((a :+: b) # (p :*: q))
zipMatch (L1 a ('AHyperType p)
x) (L1 a ('AHyperType q)
y) = forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch a ('AHyperType p)
x a ('AHyperType q)
y forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> 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) = forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch b ('AHyperType p)
x b ('AHyperType q)
y forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1
    zipMatch L1{} R1{} = forall a. Maybe a
Nothing
    zipMatch R1{} L1{} = 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 (h :: HyperType) (p :: HyperType) (q :: HyperType)
       (r :: HyperType).
(ZipMatch h, HFunctor h) =>
(forall (n :: HyperType).
 HWitness h n -> (p # n) -> (q # n) -> r # n)
-> (h # p) -> (h # q) -> Maybe (h # r)
zipMatch2 forall (n :: HyperType).
HWitness h n -> (p # n) -> (q # n) -> r # n
f h # p
x h # q
y = forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch h # p
x h # q
y forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (\HWitness h n
w (p ('AHyperType n)
a :*: q ('AHyperType n)
b) -> forall (n :: HyperType).
HWitness h n -> (p # n) -> (q # n) -> r # n
f HWitness h n
w p ('AHyperType n)
a q ('AHyperType 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 (f :: * -> *) (h :: HyperType) (p :: HyperType)
       (q :: HyperType) (r :: HyperType).
(Applicative f, ZipMatch h, HTraversable h) =>
(forall (n :: HyperType).
 HWitness h n -> (p # n) -> (q # n) -> f (r # n))
-> (h # p) -> (h # q) -> Maybe (f (h # r))
zipMatchA forall (n :: HyperType).
HWitness h n -> (p # n) -> (q # n) -> f (r # n)
f h # p
x h # q
y = forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch h # p
x h # q
y forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (f :: * -> *) (h :: HyperType) (p :: HyperType)
       (q :: HyperType).
(Applicative f, HTraversable h) =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> f (q # n))
-> (h # p) -> f (h # q)
htraverse (\HWitness h n
w (p ('AHyperType n)
a :*: q ('AHyperType n)
b) -> forall (n :: HyperType).
HWitness h n -> (p # n) -> (q # n) -> f (r # n)
f HWitness h n
w p ('AHyperType n)
a q ('AHyperType 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 (f :: * -> *) (h :: HyperType) (p :: HyperType)
       (q :: HyperType).
(Applicative f, ZipMatch h, HFoldable h) =>
(forall (n :: HyperType).
 HWitness h n -> (p # n) -> (q # n) -> f ())
-> (h # p) -> (h # q) -> Maybe (f ())
zipMatch_ forall (n :: HyperType). HWitness h n -> (p # n) -> (q # n) -> f ()
f h # p
x h # q
y = forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch h # p
x h # q
y forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (f :: * -> *) (h :: HyperType) (m :: HyperType).
(Applicative f, HFoldable h) =>
(forall (c :: HyperType). HWitness h c -> (m # c) -> f ())
-> (h # m) -> f ()
htraverse_ (\HWitness h c
w (p ('AHyperType c)
a :*: q ('AHyperType c)
b) -> forall (n :: HyperType). HWitness h n -> (p # n) -> (q # n) -> f ()
f HWitness h c
w p ('AHyperType c)
a q ('AHyperType 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_ :: forall (f :: * -> *) (h :: HyperType) (n :: HyperType)
       (p :: HyperType) (q :: HyperType).
(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 ()
f h # p
x h # q
y = forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch h # p
x h # q
y forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (f :: * -> *) (h :: HyperType) (n :: HyperType)
       (p :: HyperType).
(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)