git.iko.soy/rel8
on 7c5422f help sign in
rel8/src/Rel8/Table/Serialize.hs
155 lines 4.2 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language FlexibleContexts #-}
3{-# language FlexibleInstances #-}
4{-# language FunctionalDependencies #-}
5{-# language NamedFieldPuns #-}
6{-# language ScopedTypeVariables #-}
7{-# language StandaloneKindSignatures #-}
8{-# language TypeApplications #-}
9{-# language TypeFamilies #-}
10{-# language UndecidableInstances #-}
12module Rel8.Table.Serialize
13 ( Serializable, lit, parse
14 , ToExprs
15 )
16where
18-- base
19import Data.Kind ( Constraint, Type )
20import Data.List.NonEmpty ( NonEmpty )
21import Prelude
23-- hasql
24import qualified Hasql.Decoders as Hasql
26-- rel8
27import Rel8.Expr ( Expr, Col( E ) )
28import Rel8.Expr.Serialize ( slitExpr, sparseValue )
29import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
30import Rel8.Schema.Null ( NotNull, Sql )
31import Rel8.Schema.Result ( Col( R ), Result )
32import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
33import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )
34import Rel8.Type ( DBType )
36-- semigroupoids
37import Data.Functor.Apply ( WrappedApplicative(..) )
40-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe
41-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is
42-- a normal Haskell type.
43type ToExprs :: Type -> Type -> Constraint
44class Table Expr exprs => ToExprs exprs a
47instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a
50instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]
53instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
56instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
59instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
60 ToExprs x (a, b)
63instance
64 ( ToExprs exprs1 a
65 , ToExprs exprs2 b
66 , ToExprs exprs3 c
67 , x ~ (exprs1, exprs2, exprs3)
68 )
69 => ToExprs x (a, b, c)
72instance
73 ( ToExprs exprs1 a
74 , ToExprs exprs2 b
75 , ToExprs exprs3 c
76 , ToExprs exprs4 d
77 , x ~ (exprs1, exprs2, exprs3, exprs4)
78 )
79 => ToExprs x (a, b, c, d)
82instance
83 ( ToExprs exprs1 a
84 , ToExprs exprs2 b
85 , ToExprs exprs3 c
86 , ToExprs exprs4 d
87 , ToExprs exprs5 e
88 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
89 )
90 => ToExprs x (a, b, c, d, e)
93instance
94 ( ToExprs exprs1 a
95 , ToExprs exprs2 b
96 , ToExprs exprs3 c
97 , ToExprs exprs4 d
98 , ToExprs exprs5 e
99 , ToExprs exprs6 f
100 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
101 )
102 => ToExprs x (a, b, c, d, e, f)
105instance
106 ( ToExprs exprs1 a
107 , ToExprs exprs2 b
108 , ToExprs exprs3 c
109 , ToExprs exprs4 d
110 , ToExprs exprs5 e
111 , ToExprs exprs6 f
112 , ToExprs exprs7 g
113 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
114 )
115 => ToExprs x (a, b, c, d, e, f, g)
118instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
119 ToExprs x (t result)
122instance (KnownSpec spec, x ~ Col Expr spec) =>
123 ToExprs x (Col Result spec)
126-- | @Serializable@ witnesses the one-to-one correspondence between the type
127-- @sql@, which contains SQL expressions, and the type @haskell@, which
128-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
129type Serializable :: Type -> Type -> Constraint
130class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
131instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
132instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
135-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
136-- capable of lifting single @Expr@s to full tables.
137lit :: forall exprs a. Serializable exprs a => a -> exprs
138lit = fromColumns . litHTable . toResult @_ @exprs
141parse :: forall exprs a. Serializable exprs a => Hasql.Row a
142parse = fromResult @_ @exprs <$> parseHTable
145litHTable :: HTable t => t (Col Result) -> t (Col Expr)
146litHTable as = htabulate $ \field ->
147 case hfield hspecs field of
148 SSpec {nullity, info} -> case hfield as field of
149 R value -> E (slitExpr nullity info value)
152parseHTable :: HTable t => Hasql.Row (t (Col Result))
153parseHTable = unwrapApplicative $ htabulateA $ \field ->
154 WrapApplicative $ case hfield hspecs field of
155 SSpec {nullity, info} -> R <$> sparseValue nullity info