@@ -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,29 @@
29module Data.Generics.Product.Types
29module Data.Generics.Product.Types
30 ( -- *Traversals
30 ( -- *Traversals
32− -- $setup
32+ -- $example
36− -- * Custom traversal strategies
41 , HasTypesUsing
36 , HasTypesUsing
42 , typesUsing
37 , typesUsing
44− , HasTypesCustom (typesCustom)
39+ , HasTypes'
48import Data.Kind
46import Data.Kind
49import Data.Int (Int8, Int16, Int32, Int64)
47import Data.Int (Int8, Int16, Int32, Int64)
50import Data.Word (Word, Word8, Word16, Word32, Word64)
48import Data.Word (Word, Word8, Word16, Word32, Word64)
51−import qualified Data.Text as T
53import GHC.Generics
50import GHC.Generics
55import Data.Generics.Internal.VL.Traversal
51import 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
53-- 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
55types :: forall a s. HasTypes s a => Traversal' s a
92types = types_ @s @a
56types = types_ @s @a
93{-# INLINE types #-}
57{-# INLINE types #-}
@@ -100,55 +64,100 @@ class HasTypes s a where
100 {-# INLINE types_ #-}
64 {-# INLINE types_ #-}
103− ( HasTypesUsing ChGeneric s a
67+ ( HasTypesUsing ChDefault s a
104 ) => HasTypes s a where
68 ) => HasTypes s a where
105− types_ = typesUsing_ @ChGeneric
69+ types_ = typesUsing @ChDefault
106 {-# INLINE types_ #-}
70 {-# INLINE types_ #-}
108−--------------------------------------------------------------------------------
72+class HasTypesUsing (ch :: Type) s a where
109−data Void
73+ typesUsing :: Traversal' s a
110−instance {-# OVERLAPPING #-} HasTypes Void a where
113−instance {-# OVERLAPPING #-} HasTypes s Void where
75+instance
114− types_ _ = pure
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 #-}
116−instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where
81+class HasTypes0 (ch :: Type) s a where
117− typesUsing_ _ = pure
82+ types0 :: Traversal' s a
119−instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
84+instance {-# OVERLAPPING #-} HasTypes0 ch a a where
120− typesUsing_ _ = pure
85+ types0 = id
121−--------------------------------------------------------------------------------
86+
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' #-}
123−--------------------------------------------------------------------------------
125--------------------------------------------------------------------------------
112--------------------------------------------------------------------------------
127−-- $custom
114+class GHasTypes ch s a where
128−--
115+ gtypes_ :: Traversal' (s x) a
129−-- The default traversal strategy 'types' recurses into each node of the type
116+
130−-- using the 'Generic' instance for the nodes. However, in general not all
117+instance
131−-- nodes will have a 'Generic' instance. For example:
118+ ( GHasTypes ch l a
132−--
119+ , GHasTypes ch r a
133−-- >>> data Opaque = Opaque String deriving Show
120+ ) => GHasTypes ch (l :*: r) a where
134−-- >>> myTree = WithWeight (Fork (Leaf (Opaque "foo")) (Leaf (Opaque "bar"))) False
121+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
135−-- >>> over (types @String) (++ "!") myTree
122+ {-# INLINE gtypes_ #-}
137−-- ... | No instance for ‘Generic Opaque’
124+instance
138−-- ... | arising from a generic traversal.
125+ ( GHasTypes ch l a
139−-- ... | Either derive the instance, or define a custom traversal using ‘HasTypesCustom’
126+ , GHasTypes ch r a
140−-- ...
127+ ) => GHasTypes ch (l :+: r) a where
141−--
128+ gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l
142−-- In these cases, we can define a custom traversal strategy to override the
129+ gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r
143−-- generic behaviour for certain types.
130+ {-# INLINE gtypes_ #-}
144−-- For a self-contained example, see the CustomChildren module in the tests directory.
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_ #-}
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_ #-}
140+instance GHasTypes ch U1 a where
141+ gtypes_ _ _ = pure U1
142+ {-# INLINE gtypes_ #-}
144+instance GHasTypes ch V1 a where
146+ {-# INLINE gtypes_ #-}
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
146-- | The children of a type are the types of its fields.
155-- | 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.
156-- 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
158-- This type family is parameterized by a symbol @ch@ (that can be declared as
150-- an empty data type).
159-- 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
152-- symbols to override the set of children of abstract, non-generic types.
161-- symbols to override the set of children of abstract, non-generic types.
154-- The following example declares a @Custom@ symbol to redefine 'Children'
163-- The following example declares a @Custom@ symbol to redefine 'Children'
@@ -163,69 +172,17 @@ instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
163-- ChildrenCustom NominalDiffTime = '[]
172-- ChildrenCustom NominalDiffTime = '[]
164-- -- Add more custom mappings here.
173-- -- Add more custom mappings here.
166−-- ChildrenCustom a = Children ChGeneric a
175+-- ChildrenCustom a = Children ChDefault a
169-- To use this definition, replace 'types' with @'typesUsing' \@Custom@.
178-- To use this definition, replace 'types' with @'typesUsing' \@Custom@.
170type family Children (ch :: Type) (a :: Type) :: [Type]
179type 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' #-}
224-- | The default definition of 'Children'.
181-- | The default definition of 'Children'.
225-- Primitive types from core libraries have no children, and other types are
182-- Primitive types from core libraries have no children, and other types are
226-- assumed to be 'Generic'.
183-- assumed to be 'Generic'.
227−data ChGeneric
184+data ChDefault
228−type instance Children ChGeneric a = ChildrenDefault a
185+type instance Children ChDefault a = ChildrenDefault a
230type family ChildrenDefault (a :: Type) :: [Type] where
187type family ChildrenDefault (a :: Type) :: [Type] where
231 ChildrenDefault Char = '[]
188 ChildrenDefault Char = '[]
@@ -242,96 +199,10 @@ type family ChildrenDefault (a :: Type) :: [Type] where
242 ChildrenDefault Word16 = '[]
199 ChildrenDefault Word16 = '[]
243 ChildrenDefault Word32 = '[]
200 ChildrenDefault Word32 = '[]
244 ChildrenDefault Word64 = '[]
201 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) '[])
202+ ChildrenDefault a = 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_ #-}
324type Interesting (ch :: Type) (a :: Type) (t :: Type)
204type 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)))
205+ = 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
336type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
207type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
337 Interesting' ch _ seen '[] = 'Just seen
208 Interesting' ch _ seen '[] = 'Just seen
@@ -345,9 +216,7 @@ type family InterestingUnless
345 Maybe [Type] where
216 Maybe [Type] where
346 InterestingUnless ch a seen a _ = 'Nothing
217 InterestingUnless ch a seen a _ = 'Nothing
347 InterestingUnless ch a seen t 'True = 'Just seen
218 InterestingUnless ch a seen t 'True = 'Just seen
348− InterestingUnless ch a seen t 'False
219+ InterestingUnless ch a seen t 'False = Interesting' ch a (t ': seen) (Children ch t)
349− = Defined_list (Children ch t) (NoChildren ch t)
350− (Interesting' ch a (t ': seen) (Children ch t))
352-- Short circuit
221-- Short circuit
353type family InterestingOr
222type family InterestingOr