src/Darcs/Patch/Check.lhs

   1 %  Copyright (C) 2002-2003 David Roundy
   2 %
   3 %  This program is free software; you can redistribute it and/or modify
   4 %  it under the terms of the GNU General Public License as published by
   5 %  the Free Software Foundation; either version 2, or (at your option)
   6 %  any later version.
   7 %
   8 %  This program is distributed in the hope that it will be useful,
   9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 %  GNU General Public License for more details.
  12 %
  13 %  You should have received a copy of the GNU General Public License
  14 %  along with this program; see the file COPYING.  If not, write to
  15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16 %  Boston, MA 02110-1301, USA.
  17
  18
  19 \begin{code}
  20 module Darcs.Patch.Check ( PatchCheck(), do_check, file_exists, dir_exists,
  21                     remove_file, remove_dir, create_file, create_dir,
  22                     insert_line, delete_line, is_valid, do_verbose_check,
  23                     file_empty,
  24                     check_move, modify_file, Possibly(..)
  25                   ) where
  26
  27 import Text.Regex ( mkRegex, matchRegex )
  28 import System.IO.Unsafe ( unsafePerformIO )
  29 import qualified Data.ByteString as B (ByteString)
  30 import Data.List (isPrefixOf)
  31
  32 newtype PatchCheck a = PC( KnownState -> (KnownState, a) )
  33
  34 data Possibly a = PJust a | PNothing | PSomething
  35                   deriving (Eq, Show)
  36 data Prop = FileEx String | DirEx String | NotEx String
  37           | FileLines String [Possibly B.ByteString]
  38             deriving (Eq)
  39 data KnownState = P [Prop] [Prop]
  40                 | Inconsistent
  41                   deriving (Show)
  42 instance  Show Prop  where
  43     show (FileEx f) = "FileEx "++f
  44     show (DirEx d)  = "DirEx "++d
  45     show (NotEx f) = "NotEx"++f
  46     show (FileLines f l)  = "FileLines "++f++" "++show (take 10 l)
  47 \end{code}
  48
  49 \section{Patch Consistency Checking}
  50
  51 \begin{code}
  52 instance Monad PatchCheck where
  53     (PC p) >>= k  =  PC( \s0 -> let (s1, a) = p s0
  54                                     (PC q) = k a
  55                                 in q s1 )
  56     return a = PC( \s -> (s, a) )
  57 \end{code}
  58
  59 \begin{code}
  60 do_check :: PatchCheck a -> a
  61 do_check (PC p) = snd $ p (P [] [])
  62
  63 do_verbose_check :: PatchCheck a -> a
  64 do_verbose_check (PC p) =
  65     case p (P [] []) of
  66     (pc, b) -> unsafePerformIO $ do putStrLn $ show pc
  67                                     return b
  68
  69 is_valid :: PatchCheck Bool
  70 is_valid = PC iv
  71     where iv Inconsistent = (Inconsistent, False)
  72           iv m = (m, True)
  73 \end{code}
  74
  75 \begin{code}
  76 has :: Prop -> [Prop] -> Bool
  77 has _ [] = False
  78 has k (k':ks) = k == k' || has k ks
  79
  80 modify_file :: String
  81             -> ([Possibly B.ByteString]-> Maybe [Possibly B.ByteString])
  82             -> PatchCheck Bool
  83 modify_file f change = do
  84     file_exists f
  85     c <- file_contents f
  86     case change c of
  87       Nothing -> assert_not $ FileEx f -- shorthand for "FAIL"
  88       Just c' -> do set_contents f c'
  89                     is_valid
  90
  91 insert_line :: String -> Int -> B.ByteString -> PatchCheck Bool
  92 insert_line f n l = do
  93     c <- file_contents f
  94     case il n c of
  95        [] -> assert_not $ FileEx f
  96        c' -> do
  97              set_contents f c'
  98              return True
  99   where il 1 mls = (PJust l:mls)
 100         il i (ml:mls) = ml : il (i-1) mls
 101         il _ [] = []
 102
 103 -- deletes a line from a hunk patch (third argument) in the given file (first
 104 -- argument) at the given line number (second argument)
 105 delete_line :: String -> Int -> B.ByteString -> PatchCheck Bool
 106 delete_line f n l = do
 107     c <- file_contents f
 108     case dl [] n c of
 109         Nothing -> assert_not $ FileEx f
 110         Just c' -> do
 111             set_contents f c'
 112             is_valid
 113   where dl _ _ [] = Nothing
 114         dl o 1 (ml':ls) =
 115             case ml' of
 116             PSomething -> Just $ reverse o ++ ls
 117             PNothing -> Just $ reverse o ++ ls
 118             PJust l' -> if l' == l then Just $ reverse o ++ ls
 119                                    else Nothing
 120         dl o i (ml:mls) =
 121             case ml of
 122             PNothing -> dl (PSomething:o) (i-1) mls
 123             _ -> dl (ml:o) (i-1) mls
 124
 125 set_contents :: String -> [Possibly B.ByteString] -> PatchCheck ()
 126 set_contents f mss = PC (sc f mss)
 127 sc :: String -> [Possibly B.ByteString] -> KnownState -> (KnownState,())
 128 sc f mss (P ks nots) = (P (scl [] f mss ks) nots, ())
 129 sc _ _ Inconsistent = (Inconsistent, ())
 130 scl :: [Prop] -> String -> [Possibly B.ByteString] -> [Prop] -> [Prop]
 131 scl olds f mss [] = FileLines f mss : olds
 132 scl olds f mss (FileLines f' mss':ks)
 133     | f == f' = FileLines f mss : (olds++ks)
 134     | f /= f' = scl (FileLines f' mss':olds) f mss ks
 135 scl olds f mss (k:ks) = scl (k:olds) f mss ks
 136
 137 file_contents :: String -> PatchCheck [Possibly B.ByteString]
 138 file_contents f = PC fc
 139     where fc Inconsistent = (Inconsistent, [])
 140           fc (P ks nots) = (P ks nots, fic ks)
 141           fic (FileLines f' mss:_) | f == f' = mss
 142           fic (_:ks) = fic ks
 143           fic [] = repeat PNothing
 144
 145 file_empty :: String -> PatchCheck Bool
 146 file_empty f = do
 147   c <- file_contents f
 148   let empty = all (PNothing ==) $ take 101 c
 149   if empty
 150      then do set_contents f []
 151              is_valid
 152      -- Crude way to make it inconsistent and return false:
 153      else assert_not $ FileEx f
 154   return empty
 155
 156 movedirfilename :: String -> String -> String -> String
 157 movedirfilename d d' f =
 158     if (d ++ "/") `isPrefixOf` f
 159     then d'++drop (length d) f
 160     else if f == d
 161          then d'
 162          else f
 163
 164 do_swap :: String -> String -> PatchCheck Bool
 165 do_swap f f' = PC swfn
 166   where swfn Inconsistent = (Inconsistent, False)
 167         swfn (P ks nots) = (P (map sw ks) (map sw nots), True)
 168         sw (FileEx a) | f  `is_soe` a = FileEx $ movedirfilename f f' a
 169                       | f' `is_soe` a = FileEx $ movedirfilename f' f a
 170         sw (DirEx a) | f  `is_soe` a = DirEx $ movedirfilename f f' a
 171                      | f' `is_soe` a = DirEx $ movedirfilename f' f a
 172         sw (FileLines a ls) | f  `is_soe` a = FileLines (movedirfilename f f' a) ls
 173                             | f' `is_soe` a = FileLines (movedirfilename f' f a) ls
 174         sw (NotEx a) | f `is_soe` a = NotEx $ movedirfilename f f' a
 175                      | f' `is_soe` a = NotEx $ movedirfilename f' f a
 176         sw p = p
 177         is_soe d1 d2 = -- is_superdir_or_equal
 178             d1 == d2 || (d1 ++ "/") `isPrefixOf` d2
 179
 180 assert :: Prop -> PatchCheck Bool
 181 assert p = PC assertfn
 182     where assertfn Inconsistent = (Inconsistent, False)
 183           assertfn (P ks nots) =
 184               if has p nots then (Inconsistent, False)
 185               else if has p ks then (P ks nots, True)
 186               else (P (p:ks) nots, True)
 187
 188 assert_not :: Prop -> PatchCheck Bool
 189 assert_not p = PC assertnfn
 190     where assertnfn Inconsistent = (Inconsistent, False)
 191           assertnfn (P ks nots) =
 192               if has p ks then (Inconsistent, False)
 193               else if has p nots then (P ks nots, True)
 194               else (P ks (p:nots), True)
 195
 196 change_to_true :: Prop -> PatchCheck Bool
 197 change_to_true p = PC chtfn
 198     where chtfn Inconsistent = (Inconsistent, False)
 199           chtfn (P ks nots) = (P (p:ks) (filter (p /=) nots), True)
 200
 201 change_to_false :: Prop -> PatchCheck Bool
 202 change_to_false p = PC chffn
 203     where chffn Inconsistent = (Inconsistent, False)
 204           chffn (P ks nots) = (P (filter (p /=) ks) (p:nots), True)
 205 \end{code}
 206
 207 \begin{code}
 208 assert_file_exists :: String -> PatchCheck Bool
 209 assert_file_exists f = do assert_not $ NotEx f
 210                           assert_not $ DirEx f
 211                           assert $ FileEx f
 212 assert_dir_exists :: String -> PatchCheck Bool
 213 assert_dir_exists d = do assert_not $ NotEx d
 214                          assert_not $ FileEx d
 215                          assert $ DirEx d
 216 assert_exists :: String -> PatchCheck Bool
 217 assert_exists f = assert_not $ NotEx f
 218
 219 assert_no_such :: String -> PatchCheck Bool
 220 assert_no_such f = do assert_not $ FileEx f
 221                       assert_not $ DirEx f
 222                       assert $ NotEx f
 223 \end{code}
 224
 225 \begin{code}
 226 create_file :: String -> PatchCheck Bool
 227 create_file fn = do
 228   superdirs_exist fn
 229   assert_no_such fn
 230   change_to_true (FileEx fn)
 231   change_to_false (NotEx fn)
 232
 233 create_dir :: String -> PatchCheck Bool
 234 create_dir fn = do
 235   substuff_dont_exist fn
 236   superdirs_exist fn
 237   assert_no_such fn
 238   change_to_true (DirEx fn)
 239   change_to_false (NotEx fn)
 240
 241 remove_file :: String -> PatchCheck Bool
 242 remove_file fn = do
 243   superdirs_exist fn
 244   assert_file_exists fn
 245   file_empty fn
 246   change_to_false (FileEx fn)
 247   change_to_true (NotEx fn)
 248
 249 remove_dir :: String -> PatchCheck Bool
 250 remove_dir fn = do
 251   substuff_dont_exist fn
 252   superdirs_exist fn
 253   assert_dir_exists fn
 254   change_to_false (DirEx fn)
 255   change_to_true (NotEx fn)
 256
 257 check_move :: String -> String -> PatchCheck Bool
 258 check_move f f' = do
 259   superdirs_exist f
 260   superdirs_exist f'
 261   assert_exists f
 262   assert_no_such f'
 263   do_swap f f'
 264 \end{code}
 265
 266 \begin{code}
 267 substuff_dont_exist :: String -> PatchCheck Bool
 268 substuff_dont_exist d = PC ssde
 269     where ssde Inconsistent = (Inconsistent, False)
 270           ssde (P ks nots) = if all noss ks
 271                              then (P ks nots, True)
 272                              else (Inconsistent, False)
 273               where noss (FileEx f) = not (is_within_dir f)
 274                     noss (DirEx f) = not (is_within_dir f)
 275                     noss _ = True
 276                     is_within_dir f = (d ++ "/") `isPrefixOf` f
 277
 278 superdirs_exist :: String -> PatchCheck Bool
 279 superdirs_exist fn =
 280   case matchRegex (mkRegex "\\./(.+)/[^/]+") fn of
 281   Just ["."] -> return True
 282   Just [d] -> do
 283                 a <- assert_dir_exists ("./"++d)
 284                 b <- superdirs_exist ("./"++d)
 285                 return $! a && b
 286   _ -> is_valid
 287
 288 file_exists :: String -> PatchCheck Bool
 289 file_exists fn = do
 290   superdirs_exist fn
 291   assert_file_exists fn
 292
 293 dir_exists :: String -> PatchCheck Bool
 294 dir_exists fn = do
 295   superdirs_exist fn
 296   assert_dir_exists fn
 297 \end{code}
 298