git.iko.soy/rel8
on 6c20afa help sign in
rel8/src/Rel8/Table.hs
422 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 , null, nullifier, unnullifier
22 )
23where
25-- base
26import Data.Functor ( ($>) )
27import Data.Functor.Identity ( Identity( Identity ) )
28import Data.Kind ( Constraint, Type )
29import Data.List.NonEmpty ( NonEmpty )
30import Data.Proxy ( Proxy( Proxy ) )
31import Data.Type.Equality ( (:~:)( Refl ) )
32import GHC.Generics ( Generic, Rep, from, to )
33import Prelude hiding ( null )
35-- rel8
36import Rel8.FCF ( Eval, Exp )
37import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )
38import Rel8.Generic.Table
39 ( GTable, GColumns, GContext, fromGColumns, toGColumns
40 )
41import Rel8.Generic.Record ( Record(..) )
42import Rel8.Schema.Context ( Col(..) )
43import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
44import Rel8.Schema.HTable ( HTable )
45import Rel8.Schema.HTable.Either ( HEitherTable(..) )
46import Rel8.Schema.HTable.Identity ( HIdentity(..) )
47import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
48import Rel8.Schema.HTable.List ( HListTable )
49import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
50import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
51import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
52import Rel8.Schema.HTable.These ( HTheseTable(..) )
53import Rel8.Schema.HTable.Type ( HType( HType ) )
54import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
55import qualified Rel8.Schema.Kind as K
56import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
57import Rel8.Schema.Reify
58 ( Reify, Col( Reify ), hreify, hunreify
59 , UnwrapReify
60 , notReify
61 )
62import Rel8.Schema.Result ( Result )
63import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )
64import Rel8.Type ( DBType )
65import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
67-- these
68import Data.These ( These( This, That, These ) )
69import Data.These.Combinators ( justHere, justThere )
72-- | @Table@s are one of the foundational elements of Rel8, and describe data
73-- types that have a finite number of columns. Each of these columns contains
74-- data under a shared context, and contexts describe how to interpret the
75-- metadata about a column to a particular Haskell type. In Rel8, we have
76-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
77-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
78-- others.
79--
80-- In typical usage of Rel8 you don't need to derive instances of 'Table'
81-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
82-- 'Table'.
83type Table :: K.Context -> Type -> Constraint
84class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
85 -- | The 'HTable' functor that describes the schema of this table.
86 type Columns a :: K.HTable
88 -- | The common context that all columns use as an interpretation.
89 type Context a :: K.Context
91 type Unreify a :: Type
93 toColumns :: a -> Columns a (Col context)
94 fromColumns :: Columns a (Col context) -> a
96 reify :: context :~: Reify ctx -> Unreify a -> a
97 unreify :: context :~: Reify ctx -> a -> Unreify a
99 type Columns a = GColumns TColumns (Rep (Record a))
100 type Context a = GContext TContext (Rep (Record a))
101 type Unreify a = DefaultUnreify a
103 default toColumns ::
104 ( Generic (Record a)
105 , GTable (TTable context) TColumns (Col context) (Rep (Record a))
106 , Columns a ~ GColumns TColumns (Rep (Record a))
107 )
108 => a -> Columns a (Col context)
109 toColumns =
110 toGColumns @(TTable context) @TColumns toColumns .
111 from .
112 Record
114 default fromColumns ::
115 ( Generic (Record a)
116 , GTable (TTable context) TColumns (Col context) (Rep (Record a))
117 , Columns a ~ GColumns TColumns (Rep (Record a))
118 )
119 => Columns a (Col context) -> a
120 fromColumns =
121 unrecord .
122 to .
123 fromGColumns @(TTable context) @TColumns fromColumns
125 default reify ::
126 ( Generic (Record a)
127 , Generic (Record (Unreify a))
128 , GMappable (TTable context) (Rep (Record a))
129 , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
130 )
131 => context :~: Reify ctx -> Unreify a -> a
132 reify Refl =
133 unrecord .
134 to .
135 gunmap @(TTable context) (Proxy @TUnreify) (reify Refl) .
136 from .
137 Record
139 default unreify ::
140 ( Generic (Record a)
141 , Generic (Record (Unreify a))
142 , GMappable (TTable context) (Rep (Record a))
143 , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
144 )
145 => context :~: Reify ctx -> a -> Unreify a
146 unreify Refl =
147 unrecord .
148 to .
149 gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) .
150 from .
151 Record
154data TTable :: K.Context -> Type -> Exp Constraint
155type instance Eval (TTable context a) = Table context a
158data TColumns :: Type -> Exp K.HTable
159type instance Eval (TColumns a) = Columns a
162data TContext :: Type -> Exp K.Context
163type instance Eval (TContext a) = Context a
166data TUnreify :: Type -> Exp Type
167type instance Eval (TUnreify a) = Unreify a
170type DefaultUnreify :: Type -> Type
171type family DefaultUnreify a where
172 DefaultUnreify (t a b c d e f g) =
173 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)
174 DefaultUnreify (t a b c d e f) =
175 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)
176 DefaultUnreify (t a b c d e) =
177 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)
178 DefaultUnreify (t a b c d) =
179 t (Unreify a) (Unreify b) (Unreify c) (Unreify d)
180 DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)
181 DefaultUnreify (t a b) = t (Unreify a) (Unreify b)
182 DefaultUnreify (t a) = t (Unreify a)
185-- | Any 'HTable' is also a 'Table'.
186instance HTable t => Table context (t (Col context)) where
187 type Columns (t (Col context)) = t
188 type Context (t (Col context)) = context
189 type Unreify (t (Col context)) = t (Col (UnwrapReify context))
191 toColumns = id
192 fromColumns = id
194 reify Refl = hreify
195 unreify Refl = hunreify
198-- | Any context is trivially a table.
199instance KnownSpec spec => Table context (Col context spec) where
200 type Columns (Col context spec) = HIdentity spec
201 type Context (Col context spec) = context
202 type Unreify (Col context spec) = Col (UnwrapReify context) spec
204 toColumns = HIdentity
205 fromColumns = unHIdentity
207 reify Refl = Reify
208 unreify Refl (Reify a) = a
211instance Sql DBType a => Table Result (Identity a) where
212 type Columns (Identity a) = HType a
213 type Context (Identity a) = Result
215 toColumns (Identity a) = HType (Result a)
216 fromColumns (HType (Result a)) = Identity a
218 reify = notReify
219 unreify = notReify
222instance (Table Result a, Table Result b) => Table Result (Either a b) where
223 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
224 type Context (Either a b) = Result
226 toColumns = \case
227 Left table -> HEitherTable
228 { htag = HIdentity (Result IsLeft)
229 , hleft = hlabel labeler (hnullify nullifier (toColumns table))
230 , hright = hlabel labeler (hnulls null)
231 }
232 Right table -> HEitherTable
233 { htag = HIdentity (Result IsRight)
234 , hleft = hlabel labeler (hnulls null)
235 , hright = hlabel labeler (hnullify nullifier (toColumns table))
236 }
238 fromColumns HEitherTable {htag, hleft, hright} = case htag of
239 HIdentity (Result tag) -> case tag of
240 IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
241 IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
242 where
243 err = error "Either.fromColumns: mismatch between tag and data"
245 reify = notReify
246 unreify = notReify
249instance Table Result a => Table Result [a] where
250 type Columns [a] = HListTable (Columns a)
251 type Context [a] = Result
253 toColumns = hvectorize vectorizer . fmap toColumns
254 fromColumns = fmap fromColumns . hunvectorize unvectorizer
256 reify = notReify
257 unreify = notReify
260instance Table Result a => Table Result (Maybe a) where
261 type Columns (Maybe a) = HMaybeTable (Columns a)
262 type Context (Maybe a) = Result
264 toColumns = \case
265 Nothing -> HMaybeTable
266 { htag = HIdentity (Result Nothing)
267 , hjust = hlabel labeler (hnulls null)
268 }
269 Just table -> HMaybeTable
270 { htag = HIdentity (Result (Just IsJust))
271 , hjust = hlabel labeler (hnullify nullifier (toColumns table))
272 }
274 fromColumns HMaybeTable {htag, hjust} = case htag of
275 HIdentity (Result tag) -> tag $>
276 case hunnullify unnullifier (hunlabel unlabeler hjust) of
277 Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
278 Just just -> fromColumns just
280 reify = notReify
281 unreify = notReify
284instance Table Result a => Table Result (NonEmpty a) where
285 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
286 type Context (NonEmpty a) = Result
288 toColumns = hvectorize vectorizer . fmap toColumns
289 fromColumns = fmap fromColumns . hunvectorize unvectorizer
291 reify = notReify
292 unreify = notReify
295instance (Table Result a, Table Result b) => Table Result (These a b) where
296 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
297 type Context (These a b) = Result
299 toColumns tables = HTheseTable
300 { hhereTag = relabel hhereTag
301 , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
302 , hthereTag = relabel hthereTag
303 , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
304 }
305 where
306 HMaybeTable
307 { htag = hhereTag
308 , hjust = hhere
309 } = toColumns (justHere tables)
310 HMaybeTable
311 { htag = hthereTag
312 , hjust = hthere
313 } = toColumns (justThere tables)
315 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
316 case (fromColumns mhere, fromColumns mthere) of
317 (Just a, Nothing) -> This (fromColumns a)
318 (Nothing, Just b) -> That (fromColumns b)
319 (Just a, Just b) -> These (fromColumns a) (fromColumns b)
320 _ -> error "These.fromColumns: mismatch between tags and data"
321 where
322 mhere = HMaybeTable
323 { htag = relabel hhereTag
324 , hjust = hlabel labeler (hunlabel unlabeler hhere)
325 }
326 mthere = HMaybeTable
327 { htag = relabel hthereTag
328 , hjust = hlabel labeler (hunlabel unlabeler hthere)
329 }
331 reify = notReify
332 unreify = notReify
335instance (Table context a, Table context b, Labelable context)
336 => Table context (a, b)
339instance
340 ( Table context a, Table context b, Table context c
341 , Labelable context
342 )
343 => Table context (a, b, c)
346instance
347 ( Table context a, Table context b, Table context c, Table context d
348 , Labelable context
349 )
350 => Table context (a, b, c, d)
353instance
354 ( Table context a, Table context b, Table context c, Table context d
355 , Table context e
356 , Labelable context
357 )
358 => Table context (a, b, c, d, e)
361instance
362 ( Table context a, Table context b, Table context c, Table context d
363 , Table context e, Table context f
364 , Labelable context
365 )
366 => Table context (a, b, c, d, e, f)
369instance
370 ( Table context a, Table context b, Table context c, Table context d
371 , Table context e, Table context f, Table context g
372 , Labelable context
373 )
374 => Table context (a, b, c, d, e, f, g)
377type Congruent :: Type -> Type -> Constraint
378class Columns a ~ Columns b => Congruent a b
379instance Columns a ~ Columns b => Congruent a b
382null :: Col Result ('Spec labels necessity (Maybe a))
383null = Result Nothing
386nullifier :: ()
387 => SSpec ('Spec labels necessity a)
388 -> Col Result ('Spec labels necessity a)
389 -> Col Result ('Spec labels necessity (Nullify a))
390nullifier SSpec {nullity} (Result a) = Result $ case nullity of
391 Null -> a
392 NotNull -> Just a
395unnullifier :: ()
396 => SSpec ('Spec labels necessity a)
397 -> Col Result ('Spec labels necessity (Nullify a))
398 -> Maybe (Col Result ('Spec labels necessity a))
399unnullifier SSpec {nullity} (Result a) =
400 case nullity of
401 Null -> pure $ Result a
402 NotNull -> Result <$> a
405vectorizer :: Functor f
406 => SSpec ('Spec labels necessity a)
407 -> f (Col Result ('Spec labels necessity a))
408 -> Col Result ('Spec labels necessity (f a))
409vectorizer _ = Result . fmap (\(Result a) -> a)
412unvectorizer :: Functor f
413 => SSpec ('Spec labels necessity a)
414 -> Col Result ('Spec labels necessity (f a))
415 -> f (Col Result ('Spec labels necessity a))
416unvectorizer _ (Result results) = Result <$> results
419relabel :: ()
420 => HIdentity ('Spec labels necessity a) (Col Result)
421 -> HIdentity ('Spec relabels necessity a) (Col Result)
422relabel (HIdentity (Result a)) = HIdentity (Result a)