ae60726 · generic-lens

git.iko.soy/generic-lens

Merge branch 'wip/merge-split-rep' into wip/boggle-merge

commitae607261bce31ce83c9d466a6d1c952b1545e772 authorMatthew Pickering <matthewtpickering@gmail.com> dateTue 23 Jan 2018, 16:32 (9 years ago) parentd539770 97aaeac

8 files changed+54−24

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+5−2 src/Data/Generics/Product/List.hs+1 src/Data/Generics/Product/Positions.hs+1 src/Data/Generics/Product/Typed.hs+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

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

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

5353 = f (const b) s

5454

5555view :: Lens s s a a -> s -> a

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

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

5757

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

59−withLens l k =

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

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 =

6065 case l idLens of

6166 ALens _get _set -> k _get _set

6267

6368idLens :: ALens a b a b

64−idLens = ALens id snd

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

70+{-# INLINE idLens #-}

6571

6672infixr 4 .~

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

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

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

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

8187first

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

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

8389

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

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

8692second

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

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

8894

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

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

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

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

138144

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

141− withLens r (\getr setr ->

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

143− g = either getl getr

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

147+ withLensPrim r (\getr setr ->

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

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

144152 s = bimap setl setr . stron

145153 in lens g s))

146154

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

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

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

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

157+{-# INLINE lens #-}

149158

150159------------------------------------------------------------------------------

151160

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)

153162

154163instance Functor (ALens a b s) where

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

156165

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

159168

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

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

164175

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

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

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

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

53+ {-# INLINE gposition #-}

5354

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

5556 gposition = mLens . gposition @i

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

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

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