@@ -1,7 +1,7 @@
1−{-# LANGUAGE DefaultSignatures #-}
21{-# LANGUAGE AllowAmbiguousTypes #-}
32{-# LANGUAGE ConstraintKinds #-}
43{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DefaultSignatures #-}
55{-# LANGUAGE FlexibleInstances #-}
66{-# LANGUAGE KindSignatures #-}
77{-# LANGUAGE MultiParamTypeClasses #-}
@@ -34,7 +34,6 @@ module Data.Generics.Product.Types
3434 ) where
3535
3636import Data.Kind
37−import Data.Type.Bool
3837
3938import GHC.Generics
4039import Data.Generics.Internal.VL.Traversal
@@ -47,24 +46,24 @@ class HasTypes a s where
4746 {-# INLINE types #-}
4847
4948instance
50− ( HasTypes1 (Interesting s a) a s
49+ ( Hastypes' (Interesting s a) a s
5150 ) => HasTypes a s where
52− types = types1 @(Interesting s a)
51+ types = types' @(Interesting s a)
5352 {-# INLINE types #-}
5453
55−class HasTypes1 (t :: Bool) a s where
56− types1 :: Traversal' s a
54+class Hastypes' (t :: Bool) a s where
55+ types' :: Traversal' s a
5756
5857instance
5958 ( GHasTypes a (Rep s)
6059 , Generic s
61− ) => HasTypes1 'True a s where
62− types1 f s = to <$> gtypes f (from s)
63− --{-# INLINE types1 #-}
60+ ) => Hastypes' 'True a s where
61+ types' f s = to <$> gtypes f (from s)
62+ --{-# INLINE types' #-}
6463
65−instance HasTypes1 'False a s where
66− types1 _ = pure
67− --{-# INLINE types1 #-}
64+instance Hastypes' 'False a s where
65+ types' _ = pure
66+ --{-# INLINE types' #-}
6867
6968instance {-# OVERLAPPING #-} HasTypes a Bool
7069instance {-# OVERLAPPING #-} HasTypes a Char
@@ -110,29 +109,43 @@ instance GHasTypes a U1 where
110109 gtypes _ _ = pure U1
111110 {-# INLINE gtypes #-}
112111
113−--instance GHasTypes a V1 where
114112
115−type Interesting f a = Interesting' f (Rep f) a
113+instance GHasTypes a V1 where
114+ gtypes _ = pure
115+ {-# INLINE gtypes #-}
116116
117−type family Interesting' orig f (a :: Type) :: Bool where
118− Interesting' orig (M1 _ m f) t
119− = Interesting' orig f t
120− Interesting' orig (l :*: r) t
121− = Interesting' orig l t || Interesting' orig r t
122− Interesting' orig (l :+: r) t
123− = Interesting' orig l t || Interesting' orig r t
124− Interesting' orig (Rec0 t) t
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 _) _
117+type Interesting f a = Interesting' (Rep f) a '[f]
118+
119+type family Interesting' f (a :: Type) (seen :: [Type]) :: Bool where
120+ Interesting' (M1 _ m f) t seen
121+ = Interesting' f t seen
122+ Interesting' (l :*: r) t seen
123+ = InterestingOr (Interesting' l t seen) r t seen
124+ Interesting' (l :+: r) t seen
125+ = InterestingOr (Interesting' l t seen) r t seen
126+ Interesting' (Rec0 t) t seen
136127 = '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)
137135 Interesting' _ _ _
138136 = '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