@@ -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,18 @@
29module Data.Generics.Product.Types
29module Data.Generics.Product.Types
30 ( -- *Traversals
30 ( -- *Traversals
32− -- $setup
32+ -- $example
36− -- * Custom traversal strategies
44− , HasTypesCustom (typesCustom)
48import Data.Kind
37import 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
53import GHC.Generics
39import GHC.Generics
55import Data.Generics.Internal.VL.Traversal
40import 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
42-- 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
44types :: forall a s. HasTypes s a => Traversal' s a
92types = types_ @s @a
45types = types_ @s @a
93{-# INLINE types #-}
46{-# INLINE types #-}
@@ -100,268 +53,111 @@ class HasTypes s a where
100 {-# INLINE types_ #-}
53 {-# INLINE types_ #-}
103− ( HasTypesUsing ChGeneric s a
56+ ( HasTypes' (Interesting s a) s a
104 ) => HasTypes s a where
57 ) => HasTypes s a where
105− types_ = typesUsing_ @ChGeneric
58+ types_ = types' @(Interesting s a)
106 {-# INLINE types_ #-}
59 {-# INLINE types_ #-}
108−--------------------------------------------------------------------------------
61+class HasTypes' (t :: Bool) s a where
109−data Void
62+ types' :: Traversal' s a
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
64+instance
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
209−instance {-# OVERLAPPABLE #-}
210− ( GHasTypes ch (Rep s) a
65+ ( GHasTypes (Rep s) a
211 , Generic s
66 , Generic s
212− -- if there's no Generic instance here, it means we got through the
67+ ) => 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)
68+ types' f s = to <$> gtypes_ f (from s)
221 --{-# INLINE types' #-}
69 --{-# INLINE types' #-}
71+instance HasTypes' 'False s a where
73+ --{-# INLINE types' #-}
224−-- | The default definition of 'Children'.
75+instance {-# OVERLAPPING #-} HasTypes Bool a
225−-- Primitive types from core libraries have no children, and other types are
76+instance {-# OVERLAPPING #-} HasTypes Char a
226−-- assumed to be 'Generic'.
77+instance {-# OVERLAPPING #-} HasTypes Double a
227−data ChGeneric
78+instance {-# OVERLAPPING #-} HasTypes Float a
228−type instance Children ChGeneric a = ChildrenDefault a
79+instance {-# OVERLAPPING #-} HasTypes Int a
229−
80+instance {-# OVERLAPPING #-} HasTypes Integer a
230−type family ChildrenDefault (a :: Type) :: [Type] where
81+instance {-# OVERLAPPING #-} HasTypes Ordering a
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 = '[]
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--------------------------------------------------------------------------------
83--------------------------------------------------------------------------------
278−class GHasTypes ch s a where
85+class GHasTypes s a where
279 gtypes_ :: Traversal' (s x) a
86 gtypes_ :: Traversal' (s x) a
282− ( GHasTypes ch l a
89+ ( GHasTypes l a
283− , GHasTypes ch r a
90+ , GHasTypes r a
284− ) => GHasTypes ch (l :*: r) a where
91+ ) => GHasTypes (l :*: r) a where
285− gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
92+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r
286 {-# INLINE gtypes_ #-}
93 {-# INLINE gtypes_ #-}
289− ( GHasTypes ch l a
96+ ( GHasTypes l a
290− , GHasTypes ch r a
97+ , GHasTypes r a
291− ) => GHasTypes ch (l :+: r) a where
98+ ) => GHasTypes (l :+: r) a where
292− gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l
99+ gtypes_ f (L1 l) = L1 <$> gtypes_ f l
293− gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r
100+ gtypes_ f (R1 r) = R1 <$> gtypes_ f r
294 {-# INLINE gtypes_ #-}
101 {-# INLINE gtypes_ #-}
296−instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
103+instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where
297− gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
104+ gtypes_ f (M1 s) = M1 <$> gtypes_ f s
298 {-# INLINE gtypes_ #-}
105 {-# 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
107+instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where
303− gtypes_ f (K1 x) = K1 <$> typesUsing_ @ch @b @a f x
108+ gtypes_ f (K1 x) = K1 <$> f x
304 {-# INLINE gtypes_ #-}
109 {-# 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
111+instance HasTypes b a => GHasTypes (Rec0 b) a where
313− gtypes_ f (K1 x) = K1 <$> types_ @b @a f x
112+ gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x
314 {-# INLINE gtypes_ #-}
113 {-# INLINE gtypes_ #-}
316−instance GHasTypes ch U1 a where
115+instance GHasTypes U1 a where
317 gtypes_ _ _ = pure U1
116 gtypes_ _ _ = pure U1
318 {-# INLINE gtypes_ #-}
117 {-# INLINE gtypes_ #-}
320−instance GHasTypes ch V1 a where
119+instance GHasTypes V1 a where
321 gtypes_ _ = pure
120 gtypes_ _ = pure
322 {-# INLINE gtypes_ #-}
121 {-# INLINE gtypes_ #-}
324−type Interesting (ch :: Type) (a :: Type) (t :: Type)
123+type Interesting f a = Snd (Interesting' (Rep f) a '[f])
325− = Defined_list (Children ch t) (NoChildren ch t)
124+
125+type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where
126+ Interesting' (M1 _ m f) t seen
326− (IsNothing (Interesting' ch a '[t] (Children ch t)))
127+ = Interesting' f t seen
327−
128+ -- The result of the left branch is passed on to the right branch in order to avoid duplicate work
328−type family NoChildren (ch :: Type) (a :: Type) :: Constraint where
129+ Interesting' (l :*: r) t seen
329− NoChildren ch a = PrettyError
130+ = InterestingOr (Interesting' l t seen) r t
330− '[ 'Text "No type family instance for " ':<>: QuoteType (Children ch a)
131+ Interesting' (l :+: r) t seen
331− , 'Text "arising from a traversal over " ':<>: QuoteType a
132+ = InterestingOr (Interesting' l t seen) r t
332− , 'Text "with custom strategy " ':<>: QuoteType ch
133+ Interesting' (Rec0 t) t seen
333− ]
134+ = '(seen, 'True)
334−
135+ Interesting' (Rec0 Char) _ seen = '(seen ,'False)
335−
136+ Interesting' (Rec0 Double) _ seen = '(seen ,'False)
336−type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
137+ Interesting' (Rec0 Float) _ seen = '(seen ,'False)
337− Interesting' ch _ seen '[] = 'Just seen
138+ Interesting' (Rec0 Int) _ seen = '(seen ,'False)
338− Interesting' ch a seen (t ': ts) =
139+ Interesting' (Rec0 Integer) _ seen = '(seen ,'False)
140+ Interesting' (Rec0 r) t seen
339− InterestingOr ch a (InterestingUnless ch a seen t (Elem t seen)) ts
141+ = InterestingUnless (Elem r seen) (Rep r) t r seen
142+ Interesting' _ _ seen
341-- Short circuit
145-- 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)
146+-- 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
147+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
148+ 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))
149+ InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)
352-- Short circuit
151-- Short circuit
353−type family InterestingOr
152+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
153+ InterestingOr '(seen, 'True) _ _ = '(seen, 'True)
357− InterestingOr ch a ('Just seen) ts = Interesting' ch a seen ts
154+ InterestingOr '(seen, 'False) r t = Interesting' r t seen
359type family Elem a as where
156type family Elem a as where
360 Elem a (a ': _) = 'True
157 Elem a (a ': _) = 'True
361 Elem a (_ ': as) = Elem a as
158 Elem a (_ ': as) = Elem a as
362 Elem a '[] = 'False
159 Elem a '[] = 'False
364−type family IsNothing a where
161+type family Snd a where
365− IsNothing ('Just _) = 'False
162+ Snd '(_, b) = b
366− IsNothing 'Nothing = 'True