src/Darcs/Patch/Test.lhs

   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
  19 \begin{code}
  20 {-# OPTIONS_GHC -cpp -fno-warn-deprecations -fglasgow-exts -fno-warn-orphans #-}
  21 {-# LANGUAGE CPP #-}
  22
  23 #include "gadts.h"
  24
  25 module Darcs.Patch.Test
  26              ( prop_read_show,
  27                prop_inverse_composition, prop_commute_twice,
  28                prop_inverse_valid, prop_other_inverse_valid,
  29                prop_commute_equivalency, prop_commute_either_order,
  30                prop_commute_either_way, prop_merge_is_commutable_and_correct,
  31                prop_merge_is_swapable, prop_merge_valid,
  32                prop_unravel_three_merge, prop_unravel_seq_merge,
  33                prop_unravel_order_independent,
  34                prop_simple_smart_merge_good_enough,
  35                prop_elegant_merge_good_enough,
  36                prop_patch_and_inverse_is_identity,
  37                quickmerge, check_patch, check_a_patch, verbose_check_a_patch,
  38                prop_resolve_conflicts_valid,
  39                test_patch, prop_commute_inverse,
  40                subcommutes_inverse, subcommutes_nontrivial_inverse,
  41                subcommutes_failure,
  42                join_patches
  43              ) where
  44
  45 import Prelude hiding ( pi )
  46 import System.IO.Unsafe ( unsafePerformIO )
  47 import Test.QuickCheck
  48 import Control.Monad ( liftM, liftM2, liftM3, liftM4, replicateM )
  49
  50 import Darcs.Patch.Info ( PatchInfo, patchinfo )
  51 import Darcs.Patch.Check ( PatchCheck, Possibly(..),
  52                     check_move, remove_dir, create_dir,
  53                     is_valid, insert_line, file_empty, file_exists,
  54                     delete_line, modify_file, create_file, remove_file,
  55                     do_check, do_verbose_check,
  56                   )
  57 import RegChars ( regChars )
  58 import ByteStringUtils ( linesPS )
  59 import qualified Data.ByteString as B ( ByteString, null, concat )
  60 import qualified Data.ByteString.Char8 as BC ( break, pack )
  61 import Darcs.Patch.FileName ( fn2fp )
  62
  63 import Darcs.Patch.Patchy ( Commute )
  64 import Darcs.Patch ( addfile, adddir, move, showPatch,
  65                      hunk, tokreplace, joinPatches, binary,
  66                      changepref, is_merger, invert, commute, commutex, merge,
  67                      readPatch, resolve_conflicts,
  68                      effect, fromPrims,
  69                      unravel, merger, elegant_merge )
  70 import Darcs.Patch.Core ( Patch(..) )
  71 import Darcs.Patch.Prim ( Prim(..), DirPatchType(..), FilePatchType(..),
  72                           CommuteFunction, Perhaps(..),
  73                           subcommutes )
  74 import Printer ( renderPS )
  75 import Darcs.Ordered
  76 import Darcs.Sealed ( Sealed(Sealed), unsafeUnseal, unseal )
  77
  78 #include "impossible.h"
  79
  80 instance Eq Patch where
  81    x == y = IsEq == (x =\/= y)
  82
  83 instance Eq Prim where
  84    x == y = IsEq == (x =\/= y)
  85
  86 instance (Commute a, MyEq a) => Eq (FL a) where
  87    x == y = IsEq == (x =\/= y)
  88
  89 instance Arbitrary Patch where
  90     arbitrary = sized arbpatch
  91 --    coarbitrary p = coarbitrary (show p)
  92
  93 instance Arbitrary Prim where
  94     arbitrary = onepatchgen
  95 --    coarbitrary = impossible
  96 \end{code}
  97
  98 \begin{code}
  99 hunkgen :: Gen Prim
 100 hunkgen = do
 101   i <- frequency [(1,choose (0,5)),(1,choose (0,35)),
 102                   (2,return 0),(3,return 1),(2,return 2),(1,return 3)]
 103   j <- frequency [(1,choose (0,5)),(1,choose (0,35)),
 104                   (2,return 0),(3,return 1),(2,return 2),(1,return 3)]
 105   if i == 0 && j == 0 then hunkgen
 106     else liftM4 hunk filepathgen linenumgen
 107                 (replicateM i filelinegen)
 108                 (replicateM j filelinegen)
 109
 110 tokreplacegen :: Gen Prim
 111 tokreplacegen = do
 112   f <- filepathgen
 113   o <- tokengen
 114   n <- tokengen
 115   if o == n
 116      then return $ tokreplace f "A-Za-z" "old" "new"
 117      else return $ tokreplace f "A-Za-z_" o n
 118
 119 twofilegen :: (FilePath -> FilePath -> Prim) -> Gen Prim
 120 twofilegen p = do
 121   n1 <- filepathgen
 122   n2 <- filepathgen
 123   if n1 /= n2 && (check_a_patch $ fromPrims $ (p n1 n2 :>: NilFL))
 124      then return $ p n1 n2
 125      else twofilegen p
 126
 127 chprefgen :: Gen Prim
 128 chprefgen = do
 129   f <- oneof [return "color", return "movie"]
 130   o <- tokengen
 131   n <- tokengen
 132   if o == n then return $ changepref f "old" "new"
 133             else return $ changepref f o n
 134
 135 simplepatchgen :: Gen Prim
 136 simplepatchgen = frequency [(1,liftM addfile filepathgen),
 137                             (1,liftM adddir filepathgen),
 138                             (1,liftM3 binary filepathgen arbitrary arbitrary),
 139                             (1,twofilegen move),
 140                             (1,tokreplacegen),
 141                             (1,chprefgen),
 142                             (7,hunkgen)
 143                            ]
 144
 145 onepatchgen :: Gen Prim
 146 onepatchgen = oneof [simplepatchgen, (invert) `fmap` simplepatchgen]
 147
 148 norecursgen :: Int -> Gen Patch
 149 norecursgen 0 = PP `fmap` onepatchgen
 150 norecursgen n = oneof [PP `fmap` onepatchgen,flatcompgen n]
 151
 152 arbpatch :: Int -> Gen Patch
 153 arbpatch 0 = PP `fmap` onepatchgen
 154 arbpatch n = frequency [(3,PP `fmap` onepatchgen),
 155                        -- (1,compgen n),
 156                         (2,flatcompgen n),
 157                         (0,raw_merge_gen n),
 158                         (0,mergegen n),
 159                         (1,PP `fmap` onepatchgen)
 160                        ]
 161
 162 unempty :: Arbitrary a => Gen [a]
 163 unempty = do
 164   as <- arbitrary
 165   case as of
 166     [] -> unempty
 167     _ -> return as
 168
 169 join_patches :: [Patch] -> Patch
 170 join_patches = joinPatches . unsafeFL
 171
 172 raw_merge_gen :: Int -> Gen Patch
 173 raw_merge_gen n = do p1 <- arbpatch len
 174                      p2 <- arbpatch len
 175                      if (check_a_patch $ join_patches [invert p1,p2]) &&
 176                         (check_a_patch $ join_patches [invert p2,p1])
 177                         then case merge (p2 :\/: p1) of
 178                              _ :/\: p2' -> return p2'
 179                         else raw_merge_gen n
 180     where len = if n < 15 then n`div`3 else 3
 181
 182 mergegen :: Int -> Gen Patch
 183 mergegen n = do
 184   p1 <- norecursgen len
 185   p2 <- norecursgen len
 186   if (check_a_patch $ join_patches [invert p1,p2]) &&
 187          (check_a_patch $ join_patches [invert p2,p1])
 188      then case merge (p2:\/:p1) of
 189           p1' :/\: p2' ->
 190               if check_a_patch $ join_patches [p1,p2']
 191               then return $ join_patches [p1,p2']
 192               else return $ join_patches [PP $ addfile "Error_in_mergegen",
 193                                           PP $ addfile "Error_in_mergegen",
 194                                           p1,p2,p1',p2']
 195      else mergegen n
 196   where len = if n < 15 then n`div`3 else 3
 197
 198 arbpi :: Gen PatchInfo
 199 arbpi = do n <- unempty
 200            a <- unempty
 201            l <- unempty
 202            d <- unempty
 203            return $ unsafePerformIO $ patchinfo n d a l
 204
 205 instance Arbitrary PatchInfo where
 206     arbitrary = arbpi
 207 --    coarbitrary pi = coarbitrary (show pi)
 208
 209 instance Arbitrary B.ByteString where
 210     arbitrary = liftM BC.pack arbitrary
 211 --    coarbitrary ps = coarbitrary (unpackPS ps)
 212
 213 {-
 214 plistgen :: Int -> Int -> Gen [Patch]
 215 plistgen s n
 216     | n <= 0 = return []
 217     | otherwise = do
 218                   next <- arbpatch s
 219                   rest <- plistgen s (n-1)
 220                   return $ next : rest
 221
 222 compgen :: Int -> Gen Patch
 223 compgen n = do
 224     size <- choose (0,n)
 225     myp <- liftM join_patches $ plistgen size ((n+1) `div` (size+1))
 226 -- here I assume we only want to consider valid patches...
 227     if check_a_patch myp
 228        then return myp
 229        else compgen n
 230 -}
 231
 232 flatlistgen :: Int -> Gen [Patch]
 233 flatlistgen n = replicateM n (PP `fmap` onepatchgen)
 234
 235 flatcompgen :: Int -> Gen Patch
 236 flatcompgen n = do
 237   myp <- liftM (join_patches . regularize_patches) $ flatlistgen n
 238   if check_a_patch myp
 239      then return myp
 240      else flatcompgen n
 241
 242 -- resize to size 25, that means we'll get line numbers no greater
 243 -- than 1025 using QuickCheck 2.1
 244 linenumgen :: Gen Int
 245 linenumgen = frequency [(1,return 1), (1,return 2), (1,return 3),
 246                     (3,liftM (\n->1+abs n) (resize 25 arbitrary)) ]
 247
 248 tokengen :: Gen String
 249 tokengen = oneof [return "hello", return "world", return "this",
 250                   return "is", return "a", return "silly",
 251                   return "token", return "test"]
 252
 253 toklinegen :: Gen String
 254 toklinegen = liftM unwords $ replicateM 3 tokengen
 255
 256 filelinegen :: Gen B.ByteString
 257 filelinegen = liftM BC.pack $
 258               frequency [(1,map fromSafeChar `fmap` arbitrary),(5,toklinegen),
 259                          (1,return ""), (1,return "{"), (1,return "}") ]
 260
 261 filepathgen :: Gen String
 262 filepathgen = liftM fixpath badfpgen
 263
 264 fixpath :: String -> String
 265 fixpath "" = "test"
 266 fixpath p = fpth p
 267
 268 fpth :: String -> String
 269 fpth ('/':'/':cs) = fpth ('/':cs)
 270 fpth (c:cs) = c : fpth cs
 271 fpth [] = []
 272
 273 newtype SafeChar = SS Char
 274 instance Arbitrary SafeChar where
 275     arbitrary = oneof $ map (return . SS) (['a'..'z']++['A'..'Z']++['1'..'9']++"0")
 276
 277 fromSafeChar :: SafeChar -> Char
 278 fromSafeChar (SS s) = s
 279
 280 badfpgen :: Gen String
 281 badfpgen =  frequency [(1,return "test"), (1,return "hello"), (1,return "world"),
 282                        (1,map fromSafeChar `fmap` arbitrary),
 283                        (1,liftM2 (\a b-> a++"/"++b) filepathgen filepathgen) ]
 284
 285 {-
 286 instance Arbitrary Char where
 287     arbitrary = oneof $ map return
 288                 (['a'..'z']++['A'..'Z']++['1'..'9']++['0','~','.',',','-','/'])
 289 -}
 290 --    coarbitrary c = coarbitrary (ord c)
 291 \end{code}
 292
 293 \begin{code}
 294 check_patch :: Patch -> PatchCheck Bool
 295 check_a_patch :: Patch -> Bool
 296 check_a_patch p = do_check $ do check_patch p
 297                                 check_patch $ invert p
 298 verbose_check_a_patch :: Patch -> Bool
 299 verbose_check_a_patch p = do_verbose_check $ do check_patch p
 300                                                 check_patch $ invert p
 301
 302 check_patch p | is_merger p = do
 303   check_patch $ fromPrims $ effect p
 304 check_patch (Merger _ _ _ _) = impossible
 305 check_patch (Regrem _ _ _ _) = impossible
 306 check_patch (ComP NilFL) = is_valid
 307 check_patch (ComP (p:>:ps)) =
 308   check_patch p >> check_patch (ComP ps)
 309 check_patch (PP Identity) = is_valid
 310 check_patch (PP (Split NilFL)) = is_valid
 311 check_patch (PP (Split (p:>:ps))) =
 312   check_patch (PP p) >> check_patch (PP (Split ps))
 313
 314 check_patch (PP (FP f RmFile)) = remove_file $ fn2fp f
 315 check_patch (PP (FP f AddFile)) =  create_file $ fn2fp f
 316 check_patch (PP (FP f (Hunk line old new))) = do
 317     file_exists $ fn2fp f
 318     mapM (delete_line (fn2fp f) line) old
 319     mapM (insert_line (fn2fp f) line) (reverse new)
 320     is_valid
 321 check_patch (PP (FP f (TokReplace t old new))) =
 322     modify_file (fn2fp f) (try_tok_possibly t old new)
 323 -- note that the above isn't really a sure check, as it leaves PSomethings
 324 -- and PNothings which may have contained new...
 325 check_patch (PP (FP f (Binary o n))) = do
 326     file_exists $ fn2fp f
 327     mapM (delete_line (fn2fp f) 1) (linesPS o)
 328     file_empty $ fn2fp f
 329     mapM (insert_line (fn2fp f) 1) (reverse $ linesPS n)
 330     is_valid
 331
 332 check_patch (PP (DP d AddDir)) = create_dir $ fn2fp d
 333 check_patch (PP (DP d RmDir)) = remove_dir $ fn2fp d
 334
 335 check_patch (PP (Move f f')) = check_move (fn2fp f) (fn2fp f')
 336 check_patch (PP (ChangePref _ _ _)) = return True
 337
 338 regularize_patches :: [Patch] -> [Patch]
 339 regularize_patches patches = rpint [] patches
 340     where rpint ok_ps [] = ok_ps
 341           rpint ok_ps (p:ps) =
 342             if check_a_patch (join_patches $ p:ok_ps)
 343             then rpint (p:ok_ps) ps
 344             else rpint ok_ps ps
 345 \end{code}
 346
 347 \begin{code}
 348 prop_inverse_composition :: Patch -> Patch -> Bool
 349 prop_inverse_composition p1 p2 =
 350     invert (join_patches [p1,p2]) == join_patches [invert p2, invert p1]
 351 prop_inverse_valid :: Patch -> Bool
 352 prop_inverse_valid p1 = check_a_patch $ join_patches [invert p1,p1]
 353 prop_other_inverse_valid :: Patch -> Bool
 354 prop_other_inverse_valid p1 = check_a_patch $ join_patches [p1,invert p1]
 355 \end{code}
 356
 357 \begin{code}
 358 prop_commute_twice :: Patch -> Patch -> Property
 359 prop_commute_twice p1 p2 =
 360     (does_commute p1 p2) ==> (Just (p2:<p1) == (commutex (p2:<p1) >>= commutex))
 361 does_commute :: Patch -> Patch -> Bool
 362 does_commute p1 p2 =
 363     commutex (p2:<p1) /= Nothing && (check_a_patch $ join_patches [p1,p2])
 364 prop_commute_equivalency :: Patch -> Patch -> Property
 365 prop_commute_equivalency p1 p2 =
 366     (does_commute p1 p2) ==>
 367     case commutex (p2:<p1) of
 368     Just (p1':<p2') -> check_a_patch $ join_patches [p1,p2,invert p1',invert p2']
 369     _ -> impossible
 370 \end{code}
 371
 372 \begin{code}
 373 prop_commute_either_way :: Patch -> Patch -> Property
 374 prop_commute_either_way p1 p2 =
 375     does_commute p1 p2 ==> does_commute (invert p2) (invert p1)
 376 \end{code}
 377
 378 \begin{code}
 379 prop_commute_either_order :: Patch -> Patch -> Patch -> Property
 380 prop_commute_either_order p1 p2 p3 =
 381     check_a_patch (join_patches [p1,p2,p3]) &&
 382     does_commute p1 (join_patches [p2,p3]) &&
 383     does_commute p2 p3 ==>
 384     case commutex (p2:<p1) of
 385     Nothing -> False
 386     Just (p1':<p2') ->
 387         case commutex (p3:<p1') of
 388         Nothing -> False
 389         Just (_:<p3') ->
 390             case commutex (p3':<p2') of
 391             Nothing -> False
 392             Just (_:< p3'') ->
 393                 case commutex (p3:<p2) of
 394                 Nothing -> False
 395                 Just (_:<p3'a) ->
 396                     case commutex (p3'a:<p1) of
 397                     Just (_:<p3''a) -> p3''a == p3''
 398                     Nothing -> False
 399 \end{code}
 400
 401 \begin{code}
 402 prop_patch_and_inverse_is_identity :: Patch -> Patch -> Property
 403 prop_patch_and_inverse_is_identity p1 p2 =
 404     (check_a_patch $ join_patches [p1,p2]) && (commutex (p2:<p1) /= Nothing) ==>
 405     case commutex (p2:<p1) of
 406     Just (_:<p2') -> case commutex (p2':<invert p1) of
 407                     Nothing -> True -- This is a subtle distinction.
 408                     Just (_:<p2'') -> p2'' == p2
 409     Nothing -> impossible
 410 \end{code}
 411
 412 \begin{code}
 413 quickmerge :: (Patch :\/: Patch) -> Patch
 414 quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of
 415                         _ :/\: p1' -> p1'
 416 \end{code}
 417
 418 \begin{code}
 419 prop_merge_is_commutable_and_correct :: Patch -> Patch -> Property
 420 prop_merge_is_commutable_and_correct p1 p2 =
 421     (check_a_patch $ join_patches [invert p1,p2]) ==>
 422     case merge (p2:\/:p1) of
 423     p1' :/\: p2' ->
 424         case commutex (p2':<p1) of
 425         Nothing -> False
 426         Just (p1'':<p2'') -> p2'' == p2 && p1' == p1''
 427 prop_merge_is_swapable :: Patch -> Patch -> Property
 428 prop_merge_is_swapable p1 p2 =
 429     (check_a_patch $ join_patches [invert p1,p2]) ==>
 430     case merge (p2:\/:p1) of
 431     p1' :/\: p2' ->
 432            case merge (p1:\/:p2) of
 433            p2''' :/\: p1''' -> p1' == p1''' && p2' == p2'''
 434
 435 prop_merge_valid :: Patch -> Patch -> Property
 436 prop_merge_valid p1 p2 =
 437     (check_a_patch $ join_patches [invert p1,p2]) ==>
 438     case merge (p2:\/:p1) of
 439     _ :/\: p2' ->
 440         check_a_patch $ join_patches [invert p1,p2,invert p2,p1,p2']
 441 \end{code}
 442
 443 \begin{code}
 444 prop_simple_smart_merge_good_enough :: Patch -> Patch -> Property
 445 prop_simple_smart_merge_good_enough p1 p2 =
 446     (check_a_patch $ join_patches [invert p1,p2]) ==>
 447     smart_merge (p2:\/:p1) == simple_smart_merge (p2:\/:p1)
 448
 449 smart_merge :: (Patch :\/: Patch) -> Maybe (Patch :< Patch)
 450 smart_merge (p1 :\/: p2) =
 451   case simple_smart_merge (p1:\/:p2) of
 452   Nothing -> Nothing
 453   Just (p1'a:<p2a) ->
 454       case simple_smart_merge (p2 :\/: p1) >>= commutex of
 455       Nothing -> Nothing
 456       Just (p1'b :< p2b) ->
 457           if p1'a == p1'b && p2a == p2b && p2a == p2
 458           then Just (p1'a :< p2)
 459           else Nothing
 460 simple_smart_merge :: (Patch :\/:  Patch) -> Maybe (Patch :< Patch)
 461 simple_smart_merge (p1 :\/: p2) =
 462   case commutex (p1 :< invert p2) of
 463   Just (_:<p1') ->
 464       case commutex (p1':< p2) of
 465       Just (_:< p1o) ->
 466           if p1o == p1 then Just (p1' :< p2)
 467           else Nothing
 468       Nothing -> Nothing
 469   Nothing -> Nothing
 470
 471 prop_elegant_merge_good_enough :: Patch -> Patch -> Property
 472 prop_elegant_merge_good_enough p1 p2 =
 473     (check_a_patch $ join_patches [invert p1,p2]) ==>
 474     (fst' `fmap` smart_merge (p2:\/:p1)) ==
 475        (snd'' `fmap` elegant_merge (p2:\/:p1))
 476
 477 fst' :: p :< p -> p
 478 fst' (x:<_) = x
 479
 480 snd'' :: q :/\: p -> p
 481 snd'' (_:/\:x) = x
 482
 483 instance Eq p => Eq (p :< p) where
 484    (x:<y) == (x':<y') = x == x' && y == y'
 485
 486 instance Show p => Show (p :< p) where
 487   show (x :< y) = show x ++ " :< " ++ show y
 488 \end{code}
 489
 490 \begin{code}
 491 test_patch :: String
 492 test_patch = test_str ++ test_note
 493 tp1, tp2 :: Patch
 494 tp1 = unsafeUnseal . fst . fromJust . readPatch $ BC.pack "\nmove ./test/test ./hello\n"
 495 tp2 = unsafeUnseal . fst . fromJust . readPatch $ BC.pack "\nmove ./test ./hello\n"
 496 tp1', tp2' :: Patch
 497 tp2' = quickmerge (tp2:\/:tp1)
 498 tp1' = quickmerge (tp1:\/:tp2)
 499 test_note :: String
 500 test_note = (if commutex (tp2':<tp1) == Just (tp1':<tp2)
 501               then "At least they commutex right.\n"
 502               else "Argh! they don't even commutex right.\n")
 503          ++(if check_a_patch $ tp2
 504               then "tp2 itself is valid!\n"
 505               else "Oh my! tp2 isn't even valid!\n")
 506          ++(if check_a_patch $ tp2'
 507               then "tp2' itself is valid!\n"
 508               else "Aaack! tp2' itself is invalid!\n")
 509          ++(if check_a_patch $ join_patches [tp1, tp2']
 510               then "Valid merge tp2'!\n"
 511               else "Bad merge tp2'!\n")
 512          ++ (if check_a_patch $ join_patches [tp2, tp1']
 513               then "Valid merge tp1'!\n"
 514               else "Bad merge tp1'!\n")
 515          ++ (if check_a_patch $ join_patches [tp2,tp1',invert tp2',invert tp1]
 516               then "Both agree!\n"
 517               else "The two merges don't agree!\n")
 518          ++ (if check_a_patch $ join_patches [invert tp2, tp1]
 519               then "They should be mergable!\n"
 520               else "Wait a minute, these guys can't be merged!\n")
 521 tp :: Patch
 522 tp = tp1'
 523
 524 test_str :: String
 525 test_str = "Patches are:\n"++(show tp)
 526            ++(if check_a_patch tp
 527               then "At least the patch itself is valid.\n"
 528               else "The patch itself is bad!\n")
 529            ++"commutex of tp1' and tp2 is "++show (commutex (tp1':<tp2))++"\n"
 530            ++"commutex of tp2' and tp1 is "++show (commutex (tp2':<tp1))++"\n"
 531            {-++ "\nSimply flattened, it is:\n"
 532                   ++ (show $ mapFL (joinPatches.flattenFL.merger_equivalent) $ flattenFL tp)
 533            ++ "\n\nUnravelled, it gives:\n" ++ (show $ map unravel $ flatten tp)
 534            ++ "\n\nUnwound, it gives:\n" ++ (show $ mapFL unwind $ flattenFL tp)
 535            ++(if check_a_patch (join_patches$ reverse $ unwind tp)
 536               then "Unwinding is valid.\n"
 537               else "Bad unwinding!\n")
 538            ++(if check_a_patch $ join_patches [tp,invert tp]
 539               then "Inverse is valid.\n"
 540               else "Bad inverse!\n")
 541            ++(if check_a_patch $ join_patches [invert tp, tp]
 542               then "Other inverse is valid.\n"
 543               else "Bad other inverse!\n")-}
 544 \end{code}
 545
 546 The conflict resolution code (glump) begins by ``unravelling'' the merger
 547 into a set of sequences of patches.  Each sequence of patches corresponds
 548 to one non-conflicted patch that got merged together with the others.  The
 549 result of the unravelling of a series of merges must obviously be
 550 independent of the order in which those merges are performed.  This
 551 unravelling code (which uses the unwind code mentioned above) uses probably
 552 the second most complicated algorithm.  Fortunately, if we can successfully
 553 unravel the merger, almost any function of the unravelled merger satisfies
 554 the two constraints mentioned above that the conflict resolution code must
 555 satisfy.
 556
 557 \begin{code}
 558 prop_unravel_three_merge :: Patch -> Patch -> Patch -> Property
 559 prop_unravel_three_merge p1 p2 p3 =
 560     (check_a_patch $ join_patches [invert p1,p2,invert p2,p3]) ==>
 561     (unravel $ merger "0.0" (merger "0.0" p2 p3) (merger "0.0" p2 p1)) ==
 562     (unravel $ merger "0.0" (merger "0.0" p1 p3) (merger "0.0" p1 p2))
 563 \end{code}
 564 \begin{code}
 565 prop_unravel_seq_merge :: Patch -> Patch -> Patch -> Property
 566 prop_unravel_seq_merge p1 p2 p3 =
 567     (check_a_patch $ join_patches [invert p1,p2,p3]) ==>
 568     (unravel $ merger "0.0" p3 $ merger "0.0" p2 p1) ==
 569     (unravel $ merger "0.0" (merger "0.0" p2 p1) p3)
 570 \end{code}
 571 \begin{code}
 572 prop_unravel_order_independent :: Patch -> Patch -> Property
 573 prop_unravel_order_independent p1 p2 =
 574     (check_a_patch $ join_patches [invert p1,p2]) ==>
 575     (unravel $ merger "0.0" p2 p1) == (unravel $ merger "0.0" p1 p2)
 576 \end{code}
 577
 578 \begin{code}
 579 prop_resolve_conflicts_valid :: Patch -> Patch -> Property
 580 prop_resolve_conflicts_valid p1 p2 =
 581     (check_a_patch $ join_patches [invert p1,p2]) ==>
 582     and $ map (check_a_patch.(\l-> join_patches [p,merge_list l]))
 583             $ resolve_conflicts p
 584         where p = case merge (p1:\/:p2) of
 585                   _ :/\: p1' -> join_patches [p2,p1']
 586
 587 merge_list :: [Sealed (FL Prim C(x))] -> Patch
 588 merge_list patches = fromPrims `unseal` doml NilFL patches
 589     where doml mp (Sealed p:ps) =
 590               case commute (invert p :> mp) of
 591               Just (mp' :> _) -> doml (effect p +>+ effect mp') ps
 592               Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions.
 593           doml mp [] = Sealed mp
 594 \end{code}
 595
 596 \begin{code}
 597 try_tok_possibly :: String -> String -> String
 598                 -> [Possibly B.ByteString] -> Maybe [Possibly B.ByteString]
 599 try_tok_possibly t o n mss =
 600     mapM (silly_maybe_possibly $ liftM B.concat .
 601                     try_tok_internal t (BC.pack o) (BC.pack n))
 602                  $ take 1000 mss
 603
 604 silly_maybe_possibly :: (B.ByteString -> Maybe B.ByteString) ->
 605                         (Possibly B.ByteString -> Maybe (Possibly B.ByteString))
 606 silly_maybe_possibly f =
 607     \px -> case px of
 608            PNothing -> Just PNothing
 609            PSomething -> Just PSomething
 610            PJust x -> case f x of
 611                       Nothing -> Nothing
 612                       Just x' -> Just $ PJust x'
 613
 614 try_tok_internal :: String -> B.ByteString -> B.ByteString
 615                  -> B.ByteString -> Maybe [B.ByteString]
 616 try_tok_internal _ _ _ s | B.null s = Just []
 617 try_tok_internal t o n s =
 618     case BC.break (regChars t) s of
 619     (before,s') ->
 620         case BC.break (not . regChars t) s' of
 621         (tok,after) ->
 622             case try_tok_internal t o n after of
 623             Nothing -> Nothing
 624             Just rest ->
 625                 if tok == o
 626                 then Just $ before : n : rest
 627                 else if tok == n
 628                      then Nothing
 629                      else Just $ before : tok : rest
 630 \end{code}
 631
 632 \begin{code}
 633 prop_read_show :: Patch -> Bool
 634 prop_read_show p = case readPatch $ renderPS $ showPatch p of
 635                    Just (Sealed p',_) -> p' == p
 636                    Nothing -> False
 637 \end{code}
 638
 639 %In order for merges to work right with commuted patches, inverting a patch
 640 %past a patch and its inverse had golly well better give you the same patch
 641 %back again.
 642 \begin{code}
 643 prop_commute_inverse :: Patch -> Patch -> Property
 644 prop_commute_inverse p1 p2 =
 645     does_commute p1 p2 ==> case commutex (p2:< p1) of
 646                            Nothing -> impossible
 647                            Just (p1':<_) ->
 648                                case commutex (invert p2:< p1') of
 649                                Nothing -> False
 650                                Just (p1'':<_) -> p1'' == p1
 651 \end{code}
 652
 653 \begin{code}
 654 subcommutes_inverse :: [(String, Prim -> Prim -> Property)]
 655 subcommutes_inverse = zip names (map prop_subcommute cs)
 656     where (names, cs) = unzip subcommutes
 657           prop_subcommute c p1 p2 =
 658               does c p1 p2 ==>
 659               case c (p2:< p1) of
 660               Succeeded (p1':<p2') ->
 661                   case c (invert p2:< p1') of
 662                   Succeeded (p1'':<ip2x') -> p1'' == p1 &&
 663                       case c (invert p1:< invert p2) of
 664                       Succeeded (ip2':< ip1') ->
 665                           case c (p2':< invert p1) of
 666                           Succeeded (ip1o':< p2o) ->
 667                               invert ip1' == p1' && invert ip2' == p2' &&
 668                               ip1o' == ip1' && p2o == p2 &&
 669                               p1'' == p1 && ip2x' == ip2'
 670                           _ -> False
 671                       _ -> False
 672                   _ -> False
 673               _ -> False
 674
 675 subcommutes_nontrivial_inverse :: [(String, Prim -> Prim -> Property)]
 676 subcommutes_nontrivial_inverse = zip names (map prop_subcommute cs)
 677     where (names, cs) = unzip subcommutes
 678           prop_subcommute c p1 p2 =
 679               nontrivial c p1 p2 ==>
 680               case c (p2:< p1) of
 681               Succeeded (p1':<p2') ->
 682                   case c (invert p2:< p1') of
 683                   Succeeded (p1'':<ip2x') -> p1'' == p1 &&
 684                       case c (invert p1:< invert p2) of
 685                       Succeeded (ip2':< ip1') ->
 686                           case c (p2':< invert p1) of
 687                           Succeeded (ip1o':< p2o) ->
 688                               invert ip1' == p1' && invert ip2' == p2' &&
 689                               ip1o' == ip1' && p2o == p2 &&
 690                               p1'' == p1 && ip2x' == ip2'
 691                           _ -> False
 692                       _ -> False
 693                   _ -> False
 694               _ -> False
 695
 696 subcommutes_failure :: [(String, Prim -> Prim -> Property)]
 697 subcommutes_failure = zip names (map prop cs)
 698     where (names, cs) = unzip subcommutes
 699           prop c p1 p2 =
 700               does_fail c p1 p2 ==> case c (invert p1 :< invert p2) of
 701                                     Failed -> True
 702                                     _ -> False
 703
 704 does_fail :: CommuteFunction -> Prim -> Prim -> Bool
 705 does_fail c p1 p2 =
 706     fails (c (p2:<p1)) && (check_a_patch $ fromPrims $ unsafeFL [p1,p2])
 707         where fails Failed = True
 708               fails _ = False
 709
 710 does :: CommuteFunction -> Prim -> Prim -> Bool
 711 does c p1 p2 =
 712     succeeds (c (p2:<p1)) && (check_a_patch $ fromPrims $ unsafeFL [p1,p2])
 713         where succeeds (Succeeded _) = True
 714               succeeds _ = False
 715
 716 nontrivial :: CommuteFunction -> Prim -> Prim -> Bool
 717 nontrivial c p1 p2 =
 718     succeeds (c (p2:<p1)) && (check_a_patch $ fromPrims $ unsafeFL [p1,p2])
 719         where succeeds (Succeeded (p1' :< p2')) = p1' /= p1 || p2' /= p2
 720               succeeds _ = False
 721 \end{code}
 722