module Darcs.Patch.Check ( PatchCheck(), do_check, file_exists, dir_exists,
remove_file, remove_dir, create_file, create_dir,
insert_line, delete_line, is_valid, do_verbose_check,
file_empty,
check_move, modify_file, Possibly(..)
) where
import Text.Regex ( mkRegex, matchRegex )
import System.IO.Unsafe ( unsafePerformIO )
import qualified Data.ByteString as B (ByteString)
import Data.List (isPrefixOf)
newtype PatchCheck a = PC( KnownState -> (KnownState, a) )
data Possibly a = PJust a | PNothing | PSomething
deriving (Eq, Show)
data Prop = FileEx String | DirEx String | NotEx String
| FileLines String [Possibly B.ByteString]
deriving (Eq)
data KnownState = P [Prop] [Prop]
| Inconsistent
deriving (Show)
instance Show Prop where
show (FileEx f) = "FileEx "++f
show (DirEx d) = "DirEx "++d
show (NotEx f) = "NotEx"++f
show (FileLines f l) = "FileLines "++f++" "++show (take 10 l)
instance Monad PatchCheck where
(PC p) >>= k = PC( \s0 -> let (s1, a) = p s0
(PC q) = k a
in q s1 )
return a = PC( \s -> (s, a) )
do_check :: PatchCheck a -> a
do_check (PC p) = snd $ p (P [] [])
do_verbose_check :: PatchCheck a -> a
do_verbose_check (PC p) =
case p (P [] []) of
(pc, b) -> unsafePerformIO $ do putStrLn $ show pc
return b
is_valid :: PatchCheck Bool
is_valid = PC iv
where iv Inconsistent = (Inconsistent, False)
iv m = (m, True)
has :: Prop -> [Prop] -> Bool
has _ [] = False
has k (k':ks) = k == k' || has k ks
modify_file :: String
-> ([Possibly B.ByteString]-> Maybe [Possibly B.ByteString])
-> PatchCheck Bool
modify_file f change = do
file_exists f
c <- file_contents f
case change c of
Nothing -> assert_not $ FileEx f
Just c' -> do set_contents f c'
is_valid
insert_line :: String -> Int -> B.ByteString -> PatchCheck Bool
insert_line f n l = do
c <- file_contents f
case il n c of
[] -> assert_not $ FileEx f
c' -> do
set_contents f c'
return True
where il 1 mls = (PJust l:mls)
il i (ml:mls) = ml : il (i1) mls
il _ [] = []
delete_line :: String -> Int -> B.ByteString -> PatchCheck Bool
delete_line f n l = do
c <- file_contents f
case dl [] n c of
Nothing -> assert_not $ FileEx f
Just c' -> do
set_contents f c'
is_valid
where dl _ _ [] = Nothing
dl o 1 (ml':ls) =
case ml' of
PSomething -> Just $ reverse o ++ ls
PNothing -> Just $ reverse o ++ ls
PJust l' -> if l' == l then Just $ reverse o ++ ls
else Nothing
dl o i (ml:mls) =
case ml of
PNothing -> dl (PSomething:o) (i1) mls
_ -> dl (ml:o) (i1) mls
set_contents :: String -> [Possibly B.ByteString] -> PatchCheck ()
set_contents f mss = PC (sc f mss)
sc :: String -> [Possibly B.ByteString] -> KnownState -> (KnownState,())
sc f mss (P ks nots) = (P (scl [] f mss ks) nots, ())
sc _ _ Inconsistent = (Inconsistent, ())
scl :: [Prop] -> String -> [Possibly B.ByteString] -> [Prop] -> [Prop]
scl olds f mss [] = FileLines f mss : olds
scl olds f mss (FileLines f' mss':ks)
| f == f' = FileLines f mss : (olds++ks)
| f /= f' = scl (FileLines f' mss':olds) f mss ks
scl olds f mss (k:ks) = scl (k:olds) f mss ks
file_contents :: String -> PatchCheck [Possibly B.ByteString]
file_contents f = PC fc
where fc Inconsistent = (Inconsistent, [])
fc (P ks nots) = (P ks nots, fic ks)
fic (FileLines f' mss:_) | f == f' = mss
fic (_:ks) = fic ks
fic [] = repeat PNothing
file_empty :: String -> PatchCheck Bool
file_empty f = do
c <- file_contents f
let empty = all (PNothing ==) $ take 101 c
if empty
then do set_contents f []
is_valid
else assert_not $ FileEx f
return empty
movedirfilename :: String -> String -> String -> String
movedirfilename d d' f =
if (d ++ "/") `isPrefixOf` f
then d'++drop (length d) f
else if f == d
then d'
else f
do_swap :: String -> String -> PatchCheck Bool
do_swap f f' = PC swfn
where swfn Inconsistent = (Inconsistent, False)
swfn (P ks nots) = (P (map sw ks) (map sw nots), True)
sw (FileEx a) | f `is_soe` a = FileEx $ movedirfilename f f' a
| f' `is_soe` a = FileEx $ movedirfilename f' f a
sw (DirEx a) | f `is_soe` a = DirEx $ movedirfilename f f' a
| f' `is_soe` a = DirEx $ movedirfilename f' f a
sw (FileLines a ls) | f `is_soe` a = FileLines (movedirfilename f f' a) ls
| f' `is_soe` a = FileLines (movedirfilename f' f a) ls
sw (NotEx a) | f `is_soe` a = NotEx $ movedirfilename f f' a
| f' `is_soe` a = NotEx $ movedirfilename f' f a
sw p = p
is_soe d1 d2 =
d1 == d2 || (d1 ++ "/") `isPrefixOf` d2
assert :: Prop -> PatchCheck Bool
assert p = PC assertfn
where assertfn Inconsistent = (Inconsistent, False)
assertfn (P ks nots) =
if has p nots then (Inconsistent, False)
else if has p ks then (P ks nots, True)
else (P (p:ks) nots, True)
assert_not :: Prop -> PatchCheck Bool
assert_not p = PC assertnfn
where assertnfn Inconsistent = (Inconsistent, False)
assertnfn (P ks nots) =
if has p ks then (Inconsistent, False)
else if has p nots then (P ks nots, True)
else (P ks (p:nots), True)
change_to_true :: Prop -> PatchCheck Bool
change_to_true p = PC chtfn
where chtfn Inconsistent = (Inconsistent, False)
chtfn (P ks nots) = (P (p:ks) (filter (p /=) nots), True)
change_to_false :: Prop -> PatchCheck Bool
change_to_false p = PC chffn
where chffn Inconsistent = (Inconsistent, False)
chffn (P ks nots) = (P (filter (p /=) ks) (p:nots), True)
assert_file_exists :: String -> PatchCheck Bool
assert_file_exists f = do assert_not $ NotEx f
assert_not $ DirEx f
assert $ FileEx f
assert_dir_exists :: String -> PatchCheck Bool
assert_dir_exists d = do assert_not $ NotEx d
assert_not $ FileEx d
assert $ DirEx d
assert_exists :: String -> PatchCheck Bool
assert_exists f = assert_not $ NotEx f
assert_no_such :: String -> PatchCheck Bool
assert_no_such f = do assert_not $ FileEx f
assert_not $ DirEx f
assert $ NotEx f
create_file :: String -> PatchCheck Bool
create_file fn = do
superdirs_exist fn
assert_no_such fn
change_to_true (FileEx fn)
change_to_false (NotEx fn)
create_dir :: String -> PatchCheck Bool
create_dir fn = do
substuff_dont_exist fn
superdirs_exist fn
assert_no_such fn
change_to_true (DirEx fn)
change_to_false (NotEx fn)
remove_file :: String -> PatchCheck Bool
remove_file fn = do
superdirs_exist fn
assert_file_exists fn
file_empty fn
change_to_false (FileEx fn)
change_to_true (NotEx fn)
remove_dir :: String -> PatchCheck Bool
remove_dir fn = do
substuff_dont_exist fn
superdirs_exist fn
assert_dir_exists fn
change_to_false (DirEx fn)
change_to_true (NotEx fn)
check_move :: String -> String -> PatchCheck Bool
check_move f f' = do
superdirs_exist f
superdirs_exist f'
assert_exists f
assert_no_such f'
do_swap f f'
substuff_dont_exist :: String -> PatchCheck Bool
substuff_dont_exist d = PC ssde
where ssde Inconsistent = (Inconsistent, False)
ssde (P ks nots) = if all noss ks
then (P ks nots, True)
else (Inconsistent, False)
where noss (FileEx f) = not (is_within_dir f)
noss (DirEx f) = not (is_within_dir f)
noss _ = True
is_within_dir f = (d ++ "/") `isPrefixOf` f
superdirs_exist :: String -> PatchCheck Bool
superdirs_exist fn =
case matchRegex (mkRegex "\\./(.+)/[^/]+") fn of
Just ["."] -> return True
Just [d] -> do
a <- assert_dir_exists ("./"++d)
b <- superdirs_exist ("./"++d)
return $! a && b
_ -> is_valid
file_exists :: String -> PatchCheck Bool
file_exists fn = do
superdirs_exist fn
assert_file_exists fn
dir_exists :: String -> PatchCheck Bool
dir_exists fn = do
superdirs_exist fn
assert_dir_exists fn