bindist checker improvements

* Some refactoring
* Support for Windows filenames
* Some support for installed trees (as Windows "bindists" are really
  install trees)

6 files changed, 204 insertions, 122 deletions

diff --git a/distrib/compare/BuildInfo.hs b/distrib/compare/BuildInfo.hs
index 547e5ac853..d71eeb4777 100644
--- a/distrib/compare/BuildInfo.hs
+++ b/distrib/compare/BuildInfo.hs
@@ -3,39 +3,61 @@ module BuildInfo where
 
 import Control.Monad.State
 
+type BIMonad = StateT BuildInfo Maybe
+
 data BuildInfo = BuildInfo {
                      biThingVersionMap :: ThingVersionMap,
+                     biThingHashMap :: ThingHashMap,
                      biWays :: Ways
                  }
+    deriving Show
+
+type ThingMap = [(String, String)]
 -- Mapping from thing (e.g. "Cabal") to version (e.g. "1.10.0.0")
-type ThingVersionMap = [(String, String)]
+type ThingVersionMap = ThingMap
+-- Mapping from thing (e.g. "Cabal") to ABI hash
+-- (e.g. "e1f7c380581d61d42b0360d440cc35ed")
+type ThingHashMap = ThingMap
 -- The list of ways in the order the build system uses them, e.g.
 -- ["v", "p", "dyn"] => we have ".depend-v-p-dyn.haskell" files
 type Ways = [String]
 
-addThingVersion :: ThingVersionMap -> String -> String -> Maybe ThingVersionMap
-addThingVersion mapping thing version
+emptyBuildInfo :: Ways -> BuildInfo
+emptyBuildInfo ways = BuildInfo {
+                          biThingVersionMap = [],
+                          biThingHashMap = [],
+                          biWays = ways
+                      }
+
+addThingMap :: ThingMap -> String -> String -> Maybe ThingMap
+addThingMap mapping thing str
  = case lookup thing mapping of
-   Just version' ->
-       if version == version'
+   Just str' ->
+       if str == str'
        then Just mapping
        else Nothing
    Nothing ->
-       Just ((thing, version) : mapping)
+       Just ((thing, str) : mapping)
 
-getThingVersionMap :: State BuildInfo ThingVersionMap
-getThingVersionMap = do st <- get
-                        return $ biThingVersionMap st
-
-getWays :: State BuildInfo Ways
+getWays :: BIMonad Ways
 getWays = do st <- get
              return $ biWays st
 
-putThingVersionMap :: ThingVersionMap -> State BuildInfo ()
-putThingVersionMap tm = do st <- get
-                           put $ st { biThingVersionMap = tm }
-
-putWays :: Ways -> State BuildInfo ()
+haveThingVersion :: String -> String -> BIMonad ()
+haveThingVersion thing thingVersion
+ = do st <- get
+      case addThingMap (biThingVersionMap st) thing thingVersion of
+          Nothing  -> fail "Inconsistent version"
+          Just tvm -> put $ st { biThingVersionMap = tvm }
+
+haveThingHash :: String -> String -> BIMonad ()
+haveThingHash thing thingHash
+ = do st <- get
+      case addThingMap (biThingHashMap st) thing thingHash of
+          Nothing  -> fail "Inconsistent hash"
+          Just thm -> put $ st { biThingHashMap = thm }
+
+putWays :: Ways -> BIMonad ()
 putWays ws = do st <- get
                 put $ st { biWays = ws }
 
