@@ -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,20 +29,65 @@
2929module Data.Generics.Product.Types
3030 ( -- *Traversals
3131 --
32− -- $example
32+ -- $setup
3333 HasTypes
3434 , types
35+
36+ -- * Custom traversal strategies
37+ -- $custom
38+ , Children
39+ , ChGeneric
40+
41+ , HasTypesUsing
42+ , typesUsing
43+
44+ , HasTypesCustom (typesCustom)
45+
3546 ) where
3647
3748import Data.Kind
3849import Data.Int (Int8, Int16, Int32, Int64)
3950import Data.Word (Word, Word8, Word16, Word32, Word64)
51+import qualified Data.Text as T
4052
4153import GHC.Generics
54+import GHC.TypeLits
4255import 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+--------------------------------------------------------------------------------
4378
4479-- TODO [1.0.0.0]: use type-changing variant internally
4580
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.
4691types :: forall a s. HasTypes s a => Traversal' s a
4792types = types_ @s @a
4893{-# INLINE types #-}
@@ -55,129 +100,268 @@ class HasTypes s a where
55100 {-# INLINE types_ #-}
56101
57102instance
58− ( HasTypes' (Interesting s a) s a
103+ ( HasTypesUsing ChGeneric s a
59104 ) => HasTypes s a where
60− types_ = types' @(Interesting s a)
105+ types_ = typesUsing_ @ChGeneric
61106 {-# INLINE types_ #-}
62107
63−class HasTypes' (t :: Bool) s a where
64− types' :: Traversal' s a
108+--------------------------------------------------------------------------------
109+data Void
110+instance {-# OVERLAPPING #-} HasTypes Void a where
111+ types_ _ = pure
112+
113+instance {-# OVERLAPPING #-} HasTypes s Void where
114+ types_ _ = pure
115+
116+instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where
117+ typesUsing_ _ = pure
65118
66−instance
67− ( GHasTypes (Rep s) a
119+instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
120+ typesUsing_ _ = pure
121+--------------------------------------------------------------------------------
122+
123+--------------------------------------------------------------------------------
124+-- HasTypesUsing
125+--------------------------------------------------------------------------------
126+
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.
145+
146+-- | The children of a type are the types of its fields.
147+-- The 'Children' type family maps a type @a@ to its set of children.
148+--
149+-- This type family is parameterized by a symbol @ch@ (that can be declared as
150+-- an empty data type).
151+-- The symbol 'ChGeneric' provides a default definition. You can create new
152+-- symbols to override the set of children of abstract, non-generic types.
153+--
154+-- The following example declares a @Custom@ symbol to redefine 'Children'
155+-- for some abstract types from the @time@ library.
156+--
157+-- @
158+-- data Custom
159+-- type instance 'Children' Custom a = ChildrenCustom a
160+--
161+-- type family ChildrenCustom (a :: Type) where
162+-- ChildrenCustom DiffTime = '[]
163+-- ChildrenCustom NominalDiffTime = '[]
164+-- -- Add more custom mappings here.
165+--
166+-- ChildrenCustom a = Children ChGeneric a
167+-- @
168+--
169+-- To use this definition, replace 'types' with @'typesUsing' \@Custom@.
170+type family Children (ch :: Type) (a :: Type) :: [Type]
171+
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
68211 , Generic s
69− ) => HasTypes' 'True s a where
70− types' f s = to <$> gtypes_ f (from 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)
71221 --{-# INLINE types' #-}
72222
73−instance HasTypes' 'False s a where
74− types' _ = pure
75− --{-# INLINE types' #-}
76223
77−instance {-# OVERLAPPING #-} HasTypes Bool a
78−instance {-# OVERLAPPING #-} HasTypes Char a
79−instance {-# OVERLAPPING #-} HasTypes Double a
80−instance {-# OVERLAPPING #-} HasTypes Float a
81−instance {-# OVERLAPPING #-} HasTypes Integer a
82−instance {-# OVERLAPPING #-} HasTypes Ordering a
83−instance {-# OVERLAPPING #-} HasTypes Int a
84−instance {-# OVERLAPPING #-} HasTypes Int8 a
85−instance {-# OVERLAPPING #-} HasTypes Int16 a
86−instance {-# OVERLAPPING #-} HasTypes Int32 a
87−instance {-# OVERLAPPING #-} HasTypes Int64 a
88−instance {-# OVERLAPPING #-} HasTypes Word a
89−instance {-# OVERLAPPING #-} HasTypes Word8 a
90−instance {-# OVERLAPPING #-} HasTypes Word16 a
91−instance {-# OVERLAPPING #-} HasTypes Word32 a
92−instance {-# OVERLAPPING #-} HasTypes Word64 a
224+-- | The default definition of 'Children'.
225+-- Primitive types from core libraries have no children, and other types are
226+-- assumed to be 'Generic'.
227+data ChGeneric
228+type instance Children ChGeneric a = ChildrenDefault a
229+
230+type family ChildrenDefault (a :: Type) :: [Type] where
231+ ChildrenDefault Char = '[]
232+ ChildrenDefault Double = '[]
233+ ChildrenDefault Float = '[]
234+ ChildrenDefault Integer = '[]
235+ ChildrenDefault Int = '[]
236+ ChildrenDefault Int8 = '[]
237+ ChildrenDefault Int16 = '[]
238+ ChildrenDefault Int32 = '[]
239+ ChildrenDefault Int64 = '[]
240+ ChildrenDefault Word = '[]
241+ ChildrenDefault Word8 = '[]
242+ ChildrenDefault Word16 = '[]
243+ ChildrenDefault Word32 = '[]
244+ ChildrenDefault Word64 = '[]
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 #-}
93275
94276--------------------------------------------------------------------------------
95277
96−class GHasTypes s a where
278+class GHasTypes ch s a where
97279 gtypes_ :: Traversal' (s x) a
98280
99281instance
100− ( GHasTypes l a
101− , GHasTypes r a
102− ) => GHasTypes (l :*: r) a where
103− gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r
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
104286 {-# INLINE gtypes_ #-}
105287
106288instance
107− ( GHasTypes l a
108− , GHasTypes r a
109− ) => GHasTypes (l :+: r) a where
110− gtypes_ f (L1 l) = L1 <$> gtypes_ f l
111− gtypes_ f (R1 r) = R1 <$> gtypes_ f r
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
112294 {-# INLINE gtypes_ #-}
113295
114−instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where
115− gtypes_ f (M1 s) = M1 <$> gtypes_ f s
296+instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
297+ gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
116298 {-# INLINE gtypes_ #-}
117299
118−instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where
119− gtypes_ f (K1 x) = K1 <$> f x
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
120304 {-# INLINE gtypes_ #-}
121305
122−instance HasTypes b a => GHasTypes (Rec0 b) a where
123− gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x
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
124314 {-# INLINE gtypes_ #-}
125315
126−instance GHasTypes U1 a where
316+instance GHasTypes ch U1 a where
127317 gtypes_ _ _ = pure U1
128318 {-# INLINE gtypes_ #-}
129319
130−instance GHasTypes V1 a where
320+instance GHasTypes ch V1 a where
131321 gtypes_ _ = pure
132322 {-# INLINE gtypes_ #-}
133323
134−type Interesting f a = Snd (Interesting' (Rep f) a '[f])
135−
136−type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where
137− Interesting' (M1 _ m f) t seen
138− = Interesting' f t seen
139− -- The result of the left branch is passed on to the right branch in order to avoid duplicate work
140− Interesting' (l :*: r) t seen
141− = InterestingOr (Interesting' l t seen) r t
142− Interesting' (l :+: r) t seen
143− = InterestingOr (Interesting' l t seen) r t
144− Interesting' (Rec0 t) t seen
145− = '(seen, 'True)
146− Interesting' (Rec0 Char) _ seen = '(seen ,'False)
147− Interesting' (Rec0 Double) _ seen = '(seen ,'False)
148− Interesting' (Rec0 Float) _ seen = '(seen ,'False)
149− Interesting' (Rec0 Integer) _ seen = '(seen ,'False)
150− Interesting' (Rec0 Int) _ seen = '(seen ,'False)
151− Interesting' (Rec0 Int8) _ seen = '(seen ,'False)
152− Interesting' (Rec0 Int16) _ seen = '(seen ,'False)
153− Interesting' (Rec0 Int32) _ seen = '(seen ,'False)
154− Interesting' (Rec0 Int64) _ seen = '(seen ,'False)
155− Interesting' (Rec0 Word) _ seen = '(seen ,'False)
156− Interesting' (Rec0 Word8) _ seen = '(seen ,'False)
157− Interesting' (Rec0 Word16) _ seen = '(seen ,'False)
158− Interesting' (Rec0 Word32) _ seen = '(seen ,'False)
159− Interesting' (Rec0 Word64) _ seen = '(seen ,'False)
160− Interesting' (Rec0 r) t seen
161− = InterestingUnless (Elem r seen) (Rep r) t r seen
162− Interesting' _ _ seen
163− = '(seen, 'False)
324+type Interesting (ch :: Type) (a :: Type) (t :: Type)
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+
335+
336+type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
337+ Interesting' ch _ seen '[] = 'Just seen
338+ Interesting' ch a seen (t ': ts) =
339+ InterestingOr ch a (InterestingUnless ch a seen t (Elem t seen)) ts
164340
165341-- Short circuit
166−-- Note: we only insert 'r' to the seen list if it's not already there (which is precisely when `s` is 'False)
167−type family InterestingUnless (s :: Bool) f (a :: Type) (r :: Type) (seen :: [Type]) :: ([Type], Bool) where
168− InterestingUnless 'True _ _ _ seen = '(seen, 'False)
169− InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)
342+-- Note: we only insert 't' to the seen list if it's not already there (which is precisely when `s` is 'False)
343+type family InterestingUnless
344+ (ch :: Type) (a :: Type) (seen :: [Type]) (t :: Type) (alreadySeen :: Bool) ::
345+ Maybe [Type] where
346+ InterestingUnless ch a seen a _ = 'Nothing
347+ InterestingUnless ch a seen t 'True = 'Just seen
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))
170351
171352-- Short circuit
172−type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where
173− InterestingOr '(seen, 'True) _ _ = '(seen, 'True)
174− InterestingOr '(seen, 'False) r t = Interesting' r t seen
353+type family InterestingOr
354+ (ch :: Type) (a :: Type) (seen' :: Maybe [Type]) (ts :: [Type]) ::
355+ Maybe [Type] where
356+ InterestingOr ch a 'Nothing _ = 'Nothing
357+ InterestingOr ch a ('Just seen) ts = Interesting' ch a seen ts
175358
176359type family Elem a as where
177360 Elem a (a ': _) = 'True
178361 Elem a (_ ': as) = Elem a as
179362 Elem a '[] = 'False
180363
181−type family Snd a where
182− Snd '(_, b) = b
364+type family IsNothing a where
365+ IsNothing ('Just _) = 'False
366+ IsNothing 'Nothing = 'True
183367