git.iko.soy/rel8
on 6d3959e help sign in
rel8/src/Rel8/Table.hs
438 lines 14 kB history raw
1{-# language DataKinds #-}
2{-# language DefaultSignatures #-}
3{-# language DisambiguateRecordFields #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
6{-# language FunctionalDependencies #-}
7{-# language LambdaCase #-}
8{-# language NamedFieldPuns #-}
9{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language TypeOperators #-}
14{-# language UndecidableInstances #-}
16module Rel8.Table
17 ( Table (Columns, Context)
18 , toColumns, fromColumns
19 , Congruent
20 , GTable, GColumns, GContext, fromGColumns, toGColumns
21 )
22where
24-- base
25import Data.Functor ( ($>) )
26import Data.Functor.Identity ( Identity( Identity ) )
27import Data.Kind ( Constraint, Type )
28import Data.List.NonEmpty ( NonEmpty )
29import GHC.Generics
30 ( Generic, Rep, from, to
31 , (:*:)( (:*:) ), K1( K1 ), M1( M1 )
32 , C, D, S
33 , Meta( MetaSel )
34 )
35import GHC.TypeLits ( KnownSymbol )
36import Prelude hiding ( null )
38-- rel8
39import Rel8.Generic.Record ( Record(..) )
40import Rel8.Schema.Context ( Col(..) )
41import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
42import Rel8.Schema.HTable ( HTable )
43import Rel8.Schema.HTable.Either ( HEitherTable(..) )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
46import Rel8.Schema.HTable.List ( HListTable )
47import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
48import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
49import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
50import Rel8.Schema.HTable.Pair ( HPair(..) )
51import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
52import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
53import Rel8.Schema.HTable.These ( HTheseTable(..) )
54import Rel8.Schema.HTable.Trio ( HTrio(..) )
55import Rel8.Schema.HTable.Type ( HType( HType ) )
56import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
57import qualified Rel8.Schema.Kind as K
58import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
59import Rel8.Schema.Result ( Result )
60import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )
61import Rel8.Type ( DBType )
62import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
64-- these
65import Data.These ( These( This, That, These ) )
66import Data.These.Combinators ( justHere, justThere )
69-- | @Table@s are one of the foundational elements of Rel8, and describe data
70-- types that have a finite number of columns. Each of these columns contains
71-- data under a shared context, and contexts describe how to interpret the
72-- metadata about a column to a particular Haskell type. In Rel8, we have
73-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
74-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
75-- others.
76--
77-- In typical usage of Rel8 you don't need to derive instances of 'Table'
78-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
79-- 'Table'.
80type Table :: K.Context -> Type -> Constraint
81class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
82 -- | The 'HTable' functor that describes the schema of this table.
83 type Columns a :: K.HTable
85 -- | The common context that all columns use as an interpretation.
86 type Context a :: K.Context
88 toColumns :: a -> Columns a (Col (Context a))
89 fromColumns :: Columns a (Col (Context a)) -> a
91 type Columns a = GColumns (Rep (Record a))
92 type Context a = GContext (Rep (Record a))
94 default toColumns ::
95 ( Generic (Record a), GTable (GContext (Rep (Record a))) (Rep (Record a))
96 , Columns a ~ GColumns (Rep (Record a))
97 , Context a ~ GContext (Rep (Record a))
98 )
99 => a -> Columns a (Col (Context a))
100 toColumns = toGColumns . from . Record
102 default fromColumns ::
103 ( Generic (Record a), GTable (GContext (Rep (Record a))) (Rep (Record a))
104 , Columns a ~ GColumns (Rep (Record a))
105 , Context a ~ GContext (Rep (Record a))
106 )
107 => Columns a (Col (Context a)) -> a
108 fromColumns = unrecord . to . fromGColumns
111type GColumns :: (Type -> Type) -> K.HTable
112type family GColumns rep where
113 GColumns (M1 D _ rep) = GColumns rep
114 GColumns (M1 C _ rep) = GColumns rep
115 GColumns (rep1 :*: rep2) = HPair (GColumns rep1) (GColumns rep2)
116 GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
117 HLabel label (Columns a)
120type GContext :: (Type -> Type) -> K.Context
121type family GContext rep where
122 GContext (M1 _ _ rep) = GContext rep
123 GContext (rep1 :*: _rep2) = GContext rep1
124 GContext (K1 _ a) = Context a
127type GTable :: K.Context -> (Type -> Type) -> Constraint
128class context ~ GContext rep => GTable context rep | rep -> context where
129 fromGColumns :: GColumns rep (Col context) -> rep x
130 toGColumns :: rep x -> GColumns rep (Col context)
133instance GTable context rep => GTable context (M1 D c rep) where
134 fromGColumns = M1 . fromGColumns @context @rep
135 toGColumns (M1 a) = toGColumns @context @rep a
138instance GTable context rep => GTable context (M1 C c rep) where
139 fromGColumns = M1 . fromGColumns @context @rep
140 toGColumns (M1 a) = toGColumns @context @rep a
143instance (GTable context rep1, GTable context rep2) =>
144 GTable context (rep1 :*: rep2)
145 where
146 fromGColumns (HPair a b) =
147 fromGColumns @context @rep1 a :*: fromGColumns @context @rep2 b
148 toGColumns (a :*: b) =
149 HPair (toGColumns @context @rep1 a) (toGColumns @context @rep2 b)
152instance
153 ( Table context a
154 , Labelable context
155 , KnownSymbol label
156 , GColumns (M1 S meta k1) ~ HLabel label (Columns a)
157 , meta ~ 'MetaSel ('Just label) _su _ss _ds
158 , k1 ~ K1 i a
159 ) => GTable context (M1 S meta k1)
160 where
161 fromGColumns = M1 . K1 . fromColumns . hunlabel unlabeler
162 toGColumns (M1 (K1 a)) = hlabel labeler (toColumns a)
165-- | Any 'HTable' is also a 'Table'.
166instance HTable t => Table context (t (Col context)) where
167 type Columns (t (Col context)) = t
168 type Context (t (Col context)) = context
170 toColumns = id
171 fromColumns = id
174-- | Any context is trivially a table.
175instance KnownSpec spec => Table context (Col context spec) where
176 type Columns (Col context spec) = HIdentity spec
177 type Context (Col context spec) = context
179 toColumns = HIdentity
180 fromColumns = unHIdentity
183instance Sql DBType a => Table Result (Identity a) where
184 type Columns (Identity a) = HType a
185 type Context (Identity a) = Result
187 toColumns (Identity a) = HType (Result a)
188 fromColumns (HType (Result a)) = Identity a
191instance (Table Result a, Table Result b) => Table Result (Either a b) where
192 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
193 type Context (Either a b) = Result
195 toColumns = \case
196 Left table -> HEitherTable
197 { htag = HIdentity (Result IsLeft)
198 , hleft = hlabel labeler (hnullify nullifier (toColumns table))
199 , hright = hlabel labeler (hnulls null)
200 }
201 Right table -> HEitherTable
202 { htag = HIdentity (Result IsRight)
203 , hleft = hlabel labeler (hnulls null)
204 , hright = hlabel labeler (hnullify nullifier (toColumns table))
205 }
207 fromColumns HEitherTable {htag, hleft, hright} = case htag of
208 HIdentity (Result tag) -> case tag of
209 IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
210 IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
211 where
212 err = error "Either.fromColumns: mismatch between tag and data"
215instance Table Result a => Table Result [a] where
216 type Columns [a] = HListTable (Columns a)
217 type Context [a] = Result
219 toColumns = hvectorize vectorizer . fmap toColumns
220 fromColumns = fmap fromColumns . hunvectorize unvectorizer
223instance Table Result a => Table Result (Maybe a) where
224 type Columns (Maybe a) = HMaybeTable (Columns a)
225 type Context (Maybe a) = Result
227 toColumns = \case
228 Nothing -> HMaybeTable
229 { htag = HIdentity (Result Nothing)
230 , hjust = hlabel labeler (hnulls null)
231 }
232 Just table -> HMaybeTable
233 { htag = HIdentity (Result (Just IsJust))
234 , hjust = hlabel labeler (hnullify nullifier (toColumns table))
235 }
237 fromColumns HMaybeTable {htag, hjust} = case htag of
238 HIdentity (Result tag) -> tag $>
239 case hunnullify unnullifier (hunlabel unlabeler hjust) of
240 Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
241 Just just -> fromColumns just
244instance Table Result a => Table Result (NonEmpty a) where
245 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
246 type Context (NonEmpty a) = Result
248 toColumns = hvectorize vectorizer . fmap toColumns
249 fromColumns = fmap fromColumns . hunvectorize unvectorizer
252instance (Table Result a, Table Result b) => Table Result (These a b) where
253 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
254 type Context (These a b) = Result
256 toColumns tables = HTheseTable
257 { hhereTag = relabel hhereTag
258 , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
259 , hthereTag = relabel hthereTag
260 , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
261 }
262 where
263 HMaybeTable
264 { htag = hhereTag
265 , hjust = hhere
266 } = toColumns (justHere tables)
267 HMaybeTable
268 { htag = hthereTag
269 , hjust = hthere
270 } = toColumns (justThere tables)
272 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
273 case (fromColumns mhere, fromColumns mthere) of
274 (Just a, Nothing) -> This (fromColumns a)
275 (Nothing, Just b) -> That (fromColumns b)
276 (Just a, Just b) -> These (fromColumns a) (fromColumns b)
277 _ -> error "These.fromColumns: mismatch between tags and data"
278 where
279 mhere = HMaybeTable
280 { htag = relabel hhereTag
281 , hjust = hlabel labeler (hunlabel unlabeler hhere)
282 }
283 mthere = HMaybeTable
284 { htag = relabel hthereTag
285 , hjust = hlabel labeler (hunlabel unlabeler hthere)
286 }
289instance
290 ( Table context a, Table context b
291 , Labelable context
292 ) =>
293 Table context (a, b)
294 where
295 type Columns (a, b) =
296 HPair
297 (HLabel "fst" (Columns a))
298 (HLabel "snd" (Columns b))
299 type Context (a, b) = Context a
301 toColumns (a, b) = HPair
302 { hfst = hlabel labeler $ toColumns a
303 , hsnd = hlabel labeler $ toColumns b
304 }
305 fromColumns (HPair a b) =
306 ( fromColumns $ hunlabel unlabeler a
307 , fromColumns $ hunlabel unlabeler b
308 )
311instance
312 ( Table context a, Table context b, Table context c
313 , Labelable context
314 ) => Table context (a, b, c)
315 where
316 type Columns (a, b, c) =
317 HTrio
318 (HLabel "fst" (Columns a))
319 (HLabel "snd" (Columns b))
320 (HLabel "trd" (Columns c))
321 type Context (a, b, c) = Context a
323 toColumns (a, b, c) = HTrio
324 { hfst = hlabel labeler $ toColumns a
325 , hsnd = hlabel labeler $ toColumns b
326 , htrd = hlabel labeler $ toColumns c
327 }
328 fromColumns (HTrio a b c) =
329 ( fromColumns $ hunlabel unlabeler a
330 , fromColumns $ hunlabel unlabeler b
331 , fromColumns $ hunlabel unlabeler c
332 )
335instance
336 ( Table context a, Table context b, Table context c, Table context d
337 , Labelable context
338 ) => Table context (a, b, c, d)
339 where
340 type Columns (a, b, c, d) =
341 HQuartet
342 (HLabel "fst" (Columns a))
343 (HLabel "snd" (Columns b))
344 (HLabel "trd" (Columns c))
345 (HLabel "frt" (Columns d))
346 type Context (a, b, c, d) = Context a
348 toColumns (a, b, c, d) = HQuartet
349 { hfst = hlabel labeler $ toColumns a
350 , hsnd = hlabel labeler $ toColumns b
351 , htrd = hlabel labeler $ toColumns c
352 , hfrt = hlabel labeler $ toColumns d
353 }
354 fromColumns (HQuartet a b c d) =
355 ( fromColumns $ hunlabel unlabeler a
356 , fromColumns $ hunlabel unlabeler b
357 , fromColumns $ hunlabel unlabeler c
358 , fromColumns $ hunlabel unlabeler d
359 )
362instance
363 ( Table context a, Table context b, Table context c, Table context d
364 , Table context e
365 , Labelable context
366 ) => Table context (a, b, c, d, e)
367 where
368 type Columns (a, b, c, d, e) =
369 HQuintet
370 (HLabel "fst" (Columns a))
371 (HLabel "snd" (Columns b))
372 (HLabel "trd" (Columns c))
373 (HLabel "frt" (Columns d))
374 (HLabel "fft" (Columns e))
375 type Context (a, b, c, d, e) = Context a
377 toColumns (a, b, c, d, e) = HQuintet
378 { hfst = hlabel labeler $ toColumns a
379 , hsnd = hlabel labeler $ toColumns b
380 , htrd = hlabel labeler $ toColumns c
381 , hfrt = hlabel labeler $ toColumns d
382 , hfft = hlabel labeler $ toColumns e
383 }
384 fromColumns (HQuintet a b c d e) =
385 ( fromColumns $ hunlabel unlabeler a
386 , fromColumns $ hunlabel unlabeler b
387 , fromColumns $ hunlabel unlabeler c
388 , fromColumns $ hunlabel unlabeler d
389 , fromColumns $ hunlabel unlabeler e
390 )
393type Congruent :: Type -> Type -> Constraint
394class Columns a ~ Columns b => Congruent a b
395instance Columns a ~ Columns b => Congruent a b
398null :: Col Result ('Spec labels necessity (Maybe a))
399null = Result Nothing
402nullifier :: ()
403 => SSpec ('Spec labels necessity a)
404 -> Col Result ('Spec labels necessity a)
405 -> Col Result ('Spec labels necessity (Nullify a))
406nullifier SSpec {nullity} (Result a) = Result $ case nullity of
407 Null -> a
408 NotNull -> Just a
411unnullifier :: ()
412 => SSpec ('Spec labels necessity a)
413 -> Col Result ('Spec labels necessity (Nullify a))
414 -> Maybe (Col Result ('Spec labels necessity a))
415unnullifier SSpec {nullity} (Result a) =
416 case nullity of
417 Null -> pure $ Result a
418 NotNull -> Result <$> a
421vectorizer :: Functor f
422 => SSpec ('Spec labels necessity a)
423 -> f (Col Result ('Spec labels necessity a))
424 -> Col Result ('Spec labels necessity (f a))
425vectorizer _ = Result . fmap (\(Result a) -> a)
428unvectorizer :: Functor f
429 => SSpec ('Spec labels necessity a)
430 -> Col Result ('Spec labels necessity (f a))
431 -> f (Col Result ('Spec labels necessity a))
432unvectorizer _ (Result results) = Result <$> results
435relabel :: ()
436 => HIdentity ('Spec labels necessity a) (Col Result)
437 -> HIdentity ('Spec relabels necessity a) (Col Result)
438relabel (HIdentity (Result a)) = HIdentity (Result a)