git.iko.soy/rel8
on 6d3959e help sign in
rel8/src/Rel8/Table/Serialize.hs
323 lines 9.7 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 , ToExprs(..)
18 , FromExprs
19 )
20where
22-- base
23import Data.Bifunctor ( bimap )
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.Label ( labeler, unlabeler )
36import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
37import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
38import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
39import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
40import Rel8.Schema.HTable.Pair ( HPair(..) )
41import Rel8.Schema.HTable.Trio ( HTrio(..) )
42import Rel8.Schema.HTable.Type ( HType(..) )
43import Rel8.Schema.Null ( NotNull, Sql )
44import Rel8.Schema.Result ( Result )
45import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
46import Rel8.Table ( Table, Columns, fromColumns, toColumns )
47import Rel8.Table.Either ( EitherTable )
48import Rel8.Table.List ( ListTable )
49import Rel8.Table.Maybe ( MaybeTable )
50import Rel8.Table.NonEmpty ( NonEmptyTable )
51import Rel8.Table.Recontextualize ( Recontextualize )
52import Rel8.Table.These ( TheseTable )
53import Rel8.Type ( DBType )
55-- semigroupoids
56import Data.Functor.Apply ( WrappedApplicative(..) )
58-- these
59import Data.These ( These )
62type ToExprs :: Type -> Type -> Constraint
63class Table Expr exprs => ToExprs exprs a where
64 fromResult :: Columns exprs (Col Result) -> a
65 toResult :: a -> Columns exprs (Col Result)
68instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
69 fromResult (HType (Result a)) = a
70 toResult = HType . Result
73instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
74 fromResult (HType (Result a)) = a
75 toResult = HType . Result
78instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
79 where
80 fromResult (HType (Result a)) = a
81 toResult = HType . Result
84instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
85 where
86 fromResult (HType (Result a)) = a
87 toResult = HType . Result
90instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
91 ToExprs x (Either a b)
92 where
93 fromResult =
94 bimap (fromResult @exprs1) (fromResult @exprs2) .
95 fromColumns
96 toResult =
97 toColumns .
98 bimap (toResult @exprs1) (toResult @exprs2)
101instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where
102 fromResult = fmap (fromResult @exprs) . fromColumns
103 toResult = toColumns . fmap (toResult @exprs)
106instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
107 fromResult = fmap (fromResult @exprs) . fromColumns
108 toResult = toColumns . fmap (toResult @exprs)
111instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)
112 where
113 fromResult = fmap (fromResult @exprs) . fromColumns
114 toResult = toColumns . fmap (toResult @exprs)
117instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
118 ToExprs x (These a b)
119 where
120 fromResult =
121 bimap (fromResult @exprs1) (fromResult @exprs2) .
122 fromColumns
123 toResult =
124 toColumns .
125 bimap (toResult @exprs1) (toResult @exprs2)
128instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
129 ToExprs x (a, b)
130 where
131 fromResult (HPair a b) =
132 ( fromResult @exprs1 $ hunlabel unlabeler a
133 , fromResult @exprs2 $ hunlabel unlabeler b
134 )
135 toResult (a, b) = HPair
136 { hfst = hlabel labeler $ toResult @exprs1 a
137 , hsnd = hlabel labeler $ toResult @exprs2 b
138 }
141instance
142 ( ToExprs exprs1 a
143 , ToExprs exprs2 b
144 , ToExprs exprs3 c
145 , x ~ (exprs1, exprs2, exprs3)
146 ) => ToExprs x (a, b, c)
147 where
148 fromResult (HTrio a b c) =
149 ( fromResult @exprs1 $ hunlabel unlabeler a
150 , fromResult @exprs2 $ hunlabel unlabeler b
151 , fromResult @exprs3 $ hunlabel unlabeler c
152 )
153 toResult (a, b, c) = HTrio
154 { hfst = hlabel labeler $ toResult @exprs1 a
155 , hsnd = hlabel labeler $ toResult @exprs2 b
156 , htrd = hlabel labeler $ toResult @exprs3 c
157 }
160instance
161 ( ToExprs exprs1 a
162 , ToExprs exprs2 b
163 , ToExprs exprs3 c
164 , ToExprs exprs4 d
165 , x ~ (exprs1, exprs2, exprs3, exprs4)
166 ) => ToExprs x (a, b, c, d)
167 where
168 fromResult (HQuartet a b c d) =
169 ( fromResult @exprs1 $ hunlabel unlabeler a
170 , fromResult @exprs2 $ hunlabel unlabeler b
171 , fromResult @exprs3 $ hunlabel unlabeler c
172 , fromResult @exprs4 $ hunlabel unlabeler d
173 )
174 toResult (a, b, c, d) = HQuartet
175 { hfst = hlabel labeler $ toResult @exprs1 a
176 , hsnd = hlabel labeler $ toResult @exprs2 b
177 , htrd = hlabel labeler $ toResult @exprs3 c
178 , hfrt = hlabel labeler $ toResult @exprs4 d
179 }
182instance
183 ( ToExprs exprs1 a
184 , ToExprs exprs2 b
185 , ToExprs exprs3 c
186 , ToExprs exprs4 d
187 , ToExprs exprs5 e
188 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
189 ) => ToExprs x (a, b, c, d, e)
190 where
191 fromResult (HQuintet a b c d e) =
192 ( fromResult @exprs1 $ hunlabel unlabeler a
193 , fromResult @exprs2 $ hunlabel unlabeler b
194 , fromResult @exprs3 $ hunlabel unlabeler c
195 , fromResult @exprs4 $ hunlabel unlabeler d
196 , fromResult @exprs5 $ hunlabel unlabeler e
197 )
198 toResult (a, b, c, d, e) = HQuintet
199 { hfst = hlabel labeler $ toResult @exprs1 a
200 , hsnd = hlabel labeler $ toResult @exprs2 b
201 , htrd = hlabel labeler $ toResult @exprs3 c
202 , hfrt = hlabel labeler $ toResult @exprs4 d
203 , hfft = hlabel labeler $ toResult @exprs5 e
204 }
207instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
208 ToExprs x (t result)
209 where
210 fromResult = id
211 toResult = id
214instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
215 ToExprs x (t result)
216 where
217 fromResult = fromColumns
218 toResult = toColumns
221instance (KnownSpec spec, x ~ Col Expr spec) =>
222 ToExprs x (Col Result spec)
223 where
224 fromResult = fromColumns
225 toResult = toColumns
228type FromExprs :: Type -> Type
229type family FromExprs a
230type instance FromExprs (Expr a) = a
231type instance FromExprs (Col Expr spec) = Col Result spec
232type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
233type instance FromExprs (ListTable a) = [FromExprs a]
234type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
235type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
236type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
237type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
238type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
239type instance FromExprs (a, b, c, d) =
240 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
241type instance FromExprs (a, b, c, d, e) =
242 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
243type instance FromExprs (t Expr) = t Result
244type instance FromExprs (t (Col Expr)) = t (Col Result)
247-- | @Serializable@ witnesses the one-to-one correspondence between the type
248-- @sql@, which contains SQL expressions, and the type @haskell@, which
249-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
250type Serializable :: Type -> Type -> Constraint
251class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
252instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
253instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
256-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
257-- capable of lifting single @Expr@s to full tables.
258lit :: forall exprs a. Serializable exprs a => a -> exprs
259lit = fromColumns . litHTable . toResult @exprs
262parse :: forall exprs a. Serializable exprs a => Hasql.Row a
263parse = fromResult @exprs <$> parseHTable
266type Encodes :: Type -> Type -> Constraint
267class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a
270instance KnownSpec spec => Encodes (Col Result spec) (Col Expr spec)
273instance Serializable (t Result) (t Expr) => Encodes (t Expr) (t Result)
276instance HTable t => Encodes (t (Col Result)) (t (Col Expr))
279instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)
282instance Encodes a x => Encodes [a] (ListTable x)
285instance Encodes a x => Encodes (Maybe a) (MaybeTable x)
288instance Encodes a x => Encodes (NonEmpty a) (NonEmptyTable x)
291instance (Encodes a x, Encodes b y) => Encodes (These a b) (TheseTable x y)
294instance (Encodes a x, Encodes b y) => Encodes (a, b) (x, y)
297instance (Encodes a x, Encodes b y, Encodes c z) =>
298 Encodes (a, b, c) (x, y, z)
301instance (Encodes a w, Encodes b x, Encodes c y, Encodes d z) =>
302 Encodes (a, b, c, d) (w, x, y, z)
305instance (Encodes a v, Encodes b w, Encodes c x, Encodes d y, Encodes e z) =>
306 Encodes (a, b, c, d, e) (v, w, x, y, z)
309litTable :: Encodes a exprs => a -> exprs
310litTable = lit
313litHTable :: HTable t => t (Col Result) -> t (Col Expr)
314litHTable as = htabulate $ \field ->
315 case hfield hspecs field of
316 SSpec {nullity, info} -> case hfield as field of
317 Result value -> DB (slitExpr nullity info value)
320parseHTable :: HTable t => Hasql.Row (t (Col Result))
321parseHTable = unwrapApplicative $ htabulateA $ \field ->
322 WrapApplicative $ case hfield hspecs field of
323 SSpec {nullity, info} -> Result <$> sparseValue nullity info