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 ec7e8409a8e..f368875aecd 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 639b93bd9be..34bfcde763c 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 00000000000..5a948b896f7
--- /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 00000000000..ac9ef6ce031
--- /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 00000000000..1c68e7563f9
--- /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
--
GitLab