From cabb1ad4f8c7e48694ff17fbedd94e9bcf86d565 Mon Sep 17 00:00:00 2001
From: Ian Lynagh <igloo@earth.li>
Date: Sat, 8 May 2010 19:41:05 +0000
Subject: [PATCH] Add tools to test that cleaning works properly

---
 ghc.mk                          |    1 +
 mk/tree.mk                      |    2 +-
 utils/testremove/checkremove.hs |   43 +++++++++++++++++++++++++++++++++++++++
 utils/testremove/ghc.mk         |    9 ++++++++
 utils/testremove/wouldrm.hs     |   16 +++++++++++++++
 5 files changed, 70 insertions(+), 1 deletion(-)
 create mode 100644 utils/testremove/checkremove.hs
 create mode 100644 utils/testremove/ghc.mk
 create mode 100644 utils/testremove/wouldrm.hs

diff --git a/ghc.mk b/ghc.mk
index ec7e840..f368875 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -549,6 +549,7 @@ BUILD_DIRS += \
    compiler \
    $(GHC_HSC2HS_DIR) \
    $(GHC_PKG_DIR) \
+   utils/testremove \
    utils/ghctags \
    utils/hpc \
    utils/runghc \
diff --git a/mk/tree.mk b/mk/tree.mk
index 639b93b..34bfcde 100644
--- a/mk/tree.mk
+++ b/mk/tree.mk
@@ -51,7 +51,7 @@ INPLACE_PERL            = $(INPLACE)/perl
 # unconfigured tree so that the various clean targets can be used
 # without configuring:
 ifeq "$(ONLY_SHOW_CLEANS)" "YES"
-RM = echo
+RM = utils/testremove/wouldrm
 RM_OPTS = CLEAN_FILES
 RM_OPTS_REC = CLEAN_REC
 else
diff --git a/utils/testremove/checkremove.hs b/utils/testremove/checkremove.hs
new file mode 100644
index 0000000..5a948b8
--- /dev/null
+++ b/utils/testremove/checkremove.hs
@@ -0,0 +1,43 @@
+
+module Main (main) where
+
+import Control.Monad
+import Data.List
+import System.Environment
+import System.Exit
+import System.FilePath
+import System.IO
+
+data CleanWhat = CleanFile FilePath
+               | CleanRec  FilePath
+    deriving (Read, Show)
+
+main :: IO ()
+main = do args <- getArgs
+          case args of
+              [contentsBeforeFile, contentsAfterFile, wouldBeCleanedFile] ->
+                  doit contentsBeforeFile contentsAfterFile wouldBeCleanedFile
+              _ ->
+                  error "Bad args"
+
+doit :: FilePath -> FilePath -> FilePath -> IO ()
+doit contentsBeforeFile contentsAfterFile wouldBeCleanedFile
+ = do contentsBefore <- liftM lines $ readFile contentsBeforeFile
+      contentsAfter  <- liftM lines $ readFile contentsAfterFile
+      wouldBeCleaned <- liftM (map read . lines) $ readFile wouldBeCleanedFile
+      let newContentsAfter = contentsAfter \\ contentsBefore
+      let cleanedAfter = simulateCleans newContentsAfter wouldBeCleaned
+      unless (null cleanedAfter) $ do
+          hPutStrLn stderr "Files not cleaned:"
+          mapM_ (hPutStrLn stderr . show) cleanedAfter
+          exitWith (ExitFailure 1)
+
+simulateCleans :: [FilePath] -> [CleanWhat] -> [FilePath]
+simulateCleans fs cws = filter (not . cleaned) fs
+    where cleaned f = any (`willClean` f) cws
+
+willClean :: CleanWhat -> FilePath -> Bool
+CleanFile fp `willClean` f = fp `equalFilePath` f
+CleanRec fp `willClean` f
+    = any (fp `equalFilePath`) (map joinPath $ inits $ splitPath f)
+
diff --git a/utils/testremove/ghc.mk b/utils/testremove/ghc.mk
new file mode 100644
index 0000000..ac9ef6c
--- /dev/null
+++ b/utils/testremove/ghc.mk
@@ -0,0 +1,9 @@
+
+.PHONY: utils/testremove_all
+utils/testremove_all: utils/testremove/wouldrm utils/testremove/checkremove
+
+utils/testremove/wouldrm: $$@.hs
+	$(GHC_STAGE1) --make -O $@
+
+utils/testremove/checkremove: $$@.hs
+	$(GHC_STAGE1) --make -O $@
diff --git a/utils/testremove/wouldrm.hs b/utils/testremove/wouldrm.hs
new file mode 100644
index 0000000..1c68e75
--- /dev/null
+++ b/utils/testremove/wouldrm.hs
@@ -0,0 +1,16 @@
+
+module Main (main) where
+
+import System.Environment
+
+data CleanWhat = CleanFile FilePath
+               | CleanRec  FilePath
+    deriving (Read, Show)
+
+main :: IO ()
+main = do args <- getArgs
+          ls <- case args of
+                "CLEAN_FILES" : files -> return $ map CleanFile files
+                "CLEAN_REC"   : dirs  -> return $ map CleanRec dirs
+                _ -> error "Bad args"
+          appendFile "would-be-cleaned" $ unlines $ map show ls
-- 
1.7.10.4