git.iko.soy/generic-lens
on master help sign in
Fix _Typed prism for multiple arities
commit138fbd92b2602582ebb89f1a965b1a6ca25764e2 authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateWed 2 Aug 2017, 14:33 (9 years ago) parent6a15e05
6 files changed+87−66
compare with master
unifiedsplit
README.md+3−3 src/Data/Generics/Internal/Families/Count.hs+9−19 src/Data/Generics/Internal/Families/Has.hs+13−24 src/Data/Generics/Internal/HList.hs+19−1 src/Data/Generics/Sum/Constructors.hs−3 src/Data/Generics/Sum/Typed.hs+43−16
README.md+3−3
@@ -175,10 +175,10 @@ type Name = String
175175type Age = Int
176176
177177data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)
178−data Animal = Dog Dog | Cat (Name, Age) | Duck Age deriving (Generic, Show)
178+data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show)
179179
180180shep = Dog (MkDog "Shep" 4)
181−mog = Cat ("Mog", 5)
181+mog = Cat "Mog" 5
182182donald = Duck 4
183183```
184184
@@ -193,7 +193,7 @@ Nothing
193193Just ("Mog",5)
194194
195195>>> _Ctor @"Cat" # ("Garfield", 6) :: Animal
196−Cat ("Garfield",6)
196+Cat "Garfield" 6
197197
198198>>> donald ^? _Ctor @"Giraffe"
199199error:
src/Data/Generics/Internal/Families/Count.hs+9−19
@@ -22,6 +22,9 @@ module Data.Generics.Internal.Families.Count
2222
2323import GHC.Generics
2424import GHC.TypeLits
25+import Data.Type.Bool (If)
26+
27+import Data.Generics.Internal.HList
2528
2629type family CountTotalType t f :: Count where
2730 CountTotalType t (S1 _ (Rec0 t))
@@ -49,29 +52,16 @@ type family CountTotalType t f :: Count where
4952 )
5053
5154type family CountPartialType t f :: Count where
52− CountPartialType t (S1 _ (Rec0 t))
53− = 'One
54− CountPartialType t (l :*: r)
55− = CountPartialType t l <|> CountPartialType t r
5655 CountPartialType t (l :+: r)
5756 = CountPartialType t l <|> CountPartialType t r
58− CountPartialType t (S1 _ _)
59− = 'None
60− CountPartialType t (C1 _ f)
61− = CountPartialType t f
57+ CountPartialType t (C1 m f)
58+ = If (Equals t (ListToTuple (GCollect f))) 'One 'None
6259 CountPartialType t (D1 _ f)
6360 = CountPartialType t f
64− CountPartialType t (Rec0 _)
65− = 'None
66− CountPartialType t U1
67− = 'None
68− CountPartialType t V1
69− = 'None
70− CountPartialType t f
71− = TypeError
72− ( 'ShowType f
73− ':<>: 'Text " is not a valid GHC.Generics representation type"
74− )
61+
62+type family Equals a b where
63+ Equals a a = 'True
64+ Equals _ _ = 'False
7565
7666data Count
7767 = None
src/Data/Generics/Internal/Families/Has.hs+13−24
@@ -17,7 +17,7 @@
1717module Data.Generics.Internal.Families.Has
1818 ( HasTotalFieldP
1919 , HasTotalTypeP
20− , HasPartialTypeP
20+ , HasPartialTypeTupleP
2121 , HasCtorP
2222 ) where
2323
@@ -25,6 +25,8 @@ import Data.Type.Bool (type (||), type (&&))
2525import GHC.Generics
2626import GHC.TypeLits
2727
28+import Data.Generics.Internal.HList
29+
2830type family HasTotalFieldP (field :: Symbol) f :: Bool where
2931 HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)
3032 = 'True
@@ -75,30 +77,17 @@ type family HasTotalTypeP a f :: Bool where
7577 ':<>: 'Text " is not a valid GHC.Generics representation type"
7678 )
7779
78−type family HasPartialTypeP a f :: Bool where
79− HasPartialTypeP t (S1 meta (Rec0 t))
80− = 'True
81− HasPartialTypeP t (l :*: r)
82− = HasPartialTypeP t l || HasPartialTypeP t r
83− HasPartialTypeP t (l :+: r)
84− = HasPartialTypeP t l || HasPartialTypeP t r
85− HasPartialTypeP t (S1 _ _)
86− = 'False
87− HasPartialTypeP t (C1 m f)
88− = HasPartialTypeP t f
89− HasPartialTypeP t (D1 m f)
90− = HasPartialTypeP t f
91− HasPartialTypeP t (Rec0 _)
92− = 'False
93− HasPartialTypeP t U1
94− = 'False
95− HasPartialTypeP t V1
80+type family HasPartialTypeTupleP a f :: Bool where
81+ HasPartialTypeTupleP t (l :+: r)
82+ = HasPartialTypeTupleP t l || HasPartialTypeTupleP t r
83+ HasPartialTypeTupleP t (C1 m f)
84+ = Equals t (ListToTuple (GCollect f))
85+ HasPartialTypeTupleP t _
9686 = 'False
97− HasPartialTypeP t f
98− = TypeError
99− ( 'ShowType f
100− ':<>: 'Text " is not a valid GHC.Generics representation type"
101− )
87+
88+type family Equals a b where
89+ Equals a a = 'True
90+ Equals _ _ = 'False
10291
10392type family HasCtorP (ctor :: Symbol) f :: Bool where
10493 HasCtorP ctor (C1 ('MetaCons ctor _ _) _)
src/Data/Generics/Internal/HList.hs+19−1
@@ -67,74 +67,87 @@ instance Splittable as bs cs => Splittable (a ': as) bs (a ': cs) where
6767-- * Convert tuples to/from HLists
6868
6969class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where
70+ type ListToTuple as :: Type
7071 tupleToList :: tuple -> HList as
7172 listToTuple :: HList as -> tuple
7273
7374instance ListTuple () '[] where
75+ type ListToTuple '[] = ()
7476 tupleToList _ = Nil
7577 listToTuple _ = ()
7678
7779instance ListTuple a '[a] where
80+ type ListToTuple '[a] = a
7881 tupleToList a
7982 = a :> Nil
8083 listToTuple (a :> Nil)
8184 = a
8285
8386instance ListTuple (a, b) '[a, b] where
87+ type ListToTuple '[a, b] = (a, b)
8488 tupleToList (a, b)
8589 = a :> b :> Nil
8690 listToTuple (a :> b :> Nil)
8791 = (a, b)
8892
8993instance ListTuple (a, b, c) '[a, b, c] where
94+ type ListToTuple '[a, b, c] = (a, b, c)
9095 tupleToList (a, b, c)
9196 = a :> b :> c :> Nil
9297 listToTuple (a :> b :> c :> Nil)
9398 = (a, b, c)
9499
95100instance ListTuple (a, b, c, d) '[a, b, c, d] where
101+ type ListToTuple '[a, b, c, d] = (a, b, c, d)
96102 tupleToList (a, b, c, d)
97103 = a :> b :> c :> d:> Nil
98104 listToTuple (a :> b :> c :> d :> Nil)
99105 = (a, b, c, d)
100106
101107instance ListTuple (a, b, c, d, e) '[a, b, c, d, e] where
108+ type ListToTuple '[a, b, c, d, e] = (a, b, c, d, e)
102109 tupleToList (a, b, c, d, e)
103110 = a :> b :> c :> d:> e :> Nil
104111 listToTuple (a :> b :> c :> d :> e :> Nil)
105112 = (a, b, c, d, e)
106113
107114instance ListTuple (a, b, c, d, e, f) '[a, b, c, d, e, f] where
115+ type ListToTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)
108116 tupleToList (a, b, c, d, e, f)
109117 = a :> b :> c :> d:> e :> f :> Nil
110118 listToTuple (a :> b :> c :> d :> e :> f :> Nil)
111119 = (a, b, c, d, e, f)
112120
113121instance ListTuple (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where
122+ type ListToTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)
114123 tupleToList (a, b, c, d, e, f, g)
115124 = a :> b :> c :> d:> e :> f :> g :> Nil
116125 listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
117126 = (a, b, c, d, e, f, g)
118127
119128instance ListTuple (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where
129+ type ListToTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)
120130 tupleToList (a, b, c, d, e, f, g, h)
121131 = a :> b :> c :> d:> e :> f :> g :> h :> Nil
122132 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
123133 = (a, b, c, d, e, f, g, h)
124134
125135instance ListTuple (a, b, c, d, e, f, g, h, j) '[a, b, c, d, e, f, g, h, j] where
136+ type ListToTuple '[a, b, c, d, e, f, g, h, j] = (a, b, c, d, e, f, g, h, j)
126137 tupleToList (a, b, c, d, e, f, g, h, j)
127138 = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
128139 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
129140 = (a, b, c, d, e, f, g, h, j)
130141
131142instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[a, b, c, d, e, f, g, h, j, k] where
143+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k] = (a, b, c, d, e, f, g, h, j, k)
132144 tupleToList (a, b, c, d, e, f, g, h, j, k)
133145 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
134146 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
135147 = (a, b, c, d, e, f, g, h, j, k)
136148
137149instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j, k, l] where
150+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l] = (a, b, c, d, e, f, g, h, j, k, l)
138151 tupleToList (a, b, c, d, e, f, g, h, j, k, l)
139152 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
140153 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
@@ -143,6 +156,7 @@ instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j
143156--------------------------------------------------------------------------------
144157
145158class GCollectible (f :: Type -> Type) (as :: [Type]) | f -> as where
159+ type GCollect f :: [Type]
146160 gtoCollection :: f x -> HList as
147161 gfromCollection :: HList as -> f x
148162
@@ -152,6 +166,7 @@ instance
152166 , cs ~ (as ++ bs)
153167 , Splittable as bs cs
154168 ) => GCollectible (l :*: r) cs where
169+ type GCollect (l :*: r) = GCollect l ++ GCollect r
155170
156171 gtoCollection (l :*: r)
157172 = gtoCollection l `append` gtoCollection r
@@ -160,14 +175,17 @@ instance
160175 = gfromCollection as :*: gfromCollection bs
161176 where (as, bs) = split cs
162177
163−instance GCollectible (K1 R a) '[a] where
178+instance GCollectible (Rec0 a) '[a] where
179+ type GCollect (Rec0 a) = '[a]
164180 gtoCollection = (:> Nil) . unK1
165181 gfromCollection = K1 . head'
166182
167183instance GCollectible U1 '[] where
184+ type GCollect U1 = '[]
168185 gtoCollection U1 = Nil
169186 gfromCollection Nil = U1
170187
171188instance GCollectible f as => GCollectible (M1 m meta f) as where
189+ type GCollect (M1 m meta f) = GCollect f
172190 gtoCollection = gtoCollection . unM1
173191 gfromCollection = M1 . gfromCollection
src/Data/Generics/Sum/Constructors.hs−3
@@ -123,9 +123,6 @@ instance GSumAsConstructor ctor l r a (HasCtorP ctor l) => GAsConstructor ctor (
123123instance GAsConstructor ctor f a => GAsConstructor ctor (M1 D meta f) a where
124124 _GCtor = mIso . _GCtor @ctor
125125
126−instance GAsConstructor ctor f a => GAsConstructor ctor (M1 S meta f) a where
127− _GCtor = mIso . _GCtor @ctor
128−
129126class GSumAsConstructor (ctor :: Symbol) l r a (contains :: Bool) | ctor l r contains -> a where
130127 _GSumCtor :: Prism' ((l :+: r) x) a
131128
src/Data/Generics/Sum/Typed.hs+43−16
@@ -11,6 +11,8 @@
1111{-# LANGUAGE TypeOperators #-}
1212{-# LANGUAGE UndecidableInstances #-}
1313
14+{-# LANGUAGE DeriveGeneric #-}
15+
1416-----------------------------------------------------------------------------
1517-- |
1618-- Module : Data.Generics.Sum.Typed
@@ -51,7 +53,7 @@ import GHC.TypeLits
5153--
5254-- data Animal
5355-- = Dog Dog
54−-- | Cat (Name, Age)
56+-- | Cat Name Age
5557-- | Duck Age
5658-- deriving (Generic, Show)
5759--
@@ -116,27 +118,52 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constrain
116118-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
117119class GAsType (f :: Type -> Type) a where
118120 _GTyped :: Prism' (f x) a
121+ _GTyped = prism ginjectTyped gprojectTyped
122+
123+ ginjectTyped :: a -> f x
124+ gprojectTyped :: f x -> Either (f x) a
119125
120126instance
121− ( GCollectible f '[a]
127+ ( GCollectible f as
128+ , ListTuple a as
122129 ) => GAsType (M1 C meta f) a where
123130
124− _GTyped = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple @_ @'[a] . gtoCollection . unM1)
131+ ginjectTyped
132+ = M1 . gfromCollection . tupleToList
133+ gprojectTyped
134+ = Right . listToTuple @_ @as . gtoCollection . unM1
125135
126−instance GSumAsType l r a (HasPartialTypeP a l) => GAsType (l :+: r) a where
127− _GTyped = _GSumTyped @l @r @a @(HasPartialTypeP a l)
136+instance GSumAsType (HasPartialTypeTupleP a l) l r a => GAsType (l :+: r) a where
137+ ginjectTyped
138+ = ginjectSumTyped @(HasPartialTypeTupleP a l) @l @r @a
139+ gprojectTyped
140+ = gprojectSumTyped @(HasPartialTypeTupleP a l) @l @r @a
128141
129142instance GAsType f a => GAsType (M1 D meta f) a where
130− _GTyped = mIso . _GTyped
131−
132−instance GAsType f a => GAsType (M1 S meta f) a where
133− _GTyped = mIso . _GTyped
143+ ginjectTyped
144+ = M1 . ginjectTyped
145+ gprojectTyped
146+ = either (Left . M1) Right . gprojectTyped . unM1
134147
135−class GSumAsType l r a (contains :: Bool) where
148+class GSumAsType (contains :: Bool) l r a where
136149 _GSumTyped :: Prism' ((l :+: r) x) a
137−
138−instance GAsType l a => GSumAsType l r a 'True where
139− _GSumTyped = left . _GTyped
140−
141−instance GAsType r a => GSumAsType l r a 'False where
142− _GSumTyped = right . _GTyped
150+ _GSumTyped = prism (ginjectSumTyped @contains) (gprojectSumTyped @contains)
151+
152+ ginjectSumTyped :: a -> (l :+: r) x
153+ gprojectSumTyped :: (l :+: r) x -> Either ((l :+: r) x) a
154+
155+instance GAsType l a => GSumAsType 'True l r a where
156+ ginjectSumTyped
157+ = L1 . ginjectTyped
158+ gprojectSumTyped
159+ = \x -> case x of
160+ L1 l -> either (Left . L1) Right (gprojectTyped l)
161+ R1 _ -> Left x
162+
163+instance GAsType r a => GSumAsType 'False l r a where
164+ ginjectSumTyped
165+ = R1 . ginjectTyped
166+ gprojectSumTyped
167+ = \x -> case x of
168+ R1 r -> either (Left . R1) Right (gprojectTyped r)
169+ L1 _ -> Left x