diff options
Diffstat (limited to 'distrib')
| -rw-r--r-- | distrib/compare/BuildInfo.hs | 54 | ||||
| -rw-r--r-- | distrib/compare/Change.hs | 43 | ||||
| -rw-r--r-- | distrib/compare/FilenameDescr.hs | 5 | ||||
| -rw-r--r-- | distrib/compare/Problem.hs | 37 | ||||
| -rw-r--r-- | distrib/compare/Utils.hs | 5 | ||||
| -rw-r--r-- | distrib/compare/compare.hs | 182 |
6 files changed, 204 insertions, 122 deletions
diff --git a/distrib/compare/BuildInfo.hs b/distrib/compare/BuildInfo.hs index 547e5ac853..d71eeb4777 100644 --- a/distrib/compare/BuildInfo.hs +++ b/distrib/compare/BuildInfo.hs @@ -3,39 +3,61 @@ module BuildInfo where import Control.Monad.State +type BIMonad = StateT BuildInfo Maybe + data BuildInfo = BuildInfo { biThingVersionMap :: ThingVersionMap, + biThingHashMap :: ThingHashMap, biWays :: Ways } + deriving Show + +type ThingMap = [(String, String)] -- Mapping from thing (e.g. "Cabal") to version (e.g. "1.10.0.0") -type ThingVersionMap = [(String, String)] +type ThingVersionMap = ThingMap +-- Mapping from thing (e.g. "Cabal") to ABI hash +-- (e.g. "e1f7c380581d61d42b0360d440cc35ed") +type ThingHashMap = ThingMap -- 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 +emptyBuildInfo :: Ways -> BuildInfo +emptyBuildInfo ways = BuildInfo { + biThingVersionMap = [], + biThingHashMap = [], + biWays = ways + } + +addThingMap :: ThingMap -> String -> String -> Maybe ThingMap +addThingMap mapping thing str = case lookup thing mapping of - Just version' -> - if version == version' + Just str' -> + if str == str' then Just mapping else Nothing Nothing -> - Just ((thing, version) : mapping) + Just ((thing, str) : mapping) -getThingVersionMap :: State BuildInfo ThingVersionMap -getThingVersionMap = do st <- get - return $ biThingVersionMap st - -getWays :: State BuildInfo Ways +getWays :: BIMonad 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 () +haveThingVersion :: String -> String -> BIMonad () +haveThingVersion thing thingVersion + = do st <- get + case addThingMap (biThingVersionMap st) thing thingVersion of + Nothing -> fail "Inconsistent version" + Just tvm -> put $ st { biThingVersionMap = tvm } + +haveThingHash :: String -> String -> BIMonad () +haveThingHash thing thingHash + = do st <- get + case addThingMap (biThingHashMap st) thing thingHash of + 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/Change.hs b/distrib/compare/Change.hs new file mode 100644 index 0000000000..a89517ceb5 --- /dev/null +++ b/distrib/compare/Change.hs @@ -0,0 +1,43 @@ + +module Change where + +data FileChange = First Change + | Second Change + | Change Change + +data Change = DuplicateFile FilePath + | ExtraFile FilePath + | ExtraWay String + | ExtraThing String + | ThingVersionChanged String String String + | PermissionsChanged FilePath FilePath String String + | FileSizeChanged FilePath FilePath Integer Integer + +isSizeChange :: FileChange -> Bool +isSizeChange (Change (FileSizeChanged {})) = True +isSizeChange _ = False + +pprFileChange :: FileChange -> String +pprFileChange (First p) = "First " ++ pprChange p +pprFileChange (Second p) = "Second " ++ pprChange p +pprFileChange (Change p) = "Change " ++ pprChange p + +pprChange :: Change -> String +pprChange (DuplicateFile fp) = "Duplicate file: " ++ show fp +pprChange (ExtraFile fp) = "Extra file: " ++ show fp +pprChange (ExtraWay w) = "Extra way: " ++ show w +pprChange (ExtraThing t) = "Extra thing: " ++ show t +pprChange (ThingVersionChanged t v1 v2) + = "Version changed for " ++ show t ++ ":\n" + ++ " " ++ v1 ++ " -> " ++ v2 +pprChange (PermissionsChanged fp1 fp2 p1 p2) + = "Permissions changed:\n" + ++ " " ++ show fp1 + ++ " " ++ show fp2 + ++ " " ++ p1 ++ " -> " ++ p2 +pprChange (FileSizeChanged fp1 fp2 s1 s2) + = "Size changed:\n" + ++ " " ++ show fp1 ++ "\n" + ++ " " ++ show fp2 ++ "\n" + ++ " " ++ show s1 ++ " -> " ++ show s2 + diff --git a/distrib/compare/FilenameDescr.hs b/distrib/compare/FilenameDescr.hs index 4b5898e990..c1a85954e6 100644 --- a/distrib/compare/FilenameDescr.hs +++ b/distrib/compare/FilenameDescr.hs @@ -13,6 +13,7 @@ import Tar -- abstracts out the version numbers. type FilenameDescr = [FilenameDescrBit] data FilenameDescrBit = VersionOf String + | HashOf String | FP String | Ways deriving (Show, Eq, Ord) @@ -45,5 +46,9 @@ flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of = case lookup thing (biThingVersionMap buildInfo) of Just v -> Right v Nothing -> Left ["Can't happen: thing has no version in mapping"] + f (HashOf thing) + = 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 diff --git a/distrib/compare/Problem.hs b/distrib/compare/Problem.hs deleted file mode 100644 index 7854bc5f7d..0000000000 --- a/distrib/compare/Problem.hs +++ /dev/null @@ -1,37 +0,0 @@ - -module Problem where - -data FileProblem = First Problem - | Second Problem - | Change Problem - -data Problem = DuplicateFile FilePath - | ExtraFile FilePath - | ExtraWay String - | PermissionsChanged FilePath FilePath String String - | FileSizeChanged FilePath FilePath Integer Integer - -isSizeChange :: FileProblem -> Bool -isSizeChange (Change (FileSizeChanged {})) = True -isSizeChange _ = False - -pprFileProblem :: FileProblem -> String -pprFileProblem (First p) = "First " ++ pprProblem p -pprFileProblem (Second p) = "Second " ++ pprProblem p -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 - ++ " " ++ show fp2 - ++ " " ++ p1 ++ " -> " ++ p2 -pprProblem (FileSizeChanged fp1 fp2 s1 s2) - = "Size changed:\n" - ++ " " ++ show fp1 ++ "\n" - ++ " " ++ show fp2 ++ "\n" - ++ " " ++ show s1 ++ " -> " ++ show s2 - diff --git a/distrib/compare/Utils.hs b/distrib/compare/Utils.hs index d5fb8cb442..e2da6b55fa 100644 --- a/distrib/compare/Utils.hs +++ b/distrib/compare/Utils.hs @@ -1,6 +1,8 @@ module Utils where +import Data.Function +import Data.List import System.Exit import System.IO import Text.Regex.Posix @@ -33,3 +35,6 @@ unSepList x xs = case break (x ==) xs of (this, []) -> [this] +sortByFst :: Ord a => [(a, b)] -> [(a, b)] +sortByFst = sortBy (compare `on` fst) + 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 ] |