@@ -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,18 @@
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
49−import Data.Int (Int8, Int16, Int32, Int64)
50−import Data.Word (Word, Word8, Word16, Word32, Word64)
51−import qualified Data.Text as T
5238
5339import GHC.Generics
54−import GHC.TypeLits
5540import 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−--------------------------------------------------------------------------------
7841
7942-- TODO [1.0.0.0]: use type-changing variant internally
8043
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.
9144types :: forall a s. HasTypes s a => Traversal' s a
9245types = types_ @s @a
9346{-# INLINE types #-}
@@ -100,268 +53,111 @@ class HasTypes s a where
10053 {-# INLINE types_ #-}
10154
10255instance
103− ( HasTypesUsing ChGeneric s a
56+ ( HasTypes' (Interesting s a) s a
10457 ) => HasTypes s a where
105− types_ = typesUsing_ @ChGeneric
58+ types_ = types' @(Interesting s a)
10659 {-# INLINE types_ #-}
10760
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
61+class HasTypes' (t :: Bool) s a where
62+ types' :: Traversal' s a
11863
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
64+instance
65+ ( GHasTypes (Rep s) a
21166 , 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)
67+ ) => HasTypes' 'True s a where
68+ types' f s = to <$> gtypes_ f (from s)
22169 --{-# INLINE types' #-}
22270
71+instance HasTypes' 'False s a where
72+ types' _ = pure
73+ --{-# INLINE types' #-}
22374
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 #-}
75+instance {-# OVERLAPPING #-} HasTypes Bool a
76+instance {-# OVERLAPPING #-} HasTypes Char a
77+instance {-# OVERLAPPING #-} HasTypes Double a
78+instance {-# OVERLAPPING #-} HasTypes Float a
79+instance {-# OVERLAPPING #-} HasTypes Int a
80+instance {-# OVERLAPPING #-} HasTypes Integer a
81+instance {-# OVERLAPPING #-} HasTypes Ordering a
27582
27683--------------------------------------------------------------------------------
27784
278−class GHasTypes ch s a where
85+class GHasTypes s a where
27986 gtypes_ :: Traversal' (s x) a
28087
28188instance
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
89+ ( GHasTypes l a
90+ , GHasTypes r a
91+ ) => GHasTypes (l :*: r) a where
92+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r
28693 {-# INLINE gtypes_ #-}
28794
28895instance
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
96+ ( GHasTypes l a
97+ , GHasTypes r a
98+ ) => GHasTypes (l :+: r) a where
99+ gtypes_ f (L1 l) = L1 <$> gtypes_ f l
100+ gtypes_ f (R1 r) = R1 <$> gtypes_ f r
294101 {-# INLINE gtypes_ #-}
295102
296−instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
297− gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
103+instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where
104+ gtypes_ f (M1 s) = M1 <$> gtypes_ f s
298105 {-# INLINE gtypes_ #-}
299106
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
107+instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where
108+ gtypes_ f (K1 x) = K1 <$> f x
304109 {-# INLINE gtypes_ #-}
305110
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
111+instance HasTypes b a => GHasTypes (Rec0 b) a where
112+ gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x
314113 {-# INLINE gtypes_ #-}
315114
316−instance GHasTypes ch U1 a where
115+instance GHasTypes U1 a where
317116 gtypes_ _ _ = pure U1
318117 {-# INLINE gtypes_ #-}
319118
320−instance GHasTypes ch V1 a where
119+instance GHasTypes V1 a where
321120 gtypes_ _ = pure
322121 {-# INLINE gtypes_ #-}
323122
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
123+type Interesting f a = Snd (Interesting' (Rep f) a '[f])
124+
125+type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where
126+ Interesting' (M1 _ m f) t seen
127+ = Interesting' f t seen
128+ -- The result of the left branch is passed on to the right branch in order to avoid duplicate work
129+ Interesting' (l :*: r) t seen
130+ = InterestingOr (Interesting' l t seen) r t
131+ Interesting' (l :+: r) t seen
132+ = InterestingOr (Interesting' l t seen) r t
133+ Interesting' (Rec0 t) t seen
134+ = '(seen, 'True)
135+ Interesting' (Rec0 Char) _ seen = '(seen ,'False)
136+ Interesting' (Rec0 Double) _ seen = '(seen ,'False)
137+ Interesting' (Rec0 Float) _ seen = '(seen ,'False)
138+ Interesting' (Rec0 Int) _ seen = '(seen ,'False)
139+ Interesting' (Rec0 Integer) _ seen = '(seen ,'False)
140+ Interesting' (Rec0 r) t seen
141+ = InterestingUnless (Elem r seen) (Rep r) t r seen
142+ Interesting' _ _ seen
143+ = '(seen, 'False)
340144
341145-- 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))
146+-- Note: we only insert 'r' 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
148+ InterestingUnless 'True _ _ _ seen = '(seen, 'False)
149+ InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)
351150
352151-- 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
152+type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where
153+ InterestingOr '(seen, 'True) _ _ = '(seen, 'True)
154+ InterestingOr '(seen, 'False) r t = Interesting' r t seen
358155
359156type family Elem a as where
360157 Elem a (a ': _) = 'True
361158 Elem a (_ ': as) = Elem a as
362159 Elem a '[] = 'False
363160
364−type family IsNothing a where
365− IsNothing ('Just _) = 'False
366− IsNothing 'Nothing = 'True
161+type family Snd a where
162+ Snd '(_, b) = b
367163