845516a · rel8 · git.iko.soy

git.iko.soy/rel8

on master help sign in

Add constructADT, deconstructADT, nameADT, insertADT, aggregateADT to Rel8.Table.ADT

845516aShane O'Brien6 years ago

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

compare with master

unifiedsplit

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

13{-# language UndecidableInstances #-}

15module Rel8.Generic.Construction.ADT

16− ( GConstructable

16+ ( GConstructableADT

17 , GBuildADT, gbuildADT, gunbuildADT

18 , GConstructADT, gconstructADT, gdeconstructADT

19 , GFields, CorepFields, gftabulate, gfindex

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

171

172 gunbuildADT :: ()

173 => FromColumns _Table _Columns f context

174− -> (Tag -> Unnullifier context)

174+ -> Unnullifier context

175 -> GColumnsADT _Columns rep context

176 -> (HType Tag context, GFieldsADT f rep)

177

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

184

185 gdeconstructADT :: ()

186 => FromColumns _Table _Columns f context

187− -> (Tag -> Unnullifier context)

187+ -> Unnullifier context

188 -> GConstructors f rep r

189 -> GColumnsADT _Columns rep context

190 -> (HType Tag context, NonEmpty (Tag, r))

@@ -229,7 +229,7 @@ class GConstructableADT' _Table _Columns f context htable rep where

229

230 gunbuildADT' :: ()

231 => FromColumns _Table _Columns f context

232− -> (Tag -> Unnullifier context)

232+ -> Unnullifier context

233 -> GColumnsADT' _Columns htable rep context

234 -> (htable context, GFieldsADT f rep)

235

@@ -242,7 +242,7 @@ class GConstructableADT' _Table _Columns f context htable rep where

242

243 gdeconstructADT' :: ()

244 => FromColumns _Table _Columns f context

245− -> (Tag -> Unnullifier context)

245+ -> Unnullifier context

246 -> GConstructors f rep r

247 -> GColumnsADT' _Columns htable rep context

248 -> (htable context, NonEmpty (Tag, r))

@@ -324,12 +324,10 @@ instance {-# OVERLAPPABLE #-}

324 ( htable

325 , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $

326 runIdentity $

327− hunnullify (\spec -> pure . unnullifier tag spec) $

327+ hunnullify (\spec -> pure . unnullifier spec) $

328 hunlabel hunlabeler

329 a

330 )

331− where

332− tag = Tag $ pack $ symbolVal (Proxy @label)

333

331

334 gconstructADT' toColumns _ nullifier mk =

332 gconstructADT' toColumns _ nullifier mk =

335 HProduct htable .

333 HProduct htable .

@@ -347,7 +345,7 @@ instance {-# OVERLAPPABLE #-}

347 where

345 where

348 a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $

346 a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $

349 runIdentity $

347 runIdentity $

350− hunnullify (\spec -> pure . unnullifier tag spec) $

348+ hunnullify (\spec -> pure . unnullifier spec) $

351 hunlabel hunlabeler

349 hunlabel hunlabeler

352 columns

350 columns

353 tag = Tag $ pack $ symbolVal (Proxy @label)

351 tag = Tag $ pack $ symbolVal (Proxy @label)

src/Rel8/Table/ADT.hs+241−2

@@ -1,27 +1,77 @@

1+{-# language AllowAmbiguousTypes #-}

2+{-# language BlockArguments #-}

1{-# language DataKinds #-}

3{-# language DataKinds #-}

4+{-# language FlexibleContexts #-}

5+{-# language FlexibleInstances #-}

6+{-# language LambdaCase #-}

7+{-# language NamedFieldPuns #-}

8+{-# language RankNTypes #-}

9+{-# language ScopedTypeVariables #-}

2{-# language StandaloneKindSignatures #-}

10{-# language StandaloneKindSignatures #-}

11+{-# language TypeApplications #-}

3{-# language TypeFamilies #-}

12{-# language TypeFamilies #-}

4{-# language UndecidableInstances #-}

13{-# language UndecidableInstances #-}

14+{-# language ViewPatterns #-}

6module Rel8.Table.ADT

16module Rel8.Table.ADT

7 ( ADT( ADT )

17 ( ADT( ADT )

18+ , ConstructableADT

19+ , ConstructADT, constructADT

20+ , DeconstructADT, deconstructADT

21+ , InsertADT, insertADT

22+ , NameADT, nameADT

23+ , AggregateADT, aggregateADT

8 )

24 )

9where

25where

11-- base

27-- base

28+import Data.Bifunctor ( first )

29+import Data.Kind ( Constraint, Type )

30+import Data.List.NonEmpty ( NonEmpty( (:|) ) )

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

12−import Prelude ()

32+import Prelude

14-- rel8

34-- rel8

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

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

37+import Rel8.Expr.Aggregate ( groupByExpr )

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

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

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

41+import Rel8.Expr.Serialize ( litExpr )

42+import Rel8.Generic.Construction.ADT

43+ ( GConstructableADT

44+ , GBuildADT, gbuildADT, gunbuildADT

45+ , GConstructADT, gconstructADT, gdeconstructADT

46+ , CorepConstructors, GConstructors, gcindex, gctabulate

47+ , CorepFields, GFields, gfindex, gftabulate

48+ )

15import Rel8.Generic.Rel8able

49import Rel8.Generic.Rel8able

16 ( Rel8able, Algebra

50 ( Rel8able, Algebra

17 , GRep, GColumns, GContext, gfromColumns, gtoColumns

51 , GRep, GColumns, GContext, gfromColumns, gtoColumns

18 , GColumnsADT, gfromColumnsADT, gtoColumnsADT

52 , GColumnsADT, gfromColumnsADT, gtoColumnsADT

19 , greify, gunreify

53 , greify, gunreify

20 )

54 )

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

21import qualified Rel8.Kind.Algebra as K

56import qualified Rel8.Kind.Algebra as K

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

22import Rel8.Schema.Context ( Col )

58import Rel8.Schema.Context ( Col )

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

60+import Rel8.Schema.HTable ( HTable )

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

62+import Rel8.Schema.Insert ( Col( OptionalInsert, RequiredInsert ), Insert )

23import qualified Rel8.Schema.Kind as K

63import qualified Rel8.Schema.Kind as K

64+import Rel8.Schema.Name ( Col( NameCol ), Name( Name ) )

65+import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

66+import Rel8.Schema.Spec ( SSpec( SSpec, necessity, nullity, info ) )

24−import Rel8.Schema.Reify ( hreify, hunreify )

67+import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )

68+import Rel8.Schema.Result ( Result )

69+import Rel8.Table

70+ ( TTable, TColumns, TUnreify

71+ , Table, fromColumns, toColumns, reify, unreify

72+ )

73+import Rel8.Table.Bool ( case_ )

74+import Rel8.Type.Tag ( Tag )

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

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

@@ -44,3 +94,192 @@ instance Rel8able t => Rel8able (ADT t) where

45 greify (ADT a) = ADT (hreify a)

95 greify (ADT a) = ADT (hreify a)

46 gunreify (ADT a) = ADT (hunreify a)

96 gunreify (ADT a) = ADT (hunreify a)

97+

98+

99+type ConstructableADT :: K.Rel8able -> Constraint

100+class

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

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

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

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

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

106+ , G.GColumnsADT TColumns (GRep t (Reify Aggregate)) ~ GColumnsADT t

107+ , G.GColumnsADT TColumns (GRep t (Reify Expr)) ~ GColumnsADT t

108+ , G.GColumnsADT TColumns (GRep t (Reify Insert)) ~ GColumnsADT t

109+ , G.GColumnsADT TColumns (GRep t (Reify Name)) ~ GColumnsADT t

110+ , Functor (GConstructors TUnreify (GRep t (Reify Expr)))

111+ , Functor (GConstructors TUnreify (GRep t (Reify Insert)))

112+ , HTable (G.GColumnsADT TColumns (GRep t (Reify Result)))

113+ , GConstructableADT (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (GRep t (Reify Aggregate))

114+ , GConstructableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (GRep t (Reify Expr))

115+ , GConstructableADT (TTable (Reify Insert)) TColumns TUnreify (Col (Reify Insert)) (GRep t (Reify Insert))

116+ , GConstructableADT (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (GRep t (Reify Name))

117+ )

118+ => ConstructableADT t

119+instance

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

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

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

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

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

125+ , G.GColumnsADT TColumns (GRep t (Reify Aggregate)) ~ GColumnsADT t

126+ , G.GColumnsADT TColumns (GRep t (Reify Expr)) ~ GColumnsADT t

127+ , G.GColumnsADT TColumns (GRep t (Reify Insert)) ~ GColumnsADT t

128+ , G.GColumnsADT TColumns (GRep t (Reify Name)) ~ GColumnsADT t

129+ , Functor (GConstructors TUnreify (GRep t (Reify Expr)))

130+ , Functor (GConstructors TUnreify (GRep t (Reify Insert)))

131+ , HTable (G.GColumnsADT TColumns (GRep t (Reify Result)))

132+ , GConstructableADT (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (GRep t (Reify Aggregate))

133+ , GConstructableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (GRep t (Reify Expr))

134+ , GConstructableADT (TTable (Reify Insert)) TColumns TUnreify (Col (Reify Insert)) (GRep t (Reify Insert))

135+ , GConstructableADT (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (GRep t (Reify Name))

136+ )

137+ => ConstructableADT t

138+

139+

140+type ConstructADT :: K.Rel8able -> Type

141+type ConstructADT t = (forall r. GConstructADT TUnreify (GRep t (Reify Expr)) r r) -> ADT t Expr

142+

143+

144+constructADT :: forall t. ConstructableADT t => ConstructADT t

145+constructADT f =

146+ gcindex @TUnreify @(GRep t (Reify Expr)) @(ADT t Expr) (f @(ADT t Expr)) $

147+ fmap (ADT . hunreify) $

148+ gconstructADT

149+ @(TTable (Reify Expr))

150+ @TColumns

151+ @TUnreify

152+ @(Col (Reify Expr))

153+ @(GRep t (Reify Expr))

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

155+ (\SSpec {info} -> Reify (DB (snull info)))

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

157+ Null -> id

158+ NotNull -> \(Reify (DB a)) -> Reify (DB (nullify a)))

159+ (HType . Reify . DB . litExpr)

160+

161+

162+type DeconstructADT :: K.Rel8able -> Type -> Type

163+type DeconstructADT t r = GConstructADT TUnreify (GRep t (Reify Expr)) r (ADT t Expr -> r)

164+

165+

166+deconstructADT :: forall t r. (ConstructableADT t, Table Expr r)

167+ => DeconstructADT t r

168+deconstructADT =

169+ gctabulate @TUnreify @(GRep t (Reify Expr)) @r @(ADT t Expr -> r)

170+ \constructors (ADT columns) ->

171+ let

172+ (HType (Reify (DB tag)), cases) = gdeconstructADT

173+ @(TTable (Reify Expr))

174+ @TColumns

175+ @TUnreify

176+ @(Col (Reify Expr))

177+ @(GRep t (Reify Expr))

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

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

180+ Null -> id

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

182+ constructors

183+ (hreify columns)

184+ in

185+ case cases of

186+ ((_, r) :| (map (first ((tag ==.) . litExpr)) -> cases')) ->

187+ case_ cases' r

188+

189+

190+type InsertADT :: K.Rel8able -> Type

191+type InsertADT t = (forall r. GConstructADT TUnreify (GRep t (Reify Insert)) r r) -> ADT t Insert

192+

193+

194+insertADT :: forall t. ConstructableADT t => InsertADT t

195+insertADT f =

196+ gcindex @TUnreify @(GRep t (Reify Insert)) @(ADT t Insert) (f @(ADT t Insert)) $

197+ fmap (ADT . hunreify) $

198+ gconstructADT

199+ @(TTable (Reify Insert))

200+ @TColumns

201+ @TUnreify

202+ @(Col (Reify Insert))

203+ @(GRep t (Reify Insert))

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

205+ (\SSpec {necessity, info} -> Reify $ case necessity of

206+ SRequired -> RequiredInsert (snull info)

207+ SOptional -> OptionalInsert (Just (snull info)))

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

209+ Null -> id

210+ NotNull -> \case

211+ Reify (RequiredInsert a) -> Reify (RequiredInsert (nullify a))

212+ Reify (OptionalInsert a) -> Reify (OptionalInsert (nullify <$> a)))

213+ (HType . Reify . RequiredInsert . litExpr)

214+

215+

216+type NameADT :: K.Rel8able -> Type

217+type NameADT t = Name Tag -> GBuildADT TUnreify (GRep t (Reify Name)) (ADT t Name)

218+

219+

220+nameADT :: forall t. ConstructableADT t => NameADT t

221+nameADT tag = gftabulate @TUnreify @(GRep t (Reify Name)) @(ADT t Name) $

222+ ADT .

223+ hunreify .

224+ gbuildADT

225+ @(TTable (Reify Name))

226+ @TColumns

227+ @TUnreify

228+ @(Col (Reify Name))

229+ @(GRep t (Reify Name))

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

231+ (\_ _ (Reify (NameCol a)) -> Reify (NameCol a))

232+ (HType ((\(Name a) -> Reify (NameCol a)) tag))

233+

234+

235+type AggregateADT :: K.Rel8able -> Type

236+type AggregateADT t = forall r.

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

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

239+

240+

241+aggregateADT :: forall t. ConstructableADT t

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

243+aggregateADT builder (ADT columns) = f exprs $

244+ ADT .

245+ hunreify .

246+ gbuildADT

247+ @(TTable (Reify Aggregate))

248+ @TColumns

249+ @TUnreify

250+ @(Col (Reify Aggregate))

251+ @(GRep t (Reify Aggregate))

252+ (\(_ :: 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)

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

262+ where

263+ f e =

264+ gfindex

265+ @TUnreify

266+ @(GRep t (Reify Expr))

267+ @(GBuildADT TUnreify (GRep t (Reify Aggregate)) (ADT t Aggregate) -> ADT t Aggregate)

268+ (builder @(ADT t Aggregate))

269+ e .

270+ gftabulate

271+ @TUnreify

272+ @(GRep t (Reify Aggregate))

273+ @(ADT t Aggregate)

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

275+ gunbuildADT

276+ @(TTable (Reify Expr))

277+ @TColumns

278+ @TUnreify

279+ @(Col (Reify Expr))

280+ @(GRep t (Reify Expr))

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

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

283+ Null -> id

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

285+ (hreify columns)