47e7842 · rel8 · git.iko.soy

git.iko.soy/rel8

Sketch of HKD-lifting of Generic types

commit47e7842c0f8eb7d8efe87a60000c7bfd875d44a5 authorShane O'Brien <shane.obrien@circuithub.com> dateFri 16 Apr 2021, 15:17 (6 years ago) parent242dc79

8 files changed+418−88

compare with master

unifiedsplit

cabal.project.haskell-nix+6 default.nix+1−1 rel8.cabal+2 src/Rel8.hs+4 src/Rel8/Schema/Field.hs+2−1 src/Rel8/Schema/Generic/Test.hs+26−4 src/Rel8/Schema/HKD.hs+303 src/Rel8/Table/Serialize.hs+74−82

cabal.project.haskell-nix+6

@@ -2,3 +2,9 @@

22-- will interpret them as local packages, and try to build them when we cabal

33-- build. The only reason we have to specify these is for Haskell.nix to know to

44-- override these packages by fetching them rather than using Hackage.

6+source-repository-package

7+ type: git

8+ location: git://github.com/jcpetruzza/barbies

9+ tag: f99b05454874192e3511bd133555dfb6cc6a6ecb

10+ --sha256: 0yy2i2jbllwavv5d2176rf8lmm4l1ws90lxkmdlfgvfzqxidx0gi

default.nix+1−1

@@ -5,7 +5,7 @@ let

66 nixpkgsArgs = haskellNix.nixpkgsArgs;

8− compiler-nix-name = "ghc901";

8+ compiler-nix-name = "ghc8104";

1010 pkgs = import nixpkgsSrc nixpkgsArgs;

1111

rel8.cabal+2

@@ -17,6 +17,7 @@ library

1717 , casing

1818 , contravariant

1919 , hasql ^>= 1.4.5.1

20+ , higgledy

2021 , opaleye ^>= 0.7.1.0

2122 , profunctors

2223 , scientific

@@ -93,6 +94,7 @@ library

9394 Rel8.Schema.Field

9495 Rel8.Schema.Generic

9596 Rel8.Schema.Generic.Test

97+ Rel8.Schema.HKD

9698 Rel8.Schema.HTable

9799 Rel8.Schema.HTable.Either

98100 Rel8.Schema.HTable.Identity

src/Rel8.hs+4

@@ -29,10 +29,12 @@ module Rel8

2929 , Rel8able, KRel8able

3030 , Column, Field, Necessity( Required, Optional )

3131 , Default

32+ , HEither

3233 , HMaybe

3334 , HList

3435 , HNonEmpty

3536 , HThese

37+ , Lift

3638

3739 , Table(..)

3840 , AltTable((<|>:))

@@ -236,6 +238,7 @@ module Rel8

236238 , ToExprs(..)

237239 , FromExprs

238240 , Result

241+ , HKDT(..)

239242 ) where

240243

241244-- base

@@ -275,6 +278,7 @@ import Rel8.Schema.Column

275278import Rel8.Schema.Context.Label

276279import Rel8.Schema.Field

277280import Rel8.Schema.Generic

281+import Rel8.Schema.HKD

278282import Rel8.Schema.HTable

279283import Rel8.Schema.Name

280284import Rel8.Schema.Null hiding ( nullable )

src/Rel8/Schema/Field.hs+2−1

@@ -11,9 +11,10 @@ module Rel8.Schema.Field

1111 ( Field

1212 , HEither, HList, HMaybe, HNonEmpty, HThese

1313 , Reify, hreify, hunreify

14− , Reifiable

14+ , Reifiable(..)

1515 , AField(..)

1616 , AHEither(..), AHList(..), AHMaybe(..), AHNonEmpty(..), AHThese(..)

17+ , SContext(..)

1718 )

1819where

1920

src/Rel8/Schema/Generic/Test.hs+26−4

@@ -1,8 +1,12 @@

