bindist comparison tool: Some logic improvements, and testsuite support

3 files changed, 59 insertions, 62 deletions

diff --git a/distrib/compare/BuildInfo.hs b/distrib/compare/BuildInfo.hs
index d71eeb4777..1101bf450d 100644
--- a/distrib/compare/BuildInfo.hs
+++ b/distrib/compare/BuildInfo.hs
@@ -8,7 +8,7 @@ type BIMonad = StateT BuildInfo Maybe
 data BuildInfo = BuildInfo {
                      biThingVersionMap :: ThingVersionMap,
                      biThingHashMap :: ThingHashMap,
-                     biWays :: Ways
+                     biMaybeWays :: Maybe Ways
                  }
     deriving Show
 
@@ -22,12 +22,12 @@ type ThingHashMap = ThingMap
 -- ["v", "p", "dyn"] => we have ".depend-v-p-dyn.haskell" files
 type Ways = [String]
 
-emptyBuildInfo :: Ways -> BuildInfo
-emptyBuildInfo ways = BuildInfo {
-                          biThingVersionMap = [],
-                          biThingHashMap = [],
-                          biWays = ways
-                      }
+emptyBuildInfo :: Maybe Ways -> BuildInfo
+emptyBuildInfo mWays = BuildInfo {
+                           biThingVersionMap = [],
+                           biThingHashMap = [],
+                           biMaybeWays = mWays
+                       }
 
 addThingMap :: ThingMap -> String -> String -> Maybe ThingMap
 addThingMap mapping thing str
@@ -39,9 +39,9 @@ addThingMap mapping thing str
    Nothing ->
        Just ((thing, str) : mapping)
 
-getWays :: BIMonad Ways
-getWays = do st <- get
-             return $ biWays st
+getMaybeWays :: BIMonad (Maybe Ways)
+getMaybeWays = do st <- get
+                  return $ biMaybeWays st
 
 haveThingVersion :: String -> String -> BIMonad ()
 haveThingVersion thing thingVersion
@@ -57,7 +57,3 @@ haveThingHash thing thingHash
           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/FilenameDescr.hs b/distrib/compare/FilenameDescr.hs
index c1a85954e6..d21745cd26 100644
--- a/distrib/compare/FilenameDescr.hs
+++ b/distrib/compare/FilenameDescr.hs
@@ -50,5 +50,7 @@ flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of
            = 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
+          f Ways = case biMaybeWays buildInfo of
+                   Just ways -> Right $ intercalate "-" ways
+                   Nothing   -> Left ["Can't happen: No ways, but Ways is used"]
 
diff --git a/distrib/compare/compare.hs b/distrib/compare/compare.hs
index d1a8ac7fdd..0e0e9f8306 100644
--- a/distrib/compare/compare.hs
+++ b/distrib/compare/compare.hs
@@ -33,39 +33,41 @@ main = do args <- getArgs
 
 doit :: Bool -> FilePath -> FilePath -> IO ()
 doit ignoreSizeChanges bd1 bd2
- = do let windows = any ("mingw" `isPrefixOf`) (tails bd1)
-      tls1 <- readTarLines bd1
+ = do tls1 <- readTarLines bd1
       tls2 <- readTarLines bd2
-      -- If it looks like we have a Windows "bindist" then just
-      -- set ways to [] for now.
-      ways1 <- if windows then return []
-                          else dieOnErrors $ findWays tls1
-      ways2 <- if windows then return []
-                          else dieOnErrors $ findWays tls2
-      (content1, tvm1) <- dieOnErrors $ mkContents ways1 tls1
-      (content2, tvm2) <- dieOnErrors $ mkContents ways2 tls2
+      let mWays1 = findWays tls1
+          mWays2 = findWays tls2
+      wayDifferences <- case (mWays1, mWays2) of
+                        (Nothing, Nothing) ->
+                            return []
+                        (Just ways1, Just ways2) ->
+                            return $ diffWays ways1 ways2
+                        _ ->
+                            die ["One input has ways, but the other doesn't"]
+      (content1, tvm1) <- dieOnErrors $ mkContents mWays1 tls1
+      (content2, tvm2) <- dieOnErrors $ mkContents mWays2 tls2
       let sortedContent1 = sortByFst content1
           sortedContent2 = sortByFst content2
           (nubProbs1, nubbedContent1) = nubContents sortedContent1
           (nubProbs2, nubbedContent2) = nubContents sortedContent2
-          differences = compareContent ways1 nubbedContent1
-                                       ways2 nubbedContent2
+          differences = compareContent mWays1 nubbedContent1
+                                       mWays2 nubbedContent2
           allProbs = map First nubProbs1 ++ map Second nubProbs2
                   ++ diffThingVersionMap tvm1 tvm2
