@@ -1,3 +1,4 @@
1+{-# LANGUAGE DefaultSignatures #-}
12{-# LANGUAGE AllowAmbiguousTypes #-}
23{-# LANGUAGE ConstraintKinds #-}
34{-# LANGUAGE DataKinds #-}
@@ -34,7 +35,6 @@ module Data.Generics.Product.Types
3435 ) where
3536
3637import Data.Generics.Product.Internal.Types
37−import Data.Kind (Constraint)
3838
3939import GHC.Generics
4040import Data.Generics.Internal.VL.Traversal
@@ -53,65 +53,57 @@ instance
5353class HasTypesDeep a s where
5454 typesDeep :: Traversal' s a
5555
56−class Or a b where
57− foldOr :: Applicative g => (a -> g a) -> b -> g b
58−
59−instance Or a a where
60− foldOr f a = f a
61−
62−instance {-# OVERLAPPABLE #-} Or a b where
63− foldOr _ = pure
56+ default typesDeep :: Traversal' s a
57+ typesDeep _ = pure
6458
6559instance
66− ( HasConstraints' (Or a) s
60+ ( GHasTypesDeep a (Rep s)
61+ , Generic s
6762 ) => HasTypesDeep a s where
63+ typesDeep f s = to <$> gtypesDeep f (from s)
6864
69− typesDeep f s = constraints' @(Or a) (foldOr f) s
65+instance {-# OVERLAPPING #-} HasTypesDeep a Bool
66+instance {-# OVERLAPPING #-} HasTypesDeep a Char
67+instance {-# OVERLAPPING #-} HasTypesDeep a Double
68+instance {-# OVERLAPPING #-} HasTypesDeep a Float
69+instance {-# OVERLAPPING #-} HasTypesDeep a Int
70+instance {-# OVERLAPPING #-} HasTypesDeep a Integer
71+instance {-# OVERLAPPING #-} HasTypesDeep a Ordering
7072
7173--------------------------------------------------------------------------------
72−type family Primitive a :: Bool where
73− Primitive Int = 'True
74− Primitive Char = 'True
75− Primitive Bool = 'True
76− Primitive Integer = 'True
77− Primitive _ = 'False
78− -- TODO: more primitives, or perhaps abstract from stop condition
79−
80−-- TODO: refactor
81−-- deep constrained traversals, stopping at primitive types
82−class HasConstraints' (c :: * -> Constraint) s where
83− constraints' :: forall g.
84− Applicative g => (forall a. c a => a -> g a) -> s -> g s
85−
86−instance (Generic s, GHasConstraints' c (Rep s)) => HasConstraints' c s where
87− constraints' f s = to <$> gconstraints' @c f (from s)
88−
89−class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where
90− gconstraints' :: forall g x.
91− Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
92−
93−instance (GHasConstraints' c l, GHasConstraints' c r) => GHasConstraints' c (l :*: r) where
94− gconstraints' f (l :*: r) = (:*:) <$> gconstraints' @c f l <*> gconstraints' @c f r
9574
96−instance (GHasConstraints' c l, GHasConstraints' c r) => GHasConstraints' c (l :+: r) where
97− gconstraints' f (L1 l) = L1 <$> gconstraints' @c f l
98− gconstraints' f (R1 r) = R1 <$> gconstraints' @c f r
75+class GHasTypesDeep a s where
76+ gtypesDeep :: Traversal' (s x) a
9977
100−instance GRec c (Primitive a) (K1 R a) => GHasConstraints' c (K1 R a) where
101− gconstraints' = grec @c @(Primitive a)
102−
103−instance GHasConstraints' c f => GHasConstraints' c (M1 m meta f) where
104− gconstraints' f (M1 x) = M1 <$> gconstraints' @c f x
105−
106−instance GHasConstraints' c U1 where
107− gconstraints' _ _ = pure U1
108−
109−class GRec (c :: * -> Constraint) (s :: Bool) (f :: * -> *) where
110− grec :: forall g x.
111− Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
112−
113−instance HasConstraints' c a => GRec c 'False (K1 R a) where
114− grec f (K1 s) = K1 <$> constraints' @c @a f s
78+instance
79+ ( GHasTypesDeep a l
80+ , GHasTypesDeep a r
81+ ) => GHasTypesDeep a (l :*: r) where
82+ gtypesDeep f (l :*: r) = (:*:) <$> gtypesDeep f l <*> gtypesDeep f r
83+ {-# INLINE gtypesDeep #-}
11584
116−instance c a => GRec c 'True (K1 R a) where
117− grec f s = kIso f s
85+instance
86+ ( GHasTypesDeep a l
87+ , GHasTypesDeep a r
88+ ) => GHasTypesDeep a (l :+: r) where
89+ gtypesDeep f (L1 l) = L1 <$> gtypesDeep f l
90+ gtypesDeep f (R1 r) = R1 <$> gtypesDeep f r
91+ {-# INLINE gtypesDeep #-}
92+
93+instance (GHasTypesDeep a s) => GHasTypesDeep a (M1 m meta s) where
94+ gtypesDeep f (M1 s) = M1 <$> gtypesDeep f s
95+ {-# INLINE gtypesDeep #-}
96+
97+instance {-# OVERLAPPING #-} GHasTypesDeep a (Rec0 a) where
98+ gtypesDeep f (K1 x) = K1 <$> f x
99+ {-# INLINE gtypesDeep #-}
100+
101+instance HasTypesDeep a b => GHasTypesDeep a (Rec0 b) where
102+ gtypesDeep f (K1 x) = K1 <$> typesDeep @a f x
103+ {-# INLINE gtypesDeep #-}
104+
105+instance GHasTypesDeep a U1 where
106+ gtypesDeep _ _ = pure U1
107+ {-# INLINE gtypesDeep #-}
108+
109+--instance GHasTypesDeep a V1 where