[commit: packages/binary] master: Rewrite mappend to only depend on the Builders. (6ca5897)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/binary

On branch  : master
Link       : http://git.haskell.org/packages/binary.git/commitdiff/6ca5897ce22b6bf9cf9b4a0e8ce72994928d413f

>---------------------------------------------------------------

commit 6ca5897ce22b6bf9cf9b4a0e8ce72994928d413f
Author: Lennart Kolmodin <kolmodin at gmail.com>
Date:   Sat Apr 16 10:04:47 2016 +0200

    Rewrite mappend to only depend on the Builders.
    
    This gives a 5% speedup in the generics-bench benchmark.


>---------------------------------------------------------------

6ca5897ce22b6bf9cf9b4a0e8ce72994928d413f
 src/Data/Binary/Generic.hs | 9 +++++----
 src/Data/Binary/Put.hs     | 5 ++++-
 2 files changed, 9 insertions(+), 5 deletions(-)

diff --git a/src/Data/Binary/Generic.hs b/src/Data/Binary/Generic.hs
index 9967f95..bcf8e46 100644
--- a/src/Data/Binary/Generic.hs
+++ b/src/Data/Binary/Generic.hs
@@ -28,26 +28,27 @@ import Data.Binary.Get
 import Data.Binary.Put
 import Data.Bits
 import Data.Word
+import Data.Monoid ((<>))
 import GHC.Generics
 import Prelude -- Silence AMP warning.
 
 -- Type without constructors
 instance GBinaryPut V1 where
-    gput _ = return ()
+    gput _ = pure ()
 
 instance GBinaryGet V1 where
     gget   = return undefined
 
 -- Constructor without arguments
 instance GBinaryPut U1 where
-    gput U1 = return ()
+    gput U1 = pure ()
 
 instance GBinaryGet U1 where
     gget    = return U1
 
 -- Product: constructor with parameters
 instance (GBinaryPut a, GBinaryPut b) => GBinaryPut (a :*: b) where
-    gput (x :*: y) = gput x >> gput y
+    gput (x :*: y) = gput x <> gput y
 
 instance (GBinaryGet a, GBinaryGet b) => GBinaryGet (a :*: b) where
     gget = (:*:) <$> gget <*> gget
@@ -130,7 +131,7 @@ instance GBinaryGet a => GSumGet (C1 c a) where
     getSum _ _ = gget
 
 instance GBinaryPut a => GSumPut (C1 c a) where
-    putSum !code _ x = put code *> gput x
+    putSum !code _ x = put code <> gput x
 
 ------------------------------------------------------------------------
 
diff --git a/src/Data/Binary/Put.hs b/src/Data/Binary/Put.hs
index 07a86c0..23db39f 100644
--- a/src/Data/Binary/Put.hs
+++ b/src/Data/Binary/Put.hs
@@ -139,7 +139,10 @@ instance Monoid (PutM ()) where
     mempty = pure ()
     {-# INLINE mempty #-}
 
-    mappend = (>>)
+    mappend m k = Put $
+        let PairS _ w  = unPut m
+            PairS _ w' = unPut k
+        in PairS () (w `mappend` w')
     {-# INLINE mappend #-}
 
 tell :: Builder -> Put