1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
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
|
