git.iko.soy/rel8
on 4e90af3 help sign in
rel8/src/Rel8/Table/Serialize.hs
348 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 UndecidableInstances #-}
14module Rel8.Table.Serialize
15 ( Serializable, lit, parse
16 , Encodes, litTable
17 )
18where
20-- base
21import Data.Bifunctor ( bimap )
22import Data.Functor.Identity ( Identity )
23import Data.Kind ( Constraint, Type )
24import Data.List.NonEmpty ( NonEmpty )
25import Prelude
27-- hasql
28import qualified Hasql.Decoders as Hasql
30-- rel8
31import Rel8.Expr ( Expr, Col(..) )
32import Rel8.Expr.Serialize ( slitExpr, sparseValue )
33import Rel8.Schema.Context ( Col(..) )
34import Rel8.Schema.Context.Identity
35 ( fromHEitherTable, toHEitherTable
36 , fromHListTable, toHListTable
37 , fromHMaybeTable, toHMaybeTable
38 , fromHNonEmptyTable, toHNonEmptyTable
39 , fromHTheseTable, toHTheseTable
40 )
41import Rel8.Schema.Context.Label ( labeler, unlabeler )
42import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
43import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
44import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
45import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
46import Rel8.Schema.HTable.Pair ( HPair(..) )
47import Rel8.Schema.HTable.Trio ( HTrio(..) )
48import Rel8.Schema.HTable.Type ( HType(..) )
49import Rel8.Schema.Null ( NotNull, Sql )
50import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
51import Rel8.Table ( Table, Columns, fromColumns, toColumns )
52import Rel8.Table.Either ( EitherTable )
53import Rel8.Table.List ( ListTable )
54import Rel8.Table.Maybe ( MaybeTable )
55import Rel8.Table.NonEmpty ( NonEmptyTable )
56import Rel8.Table.Recontextualize ( Recontextualize )
57import Rel8.Table.These ( TheseTable )
58import Rel8.Type ( DBType )
60-- semigroupoids
61import Data.Functor.Apply ( WrappedApplicative(..) )
63-- these
64import Data.These ( These )
67fromIdentity' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Identity) -> a
68fromIdentity' = fromIdentity @_ @exprs
71toIdentity' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Identity)
72toIdentity' = toIdentity @_ @exprs
75type ToExprs :: Type -> Type -> Constraint
76class Table Expr exprs => ToExprs a exprs where
77 fromIdentity :: Columns exprs (Col Identity) -> a
78 toIdentity :: a -> Columns exprs (Col Identity)
81instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs a x where
82 fromIdentity (HType (Result a)) = a
83 toIdentity = HType . Result
86instance (Sql DBType a, x ~ [a]) => ToExprs [a] (Expr x) where
87 fromIdentity (HType (Result a)) = a
88 toIdentity = HType . Result
91instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Maybe a) (Expr x)
92 where
93 fromIdentity (HType (Result a)) = a
94 toIdentity = HType . Result
97instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (NonEmpty a) (Expr x)
98 where
99 fromIdentity (HType (Result a)) = a
100 toIdentity = HType . Result
103instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
104 ToExprs (Either a b) x
105 where
106 fromIdentity =
107 bimap
108 (fromIdentity' @exprs1 . hunlabel unlabeler)
109 (fromIdentity' @exprs2 . hunlabel unlabeler) .
110 fromHEitherTable
111 toIdentity =
112 toHEitherTable .
113 bimap
114 (hlabel labeler . toIdentity' @exprs1)
115 (hlabel labeler . toIdentity' @exprs2)
118instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
119 fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable
120 toIdentity = toHListTable . fmap (toIdentity' @exprs)
123instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
124 fromIdentity =
125 fmap (fromIdentity' @exprs . hunlabel unlabeler) .
126 fromHMaybeTable
127 toIdentity =
128 toHMaybeTable .
129 fmap (hlabel labeler . toIdentity' @exprs)
132instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
133 where
134 fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable
135 toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)
138instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
139 ToExprs (These a b) x
140 where
141 fromIdentity =
142 bimap
143 (fromIdentity' @exprs1 . hunlabel unlabeler)
144 (fromIdentity' @exprs2 . hunlabel unlabeler) .
145 fromHTheseTable
146 toIdentity =
147 toHTheseTable .
148 bimap
149 (hlabel labeler . toIdentity' @exprs1)
150 (hlabel labeler . toIdentity' @exprs2)
153instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
154 ToExprs (a, b) x
155 where
156 fromIdentity (HPair a b) =
157 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
158 , fromIdentity' @exprs2 $ hunlabel unlabeler b
159 )
160 toIdentity (a, b) = HPair
161 { hfst = hlabel labeler $ toIdentity' @exprs1 a
162 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
163 }
166instance
167 ( ToExprs a exprs1
168 , ToExprs b exprs2
169 , ToExprs c exprs3
170 , x ~ (exprs1, exprs2, exprs3)
171 ) => ToExprs (a, b, c) x
172 where
173 fromIdentity (HTrio a b c) =
174 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
175 , fromIdentity' @exprs2 $ hunlabel unlabeler b
176 , fromIdentity' @exprs3 $ hunlabel unlabeler c
177 )
178 toIdentity (a, b, c) = HTrio
179 { hfst = hlabel labeler $ toIdentity' @exprs1 a
180 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
181 , htrd = hlabel labeler $ toIdentity' @exprs3 c
182 }
185instance
186 ( ToExprs a exprs1
187 , ToExprs b exprs2
188 , ToExprs c exprs3
189 , ToExprs d exprs4
190 , x ~ (exprs1, exprs2, exprs3, exprs4)
191 ) => ToExprs (a, b, c, d) x
192 where
193 fromIdentity (HQuartet a b c d) =
194 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
195 , fromIdentity' @exprs2 $ hunlabel unlabeler b
196 , fromIdentity' @exprs3 $ hunlabel unlabeler c
197 , fromIdentity' @exprs4 $ hunlabel unlabeler d
198 )
199 toIdentity (a, b, c, d) = HQuartet
200 { hfst = hlabel labeler $ toIdentity' @exprs1 a
201 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
202 , htrd = hlabel labeler $ toIdentity' @exprs3 c
203 , hfrt = hlabel labeler $ toIdentity' @exprs4 d
204 }
207instance
208 ( ToExprs a exprs1
209 , ToExprs b exprs2
210 , ToExprs c exprs3
211 , ToExprs d exprs4
212 , ToExprs e exprs5
213 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
214 ) => ToExprs (a, b, c, d, e) x
215 where
216 fromIdentity (HQuintet a b c d e) =
217 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
218 , fromIdentity' @exprs2 $ hunlabel unlabeler b
219 , fromIdentity' @exprs3 $ hunlabel unlabeler c
220 , fromIdentity' @exprs4 $ hunlabel unlabeler d
221 , fromIdentity' @exprs5 $ hunlabel unlabeler e
222 )
223 toIdentity (a, b, c, d, e) = HQuintet
224 { hfst = hlabel labeler $ toIdentity' @exprs1 a
225 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
226 , htrd = hlabel labeler $ toIdentity' @exprs3 c
227 , hfrt = hlabel labeler $ toIdentity' @exprs4 d
228 , hfft = hlabel labeler $ toIdentity' @exprs5 e
229 }
232instance (HTable t, result ~ Col Identity, x ~ t (Col Expr)) =>
233 ToExprs (t result) x
234 where
235 fromIdentity = id
236 toIdentity = id
239instance (Recontextualize Identity Expr (t Identity) (t Expr), result ~ Identity, x ~ t Expr) =>
240 ToExprs (t result) x
241 where
242 fromIdentity = fromColumns
243 toIdentity = toColumns
246instance (KnownSpec spec, x ~ Col Expr spec) =>
247 ToExprs (Col Identity spec) x
248 where
249 fromIdentity = fromColumns
250 toIdentity = toColumns
253type FromExprs :: Type -> Type
254type family FromExprs a where
255 FromExprs (Expr a) = a
256 FromExprs (Col Expr spec) = Col Identity spec
257 FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
258 FromExprs (ListTable a) = [FromExprs a]
259 FromExprs (MaybeTable a) = Maybe (FromExprs a)
260 FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
261 FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
262 FromExprs (a, b) = (FromExprs a, FromExprs b)
263 FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
264 FromExprs (a, b, c, d) =
265 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
266 FromExprs (a, b, c, d, e) =
267 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
268 FromExprs (t Expr) = t Identity
269 FromExprs (t (Col Expr)) = t (Col Identity)
272-- | @Serializable@ witnesses the one-to-one correspondence between the type
273-- @sql@, which contains SQL expressions, and the type @haskell@, which
274-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
275type Serializable :: Type -> Type -> Constraint
276class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
277instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
278instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
281-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
282-- capable of lifting single @Expr@s to full tables.
283lit :: forall exprs a. Serializable exprs a => a -> exprs
284lit = fromColumns . litHTable . toIdentity' @exprs
287parse :: forall exprs a. Serializable exprs a => Hasql.Row a
288parse = fromIdentity' @exprs <$> parseHTable
291type Encodes :: Type -> Type -> Constraint
292class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a
295instance KnownSpec spec => Encodes (Col Identity spec) (Col Expr spec)
298instance Serializable (t Identity) (t Expr) => Encodes (t Expr) (t Identity)
301instance HTable t => Encodes (t (Col Identity)) (t (Col Expr))
304instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)
307instance Encodes a x => Encodes [a] (ListTable x)
310instance Encodes a x => Encodes (Maybe a) (MaybeTable x)
313instance Encodes a x => Encodes (NonEmpty a) (NonEmptyTable x)
316instance (Encodes a x, Encodes b y) => Encodes (These a b) (TheseTable x y)
319instance (Encodes a x, Encodes b y) => Encodes (a, b) (x, y)
322instance (Encodes a x, Encodes b y, Encodes c z) =>
323 Encodes (a, b, c) (x, y, z)
326instance (Encodes a w, Encodes b x, Encodes c y, Encodes d z) =>
327 Encodes (a, b, c, d) (w, x, y, z)
330instance (Encodes a v, Encodes b w, Encodes c x, Encodes d y, Encodes e z) =>
331 Encodes (a, b, c, d, e) (v, w, x, y, z)
334litTable :: Encodes a exprs => a -> exprs
335litTable = lit
338litHTable :: HTable t => t (Col Identity) -> t (Col Expr)
339litHTable as = htabulate $ \field ->
340 case hfield hspecs field of
341 SSpec {nullity, info} -> case hfield as field of
342 Result value -> DB (slitExpr nullity info value)
345parseHTable :: HTable t => Hasql.Row (t (Col Identity))
346parseHTable = unwrapApplicative $ htabulateA $ \field ->
347 WrapApplicative $ case hfield hspecs field of
348 SSpec {nullity, info} -> Result <$> sparseValue nullity info