-- | A variant of 'Data.Functor.Apply.Apply' for 'Hyper.Type.HyperType's

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

-- | A variant of 'Data.Functor.Apply.Apply' for 'Hyper.Type.HyperType's.
--
-- A type which has 'HApply' and 'HPointed' instances also has 'HApplicative',
-- which is the equivalent to the 'Applicative' class.
class HFunctor h => HApply h where
    -- | Combine child values
    --
    -- >>> hzip (Person name0 age0) (Person name1 age1)
    -- Person (Pair name0 name1) (Pair age0 age1)
    hzip ::
        h # p ->
        h # q ->
        h # (p :*: q)

-- | A variant of 'Applicative' for 'Hyper.Type.HyperType's.
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

-- | 'HApply' variant of 'Control.Applicative.liftA2'
{-# 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