git.iko.soy/generic-lens
on master help sign in
WIP Deep traversals
e9c0a1fCsongor Kiss
src/Data/Generics/Internal/Families/Changing.hs+15
compare with master
unifiedsplit
@@ -13,6 +13,7 @@ module Data.Generics.Internal.Families.Changing
13 , Infer
13 , Infer
14 , PTag (..)
14 , PTag (..)
15 , P
15 , P
16+ , LookupParam
16 ) where
17 ) where
17
18
18import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
19import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
@@ -103,6 +104,20 @@ type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where
103 ReplaceArgs t '[] = t
104 ReplaceArgs t '[] = t
104 ReplaceArgs t ('Sub n arg ': ss) = ReplaceArgs (ReplaceArg t n arg) ss
105 ReplaceArgs t ('Sub n arg ': ss) = ReplaceArgs (ReplaceArg t n arg) ss
105
106
107+type family LookupParam (a :: k) (p :: Nat) :: Maybe Nat where
108+ LookupParam (param (n :: Nat)) m = 'Nothing
109+ LookupParam (a (_ (m :: Nat))) n = IfEq m n ('Just 0) (MaybeAdd (LookupParam a n) 1)
110+ LookupParam (a _) n = MaybeAdd (LookupParam a n) 1
111+ LookupParam a _ = 'Nothing
112+
113+type family MaybeAdd (a :: Maybe Nat) (b :: Nat) :: Maybe Nat where
114+ MaybeAdd 'Nothing _ = 'Nothing
115+ MaybeAdd ('Just a) b = 'Just (a + b)
116+
117+type family IfEq (a :: k) (b :: k) (t :: l) (f :: l) :: l where
118+ IfEq a a t _ = t
119+ IfEq _ _ _ f = f
120+
106-- Note [CPP in instance constraints]
121-- Note [CPP in instance constraints]
107-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
122-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
108--
123--
src/Data/Generics/Product/Constraints.hs+1−1
@@ -41,5 +41,5 @@ instance
41 ( Generic s
41 ( Generic s
42 , GHasConstraints c (Rep s)
42 , GHasConstraints c (Rep s)
43 ) => HasConstraints c s where
43 ) => HasConstraints c s where
44− constraints = confusingC @c (\f s -> to <$> cgtypes @c f (from s))
44+ constraints = confusingC @c (\f s -> to <$> gconstraints @c f (from s))
45 {-# INLINE constraints #-}
45 {-# INLINE constraints #-}
src/Data/Generics/Product/Internal/Param.hs+4−40
@@ -7,6 +7,7 @@
7{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GADTs #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE NoMonomorphismRestriction #-}
9{-# LANGUAGE NoMonomorphismRestriction #-}
10+{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE Rank2Types #-}
11{-# LANGUAGE Rank2Types #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TypeApplications #-}
@@ -29,43 +30,6 @@
29--
30--
30-----------------------------------------------------------------------------
31-----------------------------------------------------------------------------
31
32
32−module Data.Generics.Product.Internal.Param
33+module Data.Generics.Product.Internal.Param where
33− ( GHasParam (..)
34− ) where
35−
36−import GHC.Generics
37−import GHC.TypeLits (Nat)
38−import Data.Generics.Internal.VL.Iso
39−import Data.Generics.Internal.GenericN
40−
41−class GHasParam (p :: Nat) s t a b | p t a -> s, p s b -> t where
42− gparam :: forall g x.
43− Applicative g => (a -> g b) -> s x -> g (t x)
44−
45−instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :*: r) (l' :*: r') a b where
46− gparam f (l :*: r) = (:*:) <$> gparam @p f l <*> gparam @p f r
47−
48−instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :+: r) (l' :+: r') a b where
49− gparam f (L1 l) = L1 <$> gparam @p f l
50− gparam f (R1 r) = R1 <$> gparam @p f r
51−
52−-- the parameter we're looking for
53−instance GHasParam p (Rec (param p) a) (Rec (param p) b) a b where
54− gparam = recIso
55−
56−-- other parameter
57−instance {-# OVERLAPPABLE #-}
58− ( '(a, p1) ~ '(b, p2)
59− ) => GHasParam p (Rec p1 a) (Rec p2 b) c d where
34+ --( GHasParam (..)
60− gparam _ = pure
35+ --) where
61−
62−-- not a parameter
63−instance GHasParam p (K1 r a) (K1 r a) c d where
64− gparam _ = pure
65−
66−instance GHasParam p s t a b => GHasParam p (M1 m meta s) (M1 m meta t) a b where
67− gparam f (M1 x) = M1 <$> gparam @p f x
68−
69−instance GHasParam p U1 U1 a b where
70− gparam _ _ = pure U1
71−
src/Data/Generics/Product/Internal/Types.hs+8−8
@@ -38,24 +38,24 @@ import Data.Generics.Internal.VL.Iso
38
38
39-- | Constrained traversal.
39-- | Constrained traversal.
40class GHasConstraints (c :: * -> Constraint) (f :: * -> *) where
40class GHasConstraints (c :: * -> Constraint) (f :: * -> *) where
41− cgtypes :: forall g x.
41+ gconstraints :: forall g x.
42 Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
42 Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
43
43
44instance (GHasConstraints c l, GHasConstraints c r) => GHasConstraints c (l :*: r) where
44instance (GHasConstraints c l, GHasConstraints c r) => GHasConstraints c (l :*: r) where
45− cgtypes f (l :*: r) = (:*:) <$> cgtypes @c f l <*> cgtypes @c f r
45+ gconstraints f (l :*: r) = (:*:) <$> gconstraints @c f l <*> gconstraints @c f r
46
46
47instance (GHasConstraints c l, GHasConstraints c r) => GHasConstraints c (l :+: r) where
47instance (GHasConstraints c l, GHasConstraints c r) => GHasConstraints c (l :+: r) where
48− cgtypes f (L1 l) = L1 <$> cgtypes @c f l
48+ gconstraints f (L1 l) = L1 <$> gconstraints @c f l
49− cgtypes f (R1 r) = R1 <$> cgtypes @c f r
49+ gconstraints f (R1 r) = R1 <$> gconstraints @c f r
50
50
51instance c a => GHasConstraints c (K1 R a) where
51instance c a => GHasConstraints c (K1 R a) where
52− cgtypes = kIso
52+ gconstraints = kIso
53
53
54instance GHasConstraints c f => GHasConstraints c (M1 m meta f) where
54instance GHasConstraints c f => GHasConstraints c (M1 m meta f) where
55− cgtypes f (M1 x) = M1 <$> cgtypes @c f x
55+ gconstraints f (M1 x) = M1 <$> gconstraints @c f x
56
56
57instance GHasConstraints c U1 where
57instance GHasConstraints c U1 where
58− cgtypes _ _ = pure U1
58+ gconstraints _ _ = pure U1
59
59
60--------------------------------------------------------------------------------
60--------------------------------------------------------------------------------
61
61
@@ -68,7 +68,7 @@ gtypes
68 ( GHasTypes f as
68 ( GHasTypes f as
69 , Applicative g
69 , Applicative g
70 ) => HList (Functions as g) -> f x -> g (f x)
70 ) => HList (Functions as g) -> f x -> g (f x)
71−gtypes hl s = cgtypes @(Contains as) (pick hl) s
71+gtypes hl s = gconstraints @(Contains as) (pick hl) s
72
72
73--------------------------------------------------------------------------------
73--------------------------------------------------------------------------------
74
74
src/Data/Generics/Product/Param.hs+41−4
@@ -7,10 +7,9 @@
7{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE KindSignatures #-}
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeApplications #-}
10+{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE UndecidableInstances #-}
11
12
12−{-# LANGUAGE DeriveGeneric #-}
13−
14--------------------------------------------------------------------------------
13--------------------------------------------------------------------------------
15-- |
14-- |
16-- Module : Data.Generics.Product.Param
15-- Module : Data.Generics.Product.Param
@@ -31,11 +30,14 @@ module Data.Generics.Product.Param
31
30
32import GHC.TypeLits (Nat)
31import GHC.TypeLits (Nat)
33import Data.Generics.Internal.Void
32import Data.Generics.Internal.Void
34−import Data.Generics.Internal.GenericN
35import Data.Generics.Internal.Families.Changing
33import Data.Generics.Internal.Families.Changing
36−import Data.Generics.Product.Internal.Param
37import Data.Generics.Internal.VL.Traversal
34import Data.Generics.Internal.VL.Traversal
38
35
36+import GHC.Generics
37+import Data.Kind
38+import Data.Generics.Internal.VL.Iso
39+import Data.Generics.Internal.GenericN
40+
39class HasParam (p :: Nat) s t a b | p t a b -> s, p s a b -> t where
41class HasParam (p :: Nat) s t a b | p t a b -> s, p s a b -> t where
40 param :: Applicative g => (a -> g b) -> s -> g t
42 param :: Applicative g => (a -> g b) -> s -> g t
41
43
@@ -54,3 +56,38 @@ instance
54instance {-# OVERLAPPING #-} HasParam p (Void1 a) (Void1 b) a b where
56instance {-# OVERLAPPING #-} HasParam p (Void1 a) (Void1 b) a b where
55 param = undefined
57 param = undefined
56
58
59+class GHasParam (p :: Nat) s t a b where
60+ gparam :: forall g (x :: Type). Applicative g => (a -> g b) -> s x -> g (t x)
61+
62+instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :*: r) (l' :*: r') a b where
63+ gparam f (l :*: r) = (:*:) <$> gparam @p f l <*> gparam @p f r
64+
65+instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :+: r) (l' :+: r') a b where
66+ gparam f (L1 l) = L1 <$> gparam @p f l
67+ gparam f (R1 r) = R1 <$> gparam @p f r
68+
69+instance GHasParam p U1 U1 a b where
70+ gparam _ _ = pure U1
71+
72+instance GHasParam p s t a b => GHasParam p (M1 m meta s) (M1 m meta t) a b where
73+ gparam f (M1 x) = M1 <$> gparam @p f x
74+
75+-- the parameter we're looking for
76+instance GHasParam p (Rec (param p) a) (Rec (param p) b) a b where
77+ gparam = recIso
78+
79+-- other recursion
80+instance {-# OVERLAPPABLE #-}
81+ ( GHasParamRec (LookupParam si p) s t a b
82+ -- TODO: reindex `ti`
83+ ) => GHasParam p (Rec si s) (Rec ti t) a b where
84+ gparam f (Rec (K1 x)) = Rec . K1 <$> gparamRec @(LookupParam si p) f x
85+
86+class GHasParamRec (param :: Maybe Nat) s t a b | param t a b -> s, param s a b -> t where
87+ gparamRec :: forall g. Applicative g => (a -> g b) -> s -> g t
88+
89+instance GHasParamRec 'Nothing a a c d where
90+ gparamRec _ = pure
91+
92+instance (HasParam n s t a b) => GHasParamRec ('Just n) s t a b where
93+ gparamRec = param @n
src/Data/Generics/Product/Types.hs+68−1
@@ -1,6 +1,15 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE ConstraintKinds #-}
1{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE KindSignatures #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE Rank2Types #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE UndecidableInstances #-}
13{-# LANGUAGE UndecidableInstances #-}
5
14
6-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
@@ -21,11 +30,13 @@ module Data.Generics.Product.Types
21 --
30 --
22 -- $example
31 -- $example
23 HasTypes (..)
32 HasTypes (..)
33+ , HasTypesDeep (..)
24 ) where
34 ) where
25
35
26import Data.Generics.Product.Internal.Types
36import Data.Generics.Product.Internal.Types
37+import Data.Kind (Constraint)
27
38
28−import GHC.Generics (Generic (Rep))
39+import GHC.Generics
29import Data.Generics.Internal.VL.Traversal
40import Data.Generics.Internal.VL.Traversal
30import Data.Generics.Internal.VL.Iso
41import Data.Generics.Internal.VL.Iso
31
42
@@ -38,3 +49,59 @@ instance
38 ) => HasTypes a s where
49 ) => HasTypes a s where
39 types = confusing (\f -> (repIso . gtypes) (f :> HNil))
50 types = confusing (\f -> (repIso . gtypes) (f :> HNil))
40 {-# INLINE types #-}
51 {-# INLINE types #-}
52+
53+class HasTypesDeep a s where
54+ typesDeep :: Traversal' s a
55+
56+instance
57+ ( HasConstraints' ((~) a) s
58+ ) => HasTypesDeep a s where
59+
60+ typesDeep f s = constraints' @((~) a) f s
61+
62+--------------------------------------------------------------------------------
63+type family Primitive a :: Bool where
64+ Primitive Int = 'True
65+ Primitive Char = 'True
66+ Primitive Bool = 'True
67+ Primitive _ = 'False
68+ -- TODO: more primitives, or perhaps abstract from stop condition
69+
70+-- TODO: refactor
71+-- deep constrained traversals, stopping at primitive types
72+class HasConstraints' (c :: * -> Constraint) s where
73+ constraints' :: forall g.
74+ Applicative g => (forall a. c a => a -> g a) -> s -> g s
75+
76+instance (Generic s, GHasConstraints' c (Rep s)) => HasConstraints' c s where
77+ constraints' f s = to <$> gconstraints' @c f (from s)
78+
79+class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where
80+ gconstraints' :: forall g x.
81+ Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
82+
83+instance (GHasConstraints' c l, GHasConstraints' c r) => GHasConstraints' c (l :*: r) where
84+ gconstraints' f (l :*: r) = (:*:) <$> gconstraints' @c f l <*> gconstraints' @c f r
85+
86+instance (GHasConstraints' c l, GHasConstraints' c r) => GHasConstraints' c (l :+: r) where
87+ gconstraints' f (L1 l) = L1 <$> gconstraints' @c f l
88+ gconstraints' f (R1 r) = R1 <$> gconstraints' @c f r
89+
90+instance GRec c (Primitive a) (K1 R a) => GHasConstraints' c (K1 R a) where
91+ gconstraints' = grec @c @(Primitive a)
92+
93+instance GHasConstraints' c f => GHasConstraints' c (M1 m meta f) where
94+ gconstraints' f (M1 x) = M1 <$> gconstraints' @c f x
95+
96+instance GHasConstraints' c U1 where
97+ gconstraints' _ _ = pure U1
98+
99+class GRec (c :: * -> Constraint) (s :: Bool) (f :: * -> *) where
100+ grec :: forall g x.
101+ Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
102+
103+instance HasConstraints' c a => GRec c 'False (K1 R a) where
104+ grec f (K1 s) = K1 <$> constraints' @c @a f s
105+
106+instance c a => GRec c 'True (K1 R a) where
107+ grec f s = kIso f s