git.iko.soy/rel8
on 11a2229 help sign in
rel8/src/Rel8/Table/Serialize.hs
329 lines 10 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.Label ( labeler, unlabeler )
35import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
36import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
37import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
38import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
39import Rel8.Schema.HTable.Pair ( HPair(..) )
40import Rel8.Schema.HTable.Trio ( HTrio(..) )
41import Rel8.Schema.HTable.Type ( HType(..) )
42import Rel8.Schema.Null ( NotNull, Sql )
43import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
44import Rel8.Table ( Table, Columns, fromColumns, toColumns )
45import Rel8.Table.Either ( EitherTable )
46import Rel8.Table.List ( ListTable )
47import Rel8.Table.Maybe ( MaybeTable )
48import Rel8.Table.NonEmpty ( NonEmptyTable )
49import Rel8.Table.Recontextualize ( Recontextualize )
50import Rel8.Table.These ( TheseTable )
51import Rel8.Type ( DBType )
53-- semigroupoids
54import Data.Functor.Apply ( WrappedApplicative(..) )
56-- these
57import Data.These ( These )
60fromIdentity' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Identity) -> a
61fromIdentity' = fromIdentity @_ @exprs
64toIdentity' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Identity)
65toIdentity' = toIdentity @_ @exprs
68type ToExprs :: Type -> Type -> Constraint
69class Table Expr exprs => ToExprs a exprs where
70 fromIdentity :: Columns exprs (Col Identity) -> a
71 toIdentity :: a -> Columns exprs (Col Identity)
74instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs a x where
75 fromIdentity (HType (Result a)) = a
76 toIdentity = HType . Result
79instance (Sql DBType a, x ~ [a]) => ToExprs [a] (Expr x) where
80 fromIdentity (HType (Result a)) = a
81 toIdentity = HType . Result
84instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Maybe a) (Expr x)
85 where
86 fromIdentity (HType (Result a)) = a
87 toIdentity = HType . Result
90instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (NonEmpty a) (Expr x)
91 where
92 fromIdentity (HType (Result a)) = a
93 toIdentity = HType . Result
96instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
97 ToExprs (Either a b) x
98 where
99 fromIdentity =
100 bimap (fromIdentity' @exprs1) (fromIdentity' @exprs2) .
101 fromColumns
102 toIdentity =
103 toColumns .
104 bimap (toIdentity' @exprs1) (toIdentity' @exprs2)
107instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
108 fromIdentity = fmap (fromIdentity' @exprs) . fromColumns
109 toIdentity = toColumns . fmap (toIdentity' @exprs)
112instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
113 fromIdentity = fmap (fromIdentity' @exprs) . fromColumns
114 toIdentity = toColumns . fmap (toIdentity' @exprs)
117instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
118 where
119 fromIdentity = fmap (fromIdentity' @exprs) . fromColumns
120 toIdentity = toColumns . fmap (toIdentity' @exprs)
123instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
124 ToExprs (These a b) x
125 where
126 fromIdentity =
127 bimap (fromIdentity' @exprs1) (fromIdentity' @exprs2) .
128 fromColumns
129 toIdentity =
130 toColumns .
131 bimap (toIdentity' @exprs1) (toIdentity' @exprs2)
134instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
135 ToExprs (a, b) x
136 where
137 fromIdentity (HPair a b) =
138 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
139 , fromIdentity' @exprs2 $ hunlabel unlabeler b
140 )
141 toIdentity (a, b) = HPair
142 { hfst = hlabel labeler $ toIdentity' @exprs1 a
143 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
144 }
147instance
148 ( ToExprs a exprs1
149 , ToExprs b exprs2
150 , ToExprs c exprs3
151 , x ~ (exprs1, exprs2, exprs3)
152 ) => ToExprs (a, b, c) x
153 where
154 fromIdentity (HTrio a b c) =
155 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
156 , fromIdentity' @exprs2 $ hunlabel unlabeler b
157 , fromIdentity' @exprs3 $ hunlabel unlabeler c
158 )
159 toIdentity (a, b, c) = HTrio
160 { hfst = hlabel labeler $ toIdentity' @exprs1 a
161 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
162 , htrd = hlabel labeler $ toIdentity' @exprs3 c
163 }
166instance
167 ( ToExprs a exprs1
168 , ToExprs b exprs2
169 , ToExprs c exprs3
170 , ToExprs d exprs4
171 , x ~ (exprs1, exprs2, exprs3, exprs4)
172 ) => ToExprs (a, b, c, d) x
173 where
174 fromIdentity (HQuartet a b c d) =
175 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
176 , fromIdentity' @exprs2 $ hunlabel unlabeler b
177 , fromIdentity' @exprs3 $ hunlabel unlabeler c
178 , fromIdentity' @exprs4 $ hunlabel unlabeler d
179 )
180 toIdentity (a, b, c, d) = HQuartet
181 { hfst = hlabel labeler $ toIdentity' @exprs1 a
182 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
183 , htrd = hlabel labeler $ toIdentity' @exprs3 c
184 , hfrt = hlabel labeler $ toIdentity' @exprs4 d
185 }
188instance
189 ( ToExprs a exprs1
190 , ToExprs b exprs2
191 , ToExprs c exprs3
192 , ToExprs d exprs4
193 , ToExprs e exprs5
194 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
195 ) => ToExprs (a, b, c, d, e) x
196 where
197 fromIdentity (HQuintet a b c d e) =
198 ( fromIdentity' @exprs1 $ hunlabel unlabeler a
199 , fromIdentity' @exprs2 $ hunlabel unlabeler b
200 , fromIdentity' @exprs3 $ hunlabel unlabeler c
201 , fromIdentity' @exprs4 $ hunlabel unlabeler d
202 , fromIdentity' @exprs5 $ hunlabel unlabeler e
203 )
204 toIdentity (a, b, c, d, e) = HQuintet
205 { hfst = hlabel labeler $ toIdentity' @exprs1 a
206 , hsnd = hlabel labeler $ toIdentity' @exprs2 b
207 , htrd = hlabel labeler $ toIdentity' @exprs3 c
208 , hfrt = hlabel labeler $ toIdentity' @exprs4 d
209 , hfft = hlabel labeler $ toIdentity' @exprs5 e
210 }
213instance (HTable t, result ~ Col Identity, x ~ t (Col Expr)) =>
214 ToExprs (t result) x
215 where
216 fromIdentity = id
217 toIdentity = id
220instance (Recontextualize Identity Expr (t Identity) (t Expr), result ~ Identity, x ~ t Expr) =>
221 ToExprs (t result) x
222 where
223 fromIdentity = fromColumns
224 toIdentity = toColumns
227instance (KnownSpec spec, x ~ Col Expr spec) =>
228 ToExprs (Col Identity spec) x
229 where
230 fromIdentity = fromColumns
231 toIdentity = toColumns
234type FromExprs :: Type -> Type
235type family FromExprs a
236type instance FromExprs (Expr a) = a
237type instance FromExprs (Col Expr spec) = Col Identity spec
238type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
239type instance FromExprs (ListTable a) = [FromExprs a]
240type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
241type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
242type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
243type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
244type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
245type instance FromExprs (a, b, c, d) =
246 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
247type instance FromExprs (a, b, c, d, e) =
248 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
249type instance FromExprs (t Expr) = t Identity
250type instance FromExprs (t (Col Expr)) = t (Col Identity)
253-- | @Serializable@ witnesses the one-to-one correspondence between the type
254-- @sql@, which contains SQL expressions, and the type @haskell@, which
255-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
256type Serializable :: Type -> Type -> Constraint
257class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
258instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
259instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
262-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
263-- capable of lifting single @Expr@s to full tables.
264lit :: forall exprs a. Serializable exprs a => a -> exprs
265lit = fromColumns . litHTable . toIdentity' @exprs
268parse :: forall exprs a. Serializable exprs a => Hasql.Row a
269parse = fromIdentity' @exprs <$> parseHTable
272type Encodes :: Type -> Type -> Constraint
273class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a
276instance KnownSpec spec => Encodes (Col Identity spec) (Col Expr spec)
279instance Serializable (t Identity) (t Expr) => Encodes (t Expr) (t Identity)
282instance HTable t => Encodes (t (Col Identity)) (t (Col Expr))
285instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)
288instance Encodes a x => Encodes [a] (ListTable x)
291instance Encodes a x => Encodes (Maybe a) (MaybeTable x)
294instance Encodes a x => Encodes (NonEmpty a) (NonEmptyTable x)
297instance (Encodes a x, Encodes b y) => Encodes (These a b) (TheseTable x y)
300instance (Encodes a x, Encodes b y) => Encodes (a, b) (x, y)
303instance (Encodes a x, Encodes b y, Encodes c z) =>
304 Encodes (a, b, c) (x, y, z)
307instance (Encodes a w, Encodes b x, Encodes c y, Encodes d z) =>
308 Encodes (a, b, c, d) (w, x, y, z)
311instance (Encodes a v, Encodes b w, Encodes c x, Encodes d y, Encodes e z) =>
312 Encodes (a, b, c, d, e) (v, w, x, y, z)
315litTable :: Encodes a exprs => a -> exprs
316litTable = lit
319litHTable :: HTable t => t (Col Identity) -> t (Col Expr)
320litHTable as = htabulate $ \field ->
321 case hfield hspecs field of
322 SSpec {nullity, info} -> case hfield as field of
323 Result value -> DB (slitExpr nullity info value)
326parseHTable :: HTable t => Hasql.Row (t (Col Identity))
327parseHTable = unwrapApplicative $ htabulateA $ \field ->
328 WrapApplicative $ case hfield hspecs field of
329 SSpec {nullity, info} -> Result <$> sparseValue nullity info