git.iko.soy/rel8
on 66dc44d help sign in
rel8/src/Rel8/Table.hs
390 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.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 ( Col(..) )
45import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
46import Rel8.Schema.Context.Result
47 ( relabel
48 , null, nullifier, unnullifier
49 , vectorizer, unvectorizer
50 )
51import Rel8.Schema.HTable ( HTable )
52import Rel8.Schema.HTable.Either ( HEitherTable(..) )
53import Rel8.Schema.HTable.Identity ( HIdentity(..) )
54import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
55import Rel8.Schema.HTable.List ( HListTable )
56import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
57import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
58import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
59import Rel8.Schema.HTable.These ( HTheseTable(..) )
60import Rel8.Schema.HTable.Type ( HType( HType ) )
61import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
62import qualified Rel8.Schema.Kind as K
63import Rel8.Schema.Null ( Sql )
64import Rel8.Schema.Reify
65 ( Reify, Col( Reify ), hreify, hunreify
66 , UnwrapReify
67 , notReify
68 )
69import Rel8.Schema.Result ( Result )
70import Rel8.Schema.Spec ( KnownSpec )
71import Rel8.Type ( DBType )
72import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
74-- these
75import Data.These ( These( This, That, These ) )
76import Data.These.Combinators ( justHere, justThere )
79-- | @Table@s are one of the foundational elements of Rel8, and describe data
80-- types that have a finite number of columns. Each of these columns contains
81-- data under a shared context, and contexts describe how to interpret the
82-- metadata about a column to a particular Haskell type. In Rel8, we have
83-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
84-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
85-- others.
86--
87-- In typical usage of Rel8 you don't need to derive instances of 'Table'
88-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
89-- 'Table'.
90type Table :: K.Context -> Type -> Constraint
91class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
92 -- | The 'HTable' functor that describes the schema of this table.
93 type Columns a :: K.HTable
95 -- | The common context that all columns use as an interpretation.
96 type Context a :: K.Context
98 type Unreify a :: Type
100 toColumns :: a -> Columns a (Col context)
101 fromColumns :: Columns a (Col context) -> a
103 reify :: context :~: Reify ctx -> Unreify a -> a
104 unreify :: context :~: Reify ctx -> a -> Unreify a
106 type Columns a = Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
107 type Context a = Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
108 type Unreify a = DefaultUnreify a
110 default toColumns ::
111 ( Generic (Record a)
112 , KnownAlgebra (GAlgebra (Rep (Record a)))
113 , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))
114 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
115 , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
116 )
117 => a -> Columns a (Col context)
118 toColumns =
119 ggtoColumns
120 @(GAlgebra (Rep (Record a)))
121 @(TTable context)
122 @TColumns
123 @TContext
124 id
125 id
126 toColumns .
127 from .
128 Record
130 default fromColumns ::
131 ( Generic (Record a)
132 , KnownAlgebra (GAlgebra (Rep (Record a)))
133 , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))
134 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
135 , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
136 )
137 => Columns a (Col context) -> a
138 fromColumns =
139 unrecord .
140 to .
141 ggfromColumns
142 @(GAlgebra (Rep (Record a)))
143 @(TTable context)
144 @TColumns
145 @TContext
146 id
147 id
148 fromColumns
150 default reify ::
151 ( Generic (Record a)
152 , Generic (Record (Unreify a))
153 , GMappable (TTable context) (Rep (Record a))
154 , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
155 )
156 => context :~: Reify ctx -> Unreify a -> a
157 reify Refl =
158 unrecord .
159 to .
160 gunmap @(TTable context) (Proxy @TUnreify) (reify Refl) .
161 from .
162 Record
164 default unreify ::
165 ( Generic (Record a)
166 , Generic (Record (Unreify a))
167 , GMappable (TTable context) (Rep (Record a))
168 , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
169 )
170 => context :~: Reify ctx -> a -> Unreify a
171 unreify Refl =
172 unrecord .
173 to .
174 gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) .
175 from .
176 Record
179data TTable :: K.Context -> Type -> Exp Constraint
180type instance Eval (TTable context a) = Table context a
183data TColumns :: Type -> Exp K.HTable
184type instance Eval (TColumns a) = Columns a
187data TContext :: Type -> Exp K.Context
188type instance Eval (TContext a) = Context a
191data TUnreify :: Type -> Exp Type
192type instance Eval (TUnreify a) = Unreify a
195type DefaultUnreify :: Type -> Type
196type family DefaultUnreify a where
197 DefaultUnreify (t a b c d e f g) =
198 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)
199 DefaultUnreify (t a b c d e f) =
200 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)
201 DefaultUnreify (t a b c d e) =
202 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)
203 DefaultUnreify (t a b c d) =
204 t (Unreify a) (Unreify b) (Unreify c) (Unreify d)
205 DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)
206 DefaultUnreify (t a b) = t (Unreify a) (Unreify b)
207 DefaultUnreify (t a) = t (Unreify a)
208 DefaultUnreify a = ARep (GMap TUnreify (Rep a))
211-- | Any 'HTable' is also a 'Table'.
212instance HTable t => Table context (t (Col context)) where
213 type Columns (t (Col context)) = t
214 type Context (t (Col context)) = context
215 type Unreify (t (Col context)) = t (Col (UnwrapReify context))
217 toColumns = id
218 fromColumns = id
220 reify Refl = hreify
221 unreify Refl = hunreify
224-- | Any context is trivially a table.
225instance KnownSpec spec => Table context (Col context spec) where
226 type Columns (Col context spec) = HIdentity spec
227 type Context (Col context spec) = context
228 type Unreify (Col context spec) = Col (UnwrapReify context) spec
230 toColumns = HIdentity
231 fromColumns = unHIdentity
233 reify Refl = Reify
234 unreify Refl (Reify a) = a
237instance Sql DBType a => Table Result (Identity a) where
238 type Columns (Identity a) = HType a
239 type Context (Identity a) = Result
241 toColumns (Identity a) = HType (Result a)
242 fromColumns (HType (Result a)) = Identity a
244 reify = notReify
245 unreify = notReify
248instance (Table Result a, Table Result b) => Table Result (Either a b) where
249 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
250 type Context (Either a b) = Result
252 toColumns = \case
253 Left table -> HEitherTable
254 { htag = HIdentity (Result IsLeft)
255 , hleft = hlabel labeler (hnullify nullifier (toColumns table))
256 , hright = hlabel labeler (hnulls null)
257 }
258 Right table -> HEitherTable
259 { htag = HIdentity (Result IsRight)
260 , hleft = hlabel labeler (hnulls null)
261 , hright = hlabel labeler (hnullify nullifier (toColumns table))
262 }
264 fromColumns HEitherTable {htag, hleft, hright} = case htag of
265 HIdentity (Result tag) -> case tag of
266 IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
267 IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
268 where
269 err = error "Either.fromColumns: mismatch between tag and data"
272instance Table Result a => Table Result [a] where
273 type Columns [a] = HListTable (Columns a)
274 type Context [a] = Result
276 toColumns = hvectorize vectorizer . fmap toColumns
277 fromColumns = fmap fromColumns . hunvectorize unvectorizer
280instance Table Result a => Table Result (Maybe a) where
281 type Columns (Maybe a) = HMaybeTable (Columns a)
282 type Context (Maybe a) = Result
284 toColumns = \case
285 Nothing -> HMaybeTable
286 { htag = HIdentity (Result Nothing)
287 , hjust = hlabel labeler (hnulls null)
288 }
289 Just table -> HMaybeTable
290 { htag = HIdentity (Result (Just IsJust))
291 , hjust = hlabel labeler (hnullify nullifier (toColumns table))
292 }
294 fromColumns HMaybeTable {htag, hjust} = case htag of
295 HIdentity (Result tag) -> tag $>
296 case hunnullify unnullifier (hunlabel unlabeler hjust) of
297 Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
298 Just just -> fromColumns just
301instance Table Result a => Table Result (NonEmpty a) where
302 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
303 type Context (NonEmpty a) = Result
305 toColumns = hvectorize vectorizer . fmap toColumns
306 fromColumns = fmap fromColumns . hunvectorize unvectorizer
309instance (Table Result a, Table Result b) => Table Result (These a b) where
310 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
311 type Context (These a b) = Result
313 toColumns tables = HTheseTable
314 { hhereTag = relabel hhereTag
315 , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
316 , hthereTag = relabel hthereTag
317 , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
318 }
319 where
320 HMaybeTable
321 { htag = hhereTag
322 , hjust = hhere
323 } = toColumns (justHere tables)
324 HMaybeTable
325 { htag = hthereTag
326 , hjust = hthere
327 } = toColumns (justThere tables)
329 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
330 case (fromColumns mhere, fromColumns mthere) of
331 (Just a, Nothing) -> This (fromColumns a)
332 (Nothing, Just b) -> That (fromColumns b)
333 (Just a, Just b) -> These (fromColumns a) (fromColumns b)
334 _ -> error "These.fromColumns: mismatch between tags and data"
335 where
336 mhere = HMaybeTable
337 { htag = relabel hhereTag
338 , hjust = hlabel labeler (hunlabel unlabeler hhere)
339 }
340 mthere = HMaybeTable
341 { htag = relabel hthereTag
342 , hjust = hlabel labeler (hunlabel unlabeler hthere)
343 }
346instance (Table context a, Table context b, Labelable context)
347 => Table context (a, b)
350instance
351 ( Table context a, Table context b, Table context c
352 , Labelable context
353 )
354 => Table context (a, b, c)
357instance
358 ( Table context a, Table context b, Table context c, Table context d
359 , Labelable context
360 )
361 => Table context (a, b, c, d)
364instance
365 ( Table context a, Table context b, Table context c, Table context d
366 , Table context e
367 , Labelable context
368 )
369 => Table context (a, b, c, d, e)
372instance
373 ( Table context a, Table context b, Table context c, Table context d
374 , Table context e, Table context f
375 , Labelable context
376 )
377 => Table context (a, b, c, d, e, f)
380instance
381 ( Table context a, Table context b, Table context c, Table context d
382 , Table context e, Table context f, Table context g
383 , Labelable context
384 )
385 => Table context (a, b, c, d, e, f, g)
388type Congruent :: Type -> Type -> Constraint
389class Columns a ~ Columns b => Congruent a b
390instance Columns a ~ Columns b => Congruent a b