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