module Hyper.Class.Apply
( HApply(..), HApplicative
, liftH2
) where
import Hyper.Class.Functor (HFunctor(..))
import Hyper.Class.Nodes (HWitness)
import Hyper.Class.Pointed (HPointed)
import Hyper.Type (type (#))
import Hyper.Internal.Prelude
class HFunctor h => HApply h where
hzip ::
h # p ->
h # q ->
h # (p :*: q)
type HApplicative h = (HPointed h, HApply h)
instance Semigroup a => HApply (Const a) where
{-# INLINE hzip #-}
hzip :: (Const a # p) -> (Const a # q) -> Const a # (p :*: q)
hzip (Const a
x) (Const a
y) = a -> Const a # (p :*: q)
forall k a (b :: k). a -> Const a b
Const (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y)
instance (HApply a, HApply b) => HApply (a :*: b) where
{-# INLINE hzip #-}
hzip :: ((a :*: b) # p) -> ((a :*: b) # q) -> (a :*: b) # (p :*: q)
hzip (a ('AHyperType p)
a0 :*: b ('AHyperType p)
b0) (a ('AHyperType q)
a1 :*: b ('AHyperType q)
b1) = a ('AHyperType p) -> a ('AHyperType q) -> a # (p :*: q)
forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HApply h =>
(h # p) -> (h # q) -> h # (p :*: q)
hzip a ('AHyperType p)
a0 a ('AHyperType q)
a1 (a # (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
:*: b ('AHyperType p) -> b ('AHyperType q) -> b ('AHyperType (p :*: q))
forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HApply h =>
(h # p) -> (h # q) -> h # (p :*: q)
hzip b ('AHyperType p)
b0 b ('AHyperType q)
b1
{-# INLINE liftH2 #-}
liftH2 ::
HApply h =>
(forall n. HWitness h n -> p # n -> q # n -> r # n) ->
h # p ->
h # q ->
h # r
liftH2 :: (forall (n :: HyperType).
HWitness h n -> (p # n) -> (q # n) -> r # n)
-> (h # p) -> (h # q) -> h # r
liftH2 forall (n :: HyperType).
HWitness h n -> (p # n) -> (q # n) -> r # n
f h # p
x = (forall (n :: HyperType). HWitness h n -> ((p :*: q) # n) -> r # n)
-> (h # (p :*: q)) -> h # r
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 (a :*: b) -> HWitness h n -> (p # n) -> (q # n) -> r # n
forall (n :: HyperType).
HWitness h n -> (p # n) -> (q # n) -> r # n
f HWitness h n
w p # n
a q # n
b) ((h # (p :*: q)) -> h # r)
-> ((h # q) -> h # (p :*: q)) -> (h # q) -> h # r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (h # p) -> (h # q) -> h # (p :*: q)
forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HApply h =>
(h # p) -> (h # q) -> h # (p :*: q)
hzip h # p
x