04fdf27 · rel8 · git.iko.soy

git.iko.soy/rel8

Make Rel8able have kind ((X -> Type) -> Type) -> Constraint

Previous it was `((Type -> Type) -> Type) -> Constraint`. The problem is this clashes with things like `HKD` from `higgledy`. We can use GADTs and PolyKinds hacks to get around this while mostly retaining the same API. The only major difference is we use `Result` in places where we used `Identity` before.

commit04fdf2732d93735c4889664afefb6fe8005060e4 authorShane O'Brien <shane.obrien@circuithub.com> dateThu 15 Apr 2021, 17:00 (6 years ago) parentf6a9c96

24 files changed+258−220

compare with master

unifiedsplit

rel8.cabal+1

@@ -113,6 +113,7 @@ library

113113 Rel8.Schema.Kind

114114 Rel8.Schema.Name

115115 Rel8.Schema.Null

116+ Rel8.Schema.Result

116117 Rel8.Schema.Spec

117118 Rel8.Schema.Spec.ConstrainDBType

118119 Rel8.Schema.Spec.ConstrainType

src/Rel8.hs+2

@@ -235,6 +235,7 @@ module Rel8

235235 , Labelable

236236 , ToExprs(..)

237237 , FromExprs

238+ , Result

238239 ) where

239240

240241-- base

@@ -277,6 +278,7 @@ import Rel8.Schema.Generic

277278import Rel8.Schema.HTable

278279import Rel8.Schema.Name

279280import Rel8.Schema.Null hiding ( nullable )

281+import Rel8.Schema.Result

280282import Rel8.Schema.Table

281283import Rel8.Statement.Delete

282284import Rel8.Statement.Insert

src/Rel8/Aggregate.hs+16−8

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

