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
doit :: Bool -> FilePath -> FilePath -> IO ()
doit ignoreSizeChanges bd1 bd2
- = do let windows = any ("mingw" `isPrefixOf`) (tails bd1)
- tls1 <- readTarLines bd1
+ = do tls1 <- readTarLines bd1
tls2 <- readTarLines bd2
- -- 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 <- 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
wantedProbs = if ignoreSizeChanges
then filter (not . isSizeChange) allProbs
else allProbs
- mapM_ (putStrLn . pprFileProblem) 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
+ 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, _) : _))
| 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|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" 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 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
| 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 ]