git.iko.soy/rel8
on dc69cca help sign in
rel8/src/Rel8/Table/Serialize.hs
243 lines 7.0 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language DefaultSignatures #-}
4{-# language DisambiguateRecordFields #-}
5{-# language FlexibleContexts #-}
6{-# language FlexibleInstances #-}
7{-# language FunctionalDependencies #-}
8{-# language NamedFieldPuns #-}
9{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language TypeOperators #-}
14{-# language UndecidableInstances #-}
16module Rel8.Table.Serialize
17 ( Serializable, lit, parse
18 , ToExprs(..), FromExprs
19 , TToExprs
20 )
21where
23-- base
24import Data.Kind ( Constraint, Type )
25import Data.List.NonEmpty ( NonEmpty )
26import GHC.Generics ( Generic, Rep, from, to )
27import Prelude
29-- hasql
30import qualified Hasql.Decoders as Hasql
32-- rel8
33import Rel8.Expr ( Expr, Col(..) )
34import Rel8.Expr.Serialize ( slitExpr, sparseValue )
35import Rel8.FCF ( Eval, Exp )
36import Rel8.Generic.Record ( Record(..) )
37import Rel8.Generic.Table
38 ( GGToExprs, GGColumns, ggfromResult, ggtoResult
39 , GAlgebra
40 )
41import Rel8.Kind.Algebra ( KnownAlgebra )
42import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
43import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
44import Rel8.Schema.Null ( NotNull, Sql )
45import Rel8.Schema.Result ( Col( Result ), Result )
46import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
47import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )
48import Rel8.Type ( DBType )
50-- semigroupoids
51import Data.Functor.Apply ( WrappedApplicative(..) )
54type ToExprs :: Type -> Type -> Constraint
55class Table Expr exprs => ToExprs exprs a where
56 fromResult :: Columns exprs (Col Result) -> a
57 toResult :: a -> Columns exprs (Col Result)
59 default fromResult ::
60 ( Generic (Record a)
61 , KnownAlgebra (GAlgebra (Rep (Record exprs)))
62 , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
63 , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
64 )
65 => Columns exprs (Col Result) -> a
66 fromResult =
67 unrecord .
68 to .
69 ggfromResult
70 @(GAlgebra (Rep (Record exprs)))
71 @TToExprs
72 @TColumns
73 @(Rep (Record exprs))
74 (\(_ :: proxy expr) -> fromResult @expr)
76 default toResult ::
77 ( Generic (Record a)
78 , KnownAlgebra (GAlgebra (Rep (Record exprs)))
79 , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
80 , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
81 )
82 => a -> Columns exprs (Col Result)
83 toResult =
84 ggtoResult
85 @(GAlgebra (Rep (Record exprs)))
86 @TToExprs
87 @TColumns
88 @(Rep (Record exprs))
89 (\(_ :: proxy expr) -> toResult @expr) .
90 from .
91 Record
94data TToExprs :: Type -> Type -> Exp Constraint
95type instance Eval (TToExprs exprs a) = ToExprs exprs a
98instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
99 fromResult (HType (Result a)) = a
100 toResult = HType . Result
103instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
104 fromResult (HType (Result a)) = a
105 toResult = HType . Result
108instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
109 where
110 fromResult (HType (Result a)) = a
111 toResult = HType . Result
114instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
115 where
116 fromResult (HType (Result a)) = a
117 toResult = HType . Result
120instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
121 ToExprs x (a, b)
124instance
125 ( ToExprs exprs1 a
126 , ToExprs exprs2 b
127 , ToExprs exprs3 c
128 , x ~ (exprs1, exprs2, exprs3)
129 )
130 => ToExprs x (a, b, c)
133instance
134 ( ToExprs exprs1 a
135 , ToExprs exprs2 b
136 , ToExprs exprs3 c
137 , ToExprs exprs4 d
138 , x ~ (exprs1, exprs2, exprs3, exprs4)
139 )
140 => ToExprs x (a, b, c, d)
143instance
144 ( ToExprs exprs1 a
145 , ToExprs exprs2 b
146 , ToExprs exprs3 c
147 , ToExprs exprs4 d
148 , ToExprs exprs5 e
149 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
150 )
151 => ToExprs x (a, b, c, d, e)
154instance
155 ( ToExprs exprs1 a
156 , ToExprs exprs2 b
157 , ToExprs exprs3 c
158 , ToExprs exprs4 d
159 , ToExprs exprs5 e
160 , ToExprs exprs6 f
161 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
162 )
163 => ToExprs x (a, b, c, d, e, f)
166instance
167 ( ToExprs exprs1 a
168 , ToExprs exprs2 b
169 , ToExprs exprs3 c
170 , ToExprs exprs4 d
171 , ToExprs exprs5 e
172 , ToExprs exprs6 f
173 , ToExprs exprs7 g
174 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
175 )
176 => ToExprs x (a, b, c, d, e, f, g)
179instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
180 ToExprs x (t result)
181 where
182 fromResult = id
183 toResult = id
186instance (KnownSpec spec, x ~ Col Expr spec) =>
187 ToExprs x (Col Result spec)
188 where
189 fromResult = fromColumns
190 toResult = toColumns
193type FromExprs :: Type -> Type
194type family FromExprs a
195type instance FromExprs (Expr a) = a
196type instance FromExprs (Col Expr spec) = Col Result spec
197type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
198type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
199type instance FromExprs (a, b, c, d) =
200 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
201type instance FromExprs (a, b, c, d, e) =
202 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
203type instance FromExprs (a, b, c, d, e, f) =
204 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
205 , FromExprs f
206 )
207type instance FromExprs (a, b, c, d, e, f, g) =
208 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
209 , FromExprs f, FromExprs g
210 )
211type instance FromExprs (t (Col Expr)) = t (Col Result)
214-- | @Serializable@ witnesses the one-to-one correspondence between the type
215-- @sql@, which contains SQL expressions, and the type @haskell@, which
216-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
217type Serializable :: Type -> Type -> Constraint
218class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
219instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
220instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
223-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
224-- capable of lifting single @Expr@s to full tables.
225lit :: forall exprs a. Serializable exprs a => a -> exprs
226lit = fromColumns . litHTable . toResult @exprs
229parse :: forall exprs a. Serializable exprs a => Hasql.Row a
230parse = fromResult @exprs <$> parseHTable
233litHTable :: HTable t => t (Col Result) -> t (Col Expr)
234litHTable as = htabulate $ \field ->
235 case hfield hspecs field of
236 SSpec {nullity, info} -> case hfield as field of
237 Result value -> DB (slitExpr nullity info value)
240parseHTable :: HTable t => Hasql.Row (t (Col Result))
241parseHTable = unwrapApplicative $ htabulateA $ \field ->
242 WrapApplicative $ case hfield hspecs field of
243 SSpec {nullity, info} -> Result <$> sparseValue nullity info