diff --git a/distrib/compare/Change.hs b/distrib/compare/Change.hs
new file mode 100644
index 0000000000..a89517ceb5
--- /dev/null
+++ b/distrib/compare/Change.hs
@@ -0,0 +1,43 @@
+
+module Change where
+
+data FileChange = First  Change
+                | Second Change
+                | Change Change
+
+data Change = DuplicateFile FilePath
+            | ExtraFile FilePath
+            | ExtraWay String
+            | ExtraThing String
+            | ThingVersionChanged String String String
+            | PermissionsChanged FilePath FilePath String String
+            | FileSizeChanged FilePath FilePath Integer Integer
+
+isSizeChange :: FileChange -> Bool
+isSizeChange (Change (FileSizeChanged {})) = True
+isSizeChange _ = False
+
+pprFileChange :: FileChange -> String
+pprFileChange (First  p) = "First  " ++ pprChange p
+pprFileChange (Second p) = "Second " ++ pprChange p
+pprFileChange (Change p) = "Change " ++ pprChange p
+
+pprChange :: Change -> String
+pprChange (DuplicateFile fp) = "Duplicate file: " ++ show fp
+pprChange (ExtraFile fp) = "Extra file: " ++ show fp
+pprChange (ExtraWay w) = "Extra way: " ++ show w
+pprChange (ExtraThing t) = "Extra thing: " ++ show t
+pprChange (ThingVersionChanged t v1 v2)
+    = "Version changed for " ++ show t ++ ":\n"
+   ++ "    " ++ v1 ++ "  ->  " ++ v2
+pprChange (PermissionsChanged fp1 fp2 p1 p2)
+    = "Permissions changed:\n"
+   ++ "    " ++ show fp1
+   ++ "    " ++ show fp2
+   ++ "    " ++ p1 ++ "  ->  " ++ p2
+pprChange (FileSizeChanged fp1 fp2 s1 s2)
+    = "Size changed:\n"
+   ++ "    " ++ show fp1 ++ "\n"
+   ++ "    " ++ show fp2 ++ "\n"
+   ++ "    " ++ show s1 ++ "  ->  " ++ show s2
+
diff --git a/distrib/compare/FilenameDescr.hs b/distrib/compare/FilenameDescr.hs
index 4b5898e990..c1a85954e6 100644
--- a/distrib/compare/FilenameDescr.hs
+++ b/distrib/compare/FilenameDescr.hs
@@ -13,6 +13,7 @@ import Tar
 -- abstracts out the version numbers.
 type FilenameDescr = [FilenameDescrBit]
 data FilenameDescrBit = VersionOf String
+                      | HashOf String
                       | FP String
                       | Ways
     deriving (Show, Eq, Ord)
@@ -45,5 +46,9 @@ flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of
            = case lookup thing (biThingVersionMap buildInfo) of
              Just v -> Right v
              Nothing -> Left ["Can't happen: thing has no version in mapping"]
+          f (HashOf thing)
+           = case lookup thing (biThingHashMap buildInfo) of
+             Just v -> Right v
+             Nothing -> Left ["Can't happen: thing has no hash in mapping"]
           f Ways = Right $ intercalate "-" $ biWays buildInfo
 
diff --git a/distrib/compare/Problem.hs b/distrib/compare/Problem.hs
deleted file mode 100644
index 7854bc5f7d..0000000000
--- a/distrib/compare/Problem.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-
-module Problem where
-
-data FileProblem = First  Problem
-                 | Second Problem
-                 | Change Problem
-
-data Problem = DuplicateFile FilePath
-             | ExtraFile FilePath
-             | ExtraWay String
-             | PermissionsChanged FilePath FilePath String String
-             | FileSizeChanged FilePath FilePath Integer Integer
-
-isSizeChange :: FileProblem -> Bool
-isSizeChange (Change (FileSizeChanged {})) = True
-isSizeChange _ = False
-
-pprFileProblem :: FileProblem -> String
-pprFileProblem (First  p) = "First  " ++ pprProblem p
-pprFileProblem (Second p) = "Second " ++ pprProblem p
-pprFileProblem (Change p) = "Change " ++ pprProblem p
-
-pprProblem :: Problem -> String
-pprProblem (DuplicateFile fp) = "Duplicate file: " ++ show fp
-pprProblem (ExtraFile fp) = "Extra file: " ++ show fp
-pprProblem (ExtraWay w) = "Extra way: " ++ show w
-pprProblem (PermissionsChanged fp1 fp2 p1 p2)
-    = "Permissions changed:\n"
-   ++ "    " ++ show fp1
-   ++ "    " ++ show fp2
-   ++ "    " ++ p1 ++ "  ->  " ++ p2
-pprProblem (FileSizeChanged fp1 fp2 s1 s2)
-    = "Size changed:\n"
-   ++ "    " ++ show fp1 ++ "\n"
-   ++ "    " ++ show fp2 ++ "\n"
-   ++ "    " ++ show s1 ++ "  ->  " ++ show s2
-
diff --git a/distrib/compare/Utils.hs b/distrib/compare/Utils.hs
index d5fb8cb442..e2da6b55fa 100644
--- a/distrib/compare/Utils.hs
+++ b/distrib/compare/Utils.hs
@@ -1,6 +1,8 @@
 
 module Utils where
 
+import Data.Function
+import Data.List
 import System.Exit
 import System.IO
 import Text.Regex.Posix
