4a68fae · generic-lens

generic-lens.cabal+16−2

compare with master

unifiedsplit

@@ -27,6 +27,9 @@ library

27 , Data.Generics.Product.Typed

28 , Data.Generics.Labels

29 , Data.Generics.Product.Types

30+ , Data.Generics.Product.Boggle

31+

32+ , Boggle

30

33

31 , Data.Generics.Sum

34 , Data.Generics.Sum

32 , Data.Generics.Sum.Any

35 , Data.Generics.Sum.Any

@@ -58,7 +61,14 @@ library

58

61

59 hs-source-dirs: src

62 hs-source-dirs: src

60 default-language: Haskell2010

63 default-language: Haskell2010

61− ghc-options: -Wall

64+ ghc-options: -Wall -fsimpl-tick-factor=0 -ddump-simpl-stats -ddump-to-file

65+ if flag(dump-core)

66+ build-depends: dump-core

67+ ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html

68+

69+flag dump-core

70+ description: Dump HTML for the core generated by GHC during compilation

71+ default: False

62

72

63source-repository head

73source-repository head

64 type: git

74 type: git

@@ -75,7 +85,10 @@ test-suite generic-lens-test

75 , inspection-testing >= 0.1

85 , inspection-testing >= 0.1

76

86

77 default-language: Haskell2010

87 default-language: Haskell2010

78− ghc-options: -Wall

88+ ghc-options: -Wall -O2

89+ if flag(dump-core)

90+ build-depends: dump-core

91+ ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html -ddump-to-file -funfolding-use-threshold=100 -fsimpl-tick-factor=0 -ddump-simpl-stats

79

92

80test-suite doctests

93test-suite doctests

81 default-language: Haskell2010

94 default-language: Haskell2010

@@ -100,3 +113,4 @@ benchmark generic-lens-bench

100

113

101 default-language: Haskell2010

114 default-language: Haskell2010

102 ghc-options: -Wall

115 ghc-options: -Wall

116+

src/Data/Generics/Product/Internal/Types.hs+9−3

@@ -32,23 +32,29 @@ import Data.Generics.Internal.Lens

32

33import Data.Kind (Type)

34import GHC.Generics

35+import Boggle

35

36

36-- |As 'HasTypes' but over generic representations as defined by

37-- |As 'HasTypes' but over generic representations as defined by

37-- "GHC.Generics".

38-- "GHC.Generics".

38class GHasTypes (f :: Type -> Type) a where

39class GHasTypes (f :: Type -> Type) a where

39− gtypes :: Traversal' (f x) a

40+ gtypes :: forall g . Applicative g => (a -> g a) -> f a -> Boggle g (f a)

40

41

41instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :*: r) a where

42instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :*: r) a where

42 gtypes f (l :*: r) = (:*:) <$> gtypes f l <*> gtypes f r

43 gtypes f (l :*: r) = (:*:) <$> gtypes f l <*> gtypes f r

44+ {-# INLINE gtypes #-}

43

45

44-- TODO:

46-- TODO:

45-- instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :+: r) a where

47-- instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :+: r) a where

46

48

47instance GHasTypes (K1 R a) a where

49instance GHasTypes (K1 R a) a where

48− gtypes f (K1 x) = fmap K1 (f x)

50+ gtypes f (K1 x) = fmap K1 (liftBoggle (f x))

51+ {-# INLINE gtypes #-}

52+

49

53

50instance {-# OVERLAPS #-} GHasTypes (K1 R a) b where

54instance {-# OVERLAPS #-} GHasTypes (K1 R a) b where

51 gtypes _ k = pure k

55 gtypes _ k = pure k

56+ {-# INLINE gtypes #-}

52

57

53instance GHasTypes f a => GHasTypes (M1 m meta f) a where

58instance GHasTypes f a => GHasTypes (M1 m meta f) a where

59+ gtypes f (M1 x) = M1 <$> gtypes f x

54− gtypes = mIso . gtypes

60+ {-# INLINE gtypes #-}

src/Data/Generics/Product/Types.hs+4−2

@@ -35,7 +35,8 @@ import Data.Generics.Internal.Lens

35import Data.Generics.Product.Internal.Types

36

37--import Data.Kind (Constraint, Type)

38−import GHC.Generics (Generic (Rep))

38+import GHC.Generics (Generic (Rep), from, to)

39+import Boggle

39--import GHC.TypeLits (TypeError, ErrorMessage (..))

40--import GHC.TypeLits (TypeError, ErrorMessage (..))

40

41

41class HasTypes a s where

42class HasTypes a s where

@@ -46,4 +47,5 @@ instance

46 , GHasTypes (Rep s) a

47 , GHasTypes (Rep s) a

47 ) => HasTypes a s where

48 ) => HasTypes a s where

48

49

49− types = repIso . gtypes

50+ types f s = lowerBoggle (to <$> gtypes f (from s))

51+

test/Spec.hs+11

@@ -16,6 +16,7 @@ import GHC.Generics

16import Data.Profunctor

17import Data.Generics.Product

18import Data.Generics.Sum

19+import Data.Generics.Product.Boggle

19import Test.Inspection

20import Test.Inspection

20

21

21main :: IO ()

22main :: IO ()

@@ -45,6 +46,13 @@ prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b

45prism bt seta = dimap seta (either pure (fmap bt)) . right'

46prism bt seta = dimap seta (either pure (fmap bt)) . right'

46{-# INLINE prism #-}

47{-# INLINE prism #-}

47

48

49+data Record4 a = MkRecord4

50+ { fieldA :: a

51+ , fieldB :: a

52+ } deriving (Generic1)

53+

54+type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s

55+

48type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s

56type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s

49

57

50typeChangingManual :: Lens (Record3 a) (Record3 b) a b

58typeChangingManual :: Lens (Record3 a) (Record3 b) a b

@@ -58,6 +66,9 @@ newtype L s a = L (Lens' s a)

58intTraversalManual :: Traversal' Record3 Int

66intTraversalManual :: Traversal' Record3 Int

59intTraversalManual = types

67intTraversalManual = types

60

68

69+intTraversalDerived3 :: Traversal' (Record4 Int) Int

70+intTraversalDerived3 = genericTraverse

71+

61fieldALensManual :: Lens' Record Int

72fieldALensManual :: Lens' Record Int

62fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a

73fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a

63

74