-- | 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 :: forall (p :: HyperType) (q :: HyperType).
(Const a # p) -> (Const a # q) -> Const a # (p :*: q)
hzip (Const a
x) (Const a
y) = forall {k} a (b :: k). a -> Const a b
Const (a
x forall a. Semigroup a => a -> a -> a
<> a
y)

instance (HApply a, HApply b) => HApply (a :*: b) where
    {-# INLINE hzip #-}
    hzip :: forall (p :: HyperType) (q :: HyperType).
((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) = 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 forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: 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 (h :: HyperType) (p :: HyperType) (q :: HyperType)
       (r :: HyperType).
HApply h =>
(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 (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) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HApply h =>
(h # p) -> (h # q) -> h # (p :*: q)
hzip h # p
x