[Pkg-haskell-commits] [tools] 03/03: Combine nmu-lines with same packages and/or arches

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

    Combine nmu-lines with same packages and/or arches
---
 binNMUs.hs | 57 ++++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 40 insertions(+), 17 deletions(-)

diff --git a/binNMUs.hs b/binNMUs.hs
index e0f5757..7f1585e 100644
--- a/binNMUs.hs
+++ b/binNMUs.hs
@@ -17,6 +17,7 @@ import System.IO
 import Control.Arrow
 import qualified Data.ByteString.Char8 as B
 import Data.Time
+import Control.Lens
 
 import AcquireFile
 
@@ -47,7 +48,7 @@ data Reason
   deriving (Eq, Ord, Show)
 
 type BinNMU = (Binary, [Reason])
-type CBinNMU = (Status, (SourceName, Version, Arch, [Reason]))
+type CBinNMU = (Status, ((SourceName, Version), Arch, [Reason]))
 
 data Binary = Binary
     { bPkgName :: String
@@ -90,17 +91,7 @@ presentProblems cBinNMUs
         putCLn "These dependency changes are observed:"
         mapM_ (putCLn . formatReason) (S.toAscList problems)
         putStrLn ""
-  where problems = S.fromList $ [ p | (_,(_,_,_,ps)) <- cBinNMUs, p <- ps ]
-
-presentBinNMUs :: [CBinNMU] -> IO ()
-presentBinNMUs cBinNMUs = do
-    forM_ (ordGroupBy fst cBinNMUs) $ \(s, cBinNMUs) -> do
-        unless (ignoreStatus s) $ do
-        putCLn $ statusHeader s
-        putStr $ alignAt " . "
-            [ (if actStatus s then "" else "# ") ++ formatNMU nmu
-            | nmu <- sortBy (compare `on` (\(a,b,c,d) -> a)) $ map snd cBinNMUs ]
-        putStrLn ""
+  where problems = S.fromList $ concatMap (^. (_2._3)) cBinNMUs
 
 statusHeader :: Status -> String
 statusHeader Needed = "Actually required NMUs"
@@ -128,10 +119,36 @@ alignAt d lines = unlines (map expands rows)
         expands [] = ""
         expands r = concat (zipWith expand colwidths (init r)) ++ last r
 
-formatNMU :: (SourceName, Version, Arch, [Reason]) -> String
-formatNMU (s, v, a, d) =
-    printf "nmu %s_%s . %s . -m '%s'"
-        s v a
+presentBinNMUs :: [CBinNMU] -> IO ()
+presentBinNMUs cBinNMUs = do
+    forM_ (ordGroupBy fst cBinNMUs) $ \(s, cBinNMUs) -> do
+        unless (ignoreStatus s) $ do
+        putCLn $ statusHeader s
+        putStr $ alignAt " . "
+            [ (if actStatus s then "" else "# ") ++ formatNMU nmu
+            | nmu <- sortBy (compare `on` (^. _1)) $
+              groupNMUs $
+              map snd cBinNMUs
+            ]
+        putStrLn ""
+
+groupNMUs :: (Ord a, Ord b, Ord c) => [(a, b, c)] -> [([a], [b], c)]
+groupNMUs =
+    concat .
+    map (\(c,abs) ->
+        map (\(bs,as) -> (as,bs,c)) $
+        groupEqual $
+        map (\(a,bs) -> (bs,a)) $
+        groupEqual $
+        abs) .
+    groupEqual .
+    map (\(a,b,c) -> (c,(a,b)))
+
+formatNMU :: ([(SourceName, Version)], [Arch], [Reason]) -> String
+formatNMU (ss, as, d) =
+    printf "nmu %s . %s . -m '%s'"
+        (intercalate " " $ map (uncurry (printf "%s_%s")) ss)
+        (intercalate " " as)
         (intercalate ", " $ map formatReason d)
 
 formatReason :: Reason -> String
@@ -155,7 +172,7 @@ getNMUs conf a = do
                                         ]
     let binNMUs = mapMaybe (needsRebuild available) pkgs
     let cBinNMUs = map (categorize available wbmap &&&
-         (\(p,r) -> (bSourceName p, bSrcVersion p, bArchitecture p, r))) binNMUs
+         (\(p,r) -> ((bSourceName p, bSrcVersion p), bArchitecture p, r))) binNMUs
     return cBinNMUs
 
 -- Categorizing nmus
@@ -359,6 +376,12 @@ haskellRegex = "libghc-(.*)-dev-([0-9.]+-[0-9a-f]{5})"
 putC s = putStr  ("# " ++ s)
 putCLn s = putStrLn ("# " ++ s)
 
+
+-- Generic grouping algorithm
+
+groupEqual :: Ord a => [(a,b)] -> [(a, [b])]
+groupEqual xs = M.toList (M.fromListWith (++) (map (second ((:[]))) xs))
+
 -- Main program
 
 main :: IO ()

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