git.iko.soy/rel8
on 2ba99ea help sign in
rel8/src/Rel8/Table/Serialize.hs
248 lines 7.3 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( E ) )
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( R ), 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(..) )
54-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe
55-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is
56-- in the 'Result' context.
57type ToExprs :: Type -> Type -> Constraint
58class Table Expr exprs => ToExprs exprs a where
59 fromResult :: Columns exprs (Col Result) -> a
60 toResult :: a -> Columns exprs (Col Result)
62 default fromResult ::
63 ( Generic (Record a)
64 , KnownAlgebra (GAlgebra (Rep (Record exprs)))
65 , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
66 , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
67 )
68 => Columns exprs (Col Result) -> a
69 fromResult =
70 unrecord .
71 to .
72 ggfromResult
73 @(GAlgebra (Rep (Record exprs)))
74 @TToExprs
75 @TColumns
76 @(Rep (Record exprs))
77 (\(_ :: proxy expr) -> fromResult @expr)
79 default toResult ::
80 ( Generic (Record a)
81 , KnownAlgebra (GAlgebra (Rep (Record exprs)))
82 , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
83 , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
84 )
85 => a -> Columns exprs (Col Result)
86 toResult =
87 ggtoResult
88 @(GAlgebra (Rep (Record exprs)))
89 @TToExprs
90 @TColumns
91 @(Rep (Record exprs))
92 (\(_ :: proxy expr) -> toResult @expr) .
93 from .
94 Record
97data TToExprs :: Type -> Type -> Exp Constraint
98type instance Eval (TToExprs exprs a) = ToExprs exprs a
101instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
102 fromResult (HType (R a)) = a
103 toResult = HType . R
106instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
107 fromResult (HType (R a)) = a
108 toResult = HType . R
111instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
112 where
113 fromResult (HType (R a)) = a
114 toResult = HType . R
117instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
118 where
119 fromResult (HType (R a)) = a
120 toResult = HType . R
123instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
124 ToExprs x (a, b)
127instance
128 ( ToExprs exprs1 a
129 , ToExprs exprs2 b
130 , ToExprs exprs3 c
131 , x ~ (exprs1, exprs2, exprs3)
132 )
133 => ToExprs x (a, b, c)
136instance
137 ( ToExprs exprs1 a
138 , ToExprs exprs2 b
139 , ToExprs exprs3 c
140 , ToExprs exprs4 d
141 , x ~ (exprs1, exprs2, exprs3, exprs4)
142 )
143 => ToExprs x (a, b, c, d)
146instance
147 ( ToExprs exprs1 a
148 , ToExprs exprs2 b
149 , ToExprs exprs3 c
150 , ToExprs exprs4 d
151 , ToExprs exprs5 e
152 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
153 )
154 => ToExprs x (a, b, c, d, e)
157instance
158 ( ToExprs exprs1 a
159 , ToExprs exprs2 b
160 , ToExprs exprs3 c
161 , ToExprs exprs4 d
162 , ToExprs exprs5 e
163 , ToExprs exprs6 f
164 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
165 )
166 => ToExprs x (a, b, c, d, e, f)
169instance
170 ( ToExprs exprs1 a
171 , ToExprs exprs2 b
172 , ToExprs exprs3 c
173 , ToExprs exprs4 d
174 , ToExprs exprs5 e
175 , ToExprs exprs6 f
176 , ToExprs exprs7 g
177 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
178 )
179 => ToExprs x (a, b, c, d, e, f, g)
182instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
183 ToExprs x (t result)
184 where
185 fromResult = id
186 toResult = id
189instance (KnownSpec spec, x ~ Col Expr spec) =>
190 ToExprs x (Col Result spec)
191 where
192 fromResult = fromColumns
193 toResult = toColumns
196-- | The @FromExprs@ type function maps a type in the @Expr@ context to the
197-- corresponding type in the @Result@ context.
198type FromExprs :: Type -> Type
199type family FromExprs a
200type instance FromExprs (Expr a) = a
201type instance FromExprs (Col Expr spec) = Col Result spec
202type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
203type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
204type instance FromExprs (a, b, c, d) =
205 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
206type instance FromExprs (a, b, c, d, e) =
207 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
208type instance FromExprs (a, b, c, d, e, f) =
209 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
210 , FromExprs f
211 )
212type instance FromExprs (a, b, c, d, e, f, g) =
213 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
214 , FromExprs f, FromExprs g
215 )
216type instance FromExprs (t (Col Expr)) = t (Col Result)
219-- | @Serializable@ witnesses the one-to-one correspondence between the type
220-- @sql@, which contains SQL expressions, and the type @haskell@, which
221-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
222type Serializable :: Type -> Type -> Constraint
223class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
224instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
225instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
228-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
229-- capable of lifting single @Expr@s to full tables.
230lit :: forall exprs a. Serializable exprs a => a -> exprs
231lit = fromColumns . litHTable . toResult @exprs
234parse :: forall exprs a. Serializable exprs a => Hasql.Row a
235parse = fromResult @exprs <$> parseHTable
238litHTable :: HTable t => t (Col Result) -> t (Col Expr)
239litHTable as = htabulate $ \field ->
240 case hfield hspecs field of
241 SSpec {nullity, info} -> case hfield as field of
242 R value -> E (slitExpr nullity info value)
245parseHTable :: HTable t => Hasql.Row (t (Col Result))
246parseHTable = unwrapApplicative $ htabulateA $ \field ->
247 WrapApplicative $ case hfield hspecs field of
248 SSpec {nullity, info} -> R <$> sparseValue nullity info