git.iko.soy/rel8
on e432f6d help sign in
rel8/src/Rel8/Table.hs
421 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.Map ( GMap, GMappable, gmap, gunmap )
37import Rel8.Generic.Table
38 ( GTable, GColumns, GContext, fromGColumns, toGColumns
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 , GMappable (TTable context) (Rep (Record a))
128 , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
129 )
130 => context :~: Reify ctx -> Unreify a -> a
131 reify Refl =
132 unrecord .
133 to .
134 gunmap @(TTable context) (Proxy @TUnreify) (reify Refl) .
135 from .
136 Record
138 default unreify ::
139 ( Generic (Record a)
140 , Generic (Record (Unreify a))
141 , GMappable (TTable context) (Rep (Record a))
142 , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
143 )
144 => context :~: Reify ctx -> a -> Unreify a
145 unreify Refl =
146 unrecord .
147 to .
148 gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) .
149 from .
150 Record
153data TTable :: K.Context -> Type -> Exp Constraint
154type instance Eval (TTable context a) = Table context a
157data TColumns :: Type -> Exp K.HTable
158type instance Eval (TColumns a) = Columns a
161data TContext :: Type -> Exp K.Context
162type instance Eval (TContext a) = Context a
165data TUnreify :: Type -> Exp Type
166type instance Eval (TUnreify a) = Unreify a
169type DefaultUnreify :: Type -> Type
170type family DefaultUnreify a where
171 DefaultUnreify (t a b c d e f g) =
172 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)
173 DefaultUnreify (t a b c d e f) =
174 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)
175 DefaultUnreify (t a b c d e) =
176 t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)
177 DefaultUnreify (t a b c d) =
178 t (Unreify a) (Unreify b) (Unreify c) (Unreify d)
179 DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)
180 DefaultUnreify (t a b) = t (Unreify a) (Unreify b)
181 DefaultUnreify (t a) = t (Unreify a)
184-- | Any 'HTable' is also a 'Table'.
185instance HTable t => Table context (t (Col context)) where
186 type Columns (t (Col context)) = t
187 type Context (t (Col context)) = context
188 type Unreify (t (Col context)) = t (Col (UnwrapReify context))
190 toColumns = id
191 fromColumns = id
193 reify Refl = hreify
194 unreify Refl = hunreify
197-- | Any context is trivially a table.
198instance KnownSpec spec => Table context (Col context spec) where
199 type Columns (Col context spec) = HIdentity spec
200 type Context (Col context spec) = context
201 type Unreify (Col context spec) = Col (UnwrapReify context) spec
203 toColumns = HIdentity
204 fromColumns = unHIdentity
206 reify Refl = Reify
207 unreify Refl (Reify a) = a
210instance Sql DBType a => Table Result (Identity a) where
211 type Columns (Identity a) = HType a
212 type Context (Identity a) = Result
214 toColumns (Identity a) = HType (Result a)
215 fromColumns (HType (Result a)) = Identity a
217 reify = notReify
218 unreify = notReify
221instance (Table Result a, Table Result b) => Table Result (Either a b) where
222 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
223 type Context (Either a b) = Result
225 toColumns = \case
226 Left table -> HEitherTable
227 { htag = HIdentity (Result IsLeft)
228 , hleft = hlabel labeler (hnullify nullifier (toColumns table))
229 , hright = hlabel labeler (hnulls null)
230 }
231 Right table -> HEitherTable
232 { htag = HIdentity (Result IsRight)
233 , hleft = hlabel labeler (hnulls null)
234 , hright = hlabel labeler (hnullify nullifier (toColumns table))
235 }
237 fromColumns HEitherTable {htag, hleft, hright} = case htag of
238 HIdentity (Result tag) -> case tag of
239 IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
240 IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
241 where
242 err = error "Either.fromColumns: mismatch between tag and data"
244 reify = notReify
245 unreify = notReify
248instance Table Result a => Table Result [a] where
249 type Columns [a] = HListTable (Columns a)
250 type Context [a] = Result
252 toColumns = hvectorize vectorizer . fmap toColumns
253 fromColumns = fmap fromColumns . hunvectorize unvectorizer
255 reify = notReify
256 unreify = notReify
259instance Table Result a => Table Result (Maybe a) where
260 type Columns (Maybe a) = HMaybeTable (Columns a)
261 type Context (Maybe a) = Result
263 toColumns = \case
264 Nothing -> HMaybeTable
265 { htag = HIdentity (Result Nothing)
266 , hjust = hlabel labeler (hnulls null)
267 }
268 Just table -> HMaybeTable
269 { htag = HIdentity (Result (Just IsJust))
270 , hjust = hlabel labeler (hnullify nullifier (toColumns table))
271 }
273 fromColumns HMaybeTable {htag, hjust} = case htag of
274 HIdentity (Result tag) -> tag $>
275 case hunnullify unnullifier (hunlabel unlabeler hjust) of
276 Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
277 Just just -> fromColumns just
279 reify = notReify
280 unreify = notReify
283instance Table Result a => Table Result (NonEmpty a) where
284 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
285 type Context (NonEmpty a) = Result
287 toColumns = hvectorize vectorizer . fmap toColumns
288 fromColumns = fmap fromColumns . hunvectorize unvectorizer
290 reify = notReify
291 unreify = notReify
294instance (Table Result a, Table Result b) => Table Result (These a b) where
295 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
296 type Context (These a b) = Result
298 toColumns tables = HTheseTable
299 { hhereTag = relabel hhereTag
300 , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
301 , hthereTag = relabel hthereTag
302 , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
303 }
304 where
305 HMaybeTable
306 { htag = hhereTag
307 , hjust = hhere
308 } = toColumns (justHere tables)
309 HMaybeTable
310 { htag = hthereTag
311 , hjust = hthere
312 } = toColumns (justThere tables)
314 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
315 case (fromColumns mhere, fromColumns mthere) of
316 (Just a, Nothing) -> This (fromColumns a)
317 (Nothing, Just b) -> That (fromColumns b)
318 (Just a, Just b) -> These (fromColumns a) (fromColumns b)
319 _ -> error "These.fromColumns: mismatch between tags and data"
320 where
321 mhere = HMaybeTable
322 { htag = relabel hhereTag
323 , hjust = hlabel labeler (hunlabel unlabeler hhere)
324 }
325 mthere = HMaybeTable
326 { htag = relabel hthereTag
327 , hjust = hlabel labeler (hunlabel unlabeler hthere)
328 }
330 reify = notReify
331 unreify = notReify
334instance (Table context a, Table context b, Labelable context)
335 => Table context (a, b)
338instance
339 ( Table context a, Table context b, Table context c
340 , Labelable context
341 )
342 => Table context (a, b, c)
345instance
346 ( Table context a, Table context b, Table context c, Table context d
347 , Labelable context
348 )
349 => Table context (a, b, c, d)
352instance
353 ( Table context a, Table context b, Table context c, Table context d
354 , Table context e
355 , Labelable context
356 )
357 => Table context (a, b, c, d, e)
360instance
361 ( Table context a, Table context b, Table context c, Table context d
362 , Table context e, Table context f
363 , Labelable context
364 )
365 => Table context (a, b, c, d, e, f)
368instance
369 ( Table context a, Table context b, Table context c, Table context d
370 , Table context e, Table context f, Table context g
371 , Labelable context
372 )
373 => Table context (a, b, c, d, e, f, g)
376type Congruent :: Type -> Type -> Constraint
377class Columns a ~ Columns b => Congruent a b
378instance Columns a ~ Columns b => Congruent a b
381null :: Col Result ('Spec labels necessity (Maybe a))
382null = Result Nothing
385nullifier :: ()
386 => SSpec ('Spec labels necessity a)
387 -> Col Result ('Spec labels necessity a)
388 -> Col Result ('Spec labels necessity (Nullify a))
389nullifier SSpec {nullity} (Result a) = Result $ case nullity of
390 Null -> a
391 NotNull -> Just a
394unnullifier :: ()
395 => SSpec ('Spec labels necessity a)
396 -> Col Result ('Spec labels necessity (Nullify a))
397 -> Maybe (Col Result ('Spec labels necessity a))
398unnullifier SSpec {nullity} (Result a) =
399 case nullity of
400 Null -> pure $ Result a
401 NotNull -> Result <$> a
404vectorizer :: Functor f
405 => SSpec ('Spec labels necessity a)
406 -> f (Col Result ('Spec labels necessity a))
407 -> Col Result ('Spec labels necessity (f a))
408vectorizer _ = Result . fmap (\(Result a) -> a)
411unvectorizer :: Functor f
412 => SSpec ('Spec labels necessity a)
413 -> Col Result ('Spec labels necessity (f a))
414 -> f (Col Result ('Spec labels necessity a))
415unvectorizer _ (Result results) = Result <$> results
418relabel :: ()
419 => HIdentity ('Spec labels necessity a) (Col Result)
420 -> HIdentity ('Spec relabels necessity a) (Col Result)
421relabel (HIdentity (Result a)) = HIdentity (Result a)