fb21075 · rel8 · git.iko.soy

git.iko.soy/rel8

Add better generic deriving for EqTable, OrdTable and ToExprs

This builds upon the `Rel8.Generic.Record` machinery introduced in the previous commit. It means that we can use generic implementations of the `Table`, `EqTable`, `OrdTable` and `ToExprs` for all tuple types, rendering `HPair`, `HTrio`, `HQuartet` and `HQuintet` unnecessary (this commit removes them).

commitfb2107513e13c07f9dc4d2e1aca9b4492e42c965 authorShane O'Brien <shane.obrien@circuithub.com> dateSun 18 Apr 2021, 16:35 (6 years ago) parent6d3959e

13 files changed+227−361

compare with master

unifiedsplit

rel8.cabal+1−4 src/Rel8/Generic/Record.hs+5−1 src/Rel8/Schema/HKD.hs+4−4 src/Rel8/Schema/HTable.hs+15−15 src/Rel8/Schema/HTable/Pair.hs−20 src/Rel8/Schema/HTable/Product.hs+17 src/Rel8/Schema/HTable/Quartet.hs−29 src/Rel8/Schema/HTable/Quintet.hs−30 src/Rel8/Schema/HTable/Trio.hs−28 src/Rel8/Table.hs+14−94 src/Rel8/Table/Eq.hs+49−40 src/Rel8/Table/Ord.hs+52−39 src/Rel8/Table/Serialize.hs+70−57

rel8.cabal+1−4

@@ -106,11 +106,8 @@ library

106106 Rel8.Schema.HTable.Maybe

107107 Rel8.Schema.HTable.NonEmpty

108108 Rel8.Schema.HTable.Nullify

109− Rel8.Schema.HTable.Pair

110− Rel8.Schema.HTable.Quartet

111− Rel8.Schema.HTable.Quintet

109+ Rel8.Schema.HTable.Product

112110 Rel8.Schema.HTable.These

113− Rel8.Schema.HTable.Trio

114111 Rel8.Schema.HTable.Type

115112 Rel8.Schema.HTable.Vectorize

116113 Rel8.Schema.Insert

src/Rel8/Generic/Record.hs+5−1

@@ -18,7 +18,11 @@ where

1818-- base

1919import Data.Kind ( Constraint, Type )

2020import GHC.Generics

21−import GHC.TypeLits

21+ ( Generic, Rep, from, to

22+ , (:+:)( L1, R1 ), (:*:)( (:*:) ), M1( M1 )

23+ , Meta( MetaCons, MetaSel ), D, C, S

24+ )

25+import GHC.TypeLits ( type (+), AppendSymbol, Div, Mod, Nat, Symbol )

2226import Prelude hiding ( Show )

2327

2428

src/Rel8/Schema/HKD.hs+4−4

@@ -50,7 +50,7 @@ import Rel8.Schema.Dict ( Dict( Dict ) )

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

5151import Rel8.Schema.HTable ( HTable )

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

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

53+import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

5454import Rel8.Schema.HTable.Type ( HType( HType ) )

5555import Rel8.Schema.Insert ( Insert, Col(..) )

5656import qualified Rel8.Schema.Kind as K

@@ -159,10 +159,10 @@ instance (KnownSymbol name, Sql DBType a) =>

159159

160160

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

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

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

