[Pkg-haskell-commits] [tools] 01/01: Try to fix some speak-leaks in binNMU

[Joachim Breitner]

This is an automated email from the git hooks/post-receive script.

nomeata pushed a commit to branch master
in repository tools.

commit 0e3dca7767efb1eb034f468a0b849cfa21743f8b
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Jul 7 11:11:33 2015 +0200

    Try to fix some speak-leaks in binNMU
    
    although it did not help a lot, it seems.
---
 AcquireFile.hs |  6 +++---
 binNMUs.hs     | 39 +++++++++++++++++++++++----------------
 2 files changed, 26 insertions(+), 19 deletions(-)

diff --git a/AcquireFile.hs b/AcquireFile.hs
index 719934c..9fb6c79 100644
--- a/AcquireFile.hs
+++ b/AcquireFile.hs
@@ -44,10 +44,10 @@ acquireFile url ungz offline = do
                         hPutStrLn stderr $ "File " ++ savename ++ " does not exist after invoking"
                         hPutStrLn stderr $ intercalate " " ("curl" : args)
                         exitFailure
-                   text <- BL.readFile savename
+                   text <- B.readFile savename
                    return $ if ungz
-                            then BL.toStrict $ decompress  text
-                            else BL.toStrict $ text
+                            then BL.toStrict $ decompress $ BL.fromStrict text 
+                            else text
     where fixChar '/' = '_'
           fixChar ':' = '_'
           fixChar c   = c
diff --git a/binNMUs.hs b/binNMUs.hs
index a362dc7..cb8247c 100644
--- a/binNMUs.hs
+++ b/binNMUs.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, DeriveGeneric #-}
 
 import Text.Printf
 import Data.List
@@ -8,8 +8,9 @@ import Data.Char
 import Data.Ord
 import Data.Function
 import Options.Applicative
+import Options.Applicative.Types (readerAsk)
 import qualified Data.Set as S
-import qualified Data.Map as M
+import qualified Data.Map.Strict as M
 import Debian.Control.ByteString
 import Debian.Relation.Common
 import Debian.Relation.ByteString
@@ -21,6 +22,10 @@ import Control.Arrow
 import qualified Data.ByteString.Char8 as B
 import Data.Time
 import Control.Lens
+import Control.Seq
+import GHC.Generics (Generic)
+import Control.DeepSeq
+
 
 #ifdef SQL
 import Database.PostgreSQL.Simple hiding (Binary)
@@ -48,7 +53,8 @@ data VirtPackage = VirtPackage
     , vpBase   :: VirtPackageBase
     , vpHashes :: [String]
     }
-    deriving (Eq, Ord, Show)
+    deriving (Eq, Ord, Show, Generic)
+instance NFData VirtPackage
 type VirtPackageBase = String -- just the part without the hash (and without libghc-)
 
 data Status -- ^ Status of a binNMU
@@ -64,7 +70,7 @@ data Status -- ^ Status of a binNMU
 
 data Reason
     = MissingDep VirtPackage
-    | UpgradedDep VirtPackage VirtPackage
+    | UpgradedDep String String String
   deriving (Eq, Ord, Show)
 
 type BinNMU = (Binary, [Reason])
@@ -79,7 +85,8 @@ data Binary = Binary
     , bDepends :: [VirtPackage] --simplified, we consider relevant deps only
     , bProvides :: [VirtPackage]
     }
-  deriving Show
+  deriving (Show, Generic)
+instance NFData Binary
 
 -- The main action
 
@@ -196,8 +203,11 @@ formatNMU dist (ss, as, d) =
 formatReason :: Reason -> String
 formatReason (MissingDep d)
     = printf "%s has disappeared" (vpFull d)
-formatReason (UpgradedDep d1 d2)
+formatReason (UpgradedDep base hash1 hash2)
     = printf "%s changed from %s to %s" base hash1 hash2
+
+mkUpgradedDep :: VirtPackage -> VirtPackage -> Reason
+mkUpgradedDep d1 d2 = UpgradedDep base hash1 hash2
   where
     base = intercalate "-" $ vpBase d1 : map fst commonHashes
     (commonHashes, (hash1,hash2):_) = span (uncurry (==)) $ zip (vpHashes d1) (vpHashes d2)
@@ -253,7 +263,7 @@ needsRebuild available b
 
     go v = case M.lookup (vpBase v) available of
         Nothing                  -> Just $ MissingDep v
-        Just vs | v `notElem` vs -> Just $ UpgradedDep v (head vs)
+        Just vs | v `notElem` vs -> Just $ mkUpgradedDep v (head vs)
                 | otherwise -> Nothing
 
 -- Parsing virtual package names
@@ -315,10 +325,7 @@ fetchWannaBuildHTTP conf a = do
     s <- acquireFile' conf True url
     case parseControl url s of
         Left pe -> error $ show pe
-        Right c -> return $
-            M.fromList $
-            map parsePara $
-            unControl c
+        Right c -> return $! M.fromList $! (map parsePara (unControl c) `using` seqList rdeepseq)
   where
     url = wannaBuildDumpUrl a
 
@@ -347,9 +354,8 @@ acquirePackagesHTTP conf suite arch = do
     s <- acquireFile' conf True url
     case parseControl url s of
         Left pe -> error $ show pe
-        Right c -> return $
-            mapMaybe parsePara $
-            unControl c
+        Right c -> return $!
+            (mapMaybe parsePara (unControl c) `using` seqList rdeepseq)
   where
     url = packageURL suite arch
     parsePara :: Paragraph -> Maybe Binary
@@ -516,8 +522,9 @@ mkConf :: String -> [Arch] -> String -> Bool -> Bool -> Bool -> Bool -> Bool ->
 mkConf d a r =
     Conf d a (makeRegex ("^"++r++"$")) (makeRegex r) r
 
-parseArches :: String -> ReadM [Arch]
-parseArches s =
+parseArches :: ReadM [Arch]
+parseArches = do
+    s <- readerAsk
     case split (dropBlanks $ dropDelims $ oneOf ";, ") s of
         [] -> readerError "Empty list of architectures"
         arches -> case filter (not . (`elem` allArches)) arches of

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-haskell/tools.git