@@ -1,6 +1,7 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE ConstraintKinds #-}
33{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
45{-# LANGUAGE FlexibleInstances #-}
56{-# LANGUAGE KindSignatures #-}
67{-# LANGUAGE MultiParamTypeClasses #-}
@@ -12,6 +13,8 @@
1213{-# LANGUAGE TypeOperators #-}
1314{-# LANGUAGE UndecidableInstances #-}
1415
16+{-# LANGUAGE UndecidableSuperClasses #-}
17+
1518-----------------------------------------------------------------------------
1619-- |
1720-- Module : Data.Generics.Product.Types
@@ -34,7 +37,7 @@ module Data.Generics.Product.Types
3437 ) where
3538
3639import Data.Generics.Product.Internal.Types
37−import Data.Kind (Constraint)
40+import Data.Generics.Product.Constraints
3841
3942import GHC.Generics
4043import Data.Generics.Internal.VL.Traversal
@@ -53,65 +56,14 @@ instance
5356class HasTypesDeep a s where
5457 typesDeep :: Traversal' s a
5558
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
64−
65−instance
66− ( HasConstraints' (Or a) s
67− ) => HasTypesDeep a s where
68−
69− typesDeep f s = constraints' @(Or a) (foldOr f) s
70−
71−--------------------------------------------------------------------------------
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
95−
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
99−
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
59+instance Deep (Equals a) s => HasTypesDeep a s where
60+ typesDeep f = constraints @(Deep (Equals a)) (foldEquals f (typesDeep @a f))
10861
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)
62+class Equals a b where
63+ foldEquals :: (a -> g a) -> (b -> g b) -> b -> g b
11264
113−instance HasConstraints' c a => GRec c 'False (K1 R a) where
114− grec f (K1 s) = K1 <$> constraints' @c @a f s
65+instance Equals a a where
66+ foldEquals f _ = f
11567
116−instance c a => GRec c 'True (K1 R a) where
117− grec f s = kIso f s
68+instance {-# OVERLAPPABLE #-} Equals a b where
69+ foldEquals _ g = g