163163 {-# INLINABLE toGColumns #-}

164164

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

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

166166 {-# INLINABLE fromGColumns #-}

167167

168168

@@ -175,7 +175,7 @@ type family GColumns rep where

175175 GColumns (M1 C _ f) = GColumns f

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

177177 HLabel name (HType a)

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

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

179179

180180

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

src/Rel8/Schema/HTable.hs+15−15

@@ -35,7 +35,7 @@ import Prelude

3535-- rel8

3636import Rel8.Schema.Dict ( Dict )

3737import Rel8.Schema.Spec ( Spec, SSpec )

38−import Rel8.Schema.HTable.Pair ( HPair( HPair ) )

38+import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

3939import qualified Rel8.Schema.Kind as K

4040

4141-- semigroupoids

@@ -144,30 +144,30 @@ instance HTable table => GHTable context (K1 i (table context)) where

144144

145145

146146instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where

147− type GHColumns (a :*: b) = HPair (GHColumns a) (GHColumns b)

148− toGHColumns (a :*: b) = HPair (toGHColumns a) (toGHColumns b)

149− fromGHColumns (HPair a b) = fromGHColumns a :*: fromGHColumns b

147+ type GHColumns (a :*: b) = HProduct (GHColumns a) (GHColumns b)

148+ toGHColumns (a :*: b) = HProduct (toGHColumns a) (toGHColumns b)

149+ fromGHColumns (HProduct a b) = fromGHColumns a :*: fromGHColumns b

150150

151151

152−-- | A HField type for indexing into HPair.

153−type HPairField :: K.HTable -> K.HTable -> Spec -> Type

154−data HPairField x y spec

152+-- | A HField type for indexing into HProduct.

153+type HProductField :: K.HTable -> K.HTable -> Spec -> Type

154+data HProductField x y spec

155155 = HFst (HField x spec)

156156 | HSnd (HField y spec)

157157

158158

159−instance (HTable x, HTable y) => HTable (HPair x y) where

160− type HConstrainTable (HPair x y) c = (HConstrainTable x c, HConstrainTable y c)

161− type HField (HPair x y) = HPairField x y

159+instance (HTable x, HTable y) => HTable (HProduct x y) where

160+ type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c)

161+ type HField (HProduct x y) = HProductField x y

162162

163− hfield (HPair l r) = \case

163+ hfield (HProduct l r) = \case

164164 HFst i -> hfield l i

165165 HSnd i -> hfield r i

166166

167− htabulate f = HPair (htabulate (f . HFst)) (htabulate (f . HSnd))

168− htraverse f (HPair x y) = HPair <$> htraverse f x <.> htraverse f y

169− hdicts = HPair hdicts hdicts

170− hspecs = HPair hspecs hspecs

167+ htabulate f = HProduct (htabulate (f . HFst)) (htabulate (f . HSnd))

168+ htraverse f (HProduct x y) = HProduct <$> htraverse f x <.> htraverse f y

169+ hdicts = HProduct hdicts hdicts

170+ hspecs = HProduct hspecs hspecs

171171

172172 {-# INLINABLE hfield #-}

173173 {-# INLINABLE htabulate #-}

src/Rel8/Schema/HTable/Pair.hsdeleted−20

@@ -1,20 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language StandaloneKindSignatures #-}

3−

4−module Rel8.Schema.HTable.Pair

5− ( HPair(..)

6− )

7−where

8−

9−-- base

10−import Prelude ()

11−

12−-- rel8

13−import qualified Rel8.Schema.Kind as K

14−

15−

16−type HPair :: K.HTable -> K.HTable -> K.HTable

17−data HPair fst snd context = HPair

18− { hfst :: fst context

19− , hsnd :: snd context

20− }

src/Rel8/Schema/HTable/Product.hsnew file+17

@@ -0,0 +1,17 @@

1+{-# language DataKinds #-}

2+{-# language StandaloneKindSignatures #-}

4+module Rel8.Schema.HTable.Product

5+ ( HProduct(..)

6+ )

7+where

9+-- base

10+import Prelude ()

11+

12+-- rel8

13+import qualified Rel8.Schema.Kind as K

14+

15+

16+type HProduct :: K.HTable -> K.HTable -> K.HTable

17+data HProduct a b context = HProduct (a context) (b context)

src/Rel8/Schema/HTable/Quartet.hsdeleted−29

@@ -1,29 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language DeriveAnyClass #-}

3−{-# language DeriveGeneric #-}

4−{-# language DerivingStrategies #-}

5−{-# language StandaloneKindSignatures #-}

6−

7−module Rel8.Schema.HTable.Quartet

8− ( HQuartet(..)

9− )

10−where

11−

12−-- base

13−import GHC.Generics ( Generic )

14−import Prelude ()

15−

16−-- rel8

17−import Rel8.Schema.HTable ( HTable )

18−import qualified Rel8.Schema.Kind as K

19−

20−

21−type HQuartet :: K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable

22−data HQuartet w x y z context = HQuartet

23− { hfst :: w context

24− , hsnd :: x context

25− , htrd :: y context

26− , hfrt :: z context

27− }

28− deriving stock Generic

29− deriving anyclass HTable

src/Rel8/Schema/HTable/Quintet.hsdeleted−30

@@ -1,30 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language DeriveAnyClass #-}

3−{-# language DeriveGeneric #-}

4−{-# language DerivingStrategies #-}

5−{-# language StandaloneKindSignatures #-}

6−

7−module Rel8.Schema.HTable.Quintet

8− ( HQuintet(..)

9− )

10−where

11−

12−-- base

13−import GHC.Generics ( Generic )

14−import Prelude ()

15−

16−-- rel8

17−import Rel8.Schema.HTable ( HTable )

18−import qualified Rel8.Schema.Kind as K

19−

20−

21−type HQuintet :: K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable

22−data HQuintet v w x y z context = HQuintet

23− { hfst :: v context

24− , hsnd :: w context

25− , htrd :: x context

26− , hfrt :: y context

27− , hfft :: z context

28− }

29− deriving stock Generic

30− deriving anyclass HTable

src/Rel8/Schema/HTable/Trio.hsdeleted−28

@@ -1,28 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language DeriveAnyClass #-}

3−{-# language DeriveGeneric #-}

4−{-# language DerivingStrategies #-}

5−{-# language StandaloneKindSignatures #-}

6−

7−module Rel8.Schema.HTable.Trio

8− ( HTrio(..)

9− )

10−where

11−

12−-- base

13−import GHC.Generics ( Generic )

14−import Prelude ()

15−

16−-- rel8

17−import Rel8.Schema.HTable ( HTable )

18−import qualified Rel8.Schema.Kind as K

19−

20−

21−type HTrio :: K.HTable -> K.HTable -> K.HTable -> K.HTable

22−data HTrio x y z context = HTrio

23− { hfst :: x context

24− , hsnd :: y context

25− , htrd :: z context

26− }

27− deriving stock Generic

28− deriving anyclass HTable

src/Rel8/Table.hs+14−94

@@ -47,11 +47,8 @@ import Rel8.Schema.HTable.List ( HListTable )

4747import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

4848import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

4949import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )

50−import Rel8.Schema.HTable.Pair ( HPair(..) )

51−import Rel8.Schema.HTable.Quartet ( HQuartet(..) )

52−import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

50+import Rel8.Schema.HTable.Product ( HProduct(..) )

5351import Rel8.Schema.HTable.These ( HTheseTable(..) )

54−import Rel8.Schema.HTable.Trio ( HTrio(..) )

5552import Rel8.Schema.HTable.Type ( HType( HType ) )

5653import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )

5754import qualified Rel8.Schema.Kind as K

@@ -112,7 +109,7 @@ type GColumns :: (Type -> Type) -> K.HTable

112109type family GColumns rep where

113110 GColumns (M1 D _ rep) = GColumns rep

114111 GColumns (M1 C _ rep) = GColumns rep

115− GColumns (rep1 :*: rep2) = HPair (GColumns rep1) (GColumns rep2)

112+ GColumns (rep1 :*: rep2) = HProduct (GColumns rep1) (GColumns rep2)

116113 GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =

117114 HLabel label (Columns a)

118115

@@ -143,10 +140,10 @@ instance GTable context rep => GTable context (M1 C c rep) where

143140instance (GTable context rep1, GTable context rep2) =>

144141 GTable context (rep1 :*: rep2)

145142 where

146− fromGColumns (HPair a b) =

143+ fromGColumns (HProduct a b) =

147144 fromGColumns @context @rep1 a :*: fromGColumns @context @rep2 b

148145 toGColumns (a :*: b) =

149− HPair (toGColumns @context @rep1 a) (toGColumns @context @rep2 b)

146+ HProduct (toGColumns @context @rep1 a) (toGColumns @context @rep2 b)

150147

151148

152149instance

@@ -156,7 +153,8 @@ instance

156153 , GColumns (M1 S meta k1) ~ HLabel label (Columns a)

157154 , meta ~ 'MetaSel ('Just label) _su _ss _ds

158155 , k1 ~ K1 i a

159− ) => GTable context (M1 S meta k1)

156+ )

157+ => GTable context (M1 S meta k1)

160158 where

161159 fromGColumns = M1 . K1 . fromColumns . hunlabel unlabeler

162160 toGColumns (M1 (K1 a)) = hlabel labeler (toColumns a)

@@ -286,108 +284,30 @@ instance (Table Result a, Table Result b) => Table Result (These a b) where

286284 }

287285

288286

289−instance

290− ( Table context a, Table context b

291− , Labelable context

292− ) =>

293− Table context (a, b)

294− where

295− type Columns (a, b) =

296− HPair

297− (HLabel "fst" (Columns a))

298− (HLabel "snd" (Columns b))

299− type Context (a, b) = Context a

300−

301− toColumns (a, b) = HPair

302− { hfst = hlabel labeler $ toColumns a

303− , hsnd = hlabel labeler $ toColumns b

304− }

305− fromColumns (HPair a b) =

306− ( fromColumns $ hunlabel unlabeler a

307− , fromColumns $ hunlabel unlabeler b

308− )

287+instance (Table context a, Table context b, Labelable context)

288+ => Table context (a, b)

309289

310290

311291instance

312292 ( Table context a, Table context b, Table context c

313293 , Labelable context

314− ) => Table context (a, b, c)

315− where

316− type Columns (a, b, c) =

317− HTrio

318− (HLabel "fst" (Columns a))

319− (HLabel "snd" (Columns b))

320− (HLabel "trd" (Columns c))

321− type Context (a, b, c) = Context a

322−

323− toColumns (a, b, c) = HTrio

324− { hfst = hlabel labeler $ toColumns a

325− , hsnd = hlabel labeler $ toColumns b

326− , htrd = hlabel labeler $ toColumns c

327− }

328− fromColumns (HTrio a b c) =

329− ( fromColumns $ hunlabel unlabeler a

330− , fromColumns $ hunlabel unlabeler b

331− , fromColumns $ hunlabel unlabeler c

332− )

294+ )

295+ => Table context (a, b, c)

333296

334297

335298instance

336299 ( Table context a, Table context b, Table context c, Table context d

337300 , Labelable context

338− ) => Table context (a, b, c, d)

339− where

340− type Columns (a, b, c, d) =

341− HQuartet

342− (HLabel "fst" (Columns a))

343− (HLabel "snd" (Columns b))

344− (HLabel "trd" (Columns c))

345− (HLabel "frt" (Columns d))

346− type Context (a, b, c, d) = Context a

347−

348− toColumns (a, b, c, d) = HQuartet

349− { hfst = hlabel labeler $ toColumns a

350− , hsnd = hlabel labeler $ toColumns b

351− , htrd = hlabel labeler $ toColumns c

352− , hfrt = hlabel labeler $ toColumns d

353− }

354− fromColumns (HQuartet a b c d) =

355− ( fromColumns $ hunlabel unlabeler a

356− , fromColumns $ hunlabel unlabeler b

357− , fromColumns $ hunlabel unlabeler c

358− , fromColumns $ hunlabel unlabeler d

359− )

301+ )

302+ => Table context (a, b, c, d)

360303

361304

362305instance

363306 ( Table context a, Table context b, Table context c, Table context d

364307 , Table context e

365308 , Labelable context

366− ) => Table context (a, b, c, d, e)

367− where

368− type Columns (a, b, c, d, e) =

369− HQuintet

370− (HLabel "fst" (Columns a))

371− (HLabel "snd" (Columns b))

372− (HLabel "trd" (Columns c))

373− (HLabel "frt" (Columns d))

374− (HLabel "fft" (Columns e))

375− type Context (a, b, c, d, e) = Context a

376−

377− toColumns (a, b, c, d, e) = HQuintet

378− { hfst = hlabel labeler $ toColumns a

379− , hsnd = hlabel labeler $ toColumns b

380− , htrd = hlabel labeler $ toColumns c

381− , hfrt = hlabel labeler $ toColumns d

382− , hfft = hlabel labeler $ toColumns e

383− }

384− fromColumns (HQuintet a b c d e) =

385− ( fromColumns $ hunlabel unlabeler a

386− , fromColumns $ hunlabel unlabeler b

387− , fromColumns $ hunlabel unlabeler c

388− , fromColumns $ hunlabel unlabeler d

389− , fromColumns $ hunlabel unlabeler e

390− )

309+ )

310+ => Table context (a, b, c, d, e)

391311

392312

393313type Congruent :: Type -> Type -> Constraint

src/Rel8/Table/Eq.hs+49−40

@@ -9,6 +9,7 @@

99{-# language StandaloneKindSignatures #-}

1010{-# language TypeApplications #-}

1111{-# language TypeFamilies #-}

12+{-# language TypeOperators #-}

1213{-# language UndecidableInstances #-}

1314{-# language UndecidableSuperClasses #-}

1415{-# language ViewPatterns #-}

@@ -23,27 +24,28 @@ import Data.Foldable ( foldl' )

2324import Data.Functor.Const ( Const( Const ), getConst )

2425import Data.Kind ( Constraint, Type )

2526import Data.List.NonEmpty ( NonEmpty( (:|) ) )

27+import GHC.Generics ( Rep, (:*:), K1, M1, Meta( MetaSel ), D, C, S )

28+import GHC.TypeLits ( KnownSymbol )

2629import Prelude

2730

2831-- rel8

2932import Rel8.Expr ( Expr, Col(..) )

3033import Rel8.Expr.Bool ( (||.), (&&.) )

3134import Rel8.Expr.Eq ( (==.), (/=.) )

35+import Rel8.Generic.Record ( Record )

3236import Rel8.Schema.Context.Label ( hlabeler )

3337import Rel8.Schema.Dict ( Dict( Dict ) )

3438import Rel8.Schema.HTable

3539 ( HTable, HConstrainTable

3640 , htabulateA, hfield, hdicts

3741 )

38−import Rel8.Schema.HTable.Label ( hlabel )

39−import Rel8.Schema.HTable.Pair ( HPair(..) )

40−import Rel8.Schema.HTable.Quartet ( HQuartet(..) )

41−import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

42−import Rel8.Schema.HTable.Trio ( HTrio(..) )

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

43+import Rel8.Schema.HTable.Product ( HProduct(..) )

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

4345import Rel8.Schema.Kind ( Context )

4446import Rel8.Schema.Null ( Sql )

4547import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )

46−import Rel8.Table ( Table, Columns, toColumns )

48+import Rel8.Table ( Table, Columns, toColumns, GColumns )

4749import Rel8.Type.Eq ( DBEq )

4850

4951

@@ -54,10 +56,40 @@ type EqTable :: Type -> Constraint

5456class Table Expr a => EqTable a where

5557 eqTable :: Columns a (Dict (ConstrainDBType DBEq))

5658

57− default eqTable :: ()

58− => HConstrainTable (Columns a) (ConstrainDBType DBEq)

59+ default eqTable ::

60+ ( GColumns (Rep (Record a)) ~ Columns a

61+ , GEqTable (Rep (Record a))

62+ )

5963 => Columns a (Dict (ConstrainDBType DBEq))

60− eqTable = hdicts @(Columns a) @(ConstrainDBType DBEq)

64+ eqTable = geqTable @(Rep (Record a))

65+

66+

67+type GEqTable :: (Type -> Type) -> Constraint

68+class GEqTable rep where

69+ geqTable :: GColumns rep (Dict (ConstrainDBType DBEq))

70+

71+

72+instance GEqTable rep => GEqTable (M1 D c rep) where

73+ geqTable = geqTable @rep

74+

75+

76+instance GEqTable rep => GEqTable (M1 C c rep) where

77+ geqTable = geqTable @rep

78+

79+

80+instance (GEqTable rep1, GEqTable rep2) => GEqTable (rep1 :*: rep2) where

81+ geqTable = HProduct (geqTable @rep1) (geqTable @rep2)

82+

83+

84+instance

85+ ( EqTable a

86+ , KnownSymbol label

87+ , GColumns (M1 S meta k1) ~ HLabel label (Columns a)

88+ , meta ~ 'MetaSel ('Just label) _su _ss _ds

89+ , k1 ~ K1 i a

90+ ) => GEqTable (M1 S meta k1)

91+ where

92+ geqTable = hlabel hlabeler (eqTable @a)

6193

6294

6395instance

@@ -66,6 +98,8 @@ instance

6698 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)

6799 )

68100 => EqTable (t f)

101+ where

102+ eqTable = hdicts @(Columns (t f)) @(ConstrainDBType DBEq)

69103

70104

71105instance

@@ -74,50 +108,25 @@ instance

74108 , HConstrainTable t (ConstrainDBType DBEq)

75109 )

76110 => EqTable (t f)

111+ where

112+ eqTable = hdicts @(Columns (t f)) @(ConstrainDBType DBEq)

77113

78114

79−instance Sql DBEq a => EqTable (Expr a)

115+instance Sql DBEq a => EqTable (Expr a) where

116+ eqTable = HType Dict

80117

81118

82−instance (EqTable a, EqTable b) => EqTable (a, b) where

83− eqTable =

84− HPair

85− { hfst = hlabel hlabeler (eqTable @a)

86− , hsnd = hlabel hlabeler (eqTable @b)

87− }

119+instance (EqTable a, EqTable b) => EqTable (a, b)

88120

89121

90−instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c) where

91− eqTable =

92− HTrio

93− { hfst = hlabel hlabeler (eqTable @a)

94− , hsnd = hlabel hlabeler (eqTable @b)

95− , htrd = hlabel hlabeler (eqTable @c)

96− }

122+instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c)

97123

98124

99125instance (EqTable a, EqTable b, EqTable c, EqTable d) => EqTable (a, b, c, d)

100− where

101− eqTable =

102− HQuartet

103− { hfst = hlabel hlabeler (eqTable @a)

104− , hsnd = hlabel hlabeler (eqTable @b)

105− , htrd = hlabel hlabeler (eqTable @c)

106− , hfrt = hlabel hlabeler (eqTable @d)

107− }

108126

109127

110128instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) =>

111129 EqTable (a, b, c, d, e)

112− where

113− eqTable =

114− HQuintet

115− { hfst = hlabel hlabeler (eqTable @a)

116− , hsnd = hlabel hlabeler (eqTable @b)

117− , htrd = hlabel hlabeler (eqTable @c)

118− , hfrt = hlabel hlabeler (eqTable @d)

119− , hfft = hlabel hlabeler (eqTable @e)

120− }

121130

122131

123132-- | Compare two 'Table's for equality. This corresponds to comparing all

src/Rel8/Table/Ord.hs+52−39

@@ -2,11 +2,13 @@

22{-# language DataKinds #-}

33{-# language DefaultSignatures #-}

44{-# language DisambiguateRecordFields #-}

5+{-# language FlexibleContexts #-}

56{-# language FlexibleInstances #-}

67{-# language ScopedTypeVariables #-}

78{-# language StandaloneKindSignatures #-}

89{-# language TypeApplications #-}

910{-# language TypeFamilies #-}

11+{-# language TypeOperators #-}

1012{-# language UndecidableInstances #-}

1113{-# language UndecidableSuperClasses #-}

1214{-# language ViewPatterns #-}

@@ -19,6 +21,8 @@ where

1921-- base

2022import Data.Functor.Const ( Const( Const ), getConst )

2123import Data.Kind ( Constraint, Type )

24+import GHC.Generics ( Rep, (:*:), K1, M1, Meta( MetaSel ), D, C, S )

25+import GHC.TypeLits ( KnownSymbol )

2226import Prelude hiding ( seq )

2327

2428-- rel8

@@ -26,21 +30,20 @@ import Rel8.Expr ( Expr, Col(..) )

2630import Rel8.Expr.Bool ( (||.), (&&.), false, true )

2731import Rel8.Expr.Eq ( (==.) )

2832import Rel8.Expr.Ord ( (<.), (>.) )

33+import Rel8.Generic.Record ( Record )

2934import Rel8.Schema.Context.Label ( hlabeler )

3035import Rel8.Schema.Dict ( Dict( Dict ) )

3136import Rel8.Schema.HTable

3237 ( HTable, HConstrainTable

3338 , htabulateA, hfield, hdicts

3439 )

35−import Rel8.Schema.HTable.Label ( hlabel )

36−import Rel8.Schema.HTable.Pair ( HPair(..) )

37−import Rel8.Schema.HTable.Quartet ( HQuartet(..) )

38−import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

39−import Rel8.Schema.HTable.Trio ( HTrio(..) )

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

41+import Rel8.Schema.HTable.Product ( HProduct(..) )

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

4043import Rel8.Schema.Kind ( Context )

4144import Rel8.Schema.Null (Sql)

4245import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )

43−import Rel8.Table ( Table, Columns, toColumns )

46+import Rel8.Table ( Table, Columns, toColumns, GColumns )

4447import Rel8.Table.Bool ( bool )

4548import Rel8.Table.Eq ( EqTable )

4649import Rel8.Type.Eq ( DBEq )

@@ -54,8 +57,41 @@ type OrdTable :: Type -> Constraint

5457class EqTable a => OrdTable a where

5558 ordTable :: Columns a (Dict (ConstrainDBType DBOrd))

5659

57− default ordTable :: HConstrainTable (Columns a) (ConstrainDBType DBOrd) => Columns a (Dict (ConstrainDBType DBOrd))

58− ordTable = hdicts @(Columns a) @(ConstrainDBType DBOrd)

60+ default ordTable ::

61+ ( GColumns (Rep (Record a)) ~ Columns a

62+ , GOrdTable (Rep (Record a))

63+ )

64+ => Columns a (Dict (ConstrainDBType DBOrd))

65+ ordTable = gordTable @(Rep (Record a))

66+

67+

68+type GOrdTable :: (Type -> Type) -> Constraint

69+class GOrdTable rep where

70+ gordTable :: GColumns rep (Dict (ConstrainDBType DBOrd))

71+

72+

73+instance GOrdTable rep => GOrdTable (M1 D c rep) where

74+ gordTable = gordTable @rep

75+

76+

77+instance GOrdTable rep => GOrdTable (M1 C c rep) where

78+ gordTable = gordTable @rep

79+

80+

81+instance (GOrdTable rep1, GOrdTable rep2) => GOrdTable (rep1 :*: rep2) where

82+ gordTable = HProduct (gordTable @rep1) (gordTable @rep2)

83+

84+

85+instance

86+ ( OrdTable a

87+ , KnownSymbol label

88+ , GColumns (M1 S meta k1) ~ HLabel label (Columns a)

89+ , meta ~ 'MetaSel ('Just label) _su _ss _ds

90+ , k1 ~ K1 i a

91+ )

92+ => GOrdTable (M1 S meta k1)

93+ where

94+ gordTable = hlabel hlabeler (ordTable @a)

5995

6096

6197instance

@@ -65,6 +101,8 @@ instance

65101 , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)

66102 )

67103 => OrdTable (t f)

104+ where

105+ ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)

68106

69107

70108instance

@@ -74,50 +112,25 @@ instance

74112 , HConstrainTable t (ConstrainDBType DBOrd)

75113 )

76114 => OrdTable (t f)

115+ where

116+ ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)

77117

78118

79−instance Sql DBOrd a => OrdTable (Expr a)

119+instance Sql DBOrd a => OrdTable (Expr a) where

120+ ordTable = HType Dict

80121

81122

82−instance (OrdTable a, OrdTable b) => OrdTable (a, b) where

83− ordTable =

84− HPair

85− { hfst = hlabel hlabeler (ordTable @a)

86− , hsnd = hlabel hlabeler (ordTable @b)

87− }

123+instance (OrdTable a, OrdTable b) => OrdTable (a, b)

88124

89125

90−instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c) where

91− ordTable =

92− HTrio

93− { hfst = hlabel hlabeler (ordTable @a)

94− , hsnd = hlabel hlabeler (ordTable @b)

95− , htrd = hlabel hlabeler (ordTable @c)

96− }

126+instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)

97127

98128

99129instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)

100− where

101− ordTable =

102− HQuartet

103− { hfst = hlabel hlabeler (ordTable @a)

104− , hsnd = hlabel hlabeler (ordTable @b)

105− , htrd = hlabel hlabeler (ordTable @c)

106− , hfrt = hlabel hlabeler (ordTable @d)

107− }

108130

109131

110132instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>

111133 OrdTable (a, b, c, d, e)

112− where

113− ordTable =

114− HQuintet

115− { hfst = hlabel hlabeler (ordTable @a)

116− , hsnd = hlabel hlabeler (ordTable @b)

117− , htrd = hlabel hlabeler (ordTable @c)

118− , hfrt = hlabel hlabeler (ordTable @d)

119− , hfft = hlabel hlabeler (ordTable @e)

120− }

121134

122135

123136-- | Test if one 'Table' sorts before another. Corresponds to comparing all

src/Rel8/Table/Serialize.hs+70−57

@@ -1,5 +1,6 @@

11{-# language AllowAmbiguousTypes #-}

22{-# language DataKinds #-}

3+{-# language DefaultSignatures #-}

34{-# language DisambiguateRecordFields #-}

45{-# language FlexibleContexts #-}

56{-# language FlexibleInstances #-}

@@ -9,6 +10,7 @@

910{-# language StandaloneKindSignatures #-}

1011{-# language TypeApplications #-}

1112{-# language TypeFamilies #-}

13+{-# language TypeOperators #-}

1214{-# language UndecidableInstances #-}

1315

1416module Rel8.Table.Serialize

@@ -23,6 +25,11 @@ where

2325import Data.Bifunctor ( bimap )

2426import Data.Kind ( Constraint, Type )

2527import Data.List.NonEmpty ( NonEmpty )

28+import GHC.Generics

29+ ( Generic, Rep, from, to

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

31+ )

32+import GHC.TypeLits ( KnownSymbol )

2633import Prelude

2734

2835-- hasql

@@ -31,19 +38,17 @@ import qualified Hasql.Decoders as Hasql

3138-- rel8

3239import Rel8.Expr ( Expr, Col(..) )

3340import Rel8.Expr.Serialize ( slitExpr, sparseValue )

41+import Rel8.Generic.Record ( Record(..) )

3442import Rel8.Schema.Context ( Col(..) )

3543import Rel8.Schema.Context.Label ( labeler, unlabeler )

3644import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )

37−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

38−import Rel8.Schema.HTable.Quartet ( HQuartet(..) )

39−import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

40−import Rel8.Schema.HTable.Pair ( HPair(..) )

41−import Rel8.Schema.HTable.Trio ( HTrio(..) )

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

46+import Rel8.Schema.HTable.Product ( HProduct(..) )

4247import Rel8.Schema.HTable.Type ( HType(..) )

4348import Rel8.Schema.Null ( NotNull, Sql )

4449import Rel8.Schema.Result ( Result )

4550import Rel8.Schema.Spec ( SSpec(..), KnownSpec )

46−import Rel8.Table ( Table, Columns, fromColumns, toColumns )

51+import Rel8.Table ( Table, Columns, fromColumns, toColumns, GColumns )

4752import Rel8.Table.Either ( EitherTable )

4853import Rel8.Table.List ( ListTable )

4954import Rel8.Table.Maybe ( MaybeTable )

@@ -64,6 +69,59 @@ class Table Expr exprs => ToExprs exprs a where

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

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

6671

72+ default fromResult ::

73+ ( Generic (Record a)

74+ , GToExprs (Rep (Record exprs)) (Rep (Record a))

75+ , Columns exprs ~ GColumns (Rep (Record exprs))

76+ )

77+ => Columns exprs (Col Result) -> a

78+ fromResult = unrecord . to . gfromResult @(Rep (Record exprs))

79+

80+ default toResult ::

81+ ( Generic (Record a)

82+ , GToExprs (Rep (Record exprs)) (Rep (Record a))

83+ , Columns exprs ~ GColumns (Rep (Record exprs))

84+ )

85+ => a -> Columns exprs (Col Result)

86+ toResult = gtoResult @(Rep (Record exprs)) . from . Record

87+

88+

89+type GToExprs :: (Type -> Type) -> (Type -> Type) -> Constraint

90+class GToExprs exprs rep where

91+ gfromResult :: GColumns exprs (Col Result) -> rep x

92+ gtoResult :: rep x -> GColumns exprs (Col Result)

93+

94+

95+instance GToExprs exprs rep => GToExprs (M1 D c exprs) (M1 D c rep) where

96+ gfromResult = M1 . gfromResult @exprs

97+ gtoResult (M1 a) = gtoResult @exprs a

98+

99+

100+instance GToExprs exprs rep => GToExprs (M1 C c exprs) (M1 C c rep) where

101+ gfromResult = M1 . gfromResult @exprs

102+ gtoResult (M1 a) = gtoResult @exprs a

103+

104+

105+instance (GToExprs exprs1 rep1, GToExprs exprs2 rep2) =>

106+ GToExprs (exprs1 :*: exprs2) (rep1 :*: rep2)

107+ where

108+ gfromResult (HProduct a b) = gfromResult @exprs1 a :*: gfromResult @exprs2 b

109+ gtoResult (a :*: b) = HProduct (gtoResult @exprs1 a) (gtoResult @exprs2 b)

110+

111+

112+instance

113+ ( ToExprs exprs a

114+ , KnownSymbol label

115+ , GColumns (M1 S meta k1) ~ HLabel label (Columns exprs)

116+ , meta ~ 'MetaSel ('Just label) _su _ss _ds

117+ , k1 ~ K1 i exprs

118+ , k1' ~ K1 i a

119+ )

120+ => GToExprs (M1 S meta k1) (M1 S meta k1')

121+ where

122+ gfromResult = M1 . K1 . fromResult @exprs . hunlabel unlabeler

123+ gtoResult (M1 (K1 a)) = hlabel labeler (toResult @exprs a)

124+

67125

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

69127 fromResult (HType (Result a)) = a

@@ -127,15 +185,6 @@ instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>

127185

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

129187 ToExprs x (a, b)

130− where

131− fromResult (HPair a b) =

132− ( fromResult @exprs1 $ hunlabel unlabeler a

133− , fromResult @exprs2 $ hunlabel unlabeler b

134− )

135− toResult (a, b) = HPair

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

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

138− }

139188

140189

141190instance

@@ -143,18 +192,8 @@ instance

143192 , ToExprs exprs2 b

144193 , ToExprs exprs3 c

145194 , x ~ (exprs1, exprs2, exprs3)

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

147− where

148− fromResult (HTrio a b c) =

149− ( fromResult @exprs1 $ hunlabel unlabeler a

150− , fromResult @exprs2 $ hunlabel unlabeler b

151− , fromResult @exprs3 $ hunlabel unlabeler c

152− )

153− toResult (a, b, c) = HTrio

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

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

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

157− }

195+ )

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

158197

159198

160199instance

@@ -163,20 +202,8 @@ instance

163202 , ToExprs exprs3 c

164203 , ToExprs exprs4 d

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

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

167− where

168− fromResult (HQuartet a b c 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

173− )

174− toResult (a, b, c, d) = HQuartet

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

179− }

205+ )

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

180207

181208

182209instance

@@ -186,22 +213,8 @@ instance

186213 , ToExprs exprs4 d

187214 , ToExprs exprs5 e

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

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

190− where

191− fromResult (HQuintet a b c d 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

197− )

198− toResult (a, b, c, d, e) = HQuintet

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

204− }

216+ )

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

205218

206219

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