git.iko.soy/rel8
on 9216dbd help sign in
rel8/src/Rel8/Table/Serialize.hs
347 lines 11 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language DisambiguateRecordFields #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
6{-# language FunctionalDependencies #-}
7{-# language NamedFieldPuns #-}
8{-# language ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
10{-# language TypeApplications #-}
11{-# language TypeFamilies #-}
12{-# language ViewPatterns #-}
13{-# language UndecidableInstances #-}
15module Rel8.Table.Serialize
16 ( Serializable, lit, parse
17 , Encodes, litTable
18 )
19where
21-- base
22import Data.Bifunctor ( bimap )
23import Data.Functor.Identity ( Identity )
24import Data.Kind ( Constraint, Type )
25import Data.List.NonEmpty ( NonEmpty )
26import Prelude
28-- hasql
29import qualified Hasql.Decoders as Hasql
31-- rel8
32import Rel8.Expr ( Expr, Col(..) )
33import Rel8.Expr.Serialize ( slitExpr, sparseValue )
34import Rel8.Schema.Context ( Col(..) )
35import Rel8.Schema.Context.Identity
36 ( fromHEitherTable, toHEitherTable
37 , fromHListTable, toHListTable
38 , fromHMaybeTable, toHMaybeTable
39 , fromHNonEmptyTable, toHNonEmptyTable
40 , fromHTheseTable, toHTheseTable
41 )
42import Rel8.Schema.Context.Label ( labeler, unlabeler )
43import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
44import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
45import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
46import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
47import Rel8.Schema.HTable.Pair ( HPair(..) )
48import Rel8.Schema.HTable.Trio ( HTrio(..) )
49import Rel8.Schema.HTable.Type ( HType(..) )
50import Rel8.Schema.Nullability ( NotNull, Sql )
51import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
52import Rel8.Table ( Table, Columns, fromColumns, toColumns )
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 )
68fromIdentity' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Identity) -> a
69fromIdentity' = fromIdentity @_ @exprs
72toIdentity' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Identity)
73toIdentity' = toIdentity @_ @exprs
76type ToExprs :: Type -> Type -> Constraint
77class Table Expr exprs => ToExprs a exprs where
78 fromIdentity :: Columns exprs (Col Identity) -> a
79 toIdentity :: a -> Columns exprs (Col Identity)
82instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs a x where
83 fromIdentity (HType (Result a)) = a
84 toIdentity = HType . Result
87instance (Sql DBType a, x ~ [a]) => ToExprs [a] (Expr x) where
88 fromIdentity (HType (Result a)) = a
89 toIdentity = HType . Result
92instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Maybe a) (Expr x)
93 where
94 fromIdentity (HType (Result a)) = a
95 toIdentity = HType . Result
98instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (NonEmpty a) (Expr x)
99 where
100 fromIdentity (HType (Result a)) = a
101 toIdentity = HType . Result
104instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
105 ToExprs (Either a b) x
106 where
107 fromIdentity =
108 bimap
109 (fromIdentity' @exprs1 . hunlabel unlabeler)
110 (fromIdentity' @exprs2 . hunlabel unlabeler) .
111 fromHEitherTable
112 toIdentity =
113 toHEitherTable .
114 bimap
115 (hlabel labeler . toIdentity' @exprs1)
116 (hlabel labeler . toIdentity' @exprs2)
119instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
120 fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable
121 toIdentity = toHListTable . fmap (toIdentity' @exprs)
124instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
125 fromIdentity =
126 fmap (fromIdentity' @exprs . hunlabel unlabeler) .
127 fromHMaybeTable
128 toIdentity =
129 toHMaybeTable .
130 fmap (hlabel labeler . toIdentity' @exprs)
133instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
134 where
135 fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable
136 toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)
139instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
140 ToExprs (These a b) x
141 where
142 fromIdentity =
143 bimap
144 (fromIdentity' @exprs1 . hunlabel unlabeler)
145 (fromIdentity' @exprs2 . hunlabel unlabeler) .
146 fromHTheseTable
147 toIdentity =
148 toHTheseTable .
149 bimap
150 (hlabel labeler . toIdentity' @exprs1)
151 (hlabel labeler . toIdentity' @exprs2)
154instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
155 ToExprs (a, b) x
156 where
157 fromIdentity (HPair a b) =
158 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
159 , fromIdentity' @exprs2 $ hunlabel unlabeler b
160 )
161 toIdentity (a, b) = HPair
162 { hfst = hlabel labeler $ toIdentity' @exprs1 a
163 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
164 }
167instance
168 ( ToExprs a exprs1
169 , ToExprs b exprs2
170 , ToExprs c exprs3
171 , x ~ (exprs1, exprs2, exprs3)
172 ) => ToExprs (a, b, c) x
173 where
174 fromIdentity (HTrio a b c) =
175 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
176 , fromIdentity' @exprs2 $ hunlabel unlabeler b
177 , fromIdentity' @exprs3 $ hunlabel unlabeler c
178 )
179 toIdentity (a, b, c) = HTrio
180 { hfst = hlabel labeler $ toIdentity' @exprs1 a
181 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
182 , htrd = hlabel labeler $ toIdentity' @exprs3 c
183 }
186instance
187 ( ToExprs a exprs1
188 , ToExprs b exprs2
189 , ToExprs c exprs3
190 , ToExprs d exprs4
191 , x ~ (exprs1, exprs2, exprs3, exprs4)
192 ) => ToExprs (a, b, c, d) x
193 where
194 fromIdentity (HQuartet a b c d) =
195 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
196 , fromIdentity' @exprs2 $ hunlabel unlabeler b
197 , fromIdentity' @exprs3 $ hunlabel unlabeler c
198 , fromIdentity' @exprs4 $ hunlabel unlabeler d
199 )
200 toIdentity (a, b, c, d) = HQuartet
201 { hfst = hlabel labeler $ toIdentity' @exprs1 a
202 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
203 , htrd = hlabel labeler $ toIdentity' @exprs3 c
204 , hfrt = hlabel labeler $ toIdentity' @exprs4 d
205 }
208instance
209 ( ToExprs a exprs1
210 , ToExprs b exprs2
211 , ToExprs c exprs3
212 , ToExprs d exprs4
213 , ToExprs e exprs5
214 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
215 ) => ToExprs (a, b, c, d, e) x
216 where
217 fromIdentity (HQuintet a b c d e) =
218 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
219 , fromIdentity' @exprs2 $ hunlabel unlabeler b
220 , fromIdentity' @exprs3 $ hunlabel unlabeler c
221 , fromIdentity' @exprs4 $ hunlabel unlabeler d
222 , fromIdentity' @exprs5 $ hunlabel unlabeler e
223 )
224 toIdentity (a, b, c, d, e) = HQuintet
225 { hfst = hlabel labeler $ toIdentity' @exprs1 a
226 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
227 , htrd = hlabel labeler $ toIdentity' @exprs3 c
228 , hfrt = hlabel labeler $ toIdentity' @exprs4 d
229 , hfft = hlabel labeler $ toIdentity' @exprs5 e
230 }
233instance (HTable t, result ~ Col Identity, x ~ t (Col Expr)) =>
234 ToExprs (t result) x
235 where
236 fromIdentity = id
237 toIdentity = id
240instance (Recontextualize Identity Expr (t Identity) (t Expr), result ~ Identity, x ~ t Expr) =>
241 ToExprs (t result) x
242 where
243 fromIdentity = fromColumns
244 toIdentity = toColumns
247instance (KnownSpec spec, x ~ Col Expr spec) =>
248 ToExprs (Col Identity spec) x
249 where
250 fromIdentity = fromColumns
251 toIdentity = toColumns
254type FromExprs :: Type -> Type
255type family FromExprs a where
256 FromExprs (Expr a) = a
257 FromExprs (Col Expr spec) = Col Identity spec
258 FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
259 FromExprs (ListTable a) = [FromExprs a]
260 FromExprs (MaybeTable a) = Maybe (FromExprs a)
261 FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
262 FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
263 FromExprs (a, b) = (FromExprs a, FromExprs b)
264 FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
265 FromExprs (a, b, c, d) =
266 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
267 FromExprs (a, b, c, d, e) =
268 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
269 FromExprs (t Expr) = t Identity
270 FromExprs (t (Col Expr)) = t (Col Identity)
273-- | @Serializable@ witnesses the one-to-one correspondence between the type
274-- @sql@, which contains SQL expressions, and the type @haskell@, which
275-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
276type Serializable :: Type -> Type -> Constraint
277class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
278instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
279instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
282lit :: forall exprs a. Serializable exprs a => a -> exprs
283lit = fromColumns . litHTable . toIdentity' @exprs
286parse :: forall exprs a. Serializable exprs a => Hasql.Row a
287parse = fromIdentity' @exprs <$> parseHTable
290type Encodes :: Type -> Type -> Constraint
291class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a
294instance KnownSpec spec => Encodes (Col Identity spec) (Col Expr spec)
297instance Serializable (t Identity) (t Expr) => Encodes (t Expr) (t Identity)
300instance HTable t => Encodes (t (Col Identity)) (t (Col Expr))
303instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)
306instance Encodes a x => Encodes [a] (ListTable x)
309instance Encodes a x => Encodes (Maybe a) (MaybeTable x)
312instance Encodes a x => Encodes (NonEmpty a) (NonEmptyTable x)
315instance (Encodes a x, Encodes b y) => Encodes (These a b) (TheseTable x y)
318instance (Encodes a x, Encodes b y) => Encodes (a, b) (x, y)
321instance (Encodes a x, Encodes b y, Encodes c z) =>
322 Encodes (a, b, c) (x, y, z)
325instance (Encodes a w, Encodes b x, Encodes c y, Encodes d z) =>
326 Encodes (a, b, c, d) (w, x, y, z)
329instance (Encodes a v, Encodes b w, Encodes c x, Encodes d y, Encodes e z) =>
330 Encodes (a, b, c, d, e) (v, w, x, y, z)
333litTable :: Encodes a exprs => a -> exprs
334litTable = lit
337litHTable :: HTable t => t (Col Identity) -> t (Col Expr)
338litHTable as = htabulate $ \field ->
339 case hfield hspecs field of
340 SSpec {nullability, info} -> case hfield as field of
341 Result value -> DB (slitExpr nullability info value)
344parseHTable :: HTable t => Hasql.Row (t (Col Identity))
345parseHTable = unwrapApplicative $ htabulateA $ \field ->
346 WrapApplicative $ case hfield hspecs field of
347 SSpec {nullability, info} -> Result <$> sparseValue nullability info