f47423e · rel8 · git.iko.soy

rel8.cabal−2

compare with master

unifiedsplit

@@ -114,7 +114,6 @@ library

114 Rel8.Query.These

115 Rel8.Query.Values

116

117− Rel8.Schema.Context.Lower

118 Rel8.Schema.Context.Nullify

117 Rel8.Schema.Context.Nullify

119 Rel8.Schema.Context.Virtual

118 Rel8.Schema.Context.Virtual

120 Rel8.Schema.Dict

119 Rel8.Schema.Dict

@@ -135,7 +134,6 @@ library

135 Rel8.Schema.Null

134 Rel8.Schema.Null

136 Rel8.Schema.Result

135 Rel8.Schema.Result

137 Rel8.Schema.Spec

136 Rel8.Schema.Spec

138− Rel8.Schema.Spec.Constrain

139 Rel8.Schema.Table

137 Rel8.Schema.Table

140

138

141 Rel8.Statement.Delete

139 Rel8.Statement.Delete

src/Rel8/Aggregate.hs+11−19

@@ -1,10 +1,8 @@

1{-# language DataKinds #-}

2{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4−{-# language GADTs #-}

5{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

6{-# language NamedFieldPuns #-}

5{-# language NamedFieldPuns #-}

7−{-# language PolyKinds #-}

8{-# language RankNTypes #-}

6{-# language RankNTypes #-}

9{-# language StandaloneKindSignatures #-}

7{-# language StandaloneKindSignatures #-}

10{-# language TypeFamilies #-}

8{-# language TypeFamilies #-}

@@ -19,6 +17,7 @@ where

19

17

20-- base

18-- base

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

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

20+import Data.Functor.Identity ( Identity( Identity ) )

22import Data.Kind ( Constraint, Type )

21import Data.Kind ( Constraint, Type )

23import Prelude

22import Prelude

24

23

@@ -29,11 +28,9 @@ import qualified Opaleye.Internal.PackMap as Opaleye

29

28

30-- rel8

29-- rel8

31import Rel8.Expr ( Expr )

30import Rel8.Expr ( Expr )

32−import Rel8.Schema.Context.Lower ( Lower )

33−import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )

31+import Rel8.Schema.HTable.Identity ( HIdentity(..) )

32+import qualified Rel8.Schema.Kind as K

34import Rel8.Schema.Null ( Sql )

33import Rel8.Schema.Null ( Sql )

35−import Rel8.Schema.Result ( Result( R ) )

36−import Rel8.Schema.Spec ( Spec( Spec ) )

37import Rel8.Table

34import Rel8.Table

38 ( Table, Columns, Context, fromColumns, toColumns

35 ( Table, Columns, Context, fromColumns, toColumns

39 , FromExprs, fromResult, toResult

36 , FromExprs, fromResult, toResult

@@ -48,25 +45,20 @@ import Rel8.Type ( DBType )

48-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'

45-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'

49-- operation. This means 'Aggregate' is an instance of 'Apply', and you can

46-- operation. This means 'Aggregate' is an instance of 'Apply', and you can

50-- combine @Aggregate@s using the @<.>@ combinator.

47-- combine @Aggregate@s using the @<.>@ combinator.

51−type Aggregate :: k -> Type

48+type Aggregate :: K.Context

52−data Aggregate a where

53− Aggregate :: forall (a :: Type). !(Opaleye.Aggregator () (Expr a)) -> Aggregate a

49+newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))

54− A :: { unA :: !(Aggregate a) } -> Aggregate ('Spec a)

55−

56−

57−type instance Lower Aggregate = Aggregate

58

50

59

51

60instance Sql DBType a => Table Aggregate (Aggregate a) where

52instance Sql DBType a => Table Aggregate (Aggregate a) where

61− type Columns (Aggregate a) = HType a

53+ type Columns (Aggregate a) = HIdentity a

62 type Context (Aggregate a) = Aggregate

54 type Context (Aggregate a) = Aggregate

63 type FromExprs (Aggregate a) = a

55 type FromExprs (Aggregate a) = a

64− type Transpose to (Aggregate a) = Lower to a

56+ type Transpose to (Aggregate a) = to a

65

57

66− toColumns = HIdentity . A

58+ toColumns = HIdentity

67− fromColumns (HIdentity (A a)) = a

59+ fromColumns (HIdentity a) = a

68− toResult = HIdentity . R

60+ toResult = HIdentity . Identity

69− fromResult (HIdentity (R a)) = a

61+ fromResult (HIdentity (Identity a)) = a

70

62

71

63

72-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's

64-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's

src/Rel8/Column.hs+1−2

@@ -15,7 +15,6 @@ import Prelude ()

15-- rel8

16import Rel8.FCF ( Eval, Exp )

17import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Context.Lower ( Lower )

19import Rel8.Schema.Result ( Result )

18import Rel8.Schema.Result ( Result )

20

19

21

20

@@ -25,7 +24,7 @@ import Rel8.Schema.Result ( Result )

25type Column :: K.Context -> Type -> Type

24type Column :: K.Context -> Type -> Type

26type family Column context a where

25type family Column context a where

27 Column Result a = a

26 Column Result a = a

28− Column context a = Lower context a

27+ Column context a = context a

29

28

30

29

31data TColumn :: K.Context -> Type -> Exp Type

30data TColumn :: K.Context -> Type -> Exp Type

src/Rel8/Expr.hs+12−25

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

1{-# language DataKinds #-}

2{-# language DerivingStrategies #-}

3{-# language FlexibleInstances #-}

4−{-# language GADTs #-}

5{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

6−{-# language PolyKinds #-}

7−{-# language RoleAnnotations #-}

8{-# language ScopedTypeVariables #-}

5{-# language ScopedTypeVariables #-}

9−{-# language StandaloneDeriving #-}

10{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

11{-# language TypeApplications #-}

7{-# language TypeApplications #-}

12{-# language TypeFamilies #-}

8{-# language TypeFamilies #-}

@@ -18,7 +14,7 @@ module Rel8.Expr

18where

14where

19

15

20-- base

16-- base

21−import Data.Kind ( Type )

17+import Data.Functor.Identity ( Identity( Identity ) )

22import Data.String ( IsString, fromString )

18import Data.String ( IsString, fromString )

23import Prelude hiding ( null )

19import Prelude hiding ( null )

24

20

@@ -35,11 +31,9 @@ import Rel8.Expr.Opaleye

35 , zipPrimExprsWith

31 , zipPrimExprsWith

36 )

32 )

37import Rel8.Expr.Serialize ( litExpr )

33import Rel8.Expr.Serialize ( litExpr )

38−import Rel8.Schema.Context.Lower ( Lower )

39−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

34+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

35+import qualified Rel8.Schema.Kind as K

40import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

36import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

41−import Rel8.Schema.Result ( Result( R ) )

42−import Rel8.Schema.Spec ( Spec( Spec ) )

43import Rel8.Table

37import Rel8.Table

44 ( Table, Columns, Context, fromColumns, toColumns

38 ( Table, Columns, Context, fromColumns, toColumns

45 , FromExprs, fromResult, toResult

39 , FromExprs, fromResult, toResult

@@ -52,16 +46,9 @@ import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )

52

46

53

47

54-- | Typed SQL expressions.

48-- | Typed SQL expressions.

55−type Expr :: k -> Type

49+type Expr :: K.Context

56−data Expr a where

57− Expr :: forall (a :: Type). !Opaleye.PrimExpr -> Expr a

50+newtype Expr a = Expr Opaleye.PrimExpr

58− E :: { unE :: !(Expr a) } -> Expr ('Spec a)

59−

60−

61−deriving stock instance Show (Expr a)

51+ deriving stock Show

62−

63−

64−type instance Lower Expr = Expr

65

52

66

53

67instance Sql DBSemigroup a => Semigroup (Expr a) where

54instance Sql DBSemigroup a => Semigroup (Expr a) where

@@ -126,12 +113,12 @@ instance Sql DBFloating a => Floating (Expr a) where

126

113

127

114

128instance Sql DBType a => Table Expr (Expr a) where

115instance Sql DBType a => Table Expr (Expr a) where

129− type Columns (Expr a) = HType a

116+ type Columns (Expr a) = HIdentity a

130 type Context (Expr a) = Expr

117 type Context (Expr a) = Expr

131 type FromExprs (Expr a) = a

118 type FromExprs (Expr a) = a

132− type Transpose to (Expr a) = Lower to a

119+ type Transpose to (Expr a) = to a

133

120

134− toColumns a = HType (E a)

121+ toColumns a = HIdentity a

135− fromColumns (HType (E a)) = a

122+ fromColumns (HIdentity a) = a

136− toResult a = HType (R a)

123+ toResult a = HIdentity (Identity a)

137− fromResult (HType (R a)) = a

124+ fromResult (HIdentity (Identity a)) = a

src/Rel8/Expr.hs-boot+4−10

@@ -1,8 +1,4 @@

1{-# language DataKinds #-}

2−{-# language GADTs #-}

3−{-# language PolyKinds #-}

4−{-# language RankNTypes #-}

5−{-# language RoleAnnotations #-}

6{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

7

3

8module Rel8.Expr

4module Rel8.Expr

@@ -11,16 +7,14 @@ module Rel8.Expr

11where

7where

12

8

13-- base

9-- base

14−import Data.Kind ( Type )

15import Prelude ()

10import Prelude ()

16

11

17-- opaleye

12-- opaleye

18import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

13import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

19

14

15+-- rel8

20−import Rel8.Schema.Spec ( Spec(..) )

16+import Rel8.Schema.Kind ( Context )

21

17

22

18

23−type Expr :: k -> Type

19+type Expr :: Context

24−data Expr a where

25− Expr :: forall (a :: Type). !Opaleye.PrimExpr -> Expr a

20+newtype Expr a = Expr Opaleye.PrimExpr

26− E :: { unE :: !(Expr a) } -> Expr ('Spec a)

src/Rel8/Generic/Construction.hs+24−24

@@ -29,8 +29,8 @@ import GHC.TypeLits ( Symbol )

29import Prelude

30

31-- rel8

32−import Rel8.Aggregate ( Aggregate( A, Aggregate ) )

32+import Rel8.Aggregate ( Aggregate( Aggregate ) )

33−import Rel8.Expr ( Expr( E ) )

33+import Rel8.Expr ( Expr )

34import Rel8.Expr.Aggregate ( groupByExpr )

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

36import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify )

@@ -57,11 +57,11 @@ import Rel8.Kind.Algebra

57import qualified Rel8.Kind.Algebra as K

58import Rel8.Schema.Context.Nullify ( sguard, snullify )

59import Rel8.Schema.HTable ( HTable )

60−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

60+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

61import qualified Rel8.Schema.Kind as K

62−import Rel8.Schema.Name ( Name( N, Name ) )

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

63import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

64−import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )

64+import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )

65import Rel8.Table

66 ( TTable, TColumns

67 , Table, fromColumns, toColumns

@@ -127,11 +127,11 @@ ggbuild gfromColumns = case algebraSing @algebra of

127 @name

128 @(Eval (rep Expr))

129 (const toColumns)

130− (\SSpec {info} -> E (snull info))

130+ (\Spec {info} -> snull info)

131− (\SSpec {nullity} -> case nullity of

131+ (\Spec {nullity} -> case nullity of

132 Null -> id

133− NotNull -> \(E a) -> E (nullify a))

133+ NotNull -> nullify)

134− (HType . E . litExpr)

134+ (HIdentity . litExpr)

135

136

137type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint

@@ -198,11 +198,11 @@ ggconstruct gfromColumns f = case algebraSing @algebra of

198 @Expr

199 @(Eval (rep Expr))

200 (const toColumns)

201− (\SSpec {info} -> E (snull info))

201+ (\Spec {info} -> snull info)

202− (\SSpec {nullity} -> case nullity of

202+ (\Spec {nullity} -> case nullity of

203 Null -> id

204− NotNull -> \(E a) -> E (nullify a))

204+ NotNull -> nullify)

205− (HType . E . litExpr)

205+ (HIdentity . litExpr)

206

207

208type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type

@@ -230,7 +230,7 @@ ggdeconstruct gtoColumns = case algebraSing @algebra of

230 SSum ->

231 gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) $ \constructors as ->

232 let

233− (HType (E tag), cases) =

233+ (HIdentity tag, cases) =

234 gdeconstructADT

235 @(TTable Expr)

236 @TColumns

@@ -238,9 +238,9 @@ ggdeconstruct gtoColumns = case algebraSing @algebra of

238 @Expr

239 @(Eval (rep Expr))

240 (const fromColumns)

241− (\SSpec {nullity} -> case nullity of

241+ (\Spec {nullity} -> case nullity of

242 Null -> id

243− NotNull -> \(E a) -> E (unsafeUnnullify a))

243+ NotNull -> unsafeUnnullify)

244 constructors $

245 gtoColumns as

246 in

@@ -279,8 +279,8 @@ ggname gfromColumns = case algebraSing @algebra of

279 @Name

280 @(Eval (rep Name))

281 (const toColumns)

282− (\_ _ (N (Name a)) -> N (Name a))

282+ (\_ _ (Name a) -> Name a)

283− (HType (N tag))

283+ (HIdentity tag)

284

285

286type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

@@ -330,15 +330,15 @@ ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of

330 @Aggregate

331 @(Eval (rep Aggregate))

332 (const toColumns)

333− (\tag' SSpec {nullity} (A (Aggregate a)) ->

333+ (\tag' Spec {nullity} (Aggregate a) ->

334− A $ Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)

334+ Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)

335− (HType (A (groupByExpr tag)))

335+ (HIdentity (groupByExpr tag))

336 where

337 f =

338 gfindex @Id @(Eval (rep Expr)) @agg .

339 agg .

340 gftabulate @Id @(Eval (rep Aggregate)) @agg

341− (HType (E tag), exprs) =

341+ (HIdentity tag, exprs) =

342 gunbuildADT

343 @(TTable Expr)

344 @TColumns

@@ -346,7 +346,7 @@ ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of

346 @Expr

347 @(Eval (rep Expr))

348 (const fromColumns)

349− (\SSpec {nullity} -> case nullity of

349+ (\Spec {nullity} -> case nullity of

350 Null -> id

351− NotNull -> \(E a) -> E (unsafeUnnullify a)) $

351+ NotNull -> unsafeUnnullify) $

352 gtoColumns es

src/Rel8/Generic/Construction/ADT.hs+12−20

@@ -49,12 +49,12 @@ import Rel8.Generic.Construction.Record

49import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )

50import Rel8.Generic.Table.Record ( GColumns )

51import Rel8.Schema.HTable ( HTable )

52−import Rel8.Schema.HTable.Identity ( HType )

52+import Rel8.Schema.HTable.Identity ( HIdentity )

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

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

55import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

56import Rel8.Schema.Null ( Nullify )

57−import Rel8.Schema.Spec ( Spec( Spec ), SSpec )

57+import Rel8.Schema.Spec ( Spec )

58import qualified Rel8.Schema.Kind as K

59import Rel8.Type.Tag ( Tag( Tag ) )

60

@@ -63,23 +63,15 @@ import Data.Text ( pack )

63

64

65type Null :: K.Context -> Type

66−type Null context = forall a. ()

66+type Null context = forall a. Spec a -> context (Nullify a)

67− => SSpec ('Spec a)

68− -> context ('Spec (Nullify a))

69

67

70

68

71type Nullifier :: K.Context -> Type

69type Nullifier :: K.Context -> Type

72−type Nullifier context = forall a. ()

70+type Nullifier context = forall a. Spec a -> context a -> context (Nullify a)

73− => SSpec ('Spec a)

74− -> context ('Spec a)

75− -> context ('Spec (Nullify a))

76

71

77

72

78type Unnullifier :: K.Context -> Type

73type Unnullifier :: K.Context -> Type

79−type Unnullifier context = forall a. ()

74+type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a

80− => SSpec ('Spec a)

81− -> context ('Spec (Nullify a))

82− -> context ('Spec a)

83

75

84

76

85type NoConstructor :: Symbol -> Symbol -> ErrorMessage

77type NoConstructor :: Symbol -> Symbol -> ErrorMessage

@@ -193,7 +185,7 @@ class GConstructableADT _Table _Columns f context rep where

193 gbuildADT :: ()

185 gbuildADT :: ()

194 => ToColumns _Table _Columns f context

186 => ToColumns _Table _Columns f context

195 -> (Tag -> Nullifier context)

187 -> (Tag -> Nullifier context)

196− -> HType Tag context

188+ -> HIdentity Tag context

197 -> GFieldsADT f rep

189 -> GFieldsADT f rep

198 -> GColumnsADT _Columns rep context

190 -> GColumnsADT _Columns rep context

199

191

@@ -201,13 +193,13 @@ class GConstructableADT _Table _Columns f context rep where

201 => FromColumns _Table _Columns f context

193 => FromColumns _Table _Columns f context

202 -> Unnullifier context

194 -> Unnullifier context

203 -> GColumnsADT _Columns rep context

195 -> GColumnsADT _Columns rep context

204− -> (HType Tag context, GFieldsADT f rep)

196+ -> (HIdentity Tag context, GFieldsADT f rep)

205

197

206 gconstructADT :: ()

198 gconstructADT :: ()

207 => ToColumns _Table _Columns f context

199 => ToColumns _Table _Columns f context

208 -> Null context

200 -> Null context

209 -> Nullifier context

201 -> Nullifier context

210− -> (Tag -> HType Tag context)

202+ -> (Tag -> HIdentity Tag context)

211 -> GConstructors f rep (GColumnsADT _Columns rep context)

203 -> GConstructors f rep (GColumnsADT _Columns rep context)

212

204

213 gdeconstructADT :: ()

205 gdeconstructADT :: ()

@@ -215,11 +207,11 @@ class GConstructableADT _Table _Columns f context rep where

215 -> Unnullifier context

207 -> Unnullifier context

216 -> GConstructors f rep r

208 -> GConstructors f rep r

217 -> GColumnsADT _Columns rep context

209 -> GColumnsADT _Columns rep context

218− -> (HType Tag context, NonEmpty (Tag, r))

210+ -> (HIdentity Tag context, NonEmpty (Tag, r))

219

211

220

212

221instance

213instance

222− ( htable ~ HLabel "tag" (HType Tag)

214+ ( htable ~ HLabel "tag" (HIdentity Tag)

223 , GConstructableADT' _Table _Columns f context htable rep

215 , GConstructableADT' _Table _Columns f context htable rep

224 )

216 )

225 => GConstructableADT _Table _Columns f context (M1 D meta rep)

217 => GConstructableADT _Table _Columns f context (M1 D meta rep)

@@ -389,13 +381,13 @@ class GMakeableADT _Table _Columns f context name rep where

389 => ToColumns _Table _Columns f context

381 => ToColumns _Table _Columns f context

390 -> Null context

382 -> Null context

391 -> Nullifier context

383 -> Nullifier context

392− -> (Tag -> HType Tag context)

384+ -> (Tag -> HIdentity Tag context)

393 -> GFields f (GConstructorADT name rep)

385 -> GFields f (GConstructorADT name rep)

394 -> GColumnsADT _Columns rep context

386 -> GColumnsADT _Columns rep context

395

387

396

388

397instance

389instance

398− ( htable ~ HLabel "tag" (HType Tag)

390+ ( htable ~ HLabel "tag" (HIdentity Tag)

399 , meta ~ 'MetaData datatype _module _package _newtype

391 , meta ~ 'MetaData datatype _module _package _newtype

400 , fallback ~ TypeError (NoConstructor datatype name)

392 , fallback ~ TypeError (NoConstructor datatype name)

401 , fields ~ GFields f (GConstructorADT' name rep fallback)

393 , fields ~ GFields f (GConstructorADT' name rep fallback)

src/Rel8/Generic/Table/ADT.hs+7−9

@@ -18,6 +18,7 @@ module Rel8.Generic.Table.ADT

18where

19

20-- base

21+import Data.Functor.Identity ( Identity( Identity ) )

21import Data.Kind ( Constraint, Type )

22import Data.Kind ( Constraint, Type )

22import Data.Proxy ( Proxy( Proxy ) )

23import Data.Proxy ( Proxy( Proxy ) )

23import GHC.Generics

24import GHC.Generics

@@ -33,15 +34,12 @@ import Rel8.FCF ( Eval, Exp )

33import Rel8.Generic.Map ( GMap )

34import Rel8.Generic.Map ( GMap )

34import Rel8.Generic.Table.Record ( GTable, GColumns, gfromResult, gtoResult )

35import Rel8.Generic.Table.Record ( GTable, GColumns, gfromResult, gtoResult )

35import Rel8.Schema.HTable ( HTable )

36import Rel8.Schema.HTable ( HTable )

36−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

37+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

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

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

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

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

39import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

40import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

40import qualified Rel8.Schema.Kind as K

41import qualified Rel8.Schema.Kind as K

41−import Rel8.Schema.Result

42− ( Result( R )

43− , null, nullifier, unnullifier

42+import Rel8.Schema.Result ( Result, null, nullifier, unnullifier )

44− )

45import Rel8.Type.Tag ( Tag( Tag ) )

43import Rel8.Type.Tag ( Tag( Tag ) )

46

44

47-- text

45-- text

@@ -53,7 +51,7 @@ type GColumnsADT

53 -> (Type -> Type) -> K.HTable

51 -> (Type -> Type) -> K.HTable

54type family GColumnsADT _Columns rep where

52type family GColumnsADT _Columns rep where

55 GColumnsADT _Columns (M1 D _ rep) =

53 GColumnsADT _Columns (M1 D _ rep) =

56− GColumnsADT' _Columns (HLabel "tag" (HType Tag)) rep

54+ GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep

57

55

58

56

59type GColumnsADT'

57type GColumnsADT'

@@ -87,7 +85,7 @@ class GTableADT _Table _Columns _FromExprs rep where

87

85

88

86

89instance

87instance

90− ( htable ~ HLabel "tag" (HType Tag)

88+ ( htable ~ HLabel "tag" (HIdentity Tag)

91 , GTableADT' _Table _Columns _FromExprs htable rep

89 , GTableADT' _Table _Columns _FromExprs htable rep

92 )

90 )

93 => GTableADT _Table _Columns _FromExprs (M1 D meta rep)

91 => GTableADT _Table _Columns _FromExprs (M1 D meta rep)

@@ -97,12 +95,12 @@ instance

97 Just rep -> M1 rep

95 Just rep -> M1 rep

98 _ -> error "ADT.fromColumns: mismatch between tag and data"

96 _ -> error "ADT.fromColumns: mismatch between tag and data"

99 where

97 where

100− tag = (\(HType (R a)) -> a) . hunlabel @"tag"

98+ tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"

101

99

102 gtoResultADT toResult (M1 rep) =

100 gtoResultADT toResult (M1 rep) =

103 gtoResultADT' @_Table @_Columns @_FromExprs @htable @rep toResult tag (Just rep)

101 gtoResultADT' @_Table @_Columns @_FromExprs @htable @rep toResult tag (Just rep)

104 where

102 where

105− tag = hlabel @"tag" . HType . R

103+ tag = hlabel @"tag" . HIdentity . Identity

106

104

107

105

108type GTableADT'

106type GTableADT'

src/Rel8/Kind/Context.hs+1

@@ -1,6 +1,7 @@

1{-# language DataKinds #-}

2{-# language GADTs #-}

3{-# language StandaloneKindSignatures #-}

4+{-# language TypeSynonymInstances #-}

4

5

5module Rel8.Kind.Context

6module Rel8.Kind.Context

6 ( Reifiable( contextSing )

7 ( Reifiable( contextSing )

src/Rel8/Query/List.hs+4−4

@@ -19,7 +19,7 @@ import Prelude

19import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

20

21-- rel8

22−import Rel8.Expr ( Expr( E, unE ) )

22+import Rel8.Expr ( Expr )

23import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )

24import Rel8.Expr.Opaleye ( mapPrimExpr )

25import Rel8.Query ( Query )

@@ -28,7 +28,7 @@ import Rel8.Query.Evaluate ( rebind )

28import Rel8.Query.Maybe ( optional )

29import Rel8.Schema.HTable.Vectorize ( hunvectorize )

30import Rel8.Schema.Null ( Sql, Unnullify )

31−import Rel8.Schema.Spec ( SSpec( SSpec, info ) )

31+import Rel8.Schema.Spec ( Spec( Spec, info ) )

32import Rel8.Table ( Table, fromColumns )

33import Rel8.Table.Cols ( toCols )

34import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )

@@ -86,7 +86,7 @@ someExpr = aggregate . fmap nonEmptyAggExpr

86-- @catListTable@ is an inverse to 'many'.

87catListTable :: Table Expr a => ListTable Expr a -> Query a

88catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $

89− hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

89+ hunvectorize (\Spec {info} -> pure . sunnest info) as

90

91

92-- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an

@@ -95,7 +95,7 @@ catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $

95-- @catNonEmptyTable@ is an inverse to 'some'.

96catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a

97catNonEmptyTable (NonEmptyTable as) = rebind $ fromColumns $ runIdentity $

98− hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

98+ hunvectorize (\Spec {info} -> pure . sunnest info) as

99

100

101-- | Expand an expression that contains a list into a 'Query', where each row

src/Rel8/Query/Maybe.hs+5−5

@@ -19,7 +19,7 @@ import Control.Comonad ( extract )

19import qualified Opaleye.Internal.MaybeFields as Opaleye

20

21-- rel8

22−import Rel8.Expr ( Expr( E ) )

22+import Rel8.Expr ( Expr )

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

24import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )

25import Rel8.Query ( Query )

@@ -35,7 +35,7 @@ import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )

35-- JOIN@s.

36optional :: Query a -> Query (MaybeTable Expr a)

37optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable

38− { tag = E $ fromPrimExpr $ fromColumn tag

38+ { tag = fromPrimExpr $ fromColumn tag

39 , just = pure a

40 }

41

@@ -61,8 +61,8 @@ catMaybeTable ma@(MaybeTable _ a) = do

61-- the input is @nothingTable@, you will always get exactly one @nothingTable@

62-- back.

63traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)

64−traverseMaybeTable query ma@(MaybeTable (E input) _) = do

64+traverseMaybeTable query ma@(MaybeTable input _) = do

65 optional (query =<< catMaybeTable ma) >>= \case

66− MaybeTable (E output) b -> do

66+ MaybeTable output b -> do

67 where_ $ output ==. input

68− pure $ MaybeTable (E input) b

68+ pure $ MaybeTable input b

src/Rel8/Query/SQL.hs+4−4

@@ -23,11 +23,11 @@ import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )

23import qualified Opaleye.Internal.Sql as Opaleye

24

25-- rel8

26−import Rel8.Expr ( Expr( E ) )

26+import Rel8.Expr ( Expr )

27import Rel8.Expr.Opaleye ( toPrimExpr )

28import Rel8.Query ( Query )

29import Rel8.Query.Opaleye ( toOpaleye )

30−import Rel8.Schema.Name ( Name( N, Name ), Selects )

30+import Rel8.Schema.Name ( Name( Name ), Selects )

31import Rel8.Schema.HTable ( htabulateA, hfield )

32import Rel8.Table ( Table, toColumns )

33import Rel8.Table.Cols ( toCols )

@@ -69,7 +69,7 @@ selectFrom (toColumns -> names) (toColumns . castTable -> exprs) query =

69 where

70 select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query

71 attributes = getConst $ htabulateA $ \field -> case hfield names field of

72− N (Name name) -> case hfield exprs field of

72+ Name name -> case hfield exprs field of

73− E (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))

73+ expr -> Const (pure (makeAttr name (toPrimExpr expr)))

74 makeAttr label expr =

75 (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

src/Rel8/Query/These.hs+6−6

@@ -25,7 +25,7 @@ import qualified Opaleye.Internal.QueryArr as Opaleye

25import qualified Opaleye.Internal.Tag as Opaleye

26

27-- rel8

28−import Rel8.Expr ( Expr( E ) )

28+import Rel8.Expr ( Expr )

29import Rel8.Expr.Bool ( boolExpr, not_ )

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

31import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )

@@ -53,8 +53,8 @@ alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> cas

53 where

54 (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)

55 (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')

56− MaybeTable (E hasHere) a = ma

56+ MaybeTable hasHere a = ma

57− MaybeTable (E hasThere) b = mb

57+ MaybeTable hasThere b = mb

58 (hasHere', lbindings) = Opaleye.run $ do

59 traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere

60 (hasThere', rbindings) = Opaleye.run $ do

@@ -65,8 +65,8 @@ alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> cas

65 on = toPrimExpr $ condition (extract a) (extract b)

66 left'' = (lateral, Opaleye.Rebind True lbindings left')

67 right'' = (lateral, Opaleye.Rebind True rbindings right')

68− ma' = MaybeTable (E hasHere') a

68+ ma' = MaybeTable hasHere' a

69− mb' = MaybeTable (E hasThere') b

69+ mb' = MaybeTable hasThere' b

70 tab = TheseTable {here = ma', there = mb'}

71 join' lateral input = Opaleye.times lateral input (join lateral)

72

@@ -120,7 +120,7 @@ keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

120loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)

121loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

122 where_ $ not_ $ isThoseTable t

123− pure $ EitherTable (E tag) a b

123+ pure $ EitherTable tag a b

124 where

125 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)

126

src/Rel8/Schema/Context/Lower.hsdeleted−19

@@ -1,19 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language StandaloneKindSignatures #-}

3−{-# language TypeFamilyDependencies #-}

4−

5−module Rel8.Schema.Context.Lower

6− ( Lower

7− )

8−where

9−

10−-- base

11−import Data.Kind ( Type )

12−import Prelude ()

13−

14−-- rel8

15−import Rel8.Schema.Kind ( Context )

16−

17−

18−type Lower :: Context -> Type -> Type

19−type family Lower context = f | f -> context

src/Rel8/Schema/Context/Nullify.hs+27−29

@@ -16,6 +16,7 @@ where

16

17-- base

18import Data.Bool ( bool )

19+import Data.Functor.Identity ( Identity( Identity ) )

19import Data.Kind ( Constraint, Type )

20import Data.Kind ( Constraint, Type )

20import Data.Monoid ( getFirst )

21import Data.Monoid ( getFirst )

21import Prelude hiding ( null )

22import Prelude hiding ( null )

@@ -24,20 +25,17 @@ import Prelude hiding ( null )

24import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

25import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

25

26

26-- rel8

27-- rel8

27−import Rel8.Aggregate

28+import Rel8.Aggregate ( Aggregate( Aggregate ), foldInputs, mapInputs )

28− ( Aggregate( A, Aggregate )

29− , foldInputs, mapInputs

30− )

31−import Rel8.Expr ( Expr( E ) )

29+import Rel8.Expr ( Expr )

32import Rel8.Expr.Bool ( boolExpr )

30import Rel8.Expr.Bool ( boolExpr )

33import Rel8.Expr.Null ( nullify, unsafeUnnullify )

31import Rel8.Expr.Null ( nullify, unsafeUnnullify )

34import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

32import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

35import Rel8.Kind.Context ( SContext(..) )

33import Rel8.Kind.Context ( SContext(..) )

36import qualified Rel8.Schema.Kind as K

34import qualified Rel8.Schema.Kind as K

37−import Rel8.Schema.Name ( Name( N, Name ) )

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

38import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

36import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

39−import Rel8.Schema.Result ( Result( R ) )

37+import Rel8.Schema.Result ( Result )

40−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

38+import Rel8.Schema.Spec ( Spec(..) )

41

39

42

40

43type Nullifiability :: K.Context -> Type

41type Nullifiability :: K.Context -> Type

@@ -88,48 +86,48 @@ absurd = \case

88

86

89guarder :: ()

87guarder :: ()

90 => SContext context

88 => SContext context

91− -> context ('Spec tag)

89+ -> context tag

92 -> (tag -> Bool)

90 -> (tag -> Bool)

93 -> (Expr tag -> Expr Bool)

91 -> (Expr tag -> Expr Bool)

94− -> context ('Spec (Maybe a))

92+ -> context (Maybe a)

95− -> context ('Spec (Maybe a))

93+ -> context (Maybe a)

96−guarder SAggregate (A tag) _ isNonNull (A (Aggregate a)) =

94+guarder SAggregate tag _ isNonNull (Aggregate a) =

97− A $

98 mapInputs (toPrimExpr . run . fromPrimExpr) $

95 mapInputs (toPrimExpr . run . fromPrimExpr) $

99 Aggregate $

96 Aggregate $

100 run <$> a

97 run <$> a

101 where

98 where

102 mtag = foldInputs (\_ -> pure . fromPrimExpr) tag

99 mtag = foldInputs (\_ -> pure . fromPrimExpr) tag

103 run = maybe id (sguard . isNonNull) (getFirst mtag)

100 run = maybe id (sguard . isNonNull) (getFirst mtag)

104−guarder SExpr (E tag) _ isNonNull (E a) = E $ sguard condition a

101+guarder SExpr tag _ isNonNull a = sguard condition a

105 where

102 where

106 condition = isNonNull tag

103 condition = isNonNull tag

107guarder SName _ _ _ name = name

104guarder SName _ _ _ name = name

108−guarder SResult (R tag) isNonNull _ (R a) = R (bool Nothing a condition)

105+guarder SResult (Identity tag) isNonNull _ (Identity a) =

106+ Identity (bool Nothing a condition)

109 where

107 where

110 condition = isNonNull tag

108 condition = isNonNull tag

111

109

112

110

113nullifier :: ()

111nullifier :: ()

114 => Nullifiability context

112 => Nullifiability context

115− -> SSpec ('Spec a)

113+ -> Spec a

116− -> context ('Spec a)

114+ -> context a

117− -> context ('Spec (Nullify a))

115+ -> context (Nullify a)

118−nullifier NAggregate SSpec {nullity} (A (Aggregate a)) =

116+nullifier NAggregate Spec {nullity} (Aggregate a) =

119− A $ Aggregate $ snullify nullity <$> a

117+ Aggregate $ snullify nullity <$> a

120−nullifier NExpr SSpec {nullity} (E a) = E $ snullify nullity a

118+nullifier NExpr Spec {nullity} a = snullify nullity a

121−nullifier NName _ (N (Name a)) = N $ Name a

119+nullifier NName _ (Name a) = Name a

122

120

123

121

124unnullifier :: ()

122unnullifier :: ()

125 => Nullifiability context

123 => Nullifiability context

126− -> SSpec ('Spec a)

124+ -> Spec a

127− -> context ('Spec (Nullify a))

125+ -> context (Nullify a)

128− -> context ('Spec a)

126+ -> context a

129−unnullifier NAggregate SSpec {nullity} (A (Aggregate a)) =

127+unnullifier NAggregate Spec {nullity} (Aggregate a) =

130− A $ Aggregate $ sunnullify nullity <$> a

128+ Aggregate $ sunnullify nullity <$> a

131−unnullifier NExpr SSpec {nullity} (E a) = E $ sunnullify nullity a

129+unnullifier NExpr Spec {nullity} a = sunnullify nullity a

132−unnullifier NName _ (N (Name a)) = N $ Name a

130+unnullifier NName _ (Name a) = Name a

133

131

134

132

135sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)

133sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)

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

@@ -34,7 +34,7 @@ import Prelude

34

35-- rel8

36import Rel8.Schema.Dict ( Dict )

37−import Rel8.Schema.Spec ( Spec, SSpec )

37+import Rel8.Schema.Spec ( Spec )

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

39import qualified Rel8.Schema.Kind as K

40

@@ -50,14 +50,14 @@ import Data.Functor.Apply ( Apply, (<.>) )

50-- instances yourself or specify this constraint.

51type HTable :: K.HTable -> Constraint

52class HTable t where

53− type HField t = (field :: Spec -> Type) | field -> t

53+ type HField t = (field :: Type -> Type) | field -> t

54− type HConstrainTable t (c :: Spec -> Constraint) :: Constraint

54+ type HConstrainTable t (c :: Type -> Constraint) :: Constraint

55

56− hfield :: t context -> HField t spec -> context spec

56+ hfield :: t context -> HField t a -> context a

57− htabulate :: (forall spec. HField t spec -> context spec) -> t context

57+ htabulate :: (forall a. HField t a -> context a) -> t context

58− htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)

58+ htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g)

59 hdicts :: HConstrainTable t c => t (Dict c)

60− hspecs :: t SSpec

60+ hspecs :: t Spec

61

62 type HField t = GHField t

63 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c

@@ -68,7 +68,7 @@ class HTable t where

68 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

69 , GHTable context (Rep (t context))

70 )

71− => t context -> HField t spec -> context spec

71+ => t context -> HField t a -> context a

72 hfield table (GHField field) = hfield (toGHColumns (from table)) field

73

74 default htabulate ::

@@ -77,7 +77,7 @@ class HTable t where

77 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

78 , GHTable context (Rep (t context))

79 )

80− => (forall spec. HField t spec -> context spec) -> t context

80+ => (forall a. HField t a -> context a) -> t context

81 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)

82

83 default htraverse

@@ -87,7 +87,7 @@ class HTable t where

87 , Generic (t g), GHTable g (Rep (t g))

88 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))

89 )

90− => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)

90+ => (forall a. f a -> m (g a)) -> t f -> m (t g)

91 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from

92

93 default hdicts

@@ -101,10 +101,10 @@ class HTable t where

101 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)

102

103 default hspecs ::

104− ( Generic (t SSpec)

104+ ( Generic (t Spec)

105− , GHTable SSpec (Rep (t SSpec))

105+ , GHTable Spec (Rep (t Spec))

106 )

107− => t SSpec

107+ => t Spec

108 hspecs = to $ fromGHColumns hspecs

109

110 {-# INLINABLE hfield #-}

@@ -115,18 +115,18 @@ class HTable t where

115

116

117hmap :: HTable t

118− => (forall spec. context spec -> context' spec) -> t context -> t context'

118+ => (forall a. context a -> context' a) -> t context -> t context'

119hmap f a = htabulate $ \field -> f (hfield a field)

120

121

122htabulateA :: (HTable t, Apply m)

123− => (forall spec. HField t spec -> m (context spec)) -> m (t context)

123+ => (forall a. HField t a -> m (context a)) -> m (t context)

124htabulateA f = htraverse getCompose $ htabulate $ Compose . f

125{-# INLINABLE htabulateA #-}

126

127

128−type GHField :: K.HTable -> Spec -> Type

128+type GHField :: K.HTable -> Type -> Type

129−newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)

129+newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)

130

131

132type GHTable :: K.Context -> (Type -> Type) -> Constraint

@@ -155,10 +155,10 @@ instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) whe

155

156

157-- | A HField type for indexing into HProduct.

158−type HProductField :: K.HTable -> K.HTable -> Spec -> Type

158+type HProductField :: K.HTable -> K.HTable -> Type -> Type

159−data HProductField x y spec

159+data HProductField x y a

160− = HFst (HField x spec)

160+ = HFst (HField x a)

161− | HSnd (HField y spec)

161+ | HSnd (HField y a)

162

163

164instance (HTable x, HTable y) => HTable (HProduct x y) where

src/Rel8/Schema/HTable/Either.hs+2−2

@@ -15,7 +15,7 @@ import Prelude ()

15

16-- rel8

17import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Identity ( HType )

18+import Rel8.Schema.HTable.Identity ( HIdentity )

19import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Nullify ( HNullify )

21import qualified Rel8.Schema.Kind as K

@@ -24,7 +24,7 @@ import Rel8.Type.Tag ( EitherTag )

24

25type HEitherTable :: K.HTable -> K.HTable -> K.HTable

26data HEitherTable left right context = HEitherTable

27− { htag :: HLabel "isRight" (HType EitherTag) context

27+ { htag :: HLabel "isRight" (HIdentity EitherTag) context

28 , hleft :: HLabel "Left" (HNullify left) context

29 , hright :: HLabel "Right" (HNullify right) context

30 }

src/Rel8/Schema/HTable/Identity.hs+16−28

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

1{-# language DataKinds #-}

2−{-# language GADTs #-}

2+{-# language FlexibleContexts #-}

3−{-# language PatternSynonyms #-}

4{-# language StandaloneKindSignatures #-}

3{-# language StandaloneKindSignatures #-}

5{-# language TypeFamilies #-}

4{-# language TypeFamilies #-}

5+{-# language UndecidableInstances #-}

6

7module Rel8.Schema.HTable.Identity

8− ( HIdentity( HIdentity, HType, unHIdentity )

8+ ( HIdentity( HIdentity, unHIdentity )

9− , HType

10 )

9 )

11where

10where

12

11

13-- base

12-- base

14import Data.Kind ( Type )

13import Data.Kind ( Type )

14+import Data.Type.Equality ( (:~:)( Refl ) )

15import Prelude

16

17-- rel8

@@ -21,35 +21,23 @@ import Rel8.Schema.HTable

21 , hfield, htabulate, htraverse, hdicts, hspecs

22 )

23import qualified Rel8.Schema.Kind as K

24−import Rel8.Schema.Spec ( Spec( Spec ), KnownSpec, specSing )

24+import Rel8.Schema.Null ( Sql )

25+import Rel8.Schema.Spec ( specification )

26+import Rel8.Type ( DBType )

25

27

26

28

27−type HType :: Type -> K.HTable

29+type HIdentity :: Type -> K.HTable

28−type HType a = HIdentity ('Spec a)

29−

30−

31−pattern HType :: context ('Spec a) -> HType a context

32−pattern HType a = HIdentity a

33−{-# COMPLETE HType #-}

34−

35−

36−type HIdentity :: Spec -> K.HTable

37−newtype HIdentity spec context = HIdentity

30+newtype HIdentity a context = HIdentity

38− { unHIdentity :: context spec

31+ { unHIdentity :: context a

39 }

32 }

40

33

41

34

42−type HIdentityField :: Spec -> Spec -> Type

43−data HIdentityField _spec spec where

44− HIdentityField :: HIdentityField spec spec

45−

46−

47−instance KnownSpec spec => HTable (HIdentity spec) where

35+instance Sql DBType a => HTable (HIdentity a) where

48− type HConstrainTable (HIdentity spec) c = c spec

36+ type HConstrainTable (HIdentity a) constraint = constraint a

49− type HField (HIdentity spec) = HIdentityField spec

37+ type HField (HIdentity a) = (:~:) a

50

38

51− hfield (HIdentity a) HIdentityField = a

39+ hfield (HIdentity a) Refl = a

52− htabulate f = HIdentity $ f HIdentityField

40+ htabulate f = HIdentity $ f Refl

53 htraverse f (HIdentity a) = HIdentity <$> f a

41 htraverse f (HIdentity a) = HIdentity <$> f a

54 hdicts = HIdentity Dict

42 hdicts = HIdentity Dict

55− hspecs = HIdentity specSing

43+ hspecs = HIdentity specification

src/Rel8/Schema/HTable/Label.hs+4−4

@@ -19,15 +19,15 @@ import Prelude

19-- rel8

20import Rel8.Schema.HTable

21import qualified Rel8.Schema.Kind as K

22−import Rel8.Schema.Spec ( Spec, SSpec(..) )

22+import Rel8.Schema.Spec ( Spec(..) )

23

24

25type HLabel :: Symbol -> K.HTable -> K.HTable

26newtype HLabel label table context = HLabel (table context)

27

28

29−type HLabelField :: Symbol -> K.HTable -> Spec -> Type

29+type HLabelField :: Symbol -> K.HTable -> Type -> Type

30−newtype HLabelField label table spec = HLabelField (HField table spec)

30+newtype HLabelField label table a = HLabelField (HField table a)

31

32

33instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

@@ -40,7 +40,7 @@ instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

40 htraverse f (HLabel a) = HLabel <$> htraverse f a

41 hdicts = HLabel (hdicts @table)

42 hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of

43− SSpec {..} -> SSpec {labels = symbolVal (Proxy @label) : labels, ..}

43+ Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..}

44 {-# INLINABLE hspecs #-}

45

46

src/Rel8/Schema/HTable/MapTable.hs+14−12

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

6{-# language GADTs #-}

7{-# language InstanceSigs #-}

8{-# language MultiParamTypeClasses #-}

9−{-# language PolyKinds #-}

10{-# language ScopedTypeVariables #-}

9{-# language ScopedTypeVariables #-}

11{-# language StandaloneKindSignatures #-}

10{-# language StandaloneKindSignatures #-}

12{-# language TypeApplications #-}

11{-# language TypeApplications #-}

@@ -24,29 +23,32 @@ where

24

23

25-- base

24-- base

26import Data.Kind ( Constraint, Type )

25import Data.Kind ( Constraint, Type )

27−import Prelude ( ($), (.), (<$>), fmap )

26+import Prelude

28

27

29-- rel8

28-- rel8

30−import Rel8.FCF

29+import Rel8.FCF ( Exp, Eval )

31import Rel8.Schema.HTable

30import Rel8.Schema.HTable

31+ ( HTable, HConstrainTable, HField

32+ , hfield, htabulate, htraverse, hdicts, hspecs

33+ )

32−import Rel8.Schema.Spec ( Spec, SSpec )

34+import Rel8.Schema.Spec ( Spec )

33import qualified Rel8.Schema.Kind as K

35import qualified Rel8.Schema.Kind as K

34import Rel8.Schema.Dict ( Dict( Dict ) )

36import Rel8.Schema.Dict ( Dict( Dict ) )

35

37

36

38

37−type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type

39+type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable

38−newtype HMapTable f t g = HMapTable

40+newtype HMapTable f t context = HMapTable

39− { unHMapTable :: t (Precompose f g)

41+ { unHMapTable :: t (Precompose f context)

40 }

42 }

41

43

42

44

43−type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type

45+type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context

44newtype Precompose f g x = Precompose

46newtype Precompose f g x = Precompose

45 { precomposed :: g (Eval (f x))

47 { precomposed :: g (Eval (f x))

46 }

48 }

47

49

48

50

49−type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type

51+type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context

50data HMapTableField f t x where

52data HMapTableField f t x where

51 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))

53 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))

52

54

@@ -79,11 +81,11 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where

79 {-# INLINABLE hspecs #-}

81 {-# INLINABLE hspecs #-}

80

82

81

83

82−type MapSpec :: (Spec -> Exp Spec) -> Constraint

84+type MapSpec :: (Type -> Exp Type) -> Constraint

83class MapSpec f where

85class MapSpec f where

84− mapInfo :: SSpec x -> SSpec (Eval (f x))

86+ mapInfo :: Spec x -> Spec (Eval (f x))

85

87

86

88

87−type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint

89+type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint

88class c (Eval (f a)) => ComposeConstraint f c a

90class c (Eval (f a)) => ComposeConstraint f c a

89instance c (Eval (f a)) => ComposeConstraint f c a

91instance c (Eval (f a)) => ComposeConstraint f c a

src/Rel8/Schema/HTable/Maybe.hs+2−2

@@ -15,7 +15,7 @@ import Prelude

15

16-- rel8

17import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Identity ( HType )

18+import Rel8.Schema.HTable.Identity ( HIdentity )

19import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Nullify ( HNullify )

21import qualified Rel8.Schema.Kind as K

@@ -24,7 +24,7 @@ import Rel8.Type.Tag ( MaybeTag )

24

25type HMaybeTable :: K.HTable -> K.HTable

26data HMaybeTable table context = HMaybeTable

27− { htag :: HLabel "isJust" (HType (Maybe MaybeTag)) context

27+ { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context

28 , hjust :: HLabel "Just" (HNullify table) context

29 }

30 deriving stock Generic

src/Rel8/Schema/HTable/Nullify.hs+14−24

@@ -27,6 +27,7 @@ module Rel8.Schema.HTable.Nullify

27where

28

29-- base

30+import Data.Kind ( Type )

30import GHC.Generics ( Generic )

31import GHC.Generics ( Generic )

31import Prelude hiding ( null )

32import Prelude hiding ( null )

32

33

@@ -40,7 +41,7 @@ import Rel8.Schema.HTable.MapTable

40import qualified Rel8.Schema.Kind as K

41import qualified Rel8.Schema.Kind as K

41import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

42import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

42import qualified Rel8.Schema.Null as Type ( Nullify )

43import qualified Rel8.Schema.Null as Type ( Nullify )

43−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

44+import Rel8.Schema.Spec ( Spec(..) )

44

45

45-- semigroupoids

46-- semigroupoids

46import Data.Functor.Apply ( Apply )

47import Data.Functor.Apply ( Apply )

@@ -52,17 +53,14 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)

52 deriving anyclass HTable

53 deriving anyclass HTable

53

54

55

55−-- | Transform a 'Spec' by allowing it to be @null@.

56+-- | Transform a 'Type' by allowing it to be @null@.

56−data Nullify :: Spec -> Exp Spec

57+data Nullify :: Type -> Exp Type

57−

58−

59−type instance Eval (Nullify ('Spec a)) =

58+type instance Eval (Nullify a) = Type.Nullify a

60− 'Spec (Type.Nullify a)

61

59

62

60

63instance MapSpec Nullify where

61instance MapSpec Nullify where

64 mapInfo = \case

62 mapInfo = \case

65− SSpec {nullity, ..} -> SSpec

63+ Spec {nullity, ..} -> Spec

66 { nullity = case nullity of

64 { nullity = case nullity of

67 Null -> Null

65 Null -> Null

68 NotNull -> Null

66 NotNull -> Null

@@ -71,49 +69,41 @@ instance MapSpec Nullify where

71

69

72

70

73hguard :: HTable t

71hguard :: HTable t

74− => (forall a. context ('Spec (Maybe a)) -> context ('Spec (Maybe a)))

72+ => (forall a. context (Maybe a) -> context (Maybe a))

75 -> HNullify t context -> HNullify t context

73 -> HNullify t context -> HNullify t context

76hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->

74hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->

77 case hfield hspecs field of

75 case hfield hspecs field of

78− SSpec {nullity} -> case hfield as (HMapTableField field) of

76+ Spec {nullity} -> case hfield as (HMapTableField field) of

79 a -> case nullity of

77 a -> case nullity of

80 Null -> guarder a

78 Null -> guarder a

81 NotNull -> guarder a

79 NotNull -> guarder a

82

80

83

81

84hnulls :: HTable t

82hnulls :: HTable t

85− => (forall a. ()

86− => SSpec ('Spec a)

87− -> context ('Spec (Type.Nullify a)))

83+ => (forall a. Spec a -> context (Type.Nullify a))

88 -> HNullify t context

84 -> HNullify t context

89hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->

85hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->

90 case hfield hspecs field of

86 case hfield hspecs field of

91− spec@SSpec {} -> null spec

87+ spec@Spec {} -> null spec

92{-# INLINABLE hnulls #-}

88{-# INLINABLE hnulls #-}

93

89

94

90

95hnullify :: HTable t

91hnullify :: HTable t

96− => (forall a. ()

97− => SSpec ('Spec a)

98− -> context ('Spec a)

99− -> context ('Spec (Type.Nullify a)))

92+ => (forall a. Spec a -> context a -> context (Type.Nullify a))

100 -> t context

93 -> t context

101 -> HNullify t context

94 -> HNullify t context

102hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->

95hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->

103 case hfield hspecs field of

96 case hfield hspecs field of

104− spec@SSpec {} -> nullifier spec (hfield a field)

97+ spec@Spec {} -> nullifier spec (hfield a field)

105{-# INLINABLE hnullify #-}

98{-# INLINABLE hnullify #-}

106

99

107

100

108hunnullify :: (HTable t, Apply m)

101hunnullify :: (HTable t, Apply m)

109− => (forall a. ()

110− => SSpec ('Spec a)

111− -> context ('Spec (Type.Nullify a))

102+ => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))

112− -> m (context ('Spec a)))

113 -> HNullify t context

103 -> HNullify t context

114 -> m (t context)

104 -> m (t context)

115hunnullify unnullifier (HNullify as) =

105hunnullify unnullifier (HNullify as) =

116 htabulateA $ \field -> case hfield hspecs field of

106 htabulateA $ \field -> case hfield hspecs field of

117− spec@SSpec {} -> case hfield as (HMapTableField field) of

107+ spec@Spec {} -> case hfield as (HMapTableField field) of

118 a -> unnullifier spec a

108 a -> unnullifier spec a

119{-# INLINABLE hunnullify #-}

109{-# INLINABLE hunnullify #-}

src/Rel8/Schema/HTable/These.hs+3−3

@@ -15,7 +15,7 @@ import Prelude

15

16-- rel8

17import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Identity ( HType )

18+import Rel8.Schema.HTable.Identity ( HIdentity )

19import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Nullify ( HNullify )

21import qualified Rel8.Schema.Kind as K

@@ -24,9 +24,9 @@ import Rel8.Type.Tag ( MaybeTag )

24

25type HTheseTable :: K.HTable -> K.HTable -> K.HTable

26data HTheseTable here there context = HTheseTable

27− { hhereTag :: HLabel "hereTag" (HType (Maybe MaybeTag)) context

27+ { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context

28 , hhere :: HLabel "Here" (HNullify here) context

29− , hthereTag :: HLabel "thereTag" (HType (Maybe MaybeTag)) context

29+ , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context

30 , hthere :: HLabel "There" (HNullify there) context

31 }

32 deriving stock Generic

src/Rel8/Schema/HTable/Vectorize.hs+17−37

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

9{-# language GADTs #-}

10{-# language LambdaCase #-}

11{-# language MultiParamTypeClasses #-}

12−{-# language NamedFieldPuns #-}

13{-# language RankNTypes #-}

12{-# language RankNTypes #-}

14{-# language RecordWildCards #-}

13{-# language RecordWildCards #-}

15{-# language ScopedTypeVariables #-}

14{-# language ScopedTypeVariables #-}

@@ -33,12 +32,9 @@ import Prelude

33-- rel8

32-- rel8

34import Rel8.Schema.Dict ( Dict( Dict ) )

33import Rel8.Schema.Dict ( Dict( Dict ) )

35import qualified Rel8.Schema.Kind as K

34import qualified Rel8.Schema.Kind as K

36−import Rel8.Schema.HTable

37− ( HTable

38− , hfield, htabulate, htabulateA, hspecs

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

39− )

40import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )

36import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )

41−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

37+import Rel8.Schema.Spec ( Spec(..) )

42import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

38import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

43import Rel8.Type.Information ( TypeInformation )

39import Rel8.Type.Information ( TypeInformation )

44

40

@@ -73,16 +69,16 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t

73 deriving anyclass HTable

69 deriving anyclass HTable

74

70

75

71

76−data Vectorize :: (Type -> Type) -> Spec -> Exp Spec

72+data Vectorize :: (Type -> Type) -> Type -> Exp Type

77

73

78

74

79−type instance Eval (Vectorize list ('Spec a)) = 'Spec (list a)

75+type instance Eval (Vectorize list a) = list a

80

76

81

77

82instance Vector list => MapSpec (Vectorize list) where

78instance Vector list => MapSpec (Vectorize list) where

83 mapInfo = \case

79 mapInfo = \case

84− SSpec {..} -> case listNotNull @list nullity of

80+ Spec {..} -> case listNotNull @list nullity of

85− Dict -> SSpec

81+ Dict -> Spec

86 { nullity = NotNull

82 { nullity = NotNull

87 , info = vectorTypeInformation nullity info

83 , info = vectorTypeInformation nullity info

88 , ..

84 , ..

@@ -90,55 +86,39 @@ instance Vector list => MapSpec (Vectorize list) where

90

86

91

87

92hvectorize :: (HTable t, Unzip f, Vector list)

88hvectorize :: (HTable t, Unzip f, Vector list)

93− => (forall a. ()

94− => SSpec ('Spec a)

95− -> f (context ('Spec a))

96− -> context' ('Spec (list a)))

89+ => (forall a. Spec a -> f (context a) -> context' (list a))

97 -> f (t context)

90 -> f (t context)

98 -> HVectorize list t context'

91 -> HVectorize list t context'

99hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->

92hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->

100 case hfield hspecs field of

93 case hfield hspecs field of

101− spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)

94+ spec -> vectorizer spec (fmap (`hfield` field) as)

102{-# INLINABLE hvectorize #-}

95{-# INLINABLE hvectorize #-}

103

96

104

97

105hunvectorize :: (HTable t, Zip f, Vector list)

98hunvectorize :: (HTable t, Zip f, Vector list)

106− => (forall a. ()

107− => SSpec ('Spec a)

108− -> context ('Spec (list a))

99+ => (forall a. Spec a -> context (list a) -> f (context' a))

109− -> f (context' ('Spec a)))

110 -> HVectorize list t context

100 -> HVectorize list t context

111 -> f (t context')

101 -> f (t context')

112hunvectorize unvectorizer (HVectorize table) =

102hunvectorize unvectorizer (HVectorize table) =

113 getZippy $ htabulateA $ \field -> case hfield hspecs field of

103 getZippy $ htabulateA $ \field -> case hfield hspecs field of

114− spec@SSpec{} -> case hfield table (HMapTableField field) of

104+ spec -> case hfield table (HMapTableField field) of

115 a -> Zippy (unvectorizer spec a)

105 a -> Zippy (unvectorizer spec a)

116{-# INLINABLE hunvectorize #-}

106{-# INLINABLE hunvectorize #-}

117

107

118

108

119−happend :: (HTable t, Vector list) =>

109+happend :: (HTable t, Vector list)

120− ( forall a. ()

110+ => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))

121− => Nullity a

122− -> TypeInformation (Unnullify a)

123− -> context ('Spec (list a))

124− -> context ('Spec (list a))

125− -> context ('Spec (list a))

126− )

127 -> HVectorize list t context

111 -> HVectorize list t context

128 -> HVectorize list t context

112 -> HVectorize list t context

129 -> HVectorize list t context

113 -> HVectorize list t context

130happend append (HVectorize as) (HVectorize bs) = HVectorize $

114happend append (HVectorize as) (HVectorize bs) = HVectorize $

131 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of

115 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of

132 (a, b) -> case hfield hspecs j of

116 (a, b) -> case hfield hspecs j of

133− SSpec {nullity, info} -> append nullity info a b

117+ spec -> append spec a b

134

118

135

119

136−hempty :: HTable t =>

120+hempty :: HTable t

137− ( forall a. ()

121+ => (forall a. Spec a -> context [a])

138− => Nullity a

139− -> TypeInformation (Unnullify a)

140− -> context ('Spec [a])

141− )

142 -> HVectorize [] t context

122 -> HVectorize [] t context

143−hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of

123+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->

144− SSpec {nullity, info} -> empty nullity info

124+ empty (hfield hspecs field)

src/Rel8/Schema/Kind.hs+7−5

@@ -1,17 +1,19 @@

1{-# language StandaloneKindSignatures #-}

2

3−module Rel8.Schema.Kind ( Rel8able, Context, HTable ) where

3+module Rel8.Schema.Kind

4+ ( Rel8able

5+ , Context

6+ , HTable

7+ )

8+where

4

9

5-- base

10-- base

6import Data.Kind ( Type )

11import Data.Kind ( Type )

7import Prelude ()

12import Prelude ()

8

13

9−-- rel8

10−import Rel8.Schema.Spec ( Spec )

11−

12

14

13type Context :: Type

15type Context :: Type

14−type Context = Spec -> Type

16+type Context = Type -> Type

15

17

16

18

17type HTable :: Type

19type HTable :: Type

src/Rel8/Schema/Name.hs+15−27

@@ -3,10 +3,9 @@

3{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

5{-# language GADTs #-}

6+{-# language GeneralizedNewtypeDeriving #-}

6{-# language MultiParamTypeClasses #-}

7{-# language MultiParamTypeClasses #-}

7−{-# language PolyKinds #-}

8{-# language RankNTypes #-}

9−{-# language StandaloneDeriving #-}

10{-# language StandaloneKindSignatures #-}

9{-# language StandaloneKindSignatures #-}

11{-# language TypeFamilies #-}

10{-# language TypeFamilies #-}

12{-# language UndecidableInstances #-}

11{-# language UndecidableInstances #-}

@@ -18,17 +17,16 @@ module Rel8.Schema.Name

18where

17where

19

18

20-- base

19-- base

20+import Data.Functor.Identity ( Identity( Identity ) )

21import Data.Kind ( Constraint, Type )

22−import Data.String ( IsString, fromString )

22+import Data.String ( IsString )

23import Prelude

24

25-- rel8

26import Rel8.Expr ( Expr )

27−import Rel8.Schema.Context.Lower ( Lower )

27+import qualified Rel8.Schema.Kind as K

28−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

28+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

29import Rel8.Schema.Null ( Sql )

30−import Rel8.Schema.Result ( Result( R ) )

31−import Rel8.Schema.Spec ( Spec( Spec ) )

32import Rel8.Table

30import Rel8.Table

33 ( Table, Columns, Context, fromColumns, toColumns

31 ( Table, Columns, Context, fromColumns, toColumns

34 , FromExprs, fromResult, toResult

32 , FromExprs, fromResult, toResult

@@ -42,32 +40,22 @@ import Rel8.Type ( DBType )

42-- schema definition. You can construct names by using the @OverloadedStrings@

40-- schema definition. You can construct names by using the @OverloadedStrings@

43-- extension and writing string literals. This is typically done when providing

41-- extension and writing string literals. This is typically done when providing

44-- a 'TableSchema' value.

42-- a 'TableSchema' value.

45−type Name :: k -> Type

43+type Name :: K.Context

46−data Name a where

44+newtype Name a = Name String

47− Name :: forall (a :: Type). !String -> Name a

48− N :: { unN :: !(Name a) } -> Name ('Spec a)

49−

50−

51−type instance Lower Name = Name

52−

53−

54−deriving stock instance Show (Name a)

45+ deriving stock Show

55−

46+ deriving newtype IsString

56−

57−instance k ~ Type => IsString (Name (a :: k)) where

58− fromString = Name

59

47

60

48

61instance Sql DBType a => Table Name (Name a) where

49instance Sql DBType a => Table Name (Name a) where

62− type Columns (Name a) = HType a

50+ type Columns (Name a) = HIdentity a

63 type Context (Name a) = Name

51 type Context (Name a) = Name

64 type FromExprs (Name a) = a

52 type FromExprs (Name a) = a

65− type Transpose to (Name a) = Lower to a

53+ type Transpose to (Name a) = to a

66

54

67− toColumns a = HType (N a)

55+ toColumns a = HIdentity a

68− fromColumns (HType (N a)) = a

56+ fromColumns (HIdentity a) = a

69− toResult a = HType (R a)

57+ toResult a = HIdentity (Identity a)

70− fromResult (HType (R a)) = a

58+ fromResult (HIdentity (Identity a)) = a

71

59

72

60

73-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for

61-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for

src/Rel8/Schema/Result.hs+16−33

@@ -5,21 +5,20 @@

5{-# language TypeFamilies #-}

6

7module Rel8.Schema.Result

8− ( Result( R, unR )

8+ ( Result

9 , null, nullifier, unnullifier

10 , vectorizer, unvectorizer

11 )

12where

13

14-- base

15−import Data.Functor.Identity ( Identity )

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

16import Prelude hiding ( null )

17

18-- rel8

19−import Rel8.Schema.Context.Lower ( Lower )

20import Rel8.Schema.Kind ( Context )

19import Rel8.Schema.Kind ( Context )

21import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

20import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

22−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

21+import Rel8.Schema.Spec ( Spec(..) )

23

22

24

23

25-- | The @Result@ context is the context used for decoded query results.

24-- | The @Result@ context is the context used for decoded query results.

@@ -27,45 +26,29 @@ import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

27-- When a query is executed against a PostgreSQL database, Rel8 parses the

26-- When a query is executed against a PostgreSQL database, Rel8 parses the

28-- returned rows, decoding each row into the @Result@ context.

27-- returned rows, decoding each row into the @Result@ context.

29type Result :: Context

28type Result :: Context

30−data Result a where

29+type Result = Identity

31− R :: { unR :: !a } -> Result ('Spec a)

32

30

33

31

34−type instance Lower Result = Identity

32+null :: Result (Maybe a)

33+null = Identity Nothing

35

34

36

35

37−null :: Result ('Spec (Maybe a))

38−null = R Nothing

39−

40−

41−nullifier :: ()

42− => SSpec ('Spec a)

43− -> Result ('Spec a)

44− -> Result ('Spec (Nullify a))

36+nullifier :: Spec a -> Result a -> Result (Nullify a)

45−nullifier SSpec {nullity} (R a) = R $ case nullity of

37+nullifier Spec {nullity} (Identity a) = Identity $ case nullity of

46 Null -> a

38 Null -> a

47 NotNull -> Just a

39 NotNull -> Just a

48

40

49

41

50−unnullifier :: ()

51− => SSpec ('Spec a)

52− -> Result ('Spec (Nullify a))

42+unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a)

53− -> Maybe (Result ('Spec a))

54−unnullifier SSpec {nullity} (R a) =

43+unnullifier Spec {nullity} (Identity a) =

55 case nullity of

44 case nullity of

56− Null -> pure $ R a

45+ Null -> pure $ Identity a

57− NotNull -> R <$> a

46+ NotNull -> Identity <$> a

58

47

59

48

60−vectorizer :: Functor f

49+vectorizer :: Functor f => Spec a -> f (Result a) -> Result (f a)

61− => SSpec ('Spec a)

62− -> f (Result ('Spec a))

63− -> Result ('Spec (f a))

64−vectorizer _ = R . fmap unR

50+vectorizer _ = Identity . fmap runIdentity

65

51

66

52

67−unvectorizer :: Functor f

53+unvectorizer :: Functor f => Spec a -> Result (f a) -> f (Result a)

68− => SSpec ('Spec a)

69− -> Result ('Spec (f a))

70− -> f (Result ('Spec a))

71−unvectorizer _ (R results) = R <$> results

54+unvectorizer _ (Identity results) = Identity <$> results

src/Rel8/Schema/Spec.hs+16−30

@@ -1,18 +1,15 @@

1−{-# language DataKinds #-}

2{-# language FlexibleContexts #-}

1{-# language FlexibleContexts #-}

3−{-# language GADTs #-}

2+{-# language MonoLocalBinds #-}

4{-# language StandaloneKindSignatures #-}

3{-# language StandaloneKindSignatures #-}

5−{-# language UndecidableInstances #-}

6

4

7module Rel8.Schema.Spec

5module Rel8.Schema.Spec

8− ( Spec( Spec )

9− , SSpec( SSpec, labels, info, nullity )

6+ ( Spec( Spec, labels, info, nullity )

10− , KnownSpec( specSing )

7+ , specification

11 )

8 )

12where

9where

13

10

14-- base

11-- base

15−import Data.Kind ( Constraint, Type )

12+import Data.Kind ( Type )

16import Prelude

13import Prelude

17

14

18-- rel8

15-- rel8

@@ -21,28 +18,17 @@ import Rel8.Type ( DBType, typeInformation )

21import Rel8.Type.Information ( TypeInformation )

18import Rel8.Type.Information ( TypeInformation )

22

19

23

20

24−type Spec :: Type

21+type Spec :: Type -> Type

25−newtype Spec = Spec Type

22+data Spec a = Spec

23+ { labels :: [String]

24+ , info :: TypeInformation (Unnullify a)

25+ , nullity :: Nullity a

26+ }

26

27

28

28−type SSpec :: Spec -> Type

29−data SSpec spec where

30− SSpec ::

31− { labels :: [String]

32− , info :: TypeInformation (Unnullify a)

33− , nullity :: Nullity a

34− }

35− -> SSpec ('Spec a)

36−

37−

38−type KnownSpec :: Spec -> Constraint

39−class KnownSpec spec where

40− specSing :: SSpec spec

41−

42−

43−instance Sql DBType a => KnownSpec ('Spec a) where

29+specification :: Sql DBType a => Spec a

44− specSing = SSpec

30+specification = Spec

45− { labels = []

31+ { labels = []

46− , info = typeInformation

32+ , info = typeInformation

47− , nullity = nullable

33+ , nullity = nullable

48− }

34+ }

src/Rel8/Schema/Spec/Constrain.hsdeleted−32

@@ -1,32 +0,0 @@

1−{-# language ConstraintKinds #-}

2−{-# language DataKinds #-}

3−{-# language FlexibleInstances #-}

4−{-# language MultiParamTypeClasses #-}

5−{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

7−{-# language UndecidableInstances #-}

8−{-# language UndecidableSuperClasses #-}

9−

10−module Rel8.Schema.Spec.Constrain

11− ( ConstrainSpec

12− )

13−where

14−

15−-- base

16−import Data.Kind ( Constraint, Type )

17−import Prelude ()

18−

19−-- rel8

20−import Rel8.Schema.Spec ( Spec( Spec ) )

21−

22−

23−type Unspec :: Spec -> Type

24−type family Unspec spec where

25− Unspec ('Spec a) = a

26−

27−

28−type ConstrainSpec :: (Type -> Constraint) -> Spec -> Constraint

29−class (spec ~ 'Spec (Unspec spec), constraint (Unspec spec)) =>

30− ConstrainSpec constraint spec

31−instance (spec ~ 'Spec (Unspec spec), constraint (Unspec spec)) =>

32− ConstrainSpec constraint spec

src/Rel8/Table.hs−15

@@ -35,10 +35,8 @@ import Rel8.Generic.Table.Record

35 )

36import Rel8.Generic.Record ( Record(..) )

37import Rel8.Schema.HTable ( HTable )

38−import Rel8.Schema.HTable.Identity ( HIdentity(..) )

39import qualified Rel8.Schema.Kind as K

38import qualified Rel8.Schema.Kind as K

40import Rel8.Schema.Result ( Result )

39import Rel8.Schema.Result ( Result )

41−import Rel8.Schema.Spec ( KnownSpec )

42

40

43

41

44-- | @Table@s are one of the foundational elements of Rel8, and describe data

42-- | @Table@s are one of the foundational elements of Rel8, and describe data

@@ -169,19 +167,6 @@ data TTranspose :: K.Context -> Type -> Exp Type

169type instance Eval (TTranspose context a) = Transpose context a

167type instance Eval (TTranspose context a) = Transpose context a

170

168

171

169

172−-- | Any context is trivially a table.

173−instance KnownSpec spec => Table context (context spec) where

174− type Columns (context spec) = HIdentity spec

175− type Context (context spec) = context

176− type FromExprs (context spec) = Result spec

177− type Transpose to (context spec) = to spec

178−

179− toColumns = HIdentity

180− fromColumns = unHIdentity

181− toResult = HIdentity

182− fromResult = unHIdentity

183−

184−

185instance (Table context a, Table context b) => Table context (a, b)

170instance (Table context a, Table context b) => Table context (a, b)

186

171

187

172

src/Rel8/Table/Aggregate.hs+7−9

@@ -16,8 +16,8 @@ import Data.Functor.Identity ( Identity( Identity ) )

16import Prelude

17

18-- rel8

19−import Rel8.Aggregate ( Aggregate( A ), Aggregates )

19+import Rel8.Aggregate ( Aggregate, Aggregates )

20−import Rel8.Expr ( Expr( E ) )

20+import Rel8.Expr ( Expr )

21import Rel8.Expr.Aggregate

22 ( groupByExpr

23 , slistAggExpr

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

27import Rel8.Schema.HTable ( HTable, hfield, htabulate )

28import Rel8.Schema.HTable.Vectorize ( hvectorize )

29import Rel8.Schema.Null ( Sql )

30−import Rel8.Schema.Spec ( SSpec( SSpec, info ) )

30+import Rel8.Schema.Spec ( Spec( Spec, info ) )

31−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

32import Rel8.Table ( toColumns, fromColumns )

31import Rel8.Table ( toColumns, fromColumns )

33import Rel8.Table.Eq ( EqTable, eqTable )

32import Rel8.Table.Eq ( EqTable, eqTable )

34import Rel8.Table.List ( ListTable )

33import Rel8.Table.List ( ListTable )

@@ -43,12 +42,11 @@ groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

43groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

42groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

44

43

45

44

46−hgroupBy :: HTable t

47− => t (Dict (ConstrainSpec (Sql DBEq))) -> t Expr -> t Aggregate

45+hgroupBy :: HTable t => t (Dict (Sql DBEq)) -> t Expr -> t Aggregate

48hgroupBy eqs exprs = htabulate $ \field ->

46hgroupBy eqs exprs = htabulate $ \field ->

49 case hfield eqs field of

47 case hfield eqs field of

50 Dict -> case hfield exprs field of

48 Dict -> case hfield exprs field of

51− E expr -> A $ groupByExpr expr

49+ expr -> groupByExpr expr

52

50

53

51

54-- | Aggregate rows into a single row containing an array of all aggregated

52-- | Aggregate rows into a single row containing an array of all aggregated

@@ -70,7 +68,7 @@ hgroupBy eqs exprs = htabulate $ \field ->

70listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates

68listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates

71listAgg (toColumns -> exprs) = fromColumns $

69listAgg (toColumns -> exprs) = fromColumns $

72 hvectorize

70 hvectorize

73− (\SSpec {info} (Identity (E a)) -> A $ slistAggExpr info a)

71+ (\Spec {info} (Identity a) -> slistAggExpr info a)

74 (pure exprs)

72 (pure exprs)

75

73

76

74

@@ -78,5 +76,5 @@ listAgg (toColumns -> exprs) = fromColumns $

78nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates

76nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates

79nonEmptyAgg (toColumns -> exprs) = fromColumns $

77nonEmptyAgg (toColumns -> exprs) = fromColumns $

80 hvectorize

78 hvectorize

81− (\SSpec {info} (Identity (E a)) -> A $ snonEmptyAggExpr info a)

79+ (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)

82 (pure exprs)

80 (pure exprs)

src/Rel8/Table/Bool.hs+5−6

@@ -13,7 +13,7 @@ where

13import Prelude

14

15-- rel8

16−import Rel8.Expr ( Expr( E, unE ) )

16+import Rel8.Expr ( Expr )

17import Rel8.Expr.Bool ( boolExpr, caseExpr )

18import Rel8.Expr.Null ( isNull, unsafeUnnullify )

19import Rel8.Schema.HTable ( htabulate, hfield )

@@ -28,8 +28,7 @@ bool :: Table Expr a => a -> a -> Expr Bool -> a

28bool (toColumns -> false) (toColumns -> true) condition =

29 fromColumns $ htabulate $ \field ->

30 case (hfield false field, hfield true field) of

31− (E falseExpr, E trueExpr) ->

32− E (boolExpr falseExpr trueExpr condition)

31+ (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition

33{-# INLINABLE bool #-}

32{-# INLINABLE bool #-}

34

33

35

34

@@ -39,9 +38,9 @@ bool (toColumns -> false) (toColumns -> true) condition =

39case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a

38case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a

40case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =

39case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =

41 fromColumns $ htabulate $ \field -> case hfield fallback field of

40 fromColumns $ htabulate $ \field -> case hfield fallback field of

42− E fallbackExpr ->

41+ fallbackExpr ->

43− case map (fmap (unE . (`hfield` field))) branches of

42+ case map (fmap (`hfield` field)) branches of

44− branchExprs -> E (caseExpr branchExprs fallbackExpr)

43+ branchExprs -> caseExpr branchExprs fallbackExpr

45

44

46

45

47-- | Like 'maybe', but to eliminate @null@.

46-- | Like 'maybe', but to eliminate @null@.

src/Rel8/Table/Either.hs+24−25

@@ -25,6 +25,7 @@ where

25

26-- base

27import Data.Bifunctor ( Bifunctor, bimap )

28+import Data.Functor.Identity ( Identity( Identity ) )

28import Data.Kind ( Type )

29import Data.Kind ( Type )

29import Prelude hiding ( undefined )

30import Prelude hiding ( undefined )

30

31

@@ -32,8 +33,8 @@ import Prelude hiding ( undefined )

32import Control.Comonad ( extract )

33import Control.Comonad ( extract )

33

34

34-- rel8

35-- rel8

35−import Rel8.Aggregate ( Aggregate( A ) )

36+import Rel8.Aggregate ( Aggregate )

36−import Rel8.Expr ( Expr( E ) )

37+import Rel8.Expr ( Expr )

37import Rel8.Expr.Aggregate ( groupByExpr )

38import Rel8.Expr.Aggregate ( groupByExpr )

38import Rel8.Expr.Serialize ( litExpr )

39import Rel8.Expr.Serialize ( litExpr )

39import Rel8.Kind.Context ( Reifiable )

40import Rel8.Kind.Context ( Reifiable )

@@ -43,9 +44,7 @@ import Rel8.Schema.HTable.Either ( HEitherTable(..) )

43import Rel8.Schema.HTable.Identity ( HIdentity(..) )

44import Rel8.Schema.HTable.Identity ( HIdentity(..) )

44import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

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

45import qualified Rel8.Schema.Kind as K

46import qualified Rel8.Schema.Kind as K

46−import Rel8.Schema.Name ( Name( N ) )

47+import Rel8.Schema.Name ( Name )

47−import Rel8.Schema.Result ( Result( R ) )

48−import Rel8.Schema.Spec ( Spec( Spec ) )

49import Rel8.Table

48import Rel8.Table

50 ( Table, Columns, Context, fromColumns, toColumns

49 ( Table, Columns, Context, fromColumns, toColumns

51 , FromExprs, fromResult, toResult

50 , FromExprs, fromResult, toResult

@@ -72,7 +71,7 @@ import Data.Functor.Bind ( Bind, (>>-) )

72-- adapted to work with Rel8.

71-- adapted to work with Rel8.

73type EitherTable :: K.Context -> Type -> Type -> Type

72type EitherTable :: K.Context -> Type -> Type -> Type

74data EitherTable context a b = EitherTable

73data EitherTable context a b = EitherTable

75− { tag :: context ('Spec EitherTag)

74+ { tag :: context EitherTag

76 , left :: Nullify context a

75 , left :: Nullify context a

77 , right :: Nullify context b

76 , right :: Nullify context b

78 }

77 }

@@ -84,8 +83,8 @@ instance Nullifiable context => Bifunctor (EitherTable context) where

84

83

85

84

86instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where

85instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where

87− EitherTable (E tag) l1 f <.> EitherTable (E tag') l2 a =

86+ EitherTable tag l1 f <.> EitherTable tag' l2 a =

88− EitherTable (E (tag <> tag')) (bool l1 l2 (isLeft tag)) (f <.> a)

87+ EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)

89

88

90

89

91instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where

90instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where

@@ -94,9 +93,9 @@ instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) w

94

93

95

94

96instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where

95instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where

97− EitherTable (E tag) l1 a >>- f = case f (extract a) of

96+ EitherTable tag l1 a >>- f = case f (extract a) of

98− EitherTable (E tag') l2 b ->

97+ EitherTable tag' l2 b ->

99− EitherTable (E (tag <> tag')) (bool l1 l2 (isRight tag)) b

98+ EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b

100

99

101

100

102instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where

101instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where

@@ -122,7 +121,7 @@ instance

122 EitherTable to (Transpose to a) (Transpose to b)

121 EitherTable to (Transpose to a) (Transpose to b)

123

122

124 toColumns EitherTable {tag, left, right} = HEitherTable

123 toColumns EitherTable {tag, left, right} = HEitherTable

125− { htag = hlabel $ HType tag

124+ { htag = hlabel $ HIdentity tag

126 , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left

125 , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left

127 , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right

126 , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right

128 }

127 }

@@ -135,18 +134,18 @@ instance

135

134

136 toResult = \case

135 toResult = \case

137 Left table -> HEitherTable

136 Left table -> HEitherTable

138− { htag = hlabel (HType (R IsLeft))

137+ { htag = hlabel (HIdentity (Identity IsLeft))

139 , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))

138 , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))

140 , hright = hlabel (toResult @_ @(Nullify context b) Nothing)

139 , hright = hlabel (toResult @_ @(Nullify context b) Nothing)

141 }

140 }

142 Right table -> HEitherTable

141 Right table -> HEitherTable

143− { htag = hlabel (HType (R IsRight))

142+ { htag = hlabel (HIdentity (Identity IsRight))

144 , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)

143 , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)

145 , hright = hlabel (toResult @_ @(Nullify context b) (Just table))

144 , hright = hlabel (toResult @_ @(Nullify context b) (Just table))

146 }

145 }

147

146

148 fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of

147 fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of

149− HType (R tag) -> case tag of

148+ HIdentity (Identity tag) -> case tag of

150 IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)

149 IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)

151 IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)

150 IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)

152 where

151 where

@@ -157,7 +156,7 @@ instance (EqTable a, EqTable b, context ~ Expr) =>

157 EqTable (EitherTable context a b)

156 EqTable (EitherTable context a b)

158 where

157 where

159 eqTable = HEitherTable

158 eqTable = HEitherTable

160− { htag = hlabel (HType Dict)

159+ { htag = hlabel (HIdentity Dict)

161 , hleft = hlabel (eqTable @(Nullify context a))

160 , hleft = hlabel (eqTable @(Nullify context a))

162 , hright = hlabel (eqTable @(Nullify context b))

161 , hright = hlabel (eqTable @(Nullify context b))

163 }

162 }

@@ -167,7 +166,7 @@ instance (OrdTable a, OrdTable b, context ~ Expr) =>

167 OrdTable (EitherTable context a b)

166 OrdTable (EitherTable context a b)

168 where

167 where

169 ordTable = HEitherTable

168 ordTable = HEitherTable

170− { htag = hlabel (HType Dict)

169+ { htag = hlabel (HIdentity Dict)

171 , hleft = hlabel (ordTable @(Nullify context a))

170 , hleft = hlabel (ordTable @(Nullify context a))

172 , hright = hlabel (ordTable @(Nullify context b))

171 , hright = hlabel (ordTable @(Nullify context b))

173 }

172 }

@@ -179,30 +178,30 @@ instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2

179

178

180-- | Test if an 'EitherTable' is a 'leftTable'.

179-- | Test if an 'EitherTable' is a 'leftTable'.

181isLeftTable :: EitherTable Expr a b -> Expr Bool

180isLeftTable :: EitherTable Expr a b -> Expr Bool

182−isLeftTable EitherTable {tag = E tag} = isLeft tag

181+isLeftTable EitherTable {tag} = isLeft tag

183

182

184

183

185-- | Test if an 'EitherTable' is a 'rightTable'.

184-- | Test if an 'EitherTable' is a 'rightTable'.

186isRightTable :: EitherTable Expr a b -> Expr Bool

185isRightTable :: EitherTable Expr a b -> Expr Bool

187−isRightTable EitherTable {tag = E tag} = isRight tag

186+isRightTable EitherTable {tag} = isRight tag

188

187

189

188

190-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a

189-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a

191-- 'leftTable' and 'rightTable'.

190-- 'leftTable' and 'rightTable'.

192eitherTable :: Table Expr c

191eitherTable :: Table Expr c

193 => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c

192 => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c

194−eitherTable f g EitherTable {tag = E tag, left, right} =

193+eitherTable f g EitherTable {tag, left, right} =

195 bool (f (extract left)) (g (extract right)) (isRight tag)

194 bool (f (extract left)) (g (extract right)) (isRight tag)

196

195

197

196

198-- | Construct a left 'EitherTable'. Like 'Left'.

197-- | Construct a left 'EitherTable'. Like 'Left'.

199leftTable :: Table Expr b => a -> EitherTable Expr a b

198leftTable :: Table Expr b => a -> EitherTable Expr a b

200−leftTable a = EitherTable (E (litExpr IsLeft)) (pure a) undefined

199+leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined

201

200

202

201

203-- | Construct a right 'EitherTable'. Like 'Right'.

202-- | Construct a right 'EitherTable'. Like 'Right'.

204rightTable :: Table Expr a => b -> EitherTable Expr a b

203rightTable :: Table Expr a => b -> EitherTable Expr a b

205−rightTable = EitherTable (E (litExpr IsRight)) undefined . pure

204+rightTable = EitherTable (litExpr IsRight) undefined . pure

206

205

207

206

208-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.

207-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.

@@ -212,8 +211,8 @@ aggregateEitherTable :: ()

212 -> (exprs' -> aggregates')

211 -> (exprs' -> aggregates')

213 -> EitherTable Expr exprs exprs'

212 -> EitherTable Expr exprs exprs'

214 -> EitherTable Aggregate aggregates aggregates'

213 -> EitherTable Aggregate aggregates aggregates'

215−aggregateEitherTable f g (EitherTable (E tag) a b) = EitherTable

214+aggregateEitherTable f g (EitherTable tag a b) = EitherTable

216− { tag = A (groupByExpr tag)

215+ { tag = groupByExpr tag

217 , left = aggregateNullify f a

216 , left = aggregateNullify f a

218 , right = aggregateNullify g b

217 , right = aggregateNullify g b

219 }

218 }

@@ -231,4 +230,4 @@ nameEitherTable

231 -> b

230 -> b

232 -- ^ Names of the columns in the @b@ table.

231 -- ^ Names of the columns in the @b@ table.

233 -> EitherTable Name a b

232 -> EitherTable Name a b

234−nameEitherTable tag left right = EitherTable (N tag) (pure left) (pure right)

233+nameEitherTable tag left right = EitherTable tag (pure left) (pure right)

src/Rel8/Table/Eq.hs+7−8

@@ -27,7 +27,7 @@ import GHC.Generics ( Rep )

27import Prelude

28

29-- rel8

30−import Rel8.Expr ( Expr( E ) )

30+import Rel8.Expr ( Expr )

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

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

33import Rel8.FCF ( Eval, Exp )

@@ -35,9 +35,8 @@ import Rel8.Generic.Record ( Record )

35import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )

36import Rel8.Schema.Dict ( Dict( Dict ) )

37import Rel8.Schema.HTable ( htabulateA, hfield )

38−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

38+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

39import Rel8.Schema.Null ( Sql )

40−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

41import Rel8.Table ( Table, Columns, toColumns, TColumns, TFromExprs )

40import Rel8.Table ( Table, Columns, toColumns, TColumns, TFromExprs )

42import Rel8.Type.Eq ( DBEq )

41import Rel8.Type.Eq ( DBEq )

43

42

@@ -47,13 +46,13 @@ import Rel8.Type.Eq ( DBEq )

47-- means "all columns in a 'Table' have an instance of 'DBEq'".

46-- means "all columns in a 'Table' have an instance of 'DBEq'".

48type EqTable :: Type -> Constraint

47type EqTable :: Type -> Constraint

49class Table Expr a => EqTable a where

48class Table Expr a => EqTable a where

50− eqTable :: Columns a (Dict (ConstrainSpec (Sql DBEq)))

49+ eqTable :: Columns a (Dict (Sql DBEq))

51

50

52 default eqTable ::

51 default eqTable ::

53 ( GTable TEqTable TColumns TFromExprs (Rep (Record a))

52 ( GTable TEqTable TColumns TFromExprs (Rep (Record a))

54 , Columns a ~ GColumns TColumns (Rep (Record a))

53 , Columns a ~ GColumns TColumns (Rep (Record a))

55 )

54 )

56− => Columns a (Dict (ConstrainSpec (Sql DBEq)))

55+ => Columns a (Dict (Sql DBEq))

57 eqTable =

56 eqTable =

58 gtable

57 gtable

59 @TEqTable

58 @TEqTable

@@ -70,7 +69,7 @@ type instance Eval (TEqTable a) = EqTable a

70

69

71

70

72instance Sql DBEq a => EqTable (Expr a) where

71instance Sql DBEq a => EqTable (Expr a) where

73− eqTable = HType Dict

72+ eqTable = HIdentity Dict

74

73

75

74

76instance (EqTable a, EqTable b) => EqTable (a, b)

75instance (EqTable a, EqTable b) => EqTable (a, b)

@@ -104,7 +103,7 @@ instance

104(toColumns -> as) ==: (toColumns -> bs) =

103(toColumns -> as) ==: (toColumns -> bs) =

105 foldl1' (&&.) $ getConst $ htabulateA $ \field ->

104 foldl1' (&&.) $ getConst $ htabulateA $ \field ->

106 case (hfield as field, hfield bs field) of

105 case (hfield as field, hfield bs field) of

107− (E a, E b) -> case hfield (eqTable @a) field of

106+ (a, b) -> case hfield (eqTable @a) field of

108 Dict -> Const (pure (a ==. b))

107 Dict -> Const (pure (a ==. b))

109infix 4 ==:

108infix 4 ==:

110

109

@@ -116,7 +115,7 @@ infix 4 ==:

116(toColumns -> as) /=: (toColumns -> bs) =

115(toColumns -> as) /=: (toColumns -> bs) =

117 foldl1' (||.) $ getConst $ htabulateA $ \field ->

116 foldl1' (||.) $ getConst $ htabulateA $ \field ->

118 case (hfield as field, hfield bs field) of

117 case (hfield as field, hfield bs field) of

119− (E a, E b) -> case hfield (eqTable @a) field of

118+ (a, b) -> case hfield (eqTable @a) field of

120 Dict -> Const (pure (a /=. b))

119 Dict -> Const (pure (a /=. b))

121infix 4 /=:

120infix 4 /=:

122

121

src/Rel8/Table/List.hs+10−12

@@ -21,16 +21,16 @@ import Data.Kind ( Type )

21import Prelude

22

23-- rel8

24−import Rel8.Expr ( Expr( E, unE ) )

24+import Rel8.Expr ( Expr )

25import Rel8.Expr.Array ( sappend, sempty, slistOf )

26import Rel8.Schema.Dict ( Dict( Dict ) )

27import Rel8.Schema.HTable.List ( HListTable )

28import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize, hunvectorize )

29import qualified Rel8.Schema.Kind as K

30−import Rel8.Schema.Name ( Name( N, Name ) )

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

31import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

32import Rel8.Schema.Result ( vectorizer, unvectorizer )

33−import Rel8.Schema.Spec ( SSpec(..) )

33+import Rel8.Schema.Spec ( Spec(..) )

34import Rel8.Table

35 ( Table, Context, Columns, fromColumns, toColumns

36 , FromExprs, fromResult, toResult

@@ -69,7 +69,7 @@ instance (Table context a, context ~ context') =>

69instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where

70 eqTable =

71 hvectorize

72− (\SSpec {nullity} (Identity Dict) -> case nullity of

72+ (\Spec {nullity} (Identity Dict) -> case nullity of

73 Null -> Dict

74 NotNull -> Dict)

75 (Identity (eqTable @a))

@@ -78,7 +78,7 @@ instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where

78instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where

79 ordTable =

80 hvectorize

81− (\SSpec {nullity} (Identity Dict) -> case nullity of

81+ (\Spec {nullity} (Identity Dict) -> case nullity of

82 Null -> Dict

83 NotNull -> Dict)

84 (Identity (ordTable @a))

@@ -96,24 +96,22 @@ instance context ~ Expr => AlternativeTable (ListTable context) where

96 emptyTable = mempty

97

98

99−instance (context ~ Expr, Table Expr a) =>

99+instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)

100− Semigroup (ListTable context a)

101 where

100 where

102− ListTable as <> ListTable bs = ListTable $

101+ ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs

103− happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs

104

102

105

103

106instance (context ~ Expr, Table Expr a) =>

104instance (context ~ Expr, Table Expr a) =>

107 Monoid (ListTable context a)

105 Monoid (ListTable context a)

108 where

106 where

109− mempty = ListTable $ hempty $ \_ -> E . sempty

107+ mempty = ListTable $ hempty $ \Spec {info} -> sempty info

110

108

111

109

112-- | Construct a @ListTable@ from a list of expressions.

110-- | Construct a @ListTable@ from a list of expressions.

113listTable :: Table Expr a => [a] -> ListTable Expr a

111listTable :: Table Expr a => [a] -> ListTable Expr a

114listTable =

112listTable =

115 ListTable .

113 ListTable .

116− hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) .

114+ hvectorize (\Spec {info} -> slistOf info) .

117 fmap toColumns

115 fmap toColumns

118

116

119

117

@@ -126,6 +124,6 @@ nameListTable

126 -> ListTable Name a

124 -> ListTable Name a

127nameListTable =

125nameListTable =

128 ListTable .

126 ListTable .

129− hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

127+ hvectorize (\_ (Identity (Name a)) -> Name a) .

130 pure .

128 pure .

131 toColumns

129 toColumns

src/Rel8/Table/Maybe.hs+19−21

@@ -23,6 +23,7 @@ where

23

24-- base

25import Data.Functor ( ($>) )

26+import Data.Functor.Identity ( Identity( Identity ) )

26import Data.Kind ( Type )

27import Data.Kind ( Type )

27import Data.Maybe ( fromMaybe, isJust )

28import Data.Maybe ( fromMaybe, isJust )

28import Prelude hiding ( null, undefined )

29import Prelude hiding ( null, undefined )

@@ -31,8 +32,8 @@ import Prelude hiding ( null, undefined )

31import Control.Comonad ( extract )

32import Control.Comonad ( extract )

32

33

33-- rel8

34-- rel8

34−import Rel8.Aggregate ( Aggregate( A ) )

35+import Rel8.Aggregate ( Aggregate )

35−import Rel8.Expr ( Expr(E ) )

36+import Rel8.Expr ( Expr )

36import Rel8.Expr.Aggregate ( groupByExpr )

37import Rel8.Expr.Aggregate ( groupByExpr )

37import Rel8.Expr.Bool ( boolExpr )

38import Rel8.Expr.Bool ( boolExpr )

38import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )

39import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )

@@ -42,11 +43,9 @@ import qualified Rel8.Schema.Kind as K

42import Rel8.Schema.HTable.Identity ( HIdentity(..) )

43import Rel8.Schema.HTable.Identity ( HIdentity(..) )

43import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

44import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

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

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

45−import Rel8.Schema.Name ( Name( N ) )

46+import Rel8.Schema.Name ( Name )

46import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

47import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

47import qualified Rel8.Schema.Null as N

48import qualified Rel8.Schema.Null as N

48−import Rel8.Schema.Result ( Result( R ) )

49−import Rel8.Schema.Spec ( Spec( Spec ) )

50import Rel8.Table

49import Rel8.Table

51 ( Table, Columns, Context, fromColumns, toColumns

50 ( Table, Columns, Context, fromColumns, toColumns

52 , FromExprs, fromResult, toResult

51 , FromExprs, fromResult, toResult

@@ -80,15 +79,14 @@ import Data.Functor.Bind ( Bind, (>>-) )

80-- a "nullTag" - to track whether or not the outer join produced any rows.

79-- a "nullTag" - to track whether or not the outer join produced any rows.

81type MaybeTable :: K.Context -> Type -> Type

80type MaybeTable :: K.Context -> Type -> Type

82data MaybeTable context a = MaybeTable

81data MaybeTable context a = MaybeTable

83− { tag :: context ('Spec (Maybe MaybeTag))

82+ { tag :: context (Maybe MaybeTag)

84 , just :: Nullify context a

83 , just :: Nullify context a

85 }

84 }

86 deriving stock Functor

85 deriving stock Functor

87

86

88

87

89instance context ~ Expr => Apply (MaybeTable context) where

88instance context ~ Expr => Apply (MaybeTable context) where

90− MaybeTable (E tag) f <.> MaybeTable (E tag') a =

89+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)

91− MaybeTable (E (tag <> tag')) (f <.> a)

92

90

93

91

94-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:

92-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:

@@ -99,8 +97,8 @@ instance context ~ Expr => Applicative (MaybeTable context) where

99

97

100

98

101instance context ~ Expr => Bind (MaybeTable context) where

99instance context ~ Expr => Bind (MaybeTable context) where

102− MaybeTable (E tag) a >>- f = case f (extract a) of

100+ MaybeTable tag a >>- f = case f (extract a) of

103− MaybeTable (E tag') b -> MaybeTable (E (tag <> tag')) b

101+ MaybeTable tag' b -> MaybeTable (tag <> tag') b

104

102

105

103

106-- | Has the same behavior as the @Monad@ instance for @Maybe@.

104-- | Has the same behavior as the @Monad@ instance for @Maybe@.

@@ -147,12 +145,12 @@ instance (Table context a, Reifiable context, context ~ context') =>

147 }

145 }

148

146

149 toResult ma = HMaybeTable

147 toResult ma = HMaybeTable

150− { htag = hlabel (HIdentity (R (IsJust <$ ma)))

148+ { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))

151 , hjust = hlabel (toResult @_ @(Nullify context a) ma)

149 , hjust = hlabel (toResult @_ @(Nullify context a) ma)

152 }

150 }

153

151

154 fromResult HMaybeTable {htag, hjust} = case hunlabel htag of

152 fromResult HMaybeTable {htag, hjust} = case hunlabel htag of

155− HType (R tag) -> tag $>

153+ HIdentity (Identity tag) -> tag $>

156 fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))

154 fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))

157 where

155 where

158 err = error "Maybe.fromColumns: mismatch between tag and data"

156 err = error "Maybe.fromColumns: mismatch between tag and data"

@@ -160,14 +158,14 @@ instance (Table context a, Reifiable context, context ~ context') =>

160

158

161instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where

159instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where

162 eqTable = HMaybeTable

160 eqTable = HMaybeTable

163− { htag = hlabel (HType Dict)

161+ { htag = hlabel (HIdentity Dict)

164 , hjust = hlabel (eqTable @(Nullify context a))

162 , hjust = hlabel (eqTable @(Nullify context a))

165 }

163 }

166

164

167

165

168instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where

166instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where

169 ordTable = HMaybeTable

167 ordTable = HMaybeTable

170− { htag = hlabel (HType Dict)

168+ { htag = hlabel (HIdentity Dict)

171 , hjust = hlabel (ordTable @(Nullify context a))

169 , hjust = hlabel (ordTable @(Nullify context a))

172 }

170 }

173

171

@@ -178,12 +176,12 @@ instance (ToExprs exprs a, context ~ Expr) =>

178

176

179-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.

177-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.

180isNothingTable :: MaybeTable Expr a -> Expr Bool

178isNothingTable :: MaybeTable Expr a -> Expr Bool

181−isNothingTable (MaybeTable (E tag) _) = isNull tag

179+isNothingTable (MaybeTable tag _) = isNull tag

182

180

183

181

184-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.

182-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.

185isJustTable :: MaybeTable Expr a -> Expr Bool

183isJustTable :: MaybeTable Expr a -> Expr Bool

186−isJustTable (MaybeTable (E tag) _) = isNonNull tag

184+isJustTable (MaybeTable tag _) = isNonNull tag

187

185

188

186

189-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

187-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

@@ -194,13 +192,13 @@ maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)

194

192

195-- | The null table. Like 'Nothing'.

193-- | The null table. Like 'Nothing'.

196nothingTable :: Table Expr a => MaybeTable Expr a

194nothingTable :: Table Expr a => MaybeTable Expr a

197−nothingTable = MaybeTable (E null) (pure undefined)

195+nothingTable = MaybeTable null (pure undefined)

198

196

199

197

200-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use

198-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use

201-- 'pure'.

199-- 'pure'.

202justTable :: a -> MaybeTable Expr a

200justTable :: a -> MaybeTable Expr a

203−justTable = MaybeTable (E mempty) . pure

201+justTable = MaybeTable mempty . pure

204

202

205

203

206-- | Project a single expression out of a 'MaybeTable'. You can think of this

204-- | Project a single expression out of a 'MaybeTable'. You can think of this

@@ -220,8 +218,8 @@ aggregateMaybeTable :: ()

220 => (exprs -> aggregates)

218 => (exprs -> aggregates)

221 -> MaybeTable Expr exprs

219 -> MaybeTable Expr exprs

222 -> MaybeTable Aggregate aggregates

220 -> MaybeTable Aggregate aggregates

223−aggregateMaybeTable f (MaybeTable (E tag) a) =

221+aggregateMaybeTable f (MaybeTable tag a) =

224− MaybeTable (A (groupByExpr tag)) (aggregateNullify f a)

222+ MaybeTable (groupByExpr tag) (aggregateNullify f a)

225

223

226

224

227-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you

225-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you

@@ -234,4 +232,4 @@ nameMaybeTable

234 -> a

232 -> a

235 -- ^ Names of the columns in @a@.

233 -- ^ Names of the columns in @a@.

236 -> MaybeTable Name a

234 -> MaybeTable Name a

237−nameMaybeTable tag = MaybeTable (N tag) . pure

235+nameMaybeTable tag = MaybeTable tag . pure

src/Rel8/Table/Name.hs+7−7

@@ -29,11 +29,11 @@ import Prelude

29import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

30

31-- rel8

32−import Rel8.Expr ( Expr( E ) )

32+import Rel8.Expr ( Expr )

33import Rel8.Expr.Opaleye ( toPrimExpr )

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

35−import Rel8.Schema.Name ( Name( N, Name ) )

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

36−import Rel8.Schema.Spec ( SSpec(..) )

36+import Rel8.Schema.Spec ( Spec(..) )

37import Rel8.Table ( Table(..) )

38import Rel8.Table.Cols ( Cols( Cols ) )

39

@@ -67,26 +67,26 @@ namesFromLabelsWith :: Table Name a

67 => (NonEmpty String -> String) -> a

68namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

69 case hfield hspecs field of

70− SSpec {labels} -> N (Name (f (renderLabels labels)))

70+ Spec {labels} -> Name (f (renderLabels labels))

71

72

73showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]

74showExprs as = case (namesFromLabels, toColumns as) of

75 (Cols names, exprs) -> getConst $ htabulateA $ \field ->

76 case (hfield names field, hfield exprs field) of

77− (N (Name name), E expr) -> Const [(name, toPrimExpr expr)]

77+ (Name name, expr) -> Const [(name, toPrimExpr expr)]

78

79

80showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

81showLabels _ = getConst $

82 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

83− SSpec {labels} -> Const [renderLabels labels]

83+ Spec {labels} -> Const [renderLabels labels]

84

85

86showNames :: forall a. Table Name a => a -> [String]

87showNames (toColumns -> names) = getConst $

88 htabulateA @(Columns a) $ \field -> case hfield names field of

89− N (Name name) -> Const [name]

89+ Name name -> Const [name]

90

91

92renderLabels :: [String] -> NonEmpty String

src/Rel8/Table/NonEmpty.hs+9−10

@@ -22,16 +22,16 @@ import Data.List.NonEmpty ( NonEmpty )

22import Prelude hiding ( id )

23

24-- rel8

25−import Rel8.Expr ( Expr( E, unE ) )

25+import Rel8.Expr ( Expr )

26import Rel8.Expr.Array ( sappend1, snonEmptyOf )

27import Rel8.Schema.Dict ( Dict( Dict ) )

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

29import Rel8.Schema.HTable.Vectorize ( happend, hvectorize, hunvectorize )

30import qualified Rel8.Schema.Kind as K

31−import Rel8.Schema.Name ( Name( N, Name ) )

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

32import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

33import Rel8.Schema.Result ( vectorizer, unvectorizer )

34−import Rel8.Schema.Spec ( SSpec(..) )

34+import Rel8.Schema.Spec ( Spec(..) )

35import Rel8.Table

36 ( Table, Context, Columns, fromColumns, toColumns

37 , FromExprs, fromResult, toResult

@@ -70,7 +70,7 @@ instance (EqTable a, context ~ Expr) =>

70 where

71 eqTable =

72 hvectorize

73− (\SSpec {nullity} (Identity Dict) -> case nullity of

73+ (\Spec {nullity} (Identity Dict) -> case nullity of

74 Null -> Dict

75 NotNull -> Dict)

76 (Identity (eqTable @a))

@@ -81,7 +81,7 @@ instance (OrdTable a, context ~ Expr) =>

81 where

82 ordTable =

83 hvectorize

84− (\SSpec {nullity} (Identity Dict) -> case nullity of

84+ (\Spec {nullity} (Identity Dict) -> case nullity of

85 Null -> Dict

86 NotNull -> Dict)

87 (Identity (ordTable @a))

@@ -95,18 +95,17 @@ instance context ~ Expr => AltTable (NonEmptyTable context) where

95 (<|>:) = (<>)

96

97

98−instance (Table Expr a, context ~ Expr) =>

99− Semigroup (NonEmptyTable context a)

98+instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)

100 where

99 where

101 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

100 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

102− happend (\_ _ (E a) (E b) -> E (sappend1 a b)) as bs

101+ happend (const sappend1) as bs

103

102

104

103

105-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

104-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

106nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

105nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

107nonEmptyTable =

106nonEmptyTable =

108 NonEmptyTable .

107 NonEmptyTable .

109− hvectorize (\SSpec {info} -> E . snonEmptyOf info . fmap unE) .

108+ hvectorize (\Spec {info} -> snonEmptyOf info) .

110 fmap toColumns

109 fmap toColumns

111

110

112

111

@@ -119,6 +118,6 @@ nameNonEmptyTable

119 -> NonEmptyTable Name a

118 -> NonEmptyTable Name a

120nameNonEmptyTable =

119nameNonEmptyTable =

121 NonEmptyTable .

120 NonEmptyTable .

122− hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

121+ hvectorize (\_ (Identity (Name a)) -> Name a) .

123 pure .

122 pure .

124 toColumns

123 toColumns

src/Rel8/Table/Nullify.hs+1−2

@@ -42,7 +42,6 @@ import Rel8.Schema.HTable ( HTable )

42import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify, hguard )

43import qualified Rel8.Schema.Kind as K

44import qualified Rel8.Schema.Result as R

45−import Rel8.Schema.Spec ( Spec( Spec ) )

46import Rel8.Table

45import Rel8.Table

47 ( Table, Columns, Context, toColumns, fromColumns

46 ( Table, Columns, Context, toColumns, fromColumns

48 , FromExprs, fromResult, toResult

47 , FromExprs, fromResult, toResult

@@ -165,7 +164,7 @@ aggregateNullify f = \case

165

164

166

165

167guard :: (Reifiable context, HTable t)

166guard :: (Reifiable context, HTable t)

168− => context ('Spec tag)

167+ => context tag

169 -> (tag -> Bool)

168 -> (tag -> Bool)

170 -> (Expr tag -> Expr Bool)

169 -> (Expr tag -> Expr Bool)

171 -> HNullify t context

170 -> HNullify t context

src/Rel8/Table/Opaleye.hs+18−22

@@ -37,8 +37,8 @@ import qualified Opaleye.Internal.Table as Opaleye

37import Data.Profunctor ( dimap, lmap )

38

39-- rel8

40−import Rel8.Aggregate ( Aggregate( A, Aggregate ), Aggregates )

40+import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )

41−import Rel8.Expr ( Expr(..) )

41+import Rel8.Expr ( Expr )

42import Rel8.Expr.Opaleye

43 ( fromPrimExpr, toPrimExpr

44 , traversePrimExpr

@@ -46,8 +46,8 @@ import Rel8.Expr.Opaleye

46 , scastExpr

47 )

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

49−import Rel8.Schema.Name ( Name( N, Name ), Selects )

49+import Rel8.Schema.Name ( Name( Name ), Selects )

50−import Rel8.Schema.Spec ( Spec, SSpec(..) )

50+import Rel8.Schema.Spec ( Spec(..) )

51import Rel8.Schema.Table ( TableSchema(..) )

52import Rel8.Table ( Table, fromColumns, toColumns )

53import Rel8.Table.Undefined ( undefined )

@@ -60,8 +60,8 @@ aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs

60aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->

61 fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

62 WrapApplicative $ case hfield (toColumns aggregates) field of

63− A (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) ->

63+ Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner)) ->

64− E <$> inner f ()

64+ inner f ()

65

66

67binaryspec :: Table Expr a => Opaleye.Binaryspec a a

@@ -69,7 +69,7 @@ binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->

69 fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

70 WrapApplicative $

71 case (hfield (toColumns as) field, hfield (toColumns bs) field) of

72− (E a, E b) -> E . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)

72+ (a, b) -> fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)

73

74

75distinctspec :: Table Expr a => Opaleye.Distinctspec a a

@@ -78,8 +78,7 @@ distinctspec =

78 fmap fromColumns .

79 unwrapApplicative .

80 htraverse

81− (\(E a) ->

82− WrapApplicative $ E . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .

81+ (\a -> WrapApplicative $ fromPrimExpr <$> f (Nothing, toPrimExpr a)) .

83 toColumns

82 toColumns

84

83

85

84

@@ -97,18 +96,17 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $

97 case hfield names field of

96 case hfield names field of

98 name -> lmap (`hfield` field) (go name)

97 name -> lmap (`hfield` field) (go name)

99 where

98 where

100− go :: forall (spec :: Spec). Name spec -> Opaleye.TableFields (Expr spec) (Expr spec)

99+ go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)

101− go (N (Name name)) =

100+ go (Name name) =

102− lmap (\(E a) -> toColumn $ toPrimExpr a) $

103− E . fromPrimExpr . fromColumn <$>

101+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

104− Opaleye.requiredTableField name

102+ Opaleye.requiredTableField name

105

103

106

104

107unpackspec :: Table Expr a => Opaleye.Unpackspec a a

105unpackspec :: Table Expr a => Opaleye.Unpackspec a a

108unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

106unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

109 fmap fromColumns .

107 fmap fromColumns .

110 unwrapApplicative .

108 unwrapApplicative .

111− htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) .

109+ htraverse (WrapApplicative . traversePrimExpr f) .

112 toColumns

110 toColumns

113{-# INLINABLE unpackspec #-}

111{-# INLINABLE unpackspec #-}

114

112

@@ -122,7 +120,7 @@ toPackMap :: Table Expr a

122toPackMap as = Opaleye.PackMap $ \f () ->

120toPackMap as = Opaleye.PackMap $ \f () ->

123 fmap fromColumns $

121 fmap fromColumns $

124 unwrapApplicative .

122 unwrapApplicative .

125− htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) $

123+ htraverse (WrapApplicative . traversePrimExpr f) $

126 toColumns as

124 toColumns as

127

125

128

126

@@ -130,9 +128,7 @@ toPackMap as = Opaleye.PackMap $ \f () ->

130-- finalising a SELECT or RETURNING statement, guaranteed that the output

128-- finalising a SELECT or RETURNING statement, guaranteed that the output

131-- matches what is encoded in each columns TypeInformation.

129-- matches what is encoded in each columns TypeInformation.

132castTable :: Table Expr a => a -> a

130castTable :: Table Expr a => a -> a

133−castTable (toColumns -> as) = fromColumns $ htabulate \i ->

131+castTable (toColumns -> as) = fromColumns $ htabulate \field ->

134− case hfield hspecs i of

132+ case hfield hspecs field of

135− SSpec{info} ->

136− case hfield as i of

133+ Spec {info} -> case hfield as field of

137− E expr ->

138− E (scastExpr info expr)

134+ expr -> scastExpr info expr

src/Rel8/Table/Ord.hs+9−10

@@ -24,7 +24,7 @@ import GHC.Generics ( Rep )

24import Prelude hiding ( seq )

25

26-- rel8

27−import Rel8.Expr ( Expr( E ) )

27+import Rel8.Expr ( Expr )

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

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

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

@@ -33,9 +33,8 @@ import Rel8.Generic.Record ( Record )

33import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )

34import Rel8.Schema.Dict ( Dict( Dict ) )

35import Rel8.Schema.HTable ( htabulateA, hfield )

36−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

36+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

37import Rel8.Schema.Null (Sql)

38−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

39import Rel8.Table ( Columns, toColumns, TColumns, TFromExprs )

38import Rel8.Table ( Columns, toColumns, TColumns, TFromExprs )

40import Rel8.Table.Bool ( bool )

39import Rel8.Table.Bool ( bool )

41import Rel8.Table.Eq ( EqTable )

40import Rel8.Table.Eq ( EqTable )

@@ -47,13 +46,13 @@ import Rel8.Type.Ord ( DBOrd )

47-- columns in a 'Table' have an instance of 'DBOrd'".

46-- columns in a 'Table' have an instance of 'DBOrd'".

48type OrdTable :: Type -> Constraint

47type OrdTable :: Type -> Constraint

49class EqTable a => OrdTable a where

48class EqTable a => OrdTable a where

50− ordTable :: Columns a (Dict (ConstrainSpec (Sql DBOrd)))

49+ ordTable :: Columns a (Dict (Sql DBOrd))

51

50

52 default ordTable ::

51 default ordTable ::

53 ( GTable TOrdTable TColumns TFromExprs (Rep (Record a))

52 ( GTable TOrdTable TColumns TFromExprs (Rep (Record a))

54 , Columns a ~ GColumns TColumns (Rep (Record a))

53 , Columns a ~ GColumns TColumns (Rep (Record a))

55 )

54 )

56− => Columns a (Dict (ConstrainSpec (Sql DBOrd)))

55+ => Columns a (Dict (Sql DBOrd))

57 ordTable =

56 ordTable =

58 gtable

57 gtable

59 @TOrdTable

58 @TOrdTable

@@ -70,7 +69,7 @@ type instance Eval (TOrdTable a) = OrdTable a

70

69

71

70

72instance Sql DBOrd a => OrdTable (Expr a) where

71instance Sql DBOrd a => OrdTable (Expr a) where

73− ordTable = HType Dict

72+ ordTable = HIdentity Dict

74

73

75

74

76instance (OrdTable a, OrdTable b) => OrdTable (a, b)

75instance (OrdTable a, OrdTable b) => OrdTable (a, b)

@@ -105,7 +104,7 @@ instance

105(toColumns -> as) <: (toColumns -> bs) =

104(toColumns -> as) <: (toColumns -> bs) =

106 foldr @[] go false $ getConst $ htabulateA $ \field ->

105 foldr @[] go false $ getConst $ htabulateA $ \field ->

107 case (hfield as field, hfield bs field) of

106 case (hfield as field, hfield bs field) of

108− (E a, E b) -> case hfield (ordTable @a) field of

107+ (a, b) -> case hfield (ordTable @a) field of

109 Dict -> Const [(a <. b, a ==. b)]

108 Dict -> Const [(a <. b, a ==. b)]

110 where

109 where

111 go (lt, eq) a = lt ||. (eq &&. a)

110 go (lt, eq) a = lt ||. (eq &&. a)

@@ -118,7 +117,7 @@ infix 4 <:

118(toColumns -> as) <=: (toColumns -> bs) =

117(toColumns -> as) <=: (toColumns -> bs) =

119 foldr @[] go true $ getConst $ htabulateA $ \field ->

118 foldr @[] go true $ getConst $ htabulateA $ \field ->

120 case (hfield as field, hfield bs field) of

119 case (hfield as field, hfield bs field) of

121− (E a, E b) -> case hfield (ordTable @a) field of

120+ (a, b) -> case hfield (ordTable @a) field of

122 Dict -> Const [(a <. b, a ==. b)]

121 Dict -> Const [(a <. b, a ==. b)]

123 where

122 where

124 go (lt, eq) a = lt ||. (eq &&. a)

123 go (lt, eq) a = lt ||. (eq &&. a)

@@ -131,7 +130,7 @@ infix 4 <=:

131(toColumns -> as) >: (toColumns -> bs) =

130(toColumns -> as) >: (toColumns -> bs) =

132 foldr @[] go false $ getConst $ htabulateA $ \field ->

131 foldr @[] go false $ getConst $ htabulateA $ \field ->

133 case (hfield as field, hfield bs field) of

132 case (hfield as field, hfield bs field) of

134− (E a, E b) -> case hfield (ordTable @a) field of

133+ (a, b) -> case hfield (ordTable @a) field of

135 Dict -> Const [(a >. b, a ==. b)]

134 Dict -> Const [(a >. b, a ==. b)]

136 where

135 where

137 go (gt, eq) a = gt ||. (eq &&. a)

136 go (gt, eq) a = gt ||. (eq &&. a)

@@ -144,7 +143,7 @@ infix 4 >:

144(toColumns -> as) >=: (toColumns -> bs) =

143(toColumns -> as) >=: (toColumns -> bs) =

145 foldr @[] go true $ getConst $ htabulateA $ \field ->

144 foldr @[] go true $ getConst $ htabulateA $ \field ->

146 case (hfield as field, hfield bs field) of

145 case (hfield as field, hfield bs field) of

147− (E a, E b) -> case hfield (ordTable @a) field of

146+ (a, b) -> case hfield (ordTable @a) field of

148 Dict -> Const [(a >. b, a ==. b)]

147 Dict -> Const [(a >. b, a ==. b)]

149 where

148 where

150 go (gt, eq) a = gt ||. (eq &&. a)

149 go (gt, eq) a = gt ||. (eq &&. a)

src/Rel8/Table/Order.hs+5−6

@@ -16,13 +16,12 @@ import Data.Functor.Contravariant ( (>$<), contramap )

16import Prelude

17

18-- rel8

19−import Rel8.Expr ( unE )

20import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )

19import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )

21import Rel8.Order ( Order )

20import Rel8.Order ( Order )

22import Rel8.Schema.Dict ( Dict( Dict ) )

21import Rel8.Schema.Dict ( Dict( Dict ) )

23import Rel8.Schema.HTable (htabulateA, hfield, hspecs)

22import Rel8.Schema.HTable (htabulateA, hfield, hspecs)

24import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

23import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

25−import Rel8.Schema.Spec ( SSpec( SSpec, nullity ) )

24+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

26import Rel8.Table ( Columns, toColumns )

25import Rel8.Table ( Columns, toColumns )

27import Rel8.Table.Ord ( OrdTable, ordTable )

26import Rel8.Table.Ord ( OrdTable, ordTable )

28

27

@@ -32,8 +31,8 @@ import Rel8.Table.Ord ( OrdTable, ordTable )

32ascTable :: forall a. OrdTable a => Order a

31ascTable :: forall a. OrdTable a => Order a

33ascTable = contramap toColumns $ getConst $

32ascTable = contramap toColumns $ getConst $

34 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

33 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

35− SSpec {nullity} -> case hfield (ordTable @a) field of

34+ Spec {nullity} -> case hfield (ordTable @a) field of

36− Dict -> Const $ unE . (`hfield` field) >$<

35+ Dict -> Const $ (`hfield` field) >$<

37 case nullity of

36 case nullity of

38 Null -> nullsFirst asc

37 Null -> nullsFirst asc

39 NotNull -> asc

38 NotNull -> asc

@@ -44,8 +43,8 @@ ascTable = contramap toColumns $ getConst $

44descTable :: forall a. OrdTable a => Order a

43descTable :: forall a. OrdTable a => Order a

45descTable = contramap toColumns $ getConst $

44descTable = contramap toColumns $ getConst $

46 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

45 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

47− SSpec {nullity} -> case hfield (ordTable @a) field of

46+ Spec {nullity} -> case hfield (ordTable @a) field of

48− Dict -> Const $ unE . (`hfield` field) >$<

47+ Dict -> Const $ (`hfield` field) >$<

49 case nullity of

48 case nullity of

50 Null -> nullsLast desc

49 Null -> nullsLast desc

51 NotNull -> desc

50 NotNull -> desc

src/Rel8/Table/Rel8able.hs+5−6

@@ -35,7 +35,6 @@ import Rel8.Table

35 , FromExprs, fromResult, toResult

36 , Transpose

37 )

38−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

39import Rel8.Table.ADT ( ADT )

38import Rel8.Table.ADT ( ADT )

40import Rel8.Table.Eq ( EqTable, eqTable )

39import Rel8.Table.Eq ( EqTable, eqTable )

41import Rel8.Table.Ord ( OrdTable, ordTable )

40import Rel8.Table.Ord ( OrdTable, ordTable )

@@ -61,22 +60,22 @@ instance (Rel8able t, Virtual context, context ~ context') =>

61instance

60instance

62 ( context ~ Expr

61 ( context ~ Expr

63 , Rel8able t

62 , Rel8able t

64− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))

63+ , HConstrainTable (Columns (t context)) (Sql DBEq)

65 )

64 )

66 => EqTable (t context)

65 => EqTable (t context)

67 where

66 where

68− eqTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBEq))

67+ eqTable = hdicts @(Columns (t context)) @(Sql DBEq)

69

68

70

69

71instance

70instance

72 ( context ~ Expr

71 ( context ~ Expr

73 , Rel8able t

72 , Rel8able t

74− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))

73+ , HConstrainTable (Columns (t context)) (Sql DBEq)

75− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBOrd))

74+ , HConstrainTable (Columns (t context)) (Sql DBOrd)

76 )

75 )

77 => OrdTable (t context)

76 => OrdTable (t context)

78 where

77 where

79− ordTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBOrd))

78+ ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)

80

79

81

80

82instance

81instance

src/Rel8/Table/Serialize.hs+7−10

@@ -16,6 +16,7 @@ module Rel8.Table.Serialize

16where

17

18-- base

19+import Data.Functor.Identity ( Identity( Identity ) )

19import Data.Kind ( Constraint, Type )

20import Data.Kind ( Constraint, Type )

20import Data.List.NonEmpty ( NonEmpty )

21import Data.List.NonEmpty ( NonEmpty )

21import Prelude

22import Prelude

@@ -24,12 +25,12 @@ import Prelude

24import qualified Hasql.Decoders as Hasql

25import qualified Hasql.Decoders as Hasql

25

26

26-- rel8

27-- rel8

27−import Rel8.Expr ( Expr( E ) )

28+import Rel8.Expr ( Expr )

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

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

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

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

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

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

31−import Rel8.Schema.Result ( Result( R ) )

32+import Rel8.Schema.Result ( Result )

32−import Rel8.Schema.Spec ( SSpec(..), KnownSpec )

33+import Rel8.Schema.Spec ( Spec(..) )

33import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )

34import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )

34import Rel8.Type ( DBType )

35import Rel8.Type ( DBType )

35

36

@@ -115,10 +116,6 @@ instance

115 => ToExprs x (a, b, c, d, e, f, g)

116 => ToExprs x (a, b, c, d, e, f, g)

116

117

118

118−instance (KnownSpec spec, x ~ Expr spec) =>

119− ToExprs x (Result spec)

120−

121−

122-- | @Serializable@ witnesses the one-to-one correspondence between the type

119-- | @Serializable@ witnesses the one-to-one correspondence between the type

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

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

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

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

@@ -141,11 +138,11 @@ parse = fromResult @_ @exprs <$> parseHTable

141litHTable :: HTable t => t Result -> t Expr

138litHTable :: HTable t => t Result -> t Expr

142litHTable as = htabulate $ \field ->

139litHTable as = htabulate $ \field ->

143 case hfield hspecs field of

140 case hfield hspecs field of

144− SSpec {nullity, info} -> case hfield as field of

141+ Spec {nullity, info} -> case hfield as field of

145− R value -> E (slitExpr nullity info value)

142+ Identity value -> slitExpr nullity info value

146

143

147

144

148parseHTable :: HTable t => Hasql.Row (t Result)

145parseHTable :: HTable t => Hasql.Row (t Result)

149parseHTable = unwrapApplicative $ htabulateA $ \field ->

146parseHTable = unwrapApplicative $ htabulateA $ \field ->

150 WrapApplicative $ case hfield hspecs field of

147 WrapApplicative $ case hfield hspecs field of

151− SSpec {nullity, info} -> R <$> sparseValue nullity info

148+ Spec {nullity, info} -> Identity <$> sparseValue nullity info

src/Rel8/Table/These.hs+4−4

@@ -208,9 +208,9 @@ instance (EqTable a, EqTable b, context ~ Expr) =>

208 EqTable (TheseTable context a b)

209 where

210 eqTable = HTheseTable

211− { hhereTag = hlabel (HType Dict)

211+ { hhereTag = hlabel (HIdentity Dict)

212 , hhere = hlabel (eqTable @(Nullify context a))

213− , hthereTag = hlabel (HType Dict)

213+ , hthereTag = hlabel (HIdentity Dict)

214 , hthere = hlabel (eqTable @(Nullify context b))

215 }

216

@@ -219,9 +219,9 @@ instance (OrdTable a, OrdTable b, context ~ Expr) =>

219 OrdTable (TheseTable context a b)

220 where

221 ordTable = HTheseTable

222− { hhereTag = hlabel (HType Dict)

222+ { hhereTag = hlabel (HIdentity Dict)

223 , hhere = hlabel (ordTable @(Nullify context a))

224− , hthereTag = hlabel (HType Dict)

224+ , hthereTag = hlabel (HIdentity Dict)

225 , hthere = hlabel (ordTable @(Nullify context b))

226 }

227

src/Rel8/Table/Undefined.hs+5−5

@@ -11,16 +11,16 @@ where

11import Prelude hiding ( undefined )

12

13-- rel8

14−import Rel8.Expr ( Expr( E ) )

14+import Rel8.Expr ( Expr )

15import Rel8.Expr.Null ( snull, unsafeUnnullify )

16import Rel8.Schema.HTable ( htabulate, hfield, hspecs )

17import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

18−import Rel8.Schema.Spec ( SSpec(..) )

18+import Rel8.Schema.Spec ( Spec(..) )

19import Rel8.Table ( Table, fromColumns )

20

21

22undefined :: Table Expr a => a

23undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of

24− SSpec {nullity, info} -> case nullity of

24+ Spec {nullity, info} -> case nullity of

25− Null -> E (snull info)

25+ Null -> snull info

26− NotNull -> E (unsafeUnnullify (snull info))

26+ NotNull -> unsafeUnnullify (snull info)

src/Rel8/Type/Composite.hs+9−8

@@ -20,6 +20,7 @@ where

20

21-- base

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

23+import Data.Functor.Identity ( Identity( Identity ) )

23import Data.Kind ( Constraint, Type )

24import Data.Kind ( Constraint, Type )

24import Prelude

25import Prelude

25

26

@@ -30,13 +31,13 @@ import qualified Hasql.Decoders as Hasql

30import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

31import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

31

32

32-- rel8

33-- rel8

33−import Rel8.Expr ( Expr( E ) )

34+import Rel8.Expr ( Expr )

34import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )

35import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )

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

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

36−import Rel8.Schema.Name ( Name( N, Name ) )

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

37import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

38import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

38−import Rel8.Schema.Result ( Result( R ) )

39+import Rel8.Schema.Result ( Result )

39−import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )

40+import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )

40import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )

41import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )

41import Rel8.Table.Eq ( EqTable )

42import Rel8.Table.Eq ( EqTable )

42import Rel8.Table.HKD ( HKD, HKDable )

43import Rel8.Table.HKD ( HKD, HKDable )

@@ -112,8 +113,8 @@ compose = castExpr . fromPrimExpr . encoder . toColumns

112decompose :: forall a. DBComposite a => Expr a -> HKD a Expr

113decompose :: forall a. DBComposite a => Expr a -> HKD a Expr

113decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->

114decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->

114 case hfield names field of

115 case hfield names field of

115− N (Name name) -> case hfield hspecs field of

116+ Name name -> case hfield hspecs field of

116− SSpec {} -> E $ fromPrimExpr $ Opaleye.CompositeExpr a name

117+ Spec {} -> fromPrimExpr $ Opaleye.CompositeExpr a name

117 where

118 where

118 names = toColumns (compositeFields @a)

119 names = toColumns (compositeFields @a)

119

120

@@ -121,7 +122,7 @@ decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->

121decoder :: HTable t => Hasql.Composite (t Result)

122decoder :: HTable t => Hasql.Composite (t Result)

122decoder = unwrapApplicative $ htabulateA \field ->

123decoder = unwrapApplicative $ htabulateA \field ->

123 case hfield hspecs field of

124 case hfield hspecs field of

124− SSpec {nullity, info} -> WrapApplicative $ R <$>

125+ Spec {nullity, info} -> WrapApplicative $ Identity <$>

125 case nullity of

126 case nullity of

126 Null -> Hasql.field $ Hasql.nullable $ decode info

127 Null -> Hasql.field $ Hasql.nullable $ decode info

127 NotNull -> Hasql.field $ Hasql.nonNullable $ decode info

128 NotNull -> Hasql.field $ Hasql.nonNullable $ decode info

@@ -131,4 +132,4 @@ encoder :: HTable t => t Expr -> Opaleye.PrimExpr

131encoder a = Opaleye.FunExpr "ROW" exprs

132encoder a = Opaleye.FunExpr "ROW" exprs

132 where

133 where

133 exprs = getConst $ htabulateA \field -> case hfield a field of

134 exprs = getConst $ htabulateA \field -> case hfield a field of

134− E (toPrimExpr -> expr) -> Const [expr]

135+ expr -> Const [toPrimExpr expr]