Commit 42b40db0 authored by Ian Lynagh's avatar Ian Lynagh

Bindist comparison tool: Handle differences in the library ways nicely

In particular, this makes it possible to compare release bindists (with
profiling files) and validate bindists (without them).
parent 3ce328c7
module BuildInfo where
import Control.Monad.State
data BuildInfo = BuildInfo {
biThingVersionMap :: ThingVersionMap,
biWays :: Ways
}
-- Mapping from thing (e.g. "Cabal") to version (e.g. "1.10.0.0")
type ThingVersionMap = [(String, String)]
-- 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
= case lookup thing mapping of
Just version' ->
if version == version'
then Just mapping
else Nothing
Nothing ->
Just ((thing, version) : mapping)
getThingVersionMap :: State BuildInfo ThingVersionMap
getThingVersionMap = do st <- get
return $ biThingVersionMap st
getWays :: State BuildInfo 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 ()
putWays ws = do st <- get
put $ st { biWays = ws }
......@@ -2,7 +2,9 @@
module FilenameDescr where
import Data.Either
import Data.List
import BuildInfo
import Utils
import Tar
......@@ -12,6 +14,7 @@ import Tar
type FilenameDescr = [FilenameDescrBit]
data FilenameDescrBit = VersionOf String
| FP String
| Ways
deriving (Show, Eq, Ord)
normalise :: FilenameDescr -> FilenameDescr
......@@ -20,24 +23,11 @@ normalise [x] = [x]
normalise (FP x1 : FP x2 : xs) = normalise (FP (x1 ++ x2) : xs)
normalise (x : xs) = x : normalise xs
-- Mapping from thing (e.g. "Cabal") to version (e.g. "1.10.0.0")
type ThingVersionMap = [(String, String)]
addThingVersion :: ThingVersionMap -> String -> String -> Maybe ThingVersionMap
addThingVersion mapping thing version
= case lookup thing mapping of
Just version' ->
if version == version'
then Just mapping
else Nothing
Nothing ->
Just ((thing, version) : mapping)
-- Sanity check that the FilenameDescr matches the filename in the tar line
checkContent :: ThingVersionMap -> (FilenameDescr, TarLine) -> Errors
checkContent mapping (fd, tl)
checkContent :: BuildInfo -> (FilenameDescr, TarLine) -> Errors
checkContent buildInfo (fd, tl)
= let fn = tlFileName tl
in case flattenFilenameDescr mapping fd of
in case flattenFilenameDescr buildInfo fd of
Right fn' ->
if fn' == fn
then []
......@@ -45,14 +35,15 @@ checkContent mapping (fd, tl)
Left errs ->
errs
flattenFilenameDescr :: ThingVersionMap -> FilenameDescr
flattenFilenameDescr :: BuildInfo -> FilenameDescr
-> Either Errors FilePath
flattenFilenameDescr mapping fd = case partitionEithers (map f fd) of
([], strs) -> Right (concat strs)
(errs, _) -> Left (concat errs)
flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of
([], strs) -> Right (concat strs)
(errs, _) -> Left (concat errs)
where f (FP fp) = Right fp
f (VersionOf thing)
= case lookup thing mapping of
= case lookup thing (biThingVersionMap buildInfo) of
Just v -> Right v
Nothing -> Left ["Can't happen: thing has no version in mapping"]
f Ways = Right $ intercalate "-" $ biWays buildInfo
......@@ -2,7 +2,7 @@
GHC = ghc
compare: *.hs
"$(GHC)" --make -Wall -Werror $@
"$(GHC)" -O --make -Wall -Werror $@
.PHONY: clean
clean:
......
......@@ -7,6 +7,7 @@ data FileProblem = First Problem
data Problem = DuplicateFile FilePath
| ExtraFile FilePath
| ExtraWay String
| PermissionsChanged FilePath FilePath String String
| FileSizeChanged FilePath FilePath Integer Integer
......@@ -18,6 +19,7 @@ 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
......
......@@ -26,3 +26,10 @@ re r str = case matchM r' str :: Maybe (String, String, String, [String]) of
Nothing -> Nothing
where r' = makeRegex r :: Regex
unSepList :: Eq a => a -> [a] -> [[a]]
unSepList x xs = case break (x ==) xs of
(this, _ : xs') ->
this : unSepList x xs'
(this, []) ->
[this]
......@@ -7,6 +7,7 @@ import Data.Function
import Data.List
import System.Environment
import BuildInfo
import FilenameDescr
import Problem
import Utils
......@@ -34,27 +35,55 @@ doit :: FilePath -> FilePath -> IO ()
doit bd1 bd2
= do tls1 <- readTarLines bd1
tls2 <- readTarLines bd2
content1 <- dieOnErrors $ mkContents tls1
content2 <- dieOnErrors $ mkContents tls2
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
(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
++ 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
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 -> [FileProblem]
diffWays ws1 ws2 = f (sort ws1) (sort ws2)
where f [] [] = []
f xs [] = map (First . ExtraWay) xs
f [] ys = map (First . 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) ->
case concat $ map (checkContent finalBuildInfo) xs of
[] -> Right xs
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)])
......@@ -65,14 +94,14 @@ nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
| otherwise = (ps, x1 : xs')
where (ps, xs') = nubContents xs
mkFilePathDescr :: FilePath -> State ThingVersionMap FilenameDescr
mkFilePathDescr :: FilePath -> State BuildInfo FilenameDescr
mkFilePathDescr fp
| Just [ghcVersion, _, middle, filename]
<- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
= do ghcVersionDescr <- do mapping <- get
= do ghcVersionDescr <- do mapping <- getThingVersionMap
case addThingVersion mapping "ghc" ghcVersion of
Just mapping' ->
do put mapping'
do putThingVersionMap mapping'
return (VersionOf "ghc")
Nothing ->
return (FP ghcVersion)
......@@ -81,17 +110,17 @@ mkFilePathDescr fp
return $ normalise fd
| otherwise = return [FP fp]
mkFileNameDescr :: FilePath -> State ThingVersionMap FilenameDescr
mkFileNameDescr :: FilePath -> State BuildInfo FilenameDescr
mkFileNameDescr filename
| Just [thing, thingVersion, _, ghcVersion, _]
<- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.so$")
filename
= do mapping <- get
= do mapping <- getThingVersionMap
case addThingVersion mapping "ghc" ghcVersion of
Just m ->
case addThingVersion m thing thingVersion of
Just m' ->
do put m'
do putThingVersionMap m'
return [FP "libHS", FP thing, FP "-", VersionOf thing,
FP "-ghc", VersionOf "ghc", FP ".so"]
_ -> unchanged
......@@ -99,46 +128,73 @@ mkFileNameDescr filename
| Just [way, thingVersion, _]
<- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.so$")
filename
= do mapping <- get
= do mapping <- getThingVersionMap
case addThingVersion mapping "ghc" thingVersion of
Just mapping' ->
do put mapping'
do putThingVersionMap mapping'
return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
FP ".so"]
_ -> unchanged
| Just [thing, thingVersion, _, way]
<- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
filename
= do mapping <- get
= do mapping <- getThingVersionMap
case addThingVersion mapping thing thingVersion of
Just mapping' ->
do put mapping'
do putThingVersionMap mapping'
return [FP "libHS", FP thing, FP "-", VersionOf thing,
FP way, FP ".a"]
_ -> unchanged
| Just [thing, thingVersion, _]
<- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
filename
= do mapping <- get
= do mapping <- getThingVersionMap
case addThingVersion mapping thing thingVersion of
Just mapping' ->
do put mapping'
do putThingVersionMap mapping'
return [FP "HS", FP thing, FP "-", VersionOf thing,
FP ".o"]
_ -> 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)]
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 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'
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)]
findFileWay :: FilePath -> Maybe String
findFileWay fp
| Just [way] <- re "\\.([a-z_]+)_hi$" fp
= Just way
| otherwise = Nothing
compareTarLine :: TarLine -> TarLine -> [Problem]
compareTarLine tl1 tl2
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment