9fd885f · rel8 · git.iko.soy

git.iko.soy/rel8

Include both Apply and "Legacy" variants of aggregateADT

commit9fd885fc3f0bf8cf393cea9131d2d2ffd1b87858 authorShane O'Brien <shane.obrien@circuithub.com> dateTue 4 May 2021, 19:49 (6 years ago) parent845516a

4 files changed+100−22

compare with master

unifiedsplit

src/Rel8/FCF.hs+9−1 src/Rel8/Generic/Construction/ADT.hs+11−5 src/Rel8/Generic/Construction/Record.hs+10−2 src/Rel8/Table/ADT.hs+70−14

src/Rel8/FCF.hs+9−1

@@ -3,7 +3,11 @@

33{-# language StandaloneKindSignatures #-}

44{-# language TypeFamilies #-}

6−module Rel8.FCF ( Exp, Eval ) where

6+module Rel8.FCF

7+ ( Exp, Eval

8+ , Compose

9+ )

10+where

711

812-- base

913import Data.Kind ( Type )

@@ -16,3 +20,7 @@ type Exp e = e -> Type

1620

1721type Eval :: Exp e -> e

1822type family Eval a

23+

24+

25+data Compose :: (Type -> Type) -> (Type -> Exp Type) -> Type -> Exp Type

26+type instance Eval (Compose f g a) = f (Eval (g a))

src/Rel8/Generic/Construction/ADT.hs+11−5

@@ -16,12 +16,13 @@ module Rel8.Generic.Construction.ADT

1616 ( GConstructableADT

1717 , GBuildADT, gbuildADT, gunbuildADT

1818 , GConstructADT, gconstructADT, gdeconstructADT

19− , GFields, CorepFields, gftabulate, gfindex

19+ , GFields, CorepFields, gftabulate, gfindex, gftraverse

2020 , GConstructors, CorepConstructors, gctabulate, gcindex

2121 )

2222where

2323

2424-- base

25+import Control.Applicative ( liftA2 )

2526import Data.Bifunctor ( first )

2627import Data.Functor.Identity ( runIdentity )

2728import Data.Kind ( Constraint, Type )

@@ -36,10 +37,10 @@ import GHC.TypeLits ( KnownSymbol, symbolVal )

3637import Prelude hiding ( null )

3738

3839-- rel8

39−import Rel8.FCF ( Exp )

40+import Rel8.FCF ( Compose, Exp )

4041import Rel8.Generic.Construction.Record

4142 ( GConstruct, GConstructable, gconstruct, gdeconstruct

42− , GFields, Corep, gtabulate, gindex

43+ , GFields, Corep, gtabulate, gindex, gtraverse

4344 , FromColumns, ToColumns

4445 )

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

@@ -137,23 +138,28 @@ type CorepFields :: (Type -> Exp Type) -> (Type -> Type) -> Constraint

137138class CorepFields f rep where

138139 gftabulate :: (GFieldsADT f rep -> a) -> GBuildADT f rep a

139140 gfindex :: GBuildADT f rep a -> GFieldsADT f rep -> a

141+ gftraverse :: Applicative m

142+ => (forall a. g a -> m a)

143+ -> GFieldsADT (Compose g f) rep -> m (GFieldsADT f rep)

140144

141145

142146instance CorepFields f rep => CorepFields f (M1 D meta rep) where

143147 gftabulate = gftabulate @f @rep

144148 gfindex = gfindex @f @rep

149+ gftraverse = gftraverse @f @rep

145150

146151

147−instance (CorepFields f a, CorepFields f b) => CorepFields f (a :+: b)

148− where

152+instance (CorepFields f a, CorepFields f b) => CorepFields f (a :+: b) where

149153 gftabulate f =

150154 gftabulate @f @a \a -> gftabulate @f @b \b -> f (a, b)

151155 gfindex f (a, b) = gfindex @f @b (gfindex @f @a f a) b

156+ gftraverse f (a, b) = liftA2 (,) (gftraverse @f @a f a) (gftraverse @f @b f b)

152157

153158

154159instance Corep f rep => CorepFields f (M1 C meta rep) where

155160 gftabulate = gtabulate @f @rep

156161 gfindex = gindex @f @rep

162+ gftraverse = gtraverse @f @rep

157163

158164

159165type GConstructableADT

src/Rel8/Generic/Construction/Record.hs+10−2

@@ -13,12 +13,13 @@

1313

1414module Rel8.Generic.Construction.Record

1515 ( GConstruct, GConstructable, gconstruct, gdeconstruct

16− , GFields, Corep, gtabulate, gindex

16+ , GFields, Corep, gtabulate, gindex, gtraverse

1717 , FromColumns, ToColumns

1818 )

1919where

2020

2121-- base

22+import Control.Applicative ( liftA2 )

2223import Data.Kind ( Constraint, Type )

2324import Data.Proxy ( Proxy( Proxy ) )

2425import GHC.Generics

@@ -29,7 +30,7 @@ import GHC.TypeLits ( KnownSymbol )

2930import Prelude

3031

3132-- rel8

32−import Rel8.FCF ( Eval, Exp )

33+import Rel8.FCF ( Compose, Eval, Exp )

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

3435import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )

3536import Rel8.Schema.HTable ( HTable )

@@ -78,11 +79,15 @@ type Corep :: (Type -> Exp Type) -> (Type -> Type) -> Constraint

7879class Corep f rep where

7980 gtabulate :: (GFields f rep -> a) -> GConstruct f rep a

8081 gindex :: GConstruct f rep a -> GFields f rep -> a

82+ gtraverse :: Applicative m

83+ => (forall a. g a -> m a)

84+ -> GFields (Compose g f) rep -> m (GFields f rep)

8185

8286

8387instance Corep f rep => Corep f (M1 i meta rep) where

8488 gtabulate = gtabulate @f @rep

8589 gindex = gindex @f @rep

90+ gtraverse = gtraverse @f @rep

8691

8792

8893instance (Corep f a, Corep f b) =>

@@ -90,16 +95,19 @@ instance (Corep f a, Corep f b) =>

9095 where

9196 gtabulate f = gtabulate @f @a \a -> gtabulate @f @b \b -> f (a, b)

9297 gindex f (a, b) = gindex @f @b (gindex @f @a f a) b

98+ gtraverse f (a, b) = liftA2 (,) (gtraverse @f @a f a) (gtraverse @f @b f b)

9399

94100

95101instance Corep f U1 where

96102 gtabulate = ($ ())

97103 gindex = const

104+ gtraverse = const pure

98105

99106

100107instance Corep f (K1 i a) where

101108 gtabulate = id

102109 gindex = id

110+ gtraverse = id

103111

104112

105113type GConstructable

src/Rel8/Table/ADT.hs+70−14

@@ -21,6 +21,7 @@ module Rel8.Table.ADT

2121 , InsertADT, insertADT

2222 , NameADT, nameADT

2323 , AggregateADT, aggregateADT

24+ , AggregateADT', aggregateADT'

2425 )

