@@ -16,7 +16,7 @@
1616-----------------------------------------------------------------------------
1717-- |
1818-- Module : Data.Generics.Product.Types
19−-- Copyright : (C) 2018 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
2020-- License : BSD3
2121-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2222-- Stability : experimental
@@ -29,29 +29,65 @@
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
4749import Data.Int (Int8, Int16, Int32, Int64)
4850import Data.Word (Word, Word8, Word16, Word32, Word64)
51+import qualified Data.Text as T
4952
5053import GHC.Generics
54+import GHC.TypeLits
5155import Data.Generics.Internal.VL.Traversal
56+import Data.Generics.Internal.Errors
57+
58+-- $setup
59+-- == /Running example:/
60+--
61+-- >>> :set -XTypeApplications
62+-- >>> :set -XDeriveGeneric
63+-- >>> :set -XScopedTypeVariables
64+-- >>> import GHC.Generics
65+-- >>> :m +Data.Generics.Internal.VL.Traversal
66+-- >>> :m +Data.Generics.Internal.VL.Lens
67+-- >>> :{
68+-- data WTree a w
69+-- = Leaf a
70+-- | Fork (WTree a w) (WTree a w)
71+-- | WithWeight (WTree a w) w
72+-- deriving (Generic, Show)
73+-- :}
74+
75+--------------------------------------------------------------------------------
76+-- HasTypes
77+--------------------------------------------------------------------------------
5278
5379-- TODO [1.0.0.0]: use type-changing variant internally
5480
81+-- | Traverse all types in the given structure.
82+--
83+-- For example, to update all 'String's in a @WTree (Maybe String) String@, we can write
84+--
85+-- >>> myTree = WithWeight (Fork (Leaf (Just "hello")) (Leaf Nothing)) "world"
86+-- >>> over (types @String) (++ "!") myTree
87+-- WithWeight (Fork (Leaf (Just "hello!")) (Leaf Nothing)) "world!"
88+--
89+-- The traversal is /deep/, which means that not just the immediate
90+-- children are visited, but all nested values too.
5591types :: forall a s. HasTypes s a => Traversal' s a
5692types = types_ @s @a
5793{-# INLINE types #-}
@@ -64,100 +100,55 @@ class HasTypes s a where
64100 {-# INLINE types_ #-}
65101
66102instance
67− ( HasTypesUsing ChDefault s a
103+ ( HasTypesUsing ChGeneric s a
68104 ) => HasTypes s a where
69− types_ = typesUsing @ChDefault
105+ types_ = typesUsing_ @ChGeneric
70106 {-# INLINE types_ #-}
71107
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−
112108--------------------------------------------------------------------------------
109+data Void
110+instance {-# OVERLAPPING #-} HasTypes Void a where
111+ types_ _ = pure
113112
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_ #-}
131−
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 #-} HasTypes s Void where
114+ types_ _ = 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_ #-}
116+instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where
117+ typesUsing_ _ = pure
139118
140−instance GHasTypes ch U1 a where
141− gtypes_ _ _ = pure U1
142− {-# INLINE gtypes_ #-}
119+instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
120+ typesUsing_ _ = pure
121+--------------------------------------------------------------------------------
143122
144−instance GHasTypes ch V1 a where
145− gtypes_ _ = pure
146− {-# INLINE gtypes_ #-}
123+--------------------------------------------------------------------------------
124+-- HasTypesUsing
125+--------------------------------------------------------------------------------
147126
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
127+-- $custom
128+--
129+-- The default traversal strategy 'types' recurses into each node of the type
130+-- using the 'Generic' instance for the nodes. However, in general not all
131+-- nodes will have a 'Generic' instance. For example:
132+--
133+-- >>> data Opaque = Opaque String deriving Show
134+-- >>> myTree = WithWeight (Fork (Leaf (Opaque "foo")) (Leaf (Opaque "bar"))) False
135+-- >>> over (types @String) (++ "!") myTree
136+-- ...
137+-- ... | No instance for ‘Generic Opaque’
138+-- ... | arising from a generic traversal.
139+-- ... | Either derive the instance, or define a custom traversal using ‘HasTypesCustom’
140+-- ...
141+--
142+-- In these cases, we can define a custom traversal strategy to override the
143+-- generic behaviour for certain types.
144+-- For a self-contained example, see the CustomChildren module in the tests directory.
154145
155146-- | The children of a type are the types of its fields.
156147-- The 'Children' type family maps a type @a@ to its set of children.
157148--
158149-- This type family is parameterized by a symbol @ch@ (that can be declared as
159150-- an empty data type).
160−-- The symbol 'ChDefault' provides a default definition. You can create new
151+-- The symbol 'ChGeneric' provides a default definition. You can create new
161152-- symbols to override the set of children of abstract, non-generic types.
162153--
163154-- The following example declares a @Custom@ symbol to redefine 'Children'
@@ -172,17 +163,69 @@ type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
172163-- ChildrenCustom NominalDiffTime = '[]
173164-- -- Add more custom mappings here.
174165--
175−-- ChildrenCustom a = Children ChDefault a
166+-- ChildrenCustom a = Children ChGeneric a
176167-- @
177168--
178169-- To use this definition, replace 'types' with @'typesUsing' \@Custom@.
179170type family Children (ch :: Type) (a :: Type) :: [Type]
180171
172+-- | @since 1.2.0.0
173+typesUsing :: forall ch a s. HasTypesUsing ch s a => Traversal' s a
174+typesUsing = typesUsing_ @ch @s @a
175+{-# INLINE typesUsing #-}
176+
177+-- | @since 1.2.0.0
178+class HasTypesUsing (ch :: Type) s a where
179+ typesUsing_ :: Traversal' s a
180+
181+instance {-# OVERLAPPABLE #-}
182+ ( HasTypesOpt ch (Interesting ch a s) s a
183+ ) => HasTypesUsing ch s a where
184+ typesUsing_ = typesOpt @ch @(Interesting ch a s)
185+ {-# INLINE typesUsing_ #-}
186+
187+-- TODO: should this instance be incoherent?
188+instance {-# OVERLAPPABLE #-} HasTypesUsing ch a a where
189+ typesUsing_ = id
190+
191+-- | By adding instances to this class, we can override the default
192+-- behaviour in an ad-hoc manner.
193+-- For example:
194+--
195+-- @
196+-- instance HasTypesCustom Custom Opaque String where
197+-- typesCustom f (Opaque str) = Opaque <$> f str
198+-- @
199+--
200+-- @since 1.2.0.0
201+class HasTypesCustom (ch :: Type) s a where
202+ -- | This function should never be used directly, only to override
203+ -- the default traversal behaviour. To actually use the custom
204+ -- traversal strategy, see 'typesUsing'. This is because 'typesUsing' does
205+ -- additional optimisations, like ensuring that nodes with no relevant members will
206+ -- not be traversed at runtime.
207+ typesCustom :: Traversal' s a
208+
209+instance {-# OVERLAPPABLE #-}
210+ ( GHasTypes ch (Rep s) a
211+ , Generic s
212+ -- if there's no Generic instance here, it means we got through the
213+ -- Children check by a user-defined custom strategy.
214+ -- Therefore, we can ignore the missing Generic instance, and
215+ -- instead report a missing HasTypesCustom instance
216+ , Defined (Rep s)
217+ (PrettyError '[ 'Text "No instance " ':<>: QuoteType (HasTypesCustom ch s a)])
218+ (() :: Constraint)
219+ ) => HasTypesCustom ch s a where
220+ typesCustom f s = to <$> gtypes_ @ch f (from s)
221+ --{-# INLINE types' #-}
222+
223+
181224-- | The default definition of 'Children'.
182225-- Primitive types from core libraries have no children, and other types are
183226-- assumed to be 'Generic'.
184−data ChDefault
185−type instance Children ChDefault a = ChildrenDefault a
227+data ChGeneric
228+type instance Children ChGeneric a = ChildrenDefault a
186229
187230type family ChildrenDefault (a :: Type) :: [Type] where
188231 ChildrenDefault Char = '[]
@@ -199,10 +242,96 @@ type family ChildrenDefault (a :: Type) :: [Type] where
199242 ChildrenDefault Word16 = '[]
200243 ChildrenDefault Word32 = '[]
201244 ChildrenDefault Word64 = '[]
202− ChildrenDefault a = ChildrenGeneric (Rep a) '[]
245+ ChildrenDefault T.Text = '[]
246+ ChildrenDefault a
247+ = Defined (Rep a)
248+ (NoGeneric a
249+ '[ 'Text "arising from a generic traversal."
250+ , 'Text "Either derive the instance, or define a custom traversal using " ':<>: QuoteType HasTypesCustom
251+ ])
252+ (ChildrenGeneric (Rep a) '[])
253+
254+type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
255+ ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs
256+ ChildrenGeneric (l :*: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
257+ ChildrenGeneric (l :+: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
258+ ChildrenGeneric (Rec0 a) cs = a ': cs
259+ ChildrenGeneric _ cs = cs
260+
261+--------------------------------------------------------------------------------
262+-- Internals
263+--------------------------------------------------------------------------------
264+-- TODO: these should never leak out in error messages
265+
266+class HasTypesOpt (ch :: Type) (t :: Bool) s a where
267+ typesOpt :: Traversal' s a
268+
269+instance HasTypesCustom ch s a => HasTypesOpt ch 'True s a where
270+ typesOpt = typesCustom @ch
271+
272+instance HasTypesOpt ch 'False s a where
273+ typesOpt _ = pure
274+ --{-# INLINE typesOpt #-}
275+
276+--------------------------------------------------------------------------------
277+
278+class GHasTypes ch s a where
279+ gtypes_ :: Traversal' (s x) a
280+
281+instance
282+ ( GHasTypes ch l a
283+ , GHasTypes ch r a
284+ ) => GHasTypes ch (l :*: r) a where
285+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
286+ {-# INLINE gtypes_ #-}
287+
288+instance
289+ ( GHasTypes ch l a
290+ , GHasTypes ch r a
291+ ) => GHasTypes ch (l :+: r) a where
292+ gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l
293+ gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r
294+ {-# INLINE gtypes_ #-}
295+
296+instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
297+ gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
298+ {-# INLINE gtypes_ #-}
299+
300+-- | In the recursive case, we invoke 'HasTypesUsing' again, using the
301+-- same strategy
302+instance HasTypesUsing ch b a => GHasTypes ch (Rec0 b) a where
303+ gtypes_ f (K1 x) = K1 <$> typesUsing_ @ch @b @a f x
304+ {-# INLINE gtypes_ #-}
305+
306+-- | The default instance for 'HasTypes' acts as a synonym for
307+-- 'HasTypesUsing ChGeneric', so in most cases this instance should
308+-- behave the same as the one above.
309+-- However, there might be overlapping instances defined for
310+-- 'HasTypes' directly, in which case we want to prefer those
311+-- instances (even though the custom instances should always be added to 'HasTypesCustom')
312+instance {-# OVERLAPPING #-} HasTypes b a => GHasTypes ChGeneric (Rec0 b) a where
313+ gtypes_ f (K1 x) = K1 <$> types_ @b @a f x
314+ {-# INLINE gtypes_ #-}
315+
316+instance GHasTypes ch U1 a where
317+ gtypes_ _ _ = pure U1
318+ {-# INLINE gtypes_ #-}
319+
320+instance GHasTypes ch V1 a where
321+ gtypes_ _ = pure
322+ {-# INLINE gtypes_ #-}
203323
204324type Interesting (ch :: Type) (a :: Type) (t :: Type)
205− = IsNothing (Interesting' ch a '[t] (Children ch t))
325+ = Defined_list (Children ch t) (NoChildren ch t)
326+ (IsNothing (Interesting' ch a '[t] (Children ch t)))
327+
328+type family NoChildren (ch :: Type) (a :: Type) :: Constraint where
329+ NoChildren ch a = PrettyError
330+ '[ 'Text "No type family instance for " ':<>: QuoteType (Children ch a)
331+ , 'Text "arising from a traversal over " ':<>: QuoteType a
332+ , 'Text "with custom strategy " ':<>: QuoteType ch
333+ ]
334+
206335
207336type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
208337 Interesting' ch _ seen '[] = 'Just seen
@@ -216,7 +345,9 @@ type family InterestingUnless
216345 Maybe [Type] where
217346 InterestingUnless ch a seen a _ = 'Nothing
218347 InterestingUnless ch a seen t 'True = 'Just seen
219− InterestingUnless ch a seen t 'False = Interesting' ch a (t ': seen) (Children ch t)
348+ InterestingUnless ch a seen t 'False
349+ = Defined_list (Children ch t) (NoChildren ch t)
350+ (Interesting' ch a (t ': seen) (Children ch t))
220351
221352-- Short circuit
222353type family InterestingOr