git.iko.soy/rel8
on ca7aaef help sign in
rel8/src/Rel8/Schema/HTable/Label.hs
85 lines 2.4 kB history raw
1{-# LANGUAGE DeriveAnyClass #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DerivingStrategies #-}
4{-# LANGUAGE LambdaCase #-}
5{-# language ConstraintKinds #-}
6{-# language DataKinds #-}
7{-# language FlexibleInstances #-}
8{-# language GADTs #-}
9{-# language InstanceSigs #-}
10{-# language MultiParamTypeClasses #-}
11{-# language QuantifiedConstraints #-}
12{-# language RankNTypes #-}
13{-# language RecordWildCards #-}
14{-# language ScopedTypeVariables #-}
15{-# language StandaloneKindSignatures #-}
16{-# language TypeApplications #-}
17{-# language TypeFamilies #-}
18{-# language TypeOperators #-}
19{-# language UndecidableInstances #-}
21module Rel8.Schema.HTable.Label
22 ( HLabel, Label
23 , hlabel, hunlabel
24 )
25where
27-- base
28import Data.Proxy ( Proxy( Proxy ) )
29import GHC.TypeLits ( KnownSymbol, Symbol )
30import Prelude
32-- rel8
33import Rel8.Kind.Labels ( SLabels( SLabels ) )
34import Rel8.Schema.HTable
35 ( HTable
36 , hfield, htabulate, hspecs
37 )
38import qualified Rel8.Schema.Kind as K
39import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
40import Rel8.FCF
41import Rel8.Schema.HTable.MapTable
42import GHC.Generics (Generic)
45type HLabel :: Symbol -> K.HTable -> K.HTable
46newtype HLabel label table context = HLabel (HMapTable (Label label) table context)
47 deriving stock Generic
48 deriving anyclass HTable
51data Label :: Symbol -> Spec -> Exp Spec
54type instance Eval (Label label ('Spec labels necessity a)) = 'Spec (label : labels) necessity a
57instance KnownSymbol l => MapSpec (Label l) where
58 mapInfo = \case
59 SSpec {..} -> SSpec {labels = SLabels Proxy labels, ..}
62hlabel :: (HTable t, KnownSymbol label)
63 => (forall labels necessity a. ()
64 => context ('Spec labels necessity a)
65 -> context ('Spec (label ': labels) necessity a))
66 -> t context
67 -> HLabel label t context
68hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->
69 case hfield hspecs field of
70 SSpec {} -> labeler (hfield a field)
71{-# INLINABLE hlabel #-}
74hunlabel :: (HTable t, KnownSymbol label)
75 => (forall labels necessity a. ()
76 => context ('Spec (label ': labels) necessity a)
77 -> context ('Spec labels necessity a))
78 -> HLabel label t context
79 -> t context
80hunlabel unlabler (HLabel as) =
81 htabulate $ \field ->
82 case hfield hspecs field of
83 SSpec {} -> case hfield as (HMapTableField field) of
84 a -> unlabler a
85{-# INLINABLE hunlabel #-}