1 {-# LANGUAGE PatternGuards #-}
3 module Main (main) where
5 import Control.Monad.State
7 import System.Environment
16 -- * Check installed trees too
19 -- Only size changes > sizeAbs are considered an issue
23 -- Only a size change of sizePercentage% or more is considered an issue
24 sizePercentage :: Integer
28 main = do args <- getArgs
30 [bd1, bd2] -> doit False bd1 bd2
31 ["--ignore-size-changes", bd1, bd2] -> doit True bd1 bd2
32 _ -> die ["Bad args. Need 2 bindists."]
34 doit :: Bool -> FilePath -> FilePath -> IO ()
35 doit ignoreSizeChanges bd1 bd2
36 = do let windows = any ("mingw" `isPrefixOf`) (tails bd1)
37 tls1 <- readTarLines bd1
38 tls2 <- readTarLines bd2
39 -- If it looks like we have a Windows "bindist" then just
40 -- set ways to [] for now.
41 ways1 <- if windows then return []
42 else dieOnErrors $ findWays tls1
43 ways2 <- if windows then return []
44 else dieOnErrors $ findWays tls2
45 (content1, tvm1) <- dieOnErrors $ mkContents ways1 tls1
46 (content2, tvm2) <- dieOnErrors $ mkContents ways2 tls2
47 let sortedContent1 = sortByFst content1
48 sortedContent2 = sortByFst content2
49 (nubProbs1, nubbedContent1) = nubContents sortedContent1
50 (nubProbs2, nubbedContent2) = nubContents sortedContent2
51 differences = compareContent ways1 nubbedContent1
53 allProbs = map First nubProbs1 ++ map Second nubProbs2
54 ++ diffThingVersionMap tvm1 tvm2
55 ++ diffWays ways1 ways2
57 wantedProbs = if ignoreSizeChanges
58 then filter (not . isSizeChange) allProbs
60 mapM_ (putStrLn . pprFileChange) wantedProbs
62 findWays :: [TarLine] -> Either Errors Ways
63 findWays = foldr f (Left ["Couldn't find ways"])
64 where f tl res = case re regex (tlFileName tl) of
66 Right (unSepList '-' dashedWays)
69 regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"
71 diffWays :: Ways -> Ways -> [FileChange]
72 diffWays ws1 ws2 = f (sort ws1) (sort ws2)
74 f xs [] = map (First . ExtraWay) xs
75 f [] ys = map (Second . ExtraWay) ys
76 f xs@(x : xs') ys@(y : ys')
77 = case x `compare` y of
78 LT -> First (ExtraWay x) : f xs' ys
79 GT -> Second (ExtraWay y) : f xs ys'
82 diffThingVersionMap :: ThingVersionMap -> ThingVersionMap -> [FileChange]
83 diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2)
85 f xs [] = map (First . ExtraThing . fst) xs
86 f [] ys = map (Second . ExtraThing . fst) ys
87 f xs@((xt, xv) : xs') ys@((yt, yv) : ys')
88 = case xt `compare` yt of
89 LT -> First (ExtraThing xt) : f xs' ys
90 GT -> Second (ExtraThing yt) : f xs ys'
91 EQ -> let this = if xv == yv
93 else [Change (ThingVersionChanged xt xv yv)]
96 mkContents :: Ways -> [TarLine]
97 -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap)
99 = case runStateT (mapM f tls) (emptyBuildInfo ways) of
100 Nothing -> Left ["Can't happen: mkContents: Nothing"]
101 Just (xs, finalBuildInfo) ->
102 case concat $ map (checkContent finalBuildInfo) xs of
103 [] -> Right (xs, biThingVersionMap finalBuildInfo)
105 where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
108 nubContents :: [(FilenameDescr, TarLine)]
109 -> ([Change], [(FilenameDescr, TarLine)])
110 nubContents [] = ([], [])
111 nubContents [x] = ([], [x])
112 nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
113 | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs')
114 | otherwise = (ps, x1 : xs')
115 where (ps, xs') = nubContents xs
117 mkFilePathDescr :: FilePath -> BIMonad FilenameDescr
119 | Just [ghcVersion, _, middle, filename]
120 <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
121 = do haveThingVersion "ghc" ghcVersion
122 middle' <- mkMiddleDescr middle
123 filename' <- mkFileNameDescr filename
124 let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename'
125 return $ normalise fd
126 | otherwise = return [FP fp]
128 mkMiddleDescr :: FilePath -> BIMonad FilenameDescr
130 -- haddock docs in a Windows installed tree
131 | Just [thing, thingVersion, _, src]
132 <- re ("^/doc/html/libraries/([^/]*)-" ++ versionRE ++ "(/src)?$")
134 = do haveThingVersion thing thingVersion
135 return [FP "/doc/html/libraries/",
136 FP thing, FP "-", VersionOf thing, FP src]
138 -- libraries in a Windows installed tree
139 | Just [thing, thingVersion, _, rest]
140 <- re ("^/lib/([^/]*)-" ++ versionRE ++ "(/.*)?$")
142 = do haveThingVersion thing thingVersion
143 return [FP "/lib/", FP thing, FP "-", VersionOf thing, FP rest]
145 -- Windows in-tree gcc
146 | Just [prefix, _, _, gccVersion, _, rest]
147 <- re ("^(/mingw/(lib(exec)?/gcc/mingw32/|share/gcc-))" ++ versionRE ++ "(/.*)?$")
149 = do haveThingVersion "gcc" gccVersion
150 return [FP prefix, VersionOf "gcc", FP rest]
152 | otherwise = unchanged
153 where unchanged = return [FP middle]
155 mkFileNameDescr :: FilePath -> BIMonad FilenameDescr
156 mkFileNameDescr filename
157 | Just [prog, ghcVersion, _, exe]
158 <- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$")
160 = do haveThingVersion "ghc" ghcVersion
161 return [FP prog, FP "-", VersionOf "ghc", FP exe]
163 | Just [thing, thingVersion, _, ghcVersion, _, soDll]
164 <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
166 = do haveThingVersion "ghc" ghcVersion
167 haveThingVersion thing thingVersion
168 return [FP "libHS", FP thing, FP "-", VersionOf thing,
169 FP "-ghc", VersionOf "ghc", FP ".", FP soDll]
171 | Just [way, thingVersion, _, soDll]
172 <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
174 = do haveThingVersion "ghc" thingVersion
175 return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
178 | Just [thingVersion, _, soDll]
179 <- re ("^libHSffi-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
181 = do haveThingVersion "ghc" thingVersion
182 return [FP "libHSffi-ghc", VersionOf "ghc", FP ".", FP soDll]
184 | Just [thing, thingVersion, _, way]
185 <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
187 = do haveThingVersion thing thingVersion
188 return [FP "libHS", FP thing, FP "-", VersionOf thing,
191 | Just [thing, thingVersion, _]
192 <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
194 = do haveThingVersion thing thingVersion
195 return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"]
197 | Just [thing, thingVersion, _, thingHash]
198 <- re ("^(.*)-" ++ versionRE ++ "-([0-9a-f]{32})\\.conf$")
200 = do haveThingVersion thing thingVersion
201 haveThingHash thing thingHash
202 return [FP thing, FP "-", VersionOf thing, FP "-", HashOf thing,
205 | Just [thingVersion, _]
206 <- re ("^mingw32-gcc-" ++ versionRE ++ "\\.exe$")
208 = do haveThingVersion "gcc" thingVersion
209 return [FP "mingw32-gcc-", VersionOf "gcc", FP ".exe"]
211 | Just [dashedWays, depType]
212 <- re "^\\.depend-(.*)\\.(haskell|c_asm)"
215 if unSepList '-' dashedWays == ways
216 then return [FP ".depend-", Ways, FP ".", FP depType]
218 | otherwise = unchanged
219 where unchanged = return [FP filename]
221 compareContent :: Ways -> [(FilenameDescr, TarLine)]
222 -> Ways -> [(FilenameDescr, TarLine)]
224 compareContent _ [] _ [] = []
225 compareContent _ xs _ [] = map (First . ExtraFile . tlFileName . snd) xs
226 compareContent _ [] _ ys = map (Second . ExtraFile . tlFileName . snd) ys
227 compareContent ways1 xs1 ways2 xs2
230 (xs, []) -> concatMap (mkExtraFile ways1 First . tlFileName . snd) xs
231 ([], ys) -> concatMap (mkExtraFile ways2 Second . tlFileName . snd) ys
232 ((fd1, tl1) : xs1', (fd2, tl2) : xs2') ->
233 case fd1 `compare` fd2 of
234 EQ -> map Change (compareTarLine tl1 tl2)
235 ++ compareContent ways1 xs1' ways2 xs2'
236 LT -> mkExtraFile ways1 First (tlFileName tl1)
237 ++ compareContent ways1 xs1' ways2 xs2
238 GT -> mkExtraFile ways2 Second (tlFileName tl2)
239 ++ compareContent ways1 xs1 ways2 xs2'
240 where mkExtraFile ways mkFileChange filename
241 = case findFileWay filename of
243 | way `elem` ways -> []
244 _ -> [mkFileChange (ExtraFile filename)]
246 findFileWay :: FilePath -> Maybe String
248 | Just [way] <- re "\\.([a-z_]+)_hi$" fp
250 | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp
252 | otherwise = Nothing
254 compareTarLine :: TarLine -> TarLine -> [Change]
255 compareTarLine tl1 tl2
256 = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
257 ++ [ FileSizeChanged fn1 fn2 size1 size2 | sizeChanged ]
258 where fn1 = tlFileName tl1
260 perms1 = tlPermissions tl1
261 perms2 = tlPermissions tl2
264 sizeChanged = abs (size1 - size2) > sizeAbs
265 && (((100 * size1) `div` size2) > sizePercentage ||
266 ((100 * size2) `div` size1) > sizePercentage)
269 versionRE = "([0-9]+(\\.[0-9]+)*)"