{-# LANGUAGE EmptyCase, UndecidableInstances, TemplateHaskell, FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Hyper.Class.Nodes
( HNodes(..), HWitness(..), _HWitness
, (#>), (#*#)
, HNodesHaveConstraint(..)
) where
import Data.Kind (Type)
import GHC.Generics
import Hyper.Type
import Hyper.Internal.Prelude
newtype HWitness h n = HWitness (HWitnessType h n)
class HNodes (h :: HyperType) where
type HNodesConstraint h (c :: (HyperType -> Constraint)) :: Constraint
type instance HNodesConstraint h c = HNodesConstraint (Rep1 h) c
type HWitnessType h :: HyperType -> Type
type instance HWitnessType h = HWitnessType (Rep1 h)
hLiftConstraint ::
HNodesConstraint h c =>
HWitness h n ->
Proxy c ->
(c n => r) ->
r
{-# INLINE hLiftConstraint #-}
default hLiftConstraint ::
( HWitnessType h ~ HWitnessType (Rep1 h)
, HNodesConstraint h c ~ HNodesConstraint (Rep1 h) c
, HNodes (Rep1 h)
, HNodesConstraint h c
) =>
HWitness h n ->
Proxy c ->
(c n => r) ->
r
hLiftConstraint (HWitness HWitnessType h n
w) = HWitness (Rep1 h) n -> Proxy c -> (c n => r) -> r
forall (h :: HyperType) (c :: HyperType -> Constraint)
(n :: HyperType) r.
(HNodes h, HNodesConstraint h c) =>
HWitness h n -> Proxy c -> (c n => r) -> r
hLiftConstraint @(Rep1 h) (HWitnessType (Rep1 h) n -> HWitness (Rep1 h) n
forall (h :: HyperType) (n :: HyperType).
HWitnessType h n -> HWitness h n
HWitness HWitnessType h n
HWitnessType (Rep1 h) n
w)
makePrisms ''HWitness
instance HNodes (Const a) where
type HNodesConstraint (Const a) _ = ()
type HWitnessType (Const a) = V1
{-# INLINE hLiftConstraint #-}
hLiftConstraint :: HWitness (Const a) n -> Proxy c -> (c n => r) -> r
hLiftConstraint = \case{}
instance (HNodes a, HNodes b) => HNodes (a :*: b) where
type HNodesConstraint (a :*: b) x = (HNodesConstraint a x, HNodesConstraint b x)
type HWitnessType (a :*: b) = HWitness a :+: HWitness b
{-# INLINE hLiftConstraint #-}
hLiftConstraint :: HWitness (a :*: b) n -> Proxy c -> (c n => r) -> r
hLiftConstraint (HWitness (L1 w)) = HWitness a n -> Proxy c -> (c n => r) -> r
forall (h :: HyperType) (c :: HyperType -> Constraint)
(n :: HyperType) r.
(HNodes h, HNodesConstraint h c) =>
HWitness h n -> Proxy c -> (c n => r) -> r
hLiftConstraint HWitness a n
w
hLiftConstraint (HWitness (R1 w)) = HWitness b n -> Proxy c -> (c n => r) -> r
forall (h :: HyperType) (c :: HyperType -> Constraint)
(n :: HyperType) r.
(HNodes h, HNodesConstraint h c) =>
HWitness h n -> Proxy c -> (c n => r) -> r
hLiftConstraint HWitness b n
w
instance (HNodes a, HNodes b) => HNodes (a :+: b) where
type HNodesConstraint (a :+: b) x = (HNodesConstraint a x, HNodesConstraint b x)
type HWitnessType (a :+: b) = HWitness a :+: HWitness b
{-# INLINE hLiftConstraint #-}
hLiftConstraint :: HWitness (a :+: b) n -> Proxy c -> (c n => r) -> r
hLiftConstraint (HWitness (L1 w)) = HWitness a n -> Proxy c -> (c n => r) -> r
forall (h :: HyperType) (c :: HyperType -> Constraint)
(n :: HyperType) r.
(HNodes h, HNodesConstraint h c) =>
HWitness h n -> Proxy c -> (c n => r) -> r
hLiftConstraint HWitness a n
w
hLiftConstraint (HWitness (R1 w)) = HWitness b n -> Proxy c -> (c n => r) -> r
forall (h :: HyperType) (c :: HyperType -> Constraint)
(n :: HyperType) r.
(HNodes h, HNodesConstraint h c) =>
HWitness h n -> Proxy c -> (c n => r) -> r
hLiftConstraint HWitness b n
w
deriving newtype instance HNodes h => HNodes (M1 i m h)
deriving newtype instance HNodes h => HNodes (Rec1 h)
infixr 0 #>
infixr 0 #*#
{-# INLINE (#>) #-}
(#>) ::
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => r) -> HWitness h n -> r
#> :: Proxy c -> (c n => r) -> HWitness h n -> r
(#>) Proxy c
p c n => r
r HWitness h n
w = HWitness h n -> Proxy c -> (c n => r) -> r
forall (h :: HyperType) (c :: HyperType -> Constraint)
(n :: HyperType) r.
(HNodes h, HNodesConstraint h c) =>
HWitness h n -> Proxy c -> (c n => r) -> r
hLiftConstraint HWitness h n
w Proxy c
p c n => r
r
{-# INLINE (#*#) #-}
(#*#) ::
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => HWitness h n -> r) -> HWitness h n -> r
#*# :: Proxy c -> (c n => HWitness h n -> r) -> HWitness h n -> r
(#*#) Proxy c
p c n => HWitness h n -> r
r HWitness h n
w = (Proxy c
p Proxy c
-> (c n => HWitness h n -> r) -> HWitness h n -> HWitness h n -> r
forall (h :: HyperType) (c :: HyperType -> Constraint)
(n :: HyperType) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => r) -> HWitness h n -> r
#> c n => HWitness h n -> r
r) HWitness h n
w HWitness h n
w
class HNodesHaveConstraint c h where
hNodesHaveConstraint :: proxy0 c -> proxy1 h -> Dict (HNodesConstraint h c)
instance HNodesConstraint h c => HNodesHaveConstraint c h where
hNodesHaveConstraint :: proxy0 c -> proxy1 h -> Dict (HNodesConstraint h c)
hNodesHaveConstraint proxy0 c
_ proxy1 h
_ = Dict (HNodesConstraint h c)
forall (a :: Constraint). a => Dict a
Dict