[Pkg-haskell-commits] [tools] 01/03: Improve binNMUs speed: Do a rough check before parsing relations.

[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 df0f12beab115f3cf96b692d8925ba9e9bd9d589
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Aug 26 13:56:26 2014 -0700

    Improve binNMUs speed: Do a rough check before parsing relations.
---
 binNMUs.hs | 51 +++++++++++++++++++++++++++++++--------------------
 1 file changed, 31 insertions(+), 20 deletions(-)

diff --git a/binNMUs.hs b/binNMUs.hs
index 7f1585e..f92915c 100644
--- a/binNMUs.hs
+++ b/binNMUs.hs
@@ -18,6 +18,7 @@ import Control.Arrow
 import qualified Data.ByteString.Char8 as B
 import Data.Time
 import Control.Lens
+--import Control.Parallel.Strategies
 
 import AcquireFile
 
@@ -66,7 +67,10 @@ data Binary = Binary
 run :: Conf -> IO ()
 run conf = do
     printHeader conf
-    cBinNMUs <- concat <$> mapM (getNMUs conf) (arches conf)
+    cBinNMUss <- mapM (getNMUs conf) (arches conf)
+    -- Parallelization, if required
+    --let cBinNMUs = concat (cBinNMUss `using` parList (evalList (evalTuple2 rseq rseq)))
+    let cBinNMUs = concat cBinNMUss
     presentProblems cBinNMUs
     presentBinNMUs cBinNMUs
 
@@ -260,13 +264,31 @@ acquirePackages conf url = do
     case parseControl url s of
         Left pe -> error $ show pe
         Right c -> return $
-            filter interesting $
-            map parsePara $
+            mapMaybe parsePara $
             unControl c
   where
-    parsePara :: Paragraph -> Binary
-    parsePara p =
-        Binary
+    parsePara :: Paragraph -> Maybe Binary
+    parsePara p = if likelyInteresting && interesting b then Just b else Nothing
+      where
+        reqField f = maybe (error $ printf "Missing field %s" f) B.unpack (fieldValue f p)
+        optField f = B.unpack <$> fieldValue f p
+
+        pkg = reqField "Package"
+        v = reqField "Version"
+
+        relField :: String -> Relations
+        relField f = case parseRelations $ fromMaybe B.empty (fieldValue f p) of
+          Left pe ->  error $ printf "Failed to parse relations %s" (show pe)
+          Right rel -> rel
+
+        flatRels :: Relations -> [String]
+        flatRels = map (\(Rel (BinPkgName n) _ _) -> n) . join
+
+        likelyInteresting =
+            maybe False (isJust . matchRegex (roughRegex conf)) (optField "Depends") ||
+            maybe False (isJust . matchRegex (roughRegex conf)) (optField "Provides")
+
+        b = Binary
             pkg
             (maybe pkg (fst.splitSrc) (optField "Source"))
             (reqField "Architecture")
@@ -274,19 +296,6 @@ acquirePackages conf url = do
             (fromMaybe v (optField "Source" >>= snd . splitSrc))
             (mapMaybe (parseVirtPackage conf) $ flatRels $ relField "Depends")
             (mapMaybe (parseVirtPackage conf) $ flatRels $ relField "Provides")
-      where reqField f = maybe (error $ printf "Missing field %s" f) B.unpack (fieldValue f p)
-            optField f = B.unpack <$> fieldValue f p
-
-            pkg = reqField "Package"
-            v = reqField "Version"
-
-            relField :: String -> Relations
-            relField f = case parseRelations $ fromMaybe B.empty (fieldValue f p) of
-              Left pe ->  error $ printf "Failed to parse relations %s" (show pe)
-              Right rel -> rel
-
-            flatRels :: Relations -> [String]
-            flatRels = map (\(Rel (BinPkgName n) _ _) -> n) . join
 
 
 interesting :: Binary -> Bool
@@ -324,13 +333,15 @@ acquireFile' conf url = do
 data Conf = Conf
     { arches :: [Arch]
     , regex :: Regex
+    , roughRegex :: Regex
     , regexS :: String -- A regex is not Show'able, so we need to keep the string
     , offline :: Bool
     , quiet :: Bool
     }
 
 mkConf :: [Arch] -> String -> Bool -> Bool -> Conf
-mkConf a r b1 b2 = Conf a (mkRegex r) r b1 b2
+mkConf a r b1 b2 =
+    Conf a (mkRegex ("^"++r++"$")) (mkRegex r) r b1 b2
 
 parseArches :: String -> ReadM [Arch]
 parseArches s =

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