Add tools to test that cleaning works properly

[ghc-hetmet.git] / utils / testremove / checkremove.hs

diff --git a/utils/testremove/checkremove.hs b/utils/testremove/checkremove.hs
new file mode 100644 (file)
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)
+