src/Rel8/Schema/HTable/Label.hs · rel8

on 07daf4f help sign in

58 lines 1.8 kB history raw

1{-# language DataKinds #-}

2{-# language RecordWildCards #-}

3{-# language ScopedTypeVariables #-}

4{-# language StandaloneKindSignatures #-}

5{-# language TypeApplications #-}

6{-# language TypeFamilies #-}

8module Rel8.Schema.HTable.Label

9 ( HLabel, hlabel, hrelabel, hunlabel

10 )

11where

13-- base

14import Data.Kind ( Type )

15import Data.Proxy ( Proxy( Proxy ) )

16import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )

17import Prelude

19-- rel8

20import Rel8.Schema.HTable

21import qualified Rel8.Schema.Kind as K

22import Rel8.Schema.Spec ( Spec, SSpec(..) )

25type HLabel :: Symbol -> K.HTable -> K.HTable

26newtype HLabel label table context = HLabel (table context)

29type HLabelField :: Symbol -> K.HTable -> Spec -> Type

30newtype HLabelField label table spec = HLabelField (HField table spec)

33instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

34 type HField (HLabel label table) = HLabelField label table

35 type HConstrainTable (HLabel label table) constraint =

36 HConstrainTable table constraint

38 hfield (HLabel a) (HLabelField field) = hfield a field

39 htabulate f = HLabel (htabulate (f . HLabelField))

40 htraverse f (HLabel a) = HLabel <$> htraverse f a

41 hdicts = HLabel (hdicts @table)

42 hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of

43 SSpec {..} -> SSpec {labels = symbolVal (Proxy @label) : labels, ..}

46hlabel :: forall label t context. t context -> HLabel label t context

47hlabel = HLabel

48{-# INLINABLE hlabel #-}

51hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context

52hrelabel = hlabel . hunlabel

53{-# INLINABLE hrelabel #-}

56hunlabel :: forall label t context. HLabel label t context -> t context

57hunlabel (HLabel a) = a

58{-# INLINABLE hunlabel #-}