git.iko.soy/rel8
on 23bb65b help sign in
rel8/src/Rel8/Table/Serialize.hs
304 lines 9.0 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 , ToExprs(..)
19 , FromExprs
20 )
21where
23-- base
24import Data.Bifunctor ( bimap )
25import Data.Kind ( Constraint, Type )
26import Data.List.NonEmpty ( NonEmpty )
27import GHC.Generics ( Generic, Rep, from, to )
28import Prelude
30-- hasql
31import qualified Hasql.Decoders as Hasql
33-- rel8
34import Rel8.Expr ( Expr, Col(..) )
35import Rel8.Expr.Serialize ( slitExpr, sparseValue )
36import Rel8.FCF ( Eval, Exp )
37import Rel8.Generic.Record ( Record(..) )
38import Rel8.Generic.Table
39 ( GGToExprs, GGColumns, ggfromResult, ggtoResult
40 , GAlgebra
41 )
42import Rel8.Kind.Algebra ( KnownAlgebra )
43import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
44import Rel8.Schema.HTable.Type ( HType(..) )
45import Rel8.Schema.Null ( NotNull, Sql )
46import Rel8.Schema.Result ( Col( Result ), Result )
47import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
48import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )
49import Rel8.Table.Either ( EitherTable )
50import Rel8.Table.List ( ListTable )
51import Rel8.Table.Maybe ( MaybeTable )
52import Rel8.Table.NonEmpty ( NonEmptyTable )
53import Rel8.Table.Recontextualize ( Recontextualize )
54import Rel8.Table.These ( TheseTable )
55import Rel8.Type ( DBType )
57-- semigroupoids
58import Data.Functor.Apply ( WrappedApplicative(..) )
60-- these
61import Data.These ( These )
64type ToExprs :: Type -> Type -> Constraint
65class Table Expr exprs => ToExprs exprs a where
66 fromResult :: Columns exprs (Col Result) -> a
67 toResult :: a -> Columns exprs (Col Result)
69 default fromResult ::
70 ( Generic (Record a)
71 , KnownAlgebra (GAlgebra (Rep (Record exprs)))
72 , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
73 , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
74 )
75 => Columns exprs (Col Result) -> a
76 fromResult =
77 unrecord .
78 to .
79 ggfromResult
80 @(GAlgebra (Rep (Record exprs)))
81 @TToExprs
82 @TColumns
83 @(Rep (Record exprs))
84 (\(_ :: proxy expr) -> fromResult @expr)
86 default toResult ::
87 ( Generic (Record a)
88 , KnownAlgebra (GAlgebra (Rep (Record exprs)))
89 , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
90 , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
91 )
92 => a -> Columns exprs (Col Result)
93 toResult =
94 ggtoResult
95 @(GAlgebra (Rep (Record exprs)))
96 @TToExprs
97 @TColumns
98 @(Rep (Record exprs))
99 (\(_ :: proxy expr) -> toResult @expr) .
100 from .
101 Record
104data TToExprs :: Type -> Type -> Exp Constraint
105type instance Eval (TToExprs exprs a) = ToExprs exprs a
108instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
109 fromResult (HType (Result a)) = a
110 toResult = HType . Result
113instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
114 fromResult (HType (Result a)) = a
115 toResult = HType . Result
118instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
119 where
120 fromResult (HType (Result a)) = a
121 toResult = HType . Result
124instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
125 where
126 fromResult (HType (Result a)) = a
127 toResult = HType . Result
130instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
131 ToExprs x (Either a b)
132 where
133 fromResult =
134 bimap (fromResult @exprs1) (fromResult @exprs2) .
135 fromColumns
136 toResult =
137 toColumns .
138 bimap (toResult @exprs1) (toResult @exprs2)
141instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where
142 fromResult = fmap (fromResult @exprs) . fromColumns
143 toResult = toColumns . fmap (toResult @exprs)
146instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
147 fromResult = fmap (fromResult @exprs) . fromColumns
148 toResult = toColumns . fmap (toResult @exprs)
151instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)
152 where
153 fromResult = fmap (fromResult @exprs) . fromColumns
154 toResult = toColumns . fmap (toResult @exprs)
157instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
158 ToExprs x (These a b)
159 where
160 fromResult =
161 bimap (fromResult @exprs1) (fromResult @exprs2) .
162 fromColumns
163 toResult =
164 toColumns .
165 bimap (toResult @exprs1) (toResult @exprs2)
168instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
169 ToExprs x (a, b)
172instance
173 ( ToExprs exprs1 a
174 , ToExprs exprs2 b
175 , ToExprs exprs3 c
176 , x ~ (exprs1, exprs2, exprs3)
177 )
178 => ToExprs x (a, b, c)
181instance
182 ( ToExprs exprs1 a
183 , ToExprs exprs2 b
184 , ToExprs exprs3 c
185 , ToExprs exprs4 d
186 , x ~ (exprs1, exprs2, exprs3, exprs4)
187 )
188 => ToExprs x (a, b, c, d)
191instance
192 ( ToExprs exprs1 a
193 , ToExprs exprs2 b
194 , ToExprs exprs3 c
195 , ToExprs exprs4 d
196 , ToExprs exprs5 e
197 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
198 )
199 => ToExprs x (a, b, c, d, e)
202instance
203 ( ToExprs exprs1 a
204 , ToExprs exprs2 b
205 , ToExprs exprs3 c
206 , ToExprs exprs4 d
207 , ToExprs exprs5 e
208 , ToExprs exprs6 f
209 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
210 )
211 => ToExprs x (a, b, c, d, e, f)
214instance
215 ( ToExprs exprs1 a
216 , ToExprs exprs2 b
217 , ToExprs exprs3 c
218 , ToExprs exprs4 d
219 , ToExprs exprs5 e
220 , ToExprs exprs6 f
221 , ToExprs exprs7 g
222 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
223 )
224 => ToExprs x (a, b, c, d, e, f, g)
227instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
228 ToExprs x (t result)
229 where
230 fromResult = id
231 toResult = id
234instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
235 ToExprs x (t result)
236 where
237 fromResult = fromColumns
238 toResult = toColumns
241instance (KnownSpec spec, x ~ Col Expr spec) =>
242 ToExprs x (Col Result spec)
243 where
244 fromResult = fromColumns
245 toResult = toColumns
248type FromExprs :: Type -> Type
249type family FromExprs a
250type instance FromExprs (Expr a) = a
251type instance FromExprs (Col Expr spec) = Col Result spec
252type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
253type instance FromExprs (ListTable a) = [FromExprs a]
254type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
255type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
256type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
257type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
258type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
259type instance FromExprs (a, b, c, d) =
260 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
261type instance FromExprs (a, b, c, d, e) =
262 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
263type instance FromExprs (a, b, c, d, e, f) =
264 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
265 , FromExprs f
266 )
267type instance FromExprs (a, b, c, d, e, f, g) =
268 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
269 , FromExprs f, FromExprs g
270 )
271type instance FromExprs (t Expr) = t Result
272type instance FromExprs (t (Col Expr)) = t (Col Result)
275-- | @Serializable@ witnesses the one-to-one correspondence between the type
276-- @sql@, which contains SQL expressions, and the type @haskell@, which
277-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
278type Serializable :: Type -> Type -> Constraint
279class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
280instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
281instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
284-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
285-- capable of lifting single @Expr@s to full tables.
286lit :: forall exprs a. Serializable exprs a => a -> exprs
287lit = fromColumns . litHTable . toResult @exprs
290parse :: forall exprs a. Serializable exprs a => Hasql.Row a
291parse = fromResult @exprs <$> parseHTable
294litHTable :: HTable t => t (Col Result) -> t (Col Expr)
295litHTable as = htabulate $ \field ->
296 case hfield hspecs field of
297 SSpec {nullity, info} -> case hfield as field of
298 Result value -> DB (slitExpr nullity info value)
301parseHTable :: HTable t => Hasql.Row (t (Col Result))
302parseHTable = unwrapApplicative $ htabulateA $ \field ->
303 WrapApplicative $ case hfield hspecs field of
304 SSpec {nullity, info} -> Result <$> sparseValue nullity info