@@ -16,7 +16,7 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
18-- Module : Data.Generics.Product.Types
18-- Module : Data.Generics.Product.Types
19−-- Copyright : (C) 2019 Csongor Kiss
19+-- Copyright : (C) 2018 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,65 +29,22 @@
29module Data.Generics.Product.Types
29module Data.Generics.Product.Types
30 ( -- *Traversals
30 ( -- *Traversals
32− -- $setup
32+ -- $example
36− -- * Custom traversal strategies
36+ , Interesting
44− , HasTypesCustom (typesCustom)
48import Data.Kind
39import Data.Kind
49import Data.Int (Int8, Int16, Int32, Int64)
40import Data.Int (Int8, Int16, Int32, Int64)
50import Data.Word (Word, Word8, Word16, Word32, Word64)
41import Data.Word (Word, Word8, Word16, Word32, Word64)
51−import qualified Data.Text as T
53import GHC.Generics
43import GHC.Generics
55import Data.Generics.Internal.VL.Traversal
44import 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−--------------------------------------------------------------------------------
79-- TODO [1.0.0.0]: use type-changing variant internally
46-- 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.
91types :: forall a s. HasTypes s a => Traversal' s a
48types :: forall a s. HasTypes s a => Traversal' s a
92types = types_ @s @a
49types = types_ @s @a
93{-# INLINE types #-}
50{-# INLINE types #-}
@@ -100,268 +57,129 @@ class HasTypes s a where
100 {-# INLINE types_ #-}
57 {-# INLINE types_ #-}
103− ( HasTypesUsing ChGeneric s a
60+ ( HasTypes' (Interesting s a) s a
104 ) => HasTypes s a where
61 ) => HasTypes s a where
105− types_ = typesUsing_ @ChGeneric
62+ types_ = types' @(Interesting s a)
106 {-# INLINE types_ #-}
63 {-# INLINE types_ #-}
108−--------------------------------------------------------------------------------
65+class HasTypes' (t :: Bool) s a where
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
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
66+ types' :: Traversal' s a
209−instance {-# OVERLAPPABLE #-}
68+instance
210− ( GHasTypes ch (Rep s) a
69+ ( GHasTypes (Rep s) a
211 , Generic s
70 , Generic s
212− -- if there's no Generic instance here, it means we got through the
71+ ) => HasTypes' 'True s a where
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
220− typesCustom f s = to <$> gtypes_ @ch f (from s)
72+ types' f s = to <$> gtypes_ f (from s)
221 --{-# INLINE types' #-}
73 --{-# INLINE types' #-}
75+instance HasTypes' 'False s a where
77+ --{-# INLINE types' #-}
224−-- | The default definition of 'Children'.
79+instance {-# OVERLAPPING #-} HasTypes Bool a
225−-- Primitive types from core libraries have no children, and other types are
80+instance {-# OVERLAPPING #-} HasTypes Char a
226−-- assumed to be 'Generic'.
81+instance {-# OVERLAPPING #-} HasTypes Double a
227−data ChGeneric
82+instance {-# OVERLAPPING #-} HasTypes Float a
228−type instance Children ChGeneric a = ChildrenDefault a
83+instance {-# OVERLAPPING #-} HasTypes Integer a
229−
84+instance {-# OVERLAPPING #-} HasTypes Ordering a
230−type family ChildrenDefault (a :: Type) :: [Type] where
85+instance {-# OVERLAPPING #-} HasTypes Int a
231− ChildrenDefault Char = '[]
86+instance {-# OVERLAPPING #-} HasTypes Int8 a
232− ChildrenDefault Double = '[]
87+instance {-# OVERLAPPING #-} HasTypes Int16 a
233− ChildrenDefault Float = '[]
88+instance {-# OVERLAPPING #-} HasTypes Int32 a
234− ChildrenDefault Integer = '[]
89+instance {-# OVERLAPPING #-} HasTypes Int64 a
235− ChildrenDefault Int = '[]
90+instance {-# OVERLAPPING #-} HasTypes Word a
236− ChildrenDefault Int8 = '[]
91+instance {-# OVERLAPPING #-} HasTypes Word8 a
237− ChildrenDefault Int16 = '[]
92+instance {-# OVERLAPPING #-} HasTypes Word16 a
238− ChildrenDefault Int32 = '[]
93+instance {-# OVERLAPPING #-} HasTypes Word32 a
239− ChildrenDefault Int64 = '[]
94+instance {-# OVERLAPPING #-} HasTypes Word64 a
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 #-}
276--------------------------------------------------------------------------------
96--------------------------------------------------------------------------------
278−class GHasTypes ch s a where
98+class GHasTypes s a where
279 gtypes_ :: Traversal' (s x) a
99 gtypes_ :: Traversal' (s x) a
282− ( GHasTypes ch l a
102+ ( GHasTypes l a
283− , GHasTypes ch r a
103+ , GHasTypes r a
284− ) => GHasTypes ch (l :*: r) a where
104+ ) => GHasTypes (l :*: r) a where
285− gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
105+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r
286 {-# INLINE gtypes_ #-}
106 {-# INLINE gtypes_ #-}
289− ( GHasTypes ch l a
109+ ( GHasTypes l a
290− , GHasTypes ch r a
110+ , GHasTypes r a
291− ) => GHasTypes ch (l :+: r) a where
111+ ) => GHasTypes (l :+: r) a where
292− gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l
112+ gtypes_ f (L1 l) = L1 <$> gtypes_ f l
293− gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r
113+ gtypes_ f (R1 r) = R1 <$> gtypes_ f r
294 {-# INLINE gtypes_ #-}
114 {-# INLINE gtypes_ #-}
296−instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
116+instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where
297− gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
117+ gtypes_ f (M1 s) = M1 <$> gtypes_ f s
298 {-# INLINE gtypes_ #-}
118 {-# INLINE gtypes_ #-}
300−-- | In the recursive case, we invoke 'HasTypesUsing' again, using the
302−instance HasTypesUsing ch b a => GHasTypes ch (Rec0 b) a where
120+instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where
303− gtypes_ f (K1 x) = K1 <$> typesUsing_ @ch @b @a f x
121+ gtypes_ f (K1 x) = K1 <$> f x
304 {-# INLINE gtypes_ #-}
122 {-# 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')
312−instance {-# OVERLAPPING #-} HasTypes b a => GHasTypes ChGeneric (Rec0 b) a where
124+instance HasTypes b a => GHasTypes (Rec0 b) a where
313− gtypes_ f (K1 x) = K1 <$> types_ @b @a f x
125+ gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x
314 {-# INLINE gtypes_ #-}
126 {-# INLINE gtypes_ #-}
316−instance GHasTypes ch U1 a where
128+instance GHasTypes U1 a where
317 gtypes_ _ _ = pure U1
129 gtypes_ _ _ = pure U1
318 {-# INLINE gtypes_ #-}
130 {-# INLINE gtypes_ #-}
320−instance GHasTypes ch V1 a where
132+instance GHasTypes V1 a where
321 gtypes_ _ = pure
133 gtypes_ _ = pure
322 {-# INLINE gtypes_ #-}
134 {-# INLINE gtypes_ #-}
324−type Interesting (ch :: Type) (a :: Type) (t :: Type)
136+type Interesting f a = Snd (Interesting' (Rep f) a '[f])
325− = Defined_list (Children ch t) (NoChildren ch t)
137+
326− (IsNothing (Interesting' ch a '[t] (Children ch t)))
328−type family NoChildren (ch :: Type) (a :: Type) :: Constraint where
138+type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where
329− NoChildren ch a = PrettyError
139+ Interesting' (M1 _ m f) t seen
330− '[ 'Text "No type family instance for " ':<>: QuoteType (Children ch a)
140+ = Interesting' f t seen
331− , 'Text "arising from a traversal over " ':<>: QuoteType a
141+ -- The result of the left branch is passed on to the right branch in order to avoid duplicate work
332− , 'Text "with custom strategy " ':<>: QuoteType ch
142+ Interesting' (l :*: r) t seen
333− ]
143+ = InterestingOr (Interesting' l t seen) r t
336−type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
337− Interesting' ch _ seen '[] = 'Just seen
144+ Interesting' (l :+: r) t seen
338− Interesting' ch a seen (t ': ts) =
145+ = InterestingOr (Interesting' l t seen) r t
146+ Interesting' (Rec0 t) t seen
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
339− InterestingOr ch a (InterestingUnless ch a seen t (Elem t seen)) ts
163+ = InterestingUnless (Elem r seen) (Rep r) t r seen
164+ Interesting' _ _ seen
341-- Short circuit
167-- 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)
168+-- Note: we only insert 'r' to the seen list if it's not already there (which is precisely when `s` is 'False)
343−type family InterestingUnless
169+type family InterestingUnless (s :: Bool) f (a :: Type) (r :: Type) (seen :: [Type]) :: ([Type], Bool) where
344− (ch :: Type) (a :: Type) (seen :: [Type]) (t :: Type) (alreadySeen :: Bool) ::
346− InterestingUnless ch a seen a _ = 'Nothing
170+ InterestingUnless 'True _ _ _ seen = '(seen, 'False)
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))
171+ InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)
352-- Short circuit
173-- Short circuit
353−type family InterestingOr
174+type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where
354− (ch :: Type) (a :: Type) (seen' :: Maybe [Type]) (ts :: [Type]) ::
356− InterestingOr ch a 'Nothing _ = 'Nothing
175+ InterestingOr '(seen, 'True) _ _ = '(seen, 'True)
357− InterestingOr ch a ('Just seen) ts = Interesting' ch a seen ts
176+ InterestingOr '(seen, 'False) r t = Interesting' r t seen
359type family Elem a as where
178type family Elem a as where
360 Elem a (a ': _) = 'True
179 Elem a (a ': _) = 'True
361 Elem a (_ ': as) = Elem a as
180 Elem a (_ ': as) = Elem a as
362 Elem a '[] = 'False
181 Elem a '[] = 'False
364−type family IsNothing a where
183+type family Snd a where
365− IsNothing ('Just _) = 'False
184+ Snd '(_, b) = b
366− IsNothing 'Nothing = 'True