git.iko.soy/rel8
on 47e7842 help sign in
rel8/src/Rel8/Table.hs
353 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.Result ( Result )
48import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )
49import Rel8.Type ( DBType )
50import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
52-- these
53import Data.These ( These( This, That, These ) )
54import Data.These.Combinators ( justHere, justThere )
57-- | @Table@s are one of the foundational elements of Rel8, and describe data
58-- types that have a finite number of columns. Each of these columns contains
59-- data under a shared context, and contexts describe how to interpret the
60-- metadata about a column to a particular Haskell type. In Rel8, we have
61-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
62-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
63-- others.
64--
65-- In typical usage of Rel8 you don't need to derive instances of 'Table'
66-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
67-- 'Table'.
68type Table :: K.Context -> Type -> Constraint
69class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
70 -- | The 'HTable' functor that describes the schema of this table.
71 type Columns a :: K.HTable
73 -- | The common context that all columns use as an interpretation.
74 type Context a :: K.Context
76 toColumns :: a -> Columns a (Col (Context a))
77 fromColumns :: Columns a (Col (Context a)) -> a
80-- | Any 'HTable' is also a 'Table'.
81instance HTable t => Table context (t (Col context)) where
82 type Columns (t (Col context)) = t
83 type Context (t (Col context)) = context
85 toColumns = id
86 fromColumns = id
89-- | Any context is trivially a table.
90instance KnownSpec spec => Table context (Col context spec) where
91 type Columns (Col context spec) = HIdentity spec
92 type Context (Col context spec) = context
94 toColumns = HIdentity
95 fromColumns = unHIdentity
98instance Sql DBType a => Table Result (Identity a) where
99 type Columns (Identity a) = HType a
100 type Context (Identity a) = Result
102 toColumns (Identity a) = HType (Result a)
103 fromColumns (HType (Result a)) = Identity a
106instance (Table Result a, Table Result b) => Table Result (Either a b) where
107 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
108 type Context (Either a b) = Result
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 Result a => Table Result [a] where
131 type Columns [a] = HListTable (Columns a)
132 type Context [a] = Result
134 toColumns = hvectorize vectorizer . fmap toColumns
135 fromColumns = fmap fromColumns . hunvectorize unvectorizer
138instance Table Result a => Table Result (Maybe a) where
139 type Columns (Maybe a) = HMaybeTable (Columns a)
140 type Context (Maybe a) = Result
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 Result a => Table Result (NonEmpty a) where
160 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
161 type Context (NonEmpty a) = Result
163 toColumns = hvectorize vectorizer . fmap toColumns
164 fromColumns = fmap fromColumns . hunvectorize unvectorizer
167instance (Table Result a, Table Result b) => Table Result (These a b) where
168 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
169 type Context (These a b) = Result
171 toColumns tables = HTheseTable
172 { hhereTag = relabel hhereTag
173 , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
174 , hthereTag = relabel hthereTag
175 , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
176 }
177 where
178 HMaybeTable
179 { htag = hhereTag
180 , hjust = hhere
181 } = toColumns (justHere tables)
182 HMaybeTable
183 { htag = hthereTag
184 , hjust = hthere
185 } = toColumns (justThere tables)
187 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
188 case (fromColumns mhere, fromColumns mthere) of
189 (Just a, Nothing) -> This (fromColumns a)
190 (Nothing, Just b) -> That (fromColumns b)
191 (Just a, Just b) -> These (fromColumns a) (fromColumns b)
192 _ -> error "These.fromColumns: mismatch between tags and data"
193 where
194 mhere = HMaybeTable
195 { htag = relabel hhereTag
196 , hjust = hlabel labeler (hunlabel unlabeler hhere)
197 }
198 mthere = HMaybeTable
199 { htag = relabel hthereTag
200 , hjust = hlabel labeler (hunlabel unlabeler hthere)
201 }
204instance
205 ( Table context a, Table context b
206 , Labelable context
207 ) =>
208 Table context (a, b)
209 where
210 type Columns (a, b) =
211 HPair
212 (HLabel "fst" (Columns a))
213 (HLabel "snd" (Columns b))
214 type Context (a, b) = Context a
216 toColumns (a, b) = HPair
217 { hfst = hlabel labeler $ toColumns a
218 , hsnd = hlabel labeler $ toColumns b
219 }
220 fromColumns (HPair a b) =
221 ( fromColumns $ hunlabel unlabeler a
222 , fromColumns $ hunlabel unlabeler b
223 )
226instance
227 ( Table context a, Table context b, Table context c
228 , Labelable context
229 ) => Table context (a, b, c)
230 where
231 type Columns (a, b, c) =
232 HTrio
233 (HLabel "fst" (Columns a))
234 (HLabel "snd" (Columns b))
235 (HLabel "trd" (Columns c))
236 type Context (a, b, c) = Context a
238 toColumns (a, b, c) = HTrio
239 { hfst = hlabel labeler $ toColumns a
240 , hsnd = hlabel labeler $ toColumns b
241 , htrd = hlabel labeler $ toColumns c
242 }
243 fromColumns (HTrio a b c) =
244 ( fromColumns $ hunlabel unlabeler a
245 , fromColumns $ hunlabel unlabeler b
246 , fromColumns $ hunlabel unlabeler c
247 )
250instance
251 ( Table context a, Table context b, Table context c, Table context d
252 , Labelable context
253 ) => Table context (a, b, c, d)
254 where
255 type Columns (a, b, c, d) =
256 HQuartet
257 (HLabel "fst" (Columns a))
258 (HLabel "snd" (Columns b))
259 (HLabel "trd" (Columns c))
260 (HLabel "frt" (Columns d))
261 type Context (a, b, c, d) = Context a
263 toColumns (a, b, c, d) = HQuartet
264 { hfst = hlabel labeler $ toColumns a
265 , hsnd = hlabel labeler $ toColumns b
266 , htrd = hlabel labeler $ toColumns c
267 , hfrt = hlabel labeler $ toColumns d
268 }
269 fromColumns (HQuartet a b c d) =
270 ( fromColumns $ hunlabel unlabeler a
271 , fromColumns $ hunlabel unlabeler b
272 , fromColumns $ hunlabel unlabeler c
273 , fromColumns $ hunlabel unlabeler d
274 )
277instance
278 ( Table context a, Table context b, Table context c, Table context d
279 , Table context e
280 , Labelable context
281 ) => Table context (a, b, c, d, e)
282 where
283 type Columns (a, b, c, d, e) =
284 HQuintet
285 (HLabel "fst" (Columns a))
286 (HLabel "snd" (Columns b))
287 (HLabel "trd" (Columns c))
288 (HLabel "frt" (Columns d))
289 (HLabel "fft" (Columns e))
290 type Context (a, b, c, d, e) = Context a
292 toColumns (a, b, c, d, e) = HQuintet
293 { hfst = hlabel labeler $ toColumns a
294 , hsnd = hlabel labeler $ toColumns b
295 , htrd = hlabel labeler $ toColumns c
296 , hfrt = hlabel labeler $ toColumns d
297 , hfft = hlabel labeler $ toColumns e
298 }
299 fromColumns (HQuintet a b c d e) =
300 ( fromColumns $ hunlabel unlabeler a
301 , fromColumns $ hunlabel unlabeler b
302 , fromColumns $ hunlabel unlabeler c
303 , fromColumns $ hunlabel unlabeler d
304 , fromColumns $ hunlabel unlabeler e
305 )
308type Congruent :: Type -> Type -> Constraint
309class Columns a ~ Columns b => Congruent a b
310instance Columns a ~ Columns b => Congruent a b
313null :: Col Result ('Spec labels necessity (Maybe a))
314null = Result Nothing
317nullifier :: ()
318 => SSpec ('Spec labels necessity a)
319 -> Col Result ('Spec labels necessity a)
320 -> Col Result ('Spec labels necessity (Nullify a))
321nullifier SSpec {nullity} (Result a) = Result $ case nullity of
322 Null -> a
323 NotNull -> Just a
326unnullifier :: ()
327 => SSpec ('Spec labels necessity a)
328 -> Col Result ('Spec labels necessity (Nullify a))
329 -> Maybe (Col Result ('Spec labels necessity a))
330unnullifier SSpec {nullity} (Result a) =
331 case nullity of
332 Null -> pure $ Result a
333 NotNull -> Result <$> a
336vectorizer :: Functor f
337 => SSpec ('Spec labels necessity a)
338 -> f (Col Result ('Spec labels necessity a))
339 -> Col Result ('Spec labels necessity (f a))
340vectorizer _ = Result . fmap (\(Result a) -> a)
343unvectorizer :: Functor f
344 => SSpec ('Spec labels necessity a)
345 -> Col Result ('Spec labels necessity (f a))
346 -> f (Col Result ('Spec labels necessity a))
347unvectorizer _ (Result results) = Result <$> results
350relabel :: ()
351 => HIdentity ('Spec labels necessity a) (Col Result)
352 -> HIdentity ('Spec relabels necessity a) (Col Result)
353relabel (HIdentity (Result a)) = HIdentity (Result a)