git.iko.soy/rel8
on bf19395 help sign in
rel8/src/Rel8/Table.hs
379 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.HTable ( HTable )
45import Rel8.Schema.HTable.Either ( HEitherTable(..) )
46import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )
47import Rel8.Schema.HTable.Label ( hlabel, hrelabel, 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.Vectorize ( hvectorize, hunvectorize )
54import qualified Rel8.Schema.Kind as K
55import Rel8.Schema.Null ( Sql )
56import Rel8.Schema.Reify
57 ( Reify, Col( Reify ), hreify, hunreify
58 , UnwrapReify
59 , notReify
60 )
61import Rel8.Schema.Result
62 ( Col( R ), Result
63 , null, nullifier, unnullifier
64 , vectorizer, unvectorizer
65 )
66import Rel8.Schema.Spec ( KnownSpec )
67import Rel8.Type ( DBType )
68import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
70-- these
71import Data.These ( These( This, That, These ) )
72import Data.These.Combinators ( justHere, justThere )
75-- | @Table@s are one of the foundational elements of Rel8, and describe data
76-- types that have a finite number of columns. Each of these columns contains
77-- data under a shared context, and contexts describe how to interpret the
78-- metadata about a column to a particular Haskell type. In Rel8, we have
79-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
80-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
81-- others.
82--
83-- In typical usage of Rel8 you don't need to derive instances of 'Table'
84-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
85-- 'Table'.
86type Table :: K.Context -> Type -> Constraint
87class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
88 -- | The 'HTable' functor that describes the schema of this table.
89 type Columns a :: K.HTable
91 -- | The common context that all columns use as an interpretation.
92 type Context a :: K.Context
94 type Unreify a :: Type
96 toColumns :: a -> Columns a (Col context)
97 fromColumns :: Columns a (Col context) -> a
99 reify :: context :~: Reify ctx -> Unreify a -> a
100 unreify :: context :~: Reify ctx -> a -> Unreify a
102 type Columns a = Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
103 type Context a = Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
104 type Unreify a = DefaultUnreify a
106 default toColumns ::
107 ( Generic (Record a)
108 , KnownAlgebra (GAlgebra (Rep (Record a)))
109 , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))
110 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
111 , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
112 )
113 => a -> Columns a (Col context)
114 toColumns =
115 ggtoColumns
116 @(GAlgebra (Rep (Record a)))
117 @(TTable context)
118 @TColumns
119 id
120 id
121 toColumns .
122 from .
123 Record
125 default fromColumns ::
126 ( Generic (Record a)
127 , KnownAlgebra (GAlgebra (Rep (Record a)))
128 , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))
129 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
130 , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
131 )
132 => Columns a (Col context) -> a
133 fromColumns =
134 unrecord .
135 to .
136 ggfromColumns
137 @(GAlgebra (Rep (Record a)))
138 @(TTable context)
139 @TColumns
140 id
141 id
142 fromColumns
144 default reify ::
145 ( Generic (Record a)
146 , Generic (Record (Unreify a))
147 , GMappable (TTable context) (Rep (Record a))
148 , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
149 )
150 => context :~: Reify ctx -> Unreify a -> a
151 reify Refl =
152 unrecord .
153 to .
154 gunmap @(TTable context) (Proxy @TUnreify) (reify Refl) .
155 from .
156 Record
158 default unreify ::
159 ( Generic (Record a)
160 , Generic (Record (Unreify a))
161 , GMappable (TTable context) (Rep (Record a))
162 , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
163 )
164 => context :~: Reify ctx -> a -> Unreify a
165 unreify Refl =
166 unrecord .
167 to .
168 gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) .
169 from .
170 Record
173data TTable :: K.Context -> Type -> Exp Constraint
174type instance Eval (TTable context a) = Table context a
177data TColumns :: Type -> Exp K.HTable
178type instance Eval (TColumns a) = Columns a
181data TContext :: Type -> Exp K.Context
182type instance Eval (TContext a) = Context a
185data TUnreify :: Type -> Exp Type
186type instance Eval (TUnreify a) = Unreify a
189type DefaultUnreify :: Type -> Type
190type family DefaultUnreify a where
191 DefaultUnreify (t a b c d e f g) =
192 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)
193 DefaultUnreify (t a b c d e f) =
194 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)
195 DefaultUnreify (t a b c d e) =
196 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)
197 DefaultUnreify (t a b c d) =
198 t (Unreify a) (Unreify b) (Unreify c) (Unreify d)
199 DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)
200 DefaultUnreify (t a b) = t (Unreify a) (Unreify b)
201 DefaultUnreify (t a) = t (Unreify a)
202 DefaultUnreify a = ARep (GMap TUnreify (Rep a))
205-- | Any 'HTable' is also a 'Table'.
206instance HTable t => Table context (t (Col context)) where
207 type Columns (t (Col context)) = t
208 type Context (t (Col context)) = context
209 type Unreify (t (Col context)) = t (Col (UnwrapReify context))
211 toColumns = id
212 fromColumns = id
214 reify Refl = hreify
215 unreify Refl = hunreify
218-- | Any context is trivially a table.
219instance KnownSpec spec => Table context (Col context spec) where
220 type Columns (Col context spec) = HIdentity spec
221 type Context (Col context spec) = context
222 type Unreify (Col context spec) = Col (UnwrapReify context) spec
224 toColumns = HIdentity
225 fromColumns = unHIdentity
227 reify Refl = Reify
228 unreify Refl (Reify a) = a
231instance Sql DBType a => Table Result (Identity a) where
232 type Columns (Identity a) = HType a
233 type Context (Identity a) = Result
235 toColumns (Identity a) = HType (R a)
236 fromColumns (HType (R a)) = Identity a
238 reify = notReify
239 unreify = notReify
242instance (Table Result a, Table Result b) => Table Result (Either a b) where
243 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
244 type Context (Either a b) = Result
246 toColumns = \case
247 Left table -> HEitherTable
248 { htag = hlabel (HType (R IsLeft))
249 , hleft = hlabel (hnullify nullifier (toColumns table))
250 , hright = hlabel (hnulls (const null))
251 }
252 Right table -> HEitherTable
253 { htag = hlabel (HType (R IsRight))
254 , hleft = hlabel (hnulls (const null))
255 , hright = hlabel (hnullify nullifier (toColumns table))
256 }
258 fromColumns HEitherTable {htag, hleft, hright} = case hunlabel htag of
259 HType (R tag) -> case tag of
260 IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel hleft)
261 IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel hright)
262 where
263 err = error "Either.fromColumns: mismatch between tag and data"
266instance Table Result a => Table Result [a] where
267 type Columns [a] = HListTable (Columns a)
268 type Context [a] = Result
270 toColumns = hvectorize vectorizer . fmap toColumns
271 fromColumns = fmap fromColumns . hunvectorize unvectorizer
274instance Table Result a => Table Result (Maybe a) where
275 type Columns (Maybe a) = HMaybeTable (Columns a)
276 type Context (Maybe a) = Result
278 toColumns = \case
279 Nothing -> HMaybeTable
280 { htag = hlabel (HIdentity (R Nothing))
281 , hjust = hlabel (hnulls (const null))
282 }
283 Just table -> HMaybeTable
284 { htag = hlabel (HIdentity (R (Just IsJust)))
285 , hjust = hlabel (hnullify nullifier (toColumns table))
286 }
288 fromColumns HMaybeTable {htag, hjust} = case hunlabel htag of
289 HType (R tag) -> tag $>
290 case hunnullify unnullifier (hunlabel hjust) of
291 Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
292 Just just -> fromColumns just
295instance Table Result a => Table Result (NonEmpty a) where
296 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
297 type Context (NonEmpty a) = Result
299 toColumns = hvectorize vectorizer . fmap toColumns
300 fromColumns = fmap fromColumns . hunvectorize unvectorizer
303instance (Table Result a, Table Result b) => Table Result (These a b) where
304 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
305 type Context (These a b) = Result
307 toColumns tables = HTheseTable
308 { hhereTag = hrelabel hhereTag
309 , hhere = hrelabel (toColumns hhere)
310 , hthereTag = hrelabel hthereTag
311 , hthere = hrelabel (toColumns hthere)
312 }
313 where
314 HMaybeTable
315 { htag = hhereTag
316 , hjust = hhere
317 } = toColumns (justHere tables)
318 HMaybeTable
319 { htag = hthereTag
320 , hjust = hthere
321 } = toColumns (justThere tables)
323 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
324 case (fromColumns mhere, fromColumns mthere) of
325 (Just a, Nothing) -> This (fromColumns a)
326 (Nothing, Just b) -> That (fromColumns b)
327 (Just a, Just b) -> These (fromColumns a) (fromColumns b)
328 _ -> error "These.fromColumns: mismatch between tags and data"
329 where
330 mhere = HMaybeTable
331 { htag = hrelabel hhereTag
332 , hjust = hrelabel hhere
333 }
334 mthere = HMaybeTable
335 { htag = hrelabel hthereTag
336 , hjust = hrelabel hthere
337 }
340instance (Table context a, Table context b)
341 => Table context (a, b)
344instance
345 ( Table context a, Table context b, Table context c
346 )
347 => Table context (a, b, c)
350instance
351 ( Table context a, Table context b, Table context c, Table context d
352 )
353 => Table context (a, b, c, d)
356instance
357 ( Table context a, Table context b, Table context c, Table context d
358 , Table context e
359 )
360 => Table context (a, b, c, d, e)
363instance
364 ( Table context a, Table context b, Table context c, Table context d
365 , Table context e, Table context f
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 )
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