git.iko.soy/rel8
on f47423e help sign in
rel8/src/Rel8/Table/Serialize.hs
148 lines 4.0 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.Functor.Identity ( Identity( Identity ) )
20import Data.Kind ( Constraint, Type )
21import Data.List.NonEmpty ( NonEmpty )
22import Prelude
24-- hasql
25import qualified Hasql.Decoders as Hasql
27-- rel8
28import Rel8.Expr ( Expr )
29import Rel8.Expr.Serialize ( slitExpr, sparseValue )
30import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
31import Rel8.Schema.Null ( NotNull, Sql )
32import Rel8.Schema.Result ( Result )
33import Rel8.Schema.Spec ( Spec(..) )
34import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )
35import Rel8.Type ( DBType )
37-- semigroupoids
38import Data.Functor.Apply ( WrappedApplicative(..) )
41-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe
42-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is
43-- a normal Haskell type.
44type ToExprs :: Type -> Type -> Constraint
45class Table Expr exprs => ToExprs exprs a
48instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a
51instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]
54instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
57instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
60instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
61 ToExprs x (a, b)
64instance
65 ( ToExprs exprs1 a
66 , ToExprs exprs2 b
67 , ToExprs exprs3 c
68 , x ~ (exprs1, exprs2, exprs3)
69 )
70 => ToExprs x (a, b, c)
73instance
74 ( ToExprs exprs1 a
75 , ToExprs exprs2 b
76 , ToExprs exprs3 c
77 , ToExprs exprs4 d
78 , x ~ (exprs1, exprs2, exprs3, exprs4)
79 )
80 => ToExprs x (a, b, c, d)
83instance
84 ( ToExprs exprs1 a
85 , ToExprs exprs2 b
86 , ToExprs exprs3 c
87 , ToExprs exprs4 d
88 , ToExprs exprs5 e
89 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
90 )
91 => ToExprs x (a, b, c, d, e)
94instance
95 ( ToExprs exprs1 a
96 , ToExprs exprs2 b
97 , ToExprs exprs3 c
98 , ToExprs exprs4 d
99 , ToExprs exprs5 e
100 , ToExprs exprs6 f
101 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
102 )
103 => ToExprs x (a, b, c, d, e, f)
106instance
107 ( ToExprs exprs1 a
108 , ToExprs exprs2 b
109 , ToExprs exprs3 c
110 , ToExprs exprs4 d
111 , ToExprs exprs5 e
112 , ToExprs exprs6 f
113 , ToExprs exprs7 g
114 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
115 )
116 => ToExprs x (a, b, c, d, e, f, g)
119-- | @Serializable@ witnesses the one-to-one correspondence between the type
120-- @sql@, which contains SQL expressions, and the type @haskell@, which
121-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
122type Serializable :: Type -> Type -> Constraint
123class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
124instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
125instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
128-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
129-- capable of lifting single @Expr@s to full tables.
130lit :: forall exprs a. Serializable exprs a => a -> exprs
131lit = fromColumns . litHTable . toResult @_ @exprs
134parse :: forall exprs a. Serializable exprs a => Hasql.Row a
135parse = fromResult @_ @exprs <$> parseHTable
138litHTable :: HTable t => t Result -> t Expr
139litHTable as = htabulate $ \field ->
140 case hfield hspecs field of
141 Spec {nullity, info} -> case hfield as field of
142 Identity value -> slitExpr nullity info value
145parseHTable :: HTable t => Hasql.Row (t Result)
146parseHTable = unwrapApplicative $ htabulateA $ \field ->
147 WrapApplicative $ case hfield hspecs field of
148 Spec {nullity, info} -> Identity <$> sparseValue nullity info