9fd885f · rel8 · git.iko.soy

git.iko.soy/rel8

on master help sign in

Include both Apply and "Legacy" variants of aggregateADT

9fd885fShane O'Brien6 years ago

src/Rel8/FCF.hs+9−1

compare with master

unifiedsplit

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

3{-# language StandaloneKindSignatures #-}

4{-# language TypeFamilies #-}

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

6+module Rel8.FCF

7+ ( Exp, Eval

8+ , Compose

9+ )

10+where

8-- base

12-- base

9import Data.Kind ( Type )

13import Data.Kind ( Type )

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

17type Eval :: Exp e -> e

21type Eval :: Exp e -> e

18type family Eval a

22type 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

16 ( GConstructableADT

17 , GBuildADT, gbuildADT, gunbuildADT

18 , GConstructADT, gconstructADT, gdeconstructADT

19− , GFields, CorepFields, gftabulate, gfindex

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

20 , GConstructors, CorepConstructors, gctabulate, gcindex

21 )

22where

24-- base

25+import Control.Applicative ( liftA2 )

25import Data.Bifunctor ( first )

26import Data.Bifunctor ( first )

26import Data.Functor.Identity ( runIdentity )

27import Data.Functor.Identity ( runIdentity )

27import Data.Kind ( Constraint, Type )

28import Data.Kind ( Constraint, Type )

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

36import Prelude hiding ( null )

37import Prelude hiding ( null )

38-- rel8

39-- rel8

39−import Rel8.FCF ( Exp )

40+import Rel8.FCF ( Compose, Exp )

40import Rel8.Generic.Construction.Record

41import Rel8.Generic.Construction.Record

41 ( GConstruct, GConstructable, gconstruct, gdeconstruct

42 ( GConstruct, GConstructable, gconstruct, gdeconstruct

42− , GFields, Corep, gtabulate, gindex

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

43 , FromColumns, ToColumns

44 , FromColumns, ToColumns

44 )

45 )

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

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

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

137class CorepFields f rep where

138class CorepFields f rep where

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

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

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

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

140

144

141

145

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

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

143 gftabulate = gftabulate @f @rep

147 gftabulate = gftabulate @f @rep

144 gfindex = gfindex @f @rep

148 gfindex = gfindex @f @rep

149+ gftraverse = gftraverse @f @rep

145

150

146

151

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

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

148− where

149 gftabulate f =

153 gftabulate f =

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

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

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

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

152

157

153

158

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

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

155 gftabulate = gtabulate @f @rep

160 gftabulate = gtabulate @f @rep

156 gfindex = gindex @f @rep

161 gfindex = gindex @f @rep

162+ gftraverse = gtraverse @f @rep

157

163

158

164

159type GConstructableADT

165type GConstructableADT

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

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

14module Rel8.Generic.Construction.Record

15 ( GConstruct, GConstructable, gconstruct, gdeconstruct

16− , GFields, Corep, gtabulate, gindex

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

17 , FromColumns, ToColumns

18 )

19where

21-- base

22+import Control.Applicative ( liftA2 )

22import Data.Kind ( Constraint, Type )

23import Data.Kind ( Constraint, Type )

23import Data.Proxy ( Proxy( Proxy ) )

24import Data.Proxy ( Proxy( Proxy ) )

24import GHC.Generics

25import GHC.Generics

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

29import Prelude

30import Prelude

31-- rel8

32-- rel8

32−import Rel8.FCF ( Eval, Exp )

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

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

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

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

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

35import Rel8.Schema.HTable ( HTable )

36import Rel8.Schema.HTable ( HTable )

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

78class Corep f rep where

79class Corep f rep where

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

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

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

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

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

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

84 gtabulate = gtabulate @f @rep

88 gtabulate = gtabulate @f @rep

85 gindex = gindex @f @rep

89 gindex = gindex @f @rep

90+ gtraverse = gtraverse @f @rep

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

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

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

90 where

95 where

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

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

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

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

100

95instance Corep f U1 where

101instance Corep f U1 where

96 gtabulate = ($ ())

102 gtabulate = ($ ())

97 gindex = const

103 gindex = const

104+ gtraverse = const pure

105

106

100instance Corep f (K1 i a) where

107instance Corep f (K1 i a) where

101 gtabulate = id

108 gtabulate = id

102 gindex = id

109 gindex = id

110+ gtraverse = id

103

111

104

112

105type GConstructable

113type GConstructable

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

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

21 , InsertADT, insertADT

22 , NameADT, nameADT

23 , AggregateADT, aggregateADT

24+ , AggregateADT', aggregateADT'

24 )

25 )

25where

26where

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

32import Prelude

33import Prelude

34-- rel8

35-- rel8

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

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

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

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

37import Rel8.Expr.Aggregate ( groupByExpr )

38import Rel8.Expr.Aggregate ( groupByExpr )

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

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

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

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

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

41import Rel8.Expr.Serialize ( litExpr )

42+import Rel8.FCF ( Compose )

42import Rel8.Generic.Construction.ADT

43import Rel8.Generic.Construction.ADT

43 ( GConstructableADT

44 ( GConstructableADT

44 , GBuildADT, gbuildADT, gunbuildADT

45 , GBuildADT, gbuildADT, gunbuildADT

45 , GConstructADT, gconstructADT, gdeconstructADT

46 , GConstructADT, gconstructADT, gdeconstructADT

46 , CorepConstructors, GConstructors, gcindex, gctabulate

47 , CorepConstructors, GConstructors, gcindex, gctabulate

47− , CorepFields, GFields, gfindex, gftabulate

48+ , CorepFields, gfindex, gftabulate, gftraverse

48 )

49 )

49import Rel8.Generic.Rel8able

50import Rel8.Generic.Rel8able

50 ( Rel8able, Algebra

51 ( Rel8able, Algebra

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

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

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

56import qualified Rel8.Kind.Algebra as K

57import qualified Rel8.Kind.Algebra as K

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

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

58−import Rel8.Schema.Context ( Col )

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

60import Rel8.Schema.HTable ( HTable )

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

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

73import Rel8.Table.Bool ( case_ )

74import Rel8.Type.Tag ( Tag )

76+-- semigroupoids

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

78+

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

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

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

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

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

100class

103class

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

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

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

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

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

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

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

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

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

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

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

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

119instance

123instance

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

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

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

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

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

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

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

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

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

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

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

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

235type AggregateADT :: K.Rel8able -> Type

240type AggregateADT :: K.Rel8able -> Type

236type AggregateADT t = forall r.

241type AggregateADT t = forall r.

237 GBuildADT TUnreify (GRep t (Reify Expr))

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

239

244

240

245

241aggregateADT :: forall t. ConstructableADT t

246aggregateADT :: forall t. ConstructableADT t

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

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

243aggregateADT builder (ADT columns) = f exprs $

248aggregateADT 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 $

244 ADT .

300 ADT .

245 hunreify .

301 hunreify .

246 gbuildADT

302 gbuildADT

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

250 @(Col (Reify Aggregate))

306 @(Col (Reify Aggregate))

251 @(GRep t (Reify Aggregate))

307 @(GRep t (Reify Aggregate))

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

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

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

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

254− let

255− condition = tag ==. litExpr tag'

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

256− in

257− Reify $

258− Aggregation $

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

260− runTag nullity condition <$> aggregate)

261 (HType (Reify (Aggregation (groupByExpr tag))))

311 (HType (Reify (Aggregation (groupByExpr tag))))

262 where

312 where

263 f e =

313 f e =

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

283 Null -> id

333 Null -> id

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

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

285 (hreify columns)

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