@@ -16,7 +16,7 @@
1616-----------------------------------------------------------------------------
1717-- |
1818-- Module : Data.Generics.Product.Types
19−-- Copyright : (C) 2019 Csongor Kiss
19+-- Copyright : (C) 2018 Csongor Kiss
2020-- License : BSD3
2121-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2222-- Stability : experimental
@@ -29,65 +29,22 @@
2929module Data.Generics.Product.Types
3030 ( -- *Traversals
3131 --
32− -- $setup
32+ -- $example
3333 HasTypes
3434 , types
3535
36− -- * Custom traversal strategies
37− -- $custom
38− , Children
39− , ChGeneric
40−
41− , HasTypesUsing
42− , typesUsing
43−
44− , HasTypesCustom (typesCustom)
45−
36+ , Interesting
4637 ) where
4738
4839import Data.Kind
4940import Data.Int (Int8, Int16, Int32, Int64)
5041import Data.Word (Word, Word8, Word16, Word32, Word64)
51−import qualified Data.Text as T
5242
5343import GHC.Generics
54−import GHC.TypeLits
5544import 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−--------------------------------------------------------------------------------
7845
7946-- TODO [1.0.0.0]: use type-changing variant internally
8047
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.
9148types :: forall a s. HasTypes s a => Traversal' s a
9249types = types_ @s @a
9350{-# INLINE types #-}
@@ -100,268 +57,129 @@ class HasTypes s a where
10057 {-# INLINE types_ #-}
10158
10259instance
103− ( HasTypesUsing ChGeneric s a
60+ ( HasTypes' (Interesting s a) s a
10461 ) => HasTypes s a where
105− types_ = typesUsing_ @ChGeneric
62+ types_ = types' @(Interesting s a)
10663 {-# INLINE types_ #-}
10764
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
118−
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
65+class HasTypes' (t :: Bool) s a where
66+ types' :: Traversal' s a
20867
209−instance {-# OVERLAPPABLE #-}
210− ( GHasTypes ch (Rep s) a
68+instance
69+ ( GHasTypes (Rep s) a
21170 , 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)
71+ ) => HasTypes' 'True s a where
72+ types' f s = to <$> gtypes_ f (from s)
22173 --{-# INLINE types' #-}
22274
75+instance HasTypes' 'False s a where
76+ types' _ = pure
77+ --{-# INLINE types' #-}
22378
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 #-}
79+instance {-# OVERLAPPING #-} HasTypes Bool a
80+instance {-# OVERLAPPING #-} HasTypes Char a
81+instance {-# OVERLAPPING #-} HasTypes Double a
82+instance {-# OVERLAPPING #-} HasTypes Float a
83+instance {-# OVERLAPPING #-} HasTypes Integer a
84+instance {-# OVERLAPPING #-} HasTypes Ordering a
85+instance {-# OVERLAPPING #-} HasTypes Int a
86+instance {-# OVERLAPPING #-} HasTypes Int8 a
87+instance {-# OVERLAPPING #-} HasTypes Int16 a
88+instance {-# OVERLAPPING #-} HasTypes Int32 a
89+instance {-# OVERLAPPING #-} HasTypes Int64 a
90+instance {-# OVERLAPPING #-} HasTypes Word a
91+instance {-# OVERLAPPING #-} HasTypes Word8 a
92+instance {-# OVERLAPPING #-} HasTypes Word16 a
93+instance {-# OVERLAPPING #-} HasTypes Word32 a
94+instance {-# OVERLAPPING #-} HasTypes Word64 a
27595
27696--------------------------------------------------------------------------------
27797
278−class GHasTypes ch s a where
98+class GHasTypes s a where
27999 gtypes_ :: Traversal' (s x) a
280100
281101instance
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
102+ ( GHasTypes l a
103+ , GHasTypes r a
104+ ) => GHasTypes (l :*: r) a where
105+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r
286106 {-# INLINE gtypes_ #-}
287107
288108instance
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
109+ ( GHasTypes l a
110+ , GHasTypes r a
111+ ) => GHasTypes (l :+: r) a where
112+ gtypes_ f (L1 l) = L1 <$> gtypes_ f l
113+ gtypes_ f (R1 r) = R1 <$> gtypes_ f r
294114 {-# INLINE gtypes_ #-}
295115
296−instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
297− gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
116+instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where
117+ gtypes_ f (M1 s) = M1 <$> gtypes_ f s
298118 {-# INLINE gtypes_ #-}
299119
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
120+instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where
121+ gtypes_ f (K1 x) = K1 <$> f x
304122 {-# INLINE gtypes_ #-}
305123
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
124+instance HasTypes b a => GHasTypes (Rec0 b) a where
125+ gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x
314126 {-# INLINE gtypes_ #-}
315127
316−instance GHasTypes ch U1 a where
128+instance GHasTypes U1 a where
317129 gtypes_ _ _ = pure U1
318130 {-# INLINE gtypes_ #-}
319131
320−instance GHasTypes ch V1 a where
132+instance GHasTypes V1 a where
321133 gtypes_ _ = pure
322134 {-# INLINE gtypes_ #-}
323135
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
136+type Interesting f a = Snd (Interesting' (Rep f) a '[f])
137+
138+type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where
139+ Interesting' (M1 _ m f) t seen
140+ = Interesting' f t seen
141+ -- The result of the left branch is passed on to the right branch in order to avoid duplicate work
142+ Interesting' (l :*: r) t seen
143+ = InterestingOr (Interesting' l t seen) r t
144+ Interesting' (l :+: r) t seen
145+ = InterestingOr (Interesting' l t seen) r t
146+ Interesting' (Rec0 t) t seen
147+ = '(seen, 'True)
148+ Interesting' (Rec0 Char) _ seen = '(seen ,'False)
149+ Interesting' (Rec0 Double) _ seen = '(seen ,'False)
150+ Interesting' (Rec0 Float) _ seen = '(seen ,'False)
151+ Interesting' (Rec0 Integer) _ seen = '(seen ,'False)
152+ Interesting' (Rec0 Int) _ seen = '(seen ,'False)
153+ Interesting' (Rec0 Int8) _ seen = '(seen ,'False)
154+ Interesting' (Rec0 Int16) _ seen = '(seen ,'False)
155+ Interesting' (Rec0 Int32) _ seen = '(seen ,'False)
156+ Interesting' (Rec0 Int64) _ seen = '(seen ,'False)
157+ Interesting' (Rec0 Word) _ seen = '(seen ,'False)
158+ Interesting' (Rec0 Word8) _ seen = '(seen ,'False)
159+ Interesting' (Rec0 Word16) _ seen = '(seen ,'False)
160+ Interesting' (Rec0 Word32) _ seen = '(seen ,'False)
161+ Interesting' (Rec0 Word64) _ seen = '(seen ,'False)
162+ Interesting' (Rec0 r) t seen
163+ = InterestingUnless (Elem r seen) (Rep r) t r seen
164+ Interesting' _ _ seen
165+ = '(seen, 'False)
340166
341167-- Short circuit
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))
168+-- Note: we only insert 'r' to the seen list if it's not already there (which is precisely when `s` is 'False)
169+type family InterestingUnless (s :: Bool) f (a :: Type) (r :: Type) (seen :: [Type]) :: ([Type], Bool) where
170+ InterestingUnless 'True _ _ _ seen = '(seen, 'False)
171+ InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)
351172
352173-- Short circuit
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
174+type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where
175+ InterestingOr '(seen, 'True) _ _ = '(seen, 'True)
176+ InterestingOr '(seen, 'False) r t = Interesting' r t seen
358177
359178type family Elem a as where
360179 Elem a (a ': _) = 'True
361180 Elem a (_ ': as) = Elem a as
362181 Elem a '[] = 'False
363182
364−type family IsNothing a where
365− IsNothing ('Just _) = 'False
366− IsNothing 'Nothing = 'True
183+type family Snd a where
184+ Snd '(_, b) = b
367185