git.iko.soy/rel8
on 7c4c6ff help sign in
rel8/src/Rel8/Table.hs
374 lines 12 kB history raw
1{-# language DataKinds #-}
2{-# language DefaultSignatures #-}
3{-# language DisambiguateRecordFields #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
6{-# language FunctionalDependencies #-}
7{-# language LambdaCase #-}
8{-# language NamedFieldPuns #-}
9{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language TypeOperators #-}
14{-# language UndecidableInstances #-}
16module Rel8.Table
17 ( Table (Columns, Context)
18 , toColumns, fromColumns
19 , Congruent
20 , GTable, GColumns, GContext, fromGColumns, toGColumns
21 )
22where
24-- base
25import Data.Functor ( ($>) )
26import Data.Functor.Identity ( Identity( Identity ) )
27import Data.Kind ( Constraint, Type )
28import Data.List.NonEmpty ( NonEmpty )
29import GHC.Generics
30 ( Generic, Rep, from, to
31 , (:*:)( (:*:) ), K1( K1 ), M1( M1 )
32 , C, D, S
33 , Meta( MetaSel )
34 )
35import GHC.TypeLits ( KnownSymbol )
36import Prelude hiding ( null )
38-- rel8
39import Rel8.Generic.Record ( Record(..) )
40import Rel8.Schema.Context ( Col(..) )
41import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
42import Rel8.Schema.HTable ( HTable )
43import Rel8.Schema.HTable.Either ( HEitherTable(..) )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
46import Rel8.Schema.HTable.List ( HListTable )
47import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
48import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
49import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
50import Rel8.Schema.HTable.Product ( HProduct(..) )
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.Result ( Result )
57import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )
58import Rel8.Type ( DBType )
59import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
61-- these
62import Data.These ( These( This, That, These ) )
63import Data.These.Combinators ( justHere, justThere )
66-- | @Table@s are one of the foundational elements of Rel8, and describe data
67-- types that have a finite number of columns. Each of these columns contains
68-- data under a shared context, and contexts describe how to interpret the
69-- metadata about a column to a particular Haskell type. In Rel8, we have
70-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
71-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
72-- others.
73--
74-- In typical usage of Rel8 you don't need to derive instances of 'Table'
75-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
76-- 'Table'.
77type Table :: K.Context -> Type -> Constraint
78class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
79 -- | The 'HTable' functor that describes the schema of this table.
80 type Columns a :: K.HTable
82 -- | The common context that all columns use as an interpretation.
83 type Context a :: K.Context
85 toColumns :: a -> Columns a (Col (Context a))
86 fromColumns :: Columns a (Col (Context a)) -> a
88 type Columns a = GColumns (Rep (Record a))
89 type Context a = GContext (Rep (Record a))
91 default toColumns ::
92 ( Generic (Record a), GTable (GContext (Rep (Record a))) (Rep (Record a))
93 , Columns a ~ GColumns (Rep (Record a))
94 , Context a ~ GContext (Rep (Record a))
95 )
96 => a -> Columns a (Col (Context a))
97 toColumns = toGColumns . from . Record
99 default fromColumns ::
100 ( Generic (Record a), GTable (GContext (Rep (Record a))) (Rep (Record a))
101 , Columns a ~ GColumns (Rep (Record a))
102 , Context a ~ GContext (Rep (Record a))
103 )
104 => Columns a (Col (Context a)) -> a
105 fromColumns = unrecord . to . fromGColumns
108type GColumns :: (Type -> Type) -> K.HTable
109type family GColumns rep where
110 GColumns (M1 D _ rep) = GColumns rep
111 GColumns (M1 C _ rep) = GColumns rep
112 GColumns (rep1 :*: rep2) = HProduct (GColumns rep1) (GColumns rep2)
113 GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
114 HLabel label (Columns a)
117type GContext :: (Type -> Type) -> K.Context
118type family GContext rep where
119 GContext (M1 _ _ rep) = GContext rep
120 GContext (rep1 :*: _rep2) = GContext rep1
121 GContext (K1 _ a) = Context a
124type GTable :: K.Context -> (Type -> Type) -> Constraint
125class context ~ GContext rep => GTable context rep | rep -> context where
126 fromGColumns :: GColumns rep (Col context) -> rep x
127 toGColumns :: rep x -> GColumns rep (Col context)
130instance GTable context rep => GTable context (M1 D c rep) where
131 fromGColumns = M1 . fromGColumns @context @rep
132 toGColumns (M1 a) = toGColumns @context @rep a
135instance GTable context rep => GTable context (M1 C c rep) where
136 fromGColumns = M1 . fromGColumns @context @rep
137 toGColumns (M1 a) = toGColumns @context @rep a
140instance (GTable context rep1, GTable context rep2) =>
141 GTable context (rep1 :*: rep2)
142 where
143 fromGColumns (HProduct a b) =
144 fromGColumns @context @rep1 a :*: fromGColumns @context @rep2 b
145 toGColumns (a :*: b) =
146 HProduct (toGColumns @context @rep1 a) (toGColumns @context @rep2 b)
149instance
150 ( Table context a
151 , Labelable context
152 , KnownSymbol label
153 , GColumns (M1 S meta k1) ~ HLabel label (Columns a)
154 , meta ~ 'MetaSel ('Just label) _su _ss _ds
155 , k1 ~ K1 i a
156 )
157 => GTable context (M1 S meta k1)
158 where
159 fromGColumns = M1 . K1 . fromColumns . hunlabel unlabeler
160 toGColumns (M1 (K1 a)) = hlabel labeler (toColumns a)
163-- | Any 'HTable' is also a 'Table'.
164instance HTable t => Table context (t (Col context)) where
165 type Columns (t (Col context)) = t
166 type Context (t (Col context)) = context
168 toColumns = id
169 fromColumns = id
172-- | Any context is trivially a table.
173instance KnownSpec spec => Table context (Col context spec) where
174 type Columns (Col context spec) = HIdentity spec
175 type Context (Col context spec) = context
177 toColumns = HIdentity
178 fromColumns = unHIdentity
181instance Sql DBType a => Table Result (Identity a) where
182 type Columns (Identity a) = HType a
183 type Context (Identity a) = Result
185 toColumns (Identity a) = HType (Result a)
186 fromColumns (HType (Result a)) = Identity a
189instance (Table Result a, Table Result b) => Table Result (Either a b) where
190 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
191 type Context (Either a b) = Result
193 toColumns = \case
194 Left table -> HEitherTable
195 { htag = HIdentity (Result IsLeft)
196 , hleft = hlabel labeler (hnullify nullifier (toColumns table))
197 , hright = hlabel labeler (hnulls null)
198 }
199 Right table -> HEitherTable
200 { htag = HIdentity (Result IsRight)
201 , hleft = hlabel labeler (hnulls null)
202 , hright = hlabel labeler (hnullify nullifier (toColumns table))
203 }
205 fromColumns HEitherTable {htag, hleft, hright} = case htag of
206 HIdentity (Result tag) -> case tag of
207 IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
208 IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
209 where
210 err = error "Either.fromColumns: mismatch between tag and data"
213instance Table Result a => Table Result [a] where
214 type Columns [a] = HListTable (Columns a)
215 type Context [a] = Result
217 toColumns = hvectorize vectorizer . fmap toColumns
218 fromColumns = fmap fromColumns . hunvectorize unvectorizer
221instance Table Result a => Table Result (Maybe a) where
222 type Columns (Maybe a) = HMaybeTable (Columns a)
223 type Context (Maybe a) = Result
225 toColumns = \case
226 Nothing -> HMaybeTable
227 { htag = HIdentity (Result Nothing)
228 , hjust = hlabel labeler (hnulls null)
229 }
230 Just table -> HMaybeTable
231 { htag = HIdentity (Result (Just IsJust))
232 , hjust = hlabel labeler (hnullify nullifier (toColumns table))
233 }
235 fromColumns HMaybeTable {htag, hjust} = case htag of
236 HIdentity (Result tag) -> tag $>
237 case hunnullify unnullifier (hunlabel unlabeler hjust) of
238 Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
239 Just just -> fromColumns just
242instance Table Result a => Table Result (NonEmpty a) where
243 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
244 type Context (NonEmpty a) = Result
246 toColumns = hvectorize vectorizer . fmap toColumns
247 fromColumns = fmap fromColumns . hunvectorize unvectorizer
250instance (Table Result a, Table Result b) => Table Result (These a b) where
251 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
252 type Context (These a b) = Result
254 toColumns tables = HTheseTable
255 { hhereTag = relabel hhereTag
256 , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
257 , hthereTag = relabel hthereTag
258 , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
259 }
260 where
261 HMaybeTable
262 { htag = hhereTag
263 , hjust = hhere
264 } = toColumns (justHere tables)
265 HMaybeTable
266 { htag = hthereTag
267 , hjust = hthere
268 } = toColumns (justThere tables)
270 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
271 case (fromColumns mhere, fromColumns mthere) of
272 (Just a, Nothing) -> This (fromColumns a)
273 (Nothing, Just b) -> That (fromColumns b)
274 (Just a, Just b) -> These (fromColumns a) (fromColumns b)
275 _ -> error "These.fromColumns: mismatch between tags and data"
276 where
277 mhere = HMaybeTable
278 { htag = relabel hhereTag
279 , hjust = hlabel labeler (hunlabel unlabeler hhere)
280 }
281 mthere = HMaybeTable
282 { htag = relabel hthereTag
283 , hjust = hlabel labeler (hunlabel unlabeler hthere)
284 }
287instance (Table context a, Table context b, Labelable context)
288 => Table context (a, b)
291instance
292 ( Table context a, Table context b, Table context c
293 , Labelable context
294 )
295 => Table context (a, b, c)
298instance
299 ( Table context a, Table context b, Table context c, Table context d
300 , Labelable context
301 )
302 => Table context (a, b, c, d)
305instance
306 ( Table context a, Table context b, Table context c, Table context d
307 , Table context e
308 , Labelable context
309 )
310 => Table context (a, b, c, d, e)
313instance
314 ( Table context a, Table context b, Table context c, Table context d
315 , Table context e, Table context f
316 , Labelable context
317 )
318 => Table context (a, b, c, d, e, f)
321instance
322 ( Table context a, Table context b, Table context c, Table context d
323 , Table context e, Table context f, Table context g
324 , Labelable context
325 )
326 => Table context (a, b, c, d, e, f, g)
329type Congruent :: Type -> Type -> Constraint
330class Columns a ~ Columns b => Congruent a b
331instance Columns a ~ Columns b => Congruent a b
334null :: Col Result ('Spec labels necessity (Maybe a))
335null = Result Nothing
338nullifier :: ()
339 => SSpec ('Spec labels necessity a)
340 -> Col Result ('Spec labels necessity a)
341 -> Col Result ('Spec labels necessity (Nullify a))
342nullifier SSpec {nullity} (Result a) = Result $ case nullity of
343 Null -> a
344 NotNull -> Just a
347unnullifier :: ()
348 => SSpec ('Spec labels necessity a)
349 -> Col Result ('Spec labels necessity (Nullify a))
350 -> Maybe (Col Result ('Spec labels necessity a))
351unnullifier SSpec {nullity} (Result a) =
352 case nullity of
353 Null -> pure $ Result a
354 NotNull -> Result <$> a
357vectorizer :: Functor f
358 => SSpec ('Spec labels necessity a)
359 -> f (Col Result ('Spec labels necessity a))
360 -> Col Result ('Spec labels necessity (f a))
361vectorizer _ = Result . fmap (\(Result a) -> a)
364unvectorizer :: Functor f
365 => SSpec ('Spec labels necessity a)
366 -> Col Result ('Spec labels necessity (f a))
367 -> f (Col Result ('Spec labels necessity a))
368unvectorizer _ (Result results) = Result <$> results
371relabel :: ()
372 => HIdentity ('Spec labels necessity a) (Col Result)
373 -> HIdentity ('Spec relabels necessity a) (Col Result)
374relabel (HIdentity (Result a)) = HIdentity (Result a)