utils/testremove/checkremove.hs

   1
   2 module Main (main) where
   3
   4 import Control.Monad
   5 import Data.List
   6 import System.Environment
   7 import System.Exit
   8 import System.FilePath
   9 import System.IO
  10
  11 data CleanWhat = CleanFile FilePath
  12                | CleanRec  FilePath
  13     deriving (Read, Show)
  14
  15 main :: IO ()
  16 main = do args <- getArgs
  17           case args of
  18               [contentsBeforeFile, contentsAfterFile, wouldBeCleanedFile] ->
  19                   doit contentsBeforeFile contentsAfterFile wouldBeCleanedFile
  20               _ ->
  21                   error "Bad args"
  22
  23 doit :: FilePath -> FilePath -> FilePath -> IO ()
  24 doit contentsBeforeFile contentsAfterFile wouldBeCleanedFile
  25  = do contentsBefore <- liftM lines $ readFile contentsBeforeFile
  26       contentsAfter  <- liftM lines $ readFile contentsAfterFile
  27       wouldBeCleaned <- liftM (map read . lines) $ readFile wouldBeCleanedFile
  28       let newContentsAfter = contentsAfter \\ contentsBefore
  29       let cleanedAfter = simulateCleans newContentsAfter wouldBeCleaned
  30       unless (null cleanedAfter) $ do
  31           hPutStrLn stderr "Files not cleaned:"
  32           mapM_ (hPutStrLn stderr . show) cleanedAfter
  33           exitWith (ExitFailure 1)
  34
  35 simulateCleans :: [FilePath] -> [CleanWhat] -> [FilePath]
  36 simulateCleans fs cws = filter (not . cleaned) fs
  37     where cleaned f = any (`willClean` f) cws
  38
  39 willClean :: CleanWhat -> FilePath -> Bool
  40 CleanFile fp `willClean` f = fp `equalFilePath` f
  41 CleanRec fp `willClean` f
  42     = any (fp `equalFilePath`) (map joinPath $ inits $ splitPath f)
  43