11{-# language DataKinds #-}

22{-# language DeriveAnyClass #-}

33{-# language DeriveGeneric #-}

4−{-# language DerivingStrategies #-}

4+{-# language DerivingVia #-}

55{-# language DuplicateRecordFields #-}

6+{-# language FlexibleInstances #-}

7+{-# language MultiParamTypeClasses #-}

8+{-# language StandaloneDeriving #-}

9+{-# language TypeFamilies #-}

610

711module Rel8.Schema.Generic.Test

812 ( module Rel8.Schema.Generic.Test

@@ -13,10 +17,11 @@ where

1317import GHC.Generics ( Generic )

1418import Prelude

1519

20+-- higgledy

21+import Data.Generic.HKD ( HKD )

22+

1623-- rel8

17−import Rel8.Schema.Column

18−import Rel8.Schema.Field

19−import Rel8.Schema.Generic

24+import Rel8

2025

2126-- text

2227import Data.Text ( Text )

@@ -76,3 +81,20 @@ data TableNonEmpty f = TableNonEmpty

7681 }

7782 deriving stock Generic

7883 deriving anyclass Rel8able

84+

85+

86+data S3Object = S3Object

87+ { bucketName :: Text

88+ , objectKey :: Text

89+ } deriving stock Generic

90+

91+

92+deriving via HKDT S3Object

93+ instance x ~ HKD S3Object Expr => ToExprs x S3Object

94+

95+

96+data HKDTest f = HKDTest

97+ { s3Object :: Lift f S3Object

98+ }

99+ deriving stock Generic

100+ deriving anyclass Rel8able

src/Rel8/Schema/HKD.hsnew file+303

@@ -0,0 +1,303 @@

1+{-# language AllowAmbiguousTypes #-}

2+{-# language BlockArguments #-}

3+{-# language ConstraintKinds #-}

4+{-# language DataKinds #-}

5+{-# language FlexibleContexts #-}

6+{-# language FlexibleInstances #-}

7+{-# language FunctionalDependencies #-}

8+{-# language GADTs #-}

9+{-# language LambdaCase #-}

10+{-# language QuantifiedConstraints #-}

11+{-# language PolyKinds #-}

12+{-# language RankNTypes #-}

13+{-# language ScopedTypeVariables #-}

14+{-# language StandaloneKindSignatures #-}

15+{-# language TypeApplications #-}

16+{-# language TypeFamilyDependencies #-}

17+{-# language TypeOperators #-}

18+{-# language UndecidableInstances #-}

19+{-# language UndecidableSuperClasses #-}

20+

21+{-# options -Wno-orphans #-}

22+

23+module Rel8.Schema.HKD

24+ ( Lift

25+ , HKDT(..)

26+ ) where

27+

28+-- base

29+import Data.Functor.Compose ( Compose(..) )

30+import Data.Functor.Identity ( Identity(..), runIdentity )

31+import Data.Kind ( Constraint, Type )

32+import GHC.Generics

33+ ( (:*:)( (:*:) ), K1( K1 ), M1( M1 ), C, D, S, Meta( MetaSel )

34+ , Rep

35+ )

36+import GHC.TypeLits ( KnownSymbol )

37+import Prelude

38+

39+-- higgledy

40+import Data.Generic.HKD ( Construct, HKD( HKD, runHKD ), GHKD_, construct, deconstruct )

41+

42+-- rel8

43+import Rel8.Aggregate ( Col(..), Aggregate )

44+import Rel8.Expr ( Expr )

45+import Rel8.Schema.Context.Label

46+ ( Labelable

47+ , HLabelable, hlabeler, hunlabeler

48+ )

49+import Rel8.Schema.Dict ( Dict( Dict ) )

50+import Rel8.Schema.Field ( Reify, Reifiable(..), SContext(..), hunreify, hreify )

51+import Rel8.Schema.HTable ( HTable )

52+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

53+import Rel8.Schema.HTable.Pair ( HPair( HPair ) )

54+import Rel8.Schema.HTable.Type ( HType( HType ) )

55+import Rel8.Schema.Insert ( Insert, Col(..) )

56+import qualified Rel8.Schema.Kind as K

57+import Rel8.Schema.Name ( Name(..) )

58+import Rel8.Schema.Null ( Sql )

59+import Rel8.Schema.Result ( Result )

60+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

61+import Rel8.Table.Recontextualize ( Recontextualize )

62+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

63+import Rel8.Type ( DBType )

64+

65+

66+type Column1Helper :: K.Context -> (Type -> Type) -> Type -> Constraint

67+class

68+ ( Table context (f a)

69+ , Context1 f ~ context

70+ , Context (f a) ~ context

71+ , Columns (f a) ~ HType a

72+ )

73+ => Column1Helper context f a | f -> context

74+instance

75+ ( Table context (f a)

76+ , Context1 f ~ context

77+ , Context (f a) ~ context

78+ , Columns (f a) ~ HType a

79+ )

80+ => Column1Helper context f a

81+

82+

83+type Column1 :: K.Context -> (Type -> Type) -> Constraint

84+class

85+ ( forall a. Sql DBType a => Column1Helper context f a

86+ , Context1 f ~ context

87+ ) =>

88+ Column1 context f | f -> context

89+instance

90+ ( forall a. Sql DBType a => Column1Helper context f a

91+ , Context1 f ~ context

92+ ) =>

93+ Column1 context f

94+

95+

96+type Context1 :: (Type -> Type) -> K.Context

97+type Context1 f = Context (f Bool)

98+

99+

100+toColumn1 :: forall a f context. (Column1 context f, Sql DBType a)

101+ => f a -> HType a (Col context)

102+toColumn1 = case Dict @(Column1Helper context f) @a of

103+ Dict -> toColumns

104+

105+

106+fromColumn1 :: forall a f context. (Column1 context f, Sql DBType a)

107+ => HType a (Col context) -> f a

108+fromColumn1 = case Dict @(Column1Helper context f) @a of

109+ Dict -> fromColumns

110+

111+

112+type Recontextualize1

113+ :: K.Context

114+ -> K.Context

115+ -> (Type -> Type)

116+ -> (Type -> Type)

117+ -> Constraint

118+class Recontextualize context context' (f Bool) (f' Bool) =>

119+ Recontextualize1 context context' f f'

120+instance Recontextualize context context' (f Bool) (f' Bool) =>

121+ Recontextualize1 context context' f f'

122+

123+

124+class HTable (GColumns rep) => GTable rep where

125+ toGColumns :: HLabelable context

126+ => (forall a. Sql DBType a => f a -> HType a context)

127+ -> GHKD_ f rep x

128+ -> GColumns rep context

129+ fromGColumns :: HLabelable context

130+ => (forall a. Sql DBType a => HType a context -> f a)

131+ -> GColumns rep context

132+ -> GHKD_ f rep x

133+

134+

135+instance GTable rep => GTable (M1 D c rep) where

136+ toGColumns f (M1 a) = toGColumns f a

137+ {-# INLINABLE toGColumns #-}

138+

139+ fromGColumns f = M1 . fromGColumns f

140+ {-# INLINABLE fromGColumns #-}

141+

142+

143+instance GTable rep => GTable (M1 C c rep) where

144+ toGColumns f (M1 a) = toGColumns f a

145+ {-# INLINABLE toGColumns #-}

146+

147+ fromGColumns f = M1 . fromGColumns f

148+ {-# INLINABLE fromGColumns #-}

149+

150+

151+instance (KnownSymbol name, Sql DBType a) =>

152+ GTable (M1 S ('MetaSel ('Just name) _su _ss _ds) (K1 i a))

153+ where

154+ toGColumns f (M1 (K1 a)) = hlabel hlabeler (f a)

155+ {-# INLINABLE toGColumns #-}

156+

157+ fromGColumns f a = M1 (K1 (f (hunlabel hunlabeler a)))

158+ {-# INLINABLE fromGColumns #-}

159+

160+

161+instance (GTable f, GTable g) => GTable (f :*: g) where

162+ toGColumns f (x :*: y) = HPair (toGColumns f x) (toGColumns f y)

163+ {-# INLINABLE toGColumns #-}

164+

165+ fromGColumns f (HPair x y) = fromGColumns f x :*: fromGColumns f y

166+ {-# INLINABLE fromGColumns #-}

167+

168+

169+type GRep a = GColumns (Rep a)

170+

171+

172+type GColumns :: (Type -> Type) -> K.HTable

173+type family GColumns rep where

174+ GColumns (M1 D _ f) = GColumns f

175+ GColumns (M1 C _ f) = GColumns f

176+ GColumns (M1 S ('MetaSel ('Just name) _ _ _) (K1 _ a)) =

177+ HLabel name (HType a)

178+ GColumns (f :*: g) = HPair (GColumns f) (GColumns g)

179+

180+

181+instance (GTable (Rep a), Column1 context f, Labelable context) =>

182+ Table context (HKD a f)

183+ where

184+ type Columns (HKD a f) = GRep a

185+ type Context (HKD a f) = Context1 f

186+

187+ toColumns = toGColumns toColumn1 . runHKD

188+ fromColumns = HKD . fromGColumns fromColumn1

189+

190+

191+instance

192+ ( a ~ a'

193+ , GTable (Rep a)

194+ , Recontextualize1 context context' f f'

195+ , Column1 context f, Labelable context

196+ , Column1 context' f', Labelable context'

197+ ) =>

198+ Recontextualize

199+ context

200+ context'

201+ (HKD a f)

202+ (HKD a' f')

203+

204+

205+type Lift :: K.Context -> Type -> Type

206+type family Lift context a where

207+ Lift (Reify context) a = ALift context a

208+ Lift Aggregate a = HKD a (Compose Aggregate Expr)

209+ Lift Expr a = HKD a Expr

210+ Lift Insert a = HKD a Expr

211+ Lift Name a = HKD a Name

212+ Lift Result a = a

213+

214+

215+type ALift :: K.Context -> Type -> Type

216+newtype ALift context a = ALift

217+ { unALift :: Lift context a

218+ }

219+

220+

221+instance

222+ ( Reifiable context

223+ , GTable (Rep a)

224+ , Construct Identity a

225+ )

226+ => Table (Reify context) (ALift context a)

227+ where

228+ type Context (ALift context a) = Reify context

229+ type Columns (ALift context a) = GRep a

230+

231+ fromColumns = sfromColumnsLift contextSing

232+ toColumns = stoColumnsLift contextSing

233+

234+

235+instance

236+ ( Reifiable context

237+ , Reifiable context'

238+ , GTable (Rep a)

239+ , Construct Identity a

240+ )

241+ => Recontextualize

242+ (Reify context)

243+ (Reify context')

244+ (ALift context a)

245+ (ALift context' a)

246+

247+

248+sfromColumnsLift :: forall a context. (GTable (Rep a), Construct Identity a)

249+ => SContext context

250+ -> GRep a (Col (Reify context))

251+ -> ALift context a

252+sfromColumnsLift = \case

253+ SAggregate ->

254+ ALift .

255+ HKD .

256+ fromGColumns (\(HType (Aggregation a)) -> Compose a) .

257+ hunreify

258+ SExpr -> ALift . fromColumns . hunreify

259+ SInsert ->

260+ ALift .

261+ HKD .

262+ fromGColumns (\(HType (RequiredInsert a)) -> a) .

263+ hunreify

264+ SName -> ALift . fromColumns . hunreify

265+ SResult -> ALift . runIdentity . construct . fromColumns . hunreify

266+ SReify context -> ALift . sfromColumnsLift context . hunreify

267+

268+

269+stoColumnsLift :: forall a context. (GTable (Rep a), Construct Identity a)

270+ => SContext context

271+ -> ALift context a

272+ -> GRep a (Col (Reify context))

273+stoColumnsLift = \case

274+ SAggregate ->

275+ hreify .

276+ toGColumns (\(Compose a) -> HType (Aggregation a)) .

277+ runHKD .

278+ unALift

279+ SExpr -> hreify . toColumns . unALift

280+ SInsert ->

281+ hreify .

282+ toGColumns (HType . RequiredInsert) .

283+ runHKD .

284+ unALift

285+ SName -> hreify . toColumns . unALift

286+ SResult -> hreify . toColumns . deconstruct @Identity . unALift

287+ SReify context -> hreify . stoColumnsLift context . unALift

288+

289+

290+type HKDT :: Type -> Type

291+newtype HKDT a = HKDT

292+ { unHKDT :: a

293+ }

294+

295+

296+instance (GTable (Rep a), Construct Identity a, x ~ HKD a Expr) =>

297+ ToExprs x (HKDT a)

298+ where

299+ toResult = toColumns . deconstruct @Identity . unHKDT

300+ fromResult = HKDT . runIdentity . construct . fromColumns

301+

302+

303+type instance FromExprs (HKD a Expr) = a

src/Rel8/Table/Serialize.hs+74−82

@@ -59,175 +59,167 @@ import Data.Functor.Apply ( WrappedApplicative(..) )

5959import Data.These ( These )

6060

6161

62−fromResult' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Result) -> a

63−fromResult' = fromResult @_ @exprs

64−

65−

66−toResult' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Result)

67−toResult' = toResult @_ @exprs

68−

69−

7062type ToExprs :: Type -> Type -> Constraint

71−class Table Expr exprs => ToExprs a exprs where

63+class Table Expr exprs => ToExprs exprs a where

7264 fromResult :: Columns exprs (Col Result) -> a

7365 toResult :: a -> Columns exprs (Col Result)

7466

7567

76−instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs a x where

68+instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where

7769 fromResult (HType (Result a)) = a

7870 toResult = HType . Result

7971

8072

81−instance (Sql DBType a, x ~ [a]) => ToExprs [a] (Expr x) where

73+instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where

8274 fromResult (HType (Result a)) = a

8375 toResult = HType . Result

8476

8577

86−instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Maybe a) (Expr x)

78+instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)

8779 where

8880 fromResult (HType (Result a)) = a

8981 toResult = HType . Result

9082

9183

92−instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (NonEmpty a) (Expr x)

84+instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)

9385 where

9486 fromResult (HType (Result a)) = a

9587 toResult = HType . Result

9688

9789

98−instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>

99− ToExprs (Either a b) x

90+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>

91+ ToExprs x (Either a b)

10092 where

10193 fromResult =

102− bimap (fromResult' @exprs1) (fromResult' @exprs2) .

94+ bimap (fromResult @exprs1) (fromResult @exprs2) .

10395 fromColumns

10496 toResult =

10597 toColumns .

106− bimap (toResult' @exprs1) (toResult' @exprs2)

98+ bimap (toResult @exprs1) (toResult @exprs2)

10799

108100

109−instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where

110− fromResult = fmap (fromResult' @exprs) . fromColumns

111− toResult = toColumns . fmap (toResult' @exprs)

101+instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where

102+ fromResult = fmap (fromResult @exprs) . fromColumns

103+ toResult = toColumns . fmap (toResult @exprs)

112104

113105

114−instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where

115− fromResult = fmap (fromResult' @exprs) . fromColumns

116− toResult = toColumns . fmap (toResult' @exprs)

106+instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where

107+ fromResult = fmap (fromResult @exprs) . fromColumns

108+ toResult = toColumns . fmap (toResult @exprs)

117109

118110

119−instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)

111+instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)

120112 where

121− fromResult = fmap (fromResult' @exprs) . fromColumns

122− toResult = toColumns . fmap (toResult' @exprs)

113+ fromResult = fmap (fromResult @exprs) . fromColumns

114+ toResult = toColumns . fmap (toResult @exprs)

123115

124116

125−instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>

126− ToExprs (These a b) x

117+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>

118+ ToExprs x (These a b)

127119 where

128120 fromResult =

129− bimap (fromResult' @exprs1) (fromResult' @exprs2) .

121+ bimap (fromResult @exprs1) (fromResult @exprs2) .

130122 fromColumns

131123 toResult =

132124 toColumns .

133− bimap (toResult' @exprs1) (toResult' @exprs2)

125+ bimap (toResult @exprs1) (toResult @exprs2)

134126

135127

136−instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>

137− ToExprs (a, b) x

128+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>

129+ ToExprs x (a, b)

138130 where

139131 fromResult (HPair a b) =

140− ( fromResult' @exprs1 $ hunlabel unlabeler a

141− , fromResult' @exprs2 $ hunlabel unlabeler b

132+ ( fromResult @exprs1 $ hunlabel unlabeler a

133+ , fromResult @exprs2 $ hunlabel unlabeler b

142134 )

143135 toResult (a, b) = HPair

144− { hfst = hlabel labeler $ toResult' @exprs1 a

145− , hsnd = hlabel labeler $ toResult' @exprs2 b

136+ { hfst = hlabel labeler $ toResult @exprs1 a

137+ , hsnd = hlabel labeler $ toResult @exprs2 b

146138 }

147139

148140

149141instance

150− ( ToExprs a exprs1

151− , ToExprs b exprs2

152− , ToExprs c exprs3

142+ ( ToExprs exprs1 a

143+ , ToExprs exprs2 b

144+ , ToExprs exprs3 c

153145 , x ~ (exprs1, exprs2, exprs3)

154− ) => ToExprs (a, b, c) x

146+ ) => ToExprs x (a, b, c)

155147 where

156148 fromResult (HTrio a b c) =

157− ( fromResult' @exprs1 $ hunlabel unlabeler a

158− , fromResult' @exprs2 $ hunlabel unlabeler b

159− , fromResult' @exprs3 $ hunlabel unlabeler c

149+ ( fromResult @exprs1 $ hunlabel unlabeler a

150+ , fromResult @exprs2 $ hunlabel unlabeler b

151+ , fromResult @exprs3 $ hunlabel unlabeler c

160152 )

161153 toResult (a, b, c) = HTrio

162− { hfst = hlabel labeler $ toResult' @exprs1 a

163− , hsnd = hlabel labeler $ toResult' @exprs2 b

164− , htrd = hlabel labeler $ toResult' @exprs3 c

154+ { hfst = hlabel labeler $ toResult @exprs1 a

155+ , hsnd = hlabel labeler $ toResult @exprs2 b

156+ , htrd = hlabel labeler $ toResult @exprs3 c

165157 }

166158

167159

168160instance

169− ( ToExprs a exprs1

170− , ToExprs b exprs2

171− , ToExprs c exprs3

172− , ToExprs d exprs4

161+ ( ToExprs exprs1 a

162+ , ToExprs exprs2 b

163+ , ToExprs exprs3 c

164+ , ToExprs exprs4 d

173165 , x ~ (exprs1, exprs2, exprs3, exprs4)

174− ) => ToExprs (a, b, c, d) x

166+ ) => ToExprs x (a, b, c, d)

175167 where

176168 fromResult (HQuartet a b c d) =

177− ( fromResult' @exprs1 $ hunlabel unlabeler a

178− , fromResult' @exprs2 $ hunlabel unlabeler b

179− , fromResult' @exprs3 $ hunlabel unlabeler c

180− , fromResult' @exprs4 $ hunlabel unlabeler d

169+ ( fromResult @exprs1 $ hunlabel unlabeler a

170+ , fromResult @exprs2 $ hunlabel unlabeler b

171+ , fromResult @exprs3 $ hunlabel unlabeler c

172+ , fromResult @exprs4 $ hunlabel unlabeler d

181173 )

182174 toResult (a, b, c, d) = HQuartet

183− { hfst = hlabel labeler $ toResult' @exprs1 a

184− , hsnd = hlabel labeler $ toResult' @exprs2 b

185− , htrd = hlabel labeler $ toResult' @exprs3 c

186− , hfrt = hlabel labeler $ toResult' @exprs4 d

175+ { hfst = hlabel labeler $ toResult @exprs1 a

176+ , hsnd = hlabel labeler $ toResult @exprs2 b

177+ , htrd = hlabel labeler $ toResult @exprs3 c

178+ , hfrt = hlabel labeler $ toResult @exprs4 d

187179 }

188180

189181

190182instance

191− ( ToExprs a exprs1

192− , ToExprs b exprs2

193− , ToExprs c exprs3

194− , ToExprs d exprs4

195− , ToExprs e exprs5

183+ ( ToExprs exprs1 a

184+ , ToExprs exprs2 b

185+ , ToExprs exprs3 c

186+ , ToExprs exprs4 d

187+ , ToExprs exprs5 e

196188 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)

197− ) => ToExprs (a, b, c, d, e) x

189+ ) => ToExprs x (a, b, c, d, e)

198190 where

199191 fromResult (HQuintet a b c d e) =

200− ( fromResult' @exprs1 $ hunlabel unlabeler a

201− , fromResult' @exprs2 $ hunlabel unlabeler b

202− , fromResult' @exprs3 $ hunlabel unlabeler c

203− , fromResult' @exprs4 $ hunlabel unlabeler d

204− , fromResult' @exprs5 $ hunlabel unlabeler e

192+ ( fromResult @exprs1 $ hunlabel unlabeler a

193+ , fromResult @exprs2 $ hunlabel unlabeler b

194+ , fromResult @exprs3 $ hunlabel unlabeler c

195+ , fromResult @exprs4 $ hunlabel unlabeler d

196+ , fromResult @exprs5 $ hunlabel unlabeler e

205197 )

206198 toResult (a, b, c, d, e) = HQuintet

207− { hfst = hlabel labeler $ toResult' @exprs1 a

208− , hsnd = hlabel labeler $ toResult' @exprs2 b

209− , htrd = hlabel labeler $ toResult' @exprs3 c

210− , hfrt = hlabel labeler $ toResult' @exprs4 d

211− , hfft = hlabel labeler $ toResult' @exprs5 e

199+ { hfst = hlabel labeler $ toResult @exprs1 a

200+ , hsnd = hlabel labeler $ toResult @exprs2 b

201+ , htrd = hlabel labeler $ toResult @exprs3 c

202+ , hfrt = hlabel labeler $ toResult @exprs4 d

203+ , hfft = hlabel labeler $ toResult @exprs5 e

212204 }

213205

214206

215207instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>

216− ToExprs (t result) x

208+ ToExprs x (t result)

217209 where

218210 fromResult = id

219211 toResult = id

220212

221213

222214instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>

223− ToExprs (t result) x

215+ ToExprs x (t result)

224216 where

225217 fromResult = fromColumns

226218 toResult = toColumns

227219

228220

229221instance (KnownSpec spec, x ~ Col Expr spec) =>

230− ToExprs (Col Result spec) x

222+ ToExprs x (Col Result spec)

231223 where

232224 fromResult = fromColumns

233225 toResult = toColumns

@@ -256,19 +248,19 @@ type instance FromExprs (t (Col Expr)) = t (Col Result)

256248-- @sql@, which contains SQL expressions, and the type @haskell@, which

257249-- contains the Haskell decoding of rows containing @sql@ SQL expressions.

258250type Serializable :: Type -> Type -> Constraint

259−class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a

260−instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a

251+class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a

252+instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a

261253instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a

262254

263255

264256-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is

265257-- capable of lifting single @Expr@s to full tables.

266258lit :: forall exprs a. Serializable exprs a => a -> exprs

267−lit = fromColumns . litHTable . toResult' @exprs

259+lit = fromColumns . litHTable . toResult @exprs

268260

269261

270262parse :: forall exprs a. Serializable exprs a => Hasql.Row a

271−parse = fromResult' @exprs <$> parseHTable

263+parse = fromResult @exprs <$> parseHTable

272264

273265

274266type Encodes :: Type -> Type -> Constraint