ef002d2 · generic-lens

git.iko.soy/generic-lens

on master help sign in

All optimisations are go

ef002d2Matthew Pickering9 years ago

src/Data/Generics/Sum/Internal/Subtype.hs+5−11

compare with master

unifiedsplit

@@ -46,8 +46,8 @@ instance

46 ( GSplash sub sup

47 , GDowncast sub sup

48 ) => GAsSubtype sub sup where

49− _GSub f = prismPRavel (prism _GSplash _GDowncast) f

49+ _GSub f = (prism _GSplash _GDowncast) f

50− {-# INLINE _GSub #-}

50+ {-# INLINE[0] _GSub #-}

52--------------------------------------------------------------------------------

@@ -57,18 +57,15 @@ class GSplash (sub :: Type -> Type) (sup :: Type -> Type) where

57instance (GSplash a sup, GSplash b sup) => GSplash (a :+: b) sup where

58 _GSplash (L1 rep) = _GSplash rep

59 _GSplash (R1 rep) = _GSplash rep

60− {-# INLINE _GSplash #-}

62instance

61instance

63 ( GIsList () subf subf as as

62 ( GIsList () subf subf as as

64 , GAsType supf as

63 , GAsType supf as

65 ) => GSplash (C1 meta subf) supf where

64 ) => GSplash (C1 meta subf) supf where

66− _GSplash p = build (prismPRavel (_GTyped . fromIso (glist @()) . fromIso mIso)) p

65+ _GSplash p = build ((_GTyped . fromIso (glist @()) . fromIso mIso)) p

67− {-# INLINE _GSplash #-}

69instance GSplash sub sup => GSplash (D1 c sub) sup where

67instance GSplash sub sup => GSplash (D1 c sub) sup where

70 _GSplash (M1 m) = _GSplash m

68 _GSplash (M1 m) = _GSplash m

71− {-# INLINE _GSplash #-}

73--------------------------------------------------------------------------------

70--------------------------------------------------------------------------------

@@ -82,7 +79,6 @@ instance

82 _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of

79 _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of

83 Left _ -> Left (M1 m)

80 Left _ -> Left (M1 m)

84 Right r -> Right r

81 Right r -> Right r

85− {-# INLINE _GDowncast #-}

87instance (GDowncast sub l, GDowncast sub r) => GDowncast sub (l :+: r) where

83instance (GDowncast sub l, GDowncast sub r) => GDowncast sub (l :+: r) where

88 _GDowncast (L1 x) = case _GDowncast x of

84 _GDowncast (L1 x) = case _GDowncast x of

@@ -91,24 +87,22 @@ instance (GDowncast sub l, GDowncast sub r) => GDowncast sub (l :+: r) where

91 _GDowncast (R1 x) = case _GDowncast x of

87 _GDowncast (R1 x) = case _GDowncast x of

92 Left _ -> Left (R1 x)

88 Left _ -> Left (R1 x)

93 Right r -> Right r

89 Right r -> Right r

94− {-# INLINE _GDowncast #-}

96instance GDowncast sub sup => GDowncast sub (D1 m sup) where

91instance GDowncast sub sup => GDowncast sub (D1 m sup) where

97 _GDowncast (M1 m) = case _GDowncast m of

92 _GDowncast (M1 m) = case _GDowncast m of

98 Left _ -> Left (M1 m)

93 Left _ -> Left (M1 m)

99 Right r -> Right r

94 Right r -> Right r

100− {-# INLINE _GDowncast #-}

101

102class GDowncastC (contains :: Bool) sub sup where

96class GDowncastC (contains :: Bool) sub sup where

103 _GDowncastC :: sup x -> Either (sup x) (sub x)

97 _GDowncastC :: sup x -> Either (sup x) (sub x)

104

105instance GDowncastC 'False sub sup where

99instance GDowncastC 'False sub sup where

106 _GDowncastC sup = Left sup

100 _GDowncastC sup = Left sup

107− {-# INLINE _GDowncastC #-}

108

101

109instance

102instance

110 ( GAsType sub subl

103 ( GAsType sub subl

111 , GIsList () sup sup subl subl

104 , GIsList () sup sup subl subl

112 ) => GDowncastC 'True sub sup where

105 ) => GDowncastC 'True sub sup where

113− _GDowncastC sup = Right (build (prismPRavel (_GTyped . fromIso (glist @()))) sup)

106+ _GDowncastC sup = Right (build (_GTyped . fromIso (glist @())) sup)

114 {-# INLINE _GDowncastC #-}

107 {-# INLINE _GDowncastC #-}

108+

src/Data/Generics/Sum/Internal/Typed.hs+7

@@ -29,6 +29,7 @@ module Data.Generics.Sum.Internal.Typed

30import Data.Kind

31import GHC.Generics

32+import Data.Tagged

33import Data.Generics.Internal.Families

34import Data.Generics.Internal.Families

34import Data.Generics.Product.Internal.List

35import Data.Generics.Product.Internal.List

@@ -38,6 +39,12 @@ import Data.Generics.Internal.Profunctor.Prism

38-- |As 'AsType' but over generic representations as defined by "GHC.Generics".

39-- |As 'AsType' but over generic representations as defined by "GHC.Generics".

39class GAsType (f :: Type -> Type) (as :: [((), Type)]) where

40class GAsType (f :: Type -> Type) (as :: [((), Type)]) where

40 _GTyped :: Prism (f x) (f x) (List as) (List as)

41 _GTyped :: Prism (f x) (f x) (List as) (List as)

42+-- We create this specialised version as we use it in the subtype prism

43+-- If we don't create it, the opportunity for specialisation is only

44+-- created after specialisation happens, I think a late specialisation pass

45+-- would pick up this case.

46+{-# SPECIALISE _GTyped :: (Tagged b b -> Tagged t t) #-}

47+

42instance

49instance

43 ( GIsList () f f as as

50 ( GIsList () f f as as

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

@@ -90,7 +90,6 @@ class AsSubtype sub sup where

90 -- Nothing

91 _Sub :: Prism' sup sub

92 _Sub = prism injectSub projectSub

93− {-# INLINE _Sub #-}

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

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

96 injectSub :: sub -> sup

95 injectSub :: sub -> sup

@@ -109,7 +108,7 @@ instance

109 ) => AsSubtype sub sup where

108 ) => AsSubtype sub sup where

110

109

111 _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f

110 _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f

112− {-# INLINE _Sub #-}

111+ {-# INLINE[2] _Sub #-}

113

112

114-- See Note [Uncluttering type signatures]

113-- See Note [Uncluttering type signatures]

115instance {-# OVERLAPPING #-} AsSubtype a Void where

114instance {-# OVERLAPPING #-} AsSubtype a Void where

test/Spec.hs+4−3

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

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

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

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

4{-# LANGUAGE AllowAmbiguousTypes #-}

5{-# LANGUAGE DataKinds #-}

@@ -127,14 +127,15 @@ sum2PrismManualChar eta = prism g f eta

127 s -> Left s

128 g = A2

129

130−

130+-- Note we don't have a catch-all case because of #14684

131subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2

132subtypePrismManual eta = prism g f eta

133 where

134 f s1 = case s1 of

135 A c -> Right (A2 c)

136 B i -> Right (B2 i)

137+ C _ -> Left s1

137− _ -> Left s1

138+ D _ -> Left s1

138 g (A2 c) = A c

139 g (A2 c) = A c

139 g (B2 i) = B i

140 g (B2 i) = B i

140

141