-                  ++ diffWays ways1 ways2
+                  ++ wayDifferences
                   ++ differences
           wantedProbs = if ignoreSizeChanges
                         then filter (not . isSizeChange) allProbs
                         else allProbs
       mapM_ (putStrLn . pprFileChange) wantedProbs
 
-findWays :: [TarLine] -> Either Errors Ways
-findWays = foldr f (Left ["Couldn't find ways"])
-    where f tl res = case re regex (tlFileName tl) of
-                     Just [dashedWays] ->
-                         Right (unSepList '-' dashedWays)
-                     _ ->
-                         res
+-- *nix bindists have ways.
+-- Windows "bindists", install trees, and testsuites don't.
+findWays :: [TarLine] -> Maybe Ways
+findWays tls = msum $ map f tls
+    where f tl = case re regex (tlFileName tl) of
+                 Just [dashedWays] -> Just (unSepList '-' dashedWays)
+                 _                 -> Nothing
           regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell"
 
 diffWays :: Ways -> Ways -> [FileChange]
@@ -93,10 +95,10 @@ diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2)
                                  else [Change (ThingVersionChanged xt xv yv)]
                       in this ++ f xs' ys'
 
-mkContents :: Ways -> [TarLine]
+mkContents :: Maybe Ways -> [TarLine]
            -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap)
-mkContents ways tls
-    = case runStateT (mapM f tls) (emptyBuildInfo ways) of
+mkContents mWays tls
+    = case runStateT (mapM f tls) (emptyBuildInfo mWays) of
       Nothing -> Left ["Can't happen: mkContents: Nothing"]
       Just (xs, finalBuildInfo) ->
           case concat $ map (checkContent finalBuildInfo) xs of
@@ -211,36 +213,33 @@ mkFileNameDescr filename
  | Just [dashedWays, depType]
        <- re "^\\.depend-(.*)\\.(haskell|c_asm)"
              filename
-    = do ways <- getWays
-         if unSepList '-' dashedWays == ways
+    = do mWays <- getMaybeWays
+         if Just (unSepList '-' dashedWays) == mWays
              then return [FP ".depend-", Ways, FP ".", FP depType]
              else unchanged
  | otherwise = unchanged
     where unchanged = return [FP filename]
 
-compareContent :: Ways -> [(FilenameDescr, TarLine)]
-               -> Ways -> [(FilenameDescr, TarLine)]
+compareContent :: Maybe Ways -> [(FilenameDescr, TarLine)]
+               -> Maybe Ways -> [(FilenameDescr, TarLine)]
                -> [FileChange]
-compareContent _ [] _ [] = []
-compareContent _ xs _ [] = map (First  . ExtraFile . tlFileName . snd) xs
-compareContent _ [] _ ys = map (Second . ExtraFile . tlFileName . snd) ys
-compareContent ways1 xs1 ways2 xs2
-    = case (xs1, xs2) of
-      ([], []) -> []
-      (xs, []) -> concatMap (mkExtraFile ways1 First  . tlFileName . snd) xs
-      ([], ys) -> concatMap (mkExtraFile ways2 Second . tlFileName . snd) ys
-      ((fd1, tl1) : xs1', (fd2, tl2) : xs2') ->
-          case fd1 `compare` fd2 of
-          EQ -> map Change (compareTarLine tl1 tl2)
-             ++ compareContent ways1 xs1' ways2 xs2'
-          LT -> mkExtraFile ways1 First  (tlFileName tl1)
-             ++ compareContent ways1 xs1' ways2 xs2
-          GT -> mkExtraFile ways2 Second (tlFileName tl2)
-             ++ compareContent ways1 xs1 ways2 xs2'
-    where mkExtraFile ways mkFileChange filename
-              = case findFileWay filename of
-                Just way
-                 | way `elem` ways -> []
+compareContent mWays1 xs1all mWays2 xs2all
+ = f xs1all xs2all
+    where f [] [] = []
+          f xs [] = concatMap (mkExtraFile mWays1 mWays2 First  . tlFileName . snd) xs
+          f [] ys = concatMap (mkExtraFile mWays2 mWays1 Second . tlFileName . snd) ys
+          f xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2')
+           = case fd1 `compare` fd2 of
+             EQ -> map Change (compareTarLine tl1 tl2)
+                ++ f xs1' xs2'
+             LT -> mkExtraFile mWays1 mWays2 First  (tlFileName tl1)
+                ++ f xs1' xs2
+             GT -> mkExtraFile mWays2 mWays1 Second (tlFileName tl2)
+                ++ f xs1 xs2'
+          mkExtraFile mWaysMe mWaysThem mkFileChange filename
+              = case (findFileWay filename, mWaysMe, mWaysThem) of
+                (Just way, Just waysMe, Just waysThem)
+                 | (way `elem` waysMe) && not (way `elem` waysThem) -> []
                 _                  -> [mkFileChange (ExtraFile filename)]
 
 findFileWay :: FilePath -> Maybe String