@@ -33,7 +33,14 @@ module Data.Generics.Product.Types
3333 HasTypes
3434 , types
3535
36− , Interesting
36+ , HasTypesUsing
37+ , typesUsing
38+
39+ , HasTypes'
40+ , types'
41+
42+ , Children
43+ , ChDefault
3744 ) where
3845
3946import Data.Kind
@@ -57,129 +64,173 @@ class HasTypes s a where
5764 {-# INLINE types_ #-}
5865
5966instance
60− ( HasTypes' (Interesting s a) s a
67+ ( HasTypesUsing ChDefault s a
6168 ) => HasTypes s a where
62− types_ = types' @(Interesting s a)
69+ types_ = typesUsing @ChDefault
6370 {-# INLINE types_ #-}
6471
65−class HasTypes' (t :: Bool) s a where
72+class HasTypesUsing (ch :: Type) s a where
73+ typesUsing :: Traversal' s a
74+
75+instance
76+ ( HasTypes1 ch (Interesting ch a s) s a
77+ ) => HasTypesUsing ch s a where
78+ typesUsing = types1 @ch @(Interesting ch a s)
79+ {-# INLINE typesUsing #-}
80+
81+class HasTypes0 (ch :: Type) s a where
82+ types0 :: Traversal' s a
83+
84+instance {-# OVERLAPPING #-} HasTypes0 ch a a where
85+ types0 = id
86+
87+instance
88+ ( HasTypes1 ch (Interesting ch a s) s a
89+ ) => HasTypes0 ch s a where
90+ types0 = types1 @ch @(Interesting ch a s)
91+
92+class HasTypes1 (ch :: Type) (t :: Bool) s a where
93+ types1 :: Traversal' s a
94+
95+instance HasTypes' ch s a => HasTypes1 ch 'True s a where
96+ types1 = types' @ch
97+
98+instance HasTypes1 ch 'False s a where
99+ types1 _ = pure
100+ --{-# INLINE types1 #-}
101+
102+class HasTypes' (ch :: Type) s a where
66103 types' :: Traversal' s a
67104
68105instance
69− ( GHasTypes (Rep s) a
106+ ( GHasTypes ch (Rep s) a
70107 , Generic s
71− ) => HasTypes' 'True s a where
72− types' f s = to <$> gtypes_ f (from s)
108+ ) => HasTypes' ch s a where
109+ types' f s = to <$> gtypes_ @ch f (from s)
73110 --{-# INLINE types' #-}
74111
75−instance HasTypes' 'False s a where
76− types' _ = pure
77− --{-# INLINE types' #-}
78−
79−instance {-# OVERLAPPING #-} HasTypes Bool a
80−instance {-# OVERLAPPING #-} HasTypes Char a
81−instance {-# OVERLAPPING #-} HasTypes Double a
82−instance {-# OVERLAPPING #-} HasTypes Float a
83−instance {-# OVERLAPPING #-} HasTypes Integer a
84−instance {-# OVERLAPPING #-} HasTypes Ordering a
85−instance {-# OVERLAPPING #-} HasTypes Int a
86−instance {-# OVERLAPPING #-} HasTypes Int8 a
87−instance {-# OVERLAPPING #-} HasTypes Int16 a
88−instance {-# OVERLAPPING #-} HasTypes Int32 a
89−instance {-# OVERLAPPING #-} HasTypes Int64 a
90−instance {-# OVERLAPPING #-} HasTypes Word a
91−instance {-# OVERLAPPING #-} HasTypes Word8 a
92−instance {-# OVERLAPPING #-} HasTypes Word16 a
93−instance {-# OVERLAPPING #-} HasTypes Word32 a
94−instance {-# OVERLAPPING #-} HasTypes Word64 a
95−
96112--------------------------------------------------------------------------------
97113
98−class GHasTypes s a where
114+class GHasTypes ch s a where
99115 gtypes_ :: Traversal' (s x) a
100116
101117instance
102− ( GHasTypes l a
103− , GHasTypes r a
104− ) => GHasTypes (l :*: r) a where
105− gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r
118+ ( GHasTypes ch l a
119+ , GHasTypes ch r a
120+ ) => GHasTypes ch (l :*: r) a where
121+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
106122 {-# INLINE gtypes_ #-}
107123
108124instance
109− ( GHasTypes l a
110− , GHasTypes r a
111− ) => GHasTypes (l :+: r) a where
112− gtypes_ f (L1 l) = L1 <$> gtypes_ f l
113− gtypes_ f (R1 r) = R1 <$> gtypes_ f r
125+ ( GHasTypes ch l a
126+ , GHasTypes ch r a
127+ ) => GHasTypes ch (l :+: r) a where
128+ gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l
129+ gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r
114130 {-# INLINE gtypes_ #-}
115131
116−instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where
117− gtypes_ f (M1 s) = M1 <$> gtypes_ f s
132+instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
133+ gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
118134 {-# INLINE gtypes_ #-}
119135
120−instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where
121− gtypes_ f (K1 x) = K1 <$> f x
136+instance HasTypes0 ch b a => GHasTypes ch (Rec0 b) a where
137+ gtypes_ f (K1 x) = K1 <$> types0 @ch @b @a f x
122138 {-# INLINE gtypes_ #-}
123139
124−instance HasTypes b a => GHasTypes (Rec0 b) a where
125− gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x
126− {-# INLINE gtypes_ #-}
127−
128−instance GHasTypes U1 a where
140+instance GHasTypes ch U1 a where
129141 gtypes_ _ _ = pure U1
130142 {-# INLINE gtypes_ #-}
131143
132−instance GHasTypes V1 a where
144+instance GHasTypes ch V1 a where
133145 gtypes_ _ = pure
134146 {-# INLINE gtypes_ #-}
135147
136−type Interesting f a = Snd (Interesting' (Rep f) a '[f])
137−
138−type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where
139− Interesting' (M1 _ m f) t seen
140− = Interesting' f t seen
141− -- The result of the left branch is passed on to the right branch in order to avoid duplicate work
142− Interesting' (l :*: r) t seen
143− = InterestingOr (Interesting' l t seen) r t
144− Interesting' (l :+: r) t seen
145− = InterestingOr (Interesting' l t seen) r t
146− Interesting' (Rec0 t) t seen
147− = '(seen, 'True)
148− Interesting' (Rec0 Char) _ seen = '(seen ,'False)
149− Interesting' (Rec0 Double) _ seen = '(seen ,'False)
150− Interesting' (Rec0 Float) _ seen = '(seen ,'False)
151− Interesting' (Rec0 Integer) _ seen = '(seen ,'False)
152− Interesting' (Rec0 Int) _ seen = '(seen ,'False)
153− Interesting' (Rec0 Int8) _ seen = '(seen ,'False)
154− Interesting' (Rec0 Int16) _ seen = '(seen ,'False)
155− Interesting' (Rec0 Int32) _ seen = '(seen ,'False)
156− Interesting' (Rec0 Int64) _ seen = '(seen ,'False)
157− Interesting' (Rec0 Word) _ seen = '(seen ,'False)
158− Interesting' (Rec0 Word8) _ seen = '(seen ,'False)
159− Interesting' (Rec0 Word16) _ seen = '(seen ,'False)
160− Interesting' (Rec0 Word32) _ seen = '(seen ,'False)
161− Interesting' (Rec0 Word64) _ seen = '(seen ,'False)
162− Interesting' (Rec0 r) t seen
163− = InterestingUnless (Elem r seen) (Rep r) t r seen
164− Interesting' _ _ seen
165− = '(seen, 'False)
148+type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
149+ ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs
150+ ChildrenGeneric (l :*: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
151+ ChildrenGeneric (l :+: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
152+ ChildrenGeneric (Rec0 a) cs = a ': cs
153+ ChildrenGeneric _ cs = cs
154+
155+-- | The children of a type are the types of its fields.
156+-- The 'Children' type family maps a type @a@ to its set of children.
157+--
158+-- This type family is parameterized by a symbol @ch@ (that can be declared as
159+-- an empty data type).
160+-- The symbol 'ChDefault' provides a default definition. You can create new
161+-- symbols to override the set of children of abstract, non-generic types.
162+--
163+-- The following example declares a @Custom@ symbol to redefine 'Children'
164+-- for some abstract types from the @time@ library.
165+--
166+-- @
167+-- data Custom
168+-- type instance 'Children' Custom a = ChildrenCustom a
169+--
170+-- type family ChildrenCustom (a :: Type) where
171+-- ChildrenCustom DiffTime = '[]
172+-- ChildrenCustom NominalDiffTime = '[]
173+-- -- Add more custom mappings here.
174+--
175+-- ChildrenCustom a = Children ChDefault a
176+-- @
177+--
178+-- To use this definition, replace 'types' with @'typesUsing' \@Custom@.
179+type family Children (ch :: Type) (a :: Type) :: [Type]
180+
181+-- | The default definition of 'Children'.
182+-- Primitive types from core libraries have no children, and other types are
183+-- assumed to be 'Generic'.
184+data ChDefault
185+type instance Children ChDefault a = ChildrenDefault a
186+
187+type family ChildrenDefault (a :: Type) :: [Type] where
188+ ChildrenDefault Char = '[]
189+ ChildrenDefault Double = '[]
190+ ChildrenDefault Float = '[]
191+ ChildrenDefault Integer = '[]
192+ ChildrenDefault Int = '[]
193+ ChildrenDefault Int8 = '[]
194+ ChildrenDefault Int16 = '[]
195+ ChildrenDefault Int32 = '[]
196+ ChildrenDefault Int64 = '[]
197+ ChildrenDefault Word = '[]
198+ ChildrenDefault Word8 = '[]
199+ ChildrenDefault Word16 = '[]
200+ ChildrenDefault Word32 = '[]
201+ ChildrenDefault Word64 = '[]
202+ ChildrenDefault a = ChildrenGeneric (Rep a) '[]
203+
204+type Interesting (ch :: Type) (a :: Type) (t :: Type)
205+ = IsNothing (Interesting' ch a '[t] (Children ch t))
206+
207+type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
208+ Interesting' ch _ seen '[] = 'Just seen
209+ Interesting' ch a seen (t ': ts) =
210+ InterestingOr ch a (InterestingUnless ch a seen t (Elem t seen)) ts
166211
167212-- Short circuit
168−-- Note: we only insert 'r' to the seen list if it's not already there (which is precisely when `s` is 'False)
169−type family InterestingUnless (s :: Bool) f (a :: Type) (r :: Type) (seen :: [Type]) :: ([Type], Bool) where
170− InterestingUnless 'True _ _ _ seen = '(seen, 'False)
171− InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)
213+-- Note: we only insert 't' to the seen list if it's not already there (which is precisely when `s` is 'False)
214+type family InterestingUnless
215+ (ch :: Type) (a :: Type) (seen :: [Type]) (t :: Type) (alreadySeen :: Bool) ::
216+ Maybe [Type] where
217+ InterestingUnless ch a seen a _ = 'Nothing
218+ InterestingUnless ch a seen t 'True = 'Just seen
219+ InterestingUnless ch a seen t 'False = Interesting' ch a (t ': seen) (Children ch t)
172220
173221-- Short circuit
174−type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where
175− InterestingOr '(seen, 'True) _ _ = '(seen, 'True)
176− InterestingOr '(seen, 'False) r t = Interesting' r t seen
222+type family InterestingOr
223+ (ch :: Type) (a :: Type) (seen' :: Maybe [Type]) (ts :: [Type]) ::
224+ Maybe [Type] where
225+ InterestingOr ch a 'Nothing _ = 'Nothing
226+ InterestingOr ch a ('Just seen) ts = Interesting' ch a seen ts
177227
178228type family Elem a as where
179229 Elem a (a ': _) = 'True
180230 Elem a (_ ': as) = Elem a as
181231 Elem a '[] = 'False
182232
183−type family Snd a where
184− Snd '(_, b) = b
233+type family IsNothing a where
234+ IsNothing ('Just _) = 'False
235+ IsNothing 'Nothing = 'True
185236