git.iko.soy/rel8
on b2e2fc9 help sign in
rel8/src/Rel8/Table/Serialize.hs
370 lines 11 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language DefaultSignatures #-}
4{-# language DisambiguateRecordFields #-}
5{-# language FlexibleContexts #-}
6{-# language FlexibleInstances #-}
7{-# language FunctionalDependencies #-}
8{-# language NamedFieldPuns #-}
9{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language TypeOperators #-}
14{-# language UndecidableInstances #-}
16module Rel8.Table.Serialize
17 ( Serializable, lit, parse
18 , Encodes, litTable
19 , ToExprs(..)
20 , FromExprs
21 )
22where
24-- base
25import Data.Bifunctor ( bimap )
26import Data.Kind ( Constraint, Type )
27import Data.List.NonEmpty ( NonEmpty )
28import GHC.Generics
29 ( Generic, Rep, from, to
30 , (:*:)( (:*:) ), K1( K1 ), M1( M1 ), Meta( MetaSel ), D, C, S
31 )
32import GHC.TypeLits ( KnownSymbol )
33import Prelude
35-- hasql
36import qualified Hasql.Decoders as Hasql
38-- rel8
39import Rel8.Expr ( Expr, Col(..) )
40import Rel8.Expr.Serialize ( slitExpr, sparseValue )
41import Rel8.Generic.Record ( Record(..) )
42import Rel8.Generic.Table ( GColumns )
43import Rel8.Schema.Context ( Col(..) )
44import Rel8.Schema.Context.Label ( labeler, unlabeler )
45import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
46import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
47import Rel8.Schema.HTable.Product ( HProduct(..) )
48import Rel8.Schema.HTable.Type ( HType(..) )
49import Rel8.Schema.Null ( NotNull, Sql )
50import Rel8.Schema.Result ( Result )
51import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
52import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )
53import Rel8.Table.Either ( EitherTable )
54import Rel8.Table.List ( ListTable )
55import Rel8.Table.Maybe ( MaybeTable )
56import Rel8.Table.NonEmpty ( NonEmptyTable )
57import Rel8.Table.Recontextualize ( Recontextualize )
58import Rel8.Table.These ( TheseTable )
59import Rel8.Type ( DBType )
61-- semigroupoids
62import Data.Functor.Apply ( WrappedApplicative(..) )
64-- these
65import Data.These ( These )
68type ToExprs :: Type -> Type -> Constraint
69class Table Expr exprs => ToExprs exprs a where
70 fromResult :: Columns exprs (Col Result) -> a
71 toResult :: a -> Columns exprs (Col Result)
73 default fromResult ::
74 ( Generic (Record a)
75 , GToExprs (Rep (Record exprs)) (Rep (Record a))
76 , Columns exprs ~ GColumns TColumns (Rep (Record exprs))
77 )
78 => Columns exprs (Col Result) -> a
79 fromResult = unrecord . to . gfromResult @(Rep (Record exprs))
81 default toResult ::
82 ( Generic (Record a)
83 , GToExprs (Rep (Record exprs)) (Rep (Record a))
84 , Columns exprs ~ GColumns TColumns (Rep (Record exprs))
85 )
86 => a -> Columns exprs (Col Result)
87 toResult = gtoResult @(Rep (Record exprs)) . from . Record
90type GToExprs :: (Type -> Type) -> (Type -> Type) -> Constraint
91class GToExprs exprs rep where
92 gfromResult :: GColumns TColumns exprs (Col Result) -> rep x
93 gtoResult :: rep x -> GColumns TColumns exprs (Col Result)
96instance GToExprs exprs rep => GToExprs (M1 D c exprs) (M1 D c rep) where
97 gfromResult = M1 . gfromResult @exprs
98 gtoResult (M1 a) = gtoResult @exprs a
101instance GToExprs exprs rep => GToExprs (M1 C c exprs) (M1 C c rep) where
102 gfromResult = M1 . gfromResult @exprs
103 gtoResult (M1 a) = gtoResult @exprs a
106instance (GToExprs exprs1 rep1, GToExprs exprs2 rep2) =>
107 GToExprs (exprs1 :*: exprs2) (rep1 :*: rep2)
108 where
109 gfromResult (HProduct a b) = gfromResult @exprs1 a :*: gfromResult @exprs2 b
110 gtoResult (a :*: b) = HProduct (gtoResult @exprs1 a) (gtoResult @exprs2 b)
113instance
114 ( ToExprs exprs a
115 , KnownSymbol label
116 , GColumns TColumns (M1 S meta k1) ~ HLabel label (Columns exprs)
117 , meta ~ 'MetaSel ('Just label) _su _ss _ds
118 , k1 ~ K1 i exprs
119 , k1' ~ K1 i a
120 )
121 => GToExprs (M1 S meta k1) (M1 S meta k1')
122 where
123 gfromResult = M1 . K1 . fromResult @exprs . hunlabel unlabeler
124 gtoResult (M1 (K1 a)) = hlabel labeler (toResult @exprs a)
127instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
128 fromResult (HType (Result a)) = a
129 toResult = HType . Result
132instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
133 fromResult (HType (Result a)) = a
134 toResult = HType . Result
137instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
138 where
139 fromResult (HType (Result a)) = a
140 toResult = HType . Result
143instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
144 where
145 fromResult (HType (Result a)) = a
146 toResult = HType . Result
149instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
150 ToExprs x (Either a b)
151 where
152 fromResult =
153 bimap (fromResult @exprs1) (fromResult @exprs2) .
154 fromColumns
155 toResult =
156 toColumns .
157 bimap (toResult @exprs1) (toResult @exprs2)
160instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where
161 fromResult = fmap (fromResult @exprs) . fromColumns
162 toResult = toColumns . fmap (toResult @exprs)
165instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
166 fromResult = fmap (fromResult @exprs) . fromColumns
167 toResult = toColumns . fmap (toResult @exprs)
170instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)
171 where
172 fromResult = fmap (fromResult @exprs) . fromColumns
173 toResult = toColumns . fmap (toResult @exprs)
176instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
177 ToExprs x (These a b)
178 where
179 fromResult =
180 bimap (fromResult @exprs1) (fromResult @exprs2) .
181 fromColumns
182 toResult =
183 toColumns .
184 bimap (toResult @exprs1) (toResult @exprs2)
187instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
188 ToExprs x (a, b)
191instance
192 ( ToExprs exprs1 a
193 , ToExprs exprs2 b
194 , ToExprs exprs3 c
195 , x ~ (exprs1, exprs2, exprs3)
196 )
197 => ToExprs x (a, b, c)
200instance
201 ( ToExprs exprs1 a
202 , ToExprs exprs2 b
203 , ToExprs exprs3 c
204 , ToExprs exprs4 d
205 , x ~ (exprs1, exprs2, exprs3, exprs4)
206 )
207 => ToExprs x (a, b, c, d)
210instance
211 ( ToExprs exprs1 a
212 , ToExprs exprs2 b
213 , ToExprs exprs3 c
214 , ToExprs exprs4 d
215 , ToExprs exprs5 e
216 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
217 )
218 => ToExprs x (a, b, c, d, e)
221instance
222 ( ToExprs exprs1 a
223 , ToExprs exprs2 b
224 , ToExprs exprs3 c
225 , ToExprs exprs4 d
226 , ToExprs exprs5 e
227 , ToExprs exprs6 f
228 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
229 )
230 => ToExprs x (a, b, c, d, e, f)
233instance
234 ( ToExprs exprs1 a
235 , ToExprs exprs2 b
236 , ToExprs exprs3 c
237 , ToExprs exprs4 d
238 , ToExprs exprs5 e
239 , ToExprs exprs6 f
240 , ToExprs exprs7 g
241 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
242 )
243 => ToExprs x (a, b, c, d, e, f, g)
246instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
247 ToExprs x (t result)
248 where
249 fromResult = id
250 toResult = id
253instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
254 ToExprs x (t result)
255 where
256 fromResult = fromColumns
257 toResult = toColumns
260instance (KnownSpec spec, x ~ Col Expr spec) =>
261 ToExprs x (Col Result spec)
262 where
263 fromResult = fromColumns
264 toResult = toColumns
267type FromExprs :: Type -> Type
268type family FromExprs a
269type instance FromExprs (Expr a) = a
270type instance FromExprs (Col Expr spec) = Col Result spec
271type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
272type instance FromExprs (ListTable a) = [FromExprs a]
273type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
274type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
275type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
276type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
277type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
278type instance FromExprs (a, b, c, d) =
279 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
280type instance FromExprs (a, b, c, d, e) =
281 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
282type instance FromExprs (a, b, c, d, e, f) =
283 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
284 , FromExprs f
285 )
286type instance FromExprs (a, b, c, d, e, f, g) =
287 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
288 , FromExprs f, FromExprs g
289 )
290type instance FromExprs (t Expr) = t Result
291type instance FromExprs (t (Col Expr)) = t (Col Result)
294-- | @Serializable@ witnesses the one-to-one correspondence between the type
295-- @sql@, which contains SQL expressions, and the type @haskell@, which
296-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
297type Serializable :: Type -> Type -> Constraint
298class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
299instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
300instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
303-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
304-- capable of lifting single @Expr@s to full tables.
305lit :: forall exprs a. Serializable exprs a => a -> exprs
306lit = fromColumns . litHTable . toResult @exprs
309parse :: forall exprs a. Serializable exprs a => Hasql.Row a
310parse = fromResult @exprs <$> parseHTable
313type Encodes :: Type -> Type -> Constraint
314class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a
317instance KnownSpec spec => Encodes (Col Result spec) (Col Expr spec)
320instance Serializable (t Result) (t Expr) => Encodes (t Expr) (t Result)
323instance HTable t => Encodes (t (Col Result)) (t (Col Expr))
326instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)
329instance Encodes a x => Encodes [a] (ListTable x)
332instance Encodes a x => Encodes (Maybe a) (MaybeTable x)
335instance Encodes a x => Encodes (NonEmpty a) (NonEmptyTable x)
338instance (Encodes a x, Encodes b y) => Encodes (These a b) (TheseTable x y)
341instance (Encodes a x, Encodes b y) => Encodes (a, b) (x, y)
344instance (Encodes a x, Encodes b y, Encodes c z) =>
345 Encodes (a, b, c) (x, y, z)
348instance (Encodes a w, Encodes b x, Encodes c y, Encodes d z) =>
349 Encodes (a, b, c, d) (w, x, y, z)
352instance (Encodes a v, Encodes b w, Encodes c x, Encodes d y, Encodes e z) =>
353 Encodes (a, b, c, d, e) (v, w, x, y, z)
356litTable :: Encodes a exprs => a -> exprs
357litTable = lit
360litHTable :: HTable t => t (Col Result) -> t (Col Expr)
361litHTable as = htabulate $ \field ->
362 case hfield hspecs field of
363 SSpec {nullity, info} -> case hfield as field of
364 Result value -> DB (slitExpr nullity info value)
367parseHTable :: HTable t => Hasql.Row (t (Col Result))
368parseHTable = unwrapApplicative $ htabulateA $ \field ->
369 WrapApplicative $ case hfield hspecs field of
370 SSpec {nullity, info} -> Result <$> sparseValue nullity info