7ba5d18 · generic-lens

generic-lens.cabal+1−1

compare with master

unifiedsplit

@@ -90,7 +90,7 @@ test-suite generic-lens-test

90 , HUnit

91

92 default-language: Haskell2010

93− ghc-options: -Wall -O2 -dsuppress-all

93+ ghc-options: -Wall -O2 -dsuppress-unfoldings

94 if flag(dump-core)

95 build-depends: dump-core

96 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html

src/Data/Generics/Internal/Profunctor/Lens.hs+27−16

@@ -47,15 +47,21 @@ set f (s, b)

47 = f (const b) s

48

49view :: Lens s s a a -> s -> a

50−view l = withLens l (\get _ -> get)

50+view l = withLensPrim l (\get _ -> snd . get)

51

52−withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r

52+--withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r

53−withLens l k =

53+--ithLens l k =

54+-- case l idLens of

55+-- ALens _get _set -> k (snd . _get) (\(s, b) -> _set ((fst $ _get s), b))

56+

57+withLensPrim :: Lens s t a b -> (forall c . (s -> (c,a)) -> ((c, b) -> t) -> r) -> r

58+withLensPrim l k =

54 case l idLens of

59 case l idLens of

55 ALens _get _set -> k _get _set

60 ALens _get _set -> k _get _set

56

61

57idLens :: ALens a b a b

62idLens :: ALens a b a b

58−idLens = ALens id snd

63+idLens = ALens (fork (const ()) id) snd

64+{-# INLINE idLens #-}

59

65

60infixr 4 .~

66infixr 4 .~

61(.~) :: ((a -> b) -> s -> t) -> b -> s -> t

67(.~) :: ((a -> b) -> s -> t) -> b -> s -> t

@@ -73,12 +79,12 @@ build p = unTagged . p . Tagged

73-- | Lens focusing on the first element of a product

79-- | Lens focusing on the first element of a product

74first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)

80first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)

75first

81first

76− = lens (\(a :*: _) -> a) (\(_ :*: b, a') -> a' :*: b)

82+ = lens (\(a :*: b) -> (b,a)) (\(b, a') -> a' :*: b)

77

83

78-- | Lens focusing on the second element of a product

84-- | Lens focusing on the second element of a product

79second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)

85second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)

80second

86second

