@@ -16,7 +16,7 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
18-- Module : Data.Generics.Product.Types
18-- Module : Data.Generics.Product.Types
19−-- Copyright : (C) 2018 Csongor Kiss
19+-- Copyright : (C) 2019 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,29 +29,65 @@
29module Data.Generics.Product.Types
29module Data.Generics.Product.Types
30 ( -- *Traversals
30 ( -- *Traversals
32− -- $example
32+ -- $setup
36+ -- * Custom traversal strategies
36 , HasTypesUsing
41 , HasTypesUsing
37 , typesUsing
42 , typesUsing
39− , HasTypes'
44+ , HasTypesCustom (typesCustom)
46import Data.Kind
48import Data.Kind
47import Data.Int (Int8, Int16, Int32, Int64)
49import Data.Int (Int8, Int16, Int32, Int64)
48import Data.Word (Word, Word8, Word16, Word32, Word64)
50import Data.Word (Word, Word8, Word16, Word32, Word64)
51+import qualified Data.Text as T
50import GHC.Generics
53import GHC.Generics
51import Data.Generics.Internal.VL.Traversal
55import 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+--------------------------------------------------------------------------------
53-- TODO [1.0.0.0]: use type-changing variant internally
79-- 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.
55types :: forall a s. HasTypes s a => Traversal' s a
91types :: forall a s. HasTypes s a => Traversal' s a
56types = types_ @s @a
92types = types_ @s @a
57{-# INLINE types #-}
93{-# INLINE types #-}
@@ -64,100 +100,55 @@ class HasTypes s a where
64 {-# INLINE types_ #-}
100 {-# INLINE types_ #-}
67− ( HasTypesUsing ChDefault s a
103+ ( HasTypesUsing ChGeneric s a
68 ) => HasTypes s a where
104 ) => HasTypes s a where
69− types_ = typesUsing @ChDefault
105+ types_ = typesUsing_ @ChGeneric
70 {-# INLINE types_ #-}
106 {-# INLINE types_ #-}
72−class HasTypesUsing (ch :: Type) s a where
73− typesUsing :: Traversal' s a
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 #-}
81−class HasTypes0 (ch :: Type) s a where
82− types0 :: Traversal' s a
84−instance {-# OVERLAPPING #-} HasTypes0 ch a a where
88− ( HasTypes1 ch (Interesting ch a s) s a
89− ) => HasTypes0 ch s a where
90− types0 = types1 @ch @(Interesting ch a s)
92−class HasTypes1 (ch :: Type) (t :: Bool) s a where
93− types1 :: Traversal' s a
95−instance HasTypes' ch s a => HasTypes1 ch 'True s a where
98−instance HasTypes1 ch 'False s a where
100− --{-# INLINE types1 #-}
102−class HasTypes' (ch :: Type) s a where
103− types' :: Traversal' s a
106− ( GHasTypes ch (Rep s) a
108− ) => HasTypes' ch s a where
109− types' f s = to <$> gtypes_ @ch f (from s)
110− --{-# INLINE types' #-}
112--------------------------------------------------------------------------------
108--------------------------------------------------------------------------------
110+instance {-# OVERLAPPING #-} HasTypes Void a where
114−class GHasTypes ch s a where
113+instance {-# OVERLAPPING #-} HasTypes s Void where
115− gtypes_ :: Traversal' (s x) a
114+ types_ _ = pure
120− ) => GHasTypes ch (l :*: r) a where
121− gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
122− {-# INLINE gtypes_ #-}
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_ #-}
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_ #-}
136−instance HasTypes0 ch b a => GHasTypes ch (Rec0 b) a where
116+instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where
137− gtypes_ f (K1 x) = K1 <$> types0 @ch @b @a f x
117+ typesUsing_ _ = pure
138− {-# INLINE gtypes_ #-}
140−instance GHasTypes ch U1 a where
119+instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
141− gtypes_ _ _ = pure U1
120+ typesUsing_ _ = pure
142− {-# INLINE gtypes_ #-}
121+--------------------------------------------------------------------------------
144−instance GHasTypes ch V1 a where
123+--------------------------------------------------------------------------------
145− gtypes_ _ = pure
124+-- HasTypesUsing
146− {-# INLINE gtypes_ #-}
125+--------------------------------------------------------------------------------
148−type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
127+-- $custom
149− ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs
128+--
150− ChildrenGeneric (l :*: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
129+-- The default traversal strategy 'types' recurses into each node of the type
151− ChildrenGeneric (l :+: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
130+-- using the 'Generic' instance for the nodes. However, in general not all
152− ChildrenGeneric (Rec0 a) cs = a ': cs
131+-- nodes will have a 'Generic' instance. For example:
153− ChildrenGeneric _ cs = cs
132+--
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.
155-- | The children of a type are the types of its fields.
146-- | The children of a type are the types of its fields.
156-- The 'Children' type family maps a type @a@ to its set of children.
147-- The 'Children' type family maps a type @a@ to its set of children.
158-- This type family is parameterized by a symbol @ch@ (that can be declared as
149-- This type family is parameterized by a symbol @ch@ (that can be declared as
159-- an empty data type).
150-- an empty data type).
160−-- The symbol 'ChDefault' provides a default definition. You can create new
151+-- The symbol 'ChGeneric' provides a default definition. You can create new
161-- symbols to override the set of children of abstract, non-generic types.
152-- symbols to override the set of children of abstract, non-generic types.
163-- The following example declares a @Custom@ symbol to redefine 'Children'
154-- The following example declares a @Custom@ symbol to redefine 'Children'
@@ -172,17 +163,69 @@ type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
172-- ChildrenCustom NominalDiffTime = '[]
163-- ChildrenCustom NominalDiffTime = '[]
173-- -- Add more custom mappings here.
164-- -- Add more custom mappings here.
175−-- ChildrenCustom a = Children ChDefault a
166+-- ChildrenCustom a = Children ChGeneric a
178-- To use this definition, replace 'types' with @'typesUsing' \@Custom@.
169-- To use this definition, replace 'types' with @'typesUsing' \@Custom@.
179type family Children (ch :: Type) (a :: Type) :: [Type]
170type 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
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
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)
221+ --{-# INLINE types' #-}
181-- | The default definition of 'Children'.
224-- | The default definition of 'Children'.
182-- Primitive types from core libraries have no children, and other types are
225-- Primitive types from core libraries have no children, and other types are
183-- assumed to be 'Generic'.
226-- assumed to be 'Generic'.
184−data ChDefault
227+data ChGeneric
185−type instance Children ChDefault a = ChildrenDefault a
228+type instance Children ChGeneric a = ChildrenDefault a
187type family ChildrenDefault (a :: Type) :: [Type] where
230type family ChildrenDefault (a :: Type) :: [Type] where
188 ChildrenDefault Char = '[]
231 ChildrenDefault Char = '[]
@@ -199,10 +242,96 @@ type family ChildrenDefault (a :: Type) :: [Type] where
199 ChildrenDefault Word16 = '[]
242 ChildrenDefault Word16 = '[]
200 ChildrenDefault Word32 = '[]
243 ChildrenDefault Word32 = '[]
201 ChildrenDefault Word64 = '[]
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
202− ChildrenDefault a = ChildrenGeneric (Rep a) '[]
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+--------------------------------------------------------------------------------
278+class GHasTypes ch s a where
279+ gtypes_ :: Traversal' (s x) a
284+ ) => GHasTypes ch (l :*: r) a where
285+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
286+ {-# INLINE gtypes_ #-}
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_ #-}
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_ #-}
300+-- | In the recursive case, we invoke 'HasTypesUsing' again, using the
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_ #-}
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_ #-}
316+instance GHasTypes ch U1 a where
317+ gtypes_ _ _ = pure U1
318+ {-# INLINE gtypes_ #-}
320+instance GHasTypes ch V1 a where
322+ {-# INLINE gtypes_ #-}
204type Interesting (ch :: Type) (a :: Type) (t :: Type)
324type Interesting (ch :: Type) (a :: Type) (t :: Type)
325+ = Defined_list (Children ch t) (NoChildren ch t)
205− = IsNothing (Interesting' ch a '[t] (Children ch t))
326+ (IsNothing (Interesting' ch a '[t] (Children ch t)))
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
207type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
336type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
208 Interesting' ch _ seen '[] = 'Just seen
337 Interesting' ch _ seen '[] = 'Just seen
@@ -216,7 +345,9 @@ type family InterestingUnless
216 Maybe [Type] where
345 Maybe [Type] where
217 InterestingUnless ch a seen a _ = 'Nothing
346 InterestingUnless ch a seen a _ = 'Nothing
218 InterestingUnless ch a seen t 'True = 'Just seen
347 InterestingUnless ch a seen t 'True = 'Just seen
219− InterestingUnless ch a seen t 'False = Interesting' ch a (t ': seen) (Children ch t)
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))
221-- Short circuit
352-- Short circuit
222type family InterestingOr
353type family InterestingOr