X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=distrib%2Fcompare%2Fcompare.hs;h=1fa2c739af7ca847071b8199dac84c78bace29e3;hb=90d7a88f304ddff15f31f9b1edb86b452679583b;hp=58f914c2615dac117902e523772ca1227fa1a528;hpb=29a05730930cd2c5986ebb22d550e893d9fa20cc;p=ghc-hetmet.git diff --git a/distrib/compare/compare.hs b/distrib/compare/compare.hs index 58f914c..1fa2c73 100644 --- a/distrib/compare/compare.hs +++ b/distrib/compare/compare.hs @@ -3,12 +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 @@ -27,37 +27,86 @@ 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 - = do tls1 <- readTarLines bd1 +doit :: Bool -> FilePath -> FilePath -> IO () +doit ignoreSizeChanges bd1 bd2 + = do let windows = any ("mingw" `isPrefixOf`) (tails bd1) + tls1 <- readTarLines bd1 tls2 <- readTarLines bd2 - content1 <- dieOnErrors $ mkContents tls1 - content2 <- dieOnErrors $ mkContents tls2 - let mySort = sortBy (compare `on` fst) - sortedContent1 = mySort content1 - sortedContent2 = mySort content2 + -- 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 sortedContent1 = sortByFst content1 + sortedContent2 = sortByFst 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 + ++ diffThingVersionMap tvm1 tvm2 + ++ 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 + 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 + regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell" + +diffWays :: Ways -> Ways -> [FileChange] +diffWays ws1 ws2 = f (sort ws1) (sort ws2) + where f [] [] = [] + 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' + +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 :: Ways -> [TarLine] + -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap) +mkContents ways tls + = case runStateT (mapM f tls) (emptyBuildInfo ways) of + Nothing -> Left ["Can't happen: mkContents: Nothing"] + Just (xs, finalBuildInfo) -> + case concat $ map (checkContent finalBuildInfo) xs of + [] -> Right (xs, biThingVersionMap finalBuildInfo) + errs -> Left errs where f tl = do fnd <- mkFilePathDescr (tlFileName tl) return (fnd, tl) nubContents :: [(FilenameDescr, TarLine)] - -> ([Problem], [(FilenameDescr, TarLine)]) + -> ([Change], [(FilenameDescr, TarLine)]) nubContents [] = ([], []) nubContents [x] = ([], [x]) nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _)) @@ -65,82 +114,144 @@ nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _)) | otherwise = (ps, x1 : xs') where (ps, xs') = nubContents xs -mkFilePathDescr :: FilePath -> State ThingVersionMap FilenameDescr +mkFilePathDescr :: FilePath -> BIMonad FilenameDescr mkFilePathDescr fp | Just [ghcVersion, _, middle, filename] <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp - = do ghcVersionDescr <- do mapping <- get - case addThingVersion mapping "ghc" ghcVersion of - Just mapping' -> - do put 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 ThingVersionMap 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)$") filename - = do mapping <- get - case addThingVersion mapping "ghc" ghcVersion of - Just m -> - case addThingVersion m thing thingVersion of - Just m' -> - do put 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)$") filename - = do mapping <- get - case addThingVersion mapping "ghc" thingVersion of - Just mapping' -> - do put 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)$") + 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 <- get - case addThingVersion mapping thing thingVersion of - Just mapping' -> - do put 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 <- get - case addThingVersion mapping thing thingVersion of - Just mapping' -> - do put 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 + then return [FP ".depend-", Ways, FP ".", FP depType] + else unchanged | otherwise = unchanged where unchanged = return [FP filename] -compareContent :: [(FilenameDescr, TarLine)] -> [(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' - -compareTarLine :: TarLine -> TarLine -> [Problem] +compareContent :: Ways -> [(FilenameDescr, TarLine)] + -> 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 -> [] + _ -> [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 -> [Change] compareTarLine tl1 tl2 = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ] ++ [ FileSizeChanged fn1 fn2 size1 size2 | sizeChanged ]