@@ -16,7 +16,7 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
18-- Module : Data.Generics.Product.Types
18-- Module : Data.Generics.Product.Types
19−-- Copyright : (C) 2018 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
20-- License : BSD3
20-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
22-- Stability : experimental
@@ -29,18 +29,65 @@
29module Data.Generics.Product.Types
29module Data.Generics.Product.Types
30 ( -- *Traversals
30 ( -- *Traversals
32− -- $example
32+ -- $setup
36+ -- * Custom traversal strategies
44+ , HasTypesCustom (typesCustom)
37import Data.Kind
48import Data.Kind
49+import Data.Int (Int8, Int16, Int32, Int64)
50+import Data.Word (Word, Word8, Word16, Word32, Word64)
51+import qualified Data.Text as T
39import GHC.Generics
53import GHC.Generics
40import Data.Generics.Internal.VL.Traversal
55import Data.Generics.Internal.VL.Traversal
56+import Data.Generics.Internal.Errors
59+-- == /Running example:/
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
70+-- | Fork (WTree a w) (WTree a w)
71+-- | WithWeight (WTree a w) w
72+-- deriving (Generic, Show)
75+--------------------------------------------------------------------------------
77+--------------------------------------------------------------------------------
42-- TODO [1.0.0.0]: use type-changing variant internally
79-- TODO [1.0.0.0]: use type-changing variant internally
81+-- | Traverse all types in the given structure.
83+-- For example, to update all 'String's in a @WTree (Maybe String) String@, we can write
85+-- >>> myTree = WithWeight (Fork (Leaf (Just "hello")) (Leaf Nothing)) "world"
86+-- >>> over (types @String) (++ "!") myTree
87+-- WithWeight (Fork (Leaf (Just "hello!")) (Leaf Nothing)) "world!"
89+-- The traversal is /deep/, which means that not just the immediate
90+-- children are visited, but all nested values too.
44types :: forall a s. HasTypes s a => Traversal' s a
91types :: forall a s. HasTypes s a => Traversal' s a
45types = types_ @s @a
92types = types_ @s @a
46{-# INLINE types #-}
93{-# INLINE types #-}
@@ -53,111 +100,268 @@ class HasTypes s a where
53 {-# INLINE types_ #-}
100 {-# INLINE types_ #-}
56− ( HasTypes' (Interesting s a) s a
103+ ( HasTypesUsing ChGeneric s a
57 ) => HasTypes s a where
104 ) => HasTypes s a where
58− types_ = types' @(Interesting s a)
105+ types_ = typesUsing_ @ChGeneric
59 {-# INLINE types_ #-}
106 {-# INLINE types_ #-}
61−class HasTypes' (t :: Bool) s a where
108+--------------------------------------------------------------------------------
62− types' :: Traversal' s a
109+data Void
110+instance {-# OVERLAPPING #-} HasTypes Void a where
113+instance {-# OVERLAPPING #-} HasTypes s Void where
116+instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where
117+ typesUsing_ _ = pure
64−instance
119+instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
120+ typesUsing_ _ = pure
121+--------------------------------------------------------------------------------
123+--------------------------------------------------------------------------------
125+--------------------------------------------------------------------------------
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:
133+-- >>> data Opaque = Opaque String deriving Show
134+-- >>> myTree = WithWeight (Fork (Leaf (Opaque "foo")) (Leaf (Opaque "bar"))) False
135+-- >>> over (types @String) (++ "!") myTree
137+-- ... | No instance for ‘Generic Opaque’
138+-- ... | arising from a generic traversal.
139+-- ... | Either derive the instance, or define a custom traversal using ‘HasTypesCustom’
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.
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.
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.
154+-- The following example declares a @Custom@ symbol to redefine 'Children'
155+-- for some abstract types from the @time@ library.
159+-- type instance 'Children' Custom a = ChildrenCustom a
161+-- type family ChildrenCustom (a :: Type) where
162+-- ChildrenCustom DiffTime = '[]
163+-- ChildrenCustom NominalDiffTime = '[]
164+-- -- Add more custom mappings here.
166+-- ChildrenCustom a = Children ChGeneric a
169+-- To use this definition, replace 'types' with @'typesUsing' \@Custom@.
170+type family Children (ch :: Type) (a :: Type) :: [Type]
173+typesUsing :: forall ch a s. HasTypesUsing ch s a => Traversal' s a
174+typesUsing = typesUsing_ @ch @s @a
175+{-# INLINE typesUsing #-}
178+class HasTypesUsing (ch :: Type) s a where
179+ typesUsing_ :: Traversal' s a
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_ #-}
187+-- TODO: should this instance be incoherent?
188+instance {-# OVERLAPPABLE #-} HasTypesUsing ch a a where
191+-- | By adding instances to this class, we can override the default
192+-- behaviour in an ad-hoc manner.
196+-- instance HasTypesCustom Custom Opaque String where
197+-- typesCustom f (Opaque str) = Opaque <$> f str
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
209+instance {-# OVERLAPPABLE #-}
65− ( GHasTypes (Rep s) a
210+ ( GHasTypes ch (Rep s) a
66 , Generic s
211 , Generic s
67− ) => HasTypes' 'True s a where
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
217+ (PrettyError '[ 'Text "No instance " ':<>: QuoteType (HasTypesCustom ch s a)])
219+ ) => HasTypesCustom ch s a where
68− types' f s = to <$> gtypes_ f (from s)
220+ typesCustom f s = to <$> gtypes_ @ch f (from s)
69 --{-# INLINE types' #-}
221 --{-# INLINE types' #-}
71−instance HasTypes' 'False s a where
73− --{-# INLINE types' #-}
75−instance {-# OVERLAPPING #-} HasTypes Bool a
224+-- | The default definition of 'Children'.
76−instance {-# OVERLAPPING #-} HasTypes Char a
225+-- Primitive types from core libraries have no children, and other types are
77−instance {-# OVERLAPPING #-} HasTypes Double a
226+-- assumed to be 'Generic'.
78−instance {-# OVERLAPPING #-} HasTypes Float a
227+data ChGeneric
79−instance {-# OVERLAPPING #-} HasTypes Int a
228+type instance Children ChGeneric a = ChildrenDefault a
80−instance {-# OVERLAPPING #-} HasTypes Integer a
229+
81−instance {-# OVERLAPPING #-} HasTypes Ordering a
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 = '[]
249+ '[ 'Text "arising from a generic traversal."
250+ , 'Text "Either derive the instance, or define a custom traversal using " ':<>: QuoteType HasTypesCustom
252+ (ChildrenGeneric (Rep a) '[])
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
261+--------------------------------------------------------------------------------
263+--------------------------------------------------------------------------------
264+-- TODO: these should never leak out in error messages
266+class HasTypesOpt (ch :: Type) (t :: Bool) s a where
267+ typesOpt :: Traversal' s a
269+instance HasTypesCustom ch s a => HasTypesOpt ch 'True s a where
270+ typesOpt = typesCustom @ch
272+instance HasTypesOpt ch 'False s a where
274+ --{-# INLINE typesOpt #-}
83--------------------------------------------------------------------------------
276--------------------------------------------------------------------------------
85−class GHasTypes s a where
278+class GHasTypes ch s a where
86 gtypes_ :: Traversal' (s x) a
279 gtypes_ :: Traversal' (s x) a
89− ( GHasTypes l a
282+ ( GHasTypes ch l a
90− , GHasTypes r a
283+ , GHasTypes ch r a
91− ) => GHasTypes (l :*: r) a where
284+ ) => GHasTypes ch (l :*: r) a where
92− gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r
285+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
93 {-# INLINE gtypes_ #-}
286 {-# INLINE gtypes_ #-}
96− ( GHasTypes l a
289+ ( GHasTypes ch l a
97− , GHasTypes r a
290+ , GHasTypes ch r a
98− ) => GHasTypes (l :+: r) a where
291+ ) => GHasTypes ch (l :+: r) a where
99− gtypes_ f (L1 l) = L1 <$> gtypes_ f l
292+ gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l
100− gtypes_ f (R1 r) = R1 <$> gtypes_ f r
293+ gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r
101 {-# INLINE gtypes_ #-}
294 {-# INLINE gtypes_ #-}
103−instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where
296+instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
104− gtypes_ f (M1 s) = M1 <$> gtypes_ f s
297+ gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
105 {-# INLINE gtypes_ #-}
298 {-# INLINE gtypes_ #-}
300+-- | In the recursive case, we invoke 'HasTypesUsing' again, using the
107−instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where
302+instance HasTypesUsing ch b a => GHasTypes ch (Rec0 b) a where
108− gtypes_ f (K1 x) = K1 <$> f x
303+ gtypes_ f (K1 x) = K1 <$> typesUsing_ @ch @b @a f x
109 {-# INLINE gtypes_ #-}
304 {-# INLINE gtypes_ #-}
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')
111−instance HasTypes b a => GHasTypes (Rec0 b) a where
312+instance {-# OVERLAPPING #-} HasTypes b a => GHasTypes ChGeneric (Rec0 b) a where
112− gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x
313+ gtypes_ f (K1 x) = K1 <$> types_ @b @a f x
113 {-# INLINE gtypes_ #-}
314 {-# INLINE gtypes_ #-}
115−instance GHasTypes U1 a where
316+instance GHasTypes ch U1 a where
116 gtypes_ _ _ = pure U1
317 gtypes_ _ _ = pure U1
117 {-# INLINE gtypes_ #-}
318 {-# INLINE gtypes_ #-}
119−instance GHasTypes V1 a where
320+instance GHasTypes ch V1 a where
120 gtypes_ _ = pure
321 gtypes_ _ = pure
121 {-# INLINE gtypes_ #-}
322 {-# INLINE gtypes_ #-}
123−type Interesting f a = Snd (Interesting' (Rep f) a '[f])
324+type Interesting (ch :: Type) (a :: Type) (t :: Type)
124−
325+ = Defined_list (Children ch t) (NoChildren ch t)
125−type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where
126− Interesting' (M1 _ m f) t seen
127− = Interesting' f t seen
326+ (IsNothing (Interesting' ch a '[t] (Children ch t)))
128− -- The result of the left branch is passed on to the right branch in order to avoid duplicate work
327+
129− Interesting' (l :*: r) t seen
328+type family NoChildren (ch :: Type) (a :: Type) :: Constraint where
130− = InterestingOr (Interesting' l t seen) r t
329+ NoChildren ch a = PrettyError
131− Interesting' (l :+: r) t seen
330+ '[ 'Text "No type family instance for " ':<>: QuoteType (Children ch a)
132− = InterestingOr (Interesting' l t seen) r t
331+ , 'Text "arising from a traversal over " ':<>: QuoteType a
133− Interesting' (Rec0 t) t seen
332+ , 'Text "with custom strategy " ':<>: QuoteType ch
134− = '(seen, 'True)
333+ ]
135− Interesting' (Rec0 Char) _ seen = '(seen ,'False)
334+
136− Interesting' (Rec0 Double) _ seen = '(seen ,'False)
335+
137− Interesting' (Rec0 Float) _ seen = '(seen ,'False)
336+type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
138− Interesting' (Rec0 Int) _ seen = '(seen ,'False)
337+ Interesting' ch _ seen '[] = 'Just seen
139− Interesting' (Rec0 Integer) _ seen = '(seen ,'False)
338+ Interesting' ch a seen (t ': ts) =
140− Interesting' (Rec0 r) t seen
141− = InterestingUnless (Elem r seen) (Rep r) t r seen
339+ InterestingOr ch a (InterestingUnless ch a seen t (Elem t seen)) ts
142− Interesting' _ _ seen
145-- Short circuit
341-- Short circuit
146−-- Note: we only insert 'r' to the seen list if it's not already there (which is precisely when `s` is 'False)
342+-- Note: we only insert 't' to the seen list if it's not already there (which is precisely when `s` is 'False)
147−type family InterestingUnless (s :: Bool) f (a :: Type) (r :: Type) (seen :: [Type]) :: ([Type], Bool) where
343+type family InterestingUnless
344+ (ch :: Type) (a :: Type) (seen :: [Type]) (t :: Type) (alreadySeen :: Bool) ::
148− InterestingUnless 'True _ _ _ seen = '(seen, 'False)
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)
149− InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)
350+ (Interesting' ch a (t ': seen) (Children ch t))
151-- Short circuit
352-- Short circuit
152−type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where
353+type family InterestingOr
354+ (ch :: Type) (a :: Type) (seen' :: Maybe [Type]) (ts :: [Type]) ::
153− InterestingOr '(seen, 'True) _ _ = '(seen, 'True)
356+ InterestingOr ch a 'Nothing _ = 'Nothing
154− InterestingOr '(seen, 'False) r t = Interesting' r t seen
357+ InterestingOr ch a ('Just seen) ts = Interesting' ch a seen ts
156type family Elem a as where
359type family Elem a as where
157 Elem a (a ': _) = 'True
360 Elem a (a ': _) = 'True
158 Elem a (_ ': as) = Elem a as
361 Elem a (_ ': as) = Elem a as
159 Elem a '[] = 'False
362 Elem a '[] = 'False
161−type family Snd a where
364+type family IsNothing a where
162− Snd '(_, b) = b
365+ IsNothing ('Just _) = 'False
366+ IsNothing 'Nothing = 'True