@@ -33,3 +35,6 @@ unSepList x xs = case break (x ==) xs of
                  (this, []) ->
                      [this]
 
+sortByFst :: Ord a => [(a, b)] -> [(a, b)]
+sortByFst = sortBy (compare `on` fst)
+
diff --git a/distrib/compare/compare.hs b/distrib/compare/compare.hs
index 8daa773c40..1fa2c739af 100644
--- a/distrib/compare/compare.hs
+++ b/distrib/compare/compare.hs
@@ -3,13 +3,12 @@
 module Main (main) where
 
 import Control.Monad.State
-import Data.Function
 import Data.List
 import System.Environment
 
 import BuildInfo
 import FilenameDescr
-import Problem
+import Change
 import Utils
 import Tar
 
@@ -43,22 +42,22 @@ doit ignoreSizeChanges bd1 bd2
                           else dieOnErrors $ findWays tls1
       ways2 <- if windows then return []
                           else dieOnErrors $ findWays tls2
-      content1 <- dieOnErrors $ mkContents ways1 tls1
-      content2 <- dieOnErrors $ mkContents ways2 tls2
-      let mySort = sortBy (compare `on` fst)
-          sortedContent1 = mySort content1
-          sortedContent2 = mySort content2
+      (content1, tvm1) <- dieOnErrors $ mkContents ways1 tls1
+      (content2, tvm2) <- dieOnErrors $ mkContents ways2 tls2
+      let sortedContent1 = sortByFst content1
+          sortedContent2 = sortByFst content2
           (nubProbs1, nubbedContent1) = nubContents sortedContent1
           (nubProbs2, nubbedContent2) = nubContents sortedContent2
           differences = compareContent ways1 nubbedContent1
                                        ways2 nubbedContent2
           allProbs = map First nubProbs1 ++ map Second nubProbs2
+                  ++ diffThingVersionMap tvm1 tvm2
                   ++ diffWays ways1 ways2
                   ++ differences
           wantedProbs = if ignoreSizeChanges
                         then filter (not . isSizeChange) allProbs
                         else allProbs
-      mapM_ (putStrLn . pprFileProblem) wantedProbs
+      mapM_ (putStrLn . pprFileChange) wantedProbs
 
 findWays :: [TarLine] -> Either Errors Ways
 findWays = foldr f (Left ["Couldn't find ways"])
@@ -69,33 +68,45 @@ findWays = foldr f (Left ["Couldn't find ways"])
                          res
           regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"
 
-diffWays :: Ways -> Ways -> [FileProblem]
+diffWays :: Ways -> Ways -> [FileChange]
 diffWays ws1 ws2 = f (sort ws1) (sort ws2)
     where f [] [] = []
-          f xs [] = map (First . ExtraWay) xs
-          f [] ys = map (First . ExtraWay) ys
+          f xs [] = map (First  . ExtraWay) xs
+          f [] ys = map (Second . ExtraWay) ys
           f xs@(x : xs') ys@(y : ys')
               = case x `compare` y of
                 LT -> First  (ExtraWay x) : f xs' ys
                 GT -> Second (ExtraWay y) : f xs  ys'
                 EQ ->                       f xs' ys'
 
-mkContents :: Ways -> [TarLine] -> Either Errors [(FilenameDescr, TarLine)]
+diffThingVersionMap :: ThingVersionMap -> ThingVersionMap -> [FileChange]
+diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2)
+    where f [] [] = []
+          f xs [] = map (First  . ExtraThing . fst) xs
+          f [] ys = map (Second . ExtraThing . fst) ys
+          f xs@((xt, xv) : xs') ys@((yt, yv) : ys')
+              = case xt `compare` yt of
+                LT -> First  (ExtraThing xt) : f xs' ys
+                GT -> Second (ExtraThing yt) : f xs  ys'
+                EQ -> let this = if xv == yv
+                                 then []
+                                 else [Change (ThingVersionChanged xt xv yv)]
+                      in this ++ f xs' ys'
+
+mkContents :: Ways -> [TarLine]
+           -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap)
 mkContents ways tls
-    = case runState (mapM f tls) initialBuildInfo of
-      (xs, finalBuildInfo) ->
+    = case runStateT (mapM f tls) (emptyBuildInfo ways) of
+      Nothing -> Left ["Can't happen: mkContents: Nothing"]
+      Just (xs, finalBuildInfo) ->
           case concat $ map (checkContent finalBuildInfo) xs of
