git.iko.soy/generic-lens
on master help sign in
Now fully optimal types traversal
0000851Csongor Kiss
src/Data/Generics/Internal/Families/Has.hs−26
compare with master
unifiedsplit
@@ -16,7 +16,6 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17module Data.Generics.Internal.Families.Has
17module Data.Generics.Internal.Families.Has
18 ( HasTotalFieldP
18 ( HasTotalFieldP
19− , HasTotalTypeP
20 , HasPartialTypeP
19 , HasPartialTypeP
21 , HasCtorP
20 , HasCtorP
22 , GTypes
21 , GTypes
@@ -54,31 +53,6 @@ type family HasTotalFieldP (field :: Symbol) f :: Bool where
54 ':<>: 'Text " is not a valid GHC.Generics representation type"
53 ':<>: 'Text " is not a valid GHC.Generics representation type"
55 )
54 )
56
55
57−type family HasTotalTypeP a f :: Bool where
58− HasTotalTypeP t (S1 meta (Rec0 t))
59− = 'True
60− HasTotalTypeP t (l :*: r)
61− = HasTotalTypeP t l || HasTotalTypeP t r
62− HasTotalTypeP t (l :+: r)
63− = HasTotalTypeP t l && HasTotalTypeP t r
64− HasTotalTypeP t (S1 _ _)
65− = 'False
66− HasTotalTypeP t (C1 m f)
67− = HasTotalTypeP t f
68− HasTotalTypeP t (D1 m f)
69− = HasTotalTypeP t f
70− HasTotalTypeP t (Rec0 _)
71− = 'False
72− HasTotalTypeP t U1
73− = 'False
74− HasTotalTypeP t V1
75− = 'False
76− HasTotalTypeP t f
77− = TypeError
78− ( 'ShowType f
79− ':<>: 'Text " is not a valid GHC.Generics representation type"
80− )
81−
82type family HasPartialTypeP a f :: Bool where
56type family HasPartialTypeP a f :: Bool where
83 HasPartialTypeP t (l :+: r)
57 HasPartialTypeP t (l :+: r)
84 = HasPartialTypeP t l || HasPartialTypeP t r
58 = HasPartialTypeP t l || HasPartialTypeP t r
src/Data/Generics/Product/Param.hs+1−1
@@ -40,7 +40,7 @@ import Data.Kind
40import Data.Generics.Internal.VL.Iso
40import Data.Generics.Internal.VL.Iso
41import Data.Generics.Internal.GenericN
41import Data.Generics.Internal.GenericN
42
42
43−class HasParam (p :: Nat) s t a b | p t a b -> s, p s a b -> t, p s -> a, p t -> b where
43+class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where
44 param :: Applicative g => (a -> g b) -> s -> g t
44 param :: Applicative g => (a -> g b) -> s -> g t
45
45
46instance
46instance
src/Data/Generics/Product/Types.hs+46−33
@@ -1,7 +1,7 @@
1−{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DefaultSignatures #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
@@ -34,7 +34,6 @@ module Data.Generics.Product.Types
34 ) where
34 ) where
35
35
36import Data.Kind
36import Data.Kind
37−import Data.Type.Bool
38
37
39import GHC.Generics
38import GHC.Generics
40import Data.Generics.Internal.VL.Traversal
39import Data.Generics.Internal.VL.Traversal
@@ -47,24 +46,24 @@ class HasTypes a s where
47 {-# INLINE types #-}
46 {-# INLINE types #-}
48
47
49instance
48instance
50− ( HasTypes1 (Interesting s a) a s
49+ ( Hastypes' (Interesting s a) a s
51 ) => HasTypes a s where
50 ) => HasTypes a s where
52− types = types1 @(Interesting s a)
51+ types = types' @(Interesting s a)
53 {-# INLINE types #-}
52 {-# INLINE types #-}
54
53
55−class HasTypes1 (t :: Bool) a s where
54+class Hastypes' (t :: Bool) a s where
56− types1 :: Traversal' s a
55+ types' :: Traversal' s a
57
56
58instance
57instance
59 ( GHasTypes a (Rep s)
58 ( GHasTypes a (Rep s)
60 , Generic s
59 , Generic s
61− ) => HasTypes1 'True a s where
60+ ) => Hastypes' 'True a s where
62− types1 f s = to <$> gtypes f (from s)
61+ types' f s = to <$> gtypes f (from s)
63− --{-# INLINE types1 #-}
62+ --{-# INLINE types' #-}
64
63
65−instance HasTypes1 'False a s where
64+instance Hastypes' 'False a s where
66− types1 _ = pure
65+ types' _ = pure
67− --{-# INLINE types1 #-}
66+ --{-# INLINE types' #-}
68
67
69instance {-# OVERLAPPING #-} HasTypes a Bool
68instance {-# OVERLAPPING #-} HasTypes a Bool
70instance {-# OVERLAPPING #-} HasTypes a Char
69instance {-# OVERLAPPING #-} HasTypes a Char
@@ -110,29 +109,43 @@ instance GHasTypes a U1 where
110 gtypes _ _ = pure U1
109 gtypes _ _ = pure U1
111 {-# INLINE gtypes #-}
110 {-# INLINE gtypes #-}
112
111
113−--instance GHasTypes a V1 where
114
112
115−type Interesting f a = Interesting' f (Rep f) a
113+instance GHasTypes a V1 where
114+ gtypes _ = pure
115+ {-# INLINE gtypes #-}
116
116
117+type Interesting f a = Interesting' (Rep f) a '[f]
118+
117−type family Interesting' orig f (a :: Type) :: Bool where
119+type family Interesting' f (a :: Type) (seen :: [Type]) :: Bool where
118− Interesting' orig (M1 _ m f) t
120+ Interesting' (M1 _ m f) t seen
119− = Interesting' orig f t
121+ = Interesting' f t seen
120− Interesting' orig (l :*: r) t
122+ Interesting' (l :*: r) t seen
121− = Interesting' orig l t || Interesting' orig r t
123+ = InterestingOr (Interesting' l t seen) r t seen
122− Interesting' orig (l :+: r) t
124+ Interesting' (l :+: r) t seen
123− = Interesting' orig l t || Interesting' orig r t
125+ = InterestingOr (Interesting' l t seen) r t seen
124− Interesting' orig (Rec0 t) t
126+ Interesting' (Rec0 t) t seen
125− = 'True
126− Interesting' _ (Rec0 Bool) _ = 'False
127− Interesting' _ (Rec0 Char) _ = 'False
128− Interesting' _ (Rec0 Double) _ = 'False
129− Interesting' _ (Rec0 Float) _ = 'False
130− Interesting' _ (Rec0 Int) _ = 'False
131− Interesting' _ (Rec0 Integer) _ = 'False
132− Interesting' _ (Rec0 Ordering) _ = 'False
133− Interesting' orig (Rec0 orig) _
134− = 'False
135− Interesting' _ (Rec0 _) _
136 = 'True
127 = 'True
128+ Interesting' (Rec0 Char) _ _ = 'False
129+ Interesting' (Rec0 Double) _ _ = 'False
130+ Interesting' (Rec0 Float) _ _ = 'False
131+ Interesting' (Rec0 Int) _ _ = 'False
132+ Interesting' (Rec0 Integer) _ _ = 'False
133+ Interesting' (Rec0 r) t seen
134+ = InterestingUnless (Elem r seen) (Rep r) t (r ': seen)
137 Interesting' _ _ _
135 Interesting' _ _ _
138 = 'False
136 = 'False
137+
138+-- Short circuit
139+type family InterestingUnless (s :: Bool) f (a :: Type) (seen :: [Type]) :: Bool where
140+ InterestingUnless 'True _ _ _ = 'False
141+ InterestingUnless 'False f a seen = Interesting' f a seen
142+
143+-- Short circuit
144+type family InterestingOr (b :: Bool) r t seen where
145+ InterestingOr 'True _ _ _ = 'True
146+ InterestingOr 'False r t seen = Interesting' r t seen
147+
148+type family Elem a as where
149+ Elem a (a ': _) = 'True
150+ Elem a (_ ': as) = Elem a as
151+ Elem a '[] = 'False