@@ -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,29 @@
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−
4136 , HasTypesUsing
4237 , typesUsing
4338
44− , HasTypesCustom (typesCustom)
39+ , HasTypes'
40+ , types'
4541
42+ , Children
43+ , ChDefault
4644 ) where
4745
4846import Data.Kind
4947import Data.Int (Int8, Int16, Int32, Int64)
5048import Data.Word (Word, Word8, Word16, Word32, Word64)
51−import qualified Data.Text as T
5249
5350import GHC.Generics
54−import GHC.TypeLits
5551import 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−--------------------------------------------------------------------------------
7852
7953-- TODO [1.0.0.0]: use type-changing variant internally
8054
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.
9155types :: forall a s. HasTypes s a => Traversal' s a
9256types = types_ @s @a
9357{-# INLINE types #-}
@@ -100,55 +64,100 @@ class HasTypes s a where
10064 {-# INLINE types_ #-}
10165
10266instance
103− ( HasTypesUsing ChGeneric s a
67+ ( HasTypesUsing ChDefault s a
10468 ) => HasTypes s a where
105− types_ = typesUsing_ @ChGeneric
69+ types_ = typesUsing @ChDefault
10670 {-# INLINE types_ #-}
10771
108−--------------------------------------------------------------------------------
109−data Void
110−instance {-# OVERLAPPING #-} HasTypes Void a where
111− types_ _ = pure
72+class HasTypesUsing (ch :: Type) s a where
73+ typesUsing :: Traversal' s a
11274
113−instance {-# OVERLAPPING #-} HasTypes s Void where
114− types_ _ = pure
75+instance
76+ ( HasTypes1 ch (Interesting ch a s) s a
77+ ) => HasTypesUsing ch s a where
78+ typesUsing = types1 @ch @(Interesting ch a s)
79+ {-# INLINE typesUsing #-}
11580
116−instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where
117− typesUsing_ _ = pure
81+class HasTypes0 (ch :: Type) s a where
82+ types0 :: Traversal' s a
11883
119−instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
120− typesUsing_ _ = pure
121−--------------------------------------------------------------------------------
84+instance {-# OVERLAPPING #-} HasTypes0 ch a a where
85+ types0 = id
86+
87+instance
88+ ( HasTypes1 ch (Interesting ch a s) s a
89+ ) => HasTypes0 ch s a where
90+ types0 = types1 @ch @(Interesting ch a s)
91+
92+class HasTypes1 (ch :: Type) (t :: Bool) s a where
93+ types1 :: Traversal' s a
94+
95+instance HasTypes' ch s a => HasTypes1 ch 'True s a where
96+ types1 = types' @ch
97+
98+instance HasTypes1 ch 'False s a where
99+ types1 _ = pure
100+ --{-# INLINE types1 #-}
101+
102+class HasTypes' (ch :: Type) s a where
103+ types' :: Traversal' s a
104+
105+instance
106+ ( GHasTypes ch (Rep s) a
107+ , Generic s
108+ ) => HasTypes' ch s a where
109+ types' f s = to <$> gtypes_ @ch f (from s)
110+ --{-# INLINE types' #-}
122111
123−--------------------------------------------------------------------------------
124−-- HasTypesUsing
125112--------------------------------------------------------------------------------
126113
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.
114+class GHasTypes ch s a where
115+ gtypes_ :: Traversal' (s x) a
116+
117+instance
118+ ( GHasTypes ch l a
119+ , GHasTypes ch r a
120+ ) => GHasTypes ch (l :*: r) a where
121+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
122+ {-# INLINE gtypes_ #-}
123+
124+instance
125+ ( GHasTypes ch l a
126+ , GHasTypes ch r a
127+ ) => GHasTypes ch (l :+: r) a where
128+ gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l
129+ gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r
130+ {-# INLINE gtypes_ #-}
131+
132+instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
133+ gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
134+ {-# INLINE gtypes_ #-}
135+
136+instance HasTypes0 ch b a => GHasTypes ch (Rec0 b) a where
137+ gtypes_ f (K1 x) = K1 <$> types0 @ch @b @a f x
138+ {-# INLINE gtypes_ #-}
139+
140+instance GHasTypes ch U1 a where
141+ gtypes_ _ _ = pure U1
142+ {-# INLINE gtypes_ #-}
143+
144+instance GHasTypes ch V1 a where
145+ gtypes_ _ = pure
146+ {-# INLINE gtypes_ #-}
147+
148+type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
149+ ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs
150+ ChildrenGeneric (l :*: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
151+ ChildrenGeneric (l :+: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
152+ ChildrenGeneric (Rec0 a) cs = a ': cs
153+ ChildrenGeneric _ cs = cs
145154
146155-- | The children of a type are the types of its fields.
147156-- The 'Children' type family maps a type @a@ to its set of children.
148157--
149158-- This type family is parameterized by a symbol @ch@ (that can be declared as
150159-- an empty data type).
151−-- The symbol 'ChGeneric' provides a default definition. You can create new
160+-- The symbol 'ChDefault' provides a default definition. You can create new
152161-- symbols to override the set of children of abstract, non-generic types.
153162--
154163-- The following example declares a @Custom@ symbol to redefine 'Children'
@@ -163,69 +172,17 @@ instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
163172-- ChildrenCustom NominalDiffTime = '[]
164173-- -- Add more custom mappings here.
165174--
166−-- ChildrenCustom a = Children ChGeneric a
175+-- ChildrenCustom a = Children ChDefault a
167176-- @
168177--
169178-- To use this definition, replace 'types' with @'typesUsing' \@Custom@.
170179type family Children (ch :: Type) (a :: Type) :: [Type]
171180
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
211− , 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)
221− --{-# INLINE types' #-}
222−
223−
224181-- | The default definition of 'Children'.
225182-- Primitive types from core libraries have no children, and other types are
226183-- assumed to be 'Generic'.
227−data ChGeneric
228−type instance Children ChGeneric a = ChildrenDefault a
184+data ChDefault
185+type instance Children ChDefault a = ChildrenDefault a
229186
230187type family ChildrenDefault (a :: Type) :: [Type] where
231188 ChildrenDefault Char = '[]
@@ -242,96 +199,10 @@ type family ChildrenDefault (a :: Type) :: [Type] where
242199 ChildrenDefault Word16 = '[]
243200 ChildrenDefault Word32 = '[]
244201 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 #-}
275−
276−--------------------------------------------------------------------------------
277−
278−class GHasTypes ch s a where
279− gtypes_ :: Traversal' (s x) a
280−
281−instance
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
286− {-# INLINE gtypes_ #-}
287−
288−instance
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
294− {-# INLINE gtypes_ #-}
295−
296−instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
297− gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
298− {-# INLINE gtypes_ #-}
299−
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
304− {-# INLINE gtypes_ #-}
305−
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
314− {-# INLINE gtypes_ #-}
315−
316−instance GHasTypes ch U1 a where
317− gtypes_ _ _ = pure U1
318− {-# INLINE gtypes_ #-}
319−
320−instance GHasTypes ch V1 a where
321− gtypes_ _ = pure
322− {-# INLINE gtypes_ #-}
202+ ChildrenDefault a = ChildrenGeneric (Rep a) '[]
323203
324204type 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−
205+ = IsNothing (Interesting' ch a '[t] (Children ch t))
335206
336207type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
337208 Interesting' ch _ seen '[] = 'Just seen
@@ -345,9 +216,7 @@ type family InterestingUnless
345216 Maybe [Type] where
346217 InterestingUnless ch a seen a _ = 'Nothing
347218 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))
219+ InterestingUnless ch a seen t 'False = Interesting' ch a (t ': seen) (Children ch t)
351220
352221-- Short circuit
353222type family InterestingOr