git.iko.soy/rel8
on 6e42c1e help sign in
rel8/src/Rel8/Table/Serialize.hs
352 lines 10 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 ( Generic, Rep, from, to )
29import Prelude
31-- hasql
32import qualified Hasql.Decoders as Hasql
34-- rel8
35import Rel8.Expr ( Expr, Col(..) )
36import Rel8.Expr.Serialize ( slitExpr, sparseValue )
37import Rel8.FCF ( Eval, Exp )
38import Rel8.Generic.Record ( Record(..) )
39import Rel8.Generic.Table
40 ( GGToExprs, GGColumns, ggfromResult, ggtoResult
41 , GAlgebra
42 )
43import Rel8.Kind.Algebra ( KnownAlgebra )
44import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
45import Rel8.Schema.HTable.Type ( HType(..) )
46import Rel8.Schema.Null ( NotNull, Sql )
47import Rel8.Schema.Result ( Col( Result ), Result )
48import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
49import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )
50import Rel8.Table.Either ( EitherTable )
51import Rel8.Table.List ( ListTable )
52import Rel8.Table.Maybe ( MaybeTable )
53import Rel8.Table.NonEmpty ( NonEmptyTable )
54import Rel8.Table.Recontextualize ( Recontextualize )
55import Rel8.Table.These ( TheseTable )
56import Rel8.Type ( DBType )
58-- semigroupoids
59import Data.Functor.Apply ( WrappedApplicative(..) )
61-- these
62import Data.These ( These )
65type ToExprs :: Type -> Type -> Constraint
66class Table Expr exprs => ToExprs exprs a where
67 fromResult :: Columns exprs (Col Result) -> a
68 toResult :: a -> Columns exprs (Col Result)
70 default fromResult ::
71 ( Generic (Record a)
72 , KnownAlgebra (GAlgebra (Rep (Record exprs)))
73 , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
74 , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
75 )
76 => Columns exprs (Col Result) -> a
77 fromResult =
78 unrecord .
79 to .
80 ggfromResult
81 @(GAlgebra (Rep (Record exprs)))
82 @TToExprs
83 @TColumns
84 @(Rep (Record exprs))
85 (\(_ :: proxy expr) -> fromResult @expr)
87 default toResult ::
88 ( Generic (Record a)
89 , KnownAlgebra (GAlgebra (Rep (Record exprs)))
90 , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
91 , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
92 )
93 => a -> Columns exprs (Col Result)
94 toResult =
95 ggtoResult
96 @(GAlgebra (Rep (Record exprs)))
97 @TToExprs
98 @TColumns
99 @(Rep (Record exprs))
100 (\(_ :: proxy expr) -> toResult @expr) .
101 from .
102 Record
105data TToExprs :: Type -> Type -> Exp Constraint
106type instance Eval (TToExprs exprs a) = ToExprs exprs a
109instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
110 fromResult (HType (Result a)) = a
111 toResult = HType . Result
114instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
115 fromResult (HType (Result a)) = a
116 toResult = HType . Result
119instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
120 where
121 fromResult (HType (Result a)) = a
122 toResult = HType . Result
125instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
126 where
127 fromResult (HType (Result a)) = a
128 toResult = HType . Result
131instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
132 ToExprs x (Either a b)
133 where
134 fromResult =
135 bimap (fromResult @exprs1) (fromResult @exprs2) .
136 fromColumns
137 toResult =
138 toColumns .
139 bimap (toResult @exprs1) (toResult @exprs2)
142instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where
143 fromResult = fmap (fromResult @exprs) . fromColumns
144 toResult = toColumns . fmap (toResult @exprs)
147instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
148 fromResult = fmap (fromResult @exprs) . fromColumns
149 toResult = toColumns . fmap (toResult @exprs)
152instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)
153 where
154 fromResult = fmap (fromResult @exprs) . fromColumns
155 toResult = toColumns . fmap (toResult @exprs)
158instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
159 ToExprs x (These a b)
160 where
161 fromResult =
162 bimap (fromResult @exprs1) (fromResult @exprs2) .
163 fromColumns
164 toResult =
165 toColumns .
166 bimap (toResult @exprs1) (toResult @exprs2)
169instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
170 ToExprs x (a, b)
173instance
174 ( ToExprs exprs1 a
175 , ToExprs exprs2 b
176 , ToExprs exprs3 c
177 , x ~ (exprs1, exprs2, exprs3)
178 )
179 => ToExprs x (a, b, c)
182instance
183 ( ToExprs exprs1 a
184 , ToExprs exprs2 b
185 , ToExprs exprs3 c
186 , ToExprs exprs4 d
187 , x ~ (exprs1, exprs2, exprs3, exprs4)
188 )
189 => ToExprs x (a, b, c, d)
192instance
193 ( ToExprs exprs1 a
194 , ToExprs exprs2 b
195 , ToExprs exprs3 c
196 , ToExprs exprs4 d
197 , ToExprs exprs5 e
198 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
199 )
200 => ToExprs x (a, b, c, d, e)
203instance
204 ( ToExprs exprs1 a
205 , ToExprs exprs2 b
206 , ToExprs exprs3 c
207 , ToExprs exprs4 d
208 , ToExprs exprs5 e
209 , ToExprs exprs6 f
210 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
211 )
212 => ToExprs x (a, b, c, d, e, f)
215instance
216 ( ToExprs exprs1 a
217 , ToExprs exprs2 b
218 , ToExprs exprs3 c
219 , ToExprs exprs4 d
220 , ToExprs exprs5 e
221 , ToExprs exprs6 f
222 , ToExprs exprs7 g
223 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
224 )
225 => ToExprs x (a, b, c, d, e, f, g)
228instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
229 ToExprs x (t result)
230 where
231 fromResult = id
232 toResult = id
235instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
236 ToExprs x (t result)
237 where
238 fromResult = fromColumns
239 toResult = toColumns
242instance (KnownSpec spec, x ~ Col Expr spec) =>
243 ToExprs x (Col Result spec)
244 where
245 fromResult = fromColumns
246 toResult = toColumns
249type FromExprs :: Type -> Type
250type family FromExprs a
251type instance FromExprs (Expr a) = a
252type instance FromExprs (Col Expr spec) = Col Result spec
253type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
254type instance FromExprs (ListTable a) = [FromExprs a]
255type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
256type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
257type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
258type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
259type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
260type instance FromExprs (a, b, c, d) =
261 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
262type instance FromExprs (a, b, c, d, e) =
263 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
264type instance FromExprs (a, b, c, d, e, f) =
265 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
266 , FromExprs f
267 )
268type instance FromExprs (a, b, c, d, e, f, g) =
269 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
270 , FromExprs f, FromExprs g
271 )
272type instance FromExprs (t Expr) = t Result
273type instance FromExprs (t (Col Expr)) = t (Col Result)
276-- | @Serializable@ witnesses the one-to-one correspondence between the type
277-- @sql@, which contains SQL expressions, and the type @haskell@, which
278-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
279type Serializable :: Type -> Type -> Constraint
280class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
281instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
282instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
285-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
286-- capable of lifting single @Expr@s to full tables.
287lit :: forall exprs a. Serializable exprs a => a -> exprs
288lit = fromColumns . litHTable . toResult @exprs
291parse :: forall exprs a. Serializable exprs a => Hasql.Row a
292parse = fromResult @exprs <$> parseHTable
295type Encodes :: Type -> Type -> Constraint
296class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a
299instance KnownSpec spec => Encodes (Col Result spec) (Col Expr spec)
302instance Serializable (t Result) (t Expr) => Encodes (t Expr) (t Result)
305instance HTable t => Encodes (t (Col Result)) (t (Col Expr))
308instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)
311instance Encodes a x => Encodes [a] (ListTable x)
314instance Encodes a x => Encodes (Maybe a) (MaybeTable x)
317instance Encodes a x => Encodes (NonEmpty a) (NonEmptyTable x)
320instance (Encodes a x, Encodes b y) => Encodes (These a b) (TheseTable x y)
323instance (Encodes a x, Encodes b y) => Encodes (a, b) (x, y)
326instance (Encodes a x, Encodes b y, Encodes c z) =>
327 Encodes (a, b, c) (x, y, z)
330instance (Encodes a w, Encodes b x, Encodes c y, Encodes d z) =>
331 Encodes (a, b, c, d) (w, x, y, z)
334instance (Encodes a v, Encodes b w, Encodes c x, Encodes d y, Encodes e z) =>
335 Encodes (a, b, c, d, e) (v, w, x, y, z)
338litTable :: Encodes a exprs => a -> exprs
339litTable = lit
342litHTable :: HTable t => t (Col Result) -> t (Col Expr)
343litHTable as = htabulate $ \field ->
344 case hfield hspecs field of
345 SSpec {nullity, info} -> case hfield as field of
346 Result value -> DB (slitExpr nullity info value)
349parseHTable :: HTable t => Hasql.Row (t (Col Result))
350parseHTable = unwrapApplicative $ htabulateA $ \field ->
351 WrapApplicative $ case hfield hspecs field of
352 SSpec {nullity, info} -> Result <$> sparseValue nullity info