@@ -29,18 +29,20 @@
2929module Data.Generics.Product.Types
3030 ( -- *Traversals
3131 --
32− -- $example
32+ -- $setup
3333 HasTypes
3434 , types
3535
36+ -- * Custom traversal strategies
37+ -- $custom
38+ , Children
39+ , ChGeneric
40+
3641 , HasTypesUsing
3742 , typesUsing
3843
39− , HasTypes'
40− , types'
44+ , HasTypesCustom (typesCustom)
4145
42− , Children
43− , ChDefault
4446 ) where
4547
4648import Data.Kind
@@ -50,8 +52,39 @@ import Data.Word (Word, Word8, Word16, Word32, Word64)
5052import GHC.Generics
5153import Data.Generics.Internal.VL.Traversal
5254
55+-- $setup
56+-- == /Running example:/
57+--
58+-- >>> :set -XTypeApplications
59+-- >>> :set -XDeriveGeneric
60+-- >>> :set -XScopedTypeVariables
61+-- >>> import GHC.Generics
62+-- >>> :m +Data.Generics.Internal.VL.Traversal
63+-- >>> :m +Data.Generics.Internal.VL.Lens
64+-- >>> :{
65+-- data WTree a w
66+-- = Leaf a
67+-- | Fork (WTree a w) (WTree a w)
68+-- | WithWeight (WTree a w) w
69+-- deriving (Generic, Show)
70+-- :}
71+
72+--------------------------------------------------------------------------------
73+-- HasTypes
74+--------------------------------------------------------------------------------
75+
5376-- TODO [1.0.0.0]: use type-changing variant internally
5477
78+-- | Traverse all types in the given structure.
79+--
80+-- For example, to update all 'String's in a @WTree (Maybe Int) Int@, we can write
81+--
82+-- >>> myTree = WithWeight (Fork (Leaf (Just "hello")) (Leaf Nothing)) "world"
83+-- >>> over (types @String) (++ "!") myTree
84+-- WithWeight (Fork (Leaf (Just "hello!")) (Leaf Nothing)) "world!"
85+--
86+-- The traversal is /deep/, which means that not just the immediate
87+-- children are visited, but all nested values too.
5588types :: forall a s. HasTypes s a => Traversal' s a
5689types = types_ @s @a
5790{-# INLINE types #-}
@@ -64,100 +97,53 @@ class HasTypes s a where
6497 {-# INLINE types_ #-}
6598
6699instance
67− ( HasTypesUsing ChDefault s a
100+ ( HasTypesUsing ChGeneric s a
68101 ) => HasTypes s a where
69− types_ = typesUsing @ChDefault
102+ types_ = typesUsing_ @ChGeneric
70103 {-# INLINE types_ #-}
71104
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
103− types' :: Traversal' s a
104−
105−instance
106− ( GHasTypes ch (Rep s) a
107− , Generic s
108− ) => HasTypes' ch s a where
109− types' f s = to <$> gtypes_ @ch f (from s)
110− --{-# INLINE types' #-}
111−
112105--------------------------------------------------------------------------------
106+data Void
107+instance {-# OVERLAPPING #-} HasTypes Void a where
108+ types_ _ = pure
113109
114−class GHasTypes ch s a where
115− gtypes_ :: Traversal' (s x) a
116−
117−instance
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
122− {-# INLINE gtypes_ #-}
123−
124−instance
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
130− {-# INLINE gtypes_ #-}
110+instance {-# OVERLAPPING #-} HasTypes s Void where
111+ types_ _ = pure
131112
132−instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
133− gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
134− {-# INLINE gtypes_ #-}
113+instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where
114+ typesUsing_ _ = pure
135115
136−instance HasTypes0 ch b a => GHasTypes ch (Rec0 b) a where
137− gtypes_ f (K1 x) = K1 <$> types0 @ch @b @a f x
138− {-# INLINE gtypes_ #-}
139−
140−instance GHasTypes ch U1 a where
141− gtypes_ _ _ = pure U1
142− {-# INLINE gtypes_ #-}
116+instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
117+ typesUsing_ _ = pure
118+--------------------------------------------------------------------------------
143119
144−instance GHasTypes ch V1 a where
145− gtypes_ _ = pure
146− {-# INLINE gtypes_ #-}
120+--------------------------------------------------------------------------------
121+-- HasTypesUsing
122+--------------------------------------------------------------------------------
147123
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
124+-- $custom
125+--
126+-- The default traversal strategy 'types' recurses into each node of the type
127+-- using the 'Generic' instance for the nodes. However, in general not all
128+-- nodes will have a 'Generic' instance. For example:
129+--
130+-- >>> data Opaque = Opaque String deriving Show
131+-- >>> myTree = WithWeight (Fork (Leaf (Opaque "foo")) (Leaf (Opaque "bar"))) False
132+-- >>> over (types @String) (++ "!") myTree
133+-- ...
134+-- ... No instance for (HasTypesOpt
135+-- ...
136+--
137+-- In these cases, we can define a custom traversal strategy to override the
138+-- generic behaviour for certain types.
139+-- For a self-contained example, see the CustomChildren module in the tests directory.
154140
155141-- | The children of a type are the types of its fields.
156142-- The 'Children' type family maps a type @a@ to its set of children.
157143--
158144-- This type family is parameterized by a symbol @ch@ (that can be declared as
159145-- an empty data type).
160−-- The symbol 'ChDefault' provides a default definition. You can create new
146+-- The symbol 'ChGeneric' provides a default definition. You can create new
161147-- symbols to override the set of children of abstract, non-generic types.
162148--
163149-- The following example declares a @Custom@ symbol to redefine 'Children'
@@ -172,17 +158,62 @@ type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
172158-- ChildrenCustom NominalDiffTime = '[]
173159-- -- Add more custom mappings here.
174160--
175−-- ChildrenCustom a = Children ChDefault a
161+-- ChildrenCustom a = Children ChGeneric a
176162-- @
177163--
178164-- To use this definition, replace 'types' with @'typesUsing' \@Custom@.
179165type family Children (ch :: Type) (a :: Type) :: [Type]
180166
167+-- | @since 1.2.0.0
168+typesUsing :: forall ch a s. HasTypesUsing ch s a => Traversal' s a
169+typesUsing = typesUsing_ @ch @s @a
170+{-# INLINE typesUsing #-}
171+
172+-- | @since 1.2.0.0
173+class HasTypesUsing (ch :: Type) s a where
174+ typesUsing_ :: Traversal' s a
175+
176+instance {-# OVERLAPPABLE #-}
177+ ( HasTypesOpt ch (Interesting ch a s) s a
178+ ) => HasTypesUsing ch s a where
179+ typesUsing_ = typesOpt @ch @(Interesting ch a s)
180+ {-# INLINE typesUsing_ #-}
181+
182+-- TODO: should this instance be incoherent?
183+instance {-# OVERLAPPABLE #-} HasTypesUsing ch a a where
184+ typesUsing_ = id
185+
186+-- | By adding instances to this class, we can override the default
187+-- behaviour in an ad-hoc manner.
188+-- For example:
189+--
190+-- @
191+-- instance HasTypesCustom Custom Opaque String where
192+-- typesCustom f (Opaque str) = Opaque <$> f str
193+-- @
194+--
195+-- @since 1.2.0.0
196+class HasTypesCustom (ch :: Type) s a where
197+ -- | This function should never be used directly, only to override
198+ -- the default traversal behaviour. To actually use the custom
199+ -- traversal strategy, see 'typesUsing'. This is because 'typesUsing' does
200+ -- additional optimisations, like ensuring that nodes with no relevant members will
201+ -- not be traversed at runtime.
202+ typesCustom :: Traversal' s a
203+
204+instance {-# OVERLAPPABLE #-}
205+ ( GHasTypes ch (Rep s) a
206+ , Generic s
207+ ) => HasTypesCustom ch s a where
208+ typesCustom f s = to <$> gtypes_ @ch f (from s)
209+ --{-# INLINE types' #-}
210+
211+
181212-- | The default definition of 'Children'.
182213-- Primitive types from core libraries have no children, and other types are
183214-- assumed to be 'Generic'.
184−data ChDefault
185−type instance Children ChDefault a = ChildrenDefault a
215+data ChGeneric
216+type instance Children ChGeneric a = ChildrenDefault a
186217
187218type family ChildrenDefault (a :: Type) :: [Type] where
188219 ChildrenDefault Char = '[]
@@ -201,6 +232,76 @@ type family ChildrenDefault (a :: Type) :: [Type] where
201232 ChildrenDefault Word64 = '[]
202233 ChildrenDefault a = ChildrenGeneric (Rep a) '[]
203234
235+type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
236+ ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs
237+ ChildrenGeneric (l :*: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
238+ ChildrenGeneric (l :+: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
239+ ChildrenGeneric (Rec0 a) cs = a ': cs
240+ ChildrenGeneric _ cs = cs
241+
242+--------------------------------------------------------------------------------
243+-- Internals
244+--------------------------------------------------------------------------------
245+-- TODO: these should never leak out in error messages
246+
247+class HasTypesOpt (ch :: Type) (t :: Bool) s a where
248+ typesOpt :: Traversal' s a
249+
250+instance HasTypesCustom ch s a => HasTypesOpt ch 'True s a where
251+ typesOpt = typesCustom @ch
252+
253+instance HasTypesOpt ch 'False s a where
254+ typesOpt _ = pure
255+ --{-# INLINE typesOpt #-}
256+
257+--------------------------------------------------------------------------------
258+
259+class GHasTypes ch s a where
260+ gtypes_ :: Traversal' (s x) a
261+
262+instance
263+ ( GHasTypes ch l a
264+ , GHasTypes ch r a
265+ ) => GHasTypes ch (l :*: r) a where
266+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
267+ {-# INLINE gtypes_ #-}
268+
269+instance
270+ ( GHasTypes ch l a
271+ , GHasTypes ch r a
272+ ) => GHasTypes ch (l :+: r) a where
273+ gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l
274+ gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r
275+ {-# INLINE gtypes_ #-}
276+
277+instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
278+ gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
279+ {-# INLINE gtypes_ #-}
280+
281+-- | In the recursive case, we invoke 'HasTypesUsing' again, using the
282+-- same strategy
283+instance HasTypesUsing ch b a => GHasTypes ch (Rec0 b) a where
284+ gtypes_ f (K1 x) = K1 <$> typesUsing_ @ch @b @a f x
285+ {-# INLINE gtypes_ #-}
286+
287+-- | The default instance for 'HasTypes' acts as a synonym for
288+-- 'HasTypesUsing ChGeneric', so in most cases this instance should
289+-- behave the same as the one above.
290+-- However, there might be overlapping instances defined for
291+-- 'HasTypes' directly, in which case we want to prefer those
292+-- instances (even though the custom instances should always be added to 'HasTypesCustom')
293+instance {-# OVERLAPPING #-} HasTypes b a => GHasTypes ChGeneric (Rec0 b) a where
294+ gtypes_ f (K1 x) = K1 <$> types_ @b @a f x
295+ {-# INLINE gtypes_ #-}
296+
297+instance GHasTypes ch U1 a where
298+ gtypes_ _ _ = pure U1
299+ {-# INLINE gtypes_ #-}
300+
301+instance GHasTypes ch V1 a where
302+ gtypes_ _ = pure
303+ {-# INLINE gtypes_ #-}
304+
204305type Interesting (ch :: Type) (a :: Type) (t :: Type)
205306 = IsNothing (Interesting' ch a '[t] (Children ch t))
206307