git.iko.soy/generic-lens
on master help sign in
Revert "Simplify typesDeep implementation"
7462a12Csongor Kiss
src/Data/Generics/Product/Constraints.hs+9−28
compare with master
unifiedsplit
@@ -1,16 +1,12 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DefaultSignatures #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE MonoLocalBinds #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE Rank2Types #-}
6+{-# LANGUAGE Rank2Types #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeApplications #-}
8+{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE UndecidableInstances #-}
9+{-# LANGUAGE UndecidableInstances #-}
13−{-# LANGUAGE UndecidableSuperClasses #-}
14
10
15-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
16-- |
12-- |
@@ -30,7 +26,6 @@ module Data.Generics.Product.Constraints
30 --
26 --
31 -- $example
27 -- $example
32 HasConstraints (..)
28 HasConstraints (..)
33− , Deep
34 ) where
29 ) where
35
30
36import Data.Generics.Product.Internal.Types
31import Data.Generics.Product.Internal.Types
@@ -42,23 +37,9 @@ import Data.Generics.Internal.VL.Traversal
42class HasConstraints (c :: * -> Constraint) s where
37class HasConstraints (c :: * -> Constraint) s where
43 constraints :: Applicative g => (forall a. c a => a -> g a) -> s -> g s
38 constraints :: Applicative g => (forall a. c a => a -> g a) -> s -> g s
44
39
45− default constraints :: Applicative g => (forall a. c a => a -> g a) -> s -> g s
46− constraints _ = pure
47−
48instance
40instance
49 ( Generic s
41 ( Generic s
50 , GHasConstraints c (Rep s)
42 , GHasConstraints c (Rep s)
51 ) => HasConstraints c s where
43 ) => HasConstraints c s where
52 constraints = confusingC @c (\f s -> to <$> gconstraints @c f (from s))
44 constraints = confusingC @c (\f s -> to <$> gconstraints @c f (from s))
53 {-# INLINE constraints #-}
45 {-# INLINE constraints #-}
54−
55−instance {-# OVERLAPPING #-} HasConstraints c Bool
56−instance {-# OVERLAPPING #-} HasConstraints c Char
57−instance {-# OVERLAPPING #-} HasConstraints c Double
58−instance {-# OVERLAPPING #-} HasConstraints c Float
59−instance {-# OVERLAPPING #-} HasConstraints c Int
60−instance {-# OVERLAPPING #-} HasConstraints c Integer
61−instance {-# OVERLAPPING #-} HasConstraints c Ordering
62−
63−class (c a, HasConstraints (Deep c) a) => Deep c a
64−instance (c a, HasConstraints (Deep c) a) => Deep c a
src/Data/Generics/Product/Types.hs+60−12
@@ -1,7 +1,6 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
@@ -13,8 +12,6 @@
13{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE UndecidableInstances #-}
13{-# LANGUAGE UndecidableInstances #-}
15
14
16−{-# LANGUAGE UndecidableSuperClasses #-}
17−
18-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
19-- |
16-- |
20-- Module : Data.Generics.Product.Types
17-- Module : Data.Generics.Product.Types
@@ -37,7 +34,7 @@ module Data.Generics.Product.Types
37 ) where
34 ) where
38
35
39import Data.Generics.Product.Internal.Types
36import Data.Generics.Product.Internal.Types
40−import Data.Generics.Product.Constraints
37+import Data.Kind (Constraint)
41
38
42import GHC.Generics
39import GHC.Generics
43import Data.Generics.Internal.VL.Traversal
40import Data.Generics.Internal.VL.Traversal
@@ -56,14 +53,65 @@ instance
56class HasTypesDeep a s where
53class HasTypesDeep a s where
57 typesDeep :: Traversal' s a
54 typesDeep :: Traversal' s a
58
55
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
59−instance Deep (Equals a) s => HasTypesDeep a s where
67+ ) => HasTypesDeep a s where
68+
60− typesDeep f = constraints @(Deep (Equals a)) (foldEquals f (typesDeep @a f))
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
61
108
62−class Equals a b where
109+class GRec (c :: * -> Constraint) (s :: Bool) (f :: * -> *) where
63− foldEquals :: (a -> g a) -> (b -> g b) -> b -> g b
110+ grec :: forall g x.
111+ Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
64
112
65−instance Equals a a where
113+instance HasConstraints' c a => GRec c 'False (K1 R a) where
66− foldEquals f _ = f
114+ grec f (K1 s) = K1 <$> constraints' @c @a f s
67
115
68−instance {-# OVERLAPPABLE #-} Equals a b where
116+instance c a => GRec c 'True (K1 R a) where
69− foldEquals _ g = g
117+ grec f s = kIso f s