git.iko.soy/rel8
on f3daaff help sign in
rel8/src/Rel8/Table/Serialize.hs
452 lines 13 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language DisambiguateRecordFields #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
6{-# language FunctionalDependencies #-}
7{-# language NamedFieldPuns #-}
8{-# language ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
10{-# language TypeApplications #-}
11{-# language TypeFamilies #-}
12{-# language ViewPatterns #-}
13{-# language UndecidableInstances #-}
15module Rel8.Table.Serialize
16 ( Serializable, lit, parse
17 )
18where
20-- base
21import Data.Bifunctor ( bimap )
22import Data.Functor.Identity ( Identity )
23import Data.Kind ( Constraint, Type )
24import Data.List.NonEmpty ( NonEmpty )
25import Prelude
27-- hasql
28import qualified Hasql.Decoders as Hasql
30-- rel8
31import Rel8.Expr ( Expr )
32import Rel8.Expr.Serialize ( slitExpr, sparseValue )
33import Rel8.Opaque ( Opaque )
34import Rel8.Schema.Context ( Col(..) )
35import Rel8.Schema.Context.Identity
36 ( fromHEitherTable, toHEitherTable
37 , fromHListTable, toHListTable
38 , fromHMaybeTable, toHMaybeTable
39 , fromHNonEmptyTable, toHNonEmptyTable
40 , fromHTheseTable, toHTheseTable
41 )
42import Rel8.Schema.Context.Label ( labeler, unlabeler )
43import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
44import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
45import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
46import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
47import Rel8.Schema.HTable.Pair ( HPair(..) )
48import Rel8.Schema.HTable.Trio ( HTrio(..) )
49import Rel8.Schema.HTable.Type ( HType(..) )
50import Rel8.Schema.Nullability ( IsMaybe, Sql )
51import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
52import Rel8.Table ( Table, Columns, fromColumns, toColumns )
53import Rel8.Table.Either ( EitherTable )
54import Rel8.Table.List ( ListTable )
55import Rel8.Table.Maybe ( MaybeTable )
56import Rel8.Table.NonEmpty ( NonEmptyTable )
57import Rel8.Table.Recontextualize ( Encodes )
58import Rel8.Table.These ( TheseTable )
59import Rel8.Type ( DBType )
61-- semigroupoids
62import Data.Functor.Apply ( WrappedApplicative(..) )
64-- these
65import Data.These ( These )
68type IsPlainColumn :: Type -> Bool
69type family IsPlainColumn a where
70 IsPlainColumn (Either _ _) = 'False
71 IsPlainColumn [_] = 'False
72 IsPlainColumn (Maybe _) = 'False
73 IsPlainColumn (NonEmpty _) = 'False
74 IsPlainColumn (These _ _) = 'False
75 IsPlainColumn (_, _) = 'False
76 IsPlainColumn (_, _, _) = 'False
77 IsPlainColumn (_, _, _, _) = 'False
78 IsPlainColumn (_, _, _, _, _) = 'False
79 IsPlainColumn (_ Identity) = 'False
80 IsPlainColumn (_ (Col Identity _)) = 'False
81 IsPlainColumn (Identity _) = 'False
82 IsPlainColumn _ = 'True
85type IsTabular :: Type -> Bool
86type family IsTabular a where
87 IsTabular (Either _ _) = 'True
88 IsTabular [a] = IsListTabular a
89 IsTabular (Maybe a) = IsMaybeTabular a
90 IsTabular (NonEmpty a) = IsListTabular a
91 IsTabular (These _ _) = 'True
92 IsTabular (_, _) = 'True
93 IsTabular (_, _, _) = 'True
94 IsTabular (_, _, _, _) = 'True
95 IsTabular (_, _, _, _, _) = 'True
96 IsTabular (_ Identity) = 'True
97 IsTabular (_ (Col Identity)) = 'True
98 IsTabular (Col Identity _) = 'True
99 IsTabular _ = 'False
102type IsTabular' :: Bool -> Type -> Bool
103type family IsTabular' isTabular exprs where
104 IsTabular' _ (Expr _) = 'False
105 IsTabular' 'False _ = 'False
106 IsTabular' _ _ = 'True
109type IsMaybeTabular :: Type -> Bool
110type family IsMaybeTabular a where
111 IsMaybeTabular (Maybe _) = 'True
112 IsMaybeTabular a = IsTabular a
115type IsListTabular :: Type -> Bool
116type family IsListTabular a where
117 IsListTabular (Maybe a) = IsMaybeTabular a
118 IsListTabular a = IsTabular a
121type ToExprs :: Type -> Type -> Constraint
122class ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs
123instance ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs
126fromIdentity' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Identity) -> a
127fromIdentity' = fromIdentity @(IsPlainColumn a) @_ @_ @exprs
130toIdentity' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Identity)
131toIdentity' = toIdentity @(IsPlainColumn a) @_ @_ @exprs
134type ExprsFor :: Bool -> Bool -> Type -> Type -> Constraint
135class (Table Expr exprs, isTabular ~ IsTabular a) =>
136 ExprsFor isPlainColumn isTabular a exprs where
137 fromIdentity :: Columns exprs (Col Identity) -> a
138 toIdentity :: a -> Columns exprs (Col Identity)
141instance
142 ( DBType a
143 , IsMaybe a ~ 'False
144 , IsTabular a ~ 'False
145 , x ~ Expr a
146 )
147 => ExprsFor 'True 'False a x
148 where
149 fromIdentity (HType (Result a)) = a
150 toIdentity = HType . Result
153instance
154 ( Sql DBType a
155 , IsListTabular a ~ 'False
156 , x ~ [a]
157 ) => ExprsFor 'False 'False [a] (Expr x)
158 where
159 fromIdentity (HType (Result a)) = a
160 toIdentity = HType . Result
163instance
164 ( Sql DBType a
165 , isTabular ~ 'False
166 , IsMaybe a ~ 'False
167 , IsMaybeTabular a ~ 'False
168 , x ~ Maybe a
169 ) => ExprsFor 'False 'False (Maybe a) (Expr x)
170 where
171 fromIdentity (HType (Result a)) = a
172 toIdentity = HType . Result
175instance
176 ( Sql DBType a
177 , IsListTabular a ~ 'False
178 , x ~ NonEmpty a
179 ) => ExprsFor 'False 'False (NonEmpty a) (Expr x)
180 where
181 fromIdentity (HType (Result a)) = a
182 toIdentity = HType . Result
185instance
186 ( ToExprs a exprs
187 , IsListTabular a ~ 'False
188 ) => ExprsFor 'False 'False [a] (ListTable exprs)
189 where
190 fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable
191 toIdentity = toHListTable . fmap (toIdentity' @exprs)
194instance
195 ( ToExprs a exprs
196 , IsMaybeTabular a ~ 'False
197 ) => ExprsFor 'False 'False (Maybe a) (MaybeTable exprs)
198 where
199 fromIdentity =
200 fmap (fromIdentity' @exprs . hunlabel unlabeler) .
201 fromHMaybeTable
202 toIdentity =
203 toHMaybeTable .
204 fmap (hlabel labeler . toIdentity' @exprs)
207instance
208 ( ToExprs a exprs
209 , IsListTabular a ~ 'False
210 ) => ExprsFor 'False 'False (NonEmpty a) (NonEmptyTable exprs)
211 where
212 fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable
213 toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)
216instance
217 ( ToExprs a exprs1
218 , ToExprs b exprs2
219 , isTabular ~ 'True
220 , x ~ EitherTable exprs1 exprs2
221 ) => ExprsFor 'False isTabular (Either a b) x
222 where
223 fromIdentity =
224 bimap
225 (fromIdentity' @exprs1 . hunlabel unlabeler)
226 (fromIdentity' @exprs2 . hunlabel unlabeler) .
227 fromHEitherTable
228 toIdentity =
229 toHEitherTable .
230 bimap
231 (hlabel labeler . toIdentity' @exprs1)
232 (hlabel labeler . toIdentity' @exprs2)
235instance
236 ( ToExprs a exprs
237 , IsListTabular a ~ 'True
238 , x ~ ListTable exprs
239 ) => ExprsFor 'False 'True [a] x
240 where
241 fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable
242 toIdentity = toHListTable . fmap (toIdentity' @exprs)
245instance
246 ( ToExprs a exprs
247 , IsMaybeTabular a ~ 'True
248 , x ~ MaybeTable exprs
249 ) => ExprsFor 'False 'True (Maybe a) x
250 where
251 fromIdentity =
252 fmap (fromIdentity' @exprs . hunlabel unlabeler) .
253 fromHMaybeTable
254 toIdentity =
255 toHMaybeTable .
256 fmap (hlabel labeler . toIdentity' @exprs)
259instance
260 ( ToExprs a exprs
261 , IsListTabular a ~ 'True
262 , x ~ NonEmptyTable exprs
263 ) => ExprsFor 'False 'True (NonEmpty a) x
264 where
265 fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable
266 toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)
269instance
270 ( ToExprs a exprs1
271 , ToExprs b exprs2
272 , isTabular ~ 'True
273 , x ~ TheseTable exprs1 exprs2
274 ) => ExprsFor 'False isTabular (These a b) x
275 where
276 fromIdentity =
277 bimap
278 (fromIdentity' @exprs1 . hunlabel unlabeler)
279 (fromIdentity' @exprs2 . hunlabel unlabeler) .
280 fromHTheseTable
281 toIdentity =
282 toHTheseTable .
283 bimap
284 (hlabel labeler . toIdentity' @exprs1)
285 (hlabel labeler . toIdentity' @exprs2)
288instance
289 ( ToExprs a exprs1
290 , ToExprs b exprs2
291 , isTabular ~ 'True
292 , x ~ (exprs1, exprs2)
293 ) => ExprsFor 'False isTabular (a, b) x
294 where
295 fromIdentity (HPair a b) =
296 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
297 , fromIdentity' @exprs2 $ hunlabel unlabeler b
298 )
299 toIdentity (a, b) = HPair
300 { hfst = hlabel labeler $ toIdentity' @exprs1 a
301 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
302 }
305instance
306 ( ToExprs a exprs1
307 , ToExprs b exprs2
308 , ToExprs c exprs3
309 , isTabular ~ 'True
310 , x ~ (exprs1, exprs2, exprs3)
311 ) => ExprsFor 'False isTabular (a, b, c) x
312 where
313 fromIdentity (HTrio a b c) =
314 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
315 , fromIdentity' @exprs2 $ hunlabel unlabeler b
316 , fromIdentity' @exprs3 $ hunlabel unlabeler c
317 )
318 toIdentity (a, b, c) = HTrio
319 { hfst = hlabel labeler $ toIdentity' @exprs1 a
320 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
321 , htrd = hlabel labeler $ toIdentity' @exprs3 c
322 }
325instance
326 ( ToExprs a exprs1
327 , ToExprs b exprs2
328 , ToExprs c exprs3
329 , ToExprs d exprs4
330 , isTabular ~ 'True
331 , x ~ (exprs1, exprs2, exprs3, exprs4)
332 ) => ExprsFor 'False isTabular (a, b, c, d) x
333 where
334 fromIdentity (HQuartet a b c d) =
335 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
336 , fromIdentity' @exprs2 $ hunlabel unlabeler b
337 , fromIdentity' @exprs3 $ hunlabel unlabeler c
338 , fromIdentity' @exprs4 $ hunlabel unlabeler d
339 )
340 toIdentity (a, b, c, d) = HQuartet
341 { hfst = hlabel labeler $ toIdentity' @exprs1 a
342 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
343 , htrd = hlabel labeler $ toIdentity' @exprs3 c
344 , hfrt = hlabel labeler $ toIdentity' @exprs4 d
345 }
348instance
349 ( ToExprs a exprs1
350 , ToExprs b exprs2
351 , ToExprs c exprs3
352 , ToExprs d exprs4
353 , ToExprs e exprs5
354 , isTabular ~ 'True
355 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
356 ) => ExprsFor 'False isTabular (a, b, c, d, e) x
357 where
358 fromIdentity (HQuintet a b c d e) =
359 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
360 , fromIdentity' @exprs2 $ hunlabel unlabeler b
361 , fromIdentity' @exprs3 $ hunlabel unlabeler c
362 , fromIdentity' @exprs4 $ hunlabel unlabeler d
363 , fromIdentity' @exprs5 $ hunlabel unlabeler e
364 )
365 toIdentity (a, b, c, d, e) = HQuintet
366 { hfst = hlabel labeler $ toIdentity' @exprs1 a
367 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
368 , htrd = hlabel labeler $ toIdentity' @exprs3 c
369 , hfrt = hlabel labeler $ toIdentity' @exprs4 d
370 , hfft = hlabel labeler $ toIdentity' @exprs5 e
371 }
374instance
375 ( HTable t
376 , isTabular ~ 'True
377 , result ~ Col Identity
378 , x ~ t (Col Expr)
379 ) => ExprsFor 'False isTabular (t result) x
380 where
381 fromIdentity = id
382 toIdentity = id
385instance
386 ( Encodes (t Identity) (t Expr)
387 , isTabular ~ 'True
388 , result ~ Identity
389 , x ~ t Expr
390 ) => ExprsFor 'False isTabular (t result) x
391 where
392 fromIdentity = fromColumns
393 toIdentity = toColumns
396instance
397 ( KnownSpec spec
398 , isTabular ~ 'True
399 , isSpecial ~ 'True
400 , x ~ Col Expr spec
401 ) => ExprsFor 'False isTabular (Col Identity spec) x
402 where
403 fromIdentity = fromColumns
404 toIdentity = toColumns
407type FromExprs :: Type -> Type
408type family FromExprs a where
409 FromExprs (Expr a) = a
410 FromExprs (Col Expr spec) = Col Identity spec
411 FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
412 FromExprs (ListTable a) = [FromExprs a]
413 FromExprs (MaybeTable a) = Maybe (FromExprs a)
414 FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
415 FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
416 FromExprs (a, b) = (FromExprs a, FromExprs b)
417 FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
418 FromExprs (a, b, c, d) =
419 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
420 FromExprs (a, b, c, d, e) =
421 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
422 FromExprs (t Expr) = t Identity
423 FromExprs (t (Col Expr)) = t (Col Identity)
426-- | @Serializable@ witnesses the one-to-one correspondence between the type
427-- @sql@, which contains SQL expressions, and the type @haskell@, which
428-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
429class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
430instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
431instance Serializable (Expr Opaque) Opaque
434lit :: forall exprs a. Serializable exprs a => a -> exprs
435lit = fromColumns . litTable . toIdentity' @exprs
438parse :: forall exprs a. Serializable exprs a => Hasql.Row a
439parse = fromIdentity' @exprs <$> parseTable
442litTable :: Encodes a b => a -> b
443litTable (toColumns -> as) = fromColumns $ htabulate $ \field ->
444 case hfield hspecs field of
445 SSpec {nullability, info} -> case hfield as field of
446 Result value -> DB (slitExpr nullability info value)
449parseTable :: Table Identity a => Hasql.Row a
450parseTable = fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
451 WrapApplicative $ case hfield hspecs field of
452 SSpec {nullability, info} -> Result <$> sparseValue nullability info