git.iko.soy/rel8
on 1276beb help sign in
rel8/src/Rel8/Table.hs
333 lines 11 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, toColumns, fromColumns)
18 , Congruent
19 , TTable, TColumns, TContext
20 )
21where
23-- base
24import Data.Functor ( ($>) )
25import Data.Functor.Identity ( Identity( Identity ) )
26import Data.Kind ( Constraint, Type )
27import Data.List.NonEmpty ( NonEmpty )
28import GHC.Generics ( Generic, Rep, from, to )
29import Prelude hiding ( null )
31-- rel8
32import Rel8.FCF ( Eval, Exp )
33import Rel8.Generic.Table
34 ( GTable, GColumns, GContext, fromGColumns, toGColumns
35 )
36import Rel8.Generic.Record ( Record(..) )
37import Rel8.Schema.Context ( Col(..) )
38import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
39import Rel8.Schema.HTable ( HTable )
40import Rel8.Schema.HTable.Either ( HEitherTable(..) )
41import Rel8.Schema.HTable.Identity ( HIdentity(..) )
42import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
43import Rel8.Schema.HTable.List ( HListTable )
44import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
45import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
46import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
47import Rel8.Schema.HTable.These ( HTheseTable(..) )
48import Rel8.Schema.HTable.Type ( HType( HType ) )
49import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
50import qualified Rel8.Schema.Kind as K
51import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
52import Rel8.Schema.Result ( Result )
53import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )
54import Rel8.Type ( DBType )
55import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
57-- these
58import Data.These ( These( This, That, These ) )
59import Data.These.Combinators ( justHere, justThere )
62-- | @Table@s are one of the foundational elements of Rel8, and describe data
63-- types that have a finite number of columns. Each of these columns contains
64-- data under a shared context, and contexts describe how to interpret the
65-- metadata about a column to a particular Haskell type. In Rel8, we have
66-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
67-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
68-- others.
69--
70-- In typical usage of Rel8 you don't need to derive instances of 'Table'
71-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
72-- 'Table'.
73type Table :: K.Context -> Type -> Constraint
74class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
75 -- | The 'HTable' functor that describes the schema of this table.
76 type Columns a :: K.HTable
78 -- | The common context that all columns use as an interpretation.
79 type Context a :: K.Context
81 toColumns :: a -> Columns a (Col (Context a))
82 fromColumns :: Columns a (Col (Context a)) -> a
84 type Columns a = GColumns TColumns (Rep (Record a))
85 type Context a = GContext TContext (Rep (Record a))
87 default toColumns ::
88 ( Generic (Record a)
89 , GTable (TTable context) TColumns (Col (Context a)) (Rep (Record a))
90 , Columns a ~ GColumns TColumns (Rep (Record a))
91 )
92 => a -> Columns a (Col (Context a))
93 toColumns =
94 toGColumns @(TTable context) @TColumns toColumns .
95 from .
96 Record
98 default fromColumns ::
99 ( Generic (Record a)
100 , GTable (TTable context) TColumns (Col (Context a)) (Rep (Record a))
101 , Columns a ~ GColumns TColumns (Rep (Record a))
102 )
103 => Columns a (Col (Context a)) -> a
104 fromColumns =
105 unrecord .
106 to .
107 fromGColumns @(TTable context) @TColumns fromColumns
110data TTable :: K.Context -> Type -> Exp Constraint
111type instance Eval (TTable context a) = Table context a
114data TColumns :: Type -> Exp K.HTable
115type instance Eval (TColumns a) = Columns a
118data TContext :: Type -> Exp K.Context
119type instance Eval (TContext a) = Context a
122-- | Any 'HTable' is also a 'Table'.
123instance HTable t => Table context (t (Col context)) where
124 type Columns (t (Col context)) = t
125 type Context (t (Col context)) = context
127 toColumns = id
128 fromColumns = id
131-- | Any context is trivially a table.
132instance KnownSpec spec => Table context (Col context spec) where
133 type Columns (Col context spec) = HIdentity spec
134 type Context (Col context spec) = context
136 toColumns = HIdentity
137 fromColumns = unHIdentity
140instance Sql DBType a => Table Result (Identity a) where
141 type Columns (Identity a) = HType a
142 type Context (Identity a) = Result
144 toColumns (Identity a) = HType (Result a)
145 fromColumns (HType (Result a)) = Identity a
148instance (Table Result a, Table Result b) => Table Result (Either a b) where
149 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
150 type Context (Either a b) = Result
152 toColumns = \case
153 Left table -> HEitherTable
154 { htag = HIdentity (Result IsLeft)
155 , hleft = hlabel labeler (hnullify nullifier (toColumns table))
156 , hright = hlabel labeler (hnulls null)
157 }
158 Right table -> HEitherTable
159 { htag = HIdentity (Result IsRight)
160 , hleft = hlabel labeler (hnulls null)
161 , hright = hlabel labeler (hnullify nullifier (toColumns table))
162 }
164 fromColumns HEitherTable {htag, hleft, hright} = case htag of
165 HIdentity (Result tag) -> case tag of
166 IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
167 IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
168 where
169 err = error "Either.fromColumns: mismatch between tag and data"
172instance Table Result a => Table Result [a] where
173 type Columns [a] = HListTable (Columns a)
174 type Context [a] = Result
176 toColumns = hvectorize vectorizer . fmap toColumns
177 fromColumns = fmap fromColumns . hunvectorize unvectorizer
180instance Table Result a => Table Result (Maybe a) where
181 type Columns (Maybe a) = HMaybeTable (Columns a)
182 type Context (Maybe a) = Result
184 toColumns = \case
185 Nothing -> HMaybeTable
186 { htag = HIdentity (Result Nothing)
187 , hjust = hlabel labeler (hnulls null)
188 }
189 Just table -> HMaybeTable
190 { htag = HIdentity (Result (Just IsJust))
191 , hjust = hlabel labeler (hnullify nullifier (toColumns table))
192 }
194 fromColumns HMaybeTable {htag, hjust} = case htag of
195 HIdentity (Result tag) -> tag $>
196 case hunnullify unnullifier (hunlabel unlabeler hjust) of
197 Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
198 Just just -> fromColumns just
201instance Table Result a => Table Result (NonEmpty a) where
202 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
203 type Context (NonEmpty a) = Result
205 toColumns = hvectorize vectorizer . fmap toColumns
206 fromColumns = fmap fromColumns . hunvectorize unvectorizer
209instance (Table Result a, Table Result b) => Table Result (These a b) where
210 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
211 type Context (These a b) = Result
213 toColumns tables = HTheseTable
214 { hhereTag = relabel hhereTag
215 , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
216 , hthereTag = relabel hthereTag
217 , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
218 }
219 where
220 HMaybeTable
221 { htag = hhereTag
222 , hjust = hhere
223 } = toColumns (justHere tables)
224 HMaybeTable
225 { htag = hthereTag
226 , hjust = hthere
227 } = toColumns (justThere tables)
229 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
230 case (fromColumns mhere, fromColumns mthere) of
231 (Just a, Nothing) -> This (fromColumns a)
232 (Nothing, Just b) -> That (fromColumns b)
233 (Just a, Just b) -> These (fromColumns a) (fromColumns b)
234 _ -> error "These.fromColumns: mismatch between tags and data"
235 where
236 mhere = HMaybeTable
237 { htag = relabel hhereTag
238 , hjust = hlabel labeler (hunlabel unlabeler hhere)
239 }
240 mthere = HMaybeTable
241 { htag = relabel hthereTag
242 , hjust = hlabel labeler (hunlabel unlabeler hthere)
243 }
246instance (Table context a, Table context b, Labelable context)
247 => Table context (a, b)
250instance
251 ( Table context a, Table context b, Table context c
252 , Labelable context
253 )
254 => Table context (a, b, c)
257instance
258 ( Table context a, Table context b, Table context c, Table context d
259 , Labelable context
260 )
261 => Table context (a, b, c, d)
264instance
265 ( Table context a, Table context b, Table context c, Table context d
266 , Table context e
267 , Labelable context
268 )
269 => Table context (a, b, c, d, e)
272instance
273 ( Table context a, Table context b, Table context c, Table context d
274 , Table context e, Table context f
275 , Labelable context
276 )
277 => Table context (a, b, c, d, e, f)
280instance
281 ( Table context a, Table context b, Table context c, Table context d
282 , Table context e, Table context f, Table context g
283 , Labelable context
284 )
285 => Table context (a, b, c, d, e, f, g)
288type Congruent :: Type -> Type -> Constraint
289class Columns a ~ Columns b => Congruent a b
290instance Columns a ~ Columns b => Congruent a b
293null :: Col Result ('Spec labels necessity (Maybe a))
294null = Result Nothing
297nullifier :: ()
298 => SSpec ('Spec labels necessity a)
299 -> Col Result ('Spec labels necessity a)
300 -> Col Result ('Spec labels necessity (Nullify a))
301nullifier SSpec {nullity} (Result a) = Result $ case nullity of
302 Null -> a
303 NotNull -> Just a
306unnullifier :: ()
307 => SSpec ('Spec labels necessity a)
308 -> Col Result ('Spec labels necessity (Nullify a))
309 -> Maybe (Col Result ('Spec labels necessity a))
310unnullifier SSpec {nullity} (Result a) =
311 case nullity of
312 Null -> pure $ Result a
313 NotNull -> Result <$> a
316vectorizer :: Functor f
317 => SSpec ('Spec labels necessity a)
318 -> f (Col Result ('Spec labels necessity a))
319 -> Col Result ('Spec labels necessity (f a))
320vectorizer _ = Result . fmap (\(Result a) -> a)
323unvectorizer :: Functor f
324 => SSpec ('Spec labels necessity a)
325 -> Col Result ('Spec labels necessity (f a))
326 -> f (Col Result ('Spec labels necessity a))
327unvectorizer _ (Result results) = Result <$> results
330relabel :: ()
331 => HIdentity ('Spec labels necessity a) (Col Result)
332 -> HIdentity ('Spec relabels necessity a) (Col Result)
333relabel (HIdentity (Result a)) = HIdentity (Result a)