git.iko.soy/rel8
on fb3d2d9 help sign in
rel8/src/Rel8/Table.hs
389 lines 12 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language DefaultSignatures #-}
4{-# language DisambiguateRecordFields #-}
5{-# language FlexibleContexts #-}
6{-# language FlexibleInstances #-}
7{-# language FunctionalDependencies #-}
8{-# language LambdaCase #-}
9{-# language NamedFieldPuns #-}
10{-# language ScopedTypeVariables #-}
11{-# language StandaloneKindSignatures #-}
12{-# language TypeApplications #-}
13{-# language TypeFamilies #-}
14{-# language TypeOperators #-}
15{-# language UndecidableInstances #-}
17module Rel8.Table
18 ( Table (Columns, Context, Unreify, toColumns, fromColumns, reify, unreify)
19 , Congruent
20 , TTable, TColumns, TContext, TUnreify
21 )
22where
24-- base
25import Data.Functor ( ($>) )
26import Data.Functor.Identity ( Identity( Identity ) )
27import Data.Kind ( Constraint, Type )
28import Data.List.NonEmpty ( NonEmpty )
29import Data.Proxy ( Proxy( Proxy ) )
30import Data.Type.Equality ( (:~:)( Refl ) )
31import GHC.Generics ( Generic, Rep, from, to )
32import Prelude hiding ( null )
34-- rel8
35import Rel8.FCF ( Eval, Exp )
36import Rel8.Kind.Algebra ( KnownAlgebra )
37import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )
38import Rel8.Generic.Table
39 ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns
40 , GAlgebra
41 )
42import Rel8.Generic.Record ( Record(..) )
43import Rel8.Generic.Reify ( ARep )
44import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
45import Rel8.Schema.HTable ( HTable )
46import Rel8.Schema.HTable.Either ( HEitherTable(..) )
47import Rel8.Schema.HTable.Identity ( HIdentity(..) )
48import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
49import Rel8.Schema.HTable.List ( HListTable )
50import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
51import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
52import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
53import Rel8.Schema.HTable.These ( HTheseTable(..) )
54import Rel8.Schema.HTable.Type ( HType( HType ) )
55import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
56import qualified Rel8.Schema.Kind as K
57import Rel8.Schema.Null ( Sql )
58import Rel8.Schema.Reify
59 ( Reify, Col( Reify ), hreify, hunreify
60 , UnwrapReify
61 , notReify
62 )
63import Rel8.Schema.Result
64 ( Col( Result ), Result
65 , relabel
66 , null, nullifier, unnullifier
67 , vectorizer, unvectorizer
68 )
69import Rel8.Schema.Spec ( KnownSpec )
70import Rel8.Type ( DBType )
71import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
73-- these
74import Data.These ( These( This, That, These ) )
75import Data.These.Combinators ( justHere, justThere )
78-- | @Table@s are one of the foundational elements of Rel8, and describe data
79-- types that have a finite number of columns. Each of these columns contains
80-- data under a shared context, and contexts describe how to interpret the
81-- metadata about a column to a particular Haskell type. In Rel8, we have
82-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
83-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
84-- others.
85--
86-- In typical usage of Rel8 you don't need to derive instances of 'Table'
87-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
88-- 'Table'.
89type Table :: K.Context -> Type -> Constraint
90class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
91 -- | The 'HTable' functor that describes the schema of this table.
92 type Columns a :: K.HTable
94 -- | The common context that all columns use as an interpretation.
95 type Context a :: K.Context
97 type Unreify a :: Type
99 toColumns :: a -> Columns a (Col context)
100 fromColumns :: Columns a (Col context) -> a
102 reify :: context :~: Reify ctx -> Unreify a -> a
103 unreify :: context :~: Reify ctx -> a -> Unreify a
105 type Columns a = Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
106 type Context a = Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
107 type Unreify a = DefaultUnreify a
109 default toColumns ::
110 ( Generic (Record a)
111 , KnownAlgebra (GAlgebra (Rep (Record a)))
112 , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))
113 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
114 , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
115 )
116 => a -> Columns a (Col context)
117 toColumns =
118 ggtoColumns
119 @(GAlgebra (Rep (Record a)))
120 @(TTable context)
121 @TColumns
122 @TContext
123 id
124 id
125 toColumns .
126 from .
127 Record
129 default fromColumns ::
130 ( Generic (Record a)
131 , KnownAlgebra (GAlgebra (Rep (Record a)))
132 , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))
133 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
134 , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
135 )
136 => Columns a (Col context) -> a
137 fromColumns =
138 unrecord .
139 to .
140 ggfromColumns
141 @(GAlgebra (Rep (Record a)))
142 @(TTable context)
143 @TColumns
144 @TContext
145 id
146 id
147 fromColumns
149 default reify ::
150 ( Generic (Record a)
151 , Generic (Record (Unreify a))
152 , GMappable (TTable context) (Rep (Record a))
153 , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
154 )
155 => context :~: Reify ctx -> Unreify a -> a
156 reify Refl =
157 unrecord .
158 to .
159 gunmap @(TTable context) (Proxy @TUnreify) (reify Refl) .
160 from .
161 Record
163 default unreify ::
164 ( Generic (Record a)
165 , Generic (Record (Unreify a))
166 , GMappable (TTable context) (Rep (Record a))
167 , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
168 )
169 => context :~: Reify ctx -> a -> Unreify a
170 unreify Refl =
171 unrecord .
172 to .
173 gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) .
174 from .
175 Record
178data TTable :: K.Context -> Type -> Exp Constraint
179type instance Eval (TTable context a) = Table context a
182data TColumns :: Type -> Exp K.HTable
183type instance Eval (TColumns a) = Columns a
186data TContext :: Type -> Exp K.Context
187type instance Eval (TContext a) = Context a
190data TUnreify :: Type -> Exp Type
191type instance Eval (TUnreify a) = Unreify a
194type DefaultUnreify :: Type -> Type
195type family DefaultUnreify a where
196 DefaultUnreify (t a b c d e f g) =
197 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)
198 DefaultUnreify (t a b c d e f) =
199 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)
200 DefaultUnreify (t a b c d e) =
201 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)
202 DefaultUnreify (t a b c d) =
203 t (Unreify a) (Unreify b) (Unreify c) (Unreify d)
204 DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)
205 DefaultUnreify (t a b) = t (Unreify a) (Unreify b)
206 DefaultUnreify (t a) = t (Unreify a)
207 DefaultUnreify a = ARep (GMap TUnreify (Rep a))
210-- | Any 'HTable' is also a 'Table'.
211instance HTable t => Table context (t (Col context)) where
212 type Columns (t (Col context)) = t
213 type Context (t (Col context)) = context
214 type Unreify (t (Col context)) = t (Col (UnwrapReify context))
216 toColumns = id
217 fromColumns = id
219 reify Refl = hreify
220 unreify Refl = hunreify
223-- | Any context is trivially a table.
224instance KnownSpec spec => Table context (Col context spec) where
225 type Columns (Col context spec) = HIdentity spec
226 type Context (Col context spec) = context
227 type Unreify (Col context spec) = Col (UnwrapReify context) spec
229 toColumns = HIdentity
230 fromColumns = unHIdentity
232 reify Refl = Reify
233 unreify Refl (Reify a) = a
236instance Sql DBType a => Table Result (Identity a) where
237 type Columns (Identity a) = HType a
238 type Context (Identity a) = Result
240 toColumns (Identity a) = HType (Result a)
241 fromColumns (HType (Result a)) = Identity a
243 reify = notReify
244 unreify = notReify
247instance (Table Result a, Table Result b) => Table Result (Either a b) where
248 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
249 type Context (Either a b) = Result
251 toColumns = \case
252 Left table -> HEitherTable
253 { htag = HIdentity (Result IsLeft)
254 , hleft = hlabel labeler (hnullify nullifier (toColumns table))
255 , hright = hlabel labeler (hnulls null)
256 }
257 Right table -> HEitherTable
258 { htag = HIdentity (Result IsRight)
259 , hleft = hlabel labeler (hnulls null)
260 , hright = hlabel labeler (hnullify nullifier (toColumns table))
261 }
263 fromColumns HEitherTable {htag, hleft, hright} = case htag of
264 HIdentity (Result tag) -> case tag of
265 IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
266 IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
267 where
268 err = error "Either.fromColumns: mismatch between tag and data"
271instance Table Result a => Table Result [a] where
272 type Columns [a] = HListTable (Columns a)
273 type Context [a] = Result
275 toColumns = hvectorize vectorizer . fmap toColumns
276 fromColumns = fmap fromColumns . hunvectorize unvectorizer
279instance Table Result a => Table Result (Maybe a) where
280 type Columns (Maybe a) = HMaybeTable (Columns a)
281 type Context (Maybe a) = Result
283 toColumns = \case
284 Nothing -> HMaybeTable
285 { htag = HIdentity (Result Nothing)
286 , hjust = hlabel labeler (hnulls null)
287 }
288 Just table -> HMaybeTable
289 { htag = HIdentity (Result (Just IsJust))
290 , hjust = hlabel labeler (hnullify nullifier (toColumns table))
291 }
293 fromColumns HMaybeTable {htag, hjust} = case htag of
294 HIdentity (Result tag) -> tag $>
295 case hunnullify unnullifier (hunlabel unlabeler hjust) of
296 Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
297 Just just -> fromColumns just
300instance Table Result a => Table Result (NonEmpty a) where
301 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
302 type Context (NonEmpty a) = Result
304 toColumns = hvectorize vectorizer . fmap toColumns
305 fromColumns = fmap fromColumns . hunvectorize unvectorizer
308instance (Table Result a, Table Result b) => Table Result (These a b) where
309 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
310 type Context (These a b) = Result
312 toColumns tables = HTheseTable
313 { hhereTag = relabel hhereTag
314 , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
315 , hthereTag = relabel hthereTag
316 , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
317 }
318 where
319 HMaybeTable
320 { htag = hhereTag
321 , hjust = hhere
322 } = toColumns (justHere tables)
323 HMaybeTable
324 { htag = hthereTag
325 , hjust = hthere
326 } = toColumns (justThere tables)
328 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
329 case (fromColumns mhere, fromColumns mthere) of
330 (Just a, Nothing) -> This (fromColumns a)
331 (Nothing, Just b) -> That (fromColumns b)
332 (Just a, Just b) -> These (fromColumns a) (fromColumns b)
333 _ -> error "These.fromColumns: mismatch between tags and data"
334 where
335 mhere = HMaybeTable
336 { htag = relabel hhereTag
337 , hjust = hlabel labeler (hunlabel unlabeler hhere)
338 }
339 mthere = HMaybeTable
340 { htag = relabel hthereTag
341 , hjust = hlabel labeler (hunlabel unlabeler hthere)
342 }
345instance (Table context a, Table context b, Labelable context)
346 => Table context (a, b)
349instance
350 ( Table context a, Table context b, Table context c
351 , Labelable context
352 )
353 => Table context (a, b, c)
356instance
357 ( Table context a, Table context b, Table context c, Table context d
358 , Labelable context
359 )
360 => Table context (a, b, c, d)
363instance
364 ( Table context a, Table context b, Table context c, Table context d
365 , Table context e
366 , Labelable context
367 )
368 => Table context (a, b, c, d, e)
371instance
372 ( Table context a, Table context b, Table context c, Table context d
373 , Table context e, Table context f
374 , Labelable context
375 )
376 => Table context (a, b, c, d, e, f)
379instance
380 ( Table context a, Table context b, Table context c, Table context d
381 , Table context e, Table context f, Table context g
382 , Labelable context
383 )
384 => Table context (a, b, c, d, e, f, g)
387type Congruent :: Type -> Type -> Constraint
388class Columns a ~ Columns b => Congruent a b
389instance Columns a ~ Columns b => Congruent a b