@@ -1,7 +1,6 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE ConstraintKinds #-}
33{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
54{-# LANGUAGE FlexibleInstances #-}
65{-# LANGUAGE KindSignatures #-}
76{-# LANGUAGE MultiParamTypeClasses #-}
@@ -13,8 +12,6 @@
1312{-# LANGUAGE TypeOperators #-}
1413{-# LANGUAGE UndecidableInstances #-}
1514
16−{-# LANGUAGE UndecidableSuperClasses #-}
17−
1815-----------------------------------------------------------------------------
1916-- |
2017-- Module : Data.Generics.Product.Types
@@ -37,7 +34,7 @@ module Data.Generics.Product.Types
3734 ) where
3835
3936import Data.Generics.Product.Internal.Types
40−import Data.Generics.Product.Constraints
37+import Data.Kind (Constraint)
4138
4239import GHC.Generics
4340import Data.Generics.Internal.VL.Traversal
@@ -56,14 +53,65 @@ instance
5653class HasTypesDeep a s where
5754 typesDeep :: Traversal' s a
5855
59−instance Deep (Equals a) s => HasTypesDeep a s where
60− typesDeep f = constraints @(Deep (Equals a)) (foldEquals f (typesDeep @a f))
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
61108
62−class Equals a b where
63− foldEquals :: (a -> g a) -> (b -> g b) -> b -> g b
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)
64112
65−instance Equals a a where
66− foldEquals f _ = f
113+instance HasConstraints' c a => GRec c 'False (K1 R a) where
114+ grec f (K1 s) = K1 <$> constraints' @c @a f s
67115
68−instance {-# OVERLAPPABLE #-} Equals a b where
69− foldEquals _ g = g
116+instance c a => GRec c 'True (K1 R a) where
117+ grec f s = kIso f s