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