f47423e · rel8 · git.iko.soy

git.iko.soy/rel8

Get rid of the Spec kind, it can be simplified to just Type (#110)

This is basically the same idea as #92, but we can even further now after #107. I had thought that this would hinder any future efforts to make Rel8 interoperate with Barbies, but #110 shows that this need not be the case.

commitf47423ec17c36f441bab4c0cbb2036dc8aecacbd authorShane <shane.obrien@circuithub.com> dateWed 7 Jul 2021, 11:43 (5 years ago) parente0a1851

47 files changed+416−624

compare with master

unifiedsplit

rel8.cabal−2

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

114114 Rel8.Query.These

115115 Rel8.Query.Values

116116

117− Rel8.Schema.Context.Lower

118117 Rel8.Schema.Context.Nullify

119118 Rel8.Schema.Context.Virtual

120119 Rel8.Schema.Dict

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

135134 Rel8.Schema.Null

136135 Rel8.Schema.Result

137136 Rel8.Schema.Spec

138− Rel8.Schema.Spec.Constrain

139137 Rel8.Schema.Table

140138

141139 Rel8.Statement.Delete

src/Rel8/Aggregate.hs+11−19

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

11{-# language DataKinds #-}

22{-# language FlexibleContexts #-}

33{-# language FlexibleInstances #-}

4−{-# language GADTs #-}

54{-# language MultiParamTypeClasses #-}

65{-# language NamedFieldPuns #-}

7−{-# language PolyKinds #-}

86{-# language RankNTypes #-}

97{-# language StandaloneKindSignatures #-}

108{-# language TypeFamilies #-}

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

1917

2018-- base

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

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

2221import Data.Kind ( Constraint, Type )

2322import Prelude

2423

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

2928

3029-- rel8

3130import 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

3433import Rel8.Schema.Null ( Sql )

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

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

3734import Rel8.Table

3835 ( Table, Columns, Context, fromColumns, toColumns

3936 , FromExprs, fromResult, toResult

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

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

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

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

51−type Aggregate :: k -> Type

52−data Aggregate a where

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

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

55−

56−

57−type instance Lower Aggregate = Aggregate

48+type Aggregate :: K.Context

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

5850

5951

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

61− type Columns (Aggregate a) = HType a

53+ type Columns (Aggregate a) = HIdentity a

6254 type Context (Aggregate a) = Aggregate

6355 type FromExprs (Aggregate a) = a

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

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

6557

66− toColumns = HIdentity . A

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

68− toResult = HIdentity . R

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

58+ toColumns = HIdentity

59+ fromColumns (HIdentity a) = a

60+ toResult = HIdentity . Identity

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

7062

7163

7264-- | @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 ()

1515-- rel8

1616import Rel8.FCF ( Eval, Exp )

1717import qualified Rel8.Schema.Kind as K

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

1918import Rel8.Schema.Result ( Result )

2019

2120

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

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

2625type family Column context a where

2726 Column Result a = a

28− Column context a = Lower context a

27+ Column context a = context a

2928

3029

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

src/Rel8/Expr.hs+12−25

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

11{-# language DataKinds #-}

22{-# language DerivingStrategies #-}

33{-# language FlexibleInstances #-}

4−{-# language GADTs #-}

54{-# language MultiParamTypeClasses #-}

6−{-# language PolyKinds #-}

7−{-# language RoleAnnotations #-}

85{-# language ScopedTypeVariables #-}

9−{-# language StandaloneDeriving #-}

106{-# language StandaloneKindSignatures #-}

117{-# language TypeApplications #-}

128{-# language TypeFamilies #-}

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

1814where

1915

2016-- base

21−import Data.Kind ( Type )

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

2218import Data.String ( IsString, fromString )

2319import Prelude hiding ( null )

2420

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

3531 , zipPrimExprsWith

3632 )

3733import 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

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

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

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

4337import Rel8.Table

4438 ( Table, Columns, Context, fromColumns, toColumns

4539 , FromExprs, fromResult, toResult

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

5246

5347

5448-- | Typed SQL expressions.

55−type Expr :: k -> Type

56−data Expr a where

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

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

59−

60−

61−deriving stock instance Show (Expr a)

62−

63−

64−type instance Lower Expr = Expr

49+type Expr :: K.Context

50+newtype Expr a = Expr Opaleye.PrimExpr

51+ deriving stock Show

6552

6653

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

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

126113

127114

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

129− type Columns (Expr a) = HType a

116+ type Columns (Expr a) = HIdentity a

130117 type Context (Expr a) = Expr

131118 type FromExprs (Expr a) = a

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

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

133120

134− toColumns a = HType (E a)

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

136− toResult a = HType (R a)

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

121+ toColumns a = HIdentity a

122+ fromColumns (HIdentity a) = a

123+ toResult a = HIdentity (Identity a)

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

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

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

11{-# language DataKinds #-}

2−{-# language GADTs #-}

3−{-# language PolyKinds #-}

4−{-# language RankNTypes #-}

5−{-# language RoleAnnotations #-}

62{-# language StandaloneKindSignatures #-}

84module Rel8.Expr

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

117where

128

139-- base

14−import Data.Kind ( Type )

1510import Prelude ()

1611

1712-- opaleye

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

1914

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

15+-- rel8

16+import Rel8.Schema.Kind ( Context )

2117

2218

23−type Expr :: k -> Type

24−data Expr a where

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

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

19+type Expr :: Context

20+newtype Expr a = Expr Opaleye.PrimExpr

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

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

2929import Prelude

3030

3131-- rel8

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

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

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

33+import Rel8.Expr ( Expr )

3434import Rel8.Expr.Aggregate ( groupByExpr )

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

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

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

5757import qualified Rel8.Kind.Algebra as K

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

5959import Rel8.Schema.HTable ( HTable )

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

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

6161import qualified Rel8.Schema.Kind as K

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

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

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

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

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

6565import Rel8.Table

6666 ( TTable, TColumns

6767 , Table, fromColumns, toColumns

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

127127 @name

128128 @(Eval (rep Expr))

129129 (const toColumns)

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

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

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

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

132132 Null -> id

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

134− (HType . E . litExpr)

133+ NotNull -> nullify)

134+ (HIdentity . litExpr)

135135

136136

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

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

198198 @Expr

199199 @(Eval (rep Expr))

200200 (const toColumns)

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

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

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

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

203203 Null -> id

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

205− (HType . E . litExpr)

204+ NotNull -> nullify)

205+ (HIdentity . litExpr)

206206

207207

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

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

230230 SSum ->

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

232232 let

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

233+ (HIdentity tag, cases) =

234234 gdeconstructADT

235235 @(TTable Expr)

236236 @TColumns

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

238238 @Expr

239239 @(Eval (rep Expr))

240240 (const fromColumns)

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

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

242242 Null -> id

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

243+ NotNull -> unsafeUnnullify)

244244 constructors $

245245 gtoColumns as

246246 in

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

279279 @Name

280280 @(Eval (rep Name))

281281 (const toColumns)

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

283− (HType (N tag))

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

283+ (HIdentity tag)

284284

285285

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

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

330330 @Aggregate

331331 @(Eval (rep Aggregate))

332332 (const toColumns)

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

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

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

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

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

335+ (HIdentity (groupByExpr tag))

336336 where

337337 f =

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

339339 agg .

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

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

341+ (HIdentity tag, exprs) =

342342 gunbuildADT

343343 @(TTable Expr)

344344 @TColumns

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

346346 @Expr

347347 @(Eval (rep Expr))

348348 (const fromColumns)

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

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

350350 Null -> id

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

351+ NotNull -> unsafeUnnullify) $

352352 gtoColumns es

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

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

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

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

5151import Rel8.Schema.HTable ( HTable )

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

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

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

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

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

5656import Rel8.Schema.Null ( Nullify )

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

57+import Rel8.Schema.Spec ( Spec )

5858import qualified Rel8.Schema.Kind as K

5959import Rel8.Type.Tag ( Tag( Tag ) )

6060

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

6363

6464

6565type Null :: K.Context -> Type

66−type Null context = forall a. ()

67− => SSpec ('Spec a)

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

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

6967

7068

7169type Nullifier :: K.Context -> Type

72−type Nullifier context = forall a. ()

73− => SSpec ('Spec a)

74− -> context ('Spec a)

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

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

7671

7772

7873type Unnullifier :: K.Context -> Type

79−type Unnullifier context = forall a. ()

80− => SSpec ('Spec a)

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

82− -> context ('Spec a)

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

8375

8476

8577type NoConstructor :: Symbol -> Symbol -> ErrorMessage

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

193185 gbuildADT :: ()

194186 => ToColumns _Table _Columns f context

195187 -> (Tag -> Nullifier context)

196− -> HType Tag context

188+ -> HIdentity Tag context

197189 -> GFieldsADT f rep

198190 -> GColumnsADT _Columns rep context

199191

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

201193 => FromColumns _Table _Columns f context

202194 -> Unnullifier context

203195 -> GColumnsADT _Columns rep context

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

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

205197

206198 gconstructADT :: ()

207199 => ToColumns _Table _Columns f context

208200 -> Null context

209201 -> Nullifier context

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

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

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

212204

213205 gdeconstructADT :: ()

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

215207 -> Unnullifier context

216208 -> GConstructors f rep r

217209 -> GColumnsADT _Columns rep context

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

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

219211

220212

221213instance

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

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

223215 , GConstructableADT' _Table _Columns f context htable rep

224216 )

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

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

389381 => ToColumns _Table _Columns f context

390382 -> Null context

391383 -> Nullifier context

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

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

393385 -> GFields f (GConstructorADT name rep)

394386 -> GColumnsADT _Columns rep context

395387

396388

397389instance

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

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

399391 , meta ~ 'MetaData datatype _module _package _newtype

400392 , fallback ~ TypeError (NoConstructor datatype name)

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

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

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

1818where

1919

2020-- base

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

2122import Data.Kind ( Constraint, Type )

2223import Data.Proxy ( Proxy( Proxy ) )

2324import GHC.Generics

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

3334import Rel8.Generic.Map ( GMap )

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

3536import Rel8.Schema.HTable ( HTable )

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

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

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

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

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

4041import qualified Rel8.Schema.Kind as K

41−import Rel8.Schema.Result

42− ( Result( R )

43− , null, nullifier, unnullifier

44− )

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

4543import Rel8.Type.Tag ( Tag( Tag ) )

4644

4745-- text

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

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

5452type family GColumnsADT _Columns rep where

5553 GColumnsADT _Columns (M1 D _ rep) =

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

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

5755

5856

5957type GColumnsADT'

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

8785

8886

8987instance

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

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

9189 , GTableADT' _Table _Columns _FromExprs htable rep

9290 )

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

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

9795 Just rep -> M1 rep

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

9997 where

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

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

10199

102100 gtoResultADT toResult (M1 rep) =

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

104102 where

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

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

106104

107105

108106type GTableADT'

src/Rel8/Kind/Context.hs+1

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

11{-# language DataKinds #-}

22{-# language GADTs #-}

33{-# language StandaloneKindSignatures #-}

4+{-# language TypeSynonymInstances #-}

56module Rel8.Kind.Context

67 ( Reifiable( contextSing )

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

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

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

2020

2121-- rel8

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

22+import Rel8.Expr ( Expr )

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

2424import Rel8.Expr.Opaleye ( mapPrimExpr )

2525import Rel8.Query ( Query )

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

2828import Rel8.Query.Maybe ( optional )

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

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

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

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

3232import Rel8.Table ( Table, fromColumns )

3333import Rel8.Table.Cols ( toCols )

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

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

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

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

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

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

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

9090

9191

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

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

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

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

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

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

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

9999

100100

101101-- | 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 )

1919import qualified Opaleye.Internal.MaybeFields as Opaleye

2020

2121-- rel8

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

22+import Rel8.Expr ( Expr )

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

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

2525import Rel8.Query ( Query )

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

3535-- JOIN@s.

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

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

38− { tag = E $ fromPrimExpr $ fromColumn tag

38+ { tag = fromPrimExpr $ fromColumn tag

3939 , just = pure a

4040 }

4141

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

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

6262-- back.

6363traverseMaybeTable :: (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

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

66− MaybeTable (E output) b -> do

66+ MaybeTable output b -> do

6767 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 )

2323import qualified Opaleye.Internal.Sql as Opaleye

2424

2525-- rel8

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

26+import Rel8.Expr ( Expr )

2727import Rel8.Expr.Opaleye ( toPrimExpr )

2828import Rel8.Query ( Query )

2929import Rel8.Query.Opaleye ( toOpaleye )

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

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

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

3232import Rel8.Table ( Table, toColumns )

3333import Rel8.Table.Cols ( toCols )

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

6969 where

7070 select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query

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

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

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

72+ Name name -> case hfield exprs field of

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

7474 makeAttr label expr =

7575 (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

2525import qualified Opaleye.Internal.Tag as Opaleye

2626

2727-- rel8

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

28+import Rel8.Expr ( Expr )

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

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

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

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

5353 where

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

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

56− MaybeTable (E hasHere) a = ma

57− MaybeTable (E hasThere) b = mb

56+ MaybeTable hasHere a = ma

57+ MaybeTable hasThere b = mb

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

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

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

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

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

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

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

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

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

68+ ma' = MaybeTable hasHere' a

69+ mb' = MaybeTable hasThere' b

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

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

7272

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

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

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

122122 where_ $ not_ $ isThoseTable t

123− pure $ EitherTable (E tag) a b

123+ pure $ EitherTable tag a b

124124 where

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

126126

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

1616

1717-- base

1818import Data.Bool ( bool )

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

1920import Data.Kind ( Constraint, Type )

2021import Data.Monoid ( getFirst )

2122import Prelude hiding ( null )

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

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

2526

2627-- rel8

27−import Rel8.Aggregate

28− ( Aggregate( A, Aggregate )

29− , foldInputs, mapInputs

30− )

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

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

29+import Rel8.Expr ( Expr )

3230import Rel8.Expr.Bool ( boolExpr )

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

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

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

3634import qualified Rel8.Schema.Kind as K

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

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

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

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

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

37+import Rel8.Schema.Result ( Result )

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

4139

4240

4341type Nullifiability :: K.Context -> Type

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

8886

8987guarder :: ()

9088 => SContext context

91− -> context ('Spec tag)

89+ -> context tag

9290 -> (tag -> Bool)

9391 -> (Expr tag -> Expr Bool)

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

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

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

97− A $

92+ -> context (Maybe a)

93+ -> context (Maybe a)

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

9895 mapInputs (toPrimExpr . run . fromPrimExpr) $

9996 Aggregate $

10097 run <$> a

10198 where

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

103100 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

105102 where

106103 condition = isNonNull tag

107104guarder 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)

109107 where

110108 condition = isNonNull tag

111109

112110

113111nullifier :: ()

114112 => Nullifiability context

115− -> SSpec ('Spec a)

116− -> context ('Spec a)

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

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

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

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

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

113+ -> Spec a

114+ -> context a

115+ -> context (Nullify a)

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

117+ Aggregate $ snullify nullity <$> a

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

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

122120

123121

124122unnullifier :: ()

125123 => Nullifiability context

126− -> SSpec ('Spec a)

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

128− -> context ('Spec a)

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

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

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

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

124+ -> Spec a

125+ -> context (Nullify a)

126+ -> context a

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

128+ Aggregate $ sunnullify nullity <$> a

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

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

133131

134132

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

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

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

3434

3535-- rel8

3636import Rel8.Schema.Dict ( Dict )

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

37+import Rel8.Schema.Spec ( Spec )

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

3939import qualified Rel8.Schema.Kind as K

4040

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

5050-- instances yourself or specify this constraint.

5151type HTable :: K.HTable -> Constraint

5252class HTable t where

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

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

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

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

5555

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

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

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

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

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

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

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

60− hspecs :: t SSpec

60+ hspecs :: t Spec

6161

6262 type HField t = GHField t

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

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

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

6969 , GHTable context (Rep (t context))

7070 )

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

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

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

7373

7474 default htabulate ::

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

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

7878 , GHTable context (Rep (t context))

7979 )

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

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

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

8282

8383 default htraverse

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

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

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

8989 )

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)

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

9292

9393 default hdicts

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

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

102102

103103 default hspecs ::

104− ( Generic (t SSpec)

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

104+ ( Generic (t Spec)

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

106106 )

107− => t SSpec

107+ => t Spec

108108 hspecs = to $ fromGHColumns hspecs

109109

110110 {-# INLINABLE hfield #-}

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

115115

116116

117117hmap :: HTable t

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

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

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

120120

121121

122122htabulateA :: (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)

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

125125{-# INLINABLE htabulateA #-}

126126

127127

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

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

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

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

130130

131131

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

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

155155

156156

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

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

159−data HProductField x y spec

160− = HFst (HField x spec)

161− | HSnd (HField y spec)

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

159+data HProductField x y a

160+ = HFst (HField x a)

161+ | HSnd (HField y a)

162162

163163

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

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

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

1515

1616-- rel8

1717import Rel8.Schema.HTable ( HTable )

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

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

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

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

2121import qualified Rel8.Schema.Kind as K

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

2424

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

2626data HEitherTable left right context = HEitherTable

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

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

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

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

3030 }

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

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

11{-# language DataKinds #-}

2−{-# language GADTs #-}

3−{-# language PatternSynonyms #-}

2+{-# language FlexibleContexts #-}

43{-# language StandaloneKindSignatures #-}

54{-# language TypeFamilies #-}

5+{-# language UndecidableInstances #-}

77module Rel8.Schema.HTable.Identity

8− ( HIdentity( HIdentity, HType, unHIdentity )

9− , HType

8+ ( HIdentity( HIdentity, unHIdentity )

109 )

1110where

1211

1312-- base

1413import Data.Kind ( Type )

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

1515import Prelude

1616

1717-- rel8

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

2121 , hfield, htabulate, htraverse, hdicts, hspecs

2222 )

2323import 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 )

2527

2628

27−type HType :: 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

38− { unHIdentity :: context spec

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

30+newtype HIdentity a context = HIdentity

31+ { unHIdentity :: context a

3932 }

4033

4134

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

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

49− type HField (HIdentity spec) = HIdentityField spec

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

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

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

5038

51− hfield (HIdentity a) HIdentityField = a

52− htabulate f = HIdentity $ f HIdentityField

39+ hfield (HIdentity a) Refl = a

40+ htabulate f = HIdentity $ f Refl

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

5442 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

1919-- rel8

2020import Rel8.Schema.HTable

2121import qualified Rel8.Schema.Kind as K

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

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

2323

2424

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

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

2727

2828

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

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

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

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

3131

3232

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

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

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

4141 hdicts = HLabel (hdicts @table)

4242 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, ..}

4444 {-# INLINABLE hspecs #-}

4545

4646

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

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

66{-# language GADTs #-}

77{-# language InstanceSigs #-}

88{-# language MultiParamTypeClasses #-}

9−{-# language PolyKinds #-}

109{-# language ScopedTypeVariables #-}

1110{-# language StandaloneKindSignatures #-}

1211{-# language TypeApplications #-}

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

2423

2524-- base

2625import Data.Kind ( Constraint, Type )

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

26+import Prelude

2827

2928-- rel8

30−import Rel8.FCF

29+import Rel8.FCF ( Exp, Eval )

3130import Rel8.Schema.HTable

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

31+ ( HTable, HConstrainTable, HField

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

33+ )

34+import Rel8.Schema.Spec ( Spec )

3335import qualified Rel8.Schema.Kind as K

3436import Rel8.Schema.Dict ( Dict( Dict ) )

3537

3638

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

38−newtype HMapTable f t g = HMapTable

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

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

40+newtype HMapTable f t context = HMapTable

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

4042 }

4143

4244

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

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

4446newtype Precompose f g x = Precompose

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

4648 }

4749

4850

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

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

5052data HMapTableField f t x where

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

5254

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

7981 {-# INLINABLE hspecs #-}

8082

8183

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

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

8385class MapSpec f where

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

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

8587

8688

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

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

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

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

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

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

1515

1616-- rel8

1717import Rel8.Schema.HTable ( HTable )

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

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

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

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

2121import qualified Rel8.Schema.Kind as K

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

2424

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

2626data HMaybeTable table context = HMaybeTable

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

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

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

2929 }

3030 deriving stock Generic

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

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

2727where

2828

2929-- base

30+import Data.Kind ( Type )

3031import GHC.Generics ( Generic )

3132import Prelude hiding ( null )

3233

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

4041import qualified Rel8.Schema.Kind as K

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

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

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

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

4445

4546-- semigroupoids

4647import Data.Functor.Apply ( Apply )

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

5253 deriving anyclass HTable

5354

5455

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

56−data Nullify :: Spec -> Exp Spec

57−

58−

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

60− 'Spec (Type.Nullify a)

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

57+data Nullify :: Type -> Exp Type

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

6159

6260

6361instance MapSpec Nullify where

6462 mapInfo = \case

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

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

6664 { nullity = case nullity of

6765 Null -> Null

6866 NotNull -> Null

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

7169

7270

7371hguard :: HTable t

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

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

7573 -> HNullify t context -> HNullify t context

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

7775 case hfield hspecs field of

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

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

7977 a -> case nullity of

8078 Null -> guarder a

8179 NotNull -> guarder a

8280

8381

8482hnulls :: HTable t

85− => (forall a. ()

86− => SSpec ('Spec a)

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

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

8884 -> HNullify t context

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

9086 case hfield hspecs field of

91− spec@SSpec {} -> null spec

87+ spec@Spec {} -> null spec

9288{-# INLINABLE hnulls #-}

9389

9490

9591hnullify :: 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))

10093 -> t context

10194 -> HNullify t context

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

10396 case hfield hspecs field of

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

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

10598{-# INLINABLE hnullify #-}

10699

107100

108101hunnullify :: (HTable t, Apply m)

109− => (forall a. ()

110− => SSpec ('Spec a)

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

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

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

113103 -> HNullify t context

114104 -> m (t context)

115105hunnullify unnullifier (HNullify as) =

116106 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

118108 a -> unnullifier spec a

119109{-# INLINABLE hunnullify #-}

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

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

1515

1616-- rel8

1717import Rel8.Schema.HTable ( HTable )

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

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

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

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

2121import qualified Rel8.Schema.Kind as K

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

2424

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

2626data HTheseTable here there context = HTheseTable

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

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

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

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

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

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

3131 }

3232 deriving stock Generic

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

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

99{-# language GADTs #-}

1010{-# language LambdaCase #-}

1111{-# language MultiParamTypeClasses #-}

12−{-# language NamedFieldPuns #-}

1312{-# language RankNTypes #-}

1413{-# language RecordWildCards #-}

1514{-# language ScopedTypeVariables #-}

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

3332-- rel8

3433import Rel8.Schema.Dict ( Dict( Dict ) )

3534import qualified Rel8.Schema.Kind as K

36−import Rel8.Schema.HTable

37− ( HTable

38− , hfield, htabulate, htabulateA, hspecs

39− )

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

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

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

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

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

4339import Rel8.Type.Information ( TypeInformation )

4440

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

7369 deriving anyclass HTable

7470

7571

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

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

7773

7874

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

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

8076

8177

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

8379 mapInfo = \case

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

85− Dict -> SSpec

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

81+ Dict -> Spec

8682 { nullity = NotNull

8783 , info = vectorTypeInformation nullity info

8884 , ..

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

9086

9187

9288hvectorize :: (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))

9790 -> f (t context)

9891 -> HVectorize list t context'

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

10093 case hfield hspecs field of

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

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

10295{-# INLINABLE hvectorize #-}

10396

10497

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

106− => (forall a. ()

107− => SSpec ('Spec a)

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

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

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

110100 -> HVectorize list t context

111101 -> f (t context')

112102hunvectorize unvectorizer (HVectorize table) =

113103 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

115105 a -> Zippy (unvectorizer spec a)

116106{-# INLINABLE hunvectorize #-}

117107

118108

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

120− ( forall a. ()

121− => Nullity a

122− -> TypeInformation (Unnullify a)

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

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

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

126− )

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

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

127111 -> HVectorize list t context

128112 -> HVectorize list t context

129113 -> HVectorize list t context

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

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

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

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

117+ spec -> append spec a b

134118

135119

136−hempty :: HTable t =>

137− ( forall a. ()

138− => Nullity a

139− -> TypeInformation (Unnullify a)

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

141− )

120+hempty :: HTable t

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

142122 -> HVectorize [] t context

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

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

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

124+ empty (hfield hspecs field)

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

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

11{-# language StandaloneKindSignatures #-}

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

3+module Rel8.Schema.Kind

4+ ( Rel8able

5+ , Context

6+ , HTable

7+ )

8+where

510-- base

611import Data.Kind ( Type )

712import Prelude ()

813

9−-- rel8

10−import Rel8.Schema.Spec ( Spec )

11−

1214

1315type Context :: Type

14−type Context = Spec -> Type

16+type Context = Type -> Type

1517

1618

1719type HTable :: Type

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

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

33{-# language FlexibleContexts #-}

44{-# language FlexibleInstances #-}

55{-# language GADTs #-}

6+{-# language GeneralizedNewtypeDeriving #-}

67{-# language MultiParamTypeClasses #-}

7−{-# language PolyKinds #-}

88{-# language RankNTypes #-}

9−{-# language StandaloneDeriving #-}

109{-# language StandaloneKindSignatures #-}

1110{-# language TypeFamilies #-}

1211{-# language UndecidableInstances #-}

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

1817where

1918

2019-- base

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

2121import Data.Kind ( Constraint, Type )

22−import Data.String ( IsString, fromString )

22+import Data.String ( IsString )

2323import Prelude

2424

2525-- rel8

2626import Rel8.Expr ( Expr )

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

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

27+import qualified Rel8.Schema.Kind as K

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

2929import Rel8.Schema.Null ( Sql )

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

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

3230import Rel8.Table

3331 ( Table, Columns, Context, fromColumns, toColumns

3432 , FromExprs, fromResult, toResult

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

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

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

4442-- a 'TableSchema' value.

45−type Name :: k -> Type

46−data Name a where

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)

55−

56−

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

58− fromString = Name

43+type Name :: K.Context

44+newtype Name a = Name String

45+ deriving stock Show

46+ deriving newtype IsString

5947

6048

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

62− type Columns (Name a) = HType a

50+ type Columns (Name a) = HIdentity a

6351 type Context (Name a) = Name

6452 type FromExprs (Name a) = a

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

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

6654

67− toColumns a = HType (N a)

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

69− toResult a = HType (R a)

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

55+ toColumns a = HIdentity a

56+ fromColumns (HIdentity a) = a

57+ toResult a = HIdentity (Identity a)

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

7159

7260

7361-- | @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 @@

55{-# language TypeFamilies #-}

77module Rel8.Schema.Result

8− ( Result( R, unR )

8+ ( Result

99 , null, nullifier, unnullifier

1010 , vectorizer, unvectorizer

1111 )

1212where

1313

1414-- base

15−import Data.Functor.Identity ( Identity )

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

1616import Prelude hiding ( null )

1717

1818-- rel8

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

2019import Rel8.Schema.Kind ( Context )

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

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

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

2322

2423

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

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

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

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

2928type Result :: Context

30−data Result a where

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

29+type Result = Identity

3230

3331

34−type instance Lower Result = Identity

32+null :: Result (Maybe a)

33+null = Identity Nothing

3534

3635

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))

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

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

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

4638 Null -> a

4739 NotNull -> Just a

4840

4941

50−unnullifier :: ()

51− => SSpec ('Spec a)

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

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

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

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

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

5544 case nullity of

56− Null -> pure $ R a

57− NotNull -> R <$> a

45+ Null -> pure $ Identity a

46+ NotNull -> Identity <$> a

5847

5948

60−vectorizer :: Functor f

61− => SSpec ('Spec a)

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

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

64−vectorizer _ = R . fmap unR

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

50+vectorizer _ = Identity . fmap runIdentity

6551

6652

67−unvectorizer :: Functor f

68− => SSpec ('Spec a)

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

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

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

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

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

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

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

1−{-# language DataKinds #-}

21{-# language FlexibleContexts #-}

3−{-# language GADTs #-}

2+{-# language MonoLocalBinds #-}

43{-# language StandaloneKindSignatures #-}

5−{-# language UndecidableInstances #-}

75module Rel8.Schema.Spec

8− ( Spec( Spec )

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

10− , KnownSpec( specSing )

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

7+ , specification

118 )

129where

1310

1411-- base

15−import Data.Kind ( Constraint, Type )

12+import Data.Kind ( Type )

1613import Prelude

1714

1815-- rel8

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

2118import Rel8.Type.Information ( TypeInformation )

2219

2320

24−type Spec :: Type

25−newtype Spec = Spec Type

21+type Spec :: Type -> Type

22+data Spec a = Spec

23+ { labels :: [String]

24+ , info :: TypeInformation (Unnullify a)

25+ , nullity :: Nullity a

26+ }

2627

2728

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

44− specSing = SSpec

45− { labels = []

46− , info = typeInformation

47− , nullity = nullable

48− }

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

30+specification = Spec

31+ { labels = []

32+ , info = typeInformation

33+ , nullity = nullable

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

3535 )

3636import Rel8.Generic.Record ( Record(..) )

3737import Rel8.Schema.HTable ( HTable )

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

3938import qualified Rel8.Schema.Kind as K

4039import Rel8.Schema.Result ( Result )

41−import Rel8.Schema.Spec ( KnownSpec )

4240

4341

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

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

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

170168

171169

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−

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

186171

187172

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

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

1616import Prelude

1717

1818-- rel8

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

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

19+import Rel8.Aggregate ( Aggregate, Aggregates )

20+import Rel8.Expr ( Expr )

2121import Rel8.Expr.Aggregate

2222 ( groupByExpr

2323 , slistAggExpr

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

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

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

2929import Rel8.Schema.Null ( Sql )

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

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

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

3231import Rel8.Table ( toColumns, fromColumns )

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

3433import Rel8.Table.List ( ListTable )

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

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

4443

4544

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

4846hgroupBy eqs exprs = htabulate $ \field ->

4947 case hfield eqs field of

5048 Dict -> case hfield exprs field of

51− E expr -> A $ groupByExpr expr

49+ expr -> groupByExpr expr

5250

5351

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

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

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

7169listAgg (toColumns -> exprs) = fromColumns $

7270 hvectorize

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

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

7472 (pure exprs)

7573

7674

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

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

7977nonEmptyAgg (toColumns -> exprs) = fromColumns $

8078 hvectorize

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

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

8280 (pure exprs)

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

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

1313import Prelude

1414

1515-- rel8

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

16+import Rel8.Expr ( Expr )

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

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

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

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

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

2929 fromColumns $ htabulate $ \field ->

3030 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

3332{-# INLINABLE bool #-}

3433

3534

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

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

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

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

42− E fallbackExpr ->

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

44− branchExprs -> E (caseExpr branchExprs fallbackExpr)

41+ fallbackExpr ->

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

43+ branchExprs -> caseExpr branchExprs fallbackExpr

4544

4645

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

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

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

2525

2626-- base

2727import Data.Bifunctor ( Bifunctor, bimap )

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

2829import Data.Kind ( Type )

2930import Prelude hiding ( undefined )

3031

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

3233import Control.Comonad ( extract )

3334

3435-- rel8

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

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

36+import Rel8.Aggregate ( Aggregate )

37+import Rel8.Expr ( Expr )

3738import Rel8.Expr.Aggregate ( groupByExpr )

3839import Rel8.Expr.Serialize ( litExpr )

3940import Rel8.Kind.Context ( Reifiable )

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

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

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

4546import qualified Rel8.Schema.Kind as K

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

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

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

47+import Rel8.Schema.Name ( Name )

4948import Rel8.Table

5049 ( Table, Columns, Context, fromColumns, toColumns

5150 , FromExprs, fromResult, toResult

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

7271-- adapted to work with Rel8.

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

7473data EitherTable context a b = EitherTable

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

74+ { tag :: context EitherTag

7675 , left :: Nullify context a

7776 , right :: Nullify context b

7877 }

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

8483

8584

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

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

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

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

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

8988

9089

9190instance (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

9493

9594

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

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

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

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

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

97+ EitherTable tag' l2 b ->

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

10099

101100

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

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

122121 EitherTable to (Transpose to a) (Transpose to b)

123122

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

125− { htag = hlabel $ HType tag

124+ { htag = hlabel $ HIdentity tag

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

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

128127 }

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

135134

136135 toResult = \case

137136 Left table -> HEitherTable

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

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

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

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

141140 }

142141 Right table -> HEitherTable

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

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

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

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

146145 }

147146

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

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

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

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

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

152151 where

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

157156 EqTable (EitherTable context a b)

158157 where

159158 eqTable = HEitherTable

160− { htag = hlabel (HType Dict)

159+ { htag = hlabel (HIdentity Dict)

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

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

163162 }

@@ -167,7 +166,7 @@ instance (OrdTable a, OrdTable b, context ~ Expr) =>

167166 OrdTable (EitherTable context a b)

168167 where

169168 ordTable = HEitherTable

170− { htag = hlabel (HType Dict)

169+ { htag = hlabel (HIdentity Dict)

171170 , hleft = hlabel (ordTable @(Nullify context a))

172171 , hright = hlabel (ordTable @(Nullify context b))

173172 }

@@ -179,30 +178,30 @@ instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2

179178

180179-- | Test if an 'EitherTable' is a 'leftTable'.

181180isLeftTable :: EitherTable Expr a b -> Expr Bool

182−isLeftTable EitherTable {tag = E tag} = isLeft tag

181+isLeftTable EitherTable {tag} = isLeft tag

183182

184183

185184-- | Test if an 'EitherTable' is a 'rightTable'.

186185isRightTable :: EitherTable Expr a b -> Expr Bool

187−isRightTable EitherTable {tag = E tag} = isRight tag

186+isRightTable EitherTable {tag} = isRight tag

188187

189188

190189-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a

191190-- 'leftTable' and 'rightTable'.

192191eitherTable :: Table Expr c

193192 => (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} =

195194 bool (f (extract left)) (g (extract right)) (isRight tag)

196195

197196

198197-- | Construct a left 'EitherTable'. Like 'Left'.

199198leftTable :: 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

201200

202201

203202-- | Construct a right 'EitherTable'. Like 'Right'.

204203rightTable :: Table Expr a => b -> EitherTable Expr a b

205−rightTable = EitherTable (E (litExpr IsRight)) undefined . pure

204+rightTable = EitherTable (litExpr IsRight) undefined . pure

206205

207206

208207-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.

@@ -212,8 +211,8 @@ aggregateEitherTable :: ()

212211 -> (exprs' -> aggregates')

213212 -> EitherTable Expr exprs exprs'

214213 -> EitherTable Aggregate aggregates aggregates'

215−aggregateEitherTable f g (EitherTable (E tag) a b) = EitherTable

216− { tag = A (groupByExpr tag)

214+aggregateEitherTable f g (EitherTable tag a b) = EitherTable

215+ { tag = groupByExpr tag

217216 , left = aggregateNullify f a

218217 , right = aggregateNullify g b

219218 }

@@ -231,4 +230,4 @@ nameEitherTable

231230 -> b

232231 -- ^ Names of the columns in the @b@ table.

233232 -> 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 )

2727import Prelude

2828

2929-- rel8

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

30+import Rel8.Expr ( Expr )

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

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

3333import Rel8.FCF ( Eval, Exp )

@@ -35,9 +35,8 @@ import Rel8.Generic.Record ( Record )

3535import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )

3636import Rel8.Schema.Dict ( Dict( Dict ) )

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

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

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

3939import Rel8.Schema.Null ( Sql )

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

4140import Rel8.Table ( Table, Columns, toColumns, TColumns, TFromExprs )

4241import Rel8.Type.Eq ( DBEq )

4342

@@ -47,13 +46,13 @@ import Rel8.Type.Eq ( DBEq )

4746-- means "all columns in a 'Table' have an instance of 'DBEq'".

4847type EqTable :: Type -> Constraint

4948class Table Expr a => EqTable a where

50− eqTable :: Columns a (Dict (ConstrainSpec (Sql DBEq)))

49+ eqTable :: Columns a (Dict (Sql DBEq))

5150

5251 default eqTable ::

5352 ( GTable TEqTable TColumns TFromExprs (Rep (Record a))

5453 , Columns a ~ GColumns TColumns (Rep (Record a))

5554 )

56− => Columns a (Dict (ConstrainSpec (Sql DBEq)))

55+ => Columns a (Dict (Sql DBEq))

5756 eqTable =

5857 gtable

5958 @TEqTable

@@ -70,7 +69,7 @@ type instance Eval (TEqTable a) = EqTable a

7069

7170

7271instance Sql DBEq a => EqTable (Expr a) where

73− eqTable = HType Dict

72+ eqTable = HIdentity Dict

7473

7574

7675instance (EqTable a, EqTable b) => EqTable (a, b)

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

104103(toColumns -> as) ==: (toColumns -> bs) =

105104 foldl1' (&&.) $ getConst $ htabulateA $ \field ->

106105 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

108107 Dict -> Const (pure (a ==. b))

109108infix 4 ==:

110109

@@ -116,7 +115,7 @@ infix 4 ==:

116115(toColumns -> as) /=: (toColumns -> bs) =

117116 foldl1' (||.) $ getConst $ htabulateA $ \field ->

118117 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

120119 Dict -> Const (pure (a /=. b))

121120infix 4 /=:

122121

src/Rel8/Table/List.hs+10−12

@@ -21,16 +21,16 @@ import Data.Kind ( Type )

2121import Prelude

2222

2323-- rel8

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

24+import Rel8.Expr ( Expr )

2525import Rel8.Expr.Array ( sappend, sempty, slistOf )

2626import Rel8.Schema.Dict ( Dict( Dict ) )

2727import Rel8.Schema.HTable.List ( HListTable )

2828import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize, hunvectorize )

2929import qualified Rel8.Schema.Kind as K

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

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

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

3232import Rel8.Schema.Result ( vectorizer, unvectorizer )

33−import Rel8.Schema.Spec ( SSpec(..) )

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

3434import Rel8.Table

3535 ( Table, Context, Columns, fromColumns, toColumns

3636 , FromExprs, fromResult, toResult

@@ -69,7 +69,7 @@ instance (Table context a, context ~ context') =>

6969instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where

7070 eqTable =

7171 hvectorize

72− (\SSpec {nullity} (Identity Dict) -> case nullity of

72+ (\Spec {nullity} (Identity Dict) -> case nullity of

7373 Null -> Dict

7474 NotNull -> Dict)

7575 (Identity (eqTable @a))

@@ -78,7 +78,7 @@ instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where

7878instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where

7979 ordTable =

8080 hvectorize

81− (\SSpec {nullity} (Identity Dict) -> case nullity of

81+ (\Spec {nullity} (Identity Dict) -> case nullity of

8282 Null -> Dict

8383 NotNull -> Dict)

8484 (Identity (ordTable @a))

@@ -96,24 +96,22 @@ instance context ~ Expr => AlternativeTable (ListTable context) where

9696 emptyTable = mempty

9797

9898

99−instance (context ~ Expr, Table Expr a) =>

100− Semigroup (ListTable context a)

99+instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)

101100 where

102− ListTable as <> ListTable bs = ListTable $

103− happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs

101+ ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs

104102

105103

106104instance (context ~ Expr, Table Expr a) =>

107105 Monoid (ListTable context a)

108106 where

109− mempty = ListTable $ hempty $ \_ -> E . sempty

107+ mempty = ListTable $ hempty $ \Spec {info} -> sempty info

110108

111109

112110-- | Construct a @ListTable@ from a list of expressions.

113111listTable :: Table Expr a => [a] -> ListTable Expr a

114112listTable =

115113 ListTable .

116− hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) .

114+ hvectorize (\Spec {info} -> slistOf info) .

117115 fmap toColumns

118116

119117

@@ -126,6 +124,6 @@ nameListTable

126124 -> ListTable Name a

127125nameListTable =

128126 ListTable .

129− hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

127+ hvectorize (\_ (Identity (Name a)) -> Name a) .

130128 pure .

131129 toColumns

src/Rel8/Table/Maybe.hs+19−21

@@ -23,6 +23,7 @@ where

2323

2424-- base

2525import Data.Functor ( ($>) )

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

2627import Data.Kind ( Type )

2728import Data.Maybe ( fromMaybe, isJust )

2829import Prelude hiding ( null, undefined )

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

3132import Control.Comonad ( extract )

3233

3334-- rel8

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

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

35+import Rel8.Aggregate ( Aggregate )

36+import Rel8.Expr ( Expr )

3637import Rel8.Expr.Aggregate ( groupByExpr )

3738import Rel8.Expr.Bool ( boolExpr )

3839import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )

@@ -42,11 +43,9 @@ import qualified Rel8.Schema.Kind as K

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

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

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

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

46+import Rel8.Schema.Name ( Name )

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

4748import qualified Rel8.Schema.Null as N

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

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

5049import Rel8.Table

5150 ( Table, Columns, Context, fromColumns, toColumns

5251 , FromExprs, fromResult, toResult

@@ -80,15 +79,14 @@ import Data.Functor.Bind ( Bind, (>>-) )

8079-- a "nullTag" - to track whether or not the outer join produced any rows.

8180type MaybeTable :: K.Context -> Type -> Type

8281data MaybeTable context a = MaybeTable

83− { tag :: context ('Spec (Maybe MaybeTag))

82+ { tag :: context (Maybe MaybeTag)

8483 , just :: Nullify context a

8584 }

8685 deriving stock Functor

8786

8887

8988instance context ~ Expr => Apply (MaybeTable context) where

90− MaybeTable (E tag) f <.> MaybeTable (E tag') a =

91− MaybeTable (E (tag <> tag')) (f <.> a)

89+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)

9290

9391

9492-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:

@@ -99,8 +97,8 @@ instance context ~ Expr => Applicative (MaybeTable context) where

9997

10098

10199instance context ~ Expr => Bind (MaybeTable context) where

102− MaybeTable (E tag) a >>- f = case f (extract a) of

103− MaybeTable (E tag') b -> MaybeTable (E (tag <> tag')) b

100+ MaybeTable tag a >>- f = case f (extract a) of

101+ MaybeTable tag' b -> MaybeTable (tag <> tag') b

104102

105103

106104-- | Has the same behavior as the @Monad@ instance for @Maybe@.

@@ -147,12 +145,12 @@ instance (Table context a, Reifiable context, context ~ context') =>

147145 }

148146

149147 toResult ma = HMaybeTable

150− { htag = hlabel (HIdentity (R (IsJust <$ ma)))

148+ { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))

151149 , hjust = hlabel (toResult @_ @(Nullify context a) ma)

152150 }

153151

154152 fromResult HMaybeTable {htag, hjust} = case hunlabel htag of

155− HType (R tag) -> tag $>

153+ HIdentity (Identity tag) -> tag $>

156154 fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))

157155 where

158156 err = error "Maybe.fromColumns: mismatch between tag and data"

@@ -160,14 +158,14 @@ instance (Table context a, Reifiable context, context ~ context') =>

160158

161159instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where

162160 eqTable = HMaybeTable

163− { htag = hlabel (HType Dict)

161+ { htag = hlabel (HIdentity Dict)

164162 , hjust = hlabel (eqTable @(Nullify context a))

165163 }

166164

167165

168166instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where

169167 ordTable = HMaybeTable

170− { htag = hlabel (HType Dict)

168+ { htag = hlabel (HIdentity Dict)

171169 , hjust = hlabel (ordTable @(Nullify context a))

172170 }

173171

@@ -178,12 +176,12 @@ instance (ToExprs exprs a, context ~ Expr) =>

178176

179177-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.

180178isNothingTable :: MaybeTable Expr a -> Expr Bool

181−isNothingTable (MaybeTable (E tag) _) = isNull tag

179+isNothingTable (MaybeTable tag _) = isNull tag

182180

183181

184182-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.

185183isJustTable :: MaybeTable Expr a -> Expr Bool

186−isJustTable (MaybeTable (E tag) _) = isNonNull tag

184+isJustTable (MaybeTable tag _) = isNonNull tag

187185

188186

189187-- | 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)

194192

195193-- | The null table. Like 'Nothing'.

196194nothingTable :: Table Expr a => MaybeTable Expr a

197−nothingTable = MaybeTable (E null) (pure undefined)

195+nothingTable = MaybeTable null (pure undefined)

198196

199197

200198-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use

201199-- 'pure'.

202200justTable :: a -> MaybeTable Expr a

203−justTable = MaybeTable (E mempty) . pure

201+justTable = MaybeTable mempty . pure

204202

205203

206204-- | Project a single expression out of a 'MaybeTable'. You can think of this

@@ -220,8 +218,8 @@ aggregateMaybeTable :: ()

220218 => (exprs -> aggregates)

221219 -> MaybeTable Expr exprs

222220 -> MaybeTable Aggregate aggregates

223−aggregateMaybeTable f (MaybeTable (E tag) a) =

224− MaybeTable (A (groupByExpr tag)) (aggregateNullify f a)

221+aggregateMaybeTable f (MaybeTable tag a) =

222+ MaybeTable (groupByExpr tag) (aggregateNullify f a)

225223

226224

227225-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you

@@ -234,4 +232,4 @@ nameMaybeTable

234232 -> a

235233 -- ^ Names of the columns in @a@.

236234 -> 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

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

3030

3131-- rel8

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

32+import Rel8.Expr ( Expr )

3333import Rel8.Expr.Opaleye ( toPrimExpr )

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

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

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

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

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

3737import Rel8.Table ( Table(..) )

3838import Rel8.Table.Cols ( Cols( Cols ) )

3939

@@ -67,26 +67,26 @@ namesFromLabelsWith :: Table Name a

6767 => (NonEmpty String -> String) -> a

6868namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

6969 case hfield hspecs field of

70− SSpec {labels} -> N (Name (f (renderLabels labels)))

70+ Spec {labels} -> Name (f (renderLabels labels))

7171

7272

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

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

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

7676 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)]

7878

7979

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

8181showLabels _ = getConst $

8282 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

83− SSpec {labels} -> Const [renderLabels labels]

83+ Spec {labels} -> Const [renderLabels labels]

8484

8585

8686showNames :: forall a. Table Name a => a -> [String]

8787showNames (toColumns -> names) = getConst $

8888 htabulateA @(Columns a) $ \field -> case hfield names field of

89− N (Name name) -> Const [name]

89+ Name name -> Const [name]

9090

9191

9292renderLabels :: [String] -> NonEmpty String

src/Rel8/Table/NonEmpty.hs+9−10

@@ -22,16 +22,16 @@ import Data.List.NonEmpty ( NonEmpty )

2222import Prelude hiding ( id )

2323

2424-- rel8

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

25+import Rel8.Expr ( Expr )

2626import Rel8.Expr.Array ( sappend1, snonEmptyOf )

2727import Rel8.Schema.Dict ( Dict( Dict ) )

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

2929import Rel8.Schema.HTable.Vectorize ( happend, hvectorize, hunvectorize )

3030import qualified Rel8.Schema.Kind as K

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

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

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

3333import Rel8.Schema.Result ( vectorizer, unvectorizer )

34−import Rel8.Schema.Spec ( SSpec(..) )

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

3535import Rel8.Table

3636 ( Table, Context, Columns, fromColumns, toColumns

3737 , FromExprs, fromResult, toResult

@@ -70,7 +70,7 @@ instance (EqTable a, context ~ Expr) =>

7070 where

7171 eqTable =

7272 hvectorize

73− (\SSpec {nullity} (Identity Dict) -> case nullity of

73+ (\Spec {nullity} (Identity Dict) -> case nullity of

7474 Null -> Dict

7575 NotNull -> Dict)

7676 (Identity (eqTable @a))

@@ -81,7 +81,7 @@ instance (OrdTable a, context ~ Expr) =>

8181 where

8282 ordTable =

8383 hvectorize

84− (\SSpec {nullity} (Identity Dict) -> case nullity of

84+ (\Spec {nullity} (Identity Dict) -> case nullity of

8585 Null -> Dict

8686 NotNull -> Dict)

8787 (Identity (ordTable @a))

@@ -95,18 +95,17 @@ instance context ~ Expr => AltTable (NonEmptyTable context) where

9595 (<|>:) = (<>)

9696

9797

98−instance (Table Expr a, context ~ Expr) =>

99− Semigroup (NonEmptyTable context a)

98+instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)

10099 where

101100 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

102− happend (\_ _ (E a) (E b) -> E (sappend1 a b)) as bs

101+ happend (const sappend1) as bs

103102

104103

105104-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

106105nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

107106nonEmptyTable =

108107 NonEmptyTable .

109− hvectorize (\SSpec {info} -> E . snonEmptyOf info . fmap unE) .

108+ hvectorize (\Spec {info} -> snonEmptyOf info) .

110109 fmap toColumns

111110

112111

@@ -119,6 +118,6 @@ nameNonEmptyTable

119118 -> NonEmptyTable Name a

120119nameNonEmptyTable =

121120 NonEmptyTable .

122− hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

121+ hvectorize (\_ (Identity (Name a)) -> Name a) .

123122 pure .

124123 toColumns

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

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

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

4343import qualified Rel8.Schema.Kind as K

4444import qualified Rel8.Schema.Result as R

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

4645import Rel8.Table

4746 ( Table, Columns, Context, toColumns, fromColumns

4847 , FromExprs, fromResult, toResult

@@ -165,7 +164,7 @@ aggregateNullify f = \case

165164

166165

167166guard :: (Reifiable context, HTable t)

168− => context ('Spec tag)

167+ => context tag

169168 -> (tag -> Bool)

170169 -> (Expr tag -> Expr Bool)

171170 -> HNullify t context

src/Rel8/Table/Opaleye.hs+18−22

@@ -37,8 +37,8 @@ import qualified Opaleye.Internal.Table as Opaleye

3737import Data.Profunctor ( dimap, lmap )

3838

3939-- rel8

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

41−import Rel8.Expr ( Expr(..) )

40+import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )

41+import Rel8.Expr ( Expr )

4242import Rel8.Expr.Opaleye

4343 ( fromPrimExpr, toPrimExpr

4444 , traversePrimExpr

@@ -46,8 +46,8 @@ import Rel8.Expr.Opaleye

4646 , scastExpr

4747 )

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

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

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

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

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

5151import Rel8.Schema.Table ( TableSchema(..) )

5252import Rel8.Table ( Table, fromColumns, toColumns )

5353import Rel8.Table.Undefined ( undefined )

@@ -60,8 +60,8 @@ aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs

6060aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->

6161 fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

6262 WrapApplicative $ case hfield (toColumns aggregates) field of

63− A (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) ->

64− E <$> inner f ()

63+ Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner)) ->

64+ inner f ()

6565

6666

6767binaryspec :: Table Expr a => Opaleye.Binaryspec a a

@@ -69,7 +69,7 @@ binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->

6969 fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

7070 WrapApplicative $

7171 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)

7373

7474

7575distinctspec :: Table Expr a => Opaleye.Distinctspec a a

@@ -78,8 +78,7 @@ distinctspec =

7878 fmap fromColumns .

7979 unwrapApplicative .

8080 htraverse

81− (\(E a) ->

82− WrapApplicative $ E . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .

81+ (\a -> WrapApplicative $ fromPrimExpr <$> f (Nothing, toPrimExpr a)) .

8382 toColumns

8483

8584

@@ -97,18 +96,17 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $

9796 case hfield names field of

9897 name -> lmap (`hfield` field) (go name)

9998 where

100− go :: forall (spec :: Spec). Name spec -> Opaleye.TableFields (Expr spec) (Expr spec)

101− go (N (Name name)) =

102− lmap (\(E a) -> toColumn $ toPrimExpr a) $

103− E . fromPrimExpr . fromColumn <$>

104− Opaleye.requiredTableField name

99+ go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)

100+ go (Name name) =

101+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

102+ Opaleye.requiredTableField name

105103

106104

107105unpackspec :: Table Expr a => Opaleye.Unpackspec a a

108106unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

109107 fmap fromColumns .

110108 unwrapApplicative .

111− htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) .

109+ htraverse (WrapApplicative . traversePrimExpr f) .

112110 toColumns

113111{-# INLINABLE unpackspec #-}

114112

@@ -122,7 +120,7 @@ toPackMap :: Table Expr a

122120toPackMap as = Opaleye.PackMap $ \f () ->

123121 fmap fromColumns $

124122 unwrapApplicative .

125− htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) $

123+ htraverse (WrapApplicative . traversePrimExpr f) $

126124 toColumns as

127125

128126

@@ -130,9 +128,7 @@ toPackMap as = Opaleye.PackMap $ \f () ->

130128-- finalising a SELECT or RETURNING statement, guaranteed that the output

131129-- matches what is encoded in each columns TypeInformation.

132130castTable :: Table Expr a => a -> a

133−castTable (toColumns -> as) = fromColumns $ htabulate \i ->

134− case hfield hspecs i of

135− SSpec{info} ->

136− case hfield as i of

137− E expr ->

138− E (scastExpr info expr)

131+castTable (toColumns -> as) = fromColumns $ htabulate \field ->

132+ case hfield hspecs field of

133+ Spec {info} -> case hfield as field of

134+ expr -> scastExpr info expr

src/Rel8/Table/Ord.hs+9−10

@@ -24,7 +24,7 @@ import GHC.Generics ( Rep )

2424import Prelude hiding ( seq )

2525

2626-- rel8

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

27+import Rel8.Expr ( Expr )

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

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

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

@@ -33,9 +33,8 @@ import Rel8.Generic.Record ( Record )

3333import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )

3434import Rel8.Schema.Dict ( Dict( Dict ) )

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

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

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

3737import Rel8.Schema.Null (Sql)

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

3938import Rel8.Table ( Columns, toColumns, TColumns, TFromExprs )

4039import Rel8.Table.Bool ( bool )

4140import Rel8.Table.Eq ( EqTable )

@@ -47,13 +46,13 @@ import Rel8.Type.Ord ( DBOrd )

4746-- columns in a 'Table' have an instance of 'DBOrd'".

4847type OrdTable :: Type -> Constraint

4948class EqTable a => OrdTable a where

50− ordTable :: Columns a (Dict (ConstrainSpec (Sql DBOrd)))

49+ ordTable :: Columns a (Dict (Sql DBOrd))

5150

5251 default ordTable ::

5352 ( GTable TOrdTable TColumns TFromExprs (Rep (Record a))

5453 , Columns a ~ GColumns TColumns (Rep (Record a))

5554 )

56− => Columns a (Dict (ConstrainSpec (Sql DBOrd)))

55+ => Columns a (Dict (Sql DBOrd))

5756 ordTable =

5857 gtable

5958 @TOrdTable

@@ -70,7 +69,7 @@ type instance Eval (TOrdTable a) = OrdTable a

7069

7170

7271instance Sql DBOrd a => OrdTable (Expr a) where

73− ordTable = HType Dict

72+ ordTable = HIdentity Dict

7473

7574

7675instance (OrdTable a, OrdTable b) => OrdTable (a, b)

@@ -105,7 +104,7 @@ instance

105104(toColumns -> as) <: (toColumns -> bs) =

106105 foldr @[] go false $ getConst $ htabulateA $ \field ->

107106 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

109108 Dict -> Const [(a <. b, a ==. b)]

110109 where

111110 go (lt, eq) a = lt ||. (eq &&. a)

@@ -118,7 +117,7 @@ infix 4 <:

118117(toColumns -> as) <=: (toColumns -> bs) =

119118 foldr @[] go true $ getConst $ htabulateA $ \field ->

120119 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

122121 Dict -> Const [(a <. b, a ==. b)]

123122 where

124123 go (lt, eq) a = lt ||. (eq &&. a)

@@ -131,7 +130,7 @@ infix 4 <=:

131130(toColumns -> as) >: (toColumns -> bs) =

132131 foldr @[] go false $ getConst $ htabulateA $ \field ->

133132 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

135134 Dict -> Const [(a >. b, a ==. b)]

136135 where

137136 go (gt, eq) a = gt ||. (eq &&. a)

@@ -144,7 +143,7 @@ infix 4 >:

144143(toColumns -> as) >=: (toColumns -> bs) =

145144 foldr @[] go true $ getConst $ htabulateA $ \field ->

146145 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

148147 Dict -> Const [(a >. b, a ==. b)]

149148 where

150149 go (gt, eq) a = gt ||. (eq &&. a)

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

@@ -16,13 +16,12 @@ import Data.Functor.Contravariant ( (>$<), contramap )

1616import Prelude

1717

1818-- rel8

19−import Rel8.Expr ( unE )

2019import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )

2120import Rel8.Order ( Order )

2221import Rel8.Schema.Dict ( Dict( Dict ) )

2322import Rel8.Schema.HTable (htabulateA, hfield, hspecs)

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

25−import Rel8.Schema.Spec ( SSpec( SSpec, nullity ) )

24+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

2625import Rel8.Table ( Columns, toColumns )

2726import Rel8.Table.Ord ( OrdTable, ordTable )

2827

@@ -32,8 +31,8 @@ import Rel8.Table.Ord ( OrdTable, ordTable )

3231ascTable :: forall a. OrdTable a => Order a

3332ascTable = contramap toColumns $ getConst $

3433 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

35− SSpec {nullity} -> case hfield (ordTable @a) field of

36− Dict -> Const $ unE . (`hfield` field) >$<

34+ Spec {nullity} -> case hfield (ordTable @a) field of

35+ Dict -> Const $ (`hfield` field) >$<

3736 case nullity of

3837 Null -> nullsFirst asc

3938 NotNull -> asc

@@ -44,8 +43,8 @@ ascTable = contramap toColumns $ getConst $

4443descTable :: forall a. OrdTable a => Order a

4544descTable = contramap toColumns $ getConst $

4645 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

47− SSpec {nullity} -> case hfield (ordTable @a) field of

48− Dict -> Const $ unE . (`hfield` field) >$<

46+ Spec {nullity} -> case hfield (ordTable @a) field of

47+ Dict -> Const $ (`hfield` field) >$<

4948 case nullity of

5049 Null -> nullsLast desc

5150 NotNull -> desc

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

@@ -35,7 +35,6 @@ import Rel8.Table

3535 , FromExprs, fromResult, toResult

3636 , Transpose

3737 )

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

3938import Rel8.Table.ADT ( ADT )

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

4140import Rel8.Table.Ord ( OrdTable, ordTable )

@@ -61,22 +60,22 @@ instance (Rel8able t, Virtual context, context ~ context') =>

6160instance

6261 ( context ~ Expr

6362 , Rel8able t

64− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))

63+ , HConstrainTable (Columns (t context)) (Sql DBEq)

6564 )

6665 => EqTable (t context)

6766 where

68− eqTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBEq))

67+ eqTable = hdicts @(Columns (t context)) @(Sql DBEq)

6968

7069

7170instance

7271 ( context ~ Expr

7372 , Rel8able t

74− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))

75− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBOrd))

73+ , HConstrainTable (Columns (t context)) (Sql DBEq)

74+ , HConstrainTable (Columns (t context)) (Sql DBOrd)

7675 )

7776 => OrdTable (t context)

7877 where

79− ordTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBOrd))

78+ ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)

8079

8180

8281instance

src/Rel8/Table/Serialize.hs+7−10

@@ -16,6 +16,7 @@ module Rel8.Table.Serialize

1616where

1717

1818-- base

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

1920import Data.Kind ( Constraint, Type )

2021import Data.List.NonEmpty ( NonEmpty )

2122import Prelude

@@ -24,12 +25,12 @@ import Prelude

2425import qualified Hasql.Decoders as Hasql

2526

2627-- rel8

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

28+import Rel8.Expr ( Expr )

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

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

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

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

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

32+import Rel8.Schema.Result ( Result )

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

3334import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )

3435import Rel8.Type ( DBType )

3536

@@ -115,10 +116,6 @@ instance

115116 => ToExprs x (a, b, c, d, e, f, g)

116117

117118

118−instance (KnownSpec spec, x ~ Expr spec) =>

119− ToExprs x (Result spec)

120−

121−

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

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

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

@@ -141,11 +138,11 @@ parse = fromResult @_ @exprs <$> parseHTable

141138litHTable :: HTable t => t Result -> t Expr

142139litHTable as = htabulate $ \field ->

143140 case hfield hspecs field of

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

145− R value -> E (slitExpr nullity info value)

141+ Spec {nullity, info} -> case hfield as field of

142+ Identity value -> slitExpr nullity info value

146143

147144

148145parseHTable :: HTable t => Hasql.Row (t Result)

149146parseHTable = unwrapApplicative $ htabulateA $ \field ->

150147 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) =>

208208 EqTable (TheseTable context a b)

209209 where

210210 eqTable = HTheseTable

211− { hhereTag = hlabel (HType Dict)

211+ { hhereTag = hlabel (HIdentity Dict)

212212 , hhere = hlabel (eqTable @(Nullify context a))

213− , hthereTag = hlabel (HType Dict)

213+ , hthereTag = hlabel (HIdentity Dict)

214214 , hthere = hlabel (eqTable @(Nullify context b))

215215 }

216216

@@ -219,9 +219,9 @@ instance (OrdTable a, OrdTable b, context ~ Expr) =>

219219 OrdTable (TheseTable context a b)

220220 where

221221 ordTable = HTheseTable

222− { hhereTag = hlabel (HType Dict)

222+ { hhereTag = hlabel (HIdentity Dict)

223223 , hhere = hlabel (ordTable @(Nullify context a))

224− , hthereTag = hlabel (HType Dict)

224+ , hthereTag = hlabel (HIdentity Dict)

225225 , hthere = hlabel (ordTable @(Nullify context b))

226226 }

227227

src/Rel8/Table/Undefined.hs+5−5

@@ -11,16 +11,16 @@ where

1111import Prelude hiding ( undefined )

1212

1313-- rel8

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

14+import Rel8.Expr ( Expr )

1515import Rel8.Expr.Null ( snull, unsafeUnnullify )

1616import Rel8.Schema.HTable ( htabulate, hfield, hspecs )

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

18−import Rel8.Schema.Spec ( SSpec(..) )

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

1919import Rel8.Table ( Table, fromColumns )

2020

2121

2222undefined :: Table Expr a => a

2323undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of

24− SSpec {nullity, info} -> case nullity of

25− Null -> E (snull info)

26− NotNull -> E (unsafeUnnullify (snull info))

24+ Spec {nullity, info} -> case nullity of

25+ Null -> snull info

26+ NotNull -> unsafeUnnullify (snull info)

src/Rel8/Type/Composite.hs+9−8

@@ -20,6 +20,7 @@ where

2020

2121-- base

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

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

2324import Data.Kind ( Constraint, Type )

2425import Prelude

2526

@@ -30,13 +31,13 @@ import qualified Hasql.Decoders as Hasql

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

3132

3233-- rel8

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

34+import Rel8.Expr ( Expr )

3435import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )

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

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

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

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

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

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

39+import Rel8.Schema.Result ( Result )

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

4041import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )

4142import Rel8.Table.Eq ( EqTable )

4243import Rel8.Table.HKD ( HKD, HKDable )

@@ -112,8 +113,8 @@ compose = castExpr . fromPrimExpr . encoder . toColumns

112113decompose :: forall a. DBComposite a => Expr a -> HKD a Expr

113114decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->

114115 case hfield names field of

115− N (Name name) -> case hfield hspecs field of

116− SSpec {} -> E $ fromPrimExpr $ Opaleye.CompositeExpr a name

116+ Name name -> case hfield hspecs field of

117+ Spec {} -> fromPrimExpr $ Opaleye.CompositeExpr a name

117118 where

118119 names = toColumns (compositeFields @a)

119120

@@ -121,7 +122,7 @@ decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->

121122decoder :: HTable t => Hasql.Composite (t Result)

122123decoder = unwrapApplicative $ htabulateA \field ->

123124 case hfield hspecs field of

124− SSpec {nullity, info} -> WrapApplicative $ R <$>

125+ Spec {nullity, info} -> WrapApplicative $ Identity <$>

125126 case nullity of

126127 Null -> Hasql.field $ Hasql.nullable $ decode info

127128 NotNull -> Hasql.field $ Hasql.nonNullable $ decode info

@@ -131,4 +132,4 @@ encoder :: HTable t => t Expr -> Opaleye.PrimExpr

131132encoder a = Opaleye.FunExpr "ROW" exprs

132133 where

133134 exprs = getConst $ htabulateA \field -> case hfield a field of

134− E (toPrimExpr -> expr) -> Const [expr]

135+ expr -> Const [toPrimExpr expr]