1 % Copyright (C) 2002-2003,2007 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 \begin{code} 19 {-# OPTIONS_GHC -cpp -fglasgow-exts #-} 20 {-# LANGUAGE CPP #-} 21 -- , MagicHash, TypeOperators, GADTs, PatternGuards #-} 22 23 #include "gadts.h" 24 25 module Darcs.Patch.Prim 26 ( Prim(..), IsConflictedPrim(IsC), ConflictState(..), showPrim, 27 DirPatchType(..), FilePatchType(..), 28 CommuteFunction, Perhaps(..), 29 null_patch, nullP, is_null_patch, 30 is_identity, 31 formatFileName, FileNameFormat(..), 32 adddir, addfile, binary, changepref, 33 hunk, move, rmdir, rmfile, tokreplace, 34 is_addfile, is_hunk, is_binary, is_setpref, 35 is_similar, is_adddir, is_filepatch, 36 canonize, try_to_shrink, modernizePrim, 37 subcommutes, sort_coalesceFL, join, 38 try_tok_internal, 39 try_shrinking_inverse, 40 n_fn, 41 FromPrim(..), FromPrims(..), ToFromPrim(..), 42 Conflict(..), Effect(..), commute_no_conflictsFL, commute_no_conflictsRL 43 ) 44 where 45 46 import Prelude hiding ( pi ) 47 import Control.Monad ( MonadPlus, msum, mzero, mplus ) 48 import Data.Maybe ( isNothing ) 49 #ifndef GADT_WITNESSES 50 import Data.Map ( elems, fromListWith, mapWithKey ) 51 #endif 52 53 import ByteStringUtils ( substrPS, fromPS2Hex) 54 import qualified Data.ByteString as B (ByteString, length, null, head, take, concat, drop) 55 import qualified Data.ByteString.Char8 as BC (break, pack) 56 57 import Darcs.Patch.FileName ( FileName, fn2ps, fn2fp, fp2fn, norm_path, 58 movedirfilename, encode_white ) 59 import Darcs.Ordered 60 import Darcs.Sealed ( Sealed, unseal ) 61 import Darcs.Patch.Patchy ( Invert(..), Commute(..) ) 62 import Darcs.Patch.Permutations () -- for Invert instance of FL 63 import Darcs.Show 64 import Darcs.Utils ( nubsort ) 65 import Lcs ( getChanges ) 66 import RegChars ( regChars ) 67 import Printer ( Doc, vcat, packedString, Color(Cyan,Magenta), lineColor, 68 text, userchunk, invisibleText, invisiblePS, blueText, 69 ($$), (<+>), (<>), prefix, userchunkPS, 70 ) 71 import GHC.Base (unsafeCoerce#) 72 #include "impossible.h" 73 74 data Prim C(x y) where 75 Move :: !FileName -> !FileName -> Prim C(x y) 76 DP :: !FileName -> !(DirPatchType C(x y)) -> Prim C(x y) 77 FP :: !FileName -> !(FilePatchType C(x y)) -> Prim C(x y) 78 Split :: FL Prim C(x y) -> Prim C(x y) 79 Identity :: Prim C(x x) 80 ChangePref :: !String -> !String -> !String -> Prim C(x y) 81 82 data FilePatchType C(x y) = RmFile | AddFile 83 | Hunk !Int [B.ByteString] [B.ByteString] 84 | TokReplace !String !String !String 85 | Binary B.ByteString B.ByteString 86 deriving (Eq,Ord) 87 88 data DirPatchType C(x y) = RmDir | AddDir 89 deriving (Eq,Ord) 90 91 instance MyEq FilePatchType where 92 unsafeCompare a b = a == unsafeCoerce# b 93 94 instance MyEq DirPatchType where 95 unsafeCompare a b = a == unsafeCoerce# b 96 97 null_patch :: Prim C(x x) 98 null_patch = Identity 99 100 is_null_patch :: Prim C(x y) -> Bool 101 is_null_patch (FP _ (Binary x y)) = B.null x && B.null y 102 is_null_patch (FP _ (Hunk _ [] [])) = True 103 is_null_patch Identity = True 104 is_null_patch _ = False 105 106 nullP :: Prim C(x y) -> EqCheck C(x y) 107 nullP = sloppyIdentity 108 109 is_identity :: Prim C(x y) -> EqCheck C(x y) 110 is_identity (FP _ (Binary old new)) | old == new = unsafeCoerce# IsEq 111 is_identity (FP _ (Hunk _ old new)) | old == new = unsafeCoerce# IsEq 112 is_identity (FP _ (TokReplace _ old new)) | old == new = unsafeCoerce# IsEq 113 is_identity (Move old new) | old == new = unsafeCoerce# IsEq 114 is_identity Identity = IsEq 115 is_identity _ = NotEq 116 117 -- FIXME: The following code needs to be moved. 118 119 -- | Tells you if two patches are in the same category, human-wise. 120 -- Currently just returns true if they are filepatches on the same 121 -- file. 122 is_similar :: Prim C(x y) -> Prim C(a b) -> Bool 123 is_similar (FP f _) (FP f' _) = f == f' 124 is_similar (DP f _) (DP f' _) = f == f' 125 is_similar _ _ = False 126 127 is_addfile :: Prim C(x y) -> Bool 128 is_addfile (FP _ AddFile) = True 129 is_addfile _ = False 130 131 is_adddir :: Prim C(x y) -> Bool 132 is_adddir (DP _ AddDir) = True 133 is_adddir _ = False 134 135 is_hunk :: Prim C(x y) -> Bool 136 is_hunk (FP _ (Hunk _ _ _)) = True 137 is_hunk _ = False 138 139 is_binary :: Prim C(x y) -> Bool 140 is_binary (FP _ (Binary _ _)) = True 141 is_binary _ = False 142 143 is_setpref :: Prim C(x y) -> Bool 144 is_setpref (ChangePref _ _ _) = True 145 is_setpref _ = False 146 147 addfile :: FilePath -> Prim C(x y) 148 rmfile :: FilePath -> Prim C(x y) 149 adddir :: FilePath -> Prim C(x y) 150 rmdir :: FilePath -> Prim C(x y) 151 move :: FilePath -> FilePath -> Prim C(x y) 152 changepref :: String -> String -> String -> Prim C(x y) 153 hunk :: FilePath -> Int -> [B.ByteString] -> [B.ByteString] -> Prim C(x y) 154 tokreplace :: FilePath -> String -> String -> String -> Prim C(x y) 155 binary :: FilePath -> B.ByteString -> B.ByteString -> Prim C(x y) 156 157 evalargs :: (a -> b -> c) -> a -> b -> c 158 evalargs f x y = (f $! x) $! y 159 160 addfile f = FP (fp2fn $ n_fn f) AddFile 161 rmfile f = FP (fp2fn $ n_fn f) RmFile 162 adddir d = DP (fp2fn $ n_fn d) AddDir 163 rmdir d = DP (fp2fn $ n_fn d) RmDir 164 move f f' = Move (fp2fn $ n_fn f) (fp2fn $ n_fn f') 165 changepref p f t = ChangePref p f t 166 hunk f line old new = evalargs FP (fp2fn $ n_fn f) (Hunk line old new) 167 tokreplace f tokchars old new = 168 evalargs FP (fp2fn $ n_fn f) (TokReplace tokchars old new) 169 binary f old new = FP (fp2fn $! n_fn f) $ Binary old new 170 171 n_fn :: FilePath -> FilePath 172 n_fn f = "./"++(fn2fp $ norm_path $ fp2fn f) 173 174 instance Invert Prim where 175 invert Identity = Identity 176 invert (FP f RmFile) = FP f AddFile 177 invert (FP f AddFile) = FP f RmFile 178 invert (FP f (Hunk line old new)) = FP f $ Hunk line new old 179 invert (FP f (TokReplace t o n)) = FP f $ TokReplace t n o 180 invert (FP f (Binary o n)) = FP f $ Binary n o 181 invert (DP d RmDir) = DP d AddDir 182 invert (DP d AddDir) = DP d RmDir 183 invert (Move f f') = Move f' f 184 invert (ChangePref p f t) = ChangePref p t f 185 invert (Split ps) = Split $ invert ps 186 identity = Identity 187 sloppyIdentity Identity = IsEq 188 sloppyIdentity _ = NotEq 189 190 instance Show (Prim C(x y)) where 191 showsPrec d (Move fn1 fn2) = showParen (d > app_prec) $ showString "Move " . 192 showsPrec (app_prec + 1) fn1 . showString " " . 193 showsPrec (app_prec + 1) fn2 194 showsPrec d (DP fn dp) = showParen (d > app_prec) $ showString "DP " . 195 showsPrec (app_prec + 1) fn . showString " " . 196 showsPrec (app_prec + 1) dp 197 showsPrec d (FP fn fp) = showParen (d > app_prec) $ showString "FP " . 198 showsPrec (app_prec + 1) fn . showString " " . 199 showsPrec (app_prec + 1) fp 200 showsPrec d (Split l) = showParen (d > app_prec) $ showString "Split " . 201 showsPrec (app_prec + 1) l 202 showsPrec _ Identity = showString "Identity" 203 showsPrec d (ChangePref p f t) = showParen (d > app_prec) $ showString "ChangePref " . 204 showsPrec (app_prec + 1) p . showString " " . 205 showsPrec (app_prec + 1) f . showString " " . 206 showsPrec (app_prec + 1) t 207 208 instance Show2 Prim where 209 showsPrec2 = showsPrec 210 211 instance Show (FilePatchType C(x y)) where 212 showsPrec _ RmFile = showString "RmFile" 213 showsPrec _ AddFile = showString "AddFile" 214 showsPrec d (Hunk line old new) | all ((==1) . B.length) old && all ((==1) . B.length) new 215 = showParen (d > app_prec) $ showString "Hunk " . 216 showsPrec (app_prec + 1) line . showString " " . 217 showsPrecC old . showString " " . 218 showsPrecC new 219 where showsPrecC [] = showString "[]" 220 showsPrecC ss = showParen True $ showString "packStringLetters " . showsPrec (app_prec + 1) (map B.head ss) 221 showsPrec d (Hunk line old new) = showParen (d > app_prec) $ showString "Hunk " . 222 showsPrec (app_prec + 1) line . showString " " . 223 showsPrec (app_prec + 1) old . showString " " . 224 showsPrec (app_prec + 1) new 225 showsPrec d (TokReplace t old new) = showParen (d > app_prec) $ showString "TokReplace " . 226 showsPrec (app_prec + 1) t . showString " " . 227 showsPrec (app_prec + 1) old . showString " " . 228 showsPrec (app_prec + 1) new 229 -- this case may not work usefully 230 showsPrec d (Binary old new) = showParen (d > app_prec) $ showString "Binary " . 231 showsPrec (app_prec + 1) old . showString " " . 232 showsPrec (app_prec + 1) new 233 234 instance Show (DirPatchType C(x y)) where 235 showsPrec _ RmDir = showString "RmDir" 236 showsPrec _ AddDir = showString "AddDir" 237 238 {- 239 instance Show (Prim C(x y)) where 240 show p = renderString (showPrim p) ++ "\n" 241 -} 242 243 data FileNameFormat = OldFormat | NewFormat 244 formatFileName :: FileNameFormat -> FileName -> Doc 245 formatFileName OldFormat = packedString . fn2ps 246 formatFileName NewFormat = text . encode_white . fn2fp 247 248 showPrim :: FileNameFormat -> Prim C(a b) -> Doc 249 showPrim x (FP f AddFile) = showAddFile x f 250 showPrim x (FP f RmFile) = showRmFile x f 251 showPrim x (FP f (Hunk line old new)) = showHunk x f line old new 252 showPrim x (FP f (TokReplace t old new)) = showTok x f t old new 253 showPrim x (FP f (Binary old new)) = showBinary x f old new 254 showPrim x (DP d AddDir) = showAddDir x d 255 showPrim x (DP d RmDir) = showRmDir x d 256 showPrim x (Move f f') = showMove x f f' 257 showPrim _ (ChangePref p f t) = showChangePref p f t 258 showPrim x (Split ps) = showSplit x ps 259 showPrim _ Identity = blueText "{}" 260 261 \end{code} 262 263 264 \paragraph{Add file} 265 Add an empty file to the tree. 266 267 \verb!addfile filename! 268 \begin{code} 269 showAddFile :: FileNameFormat -> FileName -> Doc 270 showAddFile x f = blueText "addfile" <+> formatFileName x f 271 \end{code} 272 273 \paragraph{Remove file} 274 Delete a file from the tree. 275 276 \verb!rmfile filename! 277 \begin{code} 278 showRmFile :: FileNameFormat -> FileName -> Doc 279 showRmFile x f = blueText "rmfile" <+> formatFileName x f 280 \end{code} 281 282 \paragraph{Move} 283 Rename a file or directory. 284 285 \verb!move oldname newname! 286 \begin{code} 287 showMove :: FileNameFormat -> FileName -> FileName -> Doc 288 showMove x d d' = blueText "move" <+> formatFileName x d <+> formatFileName x d' 289 \end{code} 290 291 \paragraph{Change Pref} 292 Change one of the preference settings. Darcs stores a number of simple 293 string settings. Among these are the name of the test script and the name 294 of the script that must be called prior to packing in a make dist. 295 \begin{verbatim} 296 changepref prefname 297 oldval 298 newval 299 \end{verbatim} 300 \begin{code} 301 showChangePref :: String -> String -> String -> Doc 302 showChangePref p f t = blueText "changepref" <+> text p 303 $$ userchunk f 304 $$ userchunk t 305 \end{code} 306 307 \paragraph{Add dir} 308 Add an empty directory to the tree. 309 310 \verb!adddir filename! 311 \begin{code} 312 showAddDir :: FileNameFormat -> FileName -> Doc 313 showAddDir x d = blueText "adddir" <+> formatFileName x d 314 \end{code} 315 316 \paragraph{Remove dir} 317 Delete a directory from the tree. 318 319 \verb!rmdir filename! 320 \begin{code} 321 showRmDir :: FileNameFormat -> FileName -> Doc 322 showRmDir x d = blueText "rmdir" <+> formatFileName x d 323 \end{code} 324 325 326 \paragraph{Hunk} 327 Replace a hunk (set of contiguous lines) of text with a new 328 hunk. 329 \begin{verbatim} 330 hunk FILE LINE# 331 -LINE 332 ... 333 +LINE 334 ... 335 \end{verbatim} 336 \begin{code} 337 showHunk :: FileNameFormat -> FileName -> Int -> [B.ByteString] -> [B.ByteString] -> Doc 338 showHunk x f line old new = 339 blueText "hunk" <+> formatFileName x f <+> text (show line) 340 $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS old)) 341 $$ lineColor Cyan (prefix "+" (vcat $ map userchunkPS new)) 342 \end{code} 343 344 \paragraph{Token replace} 345 346 Replace a token with a new token. Note that this format means that 347 whitespace must not be allowed within a token. If you know of a practical 348 application of whitespace within a token, let me know and I may change 349 this. 350 \begin{verbatim} 351 replace FILENAME [REGEX] OLD NEW 352 \end{verbatim} 353 \begin{code} 354 showTok :: FileNameFormat -> FileName -> String -> String -> String -> Doc 355 showTok x f t o n = blueText "replace" <+> formatFileName x f 356 <+> text "[" <> userchunk t <> text "]" 357 <+> userchunk o 358 <+> userchunk n 359 \end{code} 360 361 \paragraph{Binary file modification} 362 363 Modify a binary file 364 \begin{verbatim} 365 binary FILENAME 366 oldhex 367 *HEXHEXHEX 368 ... 369 newhex 370 *HEXHEXHEX 371 ... 372 \end{verbatim} 373 \begin{code} 374 showBinary :: FileNameFormat -> FileName -> B.ByteString -> B.ByteString -> Doc 375 showBinary x f o n = 376 blueText "binary" <+> formatFileName x f 377 $$ invisibleText "oldhex" 378 $$ (vcat $ map makeprintable $ break_every 78 $ fromPS2Hex o) 379 $$ invisibleText "newhex" 380 $$ (vcat $ map makeprintable $ break_every 78 $ fromPS2Hex n) 381 where makeprintable ps = invisibleText "*" <> invisiblePS ps 382 383 break_every :: Int -> B.ByteString -> [B.ByteString] 384 break_every n ps | B.length ps < n = [ps] 385 | otherwise = B.take n ps : break_every n (B.drop n ps) 386 \end{code} 387 388 \paragraph{Split patch [OBSOLETE!]} 389 A split patch is similar to a composite patch but rather than being 390 composed of several patches grouped together, it is created from one 391 patch that has been split apart, typically through a merge or 392 commutation. 393 \begin{verbatim} 394 ( 395 <put patches here> (indented two) 396 ) 397 \end{verbatim} 398 \begin{code} 399 showSplit :: FileNameFormat -> FL Prim C(x y) -> Doc 400 showSplit x ps = blueText "(" 401 $$ vcat (mapFL (showPrim x) ps) 402 $$ blueText ")" 403 404 commute_split :: CommuteFunction 405 commute_split (Split patches :< patch) = 406 toPerhaps $ cs (patches :< patch) >>= sc 407 where cs :: ((FL Prim) :< Prim) C(x y) -> Maybe ((Prim :< (FL Prim)) C(x y)) 408 cs (NilFL :< p1) = return (p1 :< NilFL) 409 cs (p:>:ps :< p1) = do p1' :< p' <- commutex (p :< p1) 410 p1'' :< ps' <- cs (ps :< p1') 411 return (p1'' :< p':>:ps') 412 sc :: (Prim :< (FL Prim)) C(x y) -> Maybe ((Prim :< Prim) C(x y)) 413 sc (p1 :< ps) = scFL $ p1 :< (sort_coalesceFL ps) 414 where scFL :: (Prim :< (FL Prim)) C(x y) 415 -> Maybe ((Prim :< Prim) C(x y)) 416 scFL (p1' :< (p :>: NilFL)) = return (p1' :< p) 417 scFL (p1' :< ps') = return (p1' :< Split ps') 418 commute_split _ = Unknown 419 420 try_to_shrink :: FL Prim C(x y) -> FL Prim C(x y) 421 try_to_shrink = mapPrimFL try_harder_to_shrink 422 423 mapPrimFL :: (FORALL(x y) FL Prim C(x y) -> FL Prim C(x y)) 424 -> FL Prim C(w z) -> FL Prim C(w z) 425 mapPrimFL f x = 426 #ifdef GADT_WITNESSES 427 f x 428 #else 429 -- an optimisation; break the list up into independent sublists 430 -- and apply f to each of them 431 case mapM toSimple $ mapFL id x of 432 Just sx -> foldr (+>+) NilFL $ elems $ 433 mapWithKey (\ k p -> f (fromSimples k (p NilFL))) $ 434 fromListWith (flip (.)) $ 435 map (\ (a,b) -> (a,(b:>:))) sx 436 Nothing -> f x 437 438 data Simple C(x y) = SFP !(FilePatchType C(x y)) | SDP !(DirPatchType C(x y)) 439 | SCP String String String 440 deriving ( Show ) 441 442 toSimple :: Prim C(x y) -> Maybe (FileName, Simple C(x y)) 443 toSimple (FP a b) = Just (a, SFP b) 444 toSimple (DP a AddDir) = Just (a, SDP AddDir) 445 toSimple (DP _ RmDir) = Nothing -- ordering is trickier with rmdir present 446 toSimple (Move _ _) = Nothing 447 toSimple (Split _) = Nothing 448 toSimple Identity = Nothing 449 toSimple (ChangePref a b c) = Just (fp2fn "_darcs/prefs/prefs", SCP a b c) 450 451 fromSimple :: FileName -> Simple C(x y) -> Prim C(x y) 452 fromSimple a (SFP b) = FP a b 453 fromSimple a (SDP b) = DP a b 454 fromSimple _ (SCP a b c) = ChangePref a b c 455 456 fromSimples :: FileName -> FL Simple C(x y) -> FL Prim C(x y) 457 fromSimples a bs = mapFL_FL (fromSimple a) bs 458 #endif 459 460 try_harder_to_shrink :: FL Prim C(x y) -> FL Prim C(x y) 461 try_harder_to_shrink x = try_to_shrink2 $ maybe x id (try_shrinking_inverse x) 462 463 try_to_shrink2 :: FL Prim C(x y) -> FL Prim C(x y) 464 try_to_shrink2 psold = 465 let ps = sort_coalesceFL psold 466 ps_shrunk = shrink_a_bit ps 467 in 468 if lengthFL ps_shrunk < lengthFL ps 469 then try_to_shrink2 ps_shrunk 470 else ps_shrunk 471 472 try_shrinking_inverse :: FL Prim C(x y) -> Maybe (FL Prim C(x y)) 473 try_shrinking_inverse (x:>:y:>:z) 474 | IsEq <- invert x =\/= y = Just z 475 | otherwise = case try_shrinking_inverse (y:>:z) of 476 Nothing -> Nothing 477 Just yz' -> Just $ case try_shrinking_inverse (x:>:yz') of 478 Nothing -> x:>:yz' 479 Just xyz' -> xyz' 480 try_shrinking_inverse _ = Nothing 481 482 shrink_a_bit :: FL Prim C(x y) -> FL Prim C(x y) 483 shrink_a_bit NilFL = NilFL 484 shrink_a_bit (p:>:ps) = 485 case try_one NilRL p ps of 486 Nothing -> p :>: shrink_a_bit ps 487 Just ps' -> ps' 488 489 try_one :: RL Prim C(w x) -> Prim C(x y) -> FL Prim C(y z) 490 -> Maybe (FL Prim C(w z)) 491 try_one _ _ NilFL = Nothing 492 try_one sofar p (p1:>:ps) = 493 case coalesce (p1 :< p) of 494 Just p' -> Just (reverseRL sofar +>+ p':>:NilFL +>+ ps) 495 Nothing -> case commutex (p1 :< p) of 496 Nothing -> Nothing 497 Just (p' :< p1') -> try_one (p1':<:sofar) p' ps 498 499 -- | 'sort_coalesceFL' @ps@ coalesces as many patches in @ps@ as 500 -- possible, sorting the results according to the scheme defined 501 -- in 'comparePrim' 502 sort_coalesceFL :: FL Prim C(x y) -> FL Prim C(x y) 503 sort_coalesceFL = mapPrimFL sort_coalesceFL2 504 505 -- | The heart of "sort_coalesceFL" 506 sort_coalesceFL2 :: FL Prim C(x y) -> FL Prim C(x y) 507 sort_coalesceFL2 NilFL = NilFL 508 sort_coalesceFL2 (x:>:xs) | IsEq <- nullP x = sort_coalesceFL2 xs 509 sort_coalesceFL2 (x:>:xs) | IsEq <- is_identity x = sort_coalesceFL2 xs 510 sort_coalesceFL2 (x:>:xs) = either id id $ push_coalesce_patch x $ sort_coalesceFL2 xs 511 512 -- | 'push_coalesce_patch' @new ps@ is almost like @new :>: ps@ except 513 -- as an alternative to consing, we first try to coalesce @new@ with 514 -- the head of @ps@. If this fails, we try again, using commutation 515 -- to push @new@ down the list until we find a place where either 516 -- (a) @new@ is @LT@ the next member of the list [see 'comparePrim'] 517 -- (b) commutation fails or 518 -- (c) coalescing succeeds. 519 -- The basic principle is to coalesce if we can and cons otherwise. 520 -- 521 -- As an additional optimization, push_coalesce_patch outputs a Left 522 -- value if it wasn't able to shrink the patch sequence at all, and 523 -- a Right value if it was indeed able to shrink the patch sequence. 524 -- This avoids the O(N) calls to lengthFL that were in the older 525 -- code. 526 -- 527 -- Also note that push_coalesce_patch is only ever used (and should 528 -- only ever be used) as an internal function in in 529 -- sort_coalesceFL2. 530 push_coalesce_patch :: Prim C(x y) -> FL Prim C(y z) 531 -> Either (FL Prim C(x z)) (FL Prim C(x z)) 532 push_coalesce_patch new NilFL = Left (new:>:NilFL) 533 push_coalesce_patch new ps@(p:>:ps') 534 = case coalesce (p :< new) of 535 Just new' | IsEq <- nullP new' -> Right ps' 536 | otherwise -> Right $ either id id $ push_coalesce_patch new' ps' 537 Nothing -> if comparePrim new p == LT then Left (new:>:ps) 538 else case commutex (p :< new) of 539 Just (new' :< p') -> 540 case push_coalesce_patch new' ps' of 541 Right r -> Right $ either id id $ 542 push_coalesce_patch p' r 543 Left r -> Left (p' :>: r) 544 Nothing -> Left (new:>:ps) 545 546 is_in_directory :: FileName -> FileName -> Bool 547 is_in_directory d f = iid (fn2fp d) (fn2fp f) 548 where iid (cd:cds) (cf:cfs) 549 | cd /= cf = False 550 | otherwise = iid cds cfs 551 iid [] ('/':_) = True 552 iid [] [] = True -- Count directory itself as being in directory... 553 iid _ _ = False 554 555 data Perhaps a = Unknown | Failed | Succeeded a 556 557 instance Monad Perhaps where 558 (Succeeded x) >>= k = k x 559 Failed >>= _ = Failed 560 Unknown >>= _ = Unknown 561 Failed >> _ = Failed 562 (Succeeded _) >> k = k 563 Unknown >> k = k 564 return = Succeeded 565 fail _ = Unknown 566 567 instance MonadPlus Perhaps where 568 mzero = Unknown 569 Unknown `mplus` ys = ys 570 Failed `mplus` _ = Failed 571 (Succeeded x) `mplus` _ = Succeeded x 572 573 toMaybe :: Perhaps a -> Maybe a 574 toMaybe (Succeeded x) = Just x 575 toMaybe _ = Nothing 576 577 toPerhaps :: Maybe a -> Perhaps a 578 toPerhaps (Just x) = Succeeded x 579 toPerhaps Nothing = Failed 580 581 clever_commute :: CommuteFunction -> CommuteFunction 582 clever_commute c (p1:<p2) = 583 case c (p1 :< p2) of 584 Succeeded x -> Succeeded x 585 Failed -> Failed 586 Unknown -> case c (invert p2 :< invert p1) of 587 Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1') 588 Failed -> Failed 589 Unknown -> Unknown 590 --clever_commute c (p1,p2) = c (p1,p2) `mplus` 591 -- (case c (invert p2,invert p1) of 592 -- Succeeded (p1', p2') -> Succeeded (invert p2', invert p1') 593 -- Failed -> Failed 594 -- Unknown -> Unknown) 595 596 speedy_commute :: CommuteFunction 597 speedy_commute (p1 :< p2) -- Deal with common case quickly! 598 | p1_modifies /= Nothing && p2_modifies /= Nothing && 599 p1_modifies /= p2_modifies = Succeeded (unsafeCoerce# p2 :< unsafeCoerce# p1) 600 | otherwise = Unknown 601 where p1_modifies = is_filepatch p1 602 p2_modifies = is_filepatch p2 603 604 everything_else_commute :: CommuteFunction 605 everything_else_commute x = eec x 606 where 607 eec :: CommuteFunction 608 eec (ChangePref p f t :<p1) = Succeeded (unsafeCoerce# p1 :< ChangePref p f t) 609 eec (p2 :<ChangePref p f t) = Succeeded (ChangePref p f t :< unsafeCoerce# p2) 610 eec (Identity :< p1) = Succeeded (p1 :< Identity) 611 eec (p2 :< Identity) = Succeeded (Identity :< p2) 612 eec xx = 613 msum [ 614 clever_commute commute_filedir xx 615 ,clever_commute commute_split xx 616 ] 617 618 {- 619 Note that it must be true that 620 621 commutex (A^-1 A, P) = Just (P, A'^-1 A') 622 623 and 624 625 if commutex (A, B) == Just (B', A') 626 then commutex (B^-1, A^-1) == Just (A'^-1, B'^-1) 627 -} 628 629 instance Commute Prim where 630 merge (y :\/: z) = 631 case elegant_merge (y:\/:z) of 632 Just (z' :/\: y') -> z' :/\: y' 633 Nothing -> error "Commute Prim merge" 634 commutex x = toMaybe $ msum [speedy_commute x, 635 everything_else_commute x 636 ] 637 -- Recurse on everything, these are potentially spoofed patches 638 list_touched_files (Move f1 f2) = map fn2fp [f1, f2] 639 list_touched_files (Split ps) = nubsort $ concat $ mapFL list_touched_files ps 640 list_touched_files (FP f _) = [fn2fp f] 641 list_touched_files (DP d _) = [fn2fp d] 642 list_touched_files (ChangePref _ _ _) = [] 643 list_touched_files Identity = [] 644 645 is_filepatch :: Prim C(x y) -> Maybe FileName 646 is_filepatch (FP f _) = Just f 647 is_filepatch _ = Nothing 648 649 is_superdir :: FileName -> FileName -> Bool 650 is_superdir d1 d2 = isd (fn2fp d1) (fn2fp d2) 651 where isd s1 s2 = 652 length s2 >= length s1 + 1 && take (length s1 + 1) s2 == s1 ++ "/" 653 654 commute_filedir :: CommuteFunction 655 commute_filedir (FP f1 p1 :< FP f2 p2) = 656 if f1 /= f2 then Succeeded ( FP f2 (unsafeCoerce# p2) :< FP f1 (unsafeCoerce# p1) ) 657 else commuteFP f1 (p1 :< p2) 658 commute_filedir (DP d1 p1 :< DP d2 p2) = 659 if (not $ is_in_directory d1 d2) && (not $ is_in_directory d2 d1) && 660 d1 /= d2 661 then Succeeded ( DP d2 (unsafeCoerce# p2) :< DP d1 (unsafeCoerce# p1) ) 662 else Failed 663 commute_filedir (DP d dp :< FP f fp) = 664 if not $ is_in_directory d f 665 then Succeeded (FP f (unsafeCoerce# fp) :< DP d (unsafeCoerce# dp)) 666 else Failed 667 668 commute_filedir (Move d d' :< FP f2 p2) 669 | f2 == d' = Failed 670 | (p2 == AddFile || p2 == RmFile) && d == f2 = Failed 671 | otherwise = Succeeded (FP (movedirfilename d d' f2) (unsafeCoerce# p2) :< Move d d') 672 commute_filedir (Move d d' :< DP d2 p2) 673 | is_superdir d2 d' || is_superdir d2 d = Failed 674 | (p2 == AddDir || p2 == RmDir) && d == d2 = Failed 675 | d2 == d' = Failed 676 | otherwise = Succeeded (DP (movedirfilename d d' d2) (unsafeCoerce# p2) :< Move d d') 677 commute_filedir (Move d d' :< Move f f') 678 | f == d' || f' == d = Failed 679 | f == d || f' == d' = Failed 680 | d `is_superdir` f && f' `is_superdir` d' = Failed 681 | otherwise = 682 Succeeded (Move (movedirfilename d d' f) (movedirfilename d d' f') :< 683 Move (movedirfilename f' f d) (movedirfilename f' f d')) 684 685 commute_filedir _ = Unknown 686 687 type CommuteFunction = FORALL(x y) (Prim :< Prim) C(x y) -> Perhaps ((Prim :< Prim) C(x y)) 688 subcommutes :: [(String, CommuteFunction)] 689 subcommutes = 690 [("speedy_commute", speedy_commute), 691 ("commute_filedir", clever_commute commute_filedir), 692 ("commute_filepatches", clever_commute commute_filepatches), 693 ("commutex", toPerhaps . commutex) 694 ] 695 696 elegant_merge :: (Prim :\/: Prim) C(x y) 697 -> Maybe ((Prim :/\: Prim) C(x y)) 698 elegant_merge (p1 :\/: p2) = 699 do p1':>ip2' <- commute (invert p2 :> p1) 700 -- The following should be a redundant check 701 p1o:>_ <- commute (p2 :> p1') 702 IsEq <- return $ p1o =\/= p1 703 return (invert ip2' :/\: p1') 704 \end{code} 705 706 It can sometimes be handy to have a canonical representation of a given 707 patch. We achieve this by defining a canonical form for each patch type, 708 and a function ``{\tt canonize}'' which takes a patch and puts it into 709 canonical form. This routine is used by the diff function to create an 710 optimal patch (based on an LCS algorithm) from a simple hunk describing the 711 old and new version of a file. 712 \begin{code} 713 canonize :: Prim C(x y) -> FL Prim C(x y) 714 canonize (Split ps) = sort_coalesceFL ps 715 canonize p | IsEq <- is_identity p = NilFL 716 canonize (FP f (Hunk line old new)) = canonizeHunk f line old new 717 canonize p = p :>: NilFL 718 \end{code} 719 720 A simpler, faster (and more generally useful) cousin of canonize is the 721 coalescing function. This takes two sequential patches, and tries to turn 722 them into one patch. This function is used to deal with ``split'' patches, 723 which are created when the commutation of a primitive patch can only be 724 represented by a composite patch. In this case the resulting composite 725 patch must return to the original primitive patch when the commutation is 726 reversed, which a split patch accomplishes by trying to coalesce its 727 contents each time it is commuted. 728 729 \begin{code} 730 -- | 'coalesce' @p2 :< p1@ tries to combine @p1@ and @p2@ into a single 731 -- patch without intermediary changes. For example, two hunk patches 732 -- modifying adjacent lines can be coalesced into a bigger hunk patch. 733 -- Or a patch which moves file A to file B can be coalesced with a 734 -- patch that moves file B into file C, yielding a patch that moves 735 -- file A to file C. 736 coalesce :: (Prim :< Prim) C(x y) -> Maybe (Prim C(x y)) 737 coalesce (FP f1 _ :< FP f2 _) | f1 /= f2 = Nothing 738 coalesce (p2 :< p1) | IsEq <- p2 =\/= invert p1 = Just null_patch 739 coalesce (FP f1 p1 :< FP _ p2) = coalesceFilePrim f1 (p1 :< p2) -- f1 = f2 740 coalesce (Identity :< p) = Just p 741 coalesce (p :< Identity) = Just p 742 coalesce (Split NilFL :< p) = Just p 743 coalesce (p :< Split NilFL) = Just p 744 coalesce (Move a b :< Move b' a') | a == a' = Just $ Move b' b 745 coalesce (Move a b :< FP f AddFile) | f == a = Just $ FP b AddFile 746 coalesce (Move a b :< DP f AddDir) | f == a = Just $ DP b AddDir 747 coalesce (FP f RmFile :< Move a b) | b == f = Just $ FP a RmFile 748 coalesce (DP f RmDir :< Move a b) | b == f = Just $ DP a RmDir 749 coalesce (ChangePref p f1 t1 :< ChangePref p2 f2 t2) | p == p2 && t2 == f1 = Just $ ChangePref p f2 t1 750 coalesce _ = Nothing 751 752 join :: (Prim :> Prim) C(x y) -> Maybe (Prim C(x y)) 753 join (x :> y) = coalesce (y :< x) 754 \end{code} 755 756 \subsection{File patches} 757 758 A file patch is a patch which only modifies a single 759 file. There are some rules which can be made about file patches in 760 general, which makes them a handy class. 761 For example, commutation of two filepatches is trivial if they modify 762 different files. If they happen to 763 modify the same file, we'll have to check whether or not they commutex. 764 \begin{code} 765 commute_filepatches :: CommuteFunction 766 commute_filepatches (FP f1 p1 :< FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :< p2) 767 commute_filepatches _ = Unknown 768 769 commuteFP :: FileName -> (FilePatchType :< FilePatchType) C(x y) 770 -> Perhaps ((Prim :< Prim) C(x y)) 771 commuteFP f (Hunk line1 [] [] :< p2) = 772 seq f $ Succeeded (FP f (unsafeCoerceP p2) :< FP f (Hunk line1 [] [])) 773 commuteFP f (p2 :< Hunk line1 [] []) = 774 seq f $ Succeeded (FP f (Hunk line1 [] []) :< FP f (unsafeCoerceP p2)) 775 commuteFP f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) = seq f $ 776 toPerhaps $ commuteHunk f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) 777 commuteFP f (TokReplace t o n :< Hunk line2 old2 new2) = seq f $ 778 case try_tok_replace t o n old2 of 779 Nothing -> Failed 780 Just old2' -> 781 case try_tok_replace t o n new2 of 782 Nothing -> Failed 783 Just new2' -> Succeeded (FP f (Hunk line2 old2' new2') :< 784 FP f (TokReplace t o n)) 785 commuteFP f (TokReplace t o n :< TokReplace t2 o2 n2) 786 | seq f $ t /= t2 = Failed 787 | o == o2 = Failed 788 | n == o2 = Failed 789 | o == n2 = Failed 790 | n == n2 = Failed 791 | otherwise = Succeeded (FP f (TokReplace t2 o2 n2) :< 792 FP f (TokReplace t o n)) 793 commuteFP _ _ = Unknown 794 795 coalesceFilePrim :: FileName -> (FilePatchType :< FilePatchType) C(x y) 796 -> Maybe (Prim C(x y)) 797 coalesceFilePrim f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) 798 = coalesceHunk f line1 old1 new1 line2 old2 new2 799 -- Token replace patches operating right after (or before) AddFile (RmFile) 800 -- is an identity patch, as far as coalescing is concerned. 801 coalesceFilePrim f (TokReplace _ _ _ :< AddFile) = Just $ FP f AddFile 802 coalesceFilePrim f (RmFile :< TokReplace _ _ _) = Just $ FP f RmFile 803 coalesceFilePrim f (TokReplace t1 o1 n1 :< TokReplace t2 o2 n2) 804 | t1 == t2 && n2 == o1 = Just $ FP f $ TokReplace t1 o2 n1 805 coalesceFilePrim f (Binary m n :< Binary o m') 806 | m == m' = Just $ FP f $ Binary o n 807 coalesceFilePrim _ _ = Nothing 808 \end{code} 809 810 \subsection{Hunks} 811 812 The hunk is the simplest patch that has a commuting pattern in which the 813 commuted patches differ from the originals (rather than simple success or 814 failure). This makes commuting or merging two hunks a tad tedious. 815 \begin{code} 816 commuteHunk :: FileName -> (FilePatchType :< FilePatchType) C(x y) 817 -> Maybe ((Prim :< Prim) C(x y)) 818 commuteHunk f (Hunk line2 old2 new2 :< Hunk line1 old1 new1) 819 | seq f $ line1 + lengthnew1 < line2 = 820 Just (FP f (Hunk line1 old1 new1) :< 821 FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2)) 822 | line2 + lengthold2 < line1 = 823 Just (FP f (Hunk (line1+ lengthnew2 - lengthold2) old1 new1) :< 824 FP f (Hunk line2 old2 new2)) 825 | line1 + lengthnew1 == line2 && 826 lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = 827 Just (FP f (Hunk line1 old1 new1) :< 828 FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2)) 829 | line2 + lengthold2 == line1 && 830 lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = 831 Just (FP f (Hunk (line1 + lengthnew2 - lengthold2) old1 new1) :< 832 FP f (Hunk line2 old2 new2)) 833 | otherwise = seq f Nothing 834 where lengthnew1 = length new1 835 lengthnew2 = length new2 836 lengthold1 = length old1 837 lengthold2 = length old2 838 commuteHunk _ _ = impossible 839 \end{code} 840 Hunks, of course, can be coalesced if they have any overlap. Note that 841 coalesce code doesn't check if the two patches are conflicting. If you are 842 coalescing two conflicting hunks, you've already got a bug somewhere. 843 844 \begin{code} 845 coalesceHunk :: FileName 846 -> Int -> [B.ByteString] -> [B.ByteString] 847 -> Int -> [B.ByteString] -> [B.ByteString] 848 -> Maybe (Prim C(x y)) 849 coalesceHunk f line1 old1 new1 line2 old2 new2 850 | line1 == line2 && lengthold1 < lengthnew2 = 851 if take lengthold1 new2 /= old1 852 then Nothing 853 else case drop lengthold1 new2 of 854 extranew -> Just (FP f (Hunk line1 old2 (new1 ++ extranew))) 855 | line1 == line2 && lengthold1 > lengthnew2 = 856 if take lengthnew2 old1 /= new2 857 then Nothing 858 else case drop lengthnew2 old1 of 859 extraold -> Just (FP f (Hunk line1 (old2 ++ extraold) new1)) 860 | line1 == line2 = if new2 == old1 then Just (FP f (Hunk line1 old2 new1)) 861 else Nothing 862 | line1 < line2 && lengthold1 >= line2 - line1 = 863 case take (line2 - line1) old1 of 864 extra-> coalesceHunk f line1 old1 new1 line1 (extra ++ old2) (extra ++ new2) 865 | line1 > line2 && lengthnew2 >= line1 - line2 = 866 case take (line1 - line2) new2 of 867 extra-> coalesceHunk f line2 (extra ++ old1) (extra ++ new1) line2 old2 new2 868 | otherwise = Nothing 869 where lengthold1 = length old1 870 lengthnew2 = length new2 871 \end{code} 872 873 One of the most important pieces of code is the canonization of a hunk, 874 which is where the ``diff'' algorithm is performed. This algorithm begins 875 with chopping off the identical beginnings and endings of the old and new 876 hunks. This isn't strictly necessary, but is a good idea, since this 877 process is $O(n)$, while the primary diff algorithm is something 878 considerably more painful than that\ldots\ actually the head would be dealt 879 with all right, but with more space complexity. I think it's more 880 efficient to just chop the head and tail off first. 881 882 \begin{code} 883 canonizeHunk :: FileName -> Int 884 -> [B.ByteString] -> [B.ByteString] -> FL Prim C(x y) 885 canonizeHunk f line old new 886 | null old || null new 887 = FP f (Hunk line old new) :>: NilFL 888 canonizeHunk f line old new = make_holey f line $ getChanges old new 889 890 make_holey :: FileName -> Int -> [(Int,[B.ByteString], [B.ByteString])] 891 -> FL Prim C(x y) 892 make_holey f line changes = 893 unsafeMap_l2f (\ (l,o,n) -> FP f (Hunk (l+line) o n)) changes 894 895 try_tok_replace :: String -> String -> String 896 -> [B.ByteString] -> Maybe [B.ByteString] 897 try_tok_replace t o n mss = 898 mapM (fmap B.concat . try_tok_internal t (BC.pack o) (BC.pack n)) mss 899 900 901 try_tok_internal :: String -> B.ByteString -> B.ByteString 902 -> B.ByteString -> Maybe [B.ByteString] 903 try_tok_internal _ o n s | isNothing (substrPS o s) && 904 isNothing (substrPS n s) = Just [s] 905 try_tok_internal t o n s = 906 case BC.break (regChars t) s of 907 (before,s') -> 908 case BC.break (not . regChars t) s' of 909 (tok,after) -> 910 case try_tok_internal t o n after of 911 Nothing -> Nothing 912 Just rest -> 913 if tok == o 914 then Just $ before : n : rest 915 else if tok == n 916 then Nothing 917 else Just $ before : tok : rest 918 919 modernizePrim :: Prim C(x y) -> FL Prim C(x y) 920 modernizePrim (Split ps) = concatFL $ mapFL_FL modernizePrim ps 921 modernizePrim p = p :>: NilFL 922 923 instance MyEq Prim where 924 unsafeCompare (Move a b) (Move c d) = a == c && b == d 925 unsafeCompare (DP d1 p1) (DP d2 p2) 926 = d1 == d2 && p1 `unsafeCompare` p2 927 unsafeCompare (FP f1 fp1) (FP f2 fp2) 928 = f1 == f2 && fp1 `unsafeCompare` fp2 929 unsafeCompare (Split ps1) (Split ps2) 930 = eq_FL unsafeCompare ps1 ps2 931 unsafeCompare (ChangePref a1 b1 c1) (ChangePref a2 b2 c2) 932 = c1 == c2 && b1 == b2 && a1 == a2 933 unsafeCompare Identity Identity = True 934 unsafeCompare _ _ = False 935 936 merge_orders :: Ordering -> Ordering -> Ordering 937 merge_orders EQ x = x 938 merge_orders LT _ = LT 939 merge_orders GT _ = GT 940 941 -- | 'comparePrim' @p1 p2@ is used to provide an arbitrary ordering between 942 -- @p1@ and @p2@. Basically, identical patches are equal and 943 -- @Move < DP < FP < Split < Identity < ChangePref@. 944 -- Everything else is compared in dictionary order of its arguments. 945 comparePrim :: Prim C(x y) -> Prim C(w z) -> Ordering 946 comparePrim (Move a b) (Move c d) = compare (a, b) (c, d) 947 comparePrim (Move _ _) _ = LT 948 comparePrim _ (Move _ _) = GT 949 comparePrim (DP d1 p1) (DP d2 p2) = compare (d1, p1) $ unsafeCoerceP (d2, p2) 950 comparePrim (DP _ _) _ = LT 951 comparePrim _ (DP _ _) = GT 952 comparePrim (FP f1 fp1) (FP f2 fp2) = compare (f1, fp1) $ unsafeCoerceP (f2, fp2) 953 comparePrim (FP _ _) _ = LT 954 comparePrim _ (FP _ _) = GT 955 comparePrim (Split ps1) (Split ps2) = compare_FL comparePrim ps1 $ unsafeCoerceP ps2 956 comparePrim (Split _) _ = LT 957 comparePrim _ (Split _) = GT 958 comparePrim Identity Identity = EQ 959 comparePrim Identity _ = LT 960 comparePrim _ Identity = GT 961 comparePrim (ChangePref a1 b1 c1) (ChangePref a2 b2 c2) 962 = compare (c1, b1, a1) (c2, b2, a2) 963 964 eq_FL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Bool) 965 -> FL a C(x y) -> FL a C(w z) -> Bool 966 eq_FL _ NilFL NilFL = True 967 eq_FL f (x:>:xs) (y:>:ys) = f x y && eq_FL f xs ys 968 eq_FL _ _ _ = False 969 970 compare_FL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Ordering) 971 -> FL a C(x y) -> FL a C(w z) -> Ordering 972 compare_FL _ NilFL NilFL = EQ 973 compare_FL _ NilFL _ = LT 974 compare_FL _ _ NilFL = GT 975 compare_FL f (x:>:xs) (y:>:ys) = f x y `merge_orders` compare_FL f xs ys 976 977 978 class FromPrim p where 979 fromPrim :: Prim C(x y) -> p C(x y) 980 981 class FromPrim p => ToFromPrim p where 982 toPrim :: p C(x y) -> Maybe (Prim C(x y)) 983 984 class FromPrims p where 985 fromPrims :: FL Prim C(x y) -> p C(x y) 986 joinPatches :: FL p C(x y) -> p C(x y) 987 988 instance FromPrim Prim where 989 fromPrim = id 990 instance ToFromPrim Prim where 991 toPrim = Just . id 992 993 instance FromPrim p => FromPrims (FL p) where 994 fromPrims = mapFL_FL fromPrim 995 joinPatches = concatFL 996 instance FromPrim p => FromPrims (RL p) where 997 fromPrims = reverseFL . mapFL_FL fromPrim 998 joinPatches = concatRL . reverseFL 999 1000 class (Invert p, Commute p, Effect p) => Conflict p where 1001 list_conflicted_files :: p C(x y) -> [FilePath] 1002 list_conflicted_files p = 1003 nubsort $ concatMap (unseal list_touched_files) $ concat $ resolve_conflicts p 1004 resolve_conflicts :: p C(x y) -> [[Sealed (FL Prim C(y))]] 1005 resolve_conflicts _ = [] 1006 -- | If 'commute_no_conflicts' @x :> y@ succeeds, we know that that @x@ commutes 1007 -- past @y@ without any conflicts. This function is useful for patch types 1008 -- for which 'commute' is defined to always succeed; so we need some way to 1009 -- pick out the specific cases where commutation succeeds without any conflicts. 1010 -- 1011 -- Consider the commute square with patch names written in capital letters and 1012 -- repository states written in small letters. 1013 -- 1014 -- @ 1015 -- X 1016 -- o-->--a 1017 -- | | 1018 -- Y' v v Y 1019 -- | | 1020 -- z-->--b 1021 -- X' 1022 -- @ 1023 -- 1024 -- The default definition of this function checks that we can mirror the 1025 -- commutation with patch inverses (written with the negative sign) 1026 -- 1027 -- @ 1028 -- -X X 1029 -- a-->--o-->--a 1030 -- | | | 1031 -- Y'' v Y' v v Y 1032 -- | | | 1033 -- b-->--z-->--b 1034 -- (-X)' X' 1035 -- @ 1036 -- 1037 -- 1038 -- We check that commuting @X@ and @Y@ succeeds, as does commuting @-X@ and @Y'@. 1039 -- It also checks that @Y'' == Y@ and that @-(X')@ is the same as @(-X)'@ 1040 commute_no_conflicts :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y)) 1041 commute_no_conflicts (x:>y) = 1042 do y':>x' <- commute (x:>y) 1043 y'':>ix'' <- commute (invert x :> y') 1044 IsEq <- return $ y'' =\/= y 1045 IsEq <- return $ ix'' =\/= invert x' 1046 return (y':>x') 1047 conflictedEffect :: p C(x y) -> [IsConflictedPrim] 1048 conflictedEffect x = case list_conflicted_files x of 1049 [] -> mapFL (IsC Okay) $ effect x 1050 _ -> mapFL (IsC Conflicted) $ effect x 1051 1052 instance Conflict p => Conflict (FL p) where 1053 list_conflicted_files = nubsort . concat . mapFL list_conflicted_files 1054 resolve_conflicts NilFL = [] 1055 resolve_conflicts x = resolve_conflicts $ reverseFL x 1056 commute_no_conflicts (NilFL :> x) = Just (x :> NilFL) 1057 commute_no_conflicts (x :> NilFL) = Just (NilFL :> x) 1058 commute_no_conflicts (xs :> ys) = do ys' :> rxs' <- commute_no_conflictsRLFL (reverseFL xs :> ys) 1059 return $ ys' :> reverseRL rxs' 1060 conflictedEffect = concat . mapFL conflictedEffect 1061 1062 instance Conflict p => Conflict (RL p) where 1063 list_conflicted_files = nubsort . concat . mapRL list_conflicted_files 1064 resolve_conflicts x = rcs x NilFL 1065 where rcs :: RL p C(x y) -> FL p C(y w) -> [[Sealed (FL Prim C(w))]] 1066 rcs NilRL _ = [] 1067 rcs (p:<:ps) passedby | (_:_) <- resolve_conflicts p = 1068 case commute_no_conflictsFL (p:>passedby) of 1069 Just (_:> p') -> resolve_conflicts p' ++ rcs ps (p:>:passedby) 1070 Nothing -> rcs ps (p:>:passedby) 1071 rcs (p:<:ps) passedby = seq passedby $ rcs ps (p:>:passedby) 1072 commute_no_conflicts (NilRL :> x) = Just (x :> NilRL) 1073 commute_no_conflicts (x :> NilRL) = Just (NilRL :> x) 1074 commute_no_conflicts (xs :> ys) = do ys' :> rxs' <- commute_no_conflictsRLFL (xs :> reverseRL ys) 1075 return $ reverseFL ys' :> rxs' 1076 conflictedEffect = concat . reverse . mapRL conflictedEffect 1077 1078 data IsConflictedPrim where 1079 IsC :: !ConflictState -> !(Prim C(x y)) -> IsConflictedPrim 1080 data ConflictState = Okay | Conflicted | Duplicated deriving ( Eq, Ord, Show, Read) 1081 1082 -- | Patches whose concrete effect which can be expressed as a list of 1083 -- primitive patches. 1084 -- 1085 -- A minimal definition would be either of @effect@ or @effectRL@. 1086 class Effect p where 1087 effect :: p C(x y) -> FL Prim C(x y) 1088 effect = reverseRL . effectRL 1089 effectRL :: p C(x y) -> RL Prim C(x y) 1090 effectRL = reverseFL . effect 1091 isHunk :: p C(x y) -> Maybe (Prim C(x y)) 1092 isHunk _ = Nothing 1093 1094 instance Effect Prim where 1095 effect p | IsEq <- sloppyIdentity p = NilFL 1096 | otherwise = p :>: NilFL 1097 effectRL p | IsEq <- sloppyIdentity p = NilRL 1098 | otherwise = p :<: NilRL 1099 isHunk p = if is_hunk p then Just p else Nothing 1100 1101 instance Conflict Prim 1102 1103 instance Effect p => Effect (FL p) where 1104 effect p = concatFL $ mapFL_FL effect p 1105 effectRL p = concatRL $ mapRL_RL effectRL $ reverseFL p 1106 1107 instance Effect p => Effect (RL p) where 1108 effect p = concatFL $ mapFL_FL effect $ reverseRL p 1109 effectRL p = concatRL $ mapRL_RL effectRL p 1110 1111 commute_no_conflictsFL :: Conflict p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y)) 1112 commute_no_conflictsFL (p :> NilFL) = Just (NilFL :> p) 1113 commute_no_conflictsFL (q :> p :>: ps) = do p' :> q' <- commute_no_conflicts (q :> p) 1114 ps' :> q'' <- commute_no_conflictsFL (q' :> ps) 1115 return (p' :>: ps' :> q'') 1116 1117 commute_no_conflictsRL :: Conflict p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y)) 1118 commute_no_conflictsRL (NilRL :> p) = Just (p :> NilRL) 1119 commute_no_conflictsRL (p :<: ps :> q) = do q' :> p' <- commute_no_conflicts (p :> q) 1120 q'' :> ps' <- commute_no_conflictsRL (ps :> q') 1121 return (q'' :> p' :<: ps') 1122 1123 commute_no_conflictsRLFL :: Conflict p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y)) 1124 commute_no_conflictsRLFL (NilRL :> ys) = Just (ys :> NilRL) 1125 commute_no_conflictsRLFL (xs :> NilFL) = Just (NilFL :> xs) 1126 commute_no_conflictsRLFL (xs :> y :>: ys) = do y' :> xs' <- commute_no_conflictsRL (xs :> y) 1127 ys' :> xs'' <- commute_no_conflictsRLFL (xs' :> ys) 1128 return (y' :>: ys' :> xs'') 1129 1130 \end{code}