[Pkg-haskell-commits] darcs: tools: Take wanna-build dump into account
Joachim Breitner
mail at joachim-breitner.de
Mon May 3 12:28:53 UTC 2010
Mon May 3 12:21:33 UTC 2010 Joachim Breitner <mail at joachim-breitner.de>
* Take wanna-build dump into account
Ignore-this: 1393c6b3b942b6958e043f3931596a94
M ./haskell-pkg-debcheck.hs -20 +134
Mon May 3 12:21:33 UTC 2010 Joachim Breitner <mail at joachim-breitner.de>
* Take wanna-build dump into account
Ignore-this: 1393c6b3b942b6958e043f3931596a94
diff -rN -u old-tools/haskell-pkg-debcheck.hs new-tools/haskell-pkg-debcheck.hs
--- old-tools/haskell-pkg-debcheck.hs 2010-05-03 12:28:53.119080116 +0000
+++ new-tools/haskell-pkg-debcheck.hs 2010-05-03 12:28:53.119080116 +0000
@@ -1,3 +1,5 @@
+{-# LANGUAGE PatternGuards #-}
+
import System.Directory
import System.Process
import Control.Monad
@@ -6,10 +8,11 @@
import Data.List
import Data.List.Split
import System.IO
-import Text.XML.HaXml hiding ((!))
+import Text.XML.HaXml hiding ((!),when)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LB
import qualified Codec.Compression.BZip as BZip
+import qualified Codec.Compression.GZip as GZip
import Debian.Control
import Debian.Control.ByteString
import Debian.Relation
@@ -19,11 +22,13 @@
import qualified Data.Map as M
import Data.Map ((!))
import qualified Data.Set as S
+import Debug.Trace
+import Text.Printf
type Arch = String
arches :: [Arch]
--- arches = ["amd64","i386"]
+--arches = ["amd64","i386"]
arches = words "amd64 armel hppa i386 ia64 mips mipsel powerpc s390 sparc kfreebsd-amd64 kfreebsd-i386"
@@ -63,23 +68,34 @@
forM arches $ \arch ->
toBinaryMap arch (M.keysSet bToS) <$>
(either (error.show) id) <$>
- parseControl "Sources" <$>
+ parseControl "Binary" <$>
BS.concat <$>
LB.toChunks <$>
BZip.decompress <$>
LB.readFile (binariesFiles arch)
hPutStrLn stderr $ show (M.size binaryMap) ++ " binary/arch tuples selected."
+ hPutStr stderr "# Reading Wanna-Build-State..."
+ wbMap <-
+ fmap M.unions $
+ forM arches $ \arch ->
+ toWBMap arch sourcesMap <$>
+ (either (error.show) id) <$>
+ parseControl "Wanna-Build" <$>
+ BS.concat <$>
+ LB.toChunks <$>
+ GZip.decompress <$>
+ LB.readFile (wbDump arch)
+ hPutStrLn stderr $ show (M.size wbMap) ++ " source/arch tuples selected."
+
hPutStr stderr "# Reading edos-debcheck output..."
problems <- removeArchAll <$> collectEdosOutput (filter isNotIgnored (M.keys bToS))
hPutStrLn stderr $ show (length problems) ++ " problems detected."
let outdatedSources = M.fromListWith mergeArches $ do -- list monad
- ((p,a),(bv,_)) <- M.toList binaryMap
- let s = bToS ! p
- si = sourcesMap ! s
- sv = siVersion si
- guard $ bv < sv
+ ((s,a),(st,dw)) <- M.toList wbMap
+ guard $ st /= "Installed"
+ let sv = siVersion (sourcesMap ! s)
return (s,(S.singleton a, sv, "dummy"))
let nmus = M.fromListWith mergeArches $ do
@@ -90,41 +106,49 @@
(_,bsv) = binaryMap ! (p,a)
sv = siVersion si
guard (bsv == sv) -- Do not schedule binNMUs for outdated sources
- return (s,(S.singleton a, sv, "Rebuild against updated dependencies"))
+ return (s,(S.singleton a, sv, formatReason x))
forM (M.toList nmus) $ \(s,(as,sv,exp)) -> putStrLn $ "nmu " ++ s ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ exp ++ "'"
let buildingSources = M.unionWith mergeArches outdatedSources nmus
- let depwaits = M.fromListWith (M.unionWith S.union) $ do
+ let depwaits = filterExistingDepWaits wbMap $
+ M.fromListWith (M.unionWith mergeRelations) $ do
(s,(as,sv,_)) <- M.toList buildingSources
a <- S.toList as
bdep <- flattenRelations (siBuildDepends (sourcesMap ! s))
guard (isNotIgnored bdep)
guard (bdep `M.member` bToS)
let dsi = sourcesMap ! (bToS ! bdep)
- msg <-
+ dw <-
(do
guard $ siName dsi `M.member` outdatedSources
guard $ a `S.member` (let (as,_,_) = outdatedSources ! siName dsi in as)
- return $ bdep ++ " (>= " ++ show (siVersion dsi) ++ ")"
+ let dwv = siVersion dsi
+ return $ [[(Rel bdep (Just (GRE dwv)) Nothing )]]
) ++
(do
guard $ siName dsi `M.member` nmus
guard $ a `S.member` (let (as,_,_) = nmus ! siName dsi in as)
- return $ bdep ++ " (>> " ++ show (fst (binaryMap ! (bdep,a))) ++ ")"
+ let dwv = fst (binaryMap ! (bdep,a))
+ return $ [[(Rel bdep (Just (SGR dwv)) Nothing)]]
)
- return ((s,sv),M.singleton a (S.singleton msg))
+ return ((s,sv),M.singleton a dw)
forM (M.toList depwaits) $ \((s,sv),m) -> do
-- Reorder to collapse dw lines with identical depwait command
let m2 = M.fromListWith S.union $ do
- (a,dws) <- M.toList m
- return (dws, S.singleton a)
- forM (M.toList m2) $ \(dws,as) ->
- putStrLn $ "dw " ++ s ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ intercalate ", " (S.toList dws) ++ "'"
+ (a,fdws) <- M.toList m
+ return (fdws, S.singleton a)
+ forM (M.toList m2) $ \((f,dws),as) -> do
+ forM (S.toList as) $ \a ->
+ do case (s, a) `M.lookup` wbMap of
+ Just (_,cdw@(_:_)) -> putStrLn $ "# Current Dep-Wait on " ++ a ++ ": " ++ showRelations cdw
+ _ -> return ()
+ when (not f) $ putStr "# "
+ putStrLn $ "dw " ++ s ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ showRelations dws ++ "'"
-interestingSource = any (\(Rel p _ _) -> p == "haskell-devscripts") . concat . siBuildDepends
+interestingSource si = "haskell-devscripts" `elem` (flattenRelations (siBuildDepends si))
mergeArches n1@(as1, v1, x1) n2@(as2, v2, x2)
| v1 == v2 = (as1 `S.union` as2, v1, x1)
@@ -132,9 +156,11 @@
| v1 < v2 = n2
toSourcesMap =
- M.fromList .
+ M.fromListWith higherSourceVersion .
mapMaybe (\para -> do -- Maybe monad
p <- BS.unpack <$> fieldValue "Package" para
+ a <- BS.unpack <$> fieldValue "Architecture" para
+ guard (a /= "all")
v <- parseDebianVersion <$>
fieldValue "Version" para
bins <-
@@ -171,9 +197,36 @@
) .
unControl
+toWBMap arch sourcesMap =
+ M.fromList .
+ mapMaybe (\para -> do -- Maybe monad
+ s <- BS.unpack <$>
+ fieldValue "package" para
+ guard (s `M.member` sourcesMap)
+ v <- parseDebianVersion <$>
+ fieldValue "version" para
+ -- Consider all the posibilities here: What if wanna-build is newer,
+ -- what if it is older?
+ when (v /= siVersion (sourcesMap ! s)) $
+ trace (printf "Version difference: %s and %s\n" (show v) (show (siVersion (sourcesMap ! s)))) $
+ return ()
+ guard (v == siVersion (sourcesMap ! s))
+ st <- BS.unpack <$>
+ fieldValue "state" para
+ dw <- (
+ (either (error.show) id) <$>
+ parseRelations <$>
+ fieldValue "depends" para
+ ) `mplus` Just []
+ return ((s,arch), (st,dw))
+ ) .
+ unControl
+
flattenRelations :: Relations -> [PkgName]
flattenRelations = map (\(Rel p _ _) -> p) . concat
+higherSourceVersion si1 si2 = if siVersion si1 > siVersion si2 then si1 else si2
+
checkFiles :: IO ()
checkFiles =
forM_ (sourcesFile : map binariesFiles arches ++ map wbDump arches ) $ \file -> do
@@ -195,3 +248,64 @@
isNotIgnored :: PkgName -> Bool
isNotIgnored pkg = not ("-doc" `isSuffixOf` pkg || "-prof" `isSuffixOf` pkg)
+
+formatReason :: String -> String
+formatReason s = "Dependency " ++ packageName ++ " not available any more"
+ where lastLine = last (lines s)
+ packageName = drop 4 lastLine
+
+filterExistingDepWaits wbMap = M.mapWithKey $ \(s,v) -> M.mapWithKey $ \a dw ->
+ case (s,a) `M.lookup` wbMap of
+ Just (_,cdw@(_:_)) -> if cdw `impliesRelations` dw
+ then (False, dw)
+ else (True, dw)
+ _ -> (True, dw)
+
+-- This needs to be improved:
+mergeRelations :: AndRelation -> AndRelation -> AndRelation
+mergeRelations r1 r2 = sort (go r1 r2)
+ where go rel1 [] = rel1
+ go rel1 ([r]:rs) = go (sortIn rel1 r) rs
+ go rel1 (r:rs) = r : go rel1 rs -- Do not merge OrRelations
+
+ sortIn :: AndRelation -> Relation -> AndRelation
+ sortIn [] r2 = [[r2]]
+ sortIn (r1s:rs) r2
+ | length r1s > 1
+ = r1s : sortIn rs r2
+ sortIn ([r1]:rs) r2
+ | not (samePkg r1 r2)
+ = [r1] : sortIn rs r2
+ | Rel _ _ (Just _) <- r1
+ = [r1] : sortIn rs r2
+ | Rel _ _ (Just _) <- r2
+ = [r1] : sortIn rs r2
+ | Rel _ Nothing Nothing <- r1
+ = [ r2 ] : rs
+ | Rel _ Nothing Nothing <- r2
+ = [ r1 ] : rs
+ | Rel p1 (Just v1) Nothing <- r1,
+ Rel p2 (Just v2) Nothing <- r2
+ = [ Rel p1 (Just v) Nothing | v <- mergeVersion v1 v2 ] : rs
+
+ mergeVersion (SLT v1) (SLT v2) = [SLT (min v1 v2)]
+ mergeVersion (LTE v1) (LTE v2) = [LTE (min v1 v2)]
+ mergeVersion (LTE v1) (SLT v2) | v1 < v2 = [LTE v1]
+ | otherwise = [SLT v2]
+ mergeVersion (SLT v2) (LTE v1) | v1 < v2 = [LTE v1]
+ | otherwise = [SLT v2]
+ mergeVersion (SGR v1) (SGR v2) = [SGR (max v1 v2)]
+ mergeVersion (GRE v1) (GRE v2) = [GRE (max v1 v2)]
+ mergeVersion (GRE v1) (SGR v2) | v1 > v2 = [GRE v1]
+ | otherwise = [SGR v2]
+ mergeVersion (SGR v2) (GRE v1) | v1 > v2 = [GRE v1]
+ | otherwise = [SGR v2]
+ mergeVersion (EEQ v1) (EEQ v2) | v1 == v2 = [EEQ v1]
+ mergeVersion v1 v2 = [v1,v2]
+
+-- This is a bit shaky, I hope it wokrs.:
+impliesRelations rs1 rs2 = mergeRelations rs1 rs2 == sort rs1
+
+samePkg (Rel p1 _ _) (Rel p2 _ _) = p1 == p2
+
+showRelations = intercalate ", " . map (intercalate " | " . map show)
More information about the Pkg-haskell-commits
mailing list