From 5fddd81f04e9f9df37da19148c8e4262ea381bf8 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sun, 27 Mar 2011 15:52:05 +0000 Subject: [PATCH] bindist comparison tool: Some logic improvements, and testsuite support --- distrib/compare/BuildInfo.hs | 24 ++++------ distrib/compare/FilenameDescr.hs | 4 +- distrib/compare/compare.hs | 93 +++++++++++++++++++------------------- 3 files changed, 59 insertions(+), 62 deletions(-) diff --git a/distrib/compare/BuildInfo.hs b/distrib/compare/BuildInfo.hs index d71eeb4..1101bf4 100644 --- a/distrib/compare/BuildInfo.hs +++ b/distrib/compare/BuildInfo.hs @@ -8,7 +8,7 @@ type BIMonad = StateT BuildInfo Maybe data BuildInfo = BuildInfo { biThingVersionMap :: ThingVersionMap, biThingHashMap :: ThingHashMap, - biWays :: Ways + biMaybeWays :: Maybe Ways } deriving Show @@ -22,12 +22,12 @@ type ThingHashMap = ThingMap -- ["v", "p", "dyn"] => we have ".depend-v-p-dyn.haskell" files type Ways = [String] -emptyBuildInfo :: Ways -> BuildInfo -emptyBuildInfo ways = BuildInfo { - biThingVersionMap = [], - biThingHashMap = [], - biWays = ways - } +emptyBuildInfo :: Maybe Ways -> BuildInfo +emptyBuildInfo mWays = BuildInfo { + biThingVersionMap = [], + biThingHashMap = [], + biMaybeWays = mWays + } addThingMap :: ThingMap -> String -> String -> Maybe ThingMap addThingMap mapping thing str @@ -39,9 +39,9 @@ addThingMap mapping thing str Nothing -> Just ((thing, str) : mapping) -getWays :: BIMonad Ways -getWays = do st <- get - return $ biWays st +getMaybeWays :: BIMonad (Maybe Ways) +getMaybeWays = do st <- get + return $ biMaybeWays st haveThingVersion :: String -> String -> BIMonad () haveThingVersion thing thingVersion @@ -57,7 +57,3 @@ haveThingHash thing thingHash Nothing -> fail "Inconsistent hash" Just thm -> put $ st { biThingHashMap = thm } -putWays :: Ways -> BIMonad () -putWays ws = do st <- get - put $ st { biWays = ws } - diff --git a/distrib/compare/FilenameDescr.hs b/distrib/compare/FilenameDescr.hs index c1a8595..d21745c 100644 --- a/distrib/compare/FilenameDescr.hs +++ b/distrib/compare/FilenameDescr.hs @@ -50,5 +50,7 @@ flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of = case lookup thing (biThingHashMap buildInfo) of Just v -> Right v Nothing -> Left ["Can't happen: thing has no hash in mapping"] - f Ways = Right $ intercalate "-" $ biWays buildInfo + f Ways = case biMaybeWays buildInfo of + Just ways -> Right $ intercalate "-" ways + Nothing -> Left ["Can't happen: No ways, but Ways is used"] diff --git a/distrib/compare/compare.hs b/distrib/compare/compare.hs index d1a8ac7..0e0e9f8 100644 --- a/distrib/compare/compare.hs +++ b/distrib/compare/compare.hs @@ -33,39 +33,41 @@ main = do args <- getArgs doit :: Bool -> FilePath -> FilePath -> IO () doit ignoreSizeChanges bd1 bd2 - = do let windows = any ("mingw" `isPrefixOf`) (tails bd1) - tls1 <- readTarLines bd1 + = do tls1 <- readTarLines bd1 tls2 <- readTarLines bd2 - -- If it looks like we have a Windows "bindist" then just - -- set ways to [] for now. - ways1 <- if windows then return [] - else dieOnErrors $ findWays tls1 - ways2 <- if windows then return [] - else dieOnErrors $ findWays tls2 - (content1, tvm1) <- dieOnErrors $ mkContents ways1 tls1 - (content2, tvm2) <- dieOnErrors $ mkContents ways2 tls2 + let mWays1 = findWays tls1 + mWays2 = findWays tls2 + wayDifferences <- case (mWays1, mWays2) of + (Nothing, Nothing) -> + return [] + (Just ways1, Just ways2) -> + return $ diffWays ways1 ways2 + _ -> + die ["One input has ways, but the other doesn't"] + (content1, tvm1) <- dieOnErrors $ mkContents mWays1 tls1 + (content2, tvm2) <- dieOnErrors $ mkContents mWays2 tls2 let sortedContent1 = sortByFst content1 sortedContent2 = sortByFst content2 (nubProbs1, nubbedContent1) = nubContents sortedContent1 (nubProbs2, nubbedContent2) = nubContents sortedContent2 - differences = compareContent ways1 nubbedContent1 - ways2 nubbedContent2 + differences = compareContent mWays1 nubbedContent1 + mWays2 nubbedContent2 allProbs = map First nubProbs1 ++ map Second nubProbs2 ++ diffThingVersionMap tvm1 tvm2 - ++ diffWays ways1 ways2 + ++ wayDifferences ++ differences wantedProbs = if ignoreSizeChanges then filter (not . isSizeChange) allProbs else allProbs mapM_ (putStrLn . pprFileChange) wantedProbs -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 +-- *nix bindists have ways. +-- Windows "bindists", install trees, and testsuites don't. +findWays :: [TarLine] -> Maybe Ways +findWays tls = msum $ map f tls + where f tl = case re regex (tlFileName tl) of + Just [dashedWays] -> Just (unSepList '-' dashedWays) + _ -> Nothing regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell" diffWays :: Ways -> Ways -> [FileChange] @@ -93,10 +95,10 @@ diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2) else [Change (ThingVersionChanged xt xv yv)] in this ++ f xs' ys' -mkContents :: Ways -> [TarLine] +mkContents :: Maybe Ways -> [TarLine] -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap) -mkContents ways tls - = case runStateT (mapM f tls) (emptyBuildInfo ways) of +mkContents mWays tls + = case runStateT (mapM f tls) (emptyBuildInfo mWays) of Nothing -> Left ["Can't happen: mkContents: Nothing"] Just (xs, finalBuildInfo) -> case concat $ map (checkContent finalBuildInfo) xs of @@ -211,36 +213,33 @@ mkFileNameDescr filename | Just [dashedWays, depType] <- re "^\\.depend-(.*)\\.(haskell|c_asm)" filename - = do ways <- getWays - if unSepList '-' dashedWays == ways + = do mWays <- getMaybeWays + if Just (unSepList '-' dashedWays) == mWays then return [FP ".depend-", Ways, FP ".", FP depType] else unchanged | otherwise = unchanged where unchanged = return [FP filename] -compareContent :: Ways -> [(FilenameDescr, TarLine)] - -> Ways -> [(FilenameDescr, TarLine)] +compareContent :: Maybe Ways -> [(FilenameDescr, TarLine)] + -> Maybe Ways -> [(FilenameDescr, TarLine)] -> [FileChange] -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 mkFileChange filename - = case findFileWay filename of - Just way - | way `elem` ways -> [] +compareContent mWays1 xs1all mWays2 xs2all + = f xs1all xs2all + where f [] [] = [] + f xs [] = concatMap (mkExtraFile mWays1 mWays2 First . tlFileName . snd) xs + f [] ys = concatMap (mkExtraFile mWays2 mWays1 Second . tlFileName . snd) ys + f xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2') + = case fd1 `compare` fd2 of + EQ -> map Change (compareTarLine tl1 tl2) + ++ f xs1' xs2' + LT -> mkExtraFile mWays1 mWays2 First (tlFileName tl1) + ++ f xs1' xs2 + GT -> mkExtraFile mWays2 mWays1 Second (tlFileName tl2) + ++ f xs1 xs2' + mkExtraFile mWaysMe mWaysThem mkFileChange filename + = case (findFileWay filename, mWaysMe, mWaysThem) of + (Just way, Just waysMe, Just waysThem) + | (way `elem` waysMe) && not (way `elem` waysThem) -> [] _ -> [mkFileChange (ExtraFile filename)] findFileWay :: FilePath -> Maybe String -- 1.7.10.4