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

on 707a36a help sign in

59 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, ..}

44 {-# INLINABLE hspecs #-}

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

48hlabel = HLabel

49{-# INLINABLE hlabel #-}

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

53hrelabel = hlabel . hunlabel

54{-# INLINABLE hrelabel #-}

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

58hunlabel (HLabel a) = a

59{-# INLINABLE hunlabel #-}