ae60726 · 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

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

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

53 = f (const b) s

54

55view :: Lens s s a a -> s -> a

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

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

57

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

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

59−withLens l k =

59+--ithLens l k =

60+-- case l idLens of

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

62+

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

64+withLensPrim l k =

60 case l idLens of

65 case l idLens of

61 ALens _get _set -> k _get _set

66 ALens _get _set -> k _get _set

62

67

63idLens :: ALens a b a b

68idLens :: ALens a b a b

64−idLens = ALens id snd

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

70+{-# INLINE idLens #-}

65

71

66infixr 4 .~

72infixr 4 .~

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

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

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

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

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

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

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

81first

87first

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

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

83

89

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

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

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

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

86second

92second

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

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

88

94

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

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

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

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

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

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

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

138

144

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

145choosing :: 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

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

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

141− withLens r (\getr setr ->

147+ withLensPrim r (\getr setr ->

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

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

143− g = either getl getr

149+ g e = case e of

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

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

144 s = bimap setl setr . stron

152 s = bimap setl setr . stron

145 in lens g s))

153 in lens g s))

146

154

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

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

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

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

157+{-# INLINE lens #-}

149

158

150------------------------------------------------------------------------------

159------------------------------------------------------------------------------

151

160

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

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

153

162

154instance Functor (ALens a b s) where

163instance Functor (ALens a b s) where

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

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

156

165

157instance Profunctor (ALens a b) where

166instance Profunctor (ALens a b) where

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

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

159

168

160instance Strong (ALens a b) where

169instance Strong (ALens a b) where

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

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

162 where

171 where

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

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

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

174+ {-# INLINE second' #-}

164

175

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

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

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

177-- 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+ case _get x of

46+ (c, a) -> (_set . (c, )) <$> f 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+5−2

@@ -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 = sumIso . choosing (gposition @i) (gposition @i)

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 = mLens . gposition @i

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 = ravel (mIso . glist @() . point @(i - 1))

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

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 = VL.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