33{-# language FlexibleContexts #-}

44{-# language FlexibleInstances #-}

55{-# language GADTs #-}

6−{-# language GeneralizedNewtypeDeriving #-}

76{-# language MultiParamTypeClasses #-}

87{-# language NamedFieldPuns #-}

8+{-# language PolyKinds #-}

99{-# language StandaloneKindSignatures #-}

1010{-# language TypeFamilies #-}

1111{-# language UndecidableInstances #-}

@@ -37,13 +37,14 @@ import Rel8.Schema.Context.Label ( Labelable(..) )

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

3838import Rel8.Schema.Name ( Name )

3939import Rel8.Schema.Null ( Sql )

40+import Rel8.Schema.Result ( Result )

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

4142import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

4243import Rel8.Table.Recontextualize ( Recontextualize )

4344import Rel8.Type ( DBType )

4445

4546-- semigroupoids

46−import Data.Functor.Apply ( Apply, WrappedApplicative(..) )

47+import Data.Functor.Apply ( Apply, (<.>) )

4748

4849

4950-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can

@@ -51,10 +52,17 @@ import Data.Functor.Apply ( Apply, WrappedApplicative(..) )

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

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

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

54−type Aggregate :: Type -> Type

55−newtype Aggregate a = Aggregate (Opaleye.Aggregator () a)

56− deriving newtype Functor

57− deriving Apply via (WrappedApplicative (Opaleye.Aggregator ()))

55+type Aggregate :: k -> Type

56+data Aggregate a where

57+ Aggregate :: !(Opaleye.Aggregator () a) -> Aggregate a

58+

59+

60+instance Functor Aggregate where

61+ fmap f (Aggregate a) = Aggregate (fmap f a)

62+

63+

64+instance Apply Aggregate where

65+ Aggregate f <.> Aggregate a = Aggregate (f <*> a)

5866

5967

6068instance Interpretation Aggregate where

@@ -84,7 +92,7 @@ instance Sql DBType a =>

8492

8593

8694instance Sql DBType a =>

87− Recontextualize Aggregate Identity (Aggregate (Expr a)) (Identity a)

95+ Recontextualize Aggregate Result (Aggregate (Expr a)) (Identity a)

8896

8997

9098instance Sql DBType a =>

@@ -96,7 +104,7 @@ instance Sql DBType a =>

96104

97105

98106instance Sql DBType a =>

99− Recontextualize Identity Aggregate (Identity a) (Aggregate (Expr a))

107+ Recontextualize Result Aggregate (Identity a) (Aggregate (Expr a))

100108

101109

102110instance Sql DBType a =>

src/Rel8/Expr.hs+11−5

@@ -3,8 +3,10 @@

33{-# language FlexibleInstances #-}

44{-# language GADTs #-}

55{-# language MultiParamTypeClasses #-}

6+{-# language PolyKinds #-}

67{-# language RoleAnnotations #-}

78{-# language ScopedTypeVariables #-}

9+{-# language StandaloneDeriving #-}

810{-# language StandaloneKindSignatures #-}

911{-# language TypeApplications #-}

1012{-# language TypeFamilies #-}

@@ -39,6 +41,7 @@ import Rel8.Schema.Context ( Interpretation, Col )

3941import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

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

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

44+import Rel8.Schema.Result ( Result )

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

4346import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

4447import Rel8.Table.Recontextualize ( Recontextualize )

@@ -50,9 +53,12 @@ import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )

5053

5154-- | Typed SQL expressions.

5255type role Expr representational

53−type Expr :: Type -> Type

54−newtype Expr a = Expr Opaleye.PrimExpr

55− deriving stock Show

56+type Expr :: k -> Type

57+data Expr a where

58+ Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)

59+

60+

61+deriving stock instance Show (Expr a)

5662

5763

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

@@ -111,10 +117,10 @@ instance Sql DBType a => Table Expr (Expr a) where

111117instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)

112118

113119

114−instance Sql DBType a => Recontextualize Expr Identity (Expr a) (Identity a)

120+instance Sql DBType a => Recontextualize Expr Result (Expr a) (Identity a)

115121

116122

117−instance Sql DBType a => Recontextualize Identity Expr (Identity a) (Expr a)

123+instance Sql DBType a => Recontextualize Result Expr (Identity a) (Expr a)

118124

119125

120126instance Labelable Expr where

src/Rel8/Expr.hs-boot+5−2

@@ -1,3 +1,5 @@

1+{-# language GADTs #-}

2+{-# language PolyKinds #-}

13{-# language RoleAnnotations #-}

24{-# language StandaloneKindSignatures #-}

@@ -15,5 +17,6 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

1517

1618

1719type role Expr representational

18−type Expr :: Type -> Type

19−newtype Expr a = Expr Opaleye.PrimExpr

20+type Expr :: k -> Type

21+data Expr a where

22+ Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)

src/Rel8/Expr/Bool.hs+4−2

@@ -1,3 +1,5 @@

1+{-# language GADTs #-}

13module Rel8.Expr.Bool

24 ( false, true

35 , (&&.), (||.), not_

@@ -17,7 +19,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

1719

1820-- rel8

1921import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )

20−import Rel8.Expr.Opaleye ( mapPrimExpr, zipPrimExprsWith )

22+import Rel8.Expr.Opaleye ( mapPrimExpr, toPrimExpr, zipPrimExprsWith )

2123import Rel8.Expr.Serialize ( litExpr )

2224

2325

@@ -75,7 +77,7 @@ caseExpr :: [(Expr Bool, Expr a)] -> Expr a -> Expr a

7577caseExpr branches (Expr fallback) =

7678 Expr $ Opaleye.CaseExpr (map go branches) fallback

7779 where

78− go (Expr condition, Expr value) = (condition, value)

80+ go (condition, value) = (toPrimExpr condition, toPrimExpr value)

7981

8082

8183-- | Convert a @Expr (Maybe Bool)@ to a @Expr Bool@ by treating @Nothing@ as

src/Rel8/Expr/Null.hs+1

@@ -78,6 +78,7 @@ liftOpNull :: DBType c

7878liftOpNull f ma mb =

7979 boolExpr (unsafeLiftOpNull f ma mb) null

8080 (isNull ma ||. isNull mb)

81+{-# INLINABLE liftOpNull #-}

8182

8283

8384snull :: TypeInformation a -> Expr (Maybe a)

src/Rel8/Expr/Ord.hs+4−3

@@ -23,7 +23,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

2323import Rel8.Expr ( Expr( Expr ) )

2424import Rel8.Expr.Bool ( (&&.), (||.), coalesce )

2525import Rel8.Expr.Null ( isNull, isNonNull, nullable, unsafeLiftOpNull )

26−import Rel8.Expr.Opaleye ( zipPrimExprsWith )

26+import Rel8.Expr.Opaleye ( toPrimExpr, zipPrimExprsWith )

2727import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql )

2828import qualified Rel8.Schema.Null as Schema ( nullable )

2929import Rel8.Type.Ord ( DBOrd )

@@ -122,7 +122,7 @@ leastExpr ma mb = case Schema.nullable @a of

122122 Null -> nullable ma (\a -> nullable mb (least_ a) mb) ma

123123 NotNull -> least_ ma mb

124124 where

125− least_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "LEAST" [a, b])

125+ least_ a b = Expr (Opaleye.FunExpr "LEAST" [toPrimExpr a, toPrimExpr b])

126126

127127

128128-- | Given two expressions, return the expression that sorts greater than the

@@ -134,4 +134,5 @@ greatestExpr ma mb = case Schema.nullable @a of

134134 Null -> nullable mb (\a -> nullable ma (greatest_ a) mb) ma

135135 NotNull -> greatest_ ma mb

136136 where

137− greatest_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "GREATEST" [a, b])

137+ greatest_ a b =

138+ Expr (Opaleye.FunExpr "GREATEST" [toPrimExpr a, toPrimExpr b])

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

@@ -9,12 +9,12 @@ module Rel8.Schema.Context

99where

1010

1111-- base

12−import Data.Functor.Identity ( Identity )

1312import Data.Kind ( Constraint )

1413import Prelude ()

1514

1615-- rel8

1716import Rel8.Schema.Kind ( Context, HContext )

17+import Rel8.Schema.Result ( Result )

1818import Rel8.Schema.Spec ( Spec( Spec ) )

1919

2020

@@ -23,6 +23,6 @@ class Interpretation context where

2323 data Col context :: HContext

2424

2525

26−instance Interpretation Identity where

27− data Col Identity _spec where

28− Result :: a -> Col Identity ('Spec labels necessity a)

26+instance Interpretation Result where

27+ data Col Result _spec where

28+ Result :: a -> Col Result ('Spec labels necessity a)

src/Rel8/Schema/Context/Label.hs+2−2

@@ -11,7 +11,6 @@ module Rel8.Schema.Context.Label

1111where

1212

1313-- base

14−import Data.Functor.Identity ( Identity )

1514import Data.Kind ( Constraint )

1615import Prelude hiding ( null )

1716

@@ -20,6 +19,7 @@ import Rel8.Schema.Context ( Interpretation, Col(..) )

2019import Rel8.Schema.Dict ( Dict( Dict ) )

2120import Rel8.Schema.Kind ( Context, HContext )

2221import Rel8.Schema.Spec ( Spec( Spec ) )

22+import Rel8.Schema.Result ( Result )

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

2424

2525

@@ -34,7 +34,7 @@ class Interpretation context => Labelable context where

3434 -> Col context ('Spec labels necessity a)

3535

3636

37−instance Labelable Identity where

37+instance Labelable Result where

3838 labeler (Result a) = Result a

3939 unlabeler (Result a) = Result a

4040

src/Rel8/Schema/Field.hs+29−34

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

1919

2020-- base

2121import Data.Bifunctor ( Bifunctor, bimap )

22−import Data.Functor.Identity ( Identity )

2322import Data.Kind ( Constraint, Type )

2423import Data.List.NonEmpty ( NonEmpty )

2524import Prelude

@@ -45,6 +44,7 @@ import Rel8.Schema.Insert ( Insert, Col(..) )

4544import qualified Rel8.Schema.Kind as K

4645import Rel8.Schema.Name ( Name(..), Col(..) )

4746import Rel8.Schema.Null ( Sql )

47+import Rel8.Schema.Result ( Result )

4848import Rel8.Schema.Spec ( Spec( Spec ) )

4949import Rel8.Table

5050 ( Table, Columns, Context, fromColumns, toColumns

@@ -65,12 +65,12 @@ import Data.These ( These )

6565type Field :: K.Context -> Necessity -> Type -> Type

6666type family Field context necessity a where

6767 Field (Reify context) necessity a = AField context necessity a

68− Field Identity _necessity a = a

68+ Field Aggregate _necessity a = Aggregate (Expr a)

6969 Field Expr _necessity a = Expr a

7070 Field Insert 'Required a = Expr a

7171 Field Insert 'Optional a = Maybe (Expr a)

72− Field Aggregate _necessity a = Aggregate (Expr a)

73− Field context _necessity a = context a

72+ Field Name _necessity a = Name a

73+ Field Result _necessity a = a

7474

7575

7676type HEither :: K.Context -> Type -> Type -> Type

@@ -78,10 +78,9 @@ type family HEither context where

7878 HEither (Reify context) = AHEither context

7979 HEither Aggregate = EitherTable

8080 HEither Expr = EitherTable

81− HEither Identity = Either

8281 HEither Insert = EitherTable

8382 HEither Name = EitherTable

84− HEither _ = Either

83+ HEither Result = Either

8584

8685

8786type HList :: K.Context -> Type -> Type

@@ -89,10 +88,9 @@ type family HList context where

8988 HList (Reify context) = AHList context

9089 HList Aggregate = ListTable

9190 HList Expr = ListTable

92− HList Identity = []

9391 HList Insert = ListTable

9492 HList Name = ListTable

95− HList _ = []

93+ HList Result = []

9694

9795

9896type HMaybe :: K.Context -> Type -> Type

@@ -100,10 +98,9 @@ type family HMaybe context where

10098 HMaybe (Reify context) = AHMaybe context

10199 HMaybe Aggregate = MaybeTable

102100 HMaybe Expr = MaybeTable

103− HMaybe Identity = Maybe

104101 HMaybe Insert = MaybeTable

105102 HMaybe Name = MaybeTable

106− HMaybe _ = Maybe

103+ HMaybe Result = Maybe

107104

108105

109106type HNonEmpty :: K.Context -> Type -> Type

@@ -111,10 +108,9 @@ type family HNonEmpty context where

111108 HNonEmpty (Reify context) = AHNonEmpty context

112109 HNonEmpty Aggregate = NonEmptyTable

113110 HNonEmpty Expr = NonEmptyTable

114− HNonEmpty Identity = NonEmpty

115111 HNonEmpty Insert = NonEmptyTable

116112 HNonEmpty Name = NonEmptyTable

117− HNonEmpty _ = NonEmpty

113+ HNonEmpty Result = NonEmpty

118114

119115

120116type HThese :: K.Context -> Type -> Type -> Type

@@ -122,10 +118,9 @@ type family HThese context where

122118 HThese (Reify context) = AHThese context

123119 HThese Aggregate = TheseTable

124120 HThese Expr = TheseTable

125− HThese Identity = These

126121 HThese Insert = TheseTable

127122 HThese Name = TheseTable

128− HThese _ = These

123+ HThese Result = These

129124

130125

131126type AField :: K.Context -> Necessity -> Type -> Type

@@ -304,9 +299,9 @@ type SContext :: K.Context -> Type

304299data SContext context where

305300 SAggregate :: SContext Aggregate

306301 SExpr :: SContext Expr

307− SIdentity :: SContext Identity

308302 SInsert :: SContext Insert

309303 SName :: SContext Name

304+ SResult :: SContext Result

310305 SReify :: SContext context -> SContext (Reify context)

311306

312307

@@ -323,8 +318,8 @@ instance Reifiable Expr where

323318 contextSing = SExpr

324319

325320

326−instance Reifiable Identity where

327− contextSing = SIdentity

321+instance Reifiable Result where

322+ contextSing = SResult

328323

329324

330325instance Reifiable Insert where

@@ -359,7 +354,7 @@ sfromColumn :: ()

359354sfromColumn = \case

360355 SAggregate -> \(Aggregation a) -> AField a

361356 SExpr -> \(DB a) -> AField a

362− SIdentity -> \(Result a) -> AField a

357+ SResult -> \(Result a) -> AField a

363358 SInsert -> \case

364359 RequiredInsert a -> AField a

365360 OptionalInsert a -> AField a

@@ -375,7 +370,7 @@ stoColumn :: ()

375370stoColumn = \case

376371 SAggregate -> \_ (AField a) -> Aggregation a

377372 SExpr -> \_ (AField a) -> DB a

378− SIdentity -> \_ (AField a) -> Result a

373+ SResult -> \_ (AField a) -> Result a

379374 SInsert -> \case

380375 SRequired -> \(AField a) -> RequiredInsert a

381376 SOptional -> \(AField a) -> OptionalInsert a

@@ -393,7 +388,7 @@ sbimapEither :: ()

393388sbimapEither = \case

394389 SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a)

395390 SExpr -> \f g (AHEither a) -> AHEither (bimap f g a)

396− SIdentity -> \f g (AHEither a) -> AHEither (bimap f g a)

391+ SResult -> \f g (AHEither a) -> AHEither (bimap f g a)

397392 SInsert -> \f g (AHEither a) -> AHEither (bimap f g a)

398393 SName -> \f g (AHEither a) -> AHEither (bimap f g a)

399394 SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a)

@@ -414,7 +409,7 @@ sfromColumnsEither = \case

414409 bimap (fromColumns . hreify) (fromColumns . hreify) .

415410 fromColumns .

416411 hunreify

417− SIdentity ->

412+ SResult ->

418413 AHEither .

419414 bimap (fromColumns . hreify) (fromColumns . hreify) .

420415 fromColumns .

@@ -451,7 +446,7 @@ stoColumnsEither = \case

451446 toColumns .

452447 bimap (hunreify . toColumns) (hunreify . toColumns) .

453448 (\(AHEither a) -> a)

454− SIdentity ->

449+ SResult ->

455450 hreify .

456451 toColumns .

457452 bimap (hunreify . toColumns) (hunreify . toColumns) .

@@ -482,7 +477,7 @@ smapList :: Congruent a b

482477smapList = \case

483478 SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

484479 SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

485− SIdentity -> \f _ (AHList as) -> AHList (fmap f as)

480+ SResult -> \f _ (AHList as) -> AHList (fmap f as)

486481 SInsert -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

487482 SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

488483 SReify context -> \f g (AHList as) -> AHList (smapList context f g as)

@@ -495,7 +490,7 @@ sfromColumnsList :: Table (Reify context) a

495490sfromColumnsList = \case

496491 SAggregate -> AHList . ListTable

497492 SExpr -> AHList . ListTable

498− SIdentity -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify

493+ SResult -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify

499494 SInsert -> AHList . ListTable

500495 SName -> AHList . ListTable

501496 SReify context ->

@@ -512,7 +507,7 @@ stoColumnsList :: Table (Reify context) a

512507stoColumnsList = \case

513508 SAggregate -> \(AHList (ListTable a)) -> a

514509 SExpr -> \(AHList (ListTable a)) -> a

515− SIdentity ->

510+ SResult ->

516511 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)

517512 SInsert -> \(AHList (ListTable a)) -> a

518513 SName -> \(AHList (ListTable a)) -> a

@@ -531,7 +526,7 @@ smapMaybe :: ()

531526smapMaybe = \case

532527 SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a)

533528 SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a)

534− SIdentity -> \f (AHMaybe a) -> AHMaybe (fmap f a)

529+ SResult -> \f (AHMaybe a) -> AHMaybe (fmap f a)

535530 SInsert -> \f (AHMaybe a) -> AHMaybe (fmap f a)

536531 SName -> \f (AHMaybe a) -> AHMaybe (fmap f a)

537532 SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a)

@@ -544,7 +539,7 @@ sfromColumnsMaybe :: Table (Reify context) a

544539sfromColumnsMaybe = \case

545540 SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

546541 SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

547− SIdentity -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

542+ SResult -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

548543 SInsert -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

549544 SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

550545 SReify context ->

@@ -563,7 +558,7 @@ stoColumnsMaybe = \case

563558 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

564559 SExpr ->

565560 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

566− SIdentity ->

561+ SResult ->

567562 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

568563 SInsert ->

569564 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

@@ -585,7 +580,7 @@ smapNonEmpty :: Congruent a b

585580smapNonEmpty = \case

586581 SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

587582 SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

588− SIdentity -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)

583+ SResult -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)

589584 SInsert -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

590585 SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

591586 SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as)

@@ -598,7 +593,7 @@ sfromColumnsNonEmpty :: Table (Reify context) a

598593sfromColumnsNonEmpty = \case

599594 SAggregate -> AHNonEmpty . NonEmptyTable

600595 SExpr -> AHNonEmpty . NonEmptyTable

601− SIdentity ->

596+ SResult ->

602597 AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify

603598 SInsert -> AHNonEmpty . NonEmptyTable

604599 SName -> AHNonEmpty . NonEmptyTable

@@ -616,7 +611,7 @@ stoColumnsNonEmpty :: Table (Reify context) a

616611stoColumnsNonEmpty = \case

617612 SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a

618613 SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a

619− SIdentity ->

614+ SResult ->

620615 hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)

621616 SInsert -> \(AHNonEmpty (NonEmptyTable a)) -> a

622617 SName -> \(AHNonEmpty (NonEmptyTable a)) -> a

@@ -636,7 +631,7 @@ sbimapThese :: ()

636631sbimapThese = \case

637632 SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a)

638633 SExpr -> \f g (AHThese a) -> AHThese (bimap f g a)

639− SIdentity -> \f g (AHThese a) -> AHThese (bimap f g a)

634+ SResult -> \f g (AHThese a) -> AHThese (bimap f g a)

640635 SInsert -> \f g (AHThese a) -> AHThese (bimap f g a)

641636 SName -> \f g (AHThese a) -> AHThese (bimap f g a)

642637 SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a)

@@ -657,7 +652,7 @@ sfromColumnsThese = \case

657652 bimap (fromColumns . hreify) (fromColumns . hreify) .

658653 fromColumns .

659654 hunreify

660− SIdentity ->

655+ SResult ->

661656 AHThese .

662657 bimap (fromColumns . hreify) (fromColumns . hreify) .

663658 fromColumns .

@@ -694,7 +689,7 @@ stoColumnsThese = \case

694689 toColumns .

695690 bimap (hunreify . toColumns) (hunreify . toColumns) .

696691 (\(AHThese a) -> a)

697− SIdentity ->

692+ SResult ->

698693 hreify .

699694 toColumns .

700695 bimap (hunreify . toColumns) (hunreify . toColumns) .

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

@@ -43,7 +43,6 @@ import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

4343import Rel8.Schema.HTable.Pair ( HPair(..) )

4444import qualified Rel8.Schema.Kind as K

4545import Rel8.Schema.Name ( Name )

46−import Rel8.Schema.Spec ( KTable )

4746import Rel8.Table

4847 ( Table, Columns, Context, fromColumns, toColumns

4948 )

@@ -104,7 +103,7 @@ instance

104103-- data MyType f = MyType { fieldA :: Column f T }

105104-- deriving ( GHC.Generics.Generic, Rel8able )

106105-- @

107−type Rel8able :: KTable -> Constraint

106+type Rel8able :: K.Table -> Constraint

108107class HTable (GRep t) => Rel8able t where

109108 gfromColumns :: (Labelable context, Reifiable context)

110109 => GRep t (Col (Reify context)) -> t (Reify context)

src/Rel8/Schema/Insert.hs+6−5

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

66{-# language LambdaCase #-}

77{-# language MultiParamTypeClasses #-}

88{-# language NamedFieldPuns #-}

9+{-# language PolyKinds #-}

910{-# language StandaloneKindSignatures #-}

1011{-# language TypeFamilies #-}

1112{-# language UndecidableInstances #-}

@@ -36,9 +37,9 @@ import Rel8.Schema.Context.Nullify

3637 , runTag, unnull

3738 )

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

39−import qualified Rel8.Schema.Kind as K

4040import Rel8.Schema.Name ( Name, Selects )

4141import Rel8.Schema.Null ( Sql )

42+import Rel8.Schema.Result ( Result )

4243import Rel8.Schema.Spec ( SSpec(SSpec, nullity), Spec(Spec) )

4344import Rel8.Schema.Table ( TableSchema )

4445import Rel8.Statement.Returning ( Returning )

@@ -56,7 +57,7 @@ data OnConflict

5657

5758

5859-- | The constituent parts of a SQL @INSERT@ statement.

59−type Insert :: K.Context

60+type Insert :: k -> Type

6061data Insert a where

6162 Insert :: (Selects names exprs, Inserts exprs inserts) =>

6263 { into :: TableSchema names

@@ -78,7 +79,7 @@ instance Interpretation Insert where

7879 OptionalInsert :: Maybe (Expr a) -> Col Insert ('Spec labels 'Optional a)

7980

8081

81−type Insertion :: K.Context

82+type Insertion :: Type -> Type

8283newtype Insertion a = Insertion (Expr a)

8384

8485

@@ -98,7 +99,7 @@ instance Sql DBType a => Recontextualize Expr Insert (Expr a) (Insertion a)

9899

99100

100101instance Sql DBType a =>

101− Recontextualize Identity Insert (Identity a) (Insertion a)

102+ Recontextualize Result Insert (Identity a) (Insertion a)

102103

103104

104105instance Sql DBType a =>

@@ -109,7 +110,7 @@ instance Sql DBType a => Recontextualize Insert Expr (Insertion a) (Expr a)

109110

110111

111112instance Sql DBType a =>

112− Recontextualize Insert Identity (Insertion a) (Identity a)

113+ Recontextualize Insert Result (Insertion a) (Identity a)

113114

114115

115116instance Sql DBType a => Recontextualize Insert Insert (Insertion a) (Insertion a)

src/Rel8/Schema/Kind.hs+4−1

@@ -22,8 +22,11 @@ type HTable :: Type

2222type HTable = HContext -> Type

2323

2424

25+data X

26+

27+

2528type Context :: Type

26−type Context = Type -> Type

29+type Context = X -> Type

2730

2831

2932type Table :: Type

src/Rel8/Schema/Name.hs+17−9

@@ -2,9 +2,11 @@

22{-# language DerivingStrategies #-}

33{-# language FlexibleContexts #-}

44{-# language FlexibleInstances #-}

5−{-# language GeneralizedNewtypeDeriving #-}

5+{-# language GADTs #-}

66{-# language MultiParamTypeClasses #-}

7+{-# language PolyKinds #-}

78{-# language RankNTypes #-}

9+{-# language StandaloneDeriving #-}

810{-# language StandaloneKindSignatures #-}

911{-# language TypeFamilies #-}

1012{-# language UndecidableInstances #-}

@@ -20,7 +22,7 @@ where

2022-- base

2123import Data.Functor.Identity ( Identity )

2224import Data.Kind ( Constraint, Type )

23−import Data.String ( IsString )

25+import Data.String ( IsString, fromString )

2426import Prelude

2527

2628-- rel8

@@ -28,8 +30,8 @@ import Rel8.Expr ( Expr )

2830import Rel8.Schema.Context ( Interpretation, Col )

2931import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

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

31−import qualified Rel8.Schema.Kind as K

3233import Rel8.Schema.Null ( Sql )

34+import Rel8.Schema.Result ( Result )

3335import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

3436import Rel8.Table.Recontextualize ( Recontextualize )

3537import Rel8.Type ( DBType )

@@ -39,10 +41,16 @@ import Rel8.Type ( DBType )

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

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

4143-- a 'TableSchema' value.

42−type Name :: K.Context

43−newtype Name a = Name String

44− deriving stock Show

45− deriving newtype (IsString, Monoid, Semigroup)

44+type Name :: k -> Type

45+data Name a where

46+ Name :: k ~ Type => !String -> Name (a :: k)

47+

48+

49+deriving stock instance Show (Name a)

50+

51+

52+instance k ~ Type => IsString (Name (a :: k)) where

53+ fromString = Name

4654

4755

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

@@ -56,13 +64,13 @@ instance Sql DBType a => Table Name (Name a) where

5664instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)

5765

5866

59−instance Sql DBType a => Recontextualize Identity Name (Identity a) (Name a)

67+instance Sql DBType a => Recontextualize Result Name (Identity a) (Name a)

6068

6169

6270instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)

6371

6472

65−instance Sql DBType a => Recontextualize Name Identity (Name a) (Identity a)

73+instance Sql DBType a => Recontextualize Name Result (Name a) (Identity a)

6674

6775

6876instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)

src/Rel8/Schema/Result.hsnew file+16

@@ -0,0 +1,16 @@

1+{-# language DataKinds #-}

2+{-# language StandaloneKindSignatures #-}

4+module Rel8.Schema.Result

5+ ( Result

6+ ) where

8+-- base

9+import Prelude ()

10+

11+-- rel8

12+import Rel8.Schema.Kind ( Context )

13+

14+

15+type Result :: Context

16+data Result a

src/Rel8/Schema/Spec.hs−14

@@ -8,8 +8,6 @@ module Rel8.Schema.Spec

88 ( Spec( Spec )

99 , SSpec( SSpec, labels, necessity, info, nullity )

1010 , KnownSpec( specSing )

11− , KContext, HKTable

12− , KTable

1311 )

1412where

1513

@@ -62,15 +60,3 @@ instance

6260 , info = typeInformation

6361 , nullity = nullable

6462 }

65−

66−

67−type KContext :: Type

68−type KContext = Spec -> Type

69−

70−

71−type HKTable :: Type

72−type HKTable = KContext -> Type

73−

74−

75−type KTable :: Type

76−type KTable = (Type -> Type) -> Type

src/Rel8/Table.hs+24−25

@@ -44,6 +44,7 @@ import Rel8.Schema.HTable.Type ( HType( HType ) )

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

4545import qualified Rel8.Schema.Kind as K

4646import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )

47+import Rel8.Schema.Result ( Result )

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

4849import Rel8.Type ( DBType )

4950import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )

@@ -94,18 +95,17 @@ instance KnownSpec spec => Table context (Col context spec) where

9495 fromColumns = unHIdentity

9596

9697

97−instance Sql DBType a => Table Identity (Identity a) where

98+instance Sql DBType a => Table Result (Identity a) where

9899 type Columns (Identity a) = HType a

99− type Context (Identity a) = Identity

100+ type Context (Identity a) = Result

100101

101102 toColumns (Identity a) = HType (Result a)

102103 fromColumns (HType (Result a)) = Identity a

103104

104105

105−instance (Table Identity a, Table Identity b) => Table Identity (Either a b)

106− where

106+instance (Table Result a, Table Result b) => Table Result (Either a b) where

107107 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)

108− type Context (Either a b) = Identity

108+ type Context (Either a b) = Result

109109

110110 toColumns = \case

111111 Left table -> HEitherTable

@@ -127,17 +127,17 @@ instance (Table Identity a, Table Identity b) => Table Identity (Either a b)

127127 err = error "Either.fromColumns: mismatch between tag and data"

128128

129129

130−instance Table Identity a => Table Identity [a] where

130+instance Table Result a => Table Result [a] where

131131 type Columns [a] = HListTable (Columns a)

132− type Context [a] = Identity

132+ type Context [a] = Result

133133

134134 toColumns = hvectorize vectorizer . fmap toColumns

135135 fromColumns = fmap fromColumns . hunvectorize unvectorizer

136136

137137

138−instance Table Identity a => Table Identity (Maybe a) where

138+instance Table Result a => Table Result (Maybe a) where

139139 type Columns (Maybe a) = HMaybeTable (Columns a)

140− type Context (Maybe a) = Identity

140+ type Context (Maybe a) = Result

141141

142142 toColumns = \case

143143 Nothing -> HMaybeTable

@@ -156,18 +156,17 @@ instance Table Identity a => Table Identity (Maybe a) where

156156 Just just -> fromColumns just

157157

158158

159−instance Table Identity a => Table Identity (NonEmpty a) where

159+instance Table Result a => Table Result (NonEmpty a) where

160160 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)

161− type Context (NonEmpty a) = Identity

161+ type Context (NonEmpty a) = Result

162162

163163 toColumns = hvectorize vectorizer . fmap toColumns

164164 fromColumns = fmap fromColumns . hunvectorize unvectorizer

165165

166166

167−instance (Table Identity a, Table Identity b) => Table Identity (These a b)

168− where

167+instance (Table Result a, Table Result b) => Table Result (These a b) where

169168 type Columns (These a b) = HTheseTable (Columns a) (Columns b)

170− type Context (These a b) = Identity

169+ type Context (These a b) = Result

171170

172171 toColumns tables = HTheseTable

173172 { hhereTag = relabel hhereTag

@@ -311,14 +310,14 @@ class Columns a ~ Columns b => Congruent a b

311310instance Columns a ~ Columns b => Congruent a b

312311

313312

314−null :: Col Identity ('Spec labels necessity (Maybe a))

313+null :: Col Result ('Spec labels necessity (Maybe a))

315314null = Result Nothing

316315

317316

318317nullifier :: ()

319318 => SSpec ('Spec labels necessity a)

320− -> Col Identity ('Spec labels necessity a)

321− -> Col Identity ('Spec labels necessity (Nullify a))

319+ -> Col Result ('Spec labels necessity a)

320+ -> Col Result ('Spec labels necessity (Nullify a))

322321nullifier SSpec {nullity} (Result a) = Result $ case nullity of

323322 Null -> a

324323 NotNull -> Just a

@@ -326,8 +325,8 @@ nullifier SSpec {nullity} (Result a) = Result $ case nullity of

326325

327326unnullifier :: ()

328327 => SSpec ('Spec labels necessity a)

329− -> Col Identity ('Spec labels necessity (Nullify a))

330− -> Maybe (Col Identity ('Spec labels necessity a))

328+ -> Col Result ('Spec labels necessity (Nullify a))

329+ -> Maybe (Col Result ('Spec labels necessity a))

331330unnullifier SSpec {nullity} (Result a) =

332331 case nullity of

333332 Null -> pure $ Result a

@@ -336,19 +335,19 @@ unnullifier SSpec {nullity} (Result a) =

336335

337336vectorizer :: Functor f

338337 => SSpec ('Spec labels necessity a)

339− -> f (Col Identity ('Spec labels necessity a))

340− -> Col Identity ('Spec labels necessity (f a))

338+ -> f (Col Result ('Spec labels necessity a))

339+ -> Col Result ('Spec labels necessity (f a))

341340vectorizer _ = Result . fmap (\(Result a) -> a)

342341

343342

344343unvectorizer :: Functor f

345344 => SSpec ('Spec labels necessity a)

346− -> Col Identity ('Spec labels necessity (f a))

347− -> f (Col Identity ('Spec labels necessity a))

345+ -> Col Result ('Spec labels necessity (f a))

346+ -> f (Col Result ('Spec labels necessity a))

348347unvectorizer _ (Result results) = Result <$> results

349348

350349

351350relabel :: ()

352− => HIdentity ('Spec labels necessity a) (Col Identity)

353− -> HIdentity ('Spec relabels necessity a) (Col Identity)

351+ => HIdentity ('Spec labels necessity a) (Col Result)

352+ -> HIdentity ('Spec relabels necessity a) (Col Result)

354353relabel (HIdentity (Result a)) = HIdentity (Result a)

src/Rel8/Table/Eq.hs+2−1

@@ -40,6 +40,7 @@ import Rel8.Schema.HTable.Pair ( HPair(..) )

4040import Rel8.Schema.HTable.Quartet ( HQuartet(..) )

4141import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

4242import Rel8.Schema.HTable.Trio ( HTrio(..) )

43+import Rel8.Schema.Kind ( Context )

4344import Rel8.Schema.Null ( Sql )

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

4546import Rel8.Table ( Table, Columns, toColumns )

@@ -60,7 +61,7 @@ class Table Expr a => EqTable a where

6061

6162

6263instance

63− ( Table Expr (t Expr)

64+ ( Table Expr (t (Expr :: Context))

6465 , f ~ Expr

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

6667 )

src/Rel8/Table/Name.hs+6−2

@@ -23,8 +23,12 @@ import Prelude

2323-- casing

2424import Text.Casing ( quietSnake )

2525

26+-- opaleye

27+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

28+

2629-- rel8

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

31+import Rel8.Expr.Opaleye ( toPrimExpr )

2832import Rel8.Kind.Labels ( renderLabels )

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

3034import Rel8.Schema.Name ( Name, Col(..) )

@@ -45,11 +49,11 @@ namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

4549 SSpec {labels} -> NameCol (f (renderLabels labels))

4650

4751

48−showExprs :: Table Expr a => a -> [(String, String)]

52+showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]

4953showExprs as = case (namesFromLabels, toColumns as) of

5054 (names, exprs) -> getConst $ htabulateA $ \field ->

5155 case (hfield names field, hfield exprs field) of

52− (NameCol name, DB expr) -> Const [(name, show expr)]

56+ (NameCol name, DB expr) -> Const [(name, toPrimExpr expr)]

5357

5458

5559showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

src/Rel8/Table/Ord.hs+2−1

@@ -37,6 +37,7 @@ import Rel8.Schema.HTable.Pair ( HPair(..) )

3737import Rel8.Schema.HTable.Quartet ( HQuartet(..) )

3838import Rel8.Schema.HTable.Quintet ( HQuintet(..) )

3939import Rel8.Schema.HTable.Trio ( HTrio(..) )

40+import Rel8.Schema.Kind ( Context )

4041import Rel8.Schema.Null (Sql)

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

4243import Rel8.Table ( Table, Columns, toColumns )

@@ -58,7 +59,7 @@ class EqTable a => OrdTable a where

5859

5960

6061instance

61− ( Table Expr (t Expr)

62+ ( Table Expr (t (Expr :: Context))

6263 , f ~ Expr

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

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

src/Rel8/Table/Recontextualize.hs+2−1

@@ -22,6 +22,7 @@ import Rel8.Schema.Context.Label ( Labelable )

2222import Rel8.Schema.HTable ( HTable )

2323import qualified Rel8.Schema.Kind as K

2424import Rel8.Schema.Null ( Sql )

25+import Rel8.Schema.Result ( Result )

2526import Rel8.Table ( Table, Congruent )

2627import Rel8.Type ( DBType )

2728

@@ -41,7 +42,7 @@ class

4142 , b from -> a

4243

4344

44−instance Sql DBType a => Recontextualize Identity Identity (Identity a) (Identity a)

45+instance Sql DBType a => Recontextualize Result Result (Identity a) (Identity a)

4546

4647

4748instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))

src/Rel8/Table/Serialize.hs+84−84

@@ -21,7 +21,6 @@ where

2121

2222-- base

2323import Data.Bifunctor ( bimap )

24−import Data.Functor.Identity ( Identity )

2524import Data.Kind ( Constraint, Type )

2625import Data.List.NonEmpty ( NonEmpty )

2726import Prelude

@@ -42,6 +41,7 @@ import Rel8.Schema.HTable.Pair ( HPair(..) )

4241import Rel8.Schema.HTable.Trio ( HTrio(..) )

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

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

44+import Rel8.Schema.Result ( Result )

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

4646import Rel8.Table ( Table, Columns, fromColumns, toColumns )

4747import Rel8.Table.Either ( EitherTable )

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

5959import Data.These ( These )

6060

6161

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

63−fromIdentity' = fromIdentity @_ @exprs

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

63+fromResult' = fromResult @_ @exprs

6464

6565

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

67−toIdentity' = toIdentity @_ @exprs

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

67+toResult' = toResult @_ @exprs

6868

6969

7070type ToExprs :: Type -> Type -> Constraint

7171class Table Expr exprs => ToExprs a exprs where

72− fromIdentity :: Columns exprs (Col Identity) -> a

73− toIdentity :: a -> Columns exprs (Col Identity)

72+ fromResult :: Columns exprs (Col Result) -> a

73+ toResult :: a -> Columns exprs (Col Result)

7474

7575

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

77− fromIdentity (HType (Result a)) = a

78− toIdentity = HType . Result

77+ fromResult (HType (Result a)) = a

78+ toResult = HType . Result

7979

8080

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

82− fromIdentity (HType (Result a)) = a

83− toIdentity = HType . Result

82+ fromResult (HType (Result a)) = a

83+ toResult = HType . Result

8484

8585

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

8787 where

88− fromIdentity (HType (Result a)) = a

89− toIdentity = HType . Result

88+ fromResult (HType (Result a)) = a

89+ toResult = HType . Result

9090

9191

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

9393 where

94− fromIdentity (HType (Result a)) = a

95− toIdentity = HType . Result

94+ fromResult (HType (Result a)) = a

95+ toResult = HType . Result

9696

9797

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

9999 ToExprs (Either a b) x

100100 where

101− fromIdentity =

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

101+ fromResult =

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

103103 fromColumns

104− toIdentity =

104+ toResult =

105105 toColumns .

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

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

107107

108108

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

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

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

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

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

112112

113113

114114instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where

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

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

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

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

117117

118118

119119instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)

120120 where

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

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

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

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

123123

124124

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

126126 ToExprs (These a b) x

127127 where

128− fromIdentity =

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

128+ fromResult =

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

130130 fromColumns

131− toIdentity =

131+ toResult =

132132 toColumns .

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

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

134134

135135

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

137137 ToExprs (a, b) x

138138 where

139− fromIdentity (HPair a b) =

140− ( fromIdentity' @exprs1 $ hunlabel unlabeler a

141− , fromIdentity' @exprs2 $ hunlabel unlabeler b

139+ fromResult (HPair a b) =

140+ ( fromResult' @exprs1 $ hunlabel unlabeler a

141+ , fromResult' @exprs2 $ hunlabel unlabeler b

142142 )

143− toIdentity (a, b) = HPair

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

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

143+ toResult (a, b) = HPair

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

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

146146 }

147147

148148

@@ -153,15 +153,15 @@ instance

153153 , x ~ (exprs1, exprs2, exprs3)

154154 ) => ToExprs (a, b, c) x

155155 where

156− fromIdentity (HTrio a b c) =

157− ( fromIdentity' @exprs1 $ hunlabel unlabeler a

158− , fromIdentity' @exprs2 $ hunlabel unlabeler b

159− , fromIdentity' @exprs3 $ hunlabel unlabeler c

156+ fromResult (HTrio a b c) =

157+ ( fromResult' @exprs1 $ hunlabel unlabeler a

158+ , fromResult' @exprs2 $ hunlabel unlabeler b

159+ , fromResult' @exprs3 $ hunlabel unlabeler c

160160 )

161− toIdentity (a, b, c) = HTrio

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

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

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

161+ toResult (a, b, c) = HTrio

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

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

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

165165 }

166166

167167

@@ -173,17 +173,17 @@ instance

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

174174 ) => ToExprs (a, b, c, d) x

175175 where

176− fromIdentity (HQuartet a b c d) =

177− ( fromIdentity' @exprs1 $ hunlabel unlabeler a

178− , fromIdentity' @exprs2 $ hunlabel unlabeler b

179− , fromIdentity' @exprs3 $ hunlabel unlabeler c

180− , fromIdentity' @exprs4 $ hunlabel unlabeler d

176+ fromResult (HQuartet a b c d) =

177+ ( fromResult' @exprs1 $ hunlabel unlabeler a

178+ , fromResult' @exprs2 $ hunlabel unlabeler b

179+ , fromResult' @exprs3 $ hunlabel unlabeler c

180+ , fromResult' @exprs4 $ hunlabel unlabeler d

181181 )

182− toIdentity (a, b, c, d) = HQuartet

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

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

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

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

182+ toResult (a, b, c, d) = HQuartet

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

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

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

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

187187 }

188188

189189

@@ -196,47 +196,47 @@ instance

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

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

198198 where

199− fromIdentity (HQuintet a b c d e) =

200− ( fromIdentity' @exprs1 $ hunlabel unlabeler a

201− , fromIdentity' @exprs2 $ hunlabel unlabeler b

202− , fromIdentity' @exprs3 $ hunlabel unlabeler c

203− , fromIdentity' @exprs4 $ hunlabel unlabeler d

204− , fromIdentity' @exprs5 $ hunlabel unlabeler e

199+ fromResult (HQuintet a b c d e) =

200+ ( fromResult' @exprs1 $ hunlabel unlabeler a

201+ , fromResult' @exprs2 $ hunlabel unlabeler b

202+ , fromResult' @exprs3 $ hunlabel unlabeler c

203+ , fromResult' @exprs4 $ hunlabel unlabeler d

204+ , fromResult' @exprs5 $ hunlabel unlabeler e

205205 )

206− toIdentity (a, b, c, d, e) = HQuintet

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

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

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

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

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

206+ toResult (a, b, c, d, e) = HQuintet

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

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

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

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

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

212212 }

213213

214214

215−instance (HTable t, result ~ Col Identity, x ~ t (Col Expr)) =>

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

216216 ToExprs (t result) x

217217 where

218− fromIdentity = id

219− toIdentity = id

218+ fromResult = id

219+ toResult = id

220220

221221

222−instance (Recontextualize Identity Expr (t Identity) (t Expr), result ~ Identity, x ~ t Expr) =>

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

223223 ToExprs (t result) x

224224 where

225− fromIdentity = fromColumns

226− toIdentity = toColumns

225+ fromResult = fromColumns

226+ toResult = toColumns

227227

228228

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

230− ToExprs (Col Identity spec) x

230+ ToExprs (Col Result spec) x

231231 where

232− fromIdentity = fromColumns

233− toIdentity = toColumns

232+ fromResult = fromColumns

233+ toResult = toColumns

234234

235235

236236type FromExprs :: Type -> Type

237237type family FromExprs a

238238type instance FromExprs (Expr a) = a

239−type instance FromExprs (Col Expr spec) = Col Identity spec

239+type instance FromExprs (Col Expr spec) = Col Result spec

240240type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)

241241type instance FromExprs (ListTable a) = [FromExprs a]

242242type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)

@@ -248,8 +248,8 @@ type instance FromExprs (a, b, c, d) =

248248 (FromExprs a, FromExprs b, FromExprs c, FromExprs d)

249249type instance FromExprs (a, b, c, d, e) =

250250 (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)

251−type instance FromExprs (t Expr) = t Identity

252−type instance FromExprs (t (Col Expr)) = t (Col Identity)

251+type instance FromExprs (t Expr) = t Result

252+type instance FromExprs (t (Col Expr)) = t (Col Result)

253253

254254

255255-- | @Serializable@ witnesses the one-to-one correspondence between the type

@@ -264,24 +264,24 @@ instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a

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

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

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

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

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

268268

269269

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

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

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

272272

273273

274274type Encodes :: Type -> Type -> Constraint

275275class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a

276276

277277

278−instance KnownSpec spec => Encodes (Col Identity spec) (Col Expr spec)

278+instance KnownSpec spec => Encodes (Col Result spec) (Col Expr spec)

279279

280280

281−instance Serializable (t Identity) (t Expr) => Encodes (t Expr) (t Identity)

281+instance Serializable (t Result) (t Expr) => Encodes (t Expr) (t Result)

282282

283283

284−instance HTable t => Encodes (t (Col Identity)) (t (Col Expr))

284+instance HTable t => Encodes (t (Col Result)) (t (Col Expr))

285285

286286

287287instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)

@@ -318,14 +318,14 @@ litTable :: Encodes a exprs => a -> exprs

318318litTable = lit

319319

320320

321−litHTable :: HTable t => t (Col Identity) -> t (Col Expr)

321+litHTable :: HTable t => t (Col Result) -> t (Col Expr)

322322litHTable as = htabulate $ \field ->

323323 case hfield hspecs field of

324324 SSpec {nullity, info} -> case hfield as field of

325325 Result value -> DB (slitExpr nullity info value)

326326

327327

328−parseHTable :: HTable t => Hasql.Row (t (Col Identity))

328+parseHTable :: HTable t => Hasql.Row (t (Col Result))

329329parseHTable = unwrapApplicative $ htabulateA $ \field ->

330330 WrapApplicative $ case hfield hspecs field of

331331 SSpec {nullity, info} -> Result <$> sparseValue nullity info

tests/Main.hs+15−15

@@ -27,7 +27,6 @@ import Control.Monad (void)

2727import Control.Monad.IO.Class ( MonadIO, liftIO )

2828import Data.Bifunctor ( bimap )

2929import Data.Foldable ( for_ )

30−import Data.Functor.Identity ( Identity )

3130import Data.Int ( Int32, Int64 )

3231import Data.List ( nub, sort )

3332import Data.Maybe ( catMaybes )

@@ -60,6 +59,7 @@ import Control.Exception.Lifted ( bracket, throwIO, bracket_ )

6059import Control.Monad.Trans.Control ( MonadBaseControl )

6160

6261-- rel8

62+import Rel8 ( Result )

6363import qualified Rel8

6464

6565-- scientific

@@ -161,9 +161,9 @@ data TestTable f = TestTable

161161 deriving anyclass Rel8.Rel8able

162162

163163

164−deriving stock instance Eq (TestTable Identity)

165−deriving stock instance Ord (TestTable Identity)

166−deriving stock instance Show (TestTable Identity)

164+deriving stock instance Eq (TestTable Result)

165+deriving stock instance Ord (TestTable Result)

166+deriving stock instance Show (TestTable Result)

167167

168168

169169testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name)

@@ -543,9 +543,9 @@ data TwoTestTables f =

543543 deriving anyclass Rel8.Rel8able

544544

545545

546−deriving stock instance Eq (TwoTestTables Identity)

547−deriving stock instance Ord (TwoTestTables Identity)

548−deriving stock instance Show (TwoTestTables Identity)

546+deriving stock instance Eq (TwoTestTables Result)

547+deriving stock instance Ord (TwoTestTables Result)

548+deriving stock instance Show (TwoTestTables Result)

549549

550550

551551testNestedTables :: IO TmpPostgres.DB -> TestTree

@@ -578,7 +578,7 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

578578 (as, []) -> selected === (Nothing <$ as)

579579 (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)

580580 where

581− genRows :: PropertyT IO [TestTable Identity]

581+ genRows :: PropertyT IO [TestTable Result]

582582 genRows = forAll do

583583 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

584584

@@ -591,7 +591,7 @@ rollingBack connection =

591591 (liftIO (run (sql "ROLLBACK") connection))

592592

593593

594−genTestTable :: Gen (TestTable Identity)

594+genTestTable :: Gen (TestTable Result)

595595genTestTable = do

596596 testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum

597597 testTableColumn2 <- Gen.bool

@@ -673,9 +673,9 @@ newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

673673 deriving stock Generic

674674 deriving anyclass Rel8.Rel8able

675675

676−deriving stock instance Eq (HKNestedPair Identity)

677−deriving stock instance Ord (HKNestedPair Identity)

678−deriving stock instance Show (HKNestedPair Identity)

676+deriving stock instance Eq (HKNestedPair Result)

677+deriving stock instance Ord (HKNestedPair Result)

678+deriving stock instance Show (HKNestedPair Result)

679679

680680

681681testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree

@@ -708,9 +708,9 @@ data NestedMaybeTable f = NestedMaybeTable

708708 deriving anyclass Rel8.Rel8able

709709

710710

711−deriving stock instance Eq (NestedMaybeTable Identity)

712−deriving stock instance Ord (NestedMaybeTable Identity)

713−deriving stock instance Show (NestedMaybeTable Identity)

711+deriving stock instance Eq (NestedMaybeTable Result)

712+deriving stock instance Ord (NestedMaybeTable Result)

713+deriving stock instance Show (NestedMaybeTable Result)

714714

715715

716716testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree