git.iko.soy/rel8
on 00a36f5 help sign in
rel8/src/Rel8/Schema/HTable/Label.hs
131 lines 4.1 kB history raw
1{-# language ConstraintKinds #-}
2{-# language DataKinds #-}
3{-# language FlexibleInstances #-}
4{-# language GADTs #-}
5{-# language InstanceSigs #-}
6{-# language MultiParamTypeClasses #-}
7{-# language QuantifiedConstraints #-}
8{-# language RankNTypes #-}
9{-# language RecordWildCards #-}
10{-# language ScopedTypeVariables #-}
11{-# language StandaloneKindSignatures #-}
12{-# language TypeApplications #-}
13{-# language TypeFamilies #-}
14{-# language TypeOperators #-}
15{-# language UndecidableInstances #-}
17module Rel8.Schema.HTable.Label
18 ( HLabel( HLabel )
19 , hlabel, hunlabel
20 )
21where
23-- base
24import Data.Kind ( Constraint, Type )
25import Data.Proxy ( Proxy( Proxy ) )
26import GHC.TypeLits ( KnownSymbol, Symbol )
27import Prelude
29-- rel8
30import Rel8.Kind.Labels ( SLabels( SLabels ) )
31import Rel8.Schema.Dict ( Dict( Dict ) )
32import Rel8.Schema.HTable
33 ( HTable, HConstrainTable, HField
34 , hfield, htabulate, htraverse, hdicts, hspecs
35 )
36import qualified Rel8.Schema.Kind as K
37import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
40type HLabel :: Symbol -> K.HTable -> K.HTable
41data HLabel label table context where
42 HLabel :: table (LabelSpec label context) -> HLabel label table context
45type HLabelField :: Symbol -> K.HTable -> Spec -> Type
46data HLabelField label table spec where
47 HLabelField
48 :: HField table ('Spec labels necessity db a)
49 -> HLabelField label table ('Spec (label ': labels) necessity db a)
52instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
53 type HField (HLabel label table) = HLabelField label table
54 type HConstrainTable (HLabel label table) c =
55 HConstrainTable table (LabelSpecC label c)
57 hfield (HLabel table) (HLabelField field) =
58 getLabelSpec (hfield table field)
60 htabulate f = HLabel $ htabulate $ \field -> case hfield hspecs field of
61 SSpec {} -> LabelSpec (f (HLabelField field))
62 htraverse f (HLabel t) = HLabel <$> htraverse (traverseLabelSpec f) t
64 hdicts :: forall c. HConstrainTable table (LabelSpecC label c)
65 => HLabel label table (Dict c)
66 hdicts = HLabel $ htabulate $ \field -> case hfield hspecs field of
67 SSpec {} -> case hfield (hdicts @_ @(LabelSpecC label c)) field of
68 Dict -> LabelSpec Dict
70 hspecs = HLabel $ htabulate $ \field -> case hfield hspecs field of
71 SSpec {..} -> LabelSpec SSpec {labels = SLabels Proxy labels, ..}
73 {-# INLINABLE hfield #-}
74 {-# INLINABLE htabulate #-}
75 {-# INLINABLE htraverse #-}
76 {-# INLINABLE hdicts #-}
77 {-# INLINABLE hspecs #-}
80type LabelingSpec :: Type -> Type
81type LabelingSpec r = Symbol -> (Spec -> r) -> Spec -> r
84type LabelSpec :: LabelingSpec Type
85data LabelSpec label context spec where
86 LabelSpec
87 :: { getLabelSpec :: context ('Spec (label ': labels) necessity db a) }
88 -> LabelSpec label context ('Spec labels necessity db a)
91type LabelSpecC :: LabelingSpec Constraint
92class
93 ( forall labels necessity db a.
94 ( spec ~ 'Spec labels necessity db a =>
95 constraint ('Spec (label ': labels) necessity db a)
96 )
97 ) => LabelSpecC label constraint spec
98instance
99 ( spec ~ 'Spec labels necessity db a
100 , constraint ('Spec (label ': labels) necessity db a)
101 ) => LabelSpecC label constraint spec
104traverseLabelSpec :: forall context context' label spec m. Functor m
105 => (forall x. context x -> m (context' x))
106 -> LabelSpec label context spec -> m (LabelSpec label context' spec)
107traverseLabelSpec f (LabelSpec a) = LabelSpec <$> f a
110hlabel :: HTable t
111 => (forall labels necessity db a. ()
112 => context ('Spec labels necessity db a)
113 -> context ('Spec (label ': labels) necessity db a))
114 -> t context
115 -> HLabel label t context
116hlabel labeler a = HLabel $ htabulate $ \field ->
117 case hfield hspecs field of
118 SSpec {} -> LabelSpec (labeler (hfield a field))
119{-# INLINABLE hlabel #-}
122hunlabel :: HTable t
123 => (forall labels necessity db a. ()
124 => context ('Spec (label ': labels) necessity db a)
125 -> context ('Spec labels necessity db a))
126 -> HLabel label t context
127 -> t context
128hunlabel unlabler (HLabel as) =
129 htabulate $ \field -> case hfield as field of
130 LabelSpec a -> unlabler a
131{-# INLINABLE hunlabel #-}