diff options
Diffstat (limited to 'distrib/compare/compare.hs')
| -rw-r--r-- | distrib/compare/compare.hs | 182 |
1 files changed, 113 insertions, 69 deletions
diff --git a/distrib/compare/compare.hs b/distrib/compare/compare.hs index 8daa773c40..1fa2c739af 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 @@ -43,22 +42,22 @@ doit ignoreSizeChanges bd1 bd2 else dieOnErrors $ findWays tls1 ways2 <- if windows then return [] else 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 + (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 ways1 nubbedContent1 ways2 nubbedContent2 allProbs = map First nubProbs1 ++ map Second nubProbs2 + ++ diffThingVersionMap tvm1 tvm2 ++ diffWays ways1 ways2 ++ differences wantedProbs = if ignoreSizeChanges then filter (not . isSizeChange) allProbs else allProbs - mapM_ (putStrLn . pprFileProblem) wantedProbs + mapM_ (putStrLn . pprFileChange) wantedProbs findWays :: [TarLine] -> Either Errors Ways findWays = foldr f (Left ["Couldn't find ways"]) @@ -69,33 +68,45 @@ findWays = foldr f (Left ["Couldn't find ways"]) res 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)] +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 runState (mapM f tls) initialBuildInfo of - (xs, finalBuildInfo) -> + = 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 + [] -> 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, _) : _)) @@ -103,67 +114,100 @@ 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 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 + 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 <- 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" 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 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 <- 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 @@ -176,7 +220,7 @@ mkFileNameDescr filename compareContent :: Ways -> [(FilenameDescr, TarLine)] -> Ways -> [(FilenameDescr, TarLine)] - -> [FileProblem] + -> [FileChange] compareContent _ [] _ [] = [] compareContent _ xs _ [] = map (First . ExtraFile . tlFileName . snd) xs compareContent _ [] _ ys = map (Second . ExtraFile . tlFileName . snd) ys @@ -193,11 +237,11 @@ compareContent ways1 xs1 ways2 xs2 ++ compareContent ways1 xs1' ways2 xs2 GT -> mkExtraFile ways2 Second (tlFileName tl2) ++ compareContent ways1 xs1 ways2 xs2' - where mkExtraFile ways mkFileProblem filename + where mkExtraFile ways mkFileChange filename = case findFileWay filename of Just way | way `elem` ways -> [] - _ -> [mkFileProblem (ExtraFile filename)] + _ -> [mkFileChange (ExtraFile filename)] findFileWay :: FilePath -> Maybe String findFileWay fp @@ -207,7 +251,7 @@ findFileWay 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 ] |