git.iko.soy/rel8
on eb180fa help sign in
rel8/src/Rel8/Table.hs
240 lines 6.8 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 ( Col, Col'(..), Insertion(..), Name, IsSpecialContext
28 )
29import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
30import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
31import Rel8.Schema.HTable.Identity ( HIdentity(..) )
32import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
33import Rel8.Schema.HTable.Pair ( HPair(..) )
34import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
35import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
36import Rel8.Schema.HTable.Trio ( HTrio(..) )
37import Rel8.Schema.HTable.Type ( HType( HType ) )
38import qualified Rel8.Schema.Kind as K
39import Rel8.Schema.Nullability ( Sql )
40import Rel8.Schema.Spec ( SSpec( SSpec ), KnownSpec )
41import Rel8.Type ( DBType )
44type Table :: K.Context -> Type -> Constraint
45class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
46 type Columns a :: K.HTable
47 type Context a :: K.Context
49 toColumns :: a -> Columns a (Col (Context a))
50 fromColumns :: Columns a (Col (Context a)) -> a
53-- | Any 'HTable' is also a 'Table'.
54instance (HTable t, x ~ IsSpecialContext context) =>
55 Table context (t (Col' x context))
56 where
57 type Columns (t (Col' x context)) = t
58 type Context (t (Col' x context)) = context
60 toColumns = id
61 fromColumns = id
64-- | Any context is trivially a table.
65instance (KnownSpec spec, x ~ IsSpecialContext context) =>
66 Table context (Col' x context spec)
67 where
68 type Columns (Col' x context spec) = HIdentity spec
69 type Context (Col' x context spec) = context
71 toColumns = HIdentity
72 fromColumns = unHIdentity
75instance Table Expr a => Table Aggregate (Aggregate a) where
76 type Columns (Aggregate a) = Columns a
77 type Context (Aggregate a) = Aggregate
79 toColumns a = htabulate $ \field -> case hfield hspecs field of
80 SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
81 fromColumns as = fmap fromColumns $ htabulateA $ \field ->
82 case hfield as field of
83 Aggregation a -> DB <$> a
86instance Sql DBType a => Table Expr (Expr a) where
87 type Columns (Expr a) = HType a
88 type Context (Expr a) = Expr
90 toColumns a = HType (DB a)
91 fromColumns (HType (DB a)) = a
94instance Sql DBType a => Table Identity (Identity a) where
95 type Columns (Identity a) = HType a
96 type Context (Identity a) = Identity
98 toColumns (Identity a) = HType (Result a)
99 fromColumns (HType (Result a)) = Identity a
102instance Sql DBType a => Table Insertion (Insertion a) where
103 type Columns (Insertion a) = HType a
104 type Context (Insertion a) = Insertion
106 toColumns (Insertion a) = HType (RequiredInsert a)
107 fromColumns (HType (RequiredInsert a)) = Insertion a
110instance Sql DBType a => Table Name (Name a) where
111 type Columns (Name a) = HType a
112 type Context (Name a) = Name
114 toColumns a = HType (Col a)
115 fromColumns (HType (Col a)) = a
118instance
119 ( Table context a, Table context b
120 , Labelable context
121 ) =>
122 Table context (a, b)
123 where
124 type Columns (a, b) =
125 HPair
126 (HLabel "fst" (Columns a))
127 (HLabel "snd" (Columns b))
128 type Context (a, b) = Context a
130 toColumns (a, b) = HPair
131 { hfst = hlabel labeler $ toColumns a
132 , hsnd = hlabel labeler $ toColumns b
133 }
134 fromColumns (HPair a b) =
135 ( fromColumns $ hunlabel unlabeler a
136 , fromColumns $ hunlabel unlabeler b
137 )
140instance
141 ( Table context a, Table context b, Table context c
142 , Labelable context
143 ) => Table context (a, b, c)
144 where
145 type Columns (a, b, c) =
146 HTrio
147 (HLabel "fst" (Columns a))
148 (HLabel "snd" (Columns b))
149 (HLabel "trd" (Columns c))
150 type Context (a, b, c) = Context a
152 toColumns (a, b, c) = HTrio
153 { hfst = hlabel labeler $ toColumns a
154 , hsnd = hlabel labeler $ toColumns b
155 , htrd = hlabel labeler $ toColumns c
156 }
157 fromColumns (HTrio a b c) =
158 ( fromColumns $ hunlabel unlabeler a
159 , fromColumns $ hunlabel unlabeler b
160 , fromColumns $ hunlabel unlabeler c
161 )
164instance
165 ( Table context a, Table context b, Table context c, Table context d
166 , Labelable context
167 ) => Table context (a, b, c, d)
168 where
169 type Columns (a, b, c, d) =
170 HQuartet
171 (HLabel "fst" (Columns a))
172 (HLabel "snd" (Columns b))
173 (HLabel "trd" (Columns c))
174 (HLabel "frt" (Columns d))
175 type Context (a, b, c, d) = Context a
177 toColumns (a, b, c, d) = HQuartet
178 { hfst = hlabel labeler $ toColumns a
179 , hsnd = hlabel labeler $ toColumns b
180 , htrd = hlabel labeler $ toColumns c
181 , hfrt = hlabel labeler $ toColumns d
182 }
183 fromColumns (HQuartet a b c d) =
184 ( fromColumns $ hunlabel unlabeler a
185 , fromColumns $ hunlabel unlabeler b
186 , fromColumns $ hunlabel unlabeler c
187 , fromColumns $ hunlabel unlabeler d
188 )
191instance
192 ( Table context a, Table context b, Table context c, Table context d
193 , Table context e
194 , Labelable context
195 ) => Table context (a, b, c, d, e)
196 where
197 type Columns (a, b, c, d, e) =
198 HQuintet
199 (HLabel "fst" (Columns a))
200 (HLabel "snd" (Columns b))
201 (HLabel "trd" (Columns c))
202 (HLabel "frt" (Columns d))
203 (HLabel "fft" (Columns e))
204 type Context (a, b, c, d, e) = Context a
206 toColumns (a, b, c, d, e) = HQuintet
207 { hfst = hlabel labeler $ toColumns a
208 , hsnd = hlabel labeler $ toColumns b
209 , htrd = hlabel labeler $ toColumns c
210 , hfrt = hlabel labeler $ toColumns d
211 , hfft = hlabel labeler $ toColumns e
212 }
213 fromColumns (HQuintet a b c d e) =
214 ( fromColumns $ hunlabel unlabeler a
215 , fromColumns $ hunlabel unlabeler b
216 , fromColumns $ hunlabel unlabeler c
217 , fromColumns $ hunlabel unlabeler d
218 , fromColumns $ hunlabel unlabeler e
219 )
222instance Table Expr Opaque where
223 type Columns Opaque = HType Opaque
224 type Context Opaque = Expr
226 fromColumns = error "opaque"
227 toColumns = error "opaque"
230instance Table context (Opaque1 context a) where
231 type Columns (Opaque1 context a) = HType Opaque
232 type Context (Opaque1 context a) = context
234 fromColumns = error "opaque"
235 toColumns = error "opaque"
238type Congruent :: Type -> Type -> Constraint
239class Columns a ~ Columns b => Congruent a b
240instance Columns a ~ Columns b => Congruent a b