git.iko.soy/rel8
on master help sign in
Add generic default for Table class, and share its implementation with Rel8able
6ca25e5Shane O'Brien
src/Rel8/Schema/Generic.hs+9−71
compare with master
unifiedsplit
@@ -1,17 +1,10 @@
1−{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
1{-# language DataKinds #-}
3−{-# language DisambiguateRecordFields #-}
4{-# language DefaultSignatures #-}
2{-# language DefaultSignatures #-}
5{-# language FlexibleContexts #-}
3{-# language FlexibleContexts #-}
6{-# language FlexibleInstances #-}
4{-# language FlexibleInstances #-}
7−{-# language GADTs #-}
8{-# language MultiParamTypeClasses #-}
5{-# language MultiParamTypeClasses #-}
9−{-# language QuantifiedConstraints #-}
10−{-# language ScopedTypeVariables #-}
11{-# language StandaloneKindSignatures #-}
6{-# language StandaloneKindSignatures #-}
12−{-# language TypeApplications #-}
13{-# language TypeFamilies #-}
7{-# language TypeFamilies #-}
14−{-# language TypeOperators #-}
15{-# language UndecidableInstances #-}
8{-# language UndecidableInstances #-}
16
9
17{-# options_ghc -fno-warn-orphans #-}
10{-# options_ghc -fno-warn-orphans #-}
@@ -24,28 +17,20 @@ where
24
17
25-- base
18-- base
26import Data.Kind ( Constraint, Type )
19import Data.Kind ( Constraint, Type )
27−import GHC.Generics
20+import GHC.Generics ( Generic, Rep, from, to )
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 )
35import Prelude
21import Prelude
36import Unsafe.Coerce ( unsafeCoerce )
22import Unsafe.Coerce ( unsafeCoerce )
37
23
38-- rel8
24-- rel8
39import Rel8.Schema.Context ( Col )
25import Rel8.Schema.Context ( Col )
40−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
26+import Rel8.Schema.Context.Label ( Labelable )
41import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify )
27import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify )
42import Rel8.Schema.HTable ( HTable )
28import Rel8.Schema.HTable ( HTable )
43−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
44−import Rel8.Schema.HTable.Pair ( HPair(..) )
45import qualified Rel8.Schema.Kind as K
29import qualified Rel8.Schema.Kind as K
46import Rel8.Schema.Name ( Name )
30import Rel8.Schema.Name ( Name )
47import Rel8.Table
31import Rel8.Table
48 ( Table, Columns, Context, fromColumns, toColumns
32 ( Table, Columns, Context, fromColumns, toColumns
33+ , GTable, GColumns, fromGColumns, toGColumns
49 )
34 )
50
35
51
36
@@ -116,72 +101,25 @@ class HTable (GRep t) => Rel8able t where
116 gtoColumns :: (Labelable context, Reifiable context)
101 gtoColumns :: (Labelable context, Reifiable context)
117 => t (Reify context) -> GRep t (Col (Reify context))
102 => t (Reify context) -> GRep t (Col (Reify context))
118
103
119− default gfromColumns :: forall context.
104+ default gfromColumns ::
120 ( Generic (t (Reify context))
105 ( Generic (t (Reify context))
121 , GColumns (Rep (t (Reify context))) ~ GRep t
106 , GColumns (Rep (t (Reify context))) ~ GRep t
122− , GRel8able context (Rep (t (Reify context)))
107+ , GTable (Reify context) (Rep (t (Reify context)))
123 ) => GRep t (Col (Reify context)) -> t (Reify context)
108 ) => GRep t (Col (Reify context)) -> t (Reify context)
124− gfromColumns = to . fromGColumns @_ @(Rep (t (Reify context)))
109+ gfromColumns = to . fromGColumns
125
110
126− default gtoColumns :: forall context.
111+ default gtoColumns ::
127 ( Generic (t (Reify context))
112 ( Generic (t (Reify context))
128 , GColumns (Rep (t (Reify context))) ~ GRep t
113 , GColumns (Rep (t (Reify context))) ~ GRep t
129− , GRel8able context (Rep (t (Reify context)))
114+ , GTable (Reify context) (Rep (t (Reify context)))
130 ) => t (Reify context) -> GRep t (Col (Reify context))
115 ) => t (Reify context) -> GRep t (Col (Reify context))
131− gtoColumns = toGColumns @_ @(Rep (t (Reify context))) . from
116+ gtoColumns = toGColumns . from
132
117
133
118
134type GRep :: K.Table -> K.HTable
119type GRep :: K.Table -> K.HTable
135type GRep t = GColumns (Rep (t (Reify Name)))
120type GRep t = GColumns (Rep (t (Reify Name)))
136
121
137
122
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−
185reify ::
123reify ::
186 (-- Rel8able t
124 (-- Rel8able t
187 --, forall necessity a. Coercible (Field context necessity a) (AField context necessity a) => Coercible (t context) (t (Reify context))
125 --, 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 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2+{-# language DefaultSignatures #-}
2{-# language DisambiguateRecordFields #-}
3{-# language DisambiguateRecordFields #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
5{-# language FlexibleInstances #-}
5{-# language FunctionalDependencies #-}
6{-# language FunctionalDependencies #-}
6{-# language LambdaCase #-}
7{-# language LambdaCase #-}
7{-# language NamedFieldPuns #-}
8{-# language NamedFieldPuns #-}
9+{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
10{-# language StandaloneKindSignatures #-}
11+{-# language TypeApplications #-}
9{-# language TypeFamilies #-}
12{-# language TypeFamilies #-}
10{-# language TypeOperators #-}
13{-# language TypeOperators #-}
11{-# language UndecidableInstances #-}
14{-# language UndecidableInstances #-}
@@ -14,6 +17,7 @@ module Rel8.Table
14 ( Table (Columns, Context)
17 ( Table (Columns, Context)
15 , toColumns, fromColumns
18 , toColumns, fromColumns
16 , Congruent
19 , Congruent
20+ , GTable, GColumns, GContext, fromGColumns, toGColumns
17 )
21 )
18where
22where
19
23
@@ -22,6 +26,13 @@ import Data.Functor ( ($>) )
22import Data.Functor.Identity ( Identity( Identity ) )
26import Data.Functor.Identity ( Identity( Identity ) )
23import Data.Kind ( Constraint, Type )
27import Data.Kind ( Constraint, Type )
24import Data.List.NonEmpty ( NonEmpty )
28import 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 )
25import Prelude hiding ( null )
36import Prelude hiding ( null )
26
37
27-- rel8
38-- rel8
@@ -76,6 +87,79 @@ class (HTable (Columns a), context ~ Context a) => Table context a | a -> contex
76 toColumns :: a -> Columns a (Col (Context a))
87 toColumns :: a -> Columns a (Col (Context a))
77 fromColumns :: Columns a (Col (Context a)) -> a
88 fromColumns :: Columns a (Col (Context a)) -> a
78
89
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+
79
163
80-- | Any 'HTable' is also a 'Table'.
164-- | Any 'HTable' is also a 'Table'.
81instance HTable t => Table context (t (Col context)) where
165instance HTable t => Table context (t (Col context)) where