git.iko.soy/rel8
on f0744d2 help sign in
rel8/src/Rel8/Table.hs
223 lines 6.3 kB history raw
1{-# language DataKinds #-}
2{-# language DisambiguateRecordFields #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
5{-# language FunctionalDependencies #-}
6{-# language StandaloneKindSignatures #-}
7{-# language TypeFamilies #-}
8{-# language UndecidableInstances #-}
10module Rel8.Table
11 ( Table (Columns, Context)
12 , toColumns, fromColumns
13 , Congruent
14 )
15where
17-- base
18import Data.Functor.Identity ( Identity( Identity ) )
19import Data.Kind ( Constraint, Type )
20import Prelude
22-- rel8
23import Rel8.Aggregate ( Aggregate )
24import Rel8.Expr ( Expr )
25import Rel8.Opaque ( Opaque, Opaque1 )
26import Rel8.Schema.Context
27 ( Aggregation( Aggregation )
28 , DB( DB ), unDB
29 , Result( Result )
30 )
31import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
32import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
33import Rel8.Schema.HTable.Context ( H, HKTable )
34import Rel8.Schema.HTable.Identity ( HIdentity(..) )
35import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
36import Rel8.Schema.HTable.Pair ( HPair(..) )
37import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
38import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
39import Rel8.Schema.HTable.Trio ( HTrio(..) )
40import Rel8.Schema.HTable.Type ( HType( HType ) )
41import Rel8.Schema.Nullability ( Nullabilizes )
42import Rel8.Schema.Spec ( SSpec( SSpec ), KnownSpec )
43import qualified Rel8.Schema.Spec as Kind ( Context )
44import Rel8.Type ( DBType )
47type Table :: Kind.Context -> Type -> Constraint
48class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
49 type Columns a :: HKTable
50 type Context a :: Kind.Context
52 toColumns :: a -> Columns a (H (Context a))
53 fromColumns :: Columns a (H (Context a)) -> a
56-- | Any 'HTable' is also a 'Table'.
57instance HTable t => Table context (t (H context)) where
58 type Columns (t (H context)) = t
59 type Context (t (H context)) = context
61 toColumns = id
62 fromColumns = id
65-- | Any context is trivially a table.
66instance KnownSpec spec => Table context (context spec) where
67 type Columns (context spec) = HIdentity spec
68 type Context (context spec) = context
70 toColumns = HIdentity
71 fromColumns = unHIdentity
74instance Table DB a => Table Aggregation (Aggregate a) where
75 type Columns (Aggregate a) = Columns a
76 type Context (Aggregate a) = Aggregation
78 toColumns a = htabulate $ \field -> case hfield hspecs field of
79 SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
80 fromColumns as = fmap fromColumns $ htabulateA $ \field ->
81 case hfield as field of
82 Aggregation a -> DB <$> a
85instance (DBType db, Nullabilizes db a) => Table DB (Expr a) where
86 type Columns (Expr a) = HType a
87 type Context (Expr a) = DB
89 toColumns a = HType (DB a)
90 fromColumns (HType (DB a)) = a
93instance (DBType db, Nullabilizes db a) => Table Result (Identity a) where
94 type Columns (Identity a) = HType a
95 type Context (Identity a) = Result
97 toColumns (Identity a) = HType (Result a)
98 fromColumns (HType (Result a)) = Identity a
101instance
102 ( Table context a, Table context b
103 , Labelable context
104 ) =>
105 Table context (a, b)
106 where
107 type Columns (a, b) =
108 HPair
109 (HLabel "fst" (Columns a))
110 (HLabel "snd" (Columns b))
111 type Context (a, b) = Context a
113 toColumns (a, b) = HPair
114 { hfst = hlabel labeler $ toColumns a
115 , hsnd = hlabel labeler $ toColumns b
116 }
117 fromColumns (HPair a b) =
118 ( fromColumns $ hunlabel unlabeler a
119 , fromColumns $ hunlabel unlabeler b
120 )
123instance
124 ( Table context a, Table context b, Table context c
125 , Labelable context
126 ) => Table context (a, b, c)
127 where
128 type Columns (a, b, c) =
129 HTrio
130 (HLabel "fst" (Columns a))
131 (HLabel "snd" (Columns b))
132 (HLabel "trd" (Columns c))
133 type Context (a, b, c) = Context a
135 toColumns (a, b, c) = HTrio
136 { hfst = hlabel labeler $ toColumns a
137 , hsnd = hlabel labeler $ toColumns b
138 , htrd = hlabel labeler $ toColumns c
139 }
140 fromColumns (HTrio a b c) =
141 ( fromColumns $ hunlabel unlabeler a
142 , fromColumns $ hunlabel unlabeler b
143 , fromColumns $ hunlabel unlabeler c
144 )
147instance
148 ( Table context a, Table context b, Table context c, Table context d
149 , Labelable context
150 ) => Table context (a, b, c, d)
151 where
152 type Columns (a, b, c, d) =
153 HQuartet
154 (HLabel "fst" (Columns a))
155 (HLabel "snd" (Columns b))
156 (HLabel "trd" (Columns c))
157 (HLabel "frt" (Columns d))
158 type Context (a, b, c, d) = Context a
160 toColumns (a, b, c, d) = HQuartet
161 { hfst = hlabel labeler $ toColumns a
162 , hsnd = hlabel labeler $ toColumns b
163 , htrd = hlabel labeler $ toColumns c
164 , hfrt = hlabel labeler $ toColumns d
165 }
166 fromColumns (HQuartet a b c d) =
167 ( fromColumns $ hunlabel unlabeler a
168 , fromColumns $ hunlabel unlabeler b
169 , fromColumns $ hunlabel unlabeler c
170 , fromColumns $ hunlabel unlabeler d
171 )
174instance
175 ( Table context a, Table context b, Table context c, Table context d
176 , Table context e
177 , Labelable context
178 ) => Table context (a, b, c, d, e)
179 where
180 type Columns (a, b, c, d, e) =
181 HQuintet
182 (HLabel "fst" (Columns a))
183 (HLabel "snd" (Columns b))
184 (HLabel "trd" (Columns c))
185 (HLabel "frt" (Columns d))
186 (HLabel "fft" (Columns e))
187 type Context (a, b, c, d, e) = Context a
189 toColumns (a, b, c, d, e) = HQuintet
190 { hfst = hlabel labeler $ toColumns a
191 , hsnd = hlabel labeler $ toColumns b
192 , htrd = hlabel labeler $ toColumns c
193 , hfrt = hlabel labeler $ toColumns d
194 , hfft = hlabel labeler $ toColumns e
195 }
196 fromColumns (HQuintet a b c d e) =
197 ( fromColumns $ hunlabel unlabeler a
198 , fromColumns $ hunlabel unlabeler b
199 , fromColumns $ hunlabel unlabeler c
200 , fromColumns $ hunlabel unlabeler d
201 , fromColumns $ hunlabel unlabeler e
202 )
205instance Table DB Opaque where
206 type Columns Opaque = HType Opaque
207 type Context Opaque = DB
209 fromColumns = error "opaque"
210 toColumns = error "opaque"
213instance Table context (Opaque1 context a) where
214 type Columns (Opaque1 context a) = HType Opaque
215 type Context (Opaque1 context a) = context
217 fromColumns = error "opaque"
218 toColumns = error "opaque"
221type Congruent :: Type -> Type -> Constraint
222class Columns a ~ Columns b => Congruent a b
223instance Columns a ~ Columns b => Congruent a b