-- | A variant of 'Data.Pointed.Pointed' for 'Hyper.Type.HyperType's
module Hyper.Class.Pointed
    ( HPointed (..)
    ) where

import GHC.Generics ((:+:) (..))
import Hyper.Class.Nodes (HNodes, HWitness (..))
import Hyper.Type (type (#))

import Hyper.Internal.Prelude

-- | A variant of 'Data.Pointed.Pointed' for 'Hyper.Type.HyperType's
class HNodes h => HPointed h where
    -- | Construct a value from a generator of @h@'s nodes
    -- (a generator which can generate a tree of any type given a witness that it is a node of @h@)
    hpure ::
        (forall n. HWitness h n -> p # n) ->
        h # p

instance Monoid a => HPointed (Const a) where
    {-# INLINE hpure #-}
    hpure :: forall (p :: HyperType).
(forall (n :: HyperType). HWitness (Const a) n -> p # n)
-> Const a # p
hpure forall (n :: HyperType). HWitness (Const a) n -> p # n
_ = forall {k} a (b :: k). a -> Const a b
Const forall a. Monoid a => a
mempty

instance (HPointed a, HPointed b) => HPointed (a :*: b) where
    {-# INLINE hpure #-}
    hpure :: forall (p :: HyperType).
(forall (n :: HyperType). HWitness (a :*: b) n -> p # n)
-> (a :*: b) # p
hpure forall (n :: HyperType). HWitness (a :*: b) n -> p # n
f = forall (h :: HyperType) (p :: HyperType).
HPointed h =>
(forall (n :: HyperType). HWitness h n -> p # n) -> h # p
hpure (forall (n :: HyperType). HWitness (a :*: b) n -> p # n
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: HyperType) (n :: HyperType).
HWitnessType h n -> HWitness h n
HWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1) forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (h :: HyperType) (p :: HyperType).
HPointed h =>
(forall (n :: HyperType). HWitness h n -> p # n) -> h # p
hpure (forall (n :: HyperType). HWitness (a :*: b) n -> p # n
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: HyperType) (n :: HyperType).
HWitnessType h n -> HWitness h n
HWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1)