6ca25e5 · rel8 · git.iko.soy

git.iko.soy/rel8

Add generic default for Table class, and share its implementation with Rel8able

commit6ca25e57dd566404195dc6f496cbbc7da4e45e2c authorShane O'Brien <shane.obrien@circuithub.com> dateFri 16 Apr 2021, 15:36 (6 years ago) parent47e7842

2 files changed+93−71

compare with master

unifiedsplit

src/Rel8/Schema/Generic.hs+9−71 src/Rel8/Table.hs+84

src/Rel8/Schema/Generic.hs+9−71

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

1−{-# language AllowAmbiguousTypes #-}

21{-# language DataKinds #-}

3−{-# language DisambiguateRecordFields #-}

42{-# language DefaultSignatures #-}

53{-# language FlexibleContexts #-}

64{-# language FlexibleInstances #-}

7−{-# language GADTs #-}

85{-# language MultiParamTypeClasses #-}

9−{-# language QuantifiedConstraints #-}

10−{-# language ScopedTypeVariables #-}

116{-# language StandaloneKindSignatures #-}

12−{-# language TypeApplications #-}

137{-# language TypeFamilies #-}

14−{-# language TypeOperators #-}

158{-# language UndecidableInstances #-}

169

1710{-# options_ghc -fno-warn-orphans #-}

@@ -24,28 +17,20 @@ where

2417

2518-- base

2619import Data.Kind ( Constraint, Type )

27−import GHC.Generics

28− ( Generic, Rep, from, to

29− , (:*:)( (:*:) ), K1( K1 ), M1( M1 )

30− , D, S

31− , Meta( MetaSel )

32− )

33−import qualified GHC.Generics as G ( C )

34−import GHC.TypeLits ( KnownSymbol )

20+import GHC.Generics ( Generic, Rep, from, to )

3521import Prelude

3622import Unsafe.Coerce ( unsafeCoerce )

3723

3824-- rel8

3925import Rel8.Schema.Context ( Col )

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

26+import Rel8.Schema.Context.Label ( Labelable )

4127import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify )

4228import Rel8.Schema.HTable ( HTable )

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

44−import Rel8.Schema.HTable.Pair ( HPair(..) )

4529import qualified Rel8.Schema.Kind as K

4630import Rel8.Schema.Name ( Name )

4731import Rel8.Table

4832 ( Table, Columns, Context, fromColumns, toColumns

33+ , GTable, GColumns, fromGColumns, toGColumns

4934 )

5035

5136

@@ -116,72 +101,25 @@ class HTable (GRep t) => Rel8able t where

116101 gtoColumns :: (Labelable context, Reifiable context)

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

118103

119− default gfromColumns :: forall context.

104+ default gfromColumns ::

120105 ( Generic (t (Reify context))

121106 , GColumns (Rep (t (Reify context))) ~ GRep t

122− , GRel8able context (Rep (t (Reify context)))

107+ , GTable (Reify context) (Rep (t (Reify context)))

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

124− gfromColumns = to . fromGColumns @_ @(Rep (t (Reify context)))

109+ gfromColumns = to . fromGColumns

125110

126− default gtoColumns :: forall context.

111+ default gtoColumns ::

127112 ( Generic (t (Reify context))

128113 , GColumns (Rep (t (Reify context))) ~ GRep t

129− , GRel8able context (Rep (t (Reify context)))

114+ , GTable (Reify context) (Rep (t (Reify context)))

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

131− gtoColumns = toGColumns @_ @(Rep (t (Reify context))) . from

116+ gtoColumns = toGColumns . from

132117

133118

134119type GRep :: K.Table -> K.HTable

135120type GRep t = GColumns (Rep (t (Reify Name)))

136121

137122

138−type GColumns :: (Type -> Type) -> K.HTable

139−type family GColumns rep where

140− GColumns (M1 D _ rep) = GColumns rep

141− GColumns (M1 G.C _ rep) = GColumns rep

142− GColumns (rep1 :*: rep2) = HPair (GColumns rep1) (GColumns rep2)

143− GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =

144− HLabel label (Columns a)

145−

146−

147−type GRel8able :: K.Context -> (Type -> Type) -> Constraint

148−class GRel8able context rep where

149− fromGColumns :: GColumns rep (Col (Reify context)) -> rep x

150− toGColumns :: rep x -> GColumns rep (Col (Reify context))

151−

152−

153−instance GRel8able context rep => GRel8able context (M1 D c rep) where

154− fromGColumns = M1 . fromGColumns @context @rep

155− toGColumns (M1 a) = toGColumns @context @rep a

156−

157−

158−instance GRel8able context rep => GRel8able context (M1 G.C c rep) where

159− fromGColumns = M1 . fromGColumns @context @rep

160− toGColumns (M1 a) = toGColumns @context @rep a

161−

162−

163−instance (GRel8able context rep1, GRel8able context rep2) =>

164− GRel8able context (rep1 :*: rep2)

165− where

166− fromGColumns (HPair a b) =

167− fromGColumns @context @rep1 a :*: fromGColumns @context @rep2 b

168− toGColumns (a :*: b) =

169− HPair (toGColumns @context @rep1 a) (toGColumns @context @rep2 b)

170−

171−

172−instance

173− ( Table (Reify context) a

174− , Labelable context

175− , KnownSymbol label

176− , GColumns (M1 S meta k1) ~ HLabel label (Columns a)

177− , meta ~ 'MetaSel ('Just label) _su _ss _ds

178− , k1 ~ K1 i a

179− ) => GRel8able context (M1 S meta k1)

180− where

181− fromGColumns = M1 . K1 . fromColumns . hunlabel unlabeler

182− toGColumns (M1 (K1 a)) = hlabel labeler (toColumns a)

183−

184−

185123reify ::

186124 (-- Rel8able t

187125 --, forall necessity a. Coercible (Field context necessity a) (AField context necessity a) => Coercible (t context) (t (Reify context))

src/Rel8/Table.hs+84

@@ -1,11 +1,14 @@

11{-# language DataKinds #-}

2+{-# language DefaultSignatures #-}

23{-# language DisambiguateRecordFields #-}

34{-# language FlexibleContexts #-}

45{-# language FlexibleInstances #-}

56{-# language FunctionalDependencies #-}

67{-# language LambdaCase #-}

78{-# language NamedFieldPuns #-}

9+{-# language ScopedTypeVariables #-}

810{-# language StandaloneKindSignatures #-}

11+{-# language TypeApplications #-}

912{-# language TypeFamilies #-}

1013{-# language TypeOperators #-}

1114{-# language UndecidableInstances #-}

@@ -14,6 +17,7 @@ module Rel8.Table

1417 ( Table (Columns, Context)

1518 , toColumns, fromColumns

1619 , Congruent

20+ , GTable, GColumns, GContext, fromGColumns, toGColumns

1721 )

1822where

1923

@@ -22,6 +26,13 @@ import Data.Functor ( ($>) )

2226import Data.Functor.Identity ( Identity( Identity ) )

2327import Data.Kind ( Constraint, Type )

2428import Data.List.NonEmpty ( NonEmpty )

29+import GHC.Generics

30+ ( Generic, Rep, from, to

31+ , (:*:)( (:*:) ), K1( K1 ), M1( M1 )

32+ , C, D, S

33+ , Meta( MetaSel )

34+ )

35+import GHC.TypeLits ( KnownSymbol )

2536import Prelude hiding ( null )

2637

2738-- rel8

@@ -76,6 +87,79 @@ class (HTable (Columns a), context ~ Context a) => Table context a | a -> contex

7687 toColumns :: a -> Columns a (Col (Context a))

7788 fromColumns :: Columns a (Col (Context a)) -> a

7889

90+ type Columns a = GColumns (Rep a)

91+ type Context a = GContext (Rep a)

92+

93+ default toColumns ::

94+ ( Generic a, GTable (GContext (Rep a)) (Rep a)

95+ , Columns a ~ GColumns (Rep a)

96+ , Context a ~ GContext (Rep a)

97+ )

98+ => a -> Columns a (Col (Context a))

99+ toColumns = toGColumns . from

100+

101+ default fromColumns ::

102+ ( Generic a, GTable (GContext (Rep a)) (Rep a)

103+ , Columns a ~ GColumns (Rep a)

104+ , Context a ~ GContext (Rep a)

105+ )

106+ => Columns a (Col (Context a)) -> a

107+ fromColumns = to . fromGColumns

108+

109+

110+type GColumns :: (Type -> Type) -> K.HTable

111+type family GColumns rep where

112+ GColumns (M1 D _ rep) = GColumns rep

113+ GColumns (M1 C _ rep) = GColumns rep

114+ GColumns (rep1 :*: rep2) = HPair (GColumns rep1) (GColumns rep2)

115+ GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =

116+ HLabel label (Columns a)

117+

118+

119+type GContext :: (Type -> Type) -> K.Context

120+type family GContext rep where

121+ GContext (M1 _ _ rep) = GContext rep

122+ GContext (rep1 :*: _rep2) = GContext rep1

123+ GContext (K1 _ a) = Context a

124+

125+

126+type GTable :: K.Context -> (Type -> Type) -> Constraint

127+class context ~ GContext rep => GTable context rep | rep -> context where

128+ fromGColumns :: GColumns rep (Col context) -> rep x

129+ toGColumns :: rep x -> GColumns rep (Col context)

130+

131+

132+instance GTable context rep => GTable context (M1 D c rep) where

133+ fromGColumns = M1 . fromGColumns @context @rep

134+ toGColumns (M1 a) = toGColumns @context @rep a

135+

136+

137+instance GTable context rep => GTable context (M1 C c rep) where

138+ fromGColumns = M1 . fromGColumns @context @rep

139+ toGColumns (M1 a) = toGColumns @context @rep a

140+

141+

142+instance (GTable context rep1, GTable context rep2) =>

143+ GTable context (rep1 :*: rep2)

144+ where

145+ fromGColumns (HPair a b) =

146+ fromGColumns @context @rep1 a :*: fromGColumns @context @rep2 b

147+ toGColumns (a :*: b) =

148+ HPair (toGColumns @context @rep1 a) (toGColumns @context @rep2 b)

149+

150+

151+instance

152+ ( Table context a

153+ , Labelable context

154+ , KnownSymbol label

155+ , GColumns (M1 S meta k1) ~ HLabel label (Columns a)

156+ , meta ~ 'MetaSel ('Just label) _su _ss _ds

157+ , k1 ~ K1 i a

158+ ) => GTable context (M1 S meta k1)

159+ where

160+ fromGColumns = M1 . K1 . fromColumns . hunlabel unlabeler

161+ toGColumns (M1 (K1 a)) = hlabel labeler (toColumns a)

162+

79163

80164-- | Any 'HTable' is also a 'Table'.

81165instance HTable t => Table context (t (Col context)) where