81− = lens (\(_ :*: b) -> b) (\(a :*: _, b') -> a :*: b')

87+ = lens (\(a :*: b) -> (a,b)) (\(a, b') -> a :*: b')

82

88

83fork :: (a -> b) -> (a -> c) -> a -> (b, c)

89fork :: (a -> b) -> (a -> c) -> a -> (b, c)

84fork f g a = (f a, g a)

90fork f g a = (f a, g a)

@@ -131,30 +137,35 @@ stron :: (Either s s', b) -> Either (s, b) (s', b)

131stron (e, b) = bimap (,b) (, b) e

137stron (e, b) = bimap (,b) (, b) e

132

138

133choosing :: forall s t a b s' t' . Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b

139choosing :: forall s t a b s' t' . Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b

134−choosing l r = withLens l (\getl setl ->

140+choosing l r = withLensPrim l (\getl setl ->

135− withLens r (\getr setr ->

141+ withLensPrim r (\getr setr ->

136− let g :: Either s s' -> a

142+ let --g :: Either s s' -> a

137− g = either getl getr

143+ g e = case e of

144+ Left v -> let (c, v') = getl v in (Left c, v')

145+ Right v -> let (c, v') = getr v in (Right c, v')

138 s = bimap setl setr . stron

146 s = bimap setl setr . stron

139 in lens g s))

147 in lens g s))

140

148

141−lens :: (s -> a) -> ((s,b) -> t) -> Lens s t a b

149+lens :: (s -> (c,a)) -> ((c,b) -> t) -> Lens s t a b

142−lens get _set = dimap (fork id get) _set . second'

150+lens get _set = dimap get _set . second'

151+{-# INLINE lens #-}

143

152

144------------------------------------------------------------------------------

153------------------------------------------------------------------------------

145

154

146−data ALens a b s t = ALens (s -> a) ((s, b) -> t)

155+data ALens a b s t = forall c . ALens (s -> (c,a)) ((c, b) -> t)

147

156

148instance Functor (ALens a b s) where

157instance Functor (ALens a b s) where

149 fmap f (ALens _get _set) = ALens _get (f . _set)

158 fmap f (ALens _get _set) = ALens _get (f . _set)

150

159

151instance Profunctor (ALens a b) where

160instance Profunctor (ALens a b) where

152− dimap f g (ALens get _set) = ALens (get . f) (g . _set . cross f id)

161+ dimap f g (ALens get _set) = ALens (get . f) (g . _set)

153

162

154instance Strong (ALens a b) where

163instance Strong (ALens a b) where

155− second' (ALens get _set) = ALens (get . snd) (bimap id _set . assoc)

164+ second' (ALens get _set) = ALens get' set' --(bimap id _set . assoc)

156 where

165 where

157− assoc ((a, b), c) = (a, (b, c))

166+ get' (c, a1) = let (c1, a) = get a1 in ((c, c1), a)

167+ set' ((c, c1), b) = (c, _set (c1, b))

168+ {-# INLINE second' #-}

158

169

159-- These are specialised versions of the Isos. On GHC 8.0.2, having

170-- These are specialised versions of the Isos. On GHC 8.0.2, having

160-- these functions eta-expanded allows the optimiser to inline these functions.

171-- these functions eta-expanded allows the optimiser to inline these functions.

src/Data/Generics/Internal/VL/Lens.hs+9−2

@@ -5,6 +5,7 @@

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilyDependencies #-}

7{-# LANGUAGE TypeOperators #-}

8+{-# LANGUAGE TupleSections #-}

8

9

9-----------------------------------------------------------------------------

10-----------------------------------------------------------------------------

10-- |

11-- |

@@ -23,6 +24,7 @@ module Data.Generics.Internal.VL.Lens where

23import Control.Applicative (Const(..))

24import Control.Applicative (Const(..))

24import Data.Functor.Identity (Identity(..))

25import Data.Functor.Identity (Identity(..))

25import Data.Generics.Internal.Profunctor.Lens (ALens (..), (^.), idLens)

26import Data.Generics.Internal.Profunctor.Lens (ALens (..), (^.), idLens)

27+import GHC.Exts (inline, oneShot)

26

28

27-- | Type alias for lens

29-- | Type alias for lens

28type Lens' s a

30type Lens' s a

@@ -38,12 +40,17 @@ set :: Lens s t a b -> b -> s -> t

38set l x = runIdentity . l (Identity . const x)

40set l x = runIdentity . l (Identity . const x)

39

41

40lens2lensvl :: ALens a b s t -> Lens s t a b

42lens2lensvl :: ALens a b s t -> Lens s t a b

41−lens2lensvl (ALens _get _set) = lens _get _set

43+lens2lensvl (ALens _get _set) =

44+ \f x ->

45+ let (c, a) = oneShot _get (inline x)

46+ in oneShot (_set . (c, )) <$> f (inline a)

47+{-# INLINE lens2lensvl #-}

42

48

43ravel :: (ALens a b a b -> ALens a b s t)

49ravel :: (ALens a b a b -> ALens a b s t)

44 -> Lens s t a b

50 -> Lens s t a b

45ravel l pab = (lens2lensvl $ l idLens) pab

51ravel l pab = (lens2lensvl $ l idLens) pab

46

52

47lens :: (s -> a) -> ((s, b) -> t) -> Lens s t a b

53lens :: (s -> a) -> ((s, b) -> t) -> Lens s t a b

48−lens get _set f x = curry _set x <$> f (get x)

54+lens get _set = \f x -> curry _set x <$> f (get x)

55+{-# INLINE[0] lens #-}

49

56

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

@@ -80,10 +80,10 @@ class GIsList

80 glist :: Iso (f x) (g x) (List as) (List bs)

81

82 glistL :: Lens (f x) (g x) (List as) (List bs)

83− glistL f = glist @m f

83+ glistL = glist @m

84

85 glistR :: Lens (List bs) (List as) (g x) (f x)

86− glistR f = fromIso (glist @m) f

86+ glistR = fromIso (glist @m)

87

88instance

89 ( GIsList m l l' as as'

@@ -94,9 +94,11 @@ instance

94 ) => GIsList m (l :*: r) (l' :*: r') cs cs' where

95

96 glist = prodIso . pairing (glist @m) (glist @m) . appending

97+ {-# INLINE glist #-}

97

98

98instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where

99instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where

99 glist = mIso . glist @m

100 glist = mIso . glist @m

101+ {-# INLINE glist #-}

100

102

101instance {-# OVERLAPS #-}

103instance {-# OVERLAPS #-}

102 GIsList Symbol

104 GIsList Symbol

@@ -104,15 +106,19 @@ instance {-# OVERLAPS #-}

104 (S1 ('MetaSel ('Just field) u s i) (Rec0 b))

106 (S1 ('MetaSel ('Just field) u s i) (Rec0 b))

105 '[ '(field, a)] '[ '(field, b)] where

107 '[ '(field, a)] '[ '(field, b)] where

106 glist = mIso . kIso . singleton

108 glist = mIso . kIso . singleton

109+ {-# INLINE glist #-}

107

110

108instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where

111instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where

109 glist = kIso . singleton

112 glist = kIso . singleton

113+ {-# INLINE glist #-}

110

114

111instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where

115instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where

112 glist = kIso . singleton

116 glist = kIso . singleton

117+ {-# INLINE glist #-}

113

118

114instance GIsList m U1 U1 '[] '[] where

119instance GIsList m U1 U1 '[] '[] where

115 glist = iso (const Nil) (const U1)

120 glist = iso (const Nil) (const U1)

121+ {-# INLINE glist #-}

116

122

117--------------------------------------------------------------------------------

123--------------------------------------------------------------------------------

118-- as ++ bs == cs

124-- as ++ bs == cs

@@ -168,7 +174,7 @@ instance {-# OVERLAPPING #-}

168 ( as ~ ('(f, a) ': as')

174 ( as ~ ('(f, a) ': as')

169 , bs ~ ('(f, b) ': as')

175 , bs ~ ('(f, b) ': as')

170 ) => IndexList 0 as bs a b where

176 ) => IndexList 0 as bs a b where

171− point = lens (\(x :> _) -> x) (\(_ :> xs, x') -> x' :> xs)

177+ point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)

172 {-# INLINE point #-}

178 {-# INLINE point #-}

173

179

174instance

180instance

src/Data/Generics/Product/Internal/Positions.hs+6−3

@@ -49,16 +49,19 @@ class GHasPosition (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s i

49type GHasPosition' i s a = GHasPosition i s s a a

50

51instance (GHasPosition i l l' a b, GHasPosition i r r' a b) => GHasPosition i (l :+: r) (l' :+: r') a b where

52− gposition = sumIso . choosing (gposition @i) (gposition @i)

52+ gposition = \x -> sumIso (choosing (gposition @i) (gposition @i) x)

53+ {-# INLINE gposition #-}

53

54

54instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where

55instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where

55− gposition = mLens . gposition @i

56+ gposition x = mLens (gposition @i x)

57+ {-# INLINE gposition #-}

56

58

57instance

59instance

58 ( IndexList (i - 1) as bs a b

60 ( IndexList (i - 1) as bs a b

59 , GIsList () f g as bs

61 , GIsList () f g as bs

60 ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where

62 ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where

61− gposition = mIso . glist @() . point @(i - 1)

63+ gposition x = mIso (glist @() (point @(i - 1) x))

64+ {-# INLINE gposition #-}

62

65

63type family Size f :: Nat where

66type family Size f :: Nat where

64 Size (l :*: r)

67 Size (l :*: r)

src/Data/Generics/Product/List.hs+1

@@ -47,6 +47,7 @@ instance

47 , GIsList m (Rep f) (Rep g) as bs

48 ) => IsList m f g as bs where

49 list = repIso . glist @m

50+ {-# INLINE list #-}

50

51

51class IsList Symbol f g as bs => IsRecord f g (as :: [(Symbol, Type)]) (bs :: [(Symbol, Type)]) | f -> as, g -> bs

52class IsList Symbol f g as bs => IsRecord f g (as :: [(Symbol, Type)]) (bs :: [(Symbol, Type)]) | f -> as, g -> bs

52instance IsList Symbol f g as bs => IsRecord f g as bs

53instance IsList Symbol f g as bs => IsRecord f g as bs

src/Data/Generics/Product/Positions.hs+1

@@ -119,6 +119,7 @@ instance -- see Note [Changing type parameters]

119 ) => HasPosition i s t a b where

120

121 position f s = ravel (repLens . gposition @i) f s

122+ {-# INLINE position #-}

122

123

123-- See Note [Uncluttering type signatures]

124-- See Note [Uncluttering type signatures]

124instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where

125instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where

src/Data/Generics/Product/Typed.hs+1

@@ -95,6 +95,7 @@ class HasType a s where

95 typed :: VL.Lens s s a a

96 typed

97 = VL.lens (getTyped @a) (uncurry (setTyped @a) . swap)

98+ {-# INLINE typed #-}

98

99

99 -- |Get field at type.

100 -- |Get field at type.

100 getTyped :: s -> a

101 getTyped :: s -> a

src/Data/Generics/Sum/Subtype.hs+1−1

@@ -88,7 +88,7 @@ class AsSubtype sub sup where

88 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal

89 -- Nothing

90 _Sub :: Prism' sup sub

91− _Sub eta = prism injectSub projectSub eta

91+ _Sub = prism injectSub projectSub

92 {-# INLINE _Sub #-}

93

94 -- |Injects a subtype into a supertype (upcast).

test/Spec.hs+2−1

@@ -1,5 +1,6 @@

1{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}

2−{-# OPTIONS_GHC -dsuppress-all #-}

2+{-# OPTIONS_GHC -funfolding-use-threshold=1000 #-}

3+{-# OPTIONS_GHC -dverbose-core2core -ddump-inlinings #-}

3

4

4{-# LANGUAGE AllowAmbiguousTypes #-}

5{-# LANGUAGE AllowAmbiguousTypes #-}

5{-# LANGUAGE DataKinds #-}

6{-# LANGUAGE DataKinds #-}