@@ -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,20 @@
2929module Data.Generics.Product.Types
3030 ( -- *Traversals
3131 --
32− -- $setup
32+ -- $example
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−
4635 ) where
4736
4837import Data.Kind
4938import Data.Int (Int8, Int16, Int32, Int64)
5039import Data.Word (Word, Word8, Word16, Word32, Word64)
51−import qualified Data.Text as T
5240
5341import GHC.Generics
54−import GHC.TypeLits
5542import 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−--------------------------------------------------------------------------------
7843
7944-- TODO [1.0.0.0]: use type-changing variant internally
8045
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.
9146types :: forall a s. HasTypes s a => Traversal' s a
9247types = types_ @s @a
9348{-# INLINE types #-}
@@ -100,268 +55,129 @@ class HasTypes s a where
10055 {-# INLINE types_ #-}
10156
10257instance
103− ( HasTypesUsing ChGeneric s a
58+ ( HasTypes' (Interesting s a) s a
10459 ) => HasTypes s a where
105− types_ = typesUsing_ @ChGeneric
60+ types_ = types' @(Interesting s a)
10661 {-# INLINE types_ #-}
10762
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
63+class HasTypes' (t :: Bool) s a where
64+ types' :: Traversal' s a
11865
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
66+instance
67+ ( GHasTypes (Rep s) a
21168 , 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)
69+ ) => HasTypes' 'True s a where
70+ types' f s = to <$> gtypes_ f (from s)
22171 --{-# INLINE types' #-}
22272
73+instance HasTypes' 'False s a where
74+ types' _ = pure
75+ --{-# INLINE types' #-}
22376
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 #-}
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
27593
27694--------------------------------------------------------------------------------
27795
278−class GHasTypes ch s a where
96+class GHasTypes s a where
27997 gtypes_ :: Traversal' (s x) a
28098
28199instance
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
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
286104 {-# INLINE gtypes_ #-}
287105
288106instance
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
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
294112 {-# INLINE gtypes_ #-}
295113
296−instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
297− gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
114+instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where
115+ gtypes_ f (M1 s) = M1 <$> gtypes_ f s
298116 {-# INLINE gtypes_ #-}
299117
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
118+instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where
119+ gtypes_ f (K1 x) = K1 <$> f x
304120 {-# INLINE gtypes_ #-}
305121
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
122+instance HasTypes b a => GHasTypes (Rec0 b) a where
123+ gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x
314124 {-# INLINE gtypes_ #-}
315125
316−instance GHasTypes ch U1 a where
126+instance GHasTypes U1 a where
317127 gtypes_ _ _ = pure U1
318128 {-# INLINE gtypes_ #-}
319129
320−instance GHasTypes ch V1 a where
130+instance GHasTypes V1 a where
321131 gtypes_ _ = pure
322132 {-# INLINE gtypes_ #-}
323133
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
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)
340164
341165-- 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))
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)
351170
352171-- 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
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
358175
359176type family Elem a as where
360177 Elem a (a ': _) = 'True
361178 Elem a (_ ': as) = Elem a as
362179 Elem a '[] = 'False
363180
364−type family IsNothing a where
365− IsNothing ('Just _) = 'False
366− IsNothing 'Nothing = 'True
181+type family Snd a where
182+ Snd '(_, b) = b
367183