git.iko.soy/rel8
on 66dc44d help sign in
rel8/src/Rel8/Table/Serialize.hs
353 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.Context ( Col(..) )
45import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
46import Rel8.Schema.HTable.Type ( HType(..) )
47import Rel8.Schema.Null ( NotNull, Sql )
48import Rel8.Schema.Result ( Result )
49import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
50import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )
51import Rel8.Table.Either ( EitherTable )
52import Rel8.Table.List ( ListTable )
53import Rel8.Table.Maybe ( MaybeTable )
54import Rel8.Table.NonEmpty ( NonEmptyTable )
55import Rel8.Table.Recontextualize ( Recontextualize )
56import Rel8.Table.These ( TheseTable )
57import Rel8.Type ( DBType )
59-- semigroupoids
60import Data.Functor.Apply ( WrappedApplicative(..) )
62-- these
63import Data.These ( These )
66type ToExprs :: Type -> Type -> Constraint
67class Table Expr exprs => ToExprs exprs a where
68 fromResult :: Columns exprs (Col Result) -> a
69 toResult :: a -> Columns exprs (Col Result)
71 default fromResult ::
72 ( Generic (Record a)
73 , KnownAlgebra (GAlgebra (Rep (Record exprs)))
74 , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
75 , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
76 )
77 => Columns exprs (Col Result) -> a
78 fromResult =
79 unrecord .
80 to .
81 ggfromResult
82 @(GAlgebra (Rep (Record exprs)))
83 @TToExprs
84 @TColumns
85 @(Rep (Record exprs))
86 (\(_ :: proxy expr) -> fromResult @expr)
88 default toResult ::
89 ( Generic (Record a)
90 , KnownAlgebra (GAlgebra (Rep (Record exprs)))
91 , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
92 , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
93 )
94 => a -> Columns exprs (Col Result)
95 toResult =
96 ggtoResult
97 @(GAlgebra (Rep (Record exprs)))
98 @TToExprs
99 @TColumns
100 @(Rep (Record exprs))
101 (\(_ :: proxy expr) -> toResult @expr) .
102 from .
103 Record
106data TToExprs :: Type -> Type -> Exp Constraint
107type instance Eval (TToExprs exprs a) = ToExprs exprs a
110instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
111 fromResult (HType (Result a)) = a
112 toResult = HType . Result
115instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
116 fromResult (HType (Result a)) = a
117 toResult = HType . Result
120instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
121 where
122 fromResult (HType (Result a)) = a
123 toResult = HType . Result
126instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
127 where
128 fromResult (HType (Result a)) = a
129 toResult = HType . Result
132instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
133 ToExprs x (Either a b)
134 where
135 fromResult =
136 bimap (fromResult @exprs1) (fromResult @exprs2) .
137 fromColumns
138 toResult =
139 toColumns .
140 bimap (toResult @exprs1) (toResult @exprs2)
143instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where
144 fromResult = fmap (fromResult @exprs) . fromColumns
145 toResult = toColumns . fmap (toResult @exprs)
148instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
149 fromResult = fmap (fromResult @exprs) . fromColumns
150 toResult = toColumns . fmap (toResult @exprs)
153instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)
154 where
155 fromResult = fmap (fromResult @exprs) . fromColumns
156 toResult = toColumns . fmap (toResult @exprs)
159instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
160 ToExprs x (These a b)
161 where
162 fromResult =
163 bimap (fromResult @exprs1) (fromResult @exprs2) .
164 fromColumns
165 toResult =
166 toColumns .
167 bimap (toResult @exprs1) (toResult @exprs2)
170instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
171 ToExprs x (a, b)
174instance
175 ( ToExprs exprs1 a
176 , ToExprs exprs2 b
177 , ToExprs exprs3 c
178 , x ~ (exprs1, exprs2, exprs3)
179 )
180 => ToExprs x (a, b, c)
183instance
184 ( ToExprs exprs1 a
185 , ToExprs exprs2 b
186 , ToExprs exprs3 c
187 , ToExprs exprs4 d
188 , x ~ (exprs1, exprs2, exprs3, exprs4)
189 )
190 => ToExprs x (a, b, c, d)
193instance
194 ( ToExprs exprs1 a
195 , ToExprs exprs2 b
196 , ToExprs exprs3 c
197 , ToExprs exprs4 d
198 , ToExprs exprs5 e
199 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
200 )
201 => ToExprs x (a, b, c, d, e)
204instance
205 ( ToExprs exprs1 a
206 , ToExprs exprs2 b
207 , ToExprs exprs3 c
208 , ToExprs exprs4 d
209 , ToExprs exprs5 e
210 , ToExprs exprs6 f
211 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
212 )
213 => ToExprs x (a, b, c, d, e, f)
216instance
217 ( ToExprs exprs1 a
218 , ToExprs exprs2 b
219 , ToExprs exprs3 c
220 , ToExprs exprs4 d
221 , ToExprs exprs5 e
222 , ToExprs exprs6 f
223 , ToExprs exprs7 g
224 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
225 )
226 => ToExprs x (a, b, c, d, e, f, g)
229instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
230 ToExprs x (t result)
231 where
232 fromResult = id
233 toResult = id
236instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
237 ToExprs x (t result)
238 where
239 fromResult = fromColumns
240 toResult = toColumns
243instance (KnownSpec spec, x ~ Col Expr spec) =>
244 ToExprs x (Col Result spec)
245 where
246 fromResult = fromColumns
247 toResult = toColumns
250type FromExprs :: Type -> Type
251type family FromExprs a
252type instance FromExprs (Expr a) = a
253type instance FromExprs (Col Expr spec) = Col Result spec
254type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
255type instance FromExprs (ListTable a) = [FromExprs a]
256type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
257type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
258type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
259type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
260type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
261type instance FromExprs (a, b, c, d) =
262 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
263type instance FromExprs (a, b, c, d, e) =
264 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
265type instance FromExprs (a, b, c, d, e, f) =
266 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
267 , FromExprs f
268 )
269type instance FromExprs (a, b, c, d, e, f, g) =
270 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
271 , FromExprs f, FromExprs g
272 )
273type instance FromExprs (t Expr) = t Result
274type instance FromExprs (t (Col Expr)) = t (Col Result)
277-- | @Serializable@ witnesses the one-to-one correspondence between the type
278-- @sql@, which contains SQL expressions, and the type @haskell@, which
279-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
280type Serializable :: Type -> Type -> Constraint
281class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
282instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
283instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
286-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
287-- capable of lifting single @Expr@s to full tables.
288lit :: forall exprs a. Serializable exprs a => a -> exprs
289lit = fromColumns . litHTable . toResult @exprs
292parse :: forall exprs a. Serializable exprs a => Hasql.Row a
293parse = fromResult @exprs <$> parseHTable
296type Encodes :: Type -> Type -> Constraint
297class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a
300instance KnownSpec spec => Encodes (Col Result spec) (Col Expr spec)
303instance Serializable (t Result) (t Expr) => Encodes (t Expr) (t Result)
306instance HTable t => Encodes (t (Col Result)) (t (Col Expr))
309instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)
312instance Encodes a x => Encodes [a] (ListTable x)
315instance Encodes a x => Encodes (Maybe a) (MaybeTable x)
318instance Encodes a x => Encodes (NonEmpty a) (NonEmptyTable x)
321instance (Encodes a x, Encodes b y) => Encodes (These a b) (TheseTable x y)
324instance (Encodes a x, Encodes b y) => Encodes (a, b) (x, y)
327instance (Encodes a x, Encodes b y, Encodes c z) =>
328 Encodes (a, b, c) (x, y, z)
331instance (Encodes a w, Encodes b x, Encodes c y, Encodes d z) =>
332 Encodes (a, b, c, d) (w, x, y, z)
335instance (Encodes a v, Encodes b w, Encodes c x, Encodes d y, Encodes e z) =>
336 Encodes (a, b, c, d, e) (v, w, x, y, z)
339litTable :: Encodes a exprs => a -> exprs
340litTable = lit
343litHTable :: HTable t => t (Col Result) -> t (Col Expr)
344litHTable as = htabulate $ \field ->
345 case hfield hspecs field of
346 SSpec {nullity, info} -> case hfield as field of
347 Result value -> DB (slitExpr nullity info value)
350parseHTable :: HTable t => Hasql.Row (t (Col Result))
351parseHTable = unwrapApplicative $ htabulateA $ \field ->
352 WrapApplicative $ case hfield hspecs field of
353 SSpec {nullity, info} -> Result <$> sparseValue nullity info