{-# 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
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 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)
{-# 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)
{-# 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)
{-# 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)
{-# 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)