git.iko.soy/rel8
on e0a1851 help sign in
rel8/src/Rel8/Table/Serialize.hs
151 lines 4.1 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, litHTable, 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( 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 ( Result( R ) )
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 (KnownSpec spec, x ~ Expr spec) =>
119 ToExprs x (Result spec)
122-- | @Serializable@ witnesses the one-to-one correspondence between the type
123-- @sql@, which contains SQL expressions, and the type @haskell@, which
124-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
125type Serializable :: Type -> Type -> Constraint
126class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
127instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
128instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
131-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
132-- capable of lifting single @Expr@s to full tables.
133lit :: forall exprs a. Serializable exprs a => a -> exprs
134lit = fromColumns . litHTable . toResult @_ @exprs
137parse :: forall exprs a. Serializable exprs a => Hasql.Row a
138parse = fromResult @_ @exprs <$> parseHTable
141litHTable :: HTable t => t Result -> t Expr
142litHTable as = htabulate $ \field ->
143 case hfield hspecs field of
144 SSpec {nullity, info} -> case hfield as field of
145 R value -> E (slitExpr nullity info value)
148parseHTable :: HTable t => Hasql.Row (t Result)
149parseHTable = unwrapApplicative $ htabulateA $ \field ->
150 WrapApplicative $ case hfield hspecs field of
151 SSpec {nullity, info} -> R <$> sparseValue nullity info