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 tls1 <- readTarLines bd1
38 tls2 <- readTarLines bd2
39 ways1 <- dieOnErrors $ findWays tls1
40 ways2 <- dieOnErrors $ findWays tls2
41 content1 <- dieOnErrors $ mkContents ways1 tls1
42 content2 <- dieOnErrors $ mkContents ways2 tls2
43 let mySort = sortBy (compare `on` fst)
44 sortedContent1 = mySort content1
45 sortedContent2 = mySort content2
46 (nubProbs1, nubbedContent1) = nubContents sortedContent1
47 (nubProbs2, nubbedContent2) = nubContents sortedContent2
48 differences = compareContent ways1 nubbedContent1
50 allProbs = map First nubProbs1 ++ map Second nubProbs2
51 ++ diffWays ways1 ways2
53 wantedProbs = if ignoreSizeChanges
54 then filter (not . isSizeChange) allProbs
56 mapM_ (putStrLn . pprFileProblem) wantedProbs
58 findWays :: [TarLine] -> Either Errors Ways
59 findWays = foldr f (Left ["Couldn't find ways"])
60 where f tl res = case re regex (tlFileName tl) of
62 Right (unSepList '-' dashedWays)
65 regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"
67 diffWays :: Ways -> Ways -> [FileProblem]
68 diffWays ws1 ws2 = f (sort ws1) (sort ws2)
70 f xs [] = map (First . ExtraWay) xs
71 f [] ys = map (First . ExtraWay) ys
72 f xs@(x : xs') ys@(y : ys')
73 = case x `compare` y of
74 LT -> First (ExtraWay x) : f xs' ys
75 GT -> Second (ExtraWay y) : f xs ys'
78 mkContents :: Ways -> [TarLine] -> Either Errors [(FilenameDescr, TarLine)]
80 = case runState (mapM f tls) initialBuildInfo of
81 (xs, finalBuildInfo) ->
82 case concat $ map (checkContent finalBuildInfo) xs of
85 where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
87 initialBuildInfo = BuildInfo {
88 biThingVersionMap = [],
92 nubContents :: [(FilenameDescr, TarLine)]
93 -> ([Problem], [(FilenameDescr, TarLine)])
94 nubContents [] = ([], [])
95 nubContents [x] = ([], [x])
96 nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
97 | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs')
98 | otherwise = (ps, x1 : xs')
99 where (ps, xs') = nubContents xs
101 mkFilePathDescr :: FilePath -> State BuildInfo FilenameDescr
103 | Just [ghcVersion, _, middle, filename]
104 <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
105 = do ghcVersionDescr <- do mapping <- getThingVersionMap
106 case addThingVersion mapping "ghc" ghcVersion of
108 do putThingVersionMap mapping'
109 return (VersionOf "ghc")
111 return (FP ghcVersion)
112 filename' <- mkFileNameDescr filename
113 let fd = FP "ghc-" : ghcVersionDescr : FP middle : FP "/" : filename'
114 return $ normalise fd
115 | otherwise = return [FP fp]
117 mkFileNameDescr :: FilePath -> State BuildInfo FilenameDescr
118 mkFileNameDescr filename
119 | Just [thing, thingVersion, _, ghcVersion, _]
120 <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.so$")
122 = do mapping <- getThingVersionMap
123 case addThingVersion mapping "ghc" ghcVersion of
125 case addThingVersion m thing thingVersion of
127 do putThingVersionMap m'
128 return [FP "libHS", FP thing, FP "-", VersionOf thing,
129 FP "-ghc", VersionOf "ghc", FP ".so"]
132 | Just [way, thingVersion, _]
133 <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.so$")
135 = do mapping <- getThingVersionMap
136 case addThingVersion mapping "ghc" thingVersion of
138 do putThingVersionMap mapping'
139 return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
142 | Just [thing, thingVersion, _, way]
143 <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
145 = do mapping <- getThingVersionMap
146 case addThingVersion mapping thing thingVersion of
148 do putThingVersionMap mapping'
149 return [FP "libHS", FP thing, FP "-", VersionOf thing,
152 | Just [thing, thingVersion, _]
153 <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
155 = do mapping <- getThingVersionMap
156 case addThingVersion mapping thing thingVersion of
158 do putThingVersionMap mapping'
159 return [FP "HS", FP thing, FP "-", VersionOf thing,
162 | Just [dashedWays, depType]
163 <- re "^\\.depend-(.*)\\.(haskell|c_asm)"
166 if unSepList '-' dashedWays == ways
167 then return [FP ".depend-", Ways, FP ".", FP depType]
169 | otherwise = unchanged
170 where unchanged = return [FP filename]
172 compareContent :: Ways -> [(FilenameDescr, TarLine)]
173 -> Ways -> [(FilenameDescr, TarLine)]
175 compareContent _ [] _ [] = []
176 compareContent _ xs _ [] = map (First . ExtraFile . tlFileName . snd) xs
177 compareContent _ [] _ ys = map (Second . ExtraFile . tlFileName . snd) ys
178 compareContent ways1 xs1 ways2 xs2
181 (xs, []) -> concatMap (mkExtraFile ways1 First . tlFileName . snd) xs
182 ([], ys) -> concatMap (mkExtraFile ways2 Second . tlFileName . snd) ys
183 ((fd1, tl1) : xs1', (fd2, tl2) : xs2') ->
184 case fd1 `compare` fd2 of
185 EQ -> map Change (compareTarLine tl1 tl2)
186 ++ compareContent ways1 xs1' ways2 xs2'
187 LT -> mkExtraFile ways1 First (tlFileName tl1)
188 ++ compareContent ways1 xs1' ways2 xs2
189 GT -> mkExtraFile ways2 Second (tlFileName tl2)
190 ++ compareContent ways1 xs1 ways2 xs2'
191 where mkExtraFile ways mkFileProblem filename
192 = case findFileWay filename of
194 | way `elem` ways -> []
195 _ -> [mkFileProblem (ExtraFile filename)]
197 findFileWay :: FilePath -> Maybe String
199 | Just [way] <- re "\\.([a-z_]+)_hi$" fp
201 | otherwise = Nothing
203 compareTarLine :: TarLine -> TarLine -> [Problem]
204 compareTarLine tl1 tl2
205 = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
206 ++ [ FileSizeChanged fn1 fn2 size1 size2 | sizeChanged ]
207 where fn1 = tlFileName tl1
209 perms1 = tlPermissions tl1
210 perms2 = tlPermissions tl2
213 sizeChanged = abs (size1 - size2) > sizeAbs
214 && (((100 * size1) `div` size2) > sizePercentage ||
215 ((100 * size2) `div` size1) > sizePercentage)
218 versionRE = "([0-9]+(\\.[0-9]+)*)"