git.iko.soy/rel8
on fab5b4e help sign in
rel8/src/Rel8/Table/Serialize.hs
295 lines 8.7 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(..), FromExprs
19 , TToExprs
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.These ( TheseTable )
54import Rel8.Type ( DBType )
56-- semigroupoids
57import Data.Functor.Apply ( WrappedApplicative(..) )
59-- these
60import Data.These ( These )
63type ToExprs :: Type -> Type -> Constraint
64class Table Expr exprs => ToExprs exprs a where
65 fromResult :: Columns exprs (Col Result) -> a
66 toResult :: a -> Columns exprs (Col Result)
68 default fromResult ::
69 ( Generic (Record a)
70 , KnownAlgebra (GAlgebra (Rep (Record exprs)))
71 , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
72 , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
73 )
74 => Columns exprs (Col Result) -> a
75 fromResult =
76 unrecord .
77 to .
78 ggfromResult
79 @(GAlgebra (Rep (Record exprs)))
80 @TToExprs
81 @TColumns
82 @(Rep (Record exprs))
83 (\(_ :: proxy expr) -> fromResult @expr)
85 default toResult ::
86 ( Generic (Record a)
87 , KnownAlgebra (GAlgebra (Rep (Record exprs)))
88 , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
89 , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
90 )
91 => a -> Columns exprs (Col Result)
92 toResult =
93 ggtoResult
94 @(GAlgebra (Rep (Record exprs)))
95 @TToExprs
96 @TColumns
97 @(Rep (Record exprs))
98 (\(_ :: proxy expr) -> toResult @expr) .
99 from .
100 Record
103data TToExprs :: Type -> Type -> Exp Constraint
104type instance Eval (TToExprs exprs a) = ToExprs exprs a
107instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
108 fromResult (HType (Result a)) = a
109 toResult = HType . Result
112instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
113 fromResult (HType (Result a)) = a
114 toResult = HType . Result
117instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
118 where
119 fromResult (HType (Result a)) = a
120 toResult = HType . Result
123instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
124 where
125 fromResult (HType (Result a)) = a
126 toResult = HType . Result
129instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
130 ToExprs x (Either a b)
131 where
132 fromResult =
133 bimap (fromResult @exprs1) (fromResult @exprs2) .
134 fromColumns
135 toResult =
136 toColumns .
137 bimap (toResult @exprs1) (toResult @exprs2)
140instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where
141 fromResult = fmap (fromResult @exprs) . fromColumns
142 toResult = toColumns . fmap (toResult @exprs)
145instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
146 fromResult = fmap (fromResult @exprs) . fromColumns
147 toResult = toColumns . fmap (toResult @exprs)
150instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)
151 where
152 fromResult = fmap (fromResult @exprs) . fromColumns
153 toResult = toColumns . fmap (toResult @exprs)
156instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
157 ToExprs x (These a b)
158 where
159 fromResult =
160 bimap (fromResult @exprs1) (fromResult @exprs2) .
161 fromColumns
162 toResult =
163 toColumns .
164 bimap (toResult @exprs1) (toResult @exprs2)
167instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
168 ToExprs x (a, b)
171instance
172 ( ToExprs exprs1 a
173 , ToExprs exprs2 b
174 , ToExprs exprs3 c
175 , x ~ (exprs1, exprs2, exprs3)
176 )
177 => ToExprs x (a, b, c)
180instance
181 ( ToExprs exprs1 a
182 , ToExprs exprs2 b
183 , ToExprs exprs3 c
184 , ToExprs exprs4 d
185 , x ~ (exprs1, exprs2, exprs3, exprs4)
186 )
187 => ToExprs x (a, b, c, d)
190instance
191 ( ToExprs exprs1 a
192 , ToExprs exprs2 b
193 , ToExprs exprs3 c
194 , ToExprs exprs4 d
195 , ToExprs exprs5 e
196 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
197 )
198 => ToExprs x (a, b, c, d, e)
201instance
202 ( ToExprs exprs1 a
203 , ToExprs exprs2 b
204 , ToExprs exprs3 c
205 , ToExprs exprs4 d
206 , ToExprs exprs5 e
207 , ToExprs exprs6 f
208 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
209 )
210 => ToExprs x (a, b, c, d, e, f)
213instance
214 ( ToExprs exprs1 a
215 , ToExprs exprs2 b
216 , ToExprs exprs3 c
217 , ToExprs exprs4 d
218 , ToExprs exprs5 e
219 , ToExprs exprs6 f
220 , ToExprs exprs7 g
221 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
222 )
223 => ToExprs x (a, b, c, d, e, f, g)
226instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
227 ToExprs x (t result)
228 where
229 fromResult = id
230 toResult = id
233instance (KnownSpec spec, x ~ Col Expr spec) =>
234 ToExprs x (Col Result spec)
235 where
236 fromResult = fromColumns
237 toResult = toColumns
240type FromExprs :: Type -> Type
241type family FromExprs a
242type instance FromExprs (Expr a) = a
243type instance FromExprs (Col Expr spec) = Col Result spec
244type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
245type instance FromExprs (ListTable a) = [FromExprs a]
246type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
247type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
248type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
249type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
250type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
251type instance FromExprs (a, b, c, d) =
252 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
253type instance FromExprs (a, b, c, d, e) =
254 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
255type instance FromExprs (a, b, c, d, e, f) =
256 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
257 , FromExprs f
258 )
259type instance FromExprs (a, b, c, d, e, f, g) =
260 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
261 , FromExprs f, FromExprs g
262 )
263type instance FromExprs (t (Col Expr)) = t (Col Result)
266-- | @Serializable@ witnesses the one-to-one correspondence between the type
267-- @sql@, which contains SQL expressions, and the type @haskell@, which
268-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
269type Serializable :: Type -> Type -> Constraint
270class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
271instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
272instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
275-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
276-- capable of lifting single @Expr@s to full tables.
277lit :: forall exprs a. Serializable exprs a => a -> exprs
278lit = fromColumns . litHTable . toResult @exprs
281parse :: forall exprs a. Serializable exprs a => Hasql.Row a
282parse = fromResult @exprs <$> parseHTable
285litHTable :: HTable t => t (Col Result) -> t (Col Expr)
286litHTable as = htabulate $ \field ->
287 case hfield hspecs field of
288 SSpec {nullity, info} -> case hfield as field of
289 Result value -> DB (slitExpr nullity info value)
292parseHTable :: HTable t => Hasql.Row (t (Col Result))
293parseHTable = unwrapApplicative $ htabulateA $ \field ->
294 WrapApplicative $ case hfield hspecs field of
295 SSpec {nullity, info} -> Result <$> sparseValue nullity info