git.iko.soy/rel8
on 88e6ea5 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.Kind ( Constraint, Type )
23import Data.List.NonEmpty ( NonEmpty )
24import Prelude
26-- hasql
27import qualified Hasql.Decoders as Hasql
29-- rel8
30import Rel8.Expr ( Expr )
31import Rel8.Expr.Serialize ( slitExpr, sparseValue )
32import Rel8.Opaque ( Opaque )
33import Rel8.Schema.Context ( DB(..), Result(..) )
34import Rel8.Schema.Context.Label ( labeler, unlabeler )
35import Rel8.Schema.Context.Result
36 ( fromHEitherTable, toHEitherTable
37 , fromHListTable, toHListTable
38 , fromHMaybeTable, toHMaybeTable
39 , fromHNonEmptyTable, toHNonEmptyTable
40 , fromHTheseTable, toHTheseTable
41 )
42import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
43import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
44import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
45import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
46import Rel8.Schema.HTable.Pair ( HPair(..) )
47import Rel8.Schema.HTable.Trio ( HTrio(..) )
48import Rel8.Schema.HTable.Type ( HType(..) )
49import Rel8.Schema.HTable.Context ( H )
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 (_ (H Result)) = 'False
80 IsPlainColumn (_ Result) = 'False
81 IsPlainColumn (Result _) = '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 (_ (H Result)) = 'True
97 IsTabular (_ Result) = 'True
98 IsTabular (Result _) = '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
126fromResults' :: forall exprs a. ToExprs a exprs => Columns exprs (H Result) -> a
127fromResults' = fromResults @(IsPlainColumn a) @_ @_ @exprs
130toResults' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (H Result)
131toResults' = toResults @(IsPlainColumn a) @_ @_ @exprs
134type ExprsFor :: Bool -> Bool -> Type -> Type -> Constraint
135class (Table DB exprs, isTabular ~ IsTabular a) =>
136 ExprsFor isPlainColumn isTabular a exprs where
137 fromResults :: Columns exprs (H Result) -> a
138 toResults :: a -> Columns exprs (H Result)
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 fromResults (HType (Result a)) = a
150 toResults = HType . Result
153instance
154 ( Sql DBType a
155 , IsListTabular a ~ 'False
156 , x ~ [a]
157 ) => ExprsFor 'False 'False [a] (Expr x)
158 where
159 fromResults (HType (Result a)) = a
160 toResults = 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 fromResults (HType (Result a)) = a
172 toResults = 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 fromResults (HType (Result a)) = a
182 toResults = HType . Result
185instance
186 ( ToExprs a exprs
187 , IsListTabular a ~ 'False
188 ) => ExprsFor 'False 'False [a] (ListTable exprs)
189 where
190 fromResults = fmap (fromResults' @exprs) . fromHListTable
191 toResults = toHListTable . fmap (toResults' @exprs)
194instance
195 ( ToExprs a exprs
196 , IsMaybeTabular a ~ 'False
197 ) => ExprsFor 'False 'False (Maybe a) (MaybeTable exprs)
198 where
199 fromResults =
200 fmap (fromResults' @exprs . hunlabel unlabeler) .
201 fromHMaybeTable
202 toResults =
203 toHMaybeTable .
204 fmap (hlabel labeler . toResults' @exprs)
207instance
208 ( ToExprs a exprs
209 , IsListTabular a ~ 'False
210 ) => ExprsFor 'False 'False (NonEmpty a) (NonEmptyTable exprs)
211 where
212 fromResults = fmap (fromResults' @exprs) . fromHNonEmptyTable
213 toResults = toHNonEmptyTable . fmap (toResults' @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 fromResults =
224 bimap
225 (fromResults' @exprs1 . hunlabel unlabeler)
226 (fromResults' @exprs2 . hunlabel unlabeler) .
227 fromHEitherTable
228 toResults =
229 toHEitherTable .
230 bimap
231 (hlabel labeler . toResults' @exprs1)
232 (hlabel labeler . toResults' @exprs2)
235instance
236 ( ToExprs a exprs
237 , IsListTabular a ~ 'True
238 , x ~ ListTable exprs
239 ) => ExprsFor 'False 'True [a] x
240 where
241 fromResults = fmap (fromResults' @exprs) . fromHListTable
242 toResults = toHListTable . fmap (toResults' @exprs)
245instance
246 ( ToExprs a exprs
247 , IsMaybeTabular a ~ 'True
248 , x ~ MaybeTable exprs
249 ) => ExprsFor 'False 'True (Maybe a) x
250 where
251 fromResults =
252 fmap (fromResults' @exprs . hunlabel unlabeler) .
253 fromHMaybeTable
254 toResults =
255 toHMaybeTable .
256 fmap (hlabel labeler . toResults' @exprs)
259instance
260 ( ToExprs a exprs
261 , IsListTabular a ~ 'True
262 , x ~ NonEmptyTable exprs
263 ) => ExprsFor 'False 'True (NonEmpty a) x
264 where
265 fromResults = fmap (fromResults' @exprs) . fromHNonEmptyTable
266 toResults = toHNonEmptyTable . fmap (toResults' @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 fromResults =
277 bimap
278 (fromResults' @exprs1 . hunlabel unlabeler)
279 (fromResults' @exprs2 . hunlabel unlabeler) .
280 fromHTheseTable
281 toResults =
282 toHTheseTable .
283 bimap
284 (hlabel labeler . toResults' @exprs1)
285 (hlabel labeler . toResults' @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 fromResults (HPair a b) =
296 ( fromResults' @exprs1 $ hunlabel unlabeler a
297 , fromResults' @exprs2 $ hunlabel unlabeler b
298 )
299 toResults (a, b) = HPair
300 { hfst = hlabel labeler $ toResults' @exprs1 a
301 , hsnd = hlabel labeler $ toResults' @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 fromResults (HTrio a b c) =
314 ( fromResults' @exprs1 $ hunlabel unlabeler a
315 , fromResults' @exprs2 $ hunlabel unlabeler b
316 , fromResults' @exprs3 $ hunlabel unlabeler c
317 )
318 toResults (a, b, c) = HTrio
319 { hfst = hlabel labeler $ toResults' @exprs1 a
320 , hsnd = hlabel labeler $ toResults' @exprs2 b
321 , htrd = hlabel labeler $ toResults' @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 fromResults (HQuartet a b c d) =
335 ( fromResults' @exprs1 $ hunlabel unlabeler a
336 , fromResults' @exprs2 $ hunlabel unlabeler b
337 , fromResults' @exprs3 $ hunlabel unlabeler c
338 , fromResults' @exprs4 $ hunlabel unlabeler d
339 )
340 toResults (a, b, c, d) = HQuartet
341 { hfst = hlabel labeler $ toResults' @exprs1 a
342 , hsnd = hlabel labeler $ toResults' @exprs2 b
343 , htrd = hlabel labeler $ toResults' @exprs3 c
344 , hfrt = hlabel labeler $ toResults' @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 fromResults (HQuintet a b c d e) =
359 ( fromResults' @exprs1 $ hunlabel unlabeler a
360 , fromResults' @exprs2 $ hunlabel unlabeler b
361 , fromResults' @exprs3 $ hunlabel unlabeler c
362 , fromResults' @exprs4 $ hunlabel unlabeler d
363 , fromResults' @exprs5 $ hunlabel unlabeler e
364 )
365 toResults (a, b, c, d, e) = HQuintet
366 { hfst = hlabel labeler $ toResults' @exprs1 a
367 , hsnd = hlabel labeler $ toResults' @exprs2 b
368 , htrd = hlabel labeler $ toResults' @exprs3 c
369 , hfrt = hlabel labeler $ toResults' @exprs4 d
370 , hfft = hlabel labeler $ toResults' @exprs5 e
371 }
374instance
375 ( HTable t
376 , isTabular ~ 'True
377 , result ~ H Result
378 , x ~ t (H DB)
379 ) => ExprsFor 'False isTabular (t result) x
380 where
381 fromResults = id
382 toResults = id
385instance
386 ( Encodes (t Result) (t DB)
387 , isTabular ~ 'True
388 , result ~ Result
389 , x ~ t DB
390 ) => ExprsFor 'False isTabular (t result) x
391 where
392 fromResults = fromColumns
393 toResults = toColumns
396instance
397 ( KnownSpec spec
398 , isTabular ~ 'True
399 , x ~ DB spec
400 ) => ExprsFor 'False isTabular (Result spec) x
401 where
402 fromResults = fromColumns
403 toResults = toColumns
406type FromExprs :: Type -> Type
407type family FromExprs a where
408 FromExprs (Expr a) = a
409 FromExprs (DB spec) = Result 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 DB) = t Result
422 FromExprs (t (H DB)) = t (H Result)
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 . toResults' @exprs
437parse :: forall exprs a. Serializable exprs a => Hasql.Row a
438parse = fromResults' @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 Result 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