git.iko.soy/rel8
on 032242f help sign in
rel8/src/Rel8/Schema/HTable/Label.hs
70 lines 2.0 kB history raw
1{-# language DataKinds #-}
2{-# language RankNTypes #-}
3{-# language RecordWildCards #-}
4{-# language ScopedTypeVariables #-}
5{-# language StandaloneKindSignatures #-}
6{-# language TypeApplications #-}
7{-# language TypeFamilies #-}
9module Rel8.Schema.HTable.Label
10 ( HLabel, hlabel, hrelabel, hunlabel
11 , hproject
12 )
13where
15-- base
16import Data.Kind ( Type )
17import Data.Proxy ( Proxy( Proxy ) )
18import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
19import Prelude
21-- rel8
22import Rel8.Schema.HTable
23 ( HTable, HConstrainTable, HField
24 , htabulate, hfield, htraverse, hdicts, hspecs
25 )
26import qualified Rel8.Schema.Kind as K
27import Rel8.Schema.Spec ( Spec(..) )
30type HLabel :: Symbol -> K.HTable -> K.HTable
31newtype HLabel label table context = HLabel (table context)
34type HLabelField :: Symbol -> K.HTable -> Type -> Type
35newtype HLabelField label table a = HLabelField (HField table a)
38instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
39 type HField (HLabel label table) = HLabelField label table
40 type HConstrainTable (HLabel label table) constraint =
41 HConstrainTable table constraint
43 hfield (HLabel a) (HLabelField field) = hfield a field
44 htabulate f = HLabel (htabulate (f . HLabelField))
45 htraverse f (HLabel a) = HLabel <$> htraverse f a
46 hdicts = HLabel (hdicts @table)
47 hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of
48 Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..}
49 {-# INLINABLE hspecs #-}
52hlabel :: forall label t context. t context -> HLabel label t context
53hlabel = HLabel
54{-# INLINABLE hlabel #-}
57hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context
58hrelabel = hlabel . hunlabel
59{-# INLINABLE hrelabel #-}
62hunlabel :: forall label t context. HLabel label t context -> t context
63hunlabel (HLabel a) = a
64{-# INLINABLE hunlabel #-}
67hproject :: ()
68 => (forall ctx. t ctx -> t' ctx)
69 -> HLabel label t context -> HLabel label t' context
70hproject f (HLabel a) = HLabel (f a)