git.iko.soy/rel8
on 04fdf27 help sign in
rel8/src/Rel8/Table/Serialize.hs
331 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 , 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 )
62fromResult' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Result) -> a
63fromResult' = fromResult @_ @exprs
66toResult' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Result)
67toResult' = toResult @_ @exprs
70type ToExprs :: Type -> Type -> Constraint
71class Table Expr exprs => ToExprs a exprs where
72 fromResult :: Columns exprs (Col Result) -> a
73 toResult :: a -> Columns exprs (Col Result)
76instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs a x where
77 fromResult (HType (Result a)) = a
78 toResult = HType . Result
81instance (Sql DBType a, x ~ [a]) => ToExprs [a] (Expr x) where
82 fromResult (HType (Result a)) = a
83 toResult = HType . Result
86instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Maybe a) (Expr x)
87 where
88 fromResult (HType (Result a)) = a
89 toResult = HType . Result
92instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (NonEmpty a) (Expr x)
93 where
94 fromResult (HType (Result a)) = a
95 toResult = HType . Result
98instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
99 ToExprs (Either a b) x
100 where
101 fromResult =
102 bimap (fromResult' @exprs1) (fromResult' @exprs2) .
103 fromColumns
104 toResult =
105 toColumns .
106 bimap (toResult' @exprs1) (toResult' @exprs2)
109instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
110 fromResult = fmap (fromResult' @exprs) . fromColumns
111 toResult = toColumns . fmap (toResult' @exprs)
114instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
115 fromResult = fmap (fromResult' @exprs) . fromColumns
116 toResult = toColumns . fmap (toResult' @exprs)
119instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
120 where
121 fromResult = fmap (fromResult' @exprs) . fromColumns
122 toResult = toColumns . fmap (toResult' @exprs)
125instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
126 ToExprs (These a b) x
127 where
128 fromResult =
129 bimap (fromResult' @exprs1) (fromResult' @exprs2) .
130 fromColumns
131 toResult =
132 toColumns .
133 bimap (toResult' @exprs1) (toResult' @exprs2)
136instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
137 ToExprs (a, b) x
138 where
139 fromResult (HPair a b) =
140 ( fromResult' @exprs1 $ hunlabel unlabeler a
141 , fromResult' @exprs2 $ hunlabel unlabeler b
142 )
143 toResult (a, b) = HPair
144 { hfst = hlabel labeler $ toResult' @exprs1 a
145 , hsnd = hlabel labeler $ toResult' @exprs2 b
146 }
149instance
150 ( ToExprs a exprs1
151 , ToExprs b exprs2
152 , ToExprs c exprs3
153 , x ~ (exprs1, exprs2, exprs3)
154 ) => ToExprs (a, b, c) x
155 where
156 fromResult (HTrio a b c) =
157 ( fromResult' @exprs1 $ hunlabel unlabeler a
158 , fromResult' @exprs2 $ hunlabel unlabeler b
159 , fromResult' @exprs3 $ hunlabel unlabeler c
160 )
161 toResult (a, b, c) = HTrio
162 { hfst = hlabel labeler $ toResult' @exprs1 a
163 , hsnd = hlabel labeler $ toResult' @exprs2 b
164 , htrd = hlabel labeler $ toResult' @exprs3 c
165 }
168instance
169 ( ToExprs a exprs1
170 , ToExprs b exprs2
171 , ToExprs c exprs3
172 , ToExprs d exprs4
173 , x ~ (exprs1, exprs2, exprs3, exprs4)
174 ) => ToExprs (a, b, c, d) x
175 where
176 fromResult (HQuartet a b c d) =
177 ( fromResult' @exprs1 $ hunlabel unlabeler a
178 , fromResult' @exprs2 $ hunlabel unlabeler b
179 , fromResult' @exprs3 $ hunlabel unlabeler c
180 , fromResult' @exprs4 $ hunlabel unlabeler d
181 )
182 toResult (a, b, c, d) = HQuartet
183 { hfst = hlabel labeler $ toResult' @exprs1 a
184 , hsnd = hlabel labeler $ toResult' @exprs2 b
185 , htrd = hlabel labeler $ toResult' @exprs3 c
186 , hfrt = hlabel labeler $ toResult' @exprs4 d
187 }
190instance
191 ( ToExprs a exprs1
192 , ToExprs b exprs2
193 , ToExprs c exprs3
194 , ToExprs d exprs4
195 , ToExprs e exprs5
196 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
197 ) => ToExprs (a, b, c, d, e) x
198 where
199 fromResult (HQuintet a b c d e) =
200 ( fromResult' @exprs1 $ hunlabel unlabeler a
201 , fromResult' @exprs2 $ hunlabel unlabeler b
202 , fromResult' @exprs3 $ hunlabel unlabeler c
203 , fromResult' @exprs4 $ hunlabel unlabeler d
204 , fromResult' @exprs5 $ hunlabel unlabeler e
205 )
206 toResult (a, b, c, d, e) = HQuintet
207 { hfst = hlabel labeler $ toResult' @exprs1 a
208 , hsnd = hlabel labeler $ toResult' @exprs2 b
209 , htrd = hlabel labeler $ toResult' @exprs3 c
210 , hfrt = hlabel labeler $ toResult' @exprs4 d
211 , hfft = hlabel labeler $ toResult' @exprs5 e
212 }
215instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
216 ToExprs (t result) x
217 where
218 fromResult = id
219 toResult = id
222instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
223 ToExprs (t result) x
224 where
225 fromResult = fromColumns
226 toResult = toColumns
229instance (KnownSpec spec, x ~ Col Expr spec) =>
230 ToExprs (Col Result spec) x
231 where
232 fromResult = fromColumns
233 toResult = toColumns
236type FromExprs :: Type -> Type
237type family FromExprs a
238type instance FromExprs (Expr a) = a
239type instance FromExprs (Col Expr spec) = Col Result spec
240type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
241type instance FromExprs (ListTable a) = [FromExprs a]
242type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
243type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
244type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
245type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
246type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
247type instance FromExprs (a, b, c, d) =
248 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
249type instance FromExprs (a, b, c, d, e) =
250 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
251type instance FromExprs (t Expr) = t Result
252type instance FromExprs (t (Col Expr)) = t (Col Result)
255-- | @Serializable@ witnesses the one-to-one correspondence between the type
256-- @sql@, which contains SQL expressions, and the type @haskell@, which
257-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
258type Serializable :: Type -> Type -> Constraint
259class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
260instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
261instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
264-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
265-- capable of lifting single @Expr@s to full tables.
266lit :: forall exprs a. Serializable exprs a => a -> exprs
267lit = fromColumns . litHTable . toResult' @exprs
270parse :: forall exprs a. Serializable exprs a => Hasql.Row a
271parse = fromResult' @exprs <$> parseHTable
274type Encodes :: Type -> Type -> Constraint
275class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a
278instance KnownSpec spec => Encodes (Col Result spec) (Col Expr spec)
281instance Serializable (t Result) (t Expr) => Encodes (t Expr) (t Result)
284instance HTable t => Encodes (t (Col Result)) (t (Col Expr))
287instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)
290instance Encodes a x => Encodes [a] (ListTable x)
293instance Encodes a x => Encodes (Maybe a) (MaybeTable x)
296instance Encodes a x => Encodes (NonEmpty a) (NonEmptyTable x)
299instance (Encodes a x, Encodes b y) => Encodes (These a b) (TheseTable x y)
302instance (Encodes a x, Encodes b y) => Encodes (a, b) (x, y)
305instance (Encodes a x, Encodes b y, Encodes c z) =>
306 Encodes (a, b, c) (x, y, z)
309instance (Encodes a w, Encodes b x, Encodes c y, Encodes d z) =>
310 Encodes (a, b, c, d) (w, x, y, z)
313instance (Encodes a v, Encodes b w, Encodes c x, Encodes d y, Encodes e z) =>
314 Encodes (a, b, c, d, e) (v, w, x, y, z)
317litTable :: Encodes a exprs => a -> exprs
318litTable = lit
321litHTable :: HTable t => t (Col Result) -> t (Col Expr)
322litHTable as = htabulate $ \field ->
323 case hfield hspecs field of
324 SSpec {nullity, info} -> case hfield as field of
325 Result value -> DB (slitExpr nullity info value)
328parseHTable :: HTable t => Hasql.Row (t (Col Result))
329parseHTable = unwrapApplicative $ htabulateA $ \field ->
330 WrapApplicative $ case hfield hspecs field of
331 SSpec {nullity, info} -> Result <$> sparseValue nullity info