git.iko.soy/rel8
on master help sign in
Allow generic deriving of Table instances for non-record types
6d3959eShane O'Brien
rel8.cabal+2
compare with master
unifiedsplit
@@ -66,6 +66,8 @@ library
66 Rel8.Kind.Labels
66 Rel8.Kind.Labels
67 Rel8.Kind.Necessity
67 Rel8.Kind.Necessity
68
68
69+ Rel8.Generic.Record
70+
69 Rel8.Order
71 Rel8.Order
70
72
71 Rel8.Query
73 Rel8.Query
src/Rel8/Generic/Record.hsnew file+148
@@ -0,0 +1,148 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language PolyKinds #-}
6+{-# language ScopedTypeVariables #-}
7+{-# language StandaloneKindSignatures #-}
8+{-# language TypeApplications #-}
9+{-# language TypeFamilies #-}
10+{-# language TypeOperators #-}
11+{-# language UndecidableInstances #-}
12+
13+module Rel8.Generic.Record
14+ ( Record(..)
15+ )
16+where
17+
18+-- base
19+import Data.Kind ( Constraint, Type )
20+import GHC.Generics
21+import GHC.TypeLits
22+import Prelude hiding ( Show )
23+
24+
25+type Recordize :: (Type -> Type) -> Type -> Type
26+type family Recordize rep where
27+ Recordize (M1 D meta rep) = M1 D meta (Recordize rep)
28+ Recordize (l :+: r) = Recordize l :+: Recordize r
29+ Recordize (M1 C ('MetaCons name fixity 'False) rep) =
30+ M1 C ('MetaCons name fixity 'True) (Snd (Count 0 rep))
31+ Recordize rep = rep
32+
33+
34+type Count :: Nat -> (Type -> Type) -> (Nat, Type -> Type)
35+type family Count n rep where
36+ Count n (M1 S ('MetaSel _selector su ss ds) rep) =
37+ '(n + 1, M1 S ('MetaSel ('Just (Show (n + 1))) su ss ds) rep)
38+ Count n (a :*: b) = CountHelper1 (Count n a) b
39+ Count n rep = '(n, rep)
40+
41+
42+type CountHelper1 :: (Nat, Type -> Type) -> (Type -> Type) -> (Nat, Type -> Type)
43+type family CountHelper1 tuple b where
44+ CountHelper1 '(n, a) b = CountHelper2 a (Count n b)
45+
46+
47+type CountHelper2 :: (Type -> Type) -> (Nat, Type -> Type) -> (Nat, Type -> Type)
48+type family CountHelper2 a tuple where
49+ CountHelper2 a '(n, b) = '(n, a :*: b)
50+
51+
52+type Show :: Nat -> Symbol
53+type Show n =
54+ AppendSymbol "_" (AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10)))
55+
56+
57+type Show' :: Nat -> Symbol
58+type family Show' n where
59+ Show' 0 = ""
60+ Show' n = AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10))
61+
62+
63+type ShowDigit :: Nat -> Symbol
64+type family ShowDigit n where
65+ ShowDigit 0 = "0"
66+ ShowDigit 1 = "1"
67+ ShowDigit 2 = "2"
68+ ShowDigit 3 = "3"
69+ ShowDigit 4 = "4"
70+ ShowDigit 5 = "5"
71+ ShowDigit 6 = "6"
72+ ShowDigit 7 = "7"
73+ ShowDigit 8 = "8"
74+ ShowDigit 9 = "9"
75+
76+
77+type Snd :: (a, b) -> b
78+type family Snd tuple where
79+ Snd '(_a, b) = b
80+
81+
82+type Recordizable :: (Type -> Type) -> Constraint
83+class Recordizable rep where
84+ recordize :: rep x -> Recordize rep x
85+ unrecordize :: Recordize rep x -> rep x
86+
87+
88+instance Recordizable rep => Recordizable (M1 D meta rep) where
89+ recordize (M1 a) = M1 (recordize a)
90+ unrecordize (M1 a) = M1 (unrecordize a)
91+
92+
93+instance (Recordizable l, Recordizable r) => Recordizable (l :+: r) where
94+ recordize (L1 a) = L1 (recordize a)
95+ recordize (R1 a) = R1 (recordize a)
96+ unrecordize (L1 a) = L1 (unrecordize a)
97+ unrecordize (R1 a) = R1 (unrecordize a)
98+
99+
100+instance Countable 0 rep =>
101+ Recordizable (M1 C ('MetaCons name fixity 'False) rep)
102+ where
103+ recordize (M1 a) = M1 (count @0 a)
104+ unrecordize (M1 a) = M1 (uncount @0 a)
105+
106+
107+instance {-# OVERLAPPABLE #-} Recordize rep ~ rep => Recordizable rep where
108+ recordize = id
109+ unrecordize = id
110+
111+
112+type Countable :: Nat -> (Type -> Type) -> Constraint
113+class Countable n rep where
114+ count :: rep x -> Snd (Count n rep) x
115+ uncount :: Snd (Count n rep) x -> rep x
116+
117+
118+instance Countable n (M1 S ('MetaSel selector su ss ds) rep) where
119+ count (M1 a) = M1 a
120+ uncount (M1 a) = M1 a
121+
122+
123+instance
124+ ( Countable n a, Countable n' b
125+ , '(n', a') ~ Count n a
126+ , Snd (CountHelper2 a' (Count n' b)) ~ (a' :*: Snd (Count n' b))
127+ )
128+ => Countable n (a :*: b)
129+ where
130+ count (a :*: b) = count @n a :*: count @n' b
131+ uncount (a :*: b) = uncount @n a :*: uncount @n' b
132+
133+
134+instance {-# OVERLAPPABLE #-} Snd (Count n rep) ~ rep => Countable n rep where
135+ count = id
136+ uncount = id
137+
138+
139+newtype Record a = Record
140+ { unrecord :: a
141+ }
142+
143+
144+instance (Generic a, Recordizable (Rep a)) => Generic (Record a) where
145+ type Rep (Record a) = Recordize (Rep a)
146+
147+ from (Record a) = recordize (from a)
148+ to = Record . to . unrecordize
src/Rel8/Schema/Generic.hs+10−9
@@ -22,6 +22,7 @@ import Prelude
22import Unsafe.Coerce ( unsafeCoerce )
22import Unsafe.Coerce ( unsafeCoerce )
23
23
24-- rel8
24-- rel8
25+import Rel8.Generic.Record ( Record(..) )
25import Rel8.Schema.Context ( Col )
26import Rel8.Schema.Context ( Col )
26import Rel8.Schema.Context.Label ( Labelable )
27import Rel8.Schema.Context.Label ( Labelable )
27import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify )
28import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify )
@@ -102,22 +103,22 @@ class HTable (GRep t) => Rel8able t where
102 => t (Reify context) -> GRep t (Col (Reify context))
103 => t (Reify context) -> GRep t (Col (Reify context))
103
104
104 default gfromColumns ::
105 default gfromColumns ::
105− ( Generic (t (Reify context))
106+ ( Generic (Record (t (Reify context)))
106− , GColumns (Rep (t (Reify context))) ~ GRep t
107+ , GColumns (Rep (Record (t (Reify context)))) ~ GRep t
107− , GTable (Reify context) (Rep (t (Reify context)))
108+ , GTable (Reify context) (Rep (Record (t (Reify context))))
108 ) => GRep t (Col (Reify context)) -> t (Reify context)
109 ) => GRep t (Col (Reify context)) -> t (Reify context)
109− gfromColumns = to . fromGColumns
110+ gfromColumns = unrecord . to . fromGColumns
110
111
111 default gtoColumns ::
112 default gtoColumns ::
112− ( Generic (t (Reify context))
113+ ( Generic (Record (t (Reify context)))
113− , GColumns (Rep (t (Reify context))) ~ GRep t
114+ , GColumns (Rep (Record (t (Reify context)))) ~ GRep t
114− , GTable (Reify context) (Rep (t (Reify context)))
115+ , GTable (Reify context) (Rep (Record (t (Reify context))))
115 ) => t (Reify context) -> GRep t (Col (Reify context))
116 ) => t (Reify context) -> GRep t (Col (Reify context))
116− gtoColumns = toGColumns . from
117+ gtoColumns = toGColumns . from . Record
117
118
118
119
119type GRep :: K.Table -> K.HTable
120type GRep :: K.Table -> K.HTable
120−type GRep t = GColumns (Rep (t (Reify Name)))
121+type GRep t = GColumns (Rep (Record (t (Reify Name))))
121
122
122
123
123reify ::
124reify ::
src/Rel8/Schema/Generic/Test.hs+15
@@ -98,3 +98,18 @@ data HKDTest f = HKDTest
98 }
98 }
99 deriving stock Generic
99 deriving stock Generic
100 deriving anyclass Rel8able
100 deriving anyclass Rel8able
101+
102+
103+data NonRecord f = NonRecord
104+ (Column f Bool)
105+ (Column f Char)
106+ (Column f Char)
107+ (Column f Char)
108+ (Column f Char)
109+ (Column f Char)
110+ (Column f Char)
111+ (Column f Char)
112+ (Column f Char)
113+ (Column f Char)
114+ deriving stock Generic
115+ deriving anyclass Rel8able
src/Rel8/Table.hs+11−10
@@ -36,6 +36,7 @@ import GHC.TypeLits ( KnownSymbol )
36import Prelude hiding ( null )
36import Prelude hiding ( null )
37
37
38-- rel8
38-- rel8
39+import Rel8.Generic.Record ( Record(..) )
39import Rel8.Schema.Context ( Col(..) )
40import Rel8.Schema.Context ( Col(..) )
40import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
41import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
41import Rel8.Schema.HTable ( HTable )
42import Rel8.Schema.HTable ( HTable )
@@ -87,24 +88,24 @@ class (HTable (Columns a), context ~ Context a) => Table context a | a -> contex
87 toColumns :: a -> Columns a (Col (Context a))
88 toColumns :: a -> Columns a (Col (Context a))
88 fromColumns :: Columns a (Col (Context a)) -> a
89 fromColumns :: Columns a (Col (Context a)) -> a
89
90
90− type Columns a = GColumns (Rep a)
91+ type Columns a = GColumns (Rep (Record a))
91− type Context a = GContext (Rep a)
92+ type Context a = GContext (Rep (Record a))
92
93
93 default toColumns ::
94 default toColumns ::
94− ( Generic a, GTable (GContext (Rep a)) (Rep a)
95+ ( Generic (Record a), GTable (GContext (Rep (Record a))) (Rep (Record a))
95− , Columns a ~ GColumns (Rep a)
96+ , Columns a ~ GColumns (Rep (Record a))
96− , Context a ~ GContext (Rep a)
97+ , Context a ~ GContext (Rep (Record a))
97 )
98 )
98 => a -> Columns a (Col (Context a))
99 => a -> Columns a (Col (Context a))
99− toColumns = toGColumns . from
100+ toColumns = toGColumns . from . Record
100
101
101 default fromColumns ::
102 default fromColumns ::
102− ( Generic a, GTable (GContext (Rep a)) (Rep a)
103+ ( Generic (Record a), GTable (GContext (Rep (Record a))) (Rep (Record a))
103− , Columns a ~ GColumns (Rep a)
104+ , Columns a ~ GColumns (Rep (Record a))
104− , Context a ~ GContext (Rep a)
105+ , Context a ~ GContext (Rep (Record a))
105 )
106 )
106 => Columns a (Col (Context a)) -> a
107 => Columns a (Col (Context a)) -> a
107− fromColumns = to . fromGColumns
108+ fromColumns = unrecord . to . fromGColumns
108
109
109
110
110type GColumns :: (Type -> Type) -> K.HTable
111type GColumns :: (Type -> Type) -> K.HTable