git.iko.soy/rel8
on 1c73ec6 help sign in
rel8/src/Rel8/Table.hs
423 lines 13 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.Generic.Table
37 ( GTable, GColumns, GContext, GUnreify
38 , fromGColumns, toGColumns, greify, gunreify
39 )
40import Rel8.Generic.Record ( Record(..) )
41import Rel8.Schema.Context ( Col(..) )
42import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
43import Rel8.Schema.HTable ( HTable )
44import Rel8.Schema.HTable.Either ( HEitherTable(..) )
45import Rel8.Schema.HTable.Identity ( HIdentity(..) )
46import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
47import Rel8.Schema.HTable.List ( HListTable )
48import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
49import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
50import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
51import Rel8.Schema.HTable.These ( HTheseTable(..) )
52import Rel8.Schema.HTable.Type ( HType( HType ) )
53import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
54import qualified Rel8.Schema.Kind as K
55import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
56import Rel8.Schema.Reify
57 ( Reify, Col( Reify ), hreify, hunreify
58 , UnwrapReify
59 , notReify
60 )
61import Rel8.Schema.Result ( Result )
62import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )
63import Rel8.Type ( DBType )
64import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
66-- these
67import Data.These ( These( This, That, These ) )
68import Data.These.Combinators ( justHere, justThere )
71-- | @Table@s are one of the foundational elements of Rel8, and describe data
72-- types that have a finite number of columns. Each of these columns contains
73-- data under a shared context, and contexts describe how to interpret the
74-- metadata about a column to a particular Haskell type. In Rel8, we have
75-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
76-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
77-- others.
78--
79-- In typical usage of Rel8 you don't need to derive instances of 'Table'
80-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
81-- 'Table'.
82type Table :: K.Context -> Type -> Constraint
83class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
84 -- | The 'HTable' functor that describes the schema of this table.
85 type Columns a :: K.HTable
87 -- | The common context that all columns use as an interpretation.
88 type Context a :: K.Context
90 type Unreify a :: Type
92 toColumns :: a -> Columns a (Col context)
93 fromColumns :: Columns a (Col context) -> a
95 reify :: context :~: Reify ctx -> Unreify a -> a
96 unreify :: context :~: Reify ctx -> a -> Unreify a
98 type Columns a = GColumns TColumns (Rep (Record a))
99 type Context a = GContext TContext (Rep (Record a))
100 type Unreify a = DefaultUnreify a
102 default toColumns ::
103 ( Generic (Record a)
104 , GTable (TTable context) TColumns (Col context) (Rep (Record a))
105 , Columns a ~ GColumns TColumns (Rep (Record a))
106 )
107 => a -> Columns a (Col context)
108 toColumns =
109 toGColumns @(TTable context) @TColumns toColumns .
110 from .
111 Record
113 default fromColumns ::
114 ( Generic (Record a)
115 , GTable (TTable context) TColumns (Col context) (Rep (Record a))
116 , Columns a ~ GColumns TColumns (Rep (Record a))
117 )
118 => Columns a (Col context) -> a
119 fromColumns =
120 unrecord .
121 to .
122 fromGColumns @(TTable context) @TColumns fromColumns
124 default reify ::
125 ( Generic (Record a)
126 , Generic (Record (Unreify a))
127 , GTable (TTable context) TColumns (Col context) (Rep (Record a))
128 , Rep (Record (Unreify a)) ~ GUnreify TUnreify (Rep (Record a))
129 )
130 => context :~: Reify ctx -> Unreify a -> a
131 reify Refl =
132 unrecord .
133 to .
134 greify @(TTable context) @TColumns @(Col context) (Proxy @TUnreify)
135 (reify Refl) .
136 from .
137 Record
139 default unreify ::
140 ( Generic (Record a)
141 , Generic (Record (Unreify a))
142 , GTable (TTable context) TColumns (Col context) (Rep (Record a))
143 , Rep (Record (Unreify a)) ~ GUnreify TUnreify (Rep (Record a))
144 )
145 => context :~: Reify ctx -> a -> Unreify a
146 unreify Refl =
147 unrecord .
148 to .
149 gunreify @(TTable context) @TColumns @(Col context) (Proxy @TUnreify)
150 (unreify Refl) .
151 from .
152 Record
155data TTable :: K.Context -> Type -> Exp Constraint
156type instance Eval (TTable context a) = Table context a
159data TColumns :: Type -> Exp K.HTable
160type instance Eval (TColumns a) = Columns a
163data TContext :: Type -> Exp K.Context
164type instance Eval (TContext a) = Context a
167data TUnreify :: Type -> Exp Type
168type instance Eval (TUnreify a) = Unreify a
171type DefaultUnreify :: Type -> Type
172type family DefaultUnreify a where
173 DefaultUnreify (t a b c d e f g) =
174 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)
175 DefaultUnreify (t a b c d e f) =
176 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)
177 DefaultUnreify (t a b c d e) =
178 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)
179 DefaultUnreify (t a b c d) =
180 t (Unreify a) (Unreify b) (Unreify c) (Unreify d)
181 DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)
182 DefaultUnreify (t a b) = t (Unreify a) (Unreify b)
183 DefaultUnreify (t a) = t (Unreify a)
186-- | Any 'HTable' is also a 'Table'.
187instance HTable t => Table context (t (Col context)) where
188 type Columns (t (Col context)) = t
189 type Context (t (Col context)) = context
190 type Unreify (t (Col context)) = t (Col (UnwrapReify context))
192 toColumns = id
193 fromColumns = id
195 reify Refl = hreify
196 unreify Refl = hunreify
199-- | Any context is trivially a table.
200instance KnownSpec spec => Table context (Col context spec) where
201 type Columns (Col context spec) = HIdentity spec
202 type Context (Col context spec) = context
203 type Unreify (Col context spec) = Col (UnwrapReify context) spec
205 toColumns = HIdentity
206 fromColumns = unHIdentity
208 reify Refl = Reify
209 unreify Refl (Reify a) = a
212instance Sql DBType a => Table Result (Identity a) where
213 type Columns (Identity a) = HType a
214 type Context (Identity a) = Result
216 toColumns (Identity a) = HType (Result a)
217 fromColumns (HType (Result a)) = Identity a
219 reify = notReify
220 unreify = notReify
223instance (Table Result a, Table Result b) => Table Result (Either a b) where
224 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
225 type Context (Either a b) = Result
227 toColumns = \case
228 Left table -> HEitherTable
229 { htag = HIdentity (Result IsLeft)
230 , hleft = hlabel labeler (hnullify nullifier (toColumns table))
231 , hright = hlabel labeler (hnulls null)
232 }
233 Right table -> HEitherTable
234 { htag = HIdentity (Result IsRight)
235 , hleft = hlabel labeler (hnulls null)
236 , hright = hlabel labeler (hnullify nullifier (toColumns table))
237 }
239 fromColumns HEitherTable {htag, hleft, hright} = case htag of
240 HIdentity (Result tag) -> case tag of
241 IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
242 IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
243 where
244 err = error "Either.fromColumns: mismatch between tag and data"
246 reify = notReify
247 unreify = notReify
250instance Table Result a => Table Result [a] where
251 type Columns [a] = HListTable (Columns a)
252 type Context [a] = Result
254 toColumns = hvectorize vectorizer . fmap toColumns
255 fromColumns = fmap fromColumns . hunvectorize unvectorizer
257 reify = notReify
258 unreify = notReify
261instance Table Result a => Table Result (Maybe a) where
262 type Columns (Maybe a) = HMaybeTable (Columns a)
263 type Context (Maybe a) = Result
265 toColumns = \case
266 Nothing -> HMaybeTable
267 { htag = HIdentity (Result Nothing)
268 , hjust = hlabel labeler (hnulls null)
269 }
270 Just table -> HMaybeTable
271 { htag = HIdentity (Result (Just IsJust))
272 , hjust = hlabel labeler (hnullify nullifier (toColumns table))
273 }
275 fromColumns HMaybeTable {htag, hjust} = case htag of
276 HIdentity (Result tag) -> tag $>
277 case hunnullify unnullifier (hunlabel unlabeler hjust) of
278 Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
279 Just just -> fromColumns just
281 reify = notReify
282 unreify = notReify
285instance Table Result a => Table Result (NonEmpty a) where
286 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
287 type Context (NonEmpty a) = Result
289 toColumns = hvectorize vectorizer . fmap toColumns
290 fromColumns = fmap fromColumns . hunvectorize unvectorizer
292 reify = notReify
293 unreify = notReify
296instance (Table Result a, Table Result b) => Table Result (These a b) where
297 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
298 type Context (These a b) = Result
300 toColumns tables = HTheseTable
301 { hhereTag = relabel hhereTag
302 , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
303 , hthereTag = relabel hthereTag
304 , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
305 }
306 where
307 HMaybeTable
308 { htag = hhereTag
309 , hjust = hhere
310 } = toColumns (justHere tables)
311 HMaybeTable
312 { htag = hthereTag
313 , hjust = hthere
314 } = toColumns (justThere tables)
316 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
317 case (fromColumns mhere, fromColumns mthere) of
318 (Just a, Nothing) -> This (fromColumns a)
319 (Nothing, Just b) -> That (fromColumns b)
320 (Just a, Just b) -> These (fromColumns a) (fromColumns b)
321 _ -> error "These.fromColumns: mismatch between tags and data"
322 where
323 mhere = HMaybeTable
324 { htag = relabel hhereTag
325 , hjust = hlabel labeler (hunlabel unlabeler hhere)
326 }
327 mthere = HMaybeTable
328 { htag = relabel hthereTag
329 , hjust = hlabel labeler (hunlabel unlabeler hthere)
330 }
332 reify = notReify
333 unreify = notReify
336instance (Table context a, Table context b, Labelable context)
337 => Table context (a, b)
340instance
341 ( Table context a, Table context b, Table context c
342 , Labelable context
343 )
344 => Table context (a, b, c)
347instance
348 ( Table context a, Table context b, Table context c, Table context d
349 , Labelable context
350 )
351 => Table context (a, b, c, d)
354instance
355 ( Table context a, Table context b, Table context c, Table context d
356 , Table context e
357 , Labelable context
358 )
359 => Table context (a, b, c, d, e)
362instance
363 ( Table context a, Table context b, Table context c, Table context d
364 , Table context e, Table context f
365 , Labelable context
366 )
367 => Table context (a, b, c, d, e, f)
370instance
371 ( Table context a, Table context b, Table context c, Table context d
372 , Table context e, Table context f, Table context g
373 , Labelable context
374 )
375 => Table context (a, b, c, d, e, f, g)
378type Congruent :: Type -> Type -> Constraint
379class Columns a ~ Columns b => Congruent a b
380instance Columns a ~ Columns b => Congruent a b
383null :: Col Result ('Spec labels necessity (Maybe a))
384null = Result Nothing
387nullifier :: ()
388 => SSpec ('Spec labels necessity a)
389 -> Col Result ('Spec labels necessity a)
390 -> Col Result ('Spec labels necessity (Nullify a))
391nullifier SSpec {nullity} (Result a) = Result $ case nullity of
392 Null -> a
393 NotNull -> Just a
396unnullifier :: ()
397 => SSpec ('Spec labels necessity a)
398 -> Col Result ('Spec labels necessity (Nullify a))
399 -> Maybe (Col Result ('Spec labels necessity a))
400unnullifier SSpec {nullity} (Result a) =
401 case nullity of
402 Null -> pure $ Result a
403 NotNull -> Result <$> a
406vectorizer :: Functor f
407 => SSpec ('Spec labels necessity a)
408 -> f (Col Result ('Spec labels necessity a))
409 -> Col Result ('Spec labels necessity (f a))
410vectorizer _ = Result . fmap (\(Result a) -> a)
413unvectorizer :: Functor f
414 => SSpec ('Spec labels necessity a)
415 -> Col Result ('Spec labels necessity (f a))
416 -> f (Col Result ('Spec labels necessity a))
417unvectorizer _ (Result results) = Result <$> results
420relabel :: ()
421 => HIdentity ('Spec labels necessity a) (Col Result)
422 -> HIdentity ('Spec relabels necessity a) (Col Result)
423relabel (HIdentity (Result a)) = HIdentity (Result a)