@@ -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,20 +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
38import Data.Int (Int8, Int16, Int32, Int64)
49import Data.Int (Int8, Int16, Int32, Int64)
39import Data.Word (Word, Word8, Word16, Word32, Word64)
50import Data.Word (Word, Word8, Word16, Word32, Word64)
51+import qualified Data.Text as T
41import GHC.Generics
53import GHC.Generics
42import 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+--------------------------------------------------------------------------------
44-- 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.
46types :: forall a s. HasTypes s a => Traversal' s a
91types :: forall a s. HasTypes s a => Traversal' s a
47types = types_ @s @a
92types = types_ @s @a
48{-# INLINE types #-}
93{-# INLINE types #-}
@@ -55,129 +100,268 @@ class HasTypes s a where
55 {-# INLINE types_ #-}
100 {-# INLINE types_ #-}
58− ( HasTypes' (Interesting s a) s a
103+ ( HasTypesUsing ChGeneric s a
59 ) => HasTypes s a where
104 ) => HasTypes s a where
60− types_ = types' @(Interesting s a)
105+ types_ = typesUsing_ @ChGeneric
61 {-# INLINE types_ #-}
106 {-# INLINE types_ #-}
63−class HasTypes' (t :: Bool) s a where
108+--------------------------------------------------------------------------------
64− 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
66−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 #-}
67− ( GHasTypes (Rep s) a
210+ ( GHasTypes ch (Rep s) a
68 , Generic s
211 , Generic s
69− ) => 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
70− types' f s = to <$> gtypes_ f (from s)
220+ typesCustom f s = to <$> gtypes_ @ch f (from s)
71 --{-# INLINE types' #-}
221 --{-# INLINE types' #-}
73−instance HasTypes' 'False s a where
75− --{-# INLINE types' #-}
77−instance {-# OVERLAPPING #-} HasTypes Bool a
224+-- | The default definition of 'Children'.
78−instance {-# OVERLAPPING #-} HasTypes Char a
225+-- Primitive types from core libraries have no children, and other types are
79−instance {-# OVERLAPPING #-} HasTypes Double a
226+-- assumed to be 'Generic'.
80−instance {-# OVERLAPPING #-} HasTypes Float a
227+data ChGeneric
81−instance {-# OVERLAPPING #-} HasTypes Integer a
228+type instance Children ChGeneric a = ChildrenDefault a
82−instance {-# OVERLAPPING #-} HasTypes Ordering a
229+
83−instance {-# OVERLAPPING #-} HasTypes Int a
230+type family ChildrenDefault (a :: Type) :: [Type] where
84−instance {-# OVERLAPPING #-} HasTypes Int8 a
231+ ChildrenDefault Char = '[]
85−instance {-# OVERLAPPING #-} HasTypes Int16 a
232+ ChildrenDefault Double = '[]
86−instance {-# OVERLAPPING #-} HasTypes Int32 a
233+ ChildrenDefault Float = '[]
87−instance {-# OVERLAPPING #-} HasTypes Int64 a
234+ ChildrenDefault Integer = '[]
88−instance {-# OVERLAPPING #-} HasTypes Word a
235+ ChildrenDefault Int = '[]
89−instance {-# OVERLAPPING #-} HasTypes Word8 a
236+ ChildrenDefault Int8 = '[]
90−instance {-# OVERLAPPING #-} HasTypes Word16 a
237+ ChildrenDefault Int16 = '[]
91−instance {-# OVERLAPPING #-} HasTypes Word32 a
238+ ChildrenDefault Int32 = '[]
92−instance {-# OVERLAPPING #-} HasTypes Word64 a
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 #-}
94--------------------------------------------------------------------------------
276--------------------------------------------------------------------------------
96−class GHasTypes s a where
278+class GHasTypes ch s a where
97 gtypes_ :: Traversal' (s x) a
279 gtypes_ :: Traversal' (s x) a
100− ( GHasTypes l a
282+ ( GHasTypes ch l a
101− , GHasTypes r a
283+ , GHasTypes ch r a
102− ) => GHasTypes (l :*: r) a where
284+ ) => GHasTypes ch (l :*: r) a where
103− gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r
285+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
104 {-# INLINE gtypes_ #-}
286 {-# INLINE gtypes_ #-}
107− ( GHasTypes l a
289+ ( GHasTypes ch l a
108− , GHasTypes r a
290+ , GHasTypes ch r a
109− ) => GHasTypes (l :+: r) a where
291+ ) => GHasTypes ch (l :+: r) a where
110− gtypes_ f (L1 l) = L1 <$> gtypes_ f l
292+ gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l
111− gtypes_ f (R1 r) = R1 <$> gtypes_ f r
293+ gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r
112 {-# INLINE gtypes_ #-}
294 {-# INLINE gtypes_ #-}
114−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
115− gtypes_ f (M1 s) = M1 <$> gtypes_ f s
297+ gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
116 {-# INLINE gtypes_ #-}
298 {-# INLINE gtypes_ #-}
300+-- | In the recursive case, we invoke 'HasTypesUsing' again, using the
118−instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where
302+instance HasTypesUsing ch b a => GHasTypes ch (Rec0 b) a where
119− gtypes_ f (K1 x) = K1 <$> f x
303+ gtypes_ f (K1 x) = K1 <$> typesUsing_ @ch @b @a f x
120 {-# 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')
122−instance HasTypes b a => GHasTypes (Rec0 b) a where
312+instance {-# OVERLAPPING #-} HasTypes b a => GHasTypes ChGeneric (Rec0 b) a where
123− gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x
313+ gtypes_ f (K1 x) = K1 <$> types_ @b @a f x
124 {-# INLINE gtypes_ #-}
314 {-# INLINE gtypes_ #-}
126−instance GHasTypes U1 a where
316+instance GHasTypes ch U1 a where
127 gtypes_ _ _ = pure U1
317 gtypes_ _ _ = pure U1
128 {-# INLINE gtypes_ #-}
318 {-# INLINE gtypes_ #-}
130−instance GHasTypes V1 a where
320+instance GHasTypes ch V1 a where
131 gtypes_ _ = pure
321 gtypes_ _ = pure
132 {-# INLINE gtypes_ #-}
322 {-# INLINE gtypes_ #-}
134−type Interesting f a = Snd (Interesting' (Rep f) a '[f])
324+type Interesting (ch :: Type) (a :: Type) (t :: Type)
135−
325+ = Defined_list (Children ch t) (NoChildren ch t)
326+ (IsNothing (Interesting' ch a '[t] (Children ch t)))
136−type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where
328+type family NoChildren (ch :: Type) (a :: Type) :: Constraint where
137− Interesting' (M1 _ m f) t seen
329+ NoChildren ch a = PrettyError
138− = Interesting' f t seen
330+ '[ 'Text "No type family instance for " ':<>: QuoteType (Children ch a)
139− -- The result of the left branch is passed on to the right branch in order to avoid duplicate work
331+ , 'Text "arising from a traversal over " ':<>: QuoteType a
140− Interesting' (l :*: r) t seen
332+ , 'Text "with custom strategy " ':<>: QuoteType ch
141− = InterestingOr (Interesting' l t seen) r t
333+ ]
142− Interesting' (l :+: r) t seen
334+
143− = InterestingOr (Interesting' l t seen) r t
335+
336+type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
144− Interesting' (Rec0 t) t seen
337+ Interesting' ch _ seen '[] = 'Just seen
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)
338+ Interesting' ch a seen (t ': ts) =
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
339+ InterestingOr ch a (InterestingUnless ch a seen t (Elem t seen)) ts
162− Interesting' _ _ seen
165-- Short circuit
341-- 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)
342+-- Note: we only insert 't' 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
343+type family InterestingUnless
344+ (ch :: Type) (a :: Type) (seen :: [Type]) (t :: Type) (alreadySeen :: Bool) ::
168− 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)
169− InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)
350+ (Interesting' ch a (t ': seen) (Children ch t))
171-- Short circuit
352-- Short circuit
172−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]) ::
173− InterestingOr '(seen, 'True) _ _ = '(seen, 'True)
356+ InterestingOr ch a 'Nothing _ = 'Nothing
174− InterestingOr '(seen, 'False) r t = Interesting' r t seen
357+ InterestingOr ch a ('Just seen) ts = Interesting' ch a seen ts
176type family Elem a as where
359type family Elem a as where
177 Elem a (a ': _) = 'True
360 Elem a (a ': _) = 'True
178 Elem a (_ ': as) = Elem a as
361 Elem a (_ ': as) = Elem a as
179 Elem a '[] = 'False
362 Elem a '[] = 'False
181−type family Snd a where
364+type family IsNothing a where
182− Snd '(_, b) = b
365+ IsNothing ('Just _) = 'False
366+ IsNothing 'Nothing = 'True