git.iko.soy/rel8
on dec2074 help sign in
rel8/src/Rel8/Table/Serialize.hs
451 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, Encodes, Col(..) )
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.These ( TheseTable )
58import Rel8.Type ( DBType )
60-- semigroupoids
61import Data.Functor.Apply ( WrappedApplicative(..) )
63-- these
64import Data.These ( These )
67type IsPlainColumn :: Type -> Bool
68type family IsPlainColumn a where
69 IsPlainColumn (Either _ _) = 'False
70 IsPlainColumn [_] = 'False
71 IsPlainColumn (Maybe _) = 'False
72 IsPlainColumn (NonEmpty _) = 'False
73 IsPlainColumn (These _ _) = 'False
74 IsPlainColumn (_, _) = 'False
75 IsPlainColumn (_, _, _) = 'False
76 IsPlainColumn (_, _, _, _) = 'False
77 IsPlainColumn (_, _, _, _, _) = 'False
78 IsPlainColumn (_ Identity) = 'False
79 IsPlainColumn (_ (Col Identity _)) = 'False
80 IsPlainColumn (Identity _) = 'False
81 IsPlainColumn _ = 'True
84type IsTabular :: Type -> Bool
85type family IsTabular a where
86 IsTabular (Either _ _) = 'True
87 IsTabular [a] = IsListTabular a
88 IsTabular (Maybe a) = IsMaybeTabular a
89 IsTabular (NonEmpty a) = IsListTabular a
90 IsTabular (These _ _) = 'True
91 IsTabular (_, _) = 'True
92 IsTabular (_, _, _) = 'True
93 IsTabular (_, _, _, _) = 'True
94 IsTabular (_, _, _, _, _) = 'True
95 IsTabular (_ Identity) = 'True
96 IsTabular (_ (Col Identity)) = 'True
97 IsTabular (Col Identity _) = 'True
98 IsTabular _ = 'False
101type IsTabular' :: Bool -> Type -> Bool
102type family IsTabular' isTabular exprs where
103 IsTabular' _ (Expr _) = 'False
104 IsTabular' 'False _ = 'False
105 IsTabular' _ _ = 'True
108type IsMaybeTabular :: Type -> Bool
109type family IsMaybeTabular a where
110 IsMaybeTabular (Maybe _) = 'True
111 IsMaybeTabular a = IsTabular a
114type IsListTabular :: Type -> Bool
115type family IsListTabular a where
116 IsListTabular (Maybe a) = IsMaybeTabular a
117 IsListTabular a = IsTabular a
120type ToExprs :: Type -> Type -> Constraint
121class ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs
122instance ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs
125fromIdentity' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Identity) -> a
126fromIdentity' = fromIdentity @(IsPlainColumn a) @_ @_ @exprs
129toIdentity' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Identity)
130toIdentity' = toIdentity @(IsPlainColumn a) @_ @_ @exprs
133type ExprsFor :: Bool -> Bool -> Type -> Type -> Constraint
134class (Table Expr exprs, isTabular ~ IsTabular a) =>
135 ExprsFor isPlainColumn isTabular a exprs where
136 fromIdentity :: Columns exprs (Col Identity) -> a
137 toIdentity :: a -> Columns exprs (Col Identity)
140instance
141 ( DBType a
142 , IsMaybe a ~ 'False
143 , IsTabular a ~ 'False
144 , x ~ Expr a
145 )
146 => ExprsFor 'True 'False a x
147 where
148 fromIdentity (HType (Result a)) = a
149 toIdentity = HType . Result
152instance
153 ( Sql DBType a
154 , IsListTabular a ~ 'False
155 , x ~ [a]
156 ) => ExprsFor 'False 'False [a] (Expr x)
157 where
158 fromIdentity (HType (Result a)) = a
159 toIdentity = HType . Result
162instance
163 ( Sql DBType a
164 , isTabular ~ 'False
165 , IsMaybe a ~ 'False
166 , IsMaybeTabular a ~ 'False
167 , x ~ Maybe a
168 ) => ExprsFor 'False 'False (Maybe a) (Expr x)
169 where
170 fromIdentity (HType (Result a)) = a
171 toIdentity = HType . Result
174instance
175 ( Sql DBType a
176 , IsListTabular a ~ 'False
177 , x ~ NonEmpty a
178 ) => ExprsFor 'False 'False (NonEmpty a) (Expr x)
179 where
180 fromIdentity (HType (Result a)) = a
181 toIdentity = HType . Result
184instance
185 ( ToExprs a exprs
186 , IsListTabular a ~ 'False
187 ) => ExprsFor 'False 'False [a] (ListTable exprs)
188 where
189 fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable
190 toIdentity = toHListTable . fmap (toIdentity' @exprs)
193instance
194 ( ToExprs a exprs
195 , IsMaybeTabular a ~ 'False
196 ) => ExprsFor 'False 'False (Maybe a) (MaybeTable exprs)
197 where
198 fromIdentity =
199 fmap (fromIdentity' @exprs . hunlabel unlabeler) .
200 fromHMaybeTable
201 toIdentity =
202 toHMaybeTable .
203 fmap (hlabel labeler . toIdentity' @exprs)
206instance
207 ( ToExprs a exprs
208 , IsListTabular a ~ 'False
209 ) => ExprsFor 'False 'False (NonEmpty a) (NonEmptyTable exprs)
210 where
211 fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable
212 toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)
215instance
216 ( ToExprs a exprs1
217 , ToExprs b exprs2
218 , isTabular ~ 'True
219 , x ~ EitherTable exprs1 exprs2
220 ) => ExprsFor 'False isTabular (Either a b) x
221 where
222 fromIdentity =
223 bimap
224 (fromIdentity' @exprs1 . hunlabel unlabeler)
225 (fromIdentity' @exprs2 . hunlabel unlabeler) .
226 fromHEitherTable
227 toIdentity =
228 toHEitherTable .
229 bimap
230 (hlabel labeler . toIdentity' @exprs1)
231 (hlabel labeler . toIdentity' @exprs2)
234instance
235 ( ToExprs a exprs
236 , IsListTabular a ~ 'True
237 , x ~ ListTable exprs
238 ) => ExprsFor 'False 'True [a] x
239 where
240 fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable
241 toIdentity = toHListTable . fmap (toIdentity' @exprs)
244instance
245 ( ToExprs a exprs
246 , IsMaybeTabular a ~ 'True
247 , x ~ MaybeTable exprs
248 ) => ExprsFor 'False 'True (Maybe a) x
249 where
250 fromIdentity =
251 fmap (fromIdentity' @exprs . hunlabel unlabeler) .
252 fromHMaybeTable
253 toIdentity =
254 toHMaybeTable .
255 fmap (hlabel labeler . toIdentity' @exprs)
258instance
259 ( ToExprs a exprs
260 , IsListTabular a ~ 'True
261 , x ~ NonEmptyTable exprs
262 ) => ExprsFor 'False 'True (NonEmpty a) x
263 where
264 fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable
265 toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)
268instance
269 ( ToExprs a exprs1
270 , ToExprs b exprs2
271 , isTabular ~ 'True
272 , x ~ TheseTable exprs1 exprs2
273 ) => ExprsFor 'False isTabular (These a b) x
274 where
275 fromIdentity =
276 bimap
277 (fromIdentity' @exprs1 . hunlabel unlabeler)
278 (fromIdentity' @exprs2 . hunlabel unlabeler) .
279 fromHTheseTable
280 toIdentity =
281 toHTheseTable .
282 bimap
283 (hlabel labeler . toIdentity' @exprs1)
284 (hlabel labeler . toIdentity' @exprs2)
287instance
288 ( ToExprs a exprs1
289 , ToExprs b exprs2
290 , isTabular ~ 'True
291 , x ~ (exprs1, exprs2)
292 ) => ExprsFor 'False isTabular (a, b) x
293 where
294 fromIdentity (HPair a b) =
295 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
296 , fromIdentity' @exprs2 $ hunlabel unlabeler b
297 )
298 toIdentity (a, b) = HPair
299 { hfst = hlabel labeler $ toIdentity' @exprs1 a
300 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
301 }
304instance
305 ( ToExprs a exprs1
306 , ToExprs b exprs2
307 , ToExprs c exprs3
308 , isTabular ~ 'True
309 , x ~ (exprs1, exprs2, exprs3)
310 ) => ExprsFor 'False isTabular (a, b, c) x
311 where
312 fromIdentity (HTrio a b c) =
313 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
314 , fromIdentity' @exprs2 $ hunlabel unlabeler b
315 , fromIdentity' @exprs3 $ hunlabel unlabeler c
316 )
317 toIdentity (a, b, c) = HTrio
318 { hfst = hlabel labeler $ toIdentity' @exprs1 a
319 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
320 , htrd = hlabel labeler $ toIdentity' @exprs3 c
321 }
324instance
325 ( ToExprs a exprs1
326 , ToExprs b exprs2
327 , ToExprs c exprs3
328 , ToExprs d exprs4
329 , isTabular ~ 'True
330 , x ~ (exprs1, exprs2, exprs3, exprs4)
331 ) => ExprsFor 'False isTabular (a, b, c, d) x
332 where
333 fromIdentity (HQuartet a b c d) =
334 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
335 , fromIdentity' @exprs2 $ hunlabel unlabeler b
336 , fromIdentity' @exprs3 $ hunlabel unlabeler c
337 , fromIdentity' @exprs4 $ hunlabel unlabeler d
338 )
339 toIdentity (a, b, c, d) = HQuartet
340 { hfst = hlabel labeler $ toIdentity' @exprs1 a
341 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
342 , htrd = hlabel labeler $ toIdentity' @exprs3 c
343 , hfrt = hlabel labeler $ toIdentity' @exprs4 d
344 }
347instance
348 ( ToExprs a exprs1
349 , ToExprs b exprs2
350 , ToExprs c exprs3
351 , ToExprs d exprs4
352 , ToExprs e exprs5
353 , isTabular ~ 'True
354 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
355 ) => ExprsFor 'False isTabular (a, b, c, d, e) x
356 where
357 fromIdentity (HQuintet a b c d e) =
358 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
359 , fromIdentity' @exprs2 $ hunlabel unlabeler b
360 , fromIdentity' @exprs3 $ hunlabel unlabeler c
361 , fromIdentity' @exprs4 $ hunlabel unlabeler d
362 , fromIdentity' @exprs5 $ hunlabel unlabeler e
363 )
364 toIdentity (a, b, c, d, e) = HQuintet
365 { hfst = hlabel labeler $ toIdentity' @exprs1 a
366 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
367 , htrd = hlabel labeler $ toIdentity' @exprs3 c
368 , hfrt = hlabel labeler $ toIdentity' @exprs4 d
369 , hfft = hlabel labeler $ toIdentity' @exprs5 e
370 }
373instance
374 ( HTable t
375 , isTabular ~ 'True
376 , result ~ Col Identity
377 , x ~ t (Col Expr)
378 ) => ExprsFor 'False isTabular (t result) x
379 where
380 fromIdentity = id
381 toIdentity = id
384instance
385 ( Encodes (t Identity) (t Expr)
386 , isTabular ~ 'True
387 , result ~ Identity
388 , x ~ t Expr
389 ) => ExprsFor 'False isTabular (t result) x
390 where
391 fromIdentity = fromColumns
392 toIdentity = toColumns
395instance
396 ( KnownSpec spec
397 , isTabular ~ 'True
398 , isSpecial ~ 'True
399 , x ~ Col Expr spec
400 ) => ExprsFor 'False isTabular (Col Identity spec) x
401 where
402 fromIdentity = fromColumns
403 toIdentity = toColumns
406type FromExprs :: Type -> Type
407type family FromExprs a where
408 FromExprs (Expr a) = a
409 FromExprs (Col Expr spec) = Col Identity spec
410 FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
411 FromExprs (ListTable a) = [FromExprs a]
412 FromExprs (MaybeTable a) = Maybe (FromExprs a)
413 FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
414 FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
415 FromExprs (a, b) = (FromExprs a, FromExprs b)
416 FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
417 FromExprs (a, b, c, d) =
418 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
419 FromExprs (a, b, c, d, e) =
420 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
421 FromExprs (t Expr) = t Identity
422 FromExprs (t (Col Expr)) = t (Col Identity)
425-- | @Serializable@ witnesses the one-to-one correspondence between the type
426-- @sql@, which contains SQL expressions, and the type @haskell@, which
427-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
428class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
429instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
430instance Serializable (Expr Opaque) Opaque
433lit :: forall exprs a. Serializable exprs a => a -> exprs
434lit = fromColumns . litTable . toIdentity' @exprs
437parse :: forall exprs a. Serializable exprs a => Hasql.Row a
438parse = fromIdentity' @exprs <$> parseTable
441litTable :: Encodes a b => a -> b
442litTable (toColumns -> as) = fromColumns $ htabulate $ \field ->
443 case hfield hspecs field of
444 SSpec {nullability, info} -> case hfield as field of
445 Result value -> DB (slitExpr nullability info value)
448parseTable :: Table Identity a => Hasql.Row a
449parseTable = fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
450 WrapApplicative $ case hfield hspecs field of
451 SSpec {nullability, info} -> Result <$> sparseValue nullability info