-          []   -> Right xs
+          []   -> Right (xs, biThingVersionMap finalBuildInfo)
           errs -> Left errs
     where f tl = do fnd <- mkFilePathDescr (tlFileName tl)
                     return (fnd, tl)
-          initialBuildInfo = BuildInfo {
-                                 biThingVersionMap = [],
-                                 biWays = ways
-                             }
 
 nubContents :: [(FilenameDescr, TarLine)]
-            -> ([Problem], [(FilenameDescr, TarLine)])
+            -> ([Change], [(FilenameDescr, TarLine)])
 nubContents [] = ([], [])
 nubContents [x] = ([], [x])
 nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
@@ -103,67 +114,100 @@ nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _))
  | otherwise  = (ps, x1 : xs')
     where (ps, xs') = nubContents xs
 
-mkFilePathDescr :: FilePath -> State BuildInfo FilenameDescr
+mkFilePathDescr :: FilePath -> BIMonad FilenameDescr
 mkFilePathDescr fp
  | Just [ghcVersion, _, middle, filename]
      <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp
-    = do ghcVersionDescr <- do mapping <- getThingVersionMap
-                               case addThingVersion mapping "ghc" ghcVersion of
-                                   Just mapping' ->
-                                       do putThingVersionMap mapping'
-                                          return (VersionOf "ghc")
-                                   Nothing ->
-                                       return (FP ghcVersion)
+    = do haveThingVersion "ghc" ghcVersion
+         middle' <- mkMiddleDescr middle
          filename' <- mkFileNameDescr filename
-         let fd = FP "ghc-" : ghcVersionDescr : FP middle : FP "/" : filename'
+         let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename'
          return $ normalise fd
  | otherwise = return [FP fp]
 
-mkFileNameDescr :: FilePath -> State BuildInfo FilenameDescr
+mkMiddleDescr :: FilePath -> BIMonad FilenameDescr
+mkMiddleDescr middle
+ -- haddock docs in a Windows installed tree
+ | Just [thing, thingVersion, _, src]
+       <- re ("^/doc/html/libraries/([^/]*)-" ++ versionRE ++ "(/src)?$")
+             middle
+    = do haveThingVersion thing thingVersion
+         return [FP "/doc/html/libraries/",
+                 FP thing, FP "-", VersionOf thing, FP src]
+      `mplus` unchanged
+ -- libraries in a Windows installed tree
+ | Just [thing, thingVersion, _, rest]
+       <- re ("^/lib/([^/]*)-" ++ versionRE ++ "(/.*)?$")
+             middle
+    = do haveThingVersion thing thingVersion
+         return [FP "/lib/", FP thing, FP "-", VersionOf thing, FP rest]
+      `mplus` unchanged
+ -- Windows in-tree gcc
+ | Just [prefix, _, _, gccVersion, _, rest]
+       <- re ("^(/mingw/(lib(exec)?/gcc/mingw32/|share/gcc-))" ++ versionRE ++ "(/.*)?$")
+             middle
+    = do haveThingVersion "gcc" gccVersion
+         return [FP prefix, VersionOf "gcc", FP rest]
+      `mplus` unchanged
+ | otherwise = unchanged
+    where unchanged = return [FP middle]
+
+mkFileNameDescr :: FilePath -> BIMonad FilenameDescr
 mkFileNameDescr filename
- | Just [thing, thingVersion, _, ghcVersion, _]
-       <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.so$")
+ | Just [prog, ghcVersion, _, exe]
+       <- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$")
              filename
-    = do mapping <- getThingVersionMap
-         case addThingVersion mapping "ghc" ghcVersion of
-             Just m ->
-                 case addThingVersion m thing thingVersion of
-                 Just m' ->
-                     do putThingVersionMap m'
-                        return [FP "libHS", FP thing, FP "-", VersionOf thing,
-                                FP "-ghc", VersionOf "ghc", FP ".so"]
-                 _ -> unchanged
-             _ -> unchanged
- | Just [way, thingVersion, _]
-       <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.so$")
+    = do haveThingVersion "ghc" ghcVersion
+         return [FP prog, FP "-", VersionOf "ghc", FP exe]
+      `mplus` unchanged
+ | Just [thing, thingVersion, _, ghcVersion, _, soDll]
+       <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.(so|dll)$")
              filename
-    = do mapping <- getThingVersionMap
-         case addThingVersion mapping "ghc" thingVersion of
-             Just mapping' ->
-                 do putThingVersionMap mapping'
-                    return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
-                            FP ".so"]
-             _ -> unchanged
+    = do haveThingVersion "ghc" ghcVersion
+         haveThingVersion thing thingVersion
+         return [FP "libHS", FP thing, FP "-", VersionOf thing,
+                 FP "-ghc", VersionOf "ghc", FP ".", FP soDll]
+      `mplus` unchanged
+ | Just [way, thingVersion, _, soDll]
+       <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.(so|dll)$")
+             filename
+    = do haveThingVersion "ghc" thingVersion
+         return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc",
+                 FP ".", FP soDll]
+      `mplus` unchanged
+ | Just [thingVersion, _, soDll]
+       <- re ("^libHSffi-ghc" ++ versionRE ++ "\\.(so|dll)$")
+             filename
+    = do haveThingVersion "ghc" thingVersion
+         return [FP "libHSffi-ghc", VersionOf "ghc", FP ".", FP soDll]
+      `mplus` unchanged
  | Just [thing, thingVersion, _, way]
        <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$")
              filename
