git.iko.soy/generic-lens
on master help sign in
Optimise deep traversals
543c707Csongor Kiss
src/Data/Generics/Product/Types.hs+44−2
compare with master
unifiedsplit
@@ -35,6 +35,8 @@ module Data.Generics.Product.Types
35 ) where
35 ) where
36
36
37import Data.Generics.Product.Internal.Types
37import Data.Generics.Product.Internal.Types
38+import Data.Kind
39+import Data.Type.Bool
38
40
39import GHC.Generics
41import GHC.Generics
40import Data.Generics.Internal.VL.Traversal
42import Data.Generics.Internal.VL.Traversal
@@ -55,12 +57,27 @@ class HasTypesDeep a s where
55
57
56 default typesDeep :: Traversal' s a
58 default typesDeep :: Traversal' s a
57 typesDeep _ = pure
59 typesDeep _ = pure
60+ {-# INLINE typesDeep #-}
61+
62+instance
63+ ( HasTypesDeep1 (Interesting s a) a s
64+ ) => HasTypesDeep a s where
65+ typesDeep = typesDeep1 @(Interesting s a)
66+ {-# INLINE typesDeep #-}
67+
68+class HasTypesDeep1 (t :: Bool) a s where
69+ typesDeep1 :: Traversal' s a
58
70
59instance
71instance
60 ( GHasTypesDeep a (Rep s)
72 ( GHasTypesDeep a (Rep s)
61 , Generic s
73 , Generic s
62− ) => HasTypesDeep a s where
74+ ) => HasTypesDeep1 'True a s where
63− typesDeep f s = to <$> gtypesDeep f (from s)
75+ typesDeep1 f s = to <$> gtypesDeep f (from s)
76+ --{-# INLINE typesDeep1 #-}
77+
78+instance HasTypesDeep1 'False a s where
79+ typesDeep1 _ = pure
80+ --{-# INLINE typesDeep1 #-}
64
81
65instance {-# OVERLAPPING #-} HasTypesDeep a Bool
82instance {-# OVERLAPPING #-} HasTypesDeep a Bool
66instance {-# OVERLAPPING #-} HasTypesDeep a Char
83instance {-# OVERLAPPING #-} HasTypesDeep a Char
@@ -107,3 +124,28 @@ instance GHasTypesDeep a U1 where
107 {-# INLINE gtypesDeep #-}
124 {-# INLINE gtypesDeep #-}
108
125
109--instance GHasTypesDeep a V1 where
126--instance GHasTypesDeep a V1 where
127+
128+type Interesting f a = Interesting' f (Rep f) a
129+
130+type family Interesting' orig f (a :: Type) :: Bool where
131+ Interesting' orig (M1 _ m f) t
132+ = Interesting' orig f t
133+ Interesting' orig (l :*: r) t
134+ = Interesting' orig l t || Interesting' orig r t
135+ Interesting' orig (l :+: r) t
136+ = Interesting' orig l t || Interesting' orig r t
137+ Interesting' orig (Rec0 t) t
138+ = 'True
139+ Interesting' _ (Rec0 Bool) _ = 'False
140+ Interesting' _ (Rec0 Char) _ = 'False
141+ Interesting' _ (Rec0 Double) _ = 'False
142+ Interesting' _ (Rec0 Float) _ = 'False
143+ Interesting' _ (Rec0 Int) _ = 'False
144+ Interesting' _ (Rec0 Integer) _ = 'False
145+ Interesting' _ (Rec0 Ordering) _ = 'False
146+ Interesting' orig (Rec0 orig) _
147+ = 'False
148+ Interesting' _ (Rec0 _) _
149+ = 'True
150+ Interesting' _ _ _
151+ = 'False