git.iko.soy/generic-lens
on master help sign in
WIP typed traversals
11eb649Csongor Kiss
generic-lens.cabal+2
compare with master
unifiedsplit
@@ -26,6 +26,7 @@ library
26 , Data.Generics.Product.Subtype
26 , Data.Generics.Product.Subtype
27 , Data.Generics.Product.Typed
27 , Data.Generics.Product.Typed
28 , Data.Generics.Labels
28 , Data.Generics.Labels
29+ , Data.Generics.Product.Types
29
30
30 , Data.Generics.Sum
31 , Data.Generics.Sum
31 , Data.Generics.Sum.Any
32 , Data.Generics.Sum.Any
@@ -49,6 +50,7 @@ library
49 , Data.Generics.Product.Internal.Positions
50 , Data.Generics.Product.Internal.Positions
50 , Data.Generics.Product.Internal.Subtype
51 , Data.Generics.Product.Internal.Subtype
51 , Data.Generics.Product.Internal.Typed
52 , Data.Generics.Product.Internal.Typed
53+ , Data.Generics.Product.Internal.Types
52
54
53 build-depends: base >= 4.9 && <= 5.0
55 build-depends: base >= 4.9 && <= 5.0
54 , profunctors >= 5.0 && <= 6.0
56 , profunctors >= 5.0 && <= 6.0
src/Data/Generics/Internal/Lens.hs+4
@@ -32,6 +32,10 @@ type Lens' s a
32type Lens s t a b
32type Lens s t a b
33 = forall f. Functor f => (a -> f b) -> s -> f t
33 = forall f. Functor f => (a -> f b) -> s -> f t
34
34
35+-- | Type alias for traversal
36+type Traversal' s a
37+ = forall f. Applicative f => (a -> f a) -> s -> f s
38+
35-- | Type alias for prism
39-- | Type alias for prism
36type Prism s t a b
40type Prism s t a b
37 = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
41 = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
src/Data/Generics/Product.hs+2
@@ -22,6 +22,7 @@ module Data.Generics.Product
22 , module Data.Generics.Product.Positions
22 , module Data.Generics.Product.Positions
23 , module Data.Generics.Product.Subtype
23 , module Data.Generics.Product.Subtype
24 , module Data.Generics.Product.Typed
24 , module Data.Generics.Product.Typed
25+ , module Data.Generics.Product.Types
25 ) where
26 ) where
26
27
27import Data.Generics.Product.Any
28import Data.Generics.Product.Any
@@ -29,3 +30,4 @@ import Data.Generics.Product.Fields
29import Data.Generics.Product.Positions
30import Data.Generics.Product.Positions
30import Data.Generics.Product.Subtype
31import Data.Generics.Product.Subtype
31import Data.Generics.Product.Typed
32import Data.Generics.Product.Typed
33+import Data.Generics.Product.Types
src/Data/Generics/Product/Internal/Types.hsnew file+54
@@ -0,0 +1,54 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Product.Internal.Types
16+-- Copyright : (C) 2017 Csongor Kiss
17+-- License : BSD3
18+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19+-- Stability : experimental
20+-- Portability : non-portable
21+--
22+-- Derive traversals of a given type in a product.
23+--
24+-----------------------------------------------------------------------------
25+
26+module Data.Generics.Product.Internal.Types
27+ ( GHasTypes (..)
28+ ) where
29+
30+--import Data.Generics.Internal.Families
31+import Data.Generics.Internal.Lens
32+
33+import Data.Kind (Type)
34+import GHC.Generics
35+
36+-- |As 'HasTypes' but over generic representations as defined by
37+-- "GHC.Generics".
38+class GHasTypes (f :: Type -> Type) a where
39+ gtypes :: Traversal' (f x) a
40+
41+instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :*: r) a where
42+ gtypes f (l :*: r) = (:*:) <$> gtypes f l <*> gtypes f r
43+
44+-- TODO:
45+-- instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :+: r) a where
46+
47+instance GHasTypes (K1 R a) a where
48+ gtypes f (K1 x) = fmap K1 (f x)
49+
50+instance {-# OVERLAPS #-} GHasTypes (K1 R a) b where
51+ gtypes _ k = pure k
52+
53+instance GHasTypes f a => GHasTypes (M1 m meta f) a where
54+ gtypes = mIso . gtypes
src/Data/Generics/Product/Typed.hs+1−1
@@ -19,7 +19,7 @@
19-- Stability : experimental
19-- Stability : experimental
20-- Portability : non-portable
20-- Portability : non-portable
21--
21--
22−-- Derive record field getters and setters generically.
22+-- Derive lenses of a given type in a product.
23--
23--
24-----------------------------------------------------------------------------
24-----------------------------------------------------------------------------
25
25
src/Data/Generics/Product/Types.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Product.Types
16+-- Copyright : (C) 2017 Csongor Kiss
17+-- License : BSD3
18+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19+-- Stability : experimental
20+-- Portability : non-portable
21+--
22+-- Derive traversals of a given type in a product.
23+--
24+-----------------------------------------------------------------------------
25+
26+module Data.Generics.Product.Types
27+ ( -- *Traversals
28+ --
29+ -- $example
30+ HasTypes (..)
31+ ) where
32+
33+--import Data.Generics.Internal.Families
34+import Data.Generics.Internal.Lens
35+import Data.Generics.Product.Internal.Types
36+
37+--import Data.Kind (Constraint, Type)
38+import GHC.Generics (Generic (Rep))
39+--import GHC.TypeLits (TypeError, ErrorMessage (..))
40+
41+class HasTypes a s where
42+ types :: Traversal' s a
43+
44+instance
45+ ( Generic s
46+ , GHasTypes (Rep s) a
47+ ) => HasTypes a s where
48+
49+ types = repIso . gtypes
test/Spec.hs+7−2
@@ -45,8 +45,7 @@ prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
45prism bt seta = dimap seta (either pure (fmap bt)) . right'
45prism bt seta = dimap seta (either pure (fmap bt)) . right'
46{-# INLINE prism #-}
46{-# INLINE prism #-}
47
47
48−fieldALensManual :: Lens' Record Int
48+type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s
49−fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a
50
49
51typeChangingManual :: Lens (Record3 a) (Record3 b) a b
50typeChangingManual :: Lens (Record3 a) (Record3 b) a b
52typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
51typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
@@ -56,6 +55,12 @@ typeChangingManualCompose = typeChangingManual . typeChangingManual
56
55
57newtype L s a = L (Lens' s a)
56newtype L s a = L (Lens' s a)
58
57
58+intTraversalManual :: Traversal' Record3 Int
59+intTraversalManual = types
60+
61+fieldALensManual :: Lens' Record Int
62+fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a
63+
59subtypeLensManual :: Lens' Record Record2
64subtypeLensManual :: Lens' Record Record2
60subtypeLensManual f record
65subtypeLensManual f record
61 = fmap (\ds -> case record of
66 = fmap (\ds -> case record of