git.iko.soy/rel8
on 669b262 help sign in
rel8/src/Rel8/Table/Serialize.hs
453 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, Nullabilizes )
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 ( DBType db
155 , Nullabilizes db a
156 , IsListTabular a ~ 'False
157 , x ~ [a]
158 ) => ExprsFor 'False 'False [a] (Expr x)
159 where
160 fromResults (HType (Result a)) = a
161 toResults = HType . Result
164instance
165 ( DBType a
166 , Nullabilizes a (Maybe a)
167 , isTabular ~ 'False
168 , IsMaybeTabular a ~ 'False
169 , x ~ Maybe a
170 ) => ExprsFor 'False 'False (Maybe a) (Expr x)
171 where
172 fromResults (HType (Result a)) = a
173 toResults = HType . Result
176instance
177 ( DBType db
178 , Nullabilizes db a
179 , IsListTabular a ~ 'False
180 , x ~ NonEmpty a
181 ) => ExprsFor 'False 'False (NonEmpty a) (Expr x)
182 where
183 fromResults (HType (Result a)) = a
184 toResults = HType . Result
187instance
188 ( ToExprs a exprs
189 , IsListTabular a ~ 'False
190 ) => ExprsFor 'False 'False [a] (ListTable exprs)
191 where
192 fromResults = fmap (fromResults' @exprs) . fromHListTable
193 toResults = toHListTable . fmap (toResults' @exprs)
196instance
197 ( ToExprs a exprs
198 , IsMaybeTabular a ~ 'False
199 ) => ExprsFor 'False 'False (Maybe a) (MaybeTable exprs)
200 where
201 fromResults =
202 fmap (fromResults' @exprs . hunlabel unlabeler) .
203 fromHMaybeTable
204 toResults =
205 toHMaybeTable .
206 fmap (hlabel labeler . toResults' @exprs)
209instance
210 ( ToExprs a exprs
211 , IsListTabular a ~ 'False
212 ) => ExprsFor 'False 'False (NonEmpty a) (NonEmptyTable exprs)
213 where
214 fromResults = fmap (fromResults' @exprs) . fromHNonEmptyTable
215 toResults = toHNonEmptyTable . fmap (toResults' @exprs)
218instance
219 ( ToExprs a exprs1
220 , ToExprs b exprs2
221 , isTabular ~ 'True
222 , x ~ EitherTable exprs1 exprs2
223 ) => ExprsFor 'False isTabular (Either a b) x
224 where
225 fromResults =
226 bimap
227 (fromResults' @exprs1 . hunlabel unlabeler)
228 (fromResults' @exprs2 . hunlabel unlabeler) .
229 fromHEitherTable
230 toResults =
231 toHEitherTable .
232 bimap
233 (hlabel labeler . toResults' @exprs1)
234 (hlabel labeler . toResults' @exprs2)
237instance
238 ( ToExprs a exprs
239 , IsListTabular a ~ 'True
240 , x ~ ListTable exprs
241 ) => ExprsFor 'False 'True [a] x
242 where
243 fromResults = fmap (fromResults' @exprs) . fromHListTable
244 toResults = toHListTable . fmap (toResults' @exprs)
247instance
248 ( ToExprs a exprs
249 , IsMaybeTabular a ~ 'True
250 , x ~ MaybeTable exprs
251 ) => ExprsFor 'False 'True (Maybe a) x
252 where
253 fromResults =
254 fmap (fromResults' @exprs . hunlabel unlabeler) .
255 fromHMaybeTable
256 toResults =
257 toHMaybeTable .
258 fmap (hlabel labeler . toResults' @exprs)
261instance
262 ( ToExprs a exprs
263 , IsListTabular a ~ 'True
264 , x ~ NonEmptyTable exprs
265 ) => ExprsFor 'False 'True (NonEmpty a) x
266 where
267 fromResults = fmap (fromResults' @exprs) . fromHNonEmptyTable
268 toResults = toHNonEmptyTable . fmap (toResults' @exprs)
271instance
272 ( ToExprs a exprs1
273 , ToExprs b exprs2
274 , isTabular ~ 'True
275 , x ~ TheseTable exprs1 exprs2
276 ) => ExprsFor 'False isTabular (These a b) x
277 where
278 fromResults =
279 bimap
280 (fromResults' @exprs1 . hunlabel unlabeler)
281 (fromResults' @exprs2 . hunlabel unlabeler) .
282 fromHTheseTable
283 toResults =
284 toHTheseTable .
285 bimap
286 (hlabel labeler . toResults' @exprs1)
287 (hlabel labeler . toResults' @exprs2)
290instance
291 ( ToExprs a exprs1
292 , ToExprs b exprs2
293 , isTabular ~ 'True
294 , x ~ (exprs1, exprs2)
295 ) => ExprsFor 'False isTabular (a, b) x
296 where
297 fromResults (HPair a b) =
298 ( fromResults' @exprs1 $ hunlabel unlabeler a
299 , fromResults' @exprs2 $ hunlabel unlabeler b
300 )
301 toResults (a, b) = HPair
302 { hfst = hlabel labeler $ toResults' @exprs1 a
303 , hsnd = hlabel labeler $ toResults' @exprs2 b
304 }
307instance
308 ( ToExprs a exprs1
309 , ToExprs b exprs2
310 , ToExprs c exprs3
311 , isTabular ~ 'True
312 , x ~ (exprs1, exprs2, exprs3)
313 ) => ExprsFor 'False isTabular (a, b, c) x
314 where
315 fromResults (HTrio a b c) =
316 ( fromResults' @exprs1 $ hunlabel unlabeler a
317 , fromResults' @exprs2 $ hunlabel unlabeler b
318 , fromResults' @exprs3 $ hunlabel unlabeler c
319 )
320 toResults (a, b, c) = HTrio
321 { hfst = hlabel labeler $ toResults' @exprs1 a
322 , hsnd = hlabel labeler $ toResults' @exprs2 b
323 , htrd = hlabel labeler $ toResults' @exprs3 c
324 }
327instance
328 ( ToExprs a exprs1
329 , ToExprs b exprs2
330 , ToExprs c exprs3
331 , ToExprs d exprs4
332 , isTabular ~ 'True
333 , x ~ (exprs1, exprs2, exprs3, exprs4)
334 ) => ExprsFor 'False isTabular (a, b, c, d) x
335 where
336 fromResults (HQuartet a b c d) =
337 ( fromResults' @exprs1 $ hunlabel unlabeler a
338 , fromResults' @exprs2 $ hunlabel unlabeler b
339 , fromResults' @exprs3 $ hunlabel unlabeler c
340 , fromResults' @exprs4 $ hunlabel unlabeler d
341 )
342 toResults (a, b, c, d) = HQuartet
343 { hfst = hlabel labeler $ toResults' @exprs1 a
344 , hsnd = hlabel labeler $ toResults' @exprs2 b
345 , htrd = hlabel labeler $ toResults' @exprs3 c
346 , hfrt = hlabel labeler $ toResults' @exprs4 d
347 }
350instance
351 ( ToExprs a exprs1
352 , ToExprs b exprs2
353 , ToExprs c exprs3
354 , ToExprs d exprs4
355 , ToExprs e exprs5
356 , isTabular ~ 'True
357 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
358 ) => ExprsFor 'False isTabular (a, b, c, d, e) x
359 where
360 fromResults (HQuintet a b c d e) =
361 ( fromResults' @exprs1 $ hunlabel unlabeler a
362 , fromResults' @exprs2 $ hunlabel unlabeler b
363 , fromResults' @exprs3 $ hunlabel unlabeler c
364 , fromResults' @exprs4 $ hunlabel unlabeler d
365 , fromResults' @exprs5 $ hunlabel unlabeler e
366 )
367 toResults (a, b, c, d, e) = HQuintet
368 { hfst = hlabel labeler $ toResults' @exprs1 a
369 , hsnd = hlabel labeler $ toResults' @exprs2 b
370 , htrd = hlabel labeler $ toResults' @exprs3 c
371 , hfrt = hlabel labeler $ toResults' @exprs4 d
372 , hfft = hlabel labeler $ toResults' @exprs5 e
373 }
376instance
377 ( HTable t
378 , isTabular ~ 'True
379 , result ~ H Result
380 , x ~ t (H DB)
381 ) => ExprsFor 'False isTabular (t result) x
382 where
383 fromResults = id
384 toResults = id
387instance
388 ( Encodes (t Result) (t DB)
389 , isTabular ~ 'True
390 , result ~ Result
391 , x ~ t DB
392 ) => ExprsFor 'False isTabular (t result) x
393 where
394 fromResults = fromColumns
395 toResults = toColumns
398instance
399 ( KnownSpec spec
400 , isTabular ~ 'True
401 , x ~ DB spec
402 ) => ExprsFor 'False isTabular (Result spec) x
403 where
404 fromResults = fromColumns
405 toResults = toColumns
408type FromExprs :: Type -> Type
409type family FromExprs a where
410 FromExprs (Expr a) = a
411 FromExprs (DB spec) = Result spec
412 FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
413 FromExprs (ListTable a) = [FromExprs a]
414 FromExprs (MaybeTable a) = Maybe (FromExprs a)
415 FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
416 FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
417 FromExprs (a, b) = (FromExprs a, FromExprs b)
418 FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
419 FromExprs (a, b, c, d) =
420 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
421 FromExprs (a, b, c, d, e) =
422 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
423 FromExprs (t DB) = t Result
424 FromExprs (t (H DB)) = t (H Result)
427-- | @Serializable@ witnesses the one-to-one correspondence between the type
428-- @sql@, which contains SQL expressions, and the type @haskell@, which
429-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
430class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
431instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
432instance Serializable (Expr Opaque) Opaque
435lit :: forall exprs a. Serializable exprs a => a -> exprs
436lit = fromColumns . litTable . toResults' @exprs
439parse :: forall exprs a. Serializable exprs a => Hasql.Row a
440parse = fromResults' @exprs <$> parseTable
443litTable :: Encodes a b => a -> b
444litTable (toColumns -> as) = fromColumns $ htabulate $ \field ->
445 case hfield hspecs field of
446 SSpec {nullability, info} -> case hfield as field of
447 Result value -> DB (slitExpr nullability info value)
450parseTable :: Table Result a => Hasql.Row a
451parseTable = fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
452 WrapApplicative $ case hfield hspecs field of
453 SSpec {nullability, info} -> Result <$> sparseValue nullability info