git.iko.soy/rel8
on 00a36f5 help sign in
rel8/src/Rel8/Schema/Context/Label.hs
89 lines 2.3 kB history raw
1{-# language DataKinds #-}
2{-# language LambdaCase #-}
3{-# language FlexibleInstances #-}
4{-# language MultiParamTypeClasses #-}
5{-# language StandaloneKindSignatures #-}
6{-# language TypeFamilies #-}
7{-# language TypeOperators #-}
9module Rel8.Schema.Context.Label
10 ( Labelable( labeler, unlabeler )
11 , HLabelable( hlabeler, hunlabeler )
12 )
13where
15-- base
16import Data.Functor.Identity ( Identity )
17import Data.Kind ( Constraint )
18import Prelude hiding ( null )
20-- rel8
21import Rel8.Aggregate ( Aggregate )
22import Rel8.Expr ( Expr )
23import Rel8.Schema.Context
24 ( Interpretation, Col, Col'(..), IsSpecialContext
25 , Insertion
26 )
27import qualified Rel8.Schema.Kind as K
28import Rel8.Schema.Spec ( Spec( Spec ) )
31type Labelable :: K.Context -> Constraint
32class Interpretation context => Labelable context where
33 labeler :: ()
34 => Col context ('Spec labels necessity db a)
35 -> Col context ('Spec (label ': labels) necessity db a)
37 unlabeler :: ()
38 => Col context ('Spec (label ': labels) necessity db a)
39 -> Col context ('Spec labels necessity db a)
42instance Labelable Aggregate where
43 labeler (Aggregation aggregate) = Aggregation aggregate
44 unlabeler (Aggregation aggregate) = Aggregation aggregate
47instance Labelable Expr where
48 labeler (DB a) = DB a
49 unlabeler (DB a) = DB a
52instance Labelable Insertion where
53 labeler = \case
54 RequiredInsert a -> RequiredInsert a
55 OptionalInsert ma -> OptionalInsert ma
57 unlabeler = \case
58 RequiredInsert a -> RequiredInsert a
59 OptionalInsert ma -> OptionalInsert ma
62instance Labelable Identity where
63 labeler (Result a) = Result a
64 unlabeler (Result a) = Result a
67instance {-# OVERLAPPABLE #-} IsSpecialContext context ~ 'False =>
68 Labelable context
69 where
70 labeler (Col a) = Col a
71 unlabeler (Col a) = Col a
74type HLabelable :: K.HContext -> Constraint
75class HLabelable context where
76 hlabeler :: ()
77 => context ('Spec labels necessity db a)
78 -> context ('Spec (label ': labels) necessity db a)
80 hunlabeler :: ()
81 => context ('Spec (label ': labels) necessity db a)
82 -> context ('Spec labels necessity db a)
85instance (Labelable context, x ~ IsSpecialContext context) =>
86 HLabelable (Col' x context)
87 where
88 hlabeler = labeler
89 hunlabeler = unlabeler