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 tls1 <- readTarLines bd1
37 tls2 <- readTarLines bd2
38 let mWays1 = findWays tls1
39 mWays2 = findWays tls2
40 wayDifferences <- case (mWays1, mWays2) of
43 (Just ways1, Just ways2) ->
44 return $ diffWays ways1 ways2
46 die ["One input has ways, but the other doesn't"]
47 (content1, tvm1) <- dieOnErrors $ mkContents mWays1 tls1
48 (content2, tvm2) <- dieOnErrors $ mkContents mWays2 tls2
49 let sortedContent1 = sortByFst content1
50 sortedContent2 = sortByFst content2
51 (nubProbs1, nubbedContent1) = nubContents sortedContent1
52 (nubProbs2, nubbedContent2) = nubContents sortedContent2
53 differences = compareContent mWays1 nubbedContent1
55 allProbs = map First nubProbs1 ++ map Second nubProbs2
56 ++ diffThingVersionMap tvm1 tvm2
59 wantedProbs = if ignoreSizeChanges
60 then filter (not . isSizeChange) allProbs
62 mapM_ (putStrLn . pprFileChange) wantedProbs
64 -- *nix bindists have ways.
65 -- Windows "bindists", install trees, and testsuites don't.
66 findWays :: [TarLine] -> Maybe Ways
67 findWays tls = msum $ map f tls
68 where f tl = case re regex (tlFileName tl) of
69 Just [dashedWays] -> Just (unSepList '-' dashedWays)
71 regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"
73 diffWays :: Ways -> Ways -> [FileChange]
74 diffWays ws1 ws2 = f (sort ws1) (sort ws2)
76 f xs [] = map (First . ExtraWay) xs
77 f [] ys = map (Second . ExtraWay) ys
78 f xs@(x : xs') ys@(y : ys')
79 = case x `compare` y of
80 LT -> First (ExtraWay x) : f xs' ys
81 GT -> Second (ExtraWay y) : f xs ys'
84 diffThingVersionMap :: ThingVersionMap -> ThingVersionMap -> [FileChange]
85 diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2)
87 f xs [] = map (First . ExtraThing . fst) xs
88 f [] ys = map (Second . ExtraThing . fst) ys
89 f xs@((xt, xv) : xs') ys@((yt, yv) : ys')
90 = case xt `compare` yt of
91 LT -> First (ExtraThing xt) : f xs' ys
92 GT -> Second (ExtraThing yt) : f xs ys'
93 EQ -> let this = if xv == yv
95 else [Change (ThingVersionChanged xt xv yv)]
98 mkContents :: Maybe Ways -> [TarLine]
99 -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap)
101 = case runStateT (mapM f tls) (emptyBuildInfo mWays) of
102 Nothing -> Left ["Can't happen: mkContents: Nothing"]
103 Just (xs, finalBuildInfo) ->
104 case concat $ map (checkContent finalBuildInfo) xs of
105 [] -> Right (xs, biThingVersionMap finalBuildInfo)
107 where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
110 nubContents :: [(FilenameDescr, TarLine)]
111 -> ([Change], [(FilenameDescr, TarLine)])
112 nubContents [] = ([], [])
113 nubContents [x] = ([], [x])
114 nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
115 | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs')
116 | otherwise = (ps, x1 : xs')
117 where (ps, xs') = nubContents xs
119 mkFilePathDescr :: FilePath -> BIMonad FilenameDescr
121 | Just [ghcVersion, _, middle, filename]
122 <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
123 = do haveThingVersion "ghc" ghcVersion
124 middle' <- mkMiddleDescr middle
125 filename' <- mkFileNameDescr filename
126 let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename'
127 return $ normalise fd
128 | otherwise = return [FP fp]
130 mkMiddleDescr :: FilePath -> BIMonad FilenameDescr
132 -- haddock docs in a Windows installed tree
133 | Just [thing, thingVersion, _, src]
134 <- re ("^/doc/html/libraries/([^/]*)-" ++ versionRE ++ "(/src)?$")
136 = do haveThingVersion thing thingVersion
137 return [FP "/doc/html/libraries/",
138 FP thing, FP "-", VersionOf thing, FP src]
140 -- libraries in a Windows installed tree
141 | Just [thing, thingVersion, _, rest]
142 <- re ("^/lib/([^/]*)-" ++ versionRE ++ "(/.*)?$")
144 = do haveThingVersion thing thingVersion
145 return [FP "/lib/", FP thing, FP "-", VersionOf thing, FP rest]
147 -- Windows in-tree gcc
148 | Just [prefix, _, _, gccVersion, _, rest]
149 <- re ("^(/mingw/(lib(exec)?/gcc/mingw32/|share/gcc-))" ++ versionRE ++ "(/.*)?$")
151 = do haveThingVersion "gcc" gccVersion
152 return [FP prefix, VersionOf "gcc", FP rest]
154 | otherwise = unchanged
155 where unchanged = return [FP middle]
157 mkFileNameDescr :: FilePath -> BIMonad FilenameDescr
158 mkFileNameDescr filename
159 | Just [prog, ghcVersion, _, exe]
160 <- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$")
162 = do haveThingVersion "ghc" ghcVersion
163 return [FP prog, FP "-", VersionOf "ghc", FP exe]
165 | Just [thing, thingVersion, _, ghcVersion, _, soDll]
166 <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
168 = do haveThingVersion "ghc" ghcVersion
169 haveThingVersion thing thingVersion
170 return [FP "libHS", FP thing, FP "-", VersionOf thing,
171 FP "-ghc", VersionOf "ghc", FP ".", FP soDll]
173 | Just [way, thingVersion, _, soDll]
174 <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
176 = do haveThingVersion "ghc" thingVersion
177 return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
180 | Just [thingVersion, _, soDll]
181 <- re ("^libHSffi-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$")
183 = do haveThingVersion "ghc" thingVersion
184 return [FP "libHSffi-ghc", VersionOf "ghc", FP ".", FP soDll]
186 | Just [thing, thingVersion, _, way]
187 <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
189 = do haveThingVersion thing thingVersion
190 return [FP "libHS", FP thing, FP "-", VersionOf thing,
193 | Just [thing, thingVersion, _]
194 <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
196 = do haveThingVersion thing thingVersion
197 return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"]
199 | Just [thing, thingVersion, _, thingHash]
200 <- re ("^(.*)-" ++ versionRE ++ "-([0-9a-f]{32})\\.conf$")
202 = do haveThingVersion thing thingVersion
203 haveThingHash thing thingHash
204 return [FP thing, FP "-", VersionOf thing, FP "-", HashOf thing,
207 | Just [thingVersion, _]
208 <- re ("^mingw32-gcc-" ++ versionRE ++ "\\.exe$")
210 = do haveThingVersion "gcc" thingVersion
211 return [FP "mingw32-gcc-", VersionOf "gcc", FP ".exe"]
213 | Just [dashedWays, depType]
214 <- re "^\\.depend-(.*)\\.(haskell|c_asm)"
216 = do mWays <- getMaybeWays
217 if Just (unSepList '-' dashedWays) == mWays
218 then return [FP ".depend-", Ways, FP ".", FP depType]
220 | otherwise = unchanged
221 where unchanged = return [FP filename]
223 compareContent :: Maybe Ways -> [(FilenameDescr, TarLine)]
224 -> Maybe Ways -> [(FilenameDescr, TarLine)]
226 compareContent mWays1 xs1all mWays2 xs2all
229 f xs [] = concatMap (mkExtraFile mWays1 mWays2 First . tlFileName . snd) xs
230 f [] ys = concatMap (mkExtraFile mWays2 mWays1 Second . tlFileName . snd) ys
231 f xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2')
232 = case fd1 `compare` fd2 of
233 EQ -> map Change (compareTarLine tl1 tl2)
235 LT -> mkExtraFile mWays1 mWays2 First (tlFileName tl1)
237 GT -> mkExtraFile mWays2 mWays1 Second (tlFileName tl2)
239 mkExtraFile mWaysMe mWaysThem mkFileChange filename
240 = case (findFileWay filename, mWaysMe, mWaysThem) of
241 (Just way, Just waysMe, Just waysThem)
242 | (way `elem` waysMe) && not (way `elem` waysThem) -> []
243 _ -> [mkFileChange (ExtraFile filename)]
245 findFileWay :: FilePath -> Maybe String
247 | Just [way] <- re "\\.([a-z_]+)_hi$" fp
249 | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp
251 | otherwise = Nothing
253 compareTarLine :: TarLine -> TarLine -> [Change]
254 compareTarLine tl1 tl2
255 = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
256 ++ [ FileSizeChanged fn1 fn2 size1 size2 | sizeChanged ]
257 where fn1 = tlFileName tl1
259 perms1 = tlPermissions tl1
260 perms2 = tlPermissions tl2
263 sizeChanged = abs (size1 - size2) > sizeAbs
264 && (((100 * size1) `div` size2) > sizePercentage ||
265 ((100 * size2) `div` size1) > sizePercentage)
268 versionRE = "([0-9]+(\\.[0-9]+)*)"