git.iko.soy/rel8
on 00a36f5 help sign in
rel8/src/Rel8/Table.hs
252 lines 7.5 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 )
44-- | @Table@s are one of the foundational elements of Rel8, and describe data
45-- types that have a finite number of columns. Each of these columns contains
46-- data under a shared context, and contexts describe how to interpret the
47-- metadata about a column to a particular Haskell type. In Rel8, we have
48-- contexts for expressions (the 'Expr' context), aggregations (the 'Aggregate'
49-- context), insert values (the 'Insert' contex), among others.
50--
51-- In typical usage of Rel8 you don't need to derive instances of 'Table'
52-- yourself, as anything that's an instance of 'Rel8able' is always a 'Table'.
53type Table :: K.Context -> Type -> Constraint
54class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
55 -- | The 'HTable' functor that describes the schema of this table.
56 type Columns a :: K.HTable
58 -- | The common context that all columns use as an interpretation.
59 type Context a :: K.Context
61 toColumns :: a -> Columns a (Col (Context a))
62 fromColumns :: Columns a (Col (Context a)) -> a
65-- | Any 'HTable' is also a 'Table'.
66instance (HTable t, x ~ IsSpecialContext context) =>
67 Table context (t (Col' x context))
68 where
69 type Columns (t (Col' x context)) = t
70 type Context (t (Col' x context)) = context
72 toColumns = id
73 fromColumns = id
76-- | Any context is trivially a table.
77instance (KnownSpec spec, x ~ IsSpecialContext context) =>
78 Table context (Col' x context spec)
79 where
80 type Columns (Col' x context spec) = HIdentity spec
81 type Context (Col' x context spec) = context
83 toColumns = HIdentity
84 fromColumns = unHIdentity
87instance Table Expr a => Table Aggregate (Aggregate a) where
88 type Columns (Aggregate a) = Columns a
89 type Context (Aggregate a) = Aggregate
91 toColumns a = htabulate $ \field -> case hfield hspecs field of
92 SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
93 fromColumns as = fmap fromColumns $ htabulateA $ \field ->
94 case hfield as field of
95 Aggregation a -> DB <$> a
98instance Sql DBType a => Table Expr (Expr a) where
99 type Columns (Expr a) = HType a
100 type Context (Expr a) = Expr
102 toColumns a = HType (DB a)
103 fromColumns (HType (DB a)) = a
106instance Sql DBType a => Table Identity (Identity a) where
107 type Columns (Identity a) = HType a
108 type Context (Identity a) = Identity
110 toColumns (Identity a) = HType (Result a)
111 fromColumns (HType (Result a)) = Identity a
114instance Sql DBType a => Table Insertion (Insertion a) where
115 type Columns (Insertion a) = HType a
116 type Context (Insertion a) = Insertion
118 toColumns (Insertion a) = HType (RequiredInsert a)
119 fromColumns (HType (RequiredInsert a)) = Insertion a
122instance Sql DBType a => Table Name (Name a) where
123 type Columns (Name a) = HType a
124 type Context (Name a) = Name
126 toColumns a = HType (Col a)
127 fromColumns (HType (Col a)) = a
130instance
131 ( Table context a, Table context b
132 , Labelable context
133 ) =>
134 Table context (a, b)
135 where
136 type Columns (a, b) =
137 HPair
138 (HLabel "fst" (Columns a))
139 (HLabel "snd" (Columns b))
140 type Context (a, b) = Context a
142 toColumns (a, b) = HPair
143 { hfst = hlabel labeler $ toColumns a
144 , hsnd = hlabel labeler $ toColumns b
145 }
146 fromColumns (HPair a b) =
147 ( fromColumns $ hunlabel unlabeler a
148 , fromColumns $ hunlabel unlabeler b
149 )
152instance
153 ( Table context a, Table context b, Table context c
154 , Labelable context
155 ) => Table context (a, b, c)
156 where
157 type Columns (a, b, c) =
158 HTrio
159 (HLabel "fst" (Columns a))
160 (HLabel "snd" (Columns b))
161 (HLabel "trd" (Columns c))
162 type Context (a, b, c) = Context a
164 toColumns (a, b, c) = HTrio
165 { hfst = hlabel labeler $ toColumns a
166 , hsnd = hlabel labeler $ toColumns b
167 , htrd = hlabel labeler $ toColumns c
168 }
169 fromColumns (HTrio a b c) =
170 ( fromColumns $ hunlabel unlabeler a
171 , fromColumns $ hunlabel unlabeler b
172 , fromColumns $ hunlabel unlabeler c
173 )
176instance
177 ( Table context a, Table context b, Table context c, Table context d
178 , Labelable context
179 ) => Table context (a, b, c, d)
180 where
181 type Columns (a, b, c, d) =
182 HQuartet
183 (HLabel "fst" (Columns a))
184 (HLabel "snd" (Columns b))
185 (HLabel "trd" (Columns c))
186 (HLabel "frt" (Columns d))
187 type Context (a, b, c, d) = Context a
189 toColumns (a, b, c, d) = HQuartet
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 }
195 fromColumns (HQuartet a b c d) =
196 ( fromColumns $ hunlabel unlabeler a
197 , fromColumns $ hunlabel unlabeler b
198 , fromColumns $ hunlabel unlabeler c
199 , fromColumns $ hunlabel unlabeler d
200 )
203instance
204 ( Table context a, Table context b, Table context c, Table context d
205 , Table context e
206 , Labelable context
207 ) => Table context (a, b, c, d, e)
208 where
209 type Columns (a, b, c, d, e) =
210 HQuintet
211 (HLabel "fst" (Columns a))
212 (HLabel "snd" (Columns b))
213 (HLabel "trd" (Columns c))
214 (HLabel "frt" (Columns d))
215 (HLabel "fft" (Columns e))
216 type Context (a, b, c, d, e) = Context a
218 toColumns (a, b, c, d, e) = HQuintet
219 { hfst = hlabel labeler $ toColumns a
220 , hsnd = hlabel labeler $ toColumns b
221 , htrd = hlabel labeler $ toColumns c
222 , hfrt = hlabel labeler $ toColumns d
223 , hfft = hlabel labeler $ toColumns e
224 }
225 fromColumns (HQuintet a b c d e) =
226 ( fromColumns $ hunlabel unlabeler a
227 , fromColumns $ hunlabel unlabeler b
228 , fromColumns $ hunlabel unlabeler c
229 , fromColumns $ hunlabel unlabeler d
230 , fromColumns $ hunlabel unlabeler e
231 )
234instance Table Expr Opaque where
235 type Columns Opaque = HType Opaque
236 type Context Opaque = Expr
238 fromColumns = error "opaque"
239 toColumns = error "opaque"
242instance Table context (Opaque1 context a) where
243 type Columns (Opaque1 context a) = HType Opaque
244 type Context (Opaque1 context a) = context
246 fromColumns = error "opaque"
247 toColumns = error "opaque"
250type Congruent :: Type -> Type -> Constraint
251class Columns a ~ Columns b => Congruent a b
252instance Columns a ~ Columns b => Congruent a b