[Pkg-haskell-commits] [tools] 02/02: Added reasons.hs as described at https://lists.debian.org/debian-haskell/2014/08/msg00027.html

[Sven Bartscher]

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

svenb-guest pushed a commit to branch master
in repository tools.

commit 62349c964a1b503f28433fc863614ec17be8fb6c
Author: Sven Bartscher <sven.bartscher at weltraumschlangen.de>
Date:   Sun Aug 17 13:31:07 2014 +0200

    Added reasons.hs as described at https://lists.debian.org/debian-haskell/2014/08/msg00027.html
---
 reasons.hs | 124 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 124 insertions(+)

diff --git a/reasons.hs b/reasons.hs
new file mode 100644
index 0000000..745fb2d
--- /dev/null
+++ b/reasons.hs
@@ -0,0 +1,124 @@
+import Text.Regex.PCRE
+import System.Environment
+import System.Exit
+import System.Process
+import System.IO
+import Data.Maybe
+import Data.List
+import Data.Char
+import qualified Data.Set as S
+import Control.Exception
+
+data Excuses = Excuses String [String]
+
+isEmpty :: Excuses -> Bool
+isEmpty (Excuses _ []) = False
+isEmpty (Excuses _ _) = True
+
+excuses2String :: Excuses -> String
+excuses2String (Excuses pkg excuses) = unlines $ (pkg ++ ":"):(map ("    " ++) excuses)
+
+main = do
+  (britneyout, package) <- getArgs >>= parse
+  output <- fmap lines $ readFile britneyout
+  let bins = getBinBlockers output package
+  result <- try (fmap nub $ mapM getSrcPackage bins) :: IO (Either ErrorCall [String])
+  srcBlockers <- case result of
+                   Left e -> putStrLn packageNotFoundMsg >> exitFailure
+                   Right pkgs -> return pkgs
+  excuses <- mapM getExcuse srcBlockers
+  let filteredExcuses = filterExcuses (isInteresting srcBlockers) excuses
+  mapM_ putStrLn $ map excuses2String filteredExcuses
+
+parse :: [String] -> IO (String, String)
+parse [britneyout, package] = return (britneyout, package)
+parse _ = printUsage >> exitFailure
+
+printUsage :: IO ()
+printUsage = do
+  progName <- getProgName
+  putStrLn $ "Usage: " ++ progName ++ " britney-output package-name"
+
+packageNotFoundMsg :: String
+packageNotFoundMsg
+    = "The package you requested was not processed by the autohinter.\n\
+       \grep-excuses <pkg> should list all reasons why this package doesn't\
+       \migrate."
+
+filterExcuses :: (String -> Bool) -> [Excuses] -> [Excuses]
+filterExcuses f excuses = filter isEmpty $ map filterPkgExcuses excuses
+    where filterPkgExcuses (Excuses pkg excuses) = Excuses pkg
+                                                   $ filter f excuses
+
+isInteresting :: [String] -> String -> Bool
+isInteresting blockers excuse = "out of date on" `isPrefixOf` excuse 
+                                || "introduces new bugs" `isInfixOf` excuse
+                                || "Too young" `isPrefixOf` excuse
+                                || isInterestingDependency blockers excuse
+
+isInterestingDependency :: [String] -> String -> Bool
+isInterestingDependency pkgs excuse = "(not considered)" `isSuffixOf` excuse 
+                                      && dependency `notElem` pkgs
+    where dependency' = excuse =~ "(?<=Depends: ).*(?= \\(not considered\\))"
+          dependency
+              | null dependency' = ""
+              | otherwise = tail $ dropWhile (/= ' ') dependency'
+
+maybeTail :: [a] -> Maybe [a]
+maybeTail [] = Nothing
+maybeTail (x:xs) = Just xs
+
+getExcuse :: String -> IO Excuses
+getExcuse pkg = do
+  --hPutStrLn stderr $ "retrievieng excuses for " ++ pkg
+  excuses <- readProcess "/usr/bin/grep-excuses" [pkg] ""
+  return $ Excuses pkg $ map (dropWhile isSpace)
+             $ fromMaybe [] $ maybeTail $ lines excuses
+
+getSrcPackage :: String -> IO String
+getSrcPackage bin = do
+  --hPutStrLn stderr $ "querying source for " ++ bin
+  packageDesc <- readProcess "/usr/bin/apt-cache" ["showsrc", bin] ""
+  return $ parseDesc packageDesc
+
+parseDesc :: String -> String
+parseDesc desc = let ls = lines desc
+                     srcln = findSourceLine ls
+                 in removeFieldPrefix srcln
+
+findSourceLine :: [String] -> String
+findSourceLine (curLine:rest)
+    | "Package: " `isPrefixOf` curLine = curLine
+    | otherwise = findSourceLine rest
+
+getBinBlockers :: [String] -> String -> [String]
+getBinBlockers output package = let arches = getArches package output
+                                in nub $ map stripComma
+                                       $ concat
+                                       $ map words
+                                       $ map removeFieldPrefix arches
+                                    where stripComma str = if last str == ','
+                                                           then init str
+                                                           else str
+
+removeFieldPrefix :: String -> String
+removeFieldPrefix arch = drop 2 $ dropWhile (/= ':') arch
+
+getArches :: String -> [String] -> [String]
+getArches package output = get $ removeStats $ fromJust $ findAutohint package output
+    where get (line:rest)
+              | line `matches` " *\\* .*:" = line : get rest
+              | otherwise = []
+
+removeStats :: [String] -> [String]
+removeStats = drop 4
+
+findAutohint :: String -> [String] -> Maybe [String]
+findAutohint _ [] = Nothing
+findAutohint package (curLine:rest)
+    | curLine `matches` ("Trying easy from autohinter.*" ++ package)
+        = Just rest
+    | otherwise = findAutohint package rest
+
+matches :: String -> String -> Bool
+str `matches` pattern = (not . null) (str =~ pattern :: String)

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