git.iko.soy/rel8
on f3daaff help sign in
rel8/src/Rel8/Table.hs
246 lines 7.4 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 ( Col(..), Insertion(..), Name(..) )
27import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
28import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
29import Rel8.Schema.HTable.Identity ( HIdentity(..) )
30import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
31import Rel8.Schema.HTable.Pair ( HPair(..) )
32import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
33import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
34import Rel8.Schema.HTable.Trio ( HTrio(..) )
35import Rel8.Schema.HTable.Type ( HType( HType ) )
36import qualified Rel8.Schema.Kind as K
37import Rel8.Schema.Nullability ( Sql )
38import Rel8.Schema.Spec ( SSpec( SSpec ), KnownSpec )
39import Rel8.Type ( DBType )
42-- | @Table@s are one of the foundational elements of Rel8, and describe data
43-- types that have a finite number of columns. Each of these columns contains
44-- data under a shared context, and contexts describe how to interpret the
45-- metadata about a column to a particular Haskell type. In Rel8, we have
46-- contexts for expressions (the 'Expr' context), aggregations (the 'Aggregate'
47-- context), insert values (the 'Insert' contex), among others.
48--
49-- In typical usage of Rel8 you don't need to derive instances of 'Table'
50-- yourself, as anything that's an instance of 'Rel8able' is always a 'Table'.
51type Table :: K.Context -> Type -> Constraint
52class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
53 -- | The 'HTable' functor that describes the schema of this table.
54 type Columns a :: K.HTable
56 -- | The common context that all columns use as an interpretation.
57 type Context a :: K.Context
59 toColumns :: a -> Columns a (Col (Context a))
60 fromColumns :: Columns a (Col (Context a)) -> a
63-- | Any 'HTable' is also a 'Table'.
64instance HTable t => Table context (t (Col context)) where
65 type Columns (t (Col context)) = t
66 type Context (t (Col context)) = context
68 toColumns = id
69 fromColumns = id
72-- | Any context is trivially a table.
73instance KnownSpec spec => Table context (Col context spec) where
74 type Columns (Col context spec) = HIdentity spec
75 type Context (Col context spec) = context
77 toColumns = HIdentity
78 fromColumns = unHIdentity
81instance Table Expr a => Table Aggregate (Aggregate a) where
82 type Columns (Aggregate a) = Columns a
83 type Context (Aggregate a) = Aggregate
85 toColumns a = htabulate $ \field -> case hfield hspecs field of
86 SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
87 fromColumns as = fmap fromColumns $ htabulateA $ \field ->
88 case hfield as field of
89 Aggregation a -> DB <$> a
92instance Sql DBType a => Table Expr (Expr a) where
93 type Columns (Expr a) = HType a
94 type Context (Expr a) = Expr
96 toColumns a = HType (DB a)
97 fromColumns (HType (DB a)) = a
100instance Sql DBType a => Table Identity (Identity a) where
101 type Columns (Identity a) = HType a
102 type Context (Identity a) = Identity
104 toColumns (Identity a) = HType (Result a)
105 fromColumns (HType (Result a)) = Identity a
108instance Sql DBType a => Table Insertion (Insertion a) where
109 type Columns (Insertion a) = HType a
110 type Context (Insertion a) = Insertion
112 toColumns (Insertion a) = HType (RequiredInsert a)
113 fromColumns (HType (RequiredInsert a)) = Insertion a
116instance Sql DBType a => Table Name (Name a) where
117 type Columns (Name a) = HType a
118 type Context (Name a) = Name
120 toColumns (Name a) = HType (NameCol a)
121 fromColumns (HType (NameCol a)) = Name a
124instance
125 ( Table context a, Table context b
126 , Labelable context
127 ) =>
128 Table context (a, b)
129 where
130 type Columns (a, b) =
131 HPair
132 (HLabel "fst" (Columns a))
133 (HLabel "snd" (Columns b))
134 type Context (a, b) = Context a
136 toColumns (a, b) = HPair
137 { hfst = hlabel labeler $ toColumns a
138 , hsnd = hlabel labeler $ toColumns b
139 }
140 fromColumns (HPair a b) =
141 ( fromColumns $ hunlabel unlabeler a
142 , fromColumns $ hunlabel unlabeler b
143 )
146instance
147 ( Table context a, Table context b, Table context c
148 , Labelable context
149 ) => Table context (a, b, c)
150 where
151 type Columns (a, b, c) =
152 HTrio
153 (HLabel "fst" (Columns a))
154 (HLabel "snd" (Columns b))
155 (HLabel "trd" (Columns c))
156 type Context (a, b, c) = Context a
158 toColumns (a, b, c) = HTrio
159 { hfst = hlabel labeler $ toColumns a
160 , hsnd = hlabel labeler $ toColumns b
161 , htrd = hlabel labeler $ toColumns c
162 }
163 fromColumns (HTrio a b c) =
164 ( fromColumns $ hunlabel unlabeler a
165 , fromColumns $ hunlabel unlabeler b
166 , fromColumns $ hunlabel unlabeler c
167 )
170instance
171 ( Table context a, Table context b, Table context c, Table context d
172 , Labelable context
173 ) => Table context (a, b, c, d)
174 where
175 type Columns (a, b, c, d) =
176 HQuartet
177 (HLabel "fst" (Columns a))
178 (HLabel "snd" (Columns b))
179 (HLabel "trd" (Columns c))
180 (HLabel "frt" (Columns d))
181 type Context (a, b, c, d) = Context a
183 toColumns (a, b, c, d) = HQuartet
184 { hfst = hlabel labeler $ toColumns a
185 , hsnd = hlabel labeler $ toColumns b
186 , htrd = hlabel labeler $ toColumns c
187 , hfrt = hlabel labeler $ toColumns d
188 }
189 fromColumns (HQuartet a b c d) =
190 ( fromColumns $ hunlabel unlabeler a
191 , fromColumns $ hunlabel unlabeler b
192 , fromColumns $ hunlabel unlabeler c
193 , fromColumns $ hunlabel unlabeler d
194 )
197instance
198 ( Table context a, Table context b, Table context c, Table context d
199 , Table context e
200 , Labelable context
201 ) => Table context (a, b, c, d, e)
202 where
203 type Columns (a, b, c, d, e) =
204 HQuintet
205 (HLabel "fst" (Columns a))
206 (HLabel "snd" (Columns b))
207 (HLabel "trd" (Columns c))
208 (HLabel "frt" (Columns d))
209 (HLabel "fft" (Columns e))
210 type Context (a, b, c, d, e) = Context a
212 toColumns (a, b, c, d, e) = HQuintet
213 { hfst = hlabel labeler $ toColumns a
214 , hsnd = hlabel labeler $ toColumns b
215 , htrd = hlabel labeler $ toColumns c
216 , hfrt = hlabel labeler $ toColumns d
217 , hfft = hlabel labeler $ toColumns e
218 }
219 fromColumns (HQuintet a b c d e) =
220 ( fromColumns $ hunlabel unlabeler a
221 , fromColumns $ hunlabel unlabeler b
222 , fromColumns $ hunlabel unlabeler c
223 , fromColumns $ hunlabel unlabeler d
224 , fromColumns $ hunlabel unlabeler e
225 )
228instance Table Expr Opaque where
229 type Columns Opaque = HType Opaque
230 type Context Opaque = Expr
232 fromColumns = error "opaque"
233 toColumns = error "opaque"
236instance Table context (Opaque1 context a) where
237 type Columns (Opaque1 context a) = HType Opaque
238 type Context (Opaque1 context a) = context
240 fromColumns = error "opaque"
241 toColumns = error "opaque"
244type Congruent :: Type -> Type -> Constraint
245class Columns a ~ Columns b => Congruent a b
246instance Columns a ~ Columns b => Congruent a b