@@ -1,13 +1,20 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeOperators #-}
10−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE KindSignatures #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE Rank2Types #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TypeApplications #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE TypeFamilyDependencies #-}
16+{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE UndecidableInstances #-}
1118
1219-----------------------------------------------------------------------------
1320-- |
@@ -23,37 +30,71 @@
2330-----------------------------------------------------------------------------
2431
2532module Data.Generics.Product.Internal.Types
26− ( GHasTypes (..)
33+ ( GHasTypes
34+ , GHasConstraints (..)
35+ , gtypes
36+ , HList (..)
2737 ) where
2838
29−import Data.Kind (Type)
39+import Data.Kind (Type, Constraint)
3040import GHC.Generics
41+import Data.Generics.Internal.VL.Iso
3142
32−-- |As 'HasTypes' but over generic representations as defined by
33−-- "GHC.Generics".
34−class GHasTypes (f :: Type -> Type) a where
35− gtypes :: forall g x. Applicative g => (a -> g a) -> f x -> g (f x)
43+-- | Constrained traversal.
44+class GHasConstraints (c :: * -> Constraint) (f :: * -> *) where
45+ cgtypes :: forall g x.
46+ Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
3647
37−instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :*: r) a where
38− gtypes f (l :*: r) = (:*:) <$> gtypes f l <*> gtypes f r
39− {-# INLINE gtypes #-}
48+instance (GHasConstraints c l, GHasConstraints c r) => GHasConstraints c (l :*: r) where
49+ cgtypes f (l :*: r) = (:*:) <$> cgtypes @c f l <*> cgtypes @c f r
4050
41−instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :+: r) a where
42− gtypes f (L1 l) = L1 <$> gtypes f l
43− gtypes f (R1 r) = R1 <$> gtypes f r
51+instance (GHasConstraints c l, GHasConstraints c r) => GHasConstraints c (l :+: r) where
52+ cgtypes f (L1 l) = L1 <$> cgtypes @c f l
53+ cgtypes f (R1 r) = R1 <$> cgtypes @c f r
4454
45−instance GHasTypes (K1 R a) a where
46− gtypes f (K1 x) = fmap K1 (f x)
47− {-# INLINE gtypes #-}
55+instance c a => GHasConstraints c (K1 R a) where
56+ cgtypes = kIso
4857
49−instance {-# OVERLAPPABLE #-} GHasTypes (K1 R a) b where
50− gtypes _ k = pure k
51− {-# INLINE gtypes #-}
58+instance GHasConstraints c f => GHasConstraints c (M1 m meta f) where
59+ cgtypes f (M1 x) = M1 <$> cgtypes @c f x
5260
53−instance GHasTypes f a => GHasTypes (M1 m meta f) a where
54− gtypes f (M1 x) = M1 <$> gtypes f x
55− {-# INLINE gtypes #-}
61+instance GHasConstraints c U1 where
62+ cgtypes _ _ = pure U1
5663
57−instance GHasTypes U1 a where
58− gtypes _ U1 = pure U1
59− {-# INLINE gtypes #-}
64+--------------------------------------------------------------------------------
65+
66+-- | Multi-traversal
67+type GHasTypes rep as = GHasConstraints (Contains as) rep
68+
69+-- Try to use a function from the list, or default to 'pure' if not present
70+gtypes
71+ :: forall as x f g.
72+ ( GHasTypes f as
73+ , Applicative g
74+ ) => HList (Functions as g) -> f x -> g (f x)
75+gtypes hl s = cgtypes @(Contains as) (pick hl) s
76+
77+--------------------------------------------------------------------------------
78+
79+data HList (ts :: [Type]) where
80+ HNil :: HList '[]
81+ (:>) :: a -> HList as -> HList (a ': as)
82+infixr 5 :>
83+
84+-- >>> :kind! Functions '[Int, Char, Bool] Maybe
85+-- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool]
86+type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where
87+ Functions '[] _ = '[]
88+ Functions (t ': ts) g = ((t -> g t) ': Functions ts g)
89+
90+class Contains as a where
91+ pick :: Applicative g => HList (Functions as g) -> a -> g a
92+
93+instance {-# OVERLAPPING #-} Contains (a ': as) a where
94+ pick (h :> _) = h
95+
96+instance Contains as a => Contains (b ': as) a where
97+ pick (_ :> hs) = pick hs
98+
99+instance Contains '[] a where
100+ pick _ = pure