-    = do mapping <- getThingVersionMap
-         case addThingVersion mapping thing thingVersion of
-             Just mapping' ->
-                 do putThingVersionMap mapping'
-                    return [FP "libHS", FP thing, FP "-", VersionOf thing,
-                            FP way, FP ".a"]
-             _ -> unchanged
+    = do haveThingVersion thing thingVersion
+         return [FP "libHS", FP thing, FP "-", VersionOf thing,
+                 FP way, FP ".a"]
+      `mplus` unchanged
  | Just [thing, thingVersion, _]
        <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$")
              filename
-    = do mapping <- getThingVersionMap
-         case addThingVersion mapping thing thingVersion of
-             Just mapping' ->
-                 do putThingVersionMap mapping'
-                    return [FP "HS", FP thing, FP "-", VersionOf thing,
-                            FP ".o"]
-             _ -> unchanged
+    = do haveThingVersion thing thingVersion
+         return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"]
+      `mplus` unchanged
+ | Just [thing, thingVersion, _, thingHash]
+       <- re ("^(.*)-" ++ versionRE ++ "-([0-9a-f]{32})\\.conf$")
+             filename
+    = do haveThingVersion thing thingVersion
+         haveThingHash    thing thingHash
+         return [FP thing, FP "-", VersionOf thing, FP "-", HashOf thing,
+                 FP ".conf"]
+      `mplus` unchanged
+ | Just [thingVersion, _]
+       <- re ("^mingw32-gcc-" ++ versionRE ++ "\\.exe$")
+             filename
+    = do haveThingVersion "gcc" thingVersion
+         return [FP "mingw32-gcc-", VersionOf "gcc", FP ".exe"]
+      `mplus` unchanged
  | Just [dashedWays, depType]
        <- re "^\\.depend-(.*)\\.(haskell|c_asm)"
              filename
@@ -176,7 +220,7 @@ mkFileNameDescr filename
 
 compareContent :: Ways -> [(FilenameDescr, TarLine)]
                -> Ways -> [(FilenameDescr, TarLine)]
-               -> [FileProblem]
+               -> [FileChange]
 compareContent _ [] _ [] = []
 compareContent _ xs _ [] = map (First  . ExtraFile . tlFileName . snd) xs
 compareContent _ [] _ ys = map (Second . ExtraFile . tlFileName . snd) ys
@@ -193,11 +237,11 @@ compareContent ways1 xs1 ways2 xs2
              ++ compareContent ways1 xs1' ways2 xs2
           GT -> mkExtraFile ways2 Second (tlFileName tl2)
              ++ compareContent ways1 xs1 ways2 xs2'
-    where mkExtraFile ways mkFileProblem filename
+    where mkExtraFile ways mkFileChange filename
               = case findFileWay filename of
                 Just way
                  | way `elem` ways -> []
-                _                  -> [mkFileProblem (ExtraFile filename)]
+                _                  -> [mkFileChange (ExtraFile filename)]
 
 findFileWay :: FilePath -> Maybe String
 findFileWay fp
@@ -207,7 +251,7 @@ findFileWay fp
     = Just way
  | otherwise = Nothing
 
-compareTarLine :: TarLine -> TarLine -> [Problem]
+compareTarLine :: TarLine -> TarLine -> [Change]
 compareTarLine tl1 tl2
     = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ]
    ++ [ FileSizeChanged    fn1 fn2 size1  size2  | sizeChanged ]