module Main (main) where

import Control.Monad
import qualified Data.ByteString.Char8 as BSC
import Data.Function
import Data.List
import qualified Data.Map as Map
import Data.Map (Map)
import System.Environment
import System.FilePath

data CleanWhat = CleanFile FilePath
               | CleanRec  FilePath
    deriving (Read, Show)

newtype FilePathFragment = FilePathFragment BSC.ByteString
    deriving (Show, Eq, Ord)

toFilePathFragments :: FilePath -> [FilePathFragment]
toFilePathFragments
    = map (FilePathFragment . BSC.pack) . splitDirectories . normalise

fromFilePathFragments :: [FilePathFragment] -> FilePath
fromFilePathFragments xs = joinPath $ map f $ reverse xs
    where f (FilePathFragment frag) = BSC.unpack frag

data Tree = Node !FileInfo !(Map FilePathFragment Tree)
data FileInfo = FileInfo {
                    fiBefore :: !Bool,
                    fiAfter :: !Bool,
                    fiDeleted :: !Bool
                }

beforeFileInfo :: FileInfo
beforeFileInfo = noFileInfo { fiBefore  = True }

afterFileInfo :: FileInfo
afterFileInfo = noFileInfo { fiAfter   = True }

noFileInfo :: FileInfo
noFileInfo = FileInfo {
                 fiBefore  = False,
                 fiAfter   = False,
                 fiDeleted = False
             }

readTree :: FileInfo -> FilePath -> IO (Tree)
readTree fi fp = do xs <- readFile fp
                    return $ mkTree fi $ lines xs

mkTree :: FileInfo -> [FilePath] -> Tree
mkTree fi fps = f (sort fragss)
    where fragss = map toFilePathFragments fps
          f xs = let xs' = g $ groupBy ((==) `on` head)
                             $ filter (not . null) xs
                 in Node fi xs'
          g xss = mapFromList' [ (head (head xs), f (map tail xs))
                               | xs <- xss ]

mapFromList' :: Ord a => [(a, b)] -> Map a b
mapFromList' xs = seqAll xs `seq` Map.fromList xs
    where seqAll [] = ()
          seqAll ((x, y) : xys) = x `seq` y `seq` seqAll xys

{-
... = OK: will happen if a file in a non-existant directory is rm'd [1]
..D = OK: will happen if a non-existant file is rm'd [1]
.A. = suspicious: Why wasn't this file cleaned?
.AD = OK: This is what object files look like
B.. = suspicious: Where did the file go?
B.D = suspicious: Why are we removing a file that existed before?
BA. = OK: This is what source files look like
BAD = suspicious: Why are we removing a file that existed before?

[1] some files may only be created on certain platforms, or in certain
    build-system configurations, but the cleaning code is deliberately
    simple so it will always clean them regardless
-}
pprSuspicious :: Tree -> [String]
pprSuspicious t = f [] t
    where f ps (Node fi m) = suspicious (fromFilePathFragments ps) fi
                          ++ concat [ f (p : ps) m' | (p, m') <- Map.toList m ]
          suspicious fp (FileInfo False True  False) = ["File not deleted:    " ++ show fp]
          suspicious fp (FileInfo True  False False) = ["File disappeared:    " ++ show fp]
          suspicious fp (FileInfo True  False True)  = ["Deleted before file: " ++ show fp]
          suspicious fp (FileInfo True  True  True)  = ["Deleted before file: " ++ show fp]
          suspicious _  _                            = []

pprTree :: Tree -> [String]
pprTree t = f [] t
    where f ps (Node fi m) = (pprInfo fi ++ " " ++ fromFilePathFragments ps)
                           : concat [ f (p : ps) m' | (p, m') <- Map.toList m ]

pprInfo :: FileInfo -> String
pprInfo (FileInfo before after deleted) = [if before  then 'B' else '.',
                                           if after   then 'A' else '.',
                                           if deleted then 'D' else '.']

mergeTree :: Tree -> Tree -> Tree
mergeTree (Node fi1 m1) (Node fi2 m2)
    = Node (mergeFileInfo fi1 fi2)
           (Map.unionWith mergeTree m1 m2)

mergeFileInfo :: FileInfo -> FileInfo -> FileInfo
mergeFileInfo (FileInfo before1 after1 deleted1)
              (FileInfo before2 after2 deleted2)
    = FileInfo (before1 || before2) (after1 || after2) (deleted1 || deleted2)

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 <- readTree beforeFileInfo contentsBeforeFile
      contentsAfter  <- readTree afterFileInfo  contentsAfterFile
      let contentsMerged = mergeTree contentsBefore contentsAfter
      wouldBeCleaned <- liftM (map read . lines) $ readFile wouldBeCleanedFile
      let contentsCleaned = simulateCleans contentsMerged wouldBeCleaned
      mapM_ putStrLn $ pprSuspicious contentsCleaned

simulateCleans :: Tree -> [CleanWhat] -> Tree
simulateCleans = foldl' simulateClean

simulateClean :: Tree -> CleanWhat -> Tree
simulateClean t (CleanFile fp) = at t fp markDeleted
simulateClean t (CleanRec  fp) = at t fp markSubtreeDeleted

markDeleted :: Tree -> Tree
markDeleted (Node fi m) = Node (fi { fiDeleted = True }) m

markSubtreeDeleted :: Tree -> Tree
markSubtreeDeleted (Node fi m) = Node fi' (Map.map markSubtreeDeleted m)
    where fi' = -- "rm -r" will only delete things that are there afterwards
                if fiAfter fi then fi { fiDeleted = True } else fi

at :: Tree -> FilePath -> (Tree -> Tree) -> Tree
at t fp f = at' t (toFilePathFragments fp) f

at' :: Tree -> [FilePathFragment] -> (Tree -> Tree) -> Tree
at' t           []       f = f t
at' (Node fi m) (p : ps) f = Node fi m'
    where m' = Map.insert p (at' t ps f) m
          t = Map.findWithDefault (Node noFileInfo Map.empty) p m