7ba5d18 · generic-lens

git.iko.soy/generic-lens

Try a different represention of ALens to stop

the double case problem.

commit7ba5d18bccdb1fafbf2b16bc5b3d6ba78ced418d authorMatthew Pickering <matthewtpickering@gmail.com> dateFri 19 Jan 2018, 14:14 (9 years ago) parent72d03a2

10 files changed+58−27

compare with master

unifiedsplit

generic-lens.cabal+1−1 src/Data/Generics/Internal/Profunctor/Lens.hs+27−16 src/Data/Generics/Internal/VL/Lens.hs+9−2 src/Data/Generics/Product/Internal/List.hs+9−3 src/Data/Generics/Product/Internal/Positions.hs+6−3 src/Data/Generics/Product/List.hs+1 src/Data/Generics/Product/Positions.hs+1 src/Data/Generics/Product/Typed.hs+1 src/Data/Generics/Sum/Subtype.hs+1−1 test/Spec.hs+2−1

generic-lens.cabal+1−1

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

9090 , HUnit

9191

9292 default-language: Haskell2010

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

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

9494 if flag(dump-core)

9595 build-depends: dump-core

9696 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)

4747 = f (const b) s

4848

4949view :: Lens s s a a -> s -> a

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

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

5151

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

53−withLens l k =

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

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 =

5459 case l idLens of

5560 ALens _get _set -> k _get _set

5661

5762idLens :: ALens a b a b

58−idLens = ALens id snd

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

64+{-# INLINE idLens #-}

5965

6066infixr 4 .~

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

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

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

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

7581first

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

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

7783

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

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

8086second

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

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

8288

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

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

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

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

132138

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

135− withLens r (\getr setr ->

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

137− g = either getl getr

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

141+ withLensPrim r (\getr setr ->

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

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')

138146 s = bimap setl setr . stron

139147 in lens g s))

140148

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

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

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

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

151+{-# INLINE lens #-}

143152

144153------------------------------------------------------------------------------

145154

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)

147156

148157instance Functor (ALens a b s) where

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

150159

151160instance 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)

153162

154163instance 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)

156165 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' #-}

158169

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

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

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

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

55{-# LANGUAGE TypeFamilies #-}

66{-# LANGUAGE TypeFamilyDependencies #-}

77{-# LANGUAGE TypeOperators #-}

8+{-# LANGUAGE TupleSections #-}

910-----------------------------------------------------------------------------

1011-- |

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

2324import Control.Applicative (Const(..))

2425import Data.Functor.Identity (Identity(..))

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

27+import GHC.Exts (inline, oneShot)

2628

2729-- | Type alias for lens

2830type Lens' s a

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

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

3941

4042lens2lensvl :: 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 #-}

4248

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

4450 -> Lens s t a b

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

4652

4753lens :: (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 #-}

4956

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

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

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

8181

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

83− glistL f = glist @m f

83+ glistL = glist @m

8484

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

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

86+ glistR = fromIso (glist @m)

8787

8888instance

8989 ( GIsList m l l' as as'

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

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

9595

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

97+ {-# INLINE glist #-}

9798

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

99100 glist = mIso . glist @m

101+ {-# INLINE glist #-}

100102

101103instance {-# OVERLAPS #-}

102104 GIsList Symbol

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

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

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

106108 glist = mIso . kIso . singleton

109+ {-# INLINE glist #-}

107110

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

109112 glist = kIso . singleton

113+ {-# INLINE glist #-}

110114

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

112116 glist = kIso . singleton

117+ {-# INLINE glist #-}

113118

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

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

121+ {-# INLINE glist #-}

116122

117123--------------------------------------------------------------------------------

118124-- as ++ bs == cs

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

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

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

170176 ) => 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)

172178 {-# INLINE point #-}

173179

174180instance

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

4949type GHasPosition' i s a = GHasPosition i s s a a

5050

5151instance (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 #-}

5354

5455instance 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 #-}

5658

5759instance

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

5961 , GIsList () f g as bs

6062 ) => 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 #-}

6265

6366type family Size f :: Nat where

6467 Size (l :*: r)

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

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

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

4848 ) => IsList m f g as bs where

4949 list = repIso . glist @m

50+ {-# INLINE list #-}

5051

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

5253instance 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]

119119 ) => HasPosition i s t a b where

120120

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

122+ {-# INLINE position #-}

122123

123124-- See Note [Uncluttering type signatures]

124125instance {-# 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

9595 typed :: VL.Lens s s a a

9696 typed

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

98+ {-# INLINE typed #-}

9899

99100 -- |Get field at type.

100101 getTyped :: s -> a

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

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

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

8989 -- Nothing

9090 _Sub :: Prism' sup sub

91− _Sub eta = prism injectSub projectSub eta

91+ _Sub = prism injectSub projectSub

9292 {-# INLINE _Sub #-}

9393

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

test/Spec.hs+2−1

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

11{-# 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 #-}

45{-# LANGUAGE AllowAmbiguousTypes #-}

56{-# LANGUAGE DataKinds #-}