X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=distrib%2Fcompare%2Fcompare.hs;h=0e0e9f8306c93d044e39ffad049e0b4ff1939d22;hb=f537dd87c4a07526e2b1fc1bd1c125d652833641;hp=b17faf08e2b0ed6c76960c3885755436f2f59133;hpb=42b40db07ce70b89f867247809c4e930fd82a6f6;p=ghc-hetmet.git diff --git a/distrib/compare/compare.hs b/distrib/compare/compare.hs index b17faf0..0e0e9f8 100644 --- a/distrib/compare/compare.hs +++ b/distrib/compare/compare.hs @@ -3,13 +3,12 @@ module Main (main) where import Control.Monad.State -import Data.Function import Data.List import System.Environment import BuildInfo import FilenameDescr -import Problem +import Change import Utils import Tar @@ -28,65 +27,88 @@ sizePercentage = 150 main :: IO () main = do args <- getArgs case args of - [bd1, bd2] -> doit bd1 bd2 + [bd1, bd2] -> doit False bd1 bd2 + ["--ignore-size-changes", bd1, bd2] -> doit True bd1 bd2 _ -> die ["Bad args. Need 2 bindists."] -doit :: FilePath -> FilePath -> IO () -doit bd1 bd2 +doit :: Bool -> FilePath -> FilePath -> IO () +doit ignoreSizeChanges bd1 bd2 = do tls1 <- readTarLines bd1 tls2 <- readTarLines bd2 - 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 + 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 - ++ diffWays ways1 ways2 + ++ diffThingVersionMap tvm1 tvm2 + ++ wayDifferences ++ differences - mapM_ (putStrLn . pprFileProblem) allProbs - -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 + wantedProbs = if ignoreSizeChanges + then filter (not . isSizeChange) allProbs + else allProbs + mapM_ (putStrLn . pprFileChange) wantedProbs + +-- *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 -> [FileProblem] +diffWays :: Ways -> Ways -> [FileChange] diffWays ws1 ws2 = f (sort ws1) (sort ws2) where f [] [] = [] - f xs [] = map (First . ExtraWay) xs - f [] ys = map (First . ExtraWay) ys + f xs [] = map (First . ExtraWay) xs + f [] ys = map (Second . 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) -> +diffThingVersionMap :: ThingVersionMap -> ThingVersionMap -> [FileChange] +diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2) + where f [] [] = [] + f xs [] = map (First . ExtraThing . fst) xs + f [] ys = map (Second . ExtraThing . fst) ys + f xs@((xt, xv) : xs') ys@((yt, yv) : ys') + = case xt `compare` yt of + LT -> First (ExtraThing xt) : f xs' ys + GT -> Second (ExtraThing yt) : f xs ys' + EQ -> let this = if xv == yv + then [] + else [Change (ThingVersionChanged xt xv yv)] + in this ++ f xs' ys' + +mkContents :: Maybe Ways -> [TarLine] + -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap) +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 - [] -> Right xs + [] -> Right (xs, biThingVersionMap finalBuildInfo) 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)]) + -> ([Change], [(FilenameDescr, TarLine)]) nubContents [] = ([], []) nubContents [x] = ([], [x]) nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _)) @@ -94,109 +116,141 @@ nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _)) | otherwise = (ps, x1 : xs') where (ps, xs') = nubContents xs -mkFilePathDescr :: FilePath -> State BuildInfo FilenameDescr +mkFilePathDescr :: FilePath -> BIMonad FilenameDescr mkFilePathDescr fp | Just [ghcVersion, _, middle, filename] <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp - = do ghcVersionDescr <- do mapping <- getThingVersionMap - case addThingVersion mapping "ghc" ghcVersion of - Just mapping' -> - do putThingVersionMap mapping' - return (VersionOf "ghc") - Nothing -> - return (FP ghcVersion) + = do haveThingVersion "ghc" ghcVersion + middle' <- mkMiddleDescr middle filename' <- mkFileNameDescr filename - let fd = FP "ghc-" : ghcVersionDescr : FP middle : FP "/" : filename' + let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename' return $ normalise fd | otherwise = return [FP fp] -mkFileNameDescr :: FilePath -> State BuildInfo FilenameDescr +mkMiddleDescr :: FilePath -> BIMonad FilenameDescr +mkMiddleDescr middle + -- haddock docs in a Windows installed tree + | Just [thing, thingVersion, _, src] + <- re ("^/doc/html/libraries/([^/]*)-" ++ versionRE ++ "(/src)?$") + middle + = do haveThingVersion thing thingVersion + return [FP "/doc/html/libraries/", + FP thing, FP "-", VersionOf thing, FP src] + `mplus` unchanged + -- libraries in a Windows installed tree + | Just [thing, thingVersion, _, rest] + <- re ("^/lib/([^/]*)-" ++ versionRE ++ "(/.*)?$") + middle + = do haveThingVersion thing thingVersion + return [FP "/lib/", FP thing, FP "-", VersionOf thing, FP rest] + `mplus` unchanged + -- Windows in-tree gcc + | Just [prefix, _, _, gccVersion, _, rest] + <- re ("^(/mingw/(lib(exec)?/gcc/mingw32/|share/gcc-))" ++ versionRE ++ "(/.*)?$") + middle + = do haveThingVersion "gcc" gccVersion + return [FP prefix, VersionOf "gcc", FP rest] + `mplus` unchanged + | otherwise = unchanged + where unchanged = return [FP middle] + +mkFileNameDescr :: FilePath -> BIMonad FilenameDescr mkFileNameDescr filename - | Just [thing, thingVersion, _, ghcVersion, _] - <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.so$") + | Just [prog, ghcVersion, _, exe] + <- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$") + filename + = do haveThingVersion "ghc" ghcVersion + return [FP prog, FP "-", VersionOf "ghc", FP exe] + `mplus` unchanged + | Just [thing, thingVersion, _, ghcVersion, _, soDll] + <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") filename - = do mapping <- getThingVersionMap - case addThingVersion mapping "ghc" ghcVersion of - Just m -> - case addThingVersion m thing thingVersion of - Just m' -> - do putThingVersionMap m' - return [FP "libHS", FP thing, FP "-", VersionOf thing, - FP "-ghc", VersionOf "ghc", FP ".so"] - _ -> unchanged - _ -> unchanged - | Just [way, thingVersion, _] - <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.so$") + = do haveThingVersion "ghc" ghcVersion + haveThingVersion thing thingVersion + return [FP "libHS", FP thing, FP "-", VersionOf thing, + FP "-ghc", VersionOf "ghc", FP ".", FP soDll] + `mplus` unchanged + | Just [way, thingVersion, _, soDll] + <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") filename - = do mapping <- getThingVersionMap - case addThingVersion mapping "ghc" thingVersion of - Just mapping' -> - do putThingVersionMap mapping' - return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc", - FP ".so"] - _ -> unchanged + = do haveThingVersion "ghc" thingVersion + return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc", + FP ".", FP soDll] + `mplus` unchanged + | Just [thingVersion, _, soDll] + <- re ("^libHSffi-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") + filename + = do haveThingVersion "ghc" thingVersion + return [FP "libHSffi-ghc", VersionOf "ghc", FP ".", FP soDll] + `mplus` unchanged | Just [thing, thingVersion, _, way] <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$") filename - = do mapping <- getThingVersionMap - case addThingVersion mapping thing thingVersion of - Just mapping' -> - do putThingVersionMap mapping' - return [FP "libHS", FP thing, FP "-", VersionOf thing, - FP way, FP ".a"] - _ -> unchanged + = do haveThingVersion thing thingVersion + return [FP "libHS", FP thing, FP "-", VersionOf thing, + FP way, FP ".a"] + `mplus` unchanged | Just [thing, thingVersion, _] <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$") filename - = do mapping <- getThingVersionMap - case addThingVersion mapping thing thingVersion of - Just mapping' -> - do putThingVersionMap mapping' - return [FP "HS", FP thing, FP "-", VersionOf thing, - FP ".o"] - _ -> unchanged + = do haveThingVersion thing thingVersion + return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"] + `mplus` unchanged + | Just [thing, thingVersion, _, thingHash] + <- re ("^(.*)-" ++ versionRE ++ "-([0-9a-f]{32})\\.conf$") + filename + = do haveThingVersion thing thingVersion + haveThingHash thing thingHash + return [FP thing, FP "-", VersionOf thing, FP "-", HashOf thing, + FP ".conf"] + `mplus` unchanged + | Just [thingVersion, _] + <- re ("^mingw32-gcc-" ++ versionRE ++ "\\.exe$") + filename + = do haveThingVersion "gcc" thingVersion + return [FP "mingw32-gcc-", VersionOf "gcc", FP ".exe"] + `mplus` unchanged | 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)] - -> [FileProblem] -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)] +compareContent :: Maybe Ways -> [(FilenameDescr, TarLine)] + -> Maybe Ways -> [(FilenameDescr, TarLine)] + -> [FileChange] +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 findFileWay fp | Just [way] <- re "\\.([a-z_]+)_hi$" fp = Just way + | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp + = Just way | otherwise = Nothing -compareTarLine :: TarLine -> TarLine -> [Problem] +compareTarLine :: TarLine -> TarLine -> [Change] compareTarLine tl1 tl2 = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ] ++ [ FileSizeChanged fn1 fn2 size1 size2 | sizeChanged ]