Remove LANGUAGE pragrams implied by Haskell2010
[ghc.git] / distrib / compare / compare.hs
1 module Main (main) where
2
3 import Control.Monad.State
4 import Data.Char
5 import Data.List
6 import System.Directory
7 import System.Environment
8 import System.FilePath
9
10 import BuildInfo
11 import FilenameDescr
12 import Change
13 import Utils
14 import Tar
15
16 -- TODO:
17 -- * Check installed trees too
18 -- * Check hashbangs
19
20 sizeChangeThresholds :: [(Integer, -- Theshold only applies if one of
21 -- the files is at least this big
22 Integer)] -- Size changed if the larger file's
23 -- size is at least this %age of the
24 -- smaller file's size
25 sizeChangeThresholds = [( 1000, 150),
26 (50 * 1000, 110)]
27
28 main :: IO ()
29 main = do args <- getArgs
30 (ignoreSizeChanges, p1, p2) <-
31 case args of
32 [p1, p2] -> return (False, p1, p2)
33 ["--ignore-size-changes", p1, p2] -> return (True, p1, p2)
34 _ -> die ["Bad args. Need 2 filepaths."]
35 doFileOrDirectory ignoreSizeChanges p1 p2
36
37 doFileOrDirectory :: Bool -> FilePath -> FilePath -> IO ()
38 doFileOrDirectory ignoreSizeChanges p1 p2
39 = do b <- doesDirectoryExist p1
40 let doit = if b then doDirectory else doFile
41 doit ignoreSizeChanges p1 p2
42
43 doDirectory :: Bool -> FilePath -> FilePath -> IO ()
44 doDirectory ignoreSizeChanges p1 p2
45 = do fs1 <- getDirectoryContents p1
46 fs2 <- getDirectoryContents p2
47 let isVersionChar c = isDigit c || c == '.'
48 mkFileInfo "." = return []
49 mkFileInfo ".." = return []
50 mkFileInfo fp@('g':'h':'c':'-':x:xs)
51 | isDigit x = return [(("ghc-", "VERSION", dropWhile isVersionChar xs), fp)]
52 | otherwise = die ["No version number in " ++ show fp]
53 mkFileInfo fp = do warn ["Unrecognised filename " ++ show fp]
54 return []
55 fss1' <- mapM mkFileInfo fs1
56 fss2' <- mapM mkFileInfo fs2
57 let fs1' = sort $ concat fss1'
58 fs2' = sort $ concat fss2'
59
60 putBreak = putStrLn "=========="
61 extraFile d fp = do putBreak
62 putStrLn ("Extra file in " ++ show d
63 ++ ": " ++ show fp)
64 doFiles [] [] = do putBreak
65 putStrLn "Done."
66 doFiles ((_, fp) : xs) [] = do extraFile p1 fp
67 doFiles xs []
68 doFiles [] ((_, fp) : ys) = do extraFile p2 fp
69 doFiles [] ys
70 doFiles xs@((fpc1, fp1) : xs') ys@((fpc2, fp2) : ys')
71 = do case fpc1 `compare` fpc2 of
72 EQ ->
73 do putBreak
74 putStrLn $ unwords ["Doing", show fp1, show fp2]
75 doFile ignoreSizeChanges (p1 </> fp1)
76 (p2 </> fp2)
77 doFiles xs' ys'
78 LT -> do extraFile p1 fp1
79 doFiles xs' ys
80 GT -> do extraFile p2 fp2
81 doFiles xs ys'
82 doFiles fs1' fs2'
83
84 doFile :: Bool -> FilePath -> FilePath -> IO ()
85 doFile ignoreSizeChanges bd1 bd2
86 = do tls1 <- readTarLines bd1
87 tls2 <- readTarLines bd2
88 let mWays1 = findWays tls1
89 mWays2 = findWays tls2
90 wayDifferences <- case (mWays1, mWays2) of
91 (Nothing, Nothing) ->
92 return []
93 (Just ways1, Just ways2) ->
94 return $ diffWays ways1 ways2
95 _ ->
96 die ["One input has ways, but the other doesn't"]
97 (content1, tvm1) <- dieOnErrors $ mkContents mWays1 tls1
98 (content2, tvm2) <- dieOnErrors $ mkContents mWays2 tls2
99 let sortedContent1 = sortByFst content1
100 sortedContent2 = sortByFst content2
101 (nubProbs1, nubbedContent1) = nubContents sortedContent1
102 (nubProbs2, nubbedContent2) = nubContents sortedContent2
103 differences = compareContent mWays1 nubbedContent1
104 mWays2 nubbedContent2
105 allProbs = map First nubProbs1 ++ map Second nubProbs2
106 ++ diffThingVersionMap tvm1 tvm2
107 ++ wayDifferences
108 ++ differences
109 wantedProbs = if ignoreSizeChanges
110 then filter (not . isSizeChange) allProbs
111 else allProbs
112 mapM_ (putStrLn . pprFileChange) wantedProbs
113
114 -- *nix bindists have ways.
115 -- Windows "bindists", install trees, and testsuites don't.
116 findWays :: [TarLine] -> Maybe Ways
117 findWays tls = msum $ map f tls
118 where f tl = case re regex (tlFileName tl) of
119 Just [dashedWays] -> Just (unSepList '-' dashedWays)
120 _ -> Nothing
121 regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"
122
123 diffWays :: Ways -> Ways -> [FileChange]
124 diffWays ws1 ws2 = f (sort ws1) (sort ws2)
125 where f [] [] = []
126 f xs [] = map (First . ExtraWay) xs
127 f [] ys = map (Second . ExtraWay) ys
128 f xs@(x : xs') ys@(y : ys')
129 = case x `compare` y of
130 LT -> First (ExtraWay x) : f xs' ys
131 GT -> Second (ExtraWay y) : f xs ys'
132 EQ -> f xs' ys'
133
134 diffThingVersionMap :: ThingVersionMap -> ThingVersionMap -> [FileChange]
135 diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2)
136 where f [] [] = []
137 f xs [] = map (First . ExtraThing . fst) xs
138 f [] ys = map (Second . ExtraThing . fst) ys
139 f xs@((xt, xv) : xs') ys@((yt, yv) : ys')
140 = case xt `compare` yt of
141 LT -> First (ExtraThing xt) : f xs' ys
142 GT -> Second (ExtraThing yt) : f xs ys'
143 EQ -> let this = if xv == yv
144 then []
145 else [Change (ThingVersionChanged xt xv yv)]
146 in this ++ f xs' ys'
147
148 mkContents :: Maybe Ways -> [TarLine]
149 -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap)
150 mkContents mWays tls
151 = case runStateT (mapM f tls) (emptyBuildInfo mWays) of
152 Nothing -> Left ["Can't happen: mkContents: Nothing"]
153 Just (xs, finalBuildInfo) ->
154 case concat $ map (checkContent finalBuildInfo) xs of
155 [] -> Right (xs, biThingVersionMap finalBuildInfo)
156 errs -> Left errs
157 where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
158 return (fnd, tl)
159
160 nubContents :: [(FilenameDescr, TarLine)]
161 -> ([Change], [(FilenameDescr, TarLine)])
162 nubContents [] = ([], [])
163 nubContents [x] = ([], [x])
164 nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
165 | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs')
166 | otherwise = (ps, x1 : xs')
167 where (ps, xs') = nubContents xs
168
169 mkFilePathDescr :: FilePath -> BIMonad FilenameDescr
170 mkFilePathDescr fp
171 | Just [ghcVersion, _, middle, filename]
172 <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
173 = do haveThingVersion "ghc" ghcVersion
174 middle' <- mkMiddleDescr middle
175 filename' <- mkFileNameDescr filename
176 let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename'
177 return $ normaliseDescr fd
178 | otherwise = return [FP fp]
179
180 mkMiddleDescr :: FilePath -> BIMonad FilenameDescr
181 mkMiddleDescr middle
182 -- haddock docs in a Windows installed tree
183 | Just [thing, thingVersion, _, src]
184 <- re ("^/doc/html/libraries/([^/]*)-" ++ versionRE ++ "(/src)?$")
185 middle
186 = do haveThingVersion thing thingVersion
187 return [FP "/doc/html/libraries/",
188 FP thing, FP "-", VersionOf thing, FP src]
189 `mplus` unchanged
190 -- libraries in a Windows installed tree
191 | Just [thing, thingVersion, _, rest]
192 <- re ("^/lib/([^/]*)-" ++ versionRE ++ "(/.*)?$")
193 middle
194 = do haveThingVersion thing thingVersion
195 return [FP "/lib/", FP thing, FP "-", VersionOf thing, FP rest]
196 `mplus` unchanged
197 -- Windows in-tree gcc
198 | Just [prefix, _, _, gccVersion, _, rest]
199 <- re ("^(/mingw/(lib(exec)?/gcc/mingw32/|share/gcc-))" ++ versionRE ++ "(/.*)?$")
200 middle
201 = do haveThingVersion "gcc" gccVersion
202 return [FP prefix, VersionOf "gcc", FP rest]
203 `mplus` unchanged
204 | otherwise = unchanged
205 where unchanged = return [FP middle]
206
207 mkFileNameDescr :: FilePath -> BIMonad FilenameDescr
208 mkFileNameDescr filename
209 | Just [prog, ghcVersion, _, exe]
210 <- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$")
211 filename
212 = do haveThingVersion "ghc" ghcVersion
213 return [FP prog, FP "-", VersionOf "ghc", FP exe]
214 `mplus` unchanged
215 | Just [thing, thingVersion, _, ghcVersion, _, soDll]
216 <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
217 filename
218 = do haveThingVersion "ghc" ghcVersion
219 haveThingVersion thing thingVersion
220 return [FP "libHS", FP thing, FP "-", VersionOf thing,
221 FP "-ghc", VersionOf "ghc", FP ".", FP soDll]
222 `mplus` unchanged
223 | Just [way, thingVersion, _, soDll]
224 <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
225 filename
226 = do haveThingVersion "ghc" thingVersion
227 return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
228 FP ".", FP soDll]
229 `mplus` unchanged
230 | Just [thingVersion, _, soDll]
231 <- re ("^libHSffi-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
232 filename
233 = do haveThingVersion "ghc" thingVersion
234 return [FP "libHSffi-ghc", VersionOf "ghc", FP ".", FP soDll]
235 `mplus` unchanged
236 | Just [thing, thingVersion, _, way]
237 <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
238 filename
239 = do haveThingVersion thing thingVersion
240 return [FP "libHS", FP thing, FP "-", VersionOf thing,
241 FP way, FP ".a"]
242 `mplus` unchanged
243 | Just [thing, thingVersion, _]
244 <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
245 filename
246 = do haveThingVersion thing thingVersion
247 return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"]
248 `mplus` unchanged
249 | Just [thing, thingVersion, _, thingHash]
250 <- re ("^(.*)-" ++ versionRE ++ "-([0-9a-f]{32})\\.conf$")
251 filename
252 = do haveThingVersion thing thingVersion
253 haveThingHash thing thingHash
254 return [FP thing, FP "-", VersionOf thing, FP "-", HashOf thing,
255 FP ".conf"]
256 `mplus` unchanged
257 | Just [thingVersion, _]
258 <- re ("^mingw32-gcc-" ++ versionRE ++ "\\.exe$")
259 filename
260 = do haveThingVersion "gcc" thingVersion
261 return [FP "mingw32-gcc-", VersionOf "gcc", FP ".exe"]
262 `mplus` unchanged
263 | Just [dashedWays, depType]
264 <- re "^\\.depend-(.*)\\.(haskell|c_asm)"
265 filename
266 = do mWays <- getMaybeWays
267 if Just (unSepList '-' dashedWays) == mWays
268 then return [FP ".depend-", Ways, FP ".", FP depType]
269 else unchanged
270 | otherwise = unchanged
271 where unchanged = return [FP filename]
272
273 compareContent :: Maybe Ways -> [(FilenameDescr, TarLine)]
274 -> Maybe Ways -> [(FilenameDescr, TarLine)]
275 -> [FileChange]
276 compareContent mWays1 xs1all mWays2 xs2all
277 = f xs1all xs2all
278 where f [] [] = []
279 f xs [] = concatMap (mkExtraFile mWays1 mWays2 First . tlFileName . snd) xs
280 f [] ys = concatMap (mkExtraFile mWays2 mWays1 Second . tlFileName . snd) ys
281 f xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2')
282 = case fd1 `compare` fd2 of
283 EQ -> map Change (compareTarLine tl1 tl2)
284 ++ f xs1' xs2'
285 LT -> mkExtraFile mWays1 mWays2 First (tlFileName tl1)
286 ++ f xs1' xs2
287 GT -> mkExtraFile mWays2 mWays1 Second (tlFileName tl2)
288 ++ f xs1 xs2'
289 mkExtraFile mWaysMe mWaysThem mkFileChange filename
290 = case (findFileWay filename, mWaysMe, mWaysThem) of
291 (Just way, Just waysMe, Just waysThem)
292 | (way `elem` waysMe) && not (way `elem` waysThem) -> []
293 _ -> [mkFileChange (ExtraFile filename)]
294
295 findFileWay :: FilePath -> Maybe String
296 findFileWay fp
297 | Just [way] <- re "\\.([a-z_]+)_hi$" fp
298 = Just way
299 | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp
300 = Just way
301 | otherwise = Nothing
302
303 compareTarLine :: TarLine -> TarLine -> [Change]
304 compareTarLine tl1 tl2
305 = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
306 ++ [ FileSizeChanged fn1 fn2 size1 size2 | sizeChanged ]
307 where fn1 = tlFileName tl1
308 fn2 = tlFileName tl2
309 perms1 = tlPermissions tl1
310 perms2 = tlPermissions tl2
311 size1 = tlSize tl1
312 size2 = tlSize tl2
313 sizeMin = size1 `min` size2
314 sizeMax = size1 `max` size2
315 sizeChanged = any sizeChangeThresholdReached sizeChangeThresholds
316 sizeChangeThresholdReached (reqSize, percentage)
317 = (sizeMax >= reqSize)
318 && (((100 * sizeMax) `div` sizeMin) >= percentage)
319
320 versionRE :: String
321 versionRE = "([0-9]+(\\.[0-9]+)*)"
322