1 {-# LANGUAGE PatternGuards #-}
3 module Main (main) where
5 import Control.Monad.State
8 import System.Environment
17 -- * Check installed trees too
20 -- Only size changes > sizeAbs are considered an issue
24 -- Only a size change of sizePercentage% or more is considered an issue
25 sizePercentage :: Integer
29 main = do args <- getArgs
31 [bd1, bd2] -> doit False bd1 bd2
32 ["--ignore-size-changes", bd1, bd2] -> doit True bd1 bd2
33 _ -> die ["Bad args. Need 2 bindists."]
35 doit :: Bool -> FilePath -> FilePath -> IO ()
36 doit ignoreSizeChanges bd1 bd2
37 = do let windows = any ("mingw" `isPrefixOf`) (tails bd1)
38 tls1 <- readTarLines bd1
39 tls2 <- readTarLines bd2
40 -- If it looks like we have a Windows "bindist" then just
41 -- set ways to [] for now.
42 ways1 <- if windows then return []
43 else dieOnErrors $ findWays tls1
44 ways2 <- if windows then return []
45 else dieOnErrors $ findWays tls2
46 content1 <- dieOnErrors $ mkContents ways1 tls1
47 content2 <- dieOnErrors $ mkContents ways2 tls2
48 let mySort = sortBy (compare `on` fst)
49 sortedContent1 = mySort content1
50 sortedContent2 = mySort content2
51 (nubProbs1, nubbedContent1) = nubContents sortedContent1
52 (nubProbs2, nubbedContent2) = nubContents sortedContent2
53 differences = compareContent ways1 nubbedContent1
55 allProbs = map First nubProbs1 ++ map Second nubProbs2
56 ++ diffWays ways1 ways2
58 wantedProbs = if ignoreSizeChanges
59 then filter (not . isSizeChange) allProbs
61 mapM_ (putStrLn . pprFileProblem) wantedProbs
63 findWays :: [TarLine] -> Either Errors Ways
64 findWays = foldr f (Left ["Couldn't find ways"])
65 where f tl res = case re regex (tlFileName tl) of
67 Right (unSepList '-' dashedWays)
70 regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"
72 diffWays :: Ways -> Ways -> [FileProblem]
73 diffWays ws1 ws2 = f (sort ws1) (sort ws2)
75 f xs [] = map (First . ExtraWay) xs
76 f [] ys = map (First . ExtraWay) ys
77 f xs@(x : xs') ys@(y : ys')
78 = case x `compare` y of
79 LT -> First (ExtraWay x) : f xs' ys
80 GT -> Second (ExtraWay y) : f xs ys'
83 mkContents :: Ways -> [TarLine] -> Either Errors [(FilenameDescr, TarLine)]
85 = case runState (mapM f tls) initialBuildInfo of
86 (xs, finalBuildInfo) ->
87 case concat $ map (checkContent finalBuildInfo) xs of
90 where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
92 initialBuildInfo = BuildInfo {
93 biThingVersionMap = [],
97 nubContents :: [(FilenameDescr, TarLine)]
98 -> ([Problem], [(FilenameDescr, TarLine)])
99 nubContents [] = ([], [])
100 nubContents [x] = ([], [x])
101 nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
102 | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs')
103 | otherwise = (ps, x1 : xs')
104 where (ps, xs') = nubContents xs
106 mkFilePathDescr :: FilePath -> State BuildInfo FilenameDescr
108 | Just [ghcVersion, _, middle, filename]
109 <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
110 = do ghcVersionDescr <- do mapping <- getThingVersionMap
111 case addThingVersion mapping "ghc" ghcVersion of
113 do putThingVersionMap mapping'
114 return (VersionOf "ghc")
116 return (FP ghcVersion)
117 filename' <- mkFileNameDescr filename
118 let fd = FP "ghc-" : ghcVersionDescr : FP middle : FP "/" : filename'
119 return $ normalise fd
120 | otherwise = return [FP fp]
122 mkFileNameDescr :: FilePath -> State BuildInfo FilenameDescr
123 mkFileNameDescr filename
124 | Just [thing, thingVersion, _, ghcVersion, _]
125 <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.so$")
127 = do mapping <- getThingVersionMap
128 case addThingVersion mapping "ghc" ghcVersion of
130 case addThingVersion m thing thingVersion of
132 do putThingVersionMap m'
133 return [FP "libHS", FP thing, FP "-", VersionOf thing,
134 FP "-ghc", VersionOf "ghc", FP ".so"]
137 | Just [way, thingVersion, _]
138 <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.so$")
140 = do mapping <- getThingVersionMap
141 case addThingVersion mapping "ghc" thingVersion of
143 do putThingVersionMap mapping'
144 return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
147 | Just [thing, thingVersion, _, way]
148 <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
150 = do mapping <- getThingVersionMap
151 case addThingVersion mapping thing thingVersion of
153 do putThingVersionMap mapping'
154 return [FP "libHS", FP thing, FP "-", VersionOf thing,
157 | Just [thing, thingVersion, _]
158 <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
160 = do mapping <- getThingVersionMap
161 case addThingVersion mapping thing thingVersion of
163 do putThingVersionMap mapping'
164 return [FP "HS", FP thing, FP "-", VersionOf thing,
167 | Just [dashedWays, depType]
168 <- re "^\\.depend-(.*)\\.(haskell|c_asm)"
171 if unSepList '-' dashedWays == ways
172 then return [FP ".depend-", Ways, FP ".", FP depType]
174 | otherwise = unchanged
175 where unchanged = return [FP filename]
177 compareContent :: Ways -> [(FilenameDescr, TarLine)]
178 -> Ways -> [(FilenameDescr, TarLine)]
180 compareContent _ [] _ [] = []
181 compareContent _ xs _ [] = map (First . ExtraFile . tlFileName . snd) xs
182 compareContent _ [] _ ys = map (Second . ExtraFile . tlFileName . snd) ys
183 compareContent ways1 xs1 ways2 xs2
186 (xs, []) -> concatMap (mkExtraFile ways1 First . tlFileName . snd) xs
187 ([], ys) -> concatMap (mkExtraFile ways2 Second . tlFileName . snd) ys
188 ((fd1, tl1) : xs1', (fd2, tl2) : xs2') ->
189 case fd1 `compare` fd2 of
190 EQ -> map Change (compareTarLine tl1 tl2)
191 ++ compareContent ways1 xs1' ways2 xs2'
192 LT -> mkExtraFile ways1 First (tlFileName tl1)
193 ++ compareContent ways1 xs1' ways2 xs2
194 GT -> mkExtraFile ways2 Second (tlFileName tl2)
195 ++ compareContent ways1 xs1 ways2 xs2'
196 where mkExtraFile ways mkFileProblem filename
197 = case findFileWay filename of
199 | way `elem` ways -> []
200 _ -> [mkFileProblem (ExtraFile filename)]
202 findFileWay :: FilePath -> Maybe String
204 | Just [way] <- re "\\.([a-z_]+)_hi$" fp
206 | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp
208 | otherwise = Nothing
210 compareTarLine :: TarLine -> TarLine -> [Problem]
211 compareTarLine tl1 tl2
212 = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
213 ++ [ FileSizeChanged fn1 fn2 size1 size2 | sizeChanged ]
214 where fn1 = tlFileName tl1
216 perms1 = tlPermissions tl1
217 perms2 = tlPermissions tl2
220 sizeChanged = abs (size1 - size2) > sizeAbs
221 && (((100 * size1) `div` size2) > sizePercentage ||
222 ((100 * size2) `div` size1) > sizePercentage)
225 versionRE = "([0-9]+(\\.[0-9]+)*)"