2526where

2627

@@ -32,19 +33,19 @@ import Data.Type.Equality ( (:~:)( Refl ) )

3233import Prelude

3334

3435-- rel8

35−import Rel8.Aggregate ( Col( Aggregation ), Aggregate, mapInputs )

36+import Rel8.Aggregate ( Col( Aggregation ), Aggregate )

3637import Rel8.Expr ( Col( DB ), Expr )

3738import Rel8.Expr.Aggregate ( groupByExpr )

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

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

40−import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

4141import Rel8.Expr.Serialize ( litExpr )

42+import Rel8.FCF ( Compose )

4243import Rel8.Generic.Construction.ADT

4344 ( GConstructableADT

4445 , GBuildADT, gbuildADT, gunbuildADT

4546 , GConstructADT, gconstructADT, gdeconstructADT

4647 , CorepConstructors, GConstructors, gcindex, gctabulate

47− , CorepFields, GFields, gfindex, gftabulate

48+ , CorepFields, gfindex, gftabulate, gftraverse

4849 )

4950import Rel8.Generic.Rel8able

5051 ( Rel8able, Algebra

@@ -55,7 +56,6 @@ import Rel8.Generic.Rel8able

5556import qualified Rel8.Generic.Table.ADT as G

5657import qualified Rel8.Kind.Algebra as K

5758import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )

58−import Rel8.Schema.Context ( Col )

5959import Rel8.Schema.Context.Nullify ( runTag )

6060import Rel8.Schema.HTable ( HTable )

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

@@ -73,6 +73,9 @@ import Rel8.Table

7373import Rel8.Table.Bool ( case_ )

7474import Rel8.Type.Tag ( Tag )

7575

76+-- semigroupoids

77+import Data.Functor.Apply ( Apply, MaybeApply( MaybeApply ), liftF2 )

78+

7679

7780type ADT :: K.Rel8able -> K.Rel8able

7881newtype ADT t context = ADT (GColumnsADT t (Col context))

@@ -100,6 +103,7 @@ type ConstructableADT :: K.Rel8able -> Constraint

100103class

