{-# LANGUAGE FlexibleContexts #-}
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
class ZipMatch h where
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)
{-# 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)
{-# 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)
{-# 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)
{-# 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)