git.iko.soy/rel8
on 93168af 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.Kind.Bool ( KnownBool, IsList )
33import Rel8.Opaque ( Opaque )
34import Rel8.Schema.Context ( DB(..), Result(..) )
35import Rel8.Schema.Context.Label ( labeler, unlabeler )
36import Rel8.Schema.Context.Result
37 ( fromHEitherTable, toHEitherTable
38 , fromHListTable, toHListTable
39 , fromHMaybeTable, toHMaybeTable
40 , fromHNonEmptyTable, toHNonEmptyTable
41 , fromHTheseTable, toHTheseTable
42 )
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.HTable.Context ( H )
51import Rel8.Schema.Nullability ( IsMaybe, Nullabilizes )
52import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
53import Rel8.Table ( Table, Columns, fromColumns, toColumns )
54import Rel8.Table.Either ( EitherTable )
55import Rel8.Table.List ( ListTable )
56import Rel8.Table.Maybe ( MaybeTable )
57import Rel8.Table.NonEmpty ( NonEmptyTable )
58import Rel8.Table.Recontextualize ( Encodes )
59import Rel8.Table.These ( TheseTable )
60import Rel8.Type ( DBType )
62-- semigroupoids
63import Data.Functor.Apply ( WrappedApplicative(..) )
65-- these
66import Data.These ( These )
69type IsPlainColumn :: Type -> Bool
70type family IsPlainColumn a where
71 IsPlainColumn (Either _ _) = 'False
72 IsPlainColumn [_] = 'False
73 IsPlainColumn (Maybe _) = 'False
74 IsPlainColumn (NonEmpty _) = 'False
75 IsPlainColumn (These _ _) = 'False
76 IsPlainColumn (_, _) = 'False
77 IsPlainColumn (_, _, _) = 'False
78 IsPlainColumn (_, _, _, _) = 'False
79 IsPlainColumn (_, _, _, _, _) = 'False
80 IsPlainColumn (_ (H Result)) = 'False
81 IsPlainColumn (_ Result) = 'False
82 IsPlainColumn (Result _) = 'False
83 IsPlainColumn _ = 'True
86type IsTabular :: Type -> Bool
87type family IsTabular a where
88 IsTabular (Either _ _) = 'True
89 IsTabular [a] = IsListTabular a
90 IsTabular (Maybe a) = IsMaybeTabular a
91 IsTabular (NonEmpty a) = IsListTabular a
92 IsTabular (These _ _) = 'True
93 IsTabular (_, _) = 'True
94 IsTabular (_, _, _) = 'True
95 IsTabular (_, _, _, _) = 'True
96 IsTabular (_, _, _, _, _) = 'True
97 IsTabular (_ (H Result)) = 'True
98 IsTabular (_ Result) = 'True
99 IsTabular (Result _) = 'True
100 IsTabular _ = 'False
103type IsTabular' :: Bool -> Type -> Bool
104type family IsTabular' isTabular exprs where
105 IsTabular' _ (Expr _) = 'False
106 IsTabular' 'False _ = 'False
107 IsTabular' _ _ = 'True
110type IsMaybeTabular :: Type -> Bool
111type family IsMaybeTabular a where
112 IsMaybeTabular (Maybe _) = 'True
113 IsMaybeTabular a = IsTabular a
116type IsListTabular :: Type -> Bool
117type family IsListTabular a where
118 IsListTabular (Maybe a) = IsMaybeTabular a
119 IsListTabular a = IsTabular a
122type ToExprs :: Type -> Type -> Constraint
123class ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs
124instance ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs
127fromResults' :: forall exprs a. ToExprs a exprs => Columns exprs (H Result) -> a
128fromResults' = fromResults @(IsPlainColumn a) @_ @_ @exprs
131toResults' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (H Result)
132toResults' = toResults @(IsPlainColumn a) @_ @_ @exprs
135type ExprsFor :: Bool -> Bool -> Type -> Type -> Constraint
136class (Table DB exprs, isTabular ~ IsTabular a) =>
137 ExprsFor isPlainColumn isTabular a exprs where
138 fromResults :: Columns exprs (H Result) -> a
139 toResults :: a -> Columns exprs (H Result)
142instance
143 ( DBType a
144 , IsList a ~ 'False
145 , IsMaybe a ~ 'False
146 , IsTabular a ~ 'False
147 , x ~ Expr a
148 )
149 => ExprsFor 'True 'False a x
150 where
151 fromResults (HType (Result a)) = a
152 toResults = HType . Result
155instance
156 ( DBType db
157 , Nullabilizes db a
158 , IsListTabular a ~ 'False
159 , x ~ [a]
160 ) => ExprsFor 'False 'False [a] (Expr x)
161 where
162 fromResults (HType (Result a)) = a
163 toResults = HType . Result
166instance
167 ( DBType a
168 , Nullabilizes a (Maybe a)
169 , KnownBool (IsList a)
170 , isTabular ~ 'False
171 , IsMaybeTabular a ~ 'False
172 , x ~ Maybe a
173 ) => ExprsFor 'False 'False (Maybe a) (Expr x)
174 where
175 fromResults (HType (Result a)) = a
176 toResults = HType . Result
179instance
180 ( DBType db
181 , Nullabilizes db a
182 , IsListTabular a ~ 'False
183 , x ~ NonEmpty a
184 ) => ExprsFor 'False 'False (NonEmpty a) (Expr x)
185 where
186 fromResults (HType (Result a)) = a
187 toResults = HType . Result
190instance
191 ( ToExprs a exprs
192 , IsListTabular a ~ 'False
193 ) => ExprsFor 'False 'False [a] (ListTable exprs)
194 where
195 fromResults = fmap (fromResults' @exprs) . fromHListTable
196 toResults = toHListTable . fmap (toResults' @exprs)
199instance
200 ( ToExprs a exprs
201 , IsMaybeTabular a ~ 'False
202 ) => ExprsFor 'False 'False (Maybe a) (MaybeTable exprs)
203 where
204 fromResults =
205 fmap (fromResults' @exprs . hunlabel unlabeler) .
206 fromHMaybeTable
207 toResults =
208 toHMaybeTable .
209 fmap (hlabel labeler . toResults' @exprs)
212instance
213 ( ToExprs a exprs
214 , IsListTabular a ~ 'False
215 ) => ExprsFor 'False 'False (NonEmpty a) (NonEmptyTable exprs)
216 where
217 fromResults = fmap (fromResults' @exprs) . fromHNonEmptyTable
218 toResults = toHNonEmptyTable . fmap (toResults' @exprs)
221instance
222 ( ToExprs a exprs1
223 , ToExprs b exprs2
224 , isTabular ~ 'True
225 , x ~ EitherTable exprs1 exprs2
226 ) => ExprsFor 'False isTabular (Either a b) x
227 where
228 fromResults =
229 bimap
230 (fromResults' @exprs1 . hunlabel unlabeler)
231 (fromResults' @exprs2 . hunlabel unlabeler) .
232 fromHEitherTable
233 toResults =
234 toHEitherTable .
235 bimap
236 (hlabel labeler . toResults' @exprs1)
237 (hlabel labeler . toResults' @exprs2)
240instance
241 ( ToExprs a exprs
242 , IsListTabular a ~ 'True
243 , x ~ ListTable exprs
244 ) => ExprsFor 'False 'True [a] x
245 where
246 fromResults = fmap (fromResults' @exprs) . fromHListTable
247 toResults = toHListTable . fmap (toResults' @exprs)
250instance
251 ( ToExprs a exprs
252 , IsMaybeTabular a ~ 'True
253 , x ~ MaybeTable exprs
254 ) => ExprsFor 'False 'True (Maybe a) x
255 where
256 fromResults =
257 fmap (fromResults' @exprs . hunlabel unlabeler) .
258 fromHMaybeTable
259 toResults =
260 toHMaybeTable .
261 fmap (hlabel labeler . toResults' @exprs)
264instance
265 ( ToExprs a exprs
266 , IsListTabular a ~ 'True
267 , x ~ NonEmptyTable exprs
268 ) => ExprsFor 'False 'True (NonEmpty a) x
269 where
270 fromResults = fmap (fromResults' @exprs) . fromHNonEmptyTable
271 toResults = toHNonEmptyTable . fmap (toResults' @exprs)
274instance
275 ( ToExprs a exprs1
276 , ToExprs b exprs2
277 , isTabular ~ 'True
278 , x ~ TheseTable exprs1 exprs2
279 ) => ExprsFor 'False isTabular (These a b) x
280 where
281 fromResults =
282 bimap
283 (fromResults' @exprs1 . hunlabel unlabeler)
284 (fromResults' @exprs2 . hunlabel unlabeler) .
285 fromHTheseTable
286 toResults =
287 toHTheseTable .
288 bimap
289 (hlabel labeler . toResults' @exprs1)
290 (hlabel labeler . toResults' @exprs2)
293instance
294 ( ToExprs a exprs1
295 , ToExprs b exprs2
296 , isTabular ~ 'True
297 , x ~ (exprs1, exprs2)
298 ) => ExprsFor 'False isTabular (a, b) x
299 where
300 fromResults (HPair a b) =
301 ( fromResults' @exprs1 $ hunlabel unlabeler a
302 , fromResults' @exprs2 $ hunlabel unlabeler b
303 )
304 toResults (a, b) = HPair
305 { hfst = hlabel labeler $ toResults' @exprs1 a
306 , hsnd = hlabel labeler $ toResults' @exprs2 b
307 }
310instance
311 ( ToExprs a exprs1
312 , ToExprs b exprs2
313 , ToExprs c exprs3
314 , isTabular ~ 'True
315 , x ~ (exprs1, exprs2, exprs3)
316 ) => ExprsFor 'False isTabular (a, b, c) x
317 where
318 fromResults (HTrio a b c) =
319 ( fromResults' @exprs1 $ hunlabel unlabeler a
320 , fromResults' @exprs2 $ hunlabel unlabeler b
321 , fromResults' @exprs3 $ hunlabel unlabeler c
322 )
323 toResults (a, b, c) = HTrio
324 { hfst = hlabel labeler $ toResults' @exprs1 a
325 , hsnd = hlabel labeler $ toResults' @exprs2 b
326 , htrd = hlabel labeler $ toResults' @exprs3 c
327 }
330instance
331 ( ToExprs a exprs1
332 , ToExprs b exprs2
333 , ToExprs c exprs3
334 , ToExprs d exprs4
335 , isTabular ~ 'True
336 , x ~ (exprs1, exprs2, exprs3, exprs4)
337 ) => ExprsFor 'False isTabular (a, b, c, d) x
338 where
339 fromResults (HQuartet a b c d) =
340 ( fromResults' @exprs1 $ hunlabel unlabeler a
341 , fromResults' @exprs2 $ hunlabel unlabeler b
342 , fromResults' @exprs3 $ hunlabel unlabeler c
343 , fromResults' @exprs4 $ hunlabel unlabeler d
344 )
345 toResults (a, b, c, d) = HQuartet
346 { hfst = hlabel labeler $ toResults' @exprs1 a
347 , hsnd = hlabel labeler $ toResults' @exprs2 b
348 , htrd = hlabel labeler $ toResults' @exprs3 c
349 , hfrt = hlabel labeler $ toResults' @exprs4 d
350 }
353instance
354 ( ToExprs a exprs1
355 , ToExprs b exprs2
356 , ToExprs c exprs3
357 , ToExprs d exprs4
358 , ToExprs e exprs5
359 , isTabular ~ 'True
360 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
361 ) => ExprsFor 'False isTabular (a, b, c, d, e) x
362 where
363 fromResults (HQuintet a b c d e) =
364 ( fromResults' @exprs1 $ hunlabel unlabeler a
365 , fromResults' @exprs2 $ hunlabel unlabeler b
366 , fromResults' @exprs3 $ hunlabel unlabeler c
367 , fromResults' @exprs4 $ hunlabel unlabeler d
368 , fromResults' @exprs5 $ hunlabel unlabeler e
369 )
370 toResults (a, b, c, d, e) = HQuintet
371 { hfst = hlabel labeler $ toResults' @exprs1 a
372 , hsnd = hlabel labeler $ toResults' @exprs2 b
373 , htrd = hlabel labeler $ toResults' @exprs3 c
374 , hfrt = hlabel labeler $ toResults' @exprs4 d
375 , hfft = hlabel labeler $ toResults' @exprs5 e
376 }
379instance
380 ( HTable t
381 , isTabular ~ 'True
382 , result ~ H Result
383 , x ~ t (H DB)
384 ) => ExprsFor 'False isTabular (t result) x
385 where
386 fromResults = id
387 toResults = id
390instance
391 ( Encodes (t Result) (t DB)
392 , isTabular ~ 'True
393 , result ~ Result
394 , x ~ t DB
395 ) => ExprsFor 'False isTabular (t result) x
396 where
397 fromResults = fromColumns
398 toResults = toColumns
401instance
402 ( KnownSpec spec
403 , isTabular ~ 'True
404 , x ~ DB spec
405 ) => ExprsFor 'False isTabular (Result spec) x
406 where
407 fromResults = fromColumns
408 toResults = toColumns
411type FromExprs :: Type -> Type
412type family FromExprs a where
413 FromExprs (Expr a) = a
414 FromExprs (DB spec) = Result spec
415 FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
416 FromExprs (ListTable a) = [FromExprs a]
417 FromExprs (MaybeTable a) = Maybe (FromExprs a)
418 FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
419 FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
420 FromExprs (a, b) = (FromExprs a, FromExprs b)
421 FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
422 FromExprs (a, b, c, d) =
423 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
424 FromExprs (a, b, c, d, e) =
425 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
426 FromExprs (t DB) = t Result
427 FromExprs (t (H DB)) = t (H Result)
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