101104 ( CorepConstructors TUnreify (GRep t (Reify Expr))

102105 , CorepConstructors TUnreify (GRep t (Reify Insert))

106+ , CorepFields (Compose Aggregate TUnreify) (GRep t (Reify Expr))

103107 , CorepFields TUnreify (GRep t (Reify Aggregate))

104108 , CorepFields TUnreify (GRep t (Reify Expr))

105109 , CorepFields TUnreify (GRep t (Reify Name))

@@ -119,6 +123,7 @@ class

119123instance

120124 ( CorepConstructors TUnreify (GRep t (Reify Expr))

121125 , CorepConstructors TUnreify (GRep t (Reify Insert))

126+ , CorepFields (Compose Aggregate TUnreify) (GRep t (Reify Expr))

122127 , CorepFields TUnreify (GRep t (Reify Aggregate))

123128 , CorepFields TUnreify (GRep t (Reify Expr))

124129 , CorepFields TUnreify (GRep t (Reify Name))

@@ -235,12 +240,63 @@ nameADT tag = gftabulate @TUnreify @(GRep t (Reify Name)) @(ADT t Name) $

235240type AggregateADT :: K.Rel8able -> Type

236241type AggregateADT t = forall r.

237242 GBuildADT TUnreify (GRep t (Reify Expr))

238− (GBuildADT TUnreify (GRep t (Reify Aggregate)) r -> r)

243+ (GBuildADT (Compose Aggregate TUnreify) (GRep t (Reify Expr)) r -> r)

239244

240245

241246aggregateADT :: forall t. ConstructableADT t

242− => AggregateADT t -> ADT t Expr -> ADT t Aggregate

247+ => AggregateADT t -> ADT t Expr -> Aggregate (ADT t Expr)

243248aggregateADT builder (ADT columns) = f exprs $

249+ liftF1½

250+ (\tag' ->

251+ ADT .

252+ hunreify .

253+ gbuildADT

254+ @(TTable (Reify Expr))

255+ @TColumns

256+ @TUnreify

257+ @(Col (Reify Expr))

258+ @(GRep t (Reify Expr))

259+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

260+ (\tag'' SSpec {nullity} (Reify (DB a)) ->

261+ Reify $ DB $ runTag nullity (tag ==. litExpr tag'') a)

262+ (HType (Reify (DB tag'))))

263+ (groupByExpr tag) .

264+ gftraverse @TUnreify @(GRep t (Reify Expr)) @_ @Aggregate (MaybeApply . Left)

265+ where

266+ f e =

267+ gfindex

268+ @TUnreify

269+ @(GRep t (Reify Expr))

270+ @(GBuildADT (Compose Aggregate TUnreify) (GRep t (Reify Expr)) (Aggregate (ADT t Expr)) -> Aggregate (ADT t Expr))

271+ (builder @(Aggregate (ADT t Expr)))

272+ e .

273+ gftabulate

274+ @(Compose Aggregate TUnreify)

275+ @(GRep t (Reify Expr))

276+ @(Aggregate (ADT t Expr))

277+ (HType (Reify (DB tag)), exprs) =

278+ gunbuildADT

279+ @(TTable (Reify Expr))

280+ @TColumns

281+ @TUnreify

282+ @(Col (Reify Expr))

283+ @(GRep t (Reify Expr))

284+ (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)

285+ (\SSpec {nullity} -> case nullity of

286+ Null -> id

287+ NotNull -> \(Reify (DB a)) -> Reify (DB (unsafeUnnullify a)))

288+ (hreify columns)

289+

290+

291+type AggregateADT' :: K.Rel8able -> Type

292+type AggregateADT' t = forall r.

293+ GBuildADT TUnreify (GRep t (Reify Expr))

294+ (GBuildADT TUnreify (GRep t (Reify Aggregate)) r -> r)

295+

296+

297+aggregateADT' :: forall t. ConstructableADT t

298+ => AggregateADT' t -> ADT t Expr -> ADT t Aggregate

299+aggregateADT' builder (ADT columns) = f exprs $

244300 ADT .

245301 hunreify .

246302 gbuildADT

@@ -250,14 +306,8 @@ aggregateADT builder (ADT columns) = f exprs $

250306 @(Col (Reify Aggregate))

251307 @(GRep t (Reify Aggregate))

252308 (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

253− (\tag' SSpec {nullity} (Reify (Aggregation aggregate)) ->

254− let

255− condition = tag ==. litExpr tag'

256− in

257− Reify $

258− Aggregation $

259− mapInputs (toPrimExpr . runTag nullity condition . fromPrimExpr) $

260− runTag nullity condition <$> aggregate)

309+ (\tag' SSpec {nullity} (Reify (Aggregation a)) ->

310+ Reify $ Aggregation $ runTag nullity (tag ==. litExpr tag') <$> a)

261311 (HType (Reify (Aggregation (groupByExpr tag))))

262312 where

263313 f e =

@@ -283,3 +333,9 @@ aggregateADT builder (ADT columns) = f exprs $

283333 Null -> id

284334 NotNull -> \(Reify (DB a)) -> Reify (DB (unsafeUnnullify a)))

285335 (hreify columns)

336+

337+

338+liftF1½ :: Apply v => (a -> b -> c) -> v a -> MaybeApply v b -> v c

339+liftF1½ f a (MaybeApply eb) = case eb of

340+ Left b -> liftF2 f a b

341+ Right b -> fmap (`f` b) a