git.iko.soy/rel8
on 11a2229 help sign in
rel8/src/Rel8/Table.hs
354 lines 11 kB history raw
1{-# language DataKinds #-}
2{-# language DisambiguateRecordFields #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
5{-# language FunctionalDependencies #-}
6{-# language LambdaCase #-}
7{-# language NamedFieldPuns #-}
8{-# language StandaloneKindSignatures #-}
9{-# language TypeFamilies #-}
10{-# language TypeOperators #-}
11{-# language UndecidableInstances #-}
13module Rel8.Table
14 ( Table (Columns, Context)
15 , toColumns, fromColumns
16 , Congruent
17 )
18where
20-- base
21import Data.Functor ( ($>) )
22import Data.Functor.Identity ( Identity( Identity ) )
23import Data.Kind ( Constraint, Type )
24import Data.List.NonEmpty ( NonEmpty )
25import Prelude hiding ( null )
27-- rel8
28import Rel8.Schema.Context ( Col(..) )
29import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
30import Rel8.Schema.HTable ( HTable )
31import Rel8.Schema.HTable.Either ( HEitherTable(..) )
32import Rel8.Schema.HTable.Identity ( HIdentity(..) )
33import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
34import Rel8.Schema.HTable.List ( HListTable )
35import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
36import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
37import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
38import Rel8.Schema.HTable.Pair ( HPair(..) )
39import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
40import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
41import Rel8.Schema.HTable.These ( HTheseTable(..) )
42import Rel8.Schema.HTable.Trio ( HTrio(..) )
43import Rel8.Schema.HTable.Type ( HType( HType ) )
44import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
45import qualified Rel8.Schema.Kind as K
46import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
47import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )
48import Rel8.Type ( DBType )
49import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
51-- these
52import Data.These ( These( This, That, These ) )
53import Data.These.Combinators ( justHere, justThere )
56-- | @Table@s are one of the foundational elements of Rel8, and describe data
57-- types that have a finite number of columns. Each of these columns contains
58-- data under a shared context, and contexts describe how to interpret the
59-- metadata about a column to a particular Haskell type. In Rel8, we have
60-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
61-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
62-- others.
63--
64-- In typical usage of Rel8 you don't need to derive instances of 'Table'
65-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
66-- 'Table'.
67type Table :: K.Context -> Type -> Constraint
68class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
69 -- | The 'HTable' functor that describes the schema of this table.
70 type Columns a :: K.HTable
72 -- | The common context that all columns use as an interpretation.
73 type Context a :: K.Context
75 toColumns :: a -> Columns a (Col (Context a))
76 fromColumns :: Columns a (Col (Context a)) -> a
79-- | Any 'HTable' is also a 'Table'.
80instance HTable t => Table context (t (Col context)) where
81 type Columns (t (Col context)) = t
82 type Context (t (Col context)) = context
84 toColumns = id
85 fromColumns = id
88-- | Any context is trivially a table.
89instance KnownSpec spec => Table context (Col context spec) where
90 type Columns (Col context spec) = HIdentity spec
91 type Context (Col context spec) = context
93 toColumns = HIdentity
94 fromColumns = unHIdentity
97instance Sql DBType a => Table Identity (Identity a) where
98 type Columns (Identity a) = HType a
99 type Context (Identity a) = Identity
101 toColumns (Identity a) = HType (Result a)
102 fromColumns (HType (Result a)) = Identity a
105instance (Table Identity a, Table Identity b) => Table Identity (Either a b)
106 where
107 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
108 type Context (Either a b) = Identity
110 toColumns = \case
111 Left table -> HEitherTable
112 { htag = HIdentity (Result IsLeft)
113 , hleft = hlabel labeler (hnullify nullifier (toColumns table))
114 , hright = hlabel labeler (hnulls null)
115 }
116 Right table -> HEitherTable
117 { htag = HIdentity (Result IsRight)
118 , hleft = hlabel labeler (hnulls null)
119 , hright = hlabel labeler (hnullify nullifier (toColumns table))
120 }
122 fromColumns HEitherTable {htag, hleft, hright} = case htag of
123 HIdentity (Result tag) -> case tag of
124 IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
125 IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
126 where
127 err = error "Either.fromColumns: mismatch between tag and data"
130instance Table Identity a => Table Identity [a] where
131 type Columns [a] = HListTable (Columns a)
132 type Context [a] = Identity
134 toColumns = hvectorize vectorizer . fmap toColumns
135 fromColumns = fmap fromColumns . hunvectorize unvectorizer
138instance Table Identity a => Table Identity (Maybe a) where
139 type Columns (Maybe a) = HMaybeTable (Columns a)
140 type Context (Maybe a) = Identity
142 toColumns = \case
143 Nothing -> HMaybeTable
144 { htag = HIdentity (Result Nothing)
145 , hjust = hlabel labeler (hnulls null)
146 }
147 Just table -> HMaybeTable
148 { htag = HIdentity (Result (Just IsJust))
149 , hjust = hlabel labeler (hnullify nullifier (toColumns table))
150 }
152 fromColumns HMaybeTable {htag, hjust} = case htag of
153 HIdentity (Result tag) -> tag $>
154 case hunnullify unnullifier (hunlabel unlabeler hjust) of
155 Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
156 Just just -> fromColumns just
159instance Table Identity a => Table Identity (NonEmpty a) where
160 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
161 type Context (NonEmpty a) = Identity
163 toColumns = hvectorize vectorizer . fmap toColumns
164 fromColumns = fmap fromColumns . hunvectorize unvectorizer
167instance (Table Identity a, Table Identity b) => Table Identity (These a b)
168 where
169 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
170 type Context (These a b) = Identity
172 toColumns tables = HTheseTable
173 { hhereTag = relabel hhereTag
174 , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
175 , hthereTag = relabel hthereTag
176 , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
177 }
178 where
179 HMaybeTable
180 { htag = hhereTag
181 , hjust = hhere
182 } = toColumns (justHere tables)
183 HMaybeTable
184 { htag = hthereTag
185 , hjust = hthere
186 } = toColumns (justThere tables)
188 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
189 case (fromColumns mhere, fromColumns mthere) of
190 (Just a, Nothing) -> This (fromColumns a)
191 (Nothing, Just b) -> That (fromColumns b)
192 (Just a, Just b) -> These (fromColumns a) (fromColumns b)
193 _ -> error "These.fromColumns: mismatch between tags and data"
194 where
195 mhere = HMaybeTable
196 { htag = relabel hhereTag
197 , hjust = hlabel labeler (hunlabel unlabeler hhere)
198 }
199 mthere = HMaybeTable
200 { htag = relabel hthereTag
201 , hjust = hlabel labeler (hunlabel unlabeler hthere)
202 }
205instance
206 ( Table context a, Table context b
207 , Labelable context
208 ) =>
209 Table context (a, b)
210 where
211 type Columns (a, b) =
212 HPair
213 (HLabel "fst" (Columns a))
214 (HLabel "snd" (Columns b))
215 type Context (a, b) = Context a
217 toColumns (a, b) = HPair
218 { hfst = hlabel labeler $ toColumns a
219 , hsnd = hlabel labeler $ toColumns b
220 }
221 fromColumns (HPair a b) =
222 ( fromColumns $ hunlabel unlabeler a
223 , fromColumns $ hunlabel unlabeler b
224 )
227instance
228 ( Table context a, Table context b, Table context c
229 , Labelable context
230 ) => Table context (a, b, c)
231 where
232 type Columns (a, b, c) =
233 HTrio
234 (HLabel "fst" (Columns a))
235 (HLabel "snd" (Columns b))
236 (HLabel "trd" (Columns c))
237 type Context (a, b, c) = Context a
239 toColumns (a, b, c) = HTrio
240 { hfst = hlabel labeler $ toColumns a
241 , hsnd = hlabel labeler $ toColumns b
242 , htrd = hlabel labeler $ toColumns c
243 }
244 fromColumns (HTrio a b c) =
245 ( fromColumns $ hunlabel unlabeler a
246 , fromColumns $ hunlabel unlabeler b
247 , fromColumns $ hunlabel unlabeler c
248 )
251instance
252 ( Table context a, Table context b, Table context c, Table context d
253 , Labelable context
254 ) => Table context (a, b, c, d)
255 where
256 type Columns (a, b, c, d) =
257 HQuartet
258 (HLabel "fst" (Columns a))
259 (HLabel "snd" (Columns b))
260 (HLabel "trd" (Columns c))
261 (HLabel "frt" (Columns d))
262 type Context (a, b, c, d) = Context a
264 toColumns (a, b, c, d) = HQuartet
265 { hfst = hlabel labeler $ toColumns a
266 , hsnd = hlabel labeler $ toColumns b
267 , htrd = hlabel labeler $ toColumns c
268 , hfrt = hlabel labeler $ toColumns d
269 }
270 fromColumns (HQuartet a b c d) =
271 ( fromColumns $ hunlabel unlabeler a
272 , fromColumns $ hunlabel unlabeler b
273 , fromColumns $ hunlabel unlabeler c
274 , fromColumns $ hunlabel unlabeler d
275 )
278instance
279 ( Table context a, Table context b, Table context c, Table context d
280 , Table context e
281 , Labelable context
282 ) => Table context (a, b, c, d, e)
283 where
284 type Columns (a, b, c, d, e) =
285 HQuintet
286 (HLabel "fst" (Columns a))
287 (HLabel "snd" (Columns b))
288 (HLabel "trd" (Columns c))
289 (HLabel "frt" (Columns d))
290 (HLabel "fft" (Columns e))
291 type Context (a, b, c, d, e) = Context a
293 toColumns (a, b, c, d, e) = HQuintet
294 { hfst = hlabel labeler $ toColumns a
295 , hsnd = hlabel labeler $ toColumns b
296 , htrd = hlabel labeler $ toColumns c
297 , hfrt = hlabel labeler $ toColumns d
298 , hfft = hlabel labeler $ toColumns e
299 }
300 fromColumns (HQuintet a b c d e) =
301 ( fromColumns $ hunlabel unlabeler a
302 , fromColumns $ hunlabel unlabeler b
303 , fromColumns $ hunlabel unlabeler c
304 , fromColumns $ hunlabel unlabeler d
305 , fromColumns $ hunlabel unlabeler e
306 )
309type Congruent :: Type -> Type -> Constraint
310class Columns a ~ Columns b => Congruent a b
311instance Columns a ~ Columns b => Congruent a b
314null :: Col Identity ('Spec labels necessity (Maybe a))
315null = Result Nothing
318nullifier :: ()
319 => SSpec ('Spec labels necessity a)
320 -> Col Identity ('Spec labels necessity a)
321 -> Col Identity ('Spec labels necessity (Nullify a))
322nullifier SSpec {nullity} (Result a) = Result $ case nullity of
323 Null -> a
324 NotNull -> Just a
327unnullifier :: ()
328 => SSpec ('Spec labels necessity a)
329 -> Col Identity ('Spec labels necessity (Nullify a))
330 -> Maybe (Col Identity ('Spec labels necessity a))
331unnullifier SSpec {nullity} (Result a) =
332 case nullity of
333 Null -> pure $ Result a
334 NotNull -> Result <$> a
337vectorizer :: Functor f
338 => SSpec ('Spec labels necessity a)
339 -> f (Col Identity ('Spec labels necessity a))
340 -> Col Identity ('Spec labels necessity (f a))
341vectorizer _ = Result . fmap (\(Result a) -> a)
344unvectorizer :: Functor f
345 => SSpec ('Spec labels necessity a)
346 -> Col Identity ('Spec labels necessity (f a))
347 -> f (Col Identity ('Spec labels necessity a))
348unvectorizer _ (Result results) = Result <$> results
351relabel :: ()
352 => HIdentity ('Spec labels necessity a) (Col Identity)
353 -> HIdentity ('Spec relabels necessity a) (Col Identity)
354relabel (HIdentity (Result a)) = HIdentity (Result a)