From 42b40db07ce70b89f867247809c4e930fd82a6f6 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Wed, 16 Mar 2011 21:47:08 +0000 Subject: [PATCH] Bindist comparison tool: Handle differences in the library ways nicely In particular, this makes it possible to compare release bindists (with profiling files) and validate bindists (without them). --- distrib/compare/BuildInfo.hs | 41 +++++++++++++ distrib/compare/FilenameDescr.hs | 33 ++++------- distrib/compare/Makefile | 2 +- distrib/compare/Problem.hs | 2 + distrib/compare/Utils.hs | 7 +++ distrib/compare/compare.hs | 118 ++++++++++++++++++++++++++++---------- 6 files changed, 150 insertions(+), 53 deletions(-) create mode 100644 distrib/compare/BuildInfo.hs diff --git a/distrib/compare/BuildInfo.hs b/distrib/compare/BuildInfo.hs new file mode 100644 index 0000000..547e5ac --- /dev/null +++ b/distrib/compare/BuildInfo.hs @@ -0,0 +1,41 @@ + +module BuildInfo where + +import Control.Monad.State + +data BuildInfo = BuildInfo { + biThingVersionMap :: ThingVersionMap, + biWays :: Ways + } +-- Mapping from thing (e.g. "Cabal") to version (e.g. "1.10.0.0") +type ThingVersionMap = [(String, String)] +-- The list of ways in the order the build system uses them, e.g. +-- ["v", "p", "dyn"] => we have ".depend-v-p-dyn.haskell" files +type Ways = [String] + +addThingVersion :: ThingVersionMap -> String -> String -> Maybe ThingVersionMap +addThingVersion mapping thing version + = case lookup thing mapping of + Just version' -> + if version == version' + then Just mapping + else Nothing + Nothing -> + Just ((thing, version) : mapping) + +getThingVersionMap :: State BuildInfo ThingVersionMap +getThingVersionMap = do st <- get + return $ biThingVersionMap st + +getWays :: State BuildInfo Ways +getWays = do st <- get + return $ biWays st + +putThingVersionMap :: ThingVersionMap -> State BuildInfo () +putThingVersionMap tm = do st <- get + put $ st { biThingVersionMap = tm } + +putWays :: Ways -> State BuildInfo () +putWays ws = do st <- get + put $ st { biWays = ws } + diff --git a/distrib/compare/FilenameDescr.hs b/distrib/compare/FilenameDescr.hs index 5952058..4b5898e 100644 --- a/distrib/compare/FilenameDescr.hs +++ b/distrib/compare/FilenameDescr.hs @@ -2,7 +2,9 @@ module FilenameDescr where import Data.Either +import Data.List +import BuildInfo import Utils import Tar @@ -12,6 +14,7 @@ import Tar type FilenameDescr = [FilenameDescrBit] data FilenameDescrBit = VersionOf String | FP String + | Ways deriving (Show, Eq, Ord) normalise :: FilenameDescr -> FilenameDescr @@ -20,24 +23,11 @@ normalise [x] = [x] normalise (FP x1 : FP x2 : xs) = normalise (FP (x1 ++ x2) : xs) normalise (x : xs) = x : normalise xs --- Mapping from thing (e.g. "Cabal") to version (e.g. "1.10.0.0") -type ThingVersionMap = [(String, String)] - -addThingVersion :: ThingVersionMap -> String -> String -> Maybe ThingVersionMap -addThingVersion mapping thing version - = case lookup thing mapping of - Just version' -> - if version == version' - then Just mapping - else Nothing - Nothing -> - Just ((thing, version) : mapping) - -- Sanity check that the FilenameDescr matches the filename in the tar line -checkContent :: ThingVersionMap -> (FilenameDescr, TarLine) -> Errors -checkContent mapping (fd, tl) +checkContent :: BuildInfo -> (FilenameDescr, TarLine) -> Errors +checkContent buildInfo (fd, tl) = let fn = tlFileName tl - in case flattenFilenameDescr mapping fd of + in case flattenFilenameDescr buildInfo fd of Right fn' -> if fn' == fn then [] @@ -45,14 +35,15 @@ checkContent mapping (fd, tl) Left errs -> errs -flattenFilenameDescr :: ThingVersionMap -> FilenameDescr +flattenFilenameDescr :: BuildInfo -> FilenameDescr -> Either Errors FilePath -flattenFilenameDescr mapping fd = case partitionEithers (map f fd) of - ([], strs) -> Right (concat strs) - (errs, _) -> Left (concat errs) +flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of + ([], strs) -> Right (concat strs) + (errs, _) -> Left (concat errs) where f (FP fp) = Right fp f (VersionOf thing) - = case lookup thing mapping of + = case lookup thing (biThingVersionMap buildInfo) of Just v -> Right v Nothing -> Left ["Can't happen: thing has no version in mapping"] + f Ways = Right $ intercalate "-" $ biWays buildInfo diff --git a/distrib/compare/Makefile b/distrib/compare/Makefile index 3099bc9..f65c041 100644 --- a/distrib/compare/Makefile +++ b/distrib/compare/Makefile @@ -2,7 +2,7 @@ GHC = ghc compare: *.hs - "$(GHC)" --make -Wall -Werror $@ + "$(GHC)" -O --make -Wall -Werror $@ .PHONY: clean clean: diff --git a/distrib/compare/Problem.hs b/distrib/compare/Problem.hs index f80c856..399e4f8 100644 --- a/distrib/compare/Problem.hs +++ b/distrib/compare/Problem.hs @@ -7,6 +7,7 @@ data FileProblem = First Problem data Problem = DuplicateFile FilePath | ExtraFile FilePath + | ExtraWay String | PermissionsChanged FilePath FilePath String String | FileSizeChanged FilePath FilePath Integer Integer @@ -18,6 +19,7 @@ pprFileProblem (Change p) = "Change " ++ pprProblem p pprProblem :: Problem -> String pprProblem (DuplicateFile fp) = "Duplicate file: " ++ show fp pprProblem (ExtraFile fp) = "Extra file: " ++ show fp +pprProblem (ExtraWay w) = "Extra way: " ++ show w pprProblem (PermissionsChanged fp1 fp2 p1 p2) = "Permissions changed:\n" ++ " " ++ show fp1 diff --git a/distrib/compare/Utils.hs b/distrib/compare/Utils.hs index 58298c1..d5fb8cb 100644 --- a/distrib/compare/Utils.hs +++ b/distrib/compare/Utils.hs @@ -26,3 +26,10 @@ re r str = case matchM r' str :: Maybe (String, String, String, [String]) of Nothing -> Nothing where r' = makeRegex r :: Regex +unSepList :: Eq a => a -> [a] -> [[a]] +unSepList x xs = case break (x ==) xs of + (this, _ : xs') -> + this : unSepList x xs' + (this, []) -> + [this] + diff --git a/distrib/compare/compare.hs b/distrib/compare/compare.hs index 58f914c..b17faf0 100644 --- a/distrib/compare/compare.hs +++ b/distrib/compare/compare.hs @@ -7,6 +7,7 @@ import Data.Function import Data.List import System.Environment +import BuildInfo import FilenameDescr import Problem import Utils @@ -34,27 +35,55 @@ doit :: FilePath -> FilePath -> IO () doit bd1 bd2 = do tls1 <- readTarLines bd1 tls2 <- readTarLines bd2 - content1 <- dieOnErrors $ mkContents tls1 - content2 <- dieOnErrors $ mkContents tls2 + ways1 <- dieOnErrors $ findWays tls1 + ways2 <- dieOnErrors $ findWays tls2 + content1 <- dieOnErrors $ mkContents ways1 tls1 + content2 <- dieOnErrors $ mkContents ways2 tls2 let mySort = sortBy (compare `on` fst) sortedContent1 = mySort content1 sortedContent2 = mySort content2 (nubProbs1, nubbedContent1) = nubContents sortedContent1 (nubProbs2, nubbedContent2) = nubContents sortedContent2 - differences = compareContent nubbedContent1 - nubbedContent2 + differences = compareContent ways1 nubbedContent1 + ways2 nubbedContent2 allProbs = map First nubProbs1 ++ map Second nubProbs2 + ++ diffWays ways1 ways2 ++ differences mapM_ (putStrLn . pprFileProblem) allProbs -mkContents :: [TarLine] -> Either Errors [(FilenameDescr, TarLine)] -mkContents tls = case runState (mapM f tls) [] of - (xs, mapping) -> - case concat $ map (checkContent mapping) xs of - [] -> Right xs - errs -> Left errs +findWays :: [TarLine] -> Either Errors Ways +findWays = foldr f (Left ["Couldn't find ways"]) + where f tl res = case re regex (tlFileName tl) of + Just [dashedWays] -> + Right (unSepList '-' dashedWays) + _ -> + res + regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell" + +diffWays :: Ways -> Ways -> [FileProblem] +diffWays ws1 ws2 = f (sort ws1) (sort ws2) + where f [] [] = [] + f xs [] = map (First . ExtraWay) xs + f [] ys = map (First . ExtraWay) ys + f xs@(x : xs') ys@(y : ys') + = case x `compare` y of + LT -> First (ExtraWay x) : f xs' ys + GT -> Second (ExtraWay y) : f xs ys' + EQ -> f xs' ys' + +mkContents :: Ways -> [TarLine] -> Either Errors [(FilenameDescr, TarLine)] +mkContents ways tls + = case runState (mapM f tls) initialBuildInfo of + (xs, finalBuildInfo) -> + case concat $ map (checkContent finalBuildInfo) xs of + [] -> Right xs + errs -> Left errs where f tl = do fnd <- mkFilePathDescr (tlFileName tl) return (fnd, tl) + initialBuildInfo = BuildInfo { + biThingVersionMap = [], + biWays = ways + } nubContents :: [(FilenameDescr, TarLine)] -> ([Problem], [(FilenameDescr, TarLine)]) @@ -65,14 +94,14 @@ nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _)) | otherwise = (ps, x1 : xs') where (ps, xs') = nubContents xs -mkFilePathDescr :: FilePath -> State ThingVersionMap FilenameDescr +mkFilePathDescr :: FilePath -> State BuildInfo FilenameDescr mkFilePathDescr fp | Just [ghcVersion, _, middle, filename] <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp - = do ghcVersionDescr <- do mapping <- get + = do ghcVersionDescr <- do mapping <- getThingVersionMap case addThingVersion mapping "ghc" ghcVersion of Just mapping' -> - do put mapping' + do putThingVersionMap mapping' return (VersionOf "ghc") Nothing -> return (FP ghcVersion) @@ -81,17 +110,17 @@ mkFilePathDescr fp return $ normalise fd | otherwise = return [FP fp] -mkFileNameDescr :: FilePath -> State ThingVersionMap FilenameDescr +mkFileNameDescr :: FilePath -> State BuildInfo FilenameDescr mkFileNameDescr filename | Just [thing, thingVersion, _, ghcVersion, _] <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.so$") filename - = do mapping <- get + = do mapping <- getThingVersionMap case addThingVersion mapping "ghc" ghcVersion of Just m -> case addThingVersion m thing thingVersion of Just m' -> - do put m' + do putThingVersionMap m' return [FP "libHS", FP thing, FP "-", VersionOf thing, FP "-ghc", VersionOf "ghc", FP ".so"] _ -> unchanged @@ -99,46 +128,73 @@ mkFileNameDescr filename | Just [way, thingVersion, _] <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.so$") filename - = do mapping <- get + = do mapping <- getThingVersionMap case addThingVersion mapping "ghc" thingVersion of Just mapping' -> - do put mapping' + do putThingVersionMap mapping' return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc", FP ".so"] _ -> unchanged | Just [thing, thingVersion, _, way] <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$") filename - = do mapping <- get + = do mapping <- getThingVersionMap case addThingVersion mapping thing thingVersion of Just mapping' -> - do put mapping' + do putThingVersionMap mapping' return [FP "libHS", FP thing, FP "-", VersionOf thing, FP way, FP ".a"] _ -> unchanged | Just [thing, thingVersion, _] <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$") filename - = do mapping <- get + = do mapping <- getThingVersionMap case addThingVersion mapping thing thingVersion of Just mapping' -> - do put mapping' + do putThingVersionMap mapping' return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"] _ -> unchanged + | Just [dashedWays, depType] + <- re "^\\.depend-(.*)\\.(haskell|c_asm)" + filename + = do ways <- getWays + if unSepList '-' dashedWays == ways + then return [FP ".depend-", Ways, FP ".", FP depType] + else unchanged | otherwise = unchanged where unchanged = return [FP filename] -compareContent :: [(FilenameDescr, TarLine)] -> [(FilenameDescr, TarLine)] +compareContent :: Ways -> [(FilenameDescr, TarLine)] + -> Ways -> [(FilenameDescr, TarLine)] -> [FileProblem] -compareContent [] [] = [] -compareContent xs [] = map (First . ExtraFile . tlFileName . snd) xs -compareContent [] ys = map (Second . ExtraFile . tlFileName . snd) ys -compareContent xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2') - = case fd1 `compare` fd2 of - EQ -> map Change (compareTarLine tl1 tl2) ++ compareContent xs1' xs2' - LT -> First (ExtraFile (tlFileName tl1)) : compareContent xs1' xs2 - GT -> Second (ExtraFile (tlFileName tl2)) : compareContent xs1 xs2' +compareContent _ [] _ [] = [] +compareContent _ xs _ [] = map (First . ExtraFile . tlFileName . snd) xs +compareContent _ [] _ ys = map (Second . ExtraFile . tlFileName . snd) ys +compareContent ways1 xs1 ways2 xs2 + = case (xs1, xs2) of + ([], []) -> [] + (xs, []) -> concatMap (mkExtraFile ways1 First . tlFileName . snd) xs + ([], ys) -> concatMap (mkExtraFile ways2 Second . tlFileName . snd) ys + ((fd1, tl1) : xs1', (fd2, tl2) : xs2') -> + case fd1 `compare` fd2 of + EQ -> map Change (compareTarLine tl1 tl2) + ++ compareContent ways1 xs1' ways2 xs2' + LT -> mkExtraFile ways1 First (tlFileName tl1) + ++ compareContent ways1 xs1' ways2 xs2 + GT -> mkExtraFile ways2 Second (tlFileName tl2) + ++ compareContent ways1 xs1 ways2 xs2' + where mkExtraFile ways mkFileProblem filename + = case findFileWay filename of + Just way + | way `elem` ways -> [] + _ -> [mkFileProblem (ExtraFile filename)] + +findFileWay :: FilePath -> Maybe String +findFileWay fp + | Just [way] <- re "\\.([a-z_]+)_hi$" fp + = Just way + | otherwise = Nothing compareTarLine :: TarLine -> TarLine -> [Problem] compareTarLine tl1 tl2 -- 1.7.10.4