src/unit.lhs

   1 %  Copyright (C) 2002-2005,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 \documentclass{report}
  19 \usepackage{color}
  20
  21 \usepackage{verbatim}
  22 \newenvironment{code}{\color{blue}\verbatim}{\endverbatim}
  23
  24 \begin{document}
  25
  26 % Definition of title page:
  27 \title{
  28     Unit Testing for darcs in Haskell
  29 }
  30 \author{
  31     David Roundy    % insert author(s) here
  32 }
  33
  34 \maketitle
  35
  36 \tableofcontents  % Table of Contents
  37
  38 \chapter{Introduction}
  39
  40 This is a unit testing program, which is intended to make sure that all the
  41 functions of my darcs code work properly.
  42
  43 \begin{code}
  44 {-# OPTIONS_GHC -cpp -fno-warn-orphans -fno-warn-deprecations -fglasgow-exts #-}
  45 {-# LANGUAGE CPP #-}
  46
  47 module Main (main) where
  48 \end{code}
  49
  50 \begin{code}
  51 import Control.Monad (when)
  52 import System.IO.Unsafe ( unsafePerformIO )
  53 import ByteStringUtils
  54 import qualified Data.ByteString.Char8 as BC ( unpack, pack )
  55 import qualified Data.ByteString as B ( empty, concat )
  56 import Darcs.Patch
  57 import Darcs.Patch.Test
  58 import Darcs.Patch.Unit ( run_patch_unit_tests )
  59 import Lcs ( shiftBoundaries )
  60 import Test.QuickCheck
  61 import System ( ExitCode(..), exitWith )
  62 import System.IO ( hSetBuffering, stdout, BufferMode(..) )
  63 import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )
  64 import Printer ( renderPS, text )
  65 import Darcs.Patch.Commute
  66 import Data.Array.Base
  67 import Data.Array.Unboxed
  68 import Control.Monad.ST
  69 import Darcs.Ordered
  70 import Darcs.Sealed ( Sealed(Sealed), unsafeUnseal )
  71
  72 import Darcs.Email ( make_email, read_email )
  73 #include "impossible.h"
  74 \end{code}
  75
  76 \chapter{Main body of code}
  77
  78 \begin{code}
  79 main :: IO ()
  80 main = do
  81   hSetBuffering stdout NoBuffering
  82   returnval <- newIORef 0
  83   patch_failures <- run_patch_unit_tests
  84   if patch_failures > 0
  85       then do putStrLn $ show patch_failures ++ " failures in Darcs.Patch.Unit."
  86               exitWith $ ExitFailure 1
  87       else putStrLn "No failures in Darcs.Patch.Unit."
  88   when (unpackPSfromUTF8 (BC.pack "hello world") /= "hello world") $
  89        do putStr "Problem with unpackPSfromUTF8\n"
  90           putStr $ "hello world isn't '" ++
  91                  unpackPSfromUTF8 (BC.pack "hello world")++"'\n"
  92           exitWith $ ExitFailure 1
  93   when (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world")
  94         /= "hello world") $
  95        do putStr "Problem with binary to hex conversion and back again\n"
  96           exitWith $ ExitFailure 1
  97   putStr "Checking that email can be parsed... "
  98   quickCheck $ \s ->
  99       unlines ("":s++["", ""]) ==
 100               BC.unpack (read_email (renderPS
 101                        $ make_email "reponame" (Just (text "contents\n"))
 102                        (text $ unlines s) (Just "filename")))
 103   --putStr $ test_patch
 104   --exitWith ExitSuccess
 105   case run_tests returnval of
 106     run -> do
 107       putStr ("There are a total of "++(show (length primitive_test_patches))
 108               ++" primitive patches.\n")
 109       putStr ("There are a total of "++
 110               (show (length test_patches))++" patches.\n")
 111       putStr "Checking that B.concat works... "
 112       quickCheck prop_concatPS
 113       putStr "Checking that hex conversion works... "
 114       quickCheck prop_hex_conversion
 115       putStr "Checking that show and read work right... "
 116       quickCheck prop_read_show
 117       run "Checking known commutes... " commute_tests
 118       run "Checking known merges... " merge_tests
 119       run "Checking known canons... " canonization_tests
 120       check_subcommutes subcommutes_inverse "patch and inverse both commutex"
 121       check_subcommutes subcommutes_nontrivial_inverse
 122                             "nontrivial commutes are correct"
 123       check_subcommutes subcommutes_failure "inverses fail"
 124       putStr "Checking that commuting by patch and its inverse is ok... "
 125       quickCheck prop_commute_inverse
 126       --putStr "Checking that conflict resolution is valid... "
 127       --quickCheck prop_resolve_conflicts_valid
 128       putStr "Checking that a patch followed by its inverse is identity... "
 129       quickCheck prop_patch_and_inverse_is_identity
 130       -- The following tests are "wrong" with the Conflictor code.
 131       --putStr "Checking that a simple smart_merge is sufficient... "
 132       --quickCheck prop_simple_smart_merge_good_enough
 133       --putStr "Checking that an elegant merge is sufficient... "
 134       --quickCheck prop_elegant_merge_good_enough
 135       putStr "Checking that commutes are equivalent... "
 136       quickCheck prop_commute_equivalency
 137       putStr "Checking that merges are valid... "
 138       quickCheck prop_merge_valid
 139       putStr "Checking inverses being valid... "
 140       quickCheck prop_inverse_valid
 141       putStr "Checking other inverse being valid... "
 142       quickCheck prop_other_inverse_valid
 143       run "Checking merge swaps... " merge_swap_tests
 144       -- The patch generator isn't smart enough to generate correct test
 145       -- cases for the following: (which will be obsoleted soon, anyhow)
 146       --putStr "Checking the order dependence of unravel... "
 147       --quickCheck prop_unravel_order_independent
 148       --putStr "Checking the unravelling of three merges... "
 149       --quickCheck prop_unravel_three_merge
 150       --putStr "Checking the unravelling of a merge of a sequence... "
 151       --quickCheck prop_unravel_seq_merge
 152       putStr "Checking inverse of inverse... "
 153       quickCheck prop_inverse_composition
 154       putStr "Checking the order of commutes... "
 155       quickCheck prop_commute_either_order
 156       putStr "Checking commutex either way... "
 157       quickCheck prop_commute_either_way
 158       putStr "Checking the double commutex... "
 159       quickCheck prop_commute_twice
 160       putStr "Checking that merges commutex and are well behaved... "
 161       quickCheck prop_merge_is_commutable_and_correct
 162       putStr "Checking that merges can be swapped... "
 163       quickCheck prop_merge_is_swapable
 164       putStr "Checking again that merges can be swapped (I'm paranoid) ... "
 165       quickCheck prop_merge_is_swapable
 166       run "Checking that the patch validation works... " test_check
 167       run "Checking commutex/recommute... " commute_recommute_tests
 168       run "Checking merge properties... " generic_merge_tests
 169       run "Testing the lcs code... " show_lcs_tests
 170       run "Checking primitive patch IO functions... " primitive_show_read_tests
 171       run "Checking IO functions... " show_read_tests
 172       run "Checking primitive commutex/recommute... "
 173           primitive_commute_recommute_tests
 174       trv <- readIORef returnval
 175       if trv == 0
 176          then exitWith ExitSuccess
 177          else exitWith $ ExitFailure trv
 178 \end{code}
 179
 180 \section{run\_tests}
 181
 182 run\_tests is used to run a series of tests (which return a list of strings
 183 describing their failures) and then update n IORef so the program can exit
 184 with an error if one of the tests failed.
 185
 186 \begin{code}
 187 run_tests :: (IORef Int) -> String -> [String] -> IO ()
 188 run_tests return_val s ss = do
 189     putStr s
 190     if null ss
 191        then putStr "good.\n"
 192        else do modifyIORef return_val (+1)
 193                print_strings ss
 194                exitWith $ ExitFailure 1
 195
 196 print_strings :: [String] -> IO ()
 197 print_strings [] = return ()
 198 print_strings (s:ss) = do
 199   putStr s
 200   print_strings ss
 201 \end{code}
 202
 203 \chapter{Unit Tester}
 204
 205 The unit tester function is really just a glorified map for functions that
 206 return lists, in which the lists get concatenated (where map would end up
 207 with a list of lists).
 208
 209 \begin{code}
 210 type PatchUnitTest p = p -> [String]
 211 type TwoPatchUnitTest = Patch -> Patch -> [String]
 212 unit_tester :: PatchUnitTest p -> [p] -> [String]
 213 unit_tester _ []        = []
 214 unit_tester thetest (p:ps) = (thetest p)++(unit_tester thetest ps)
 215
 216 parallel_pair_unit_tester :: TwoPatchUnitTest -> [(Patch:\/:Patch)] -> [String]
 217 parallel_pair_unit_tester _ []        = []
 218 parallel_pair_unit_tester thetest ((p1:\/:p2):ps)
 219     = (thetest p1 p2)++(parallel_pair_unit_tester thetest ps)
 220
 221 pair_unit_tester :: TwoPatchUnitTest -> [(Patch:<Patch)] -> [String]
 222 pair_unit_tester _ []        = []
 223 pair_unit_tester thetest ((p1:<p2):ps)
 224     = (thetest p1 p2)++(pair_unit_tester thetest ps)
 225 \end{code}
 226
 227 \chapter{LCS}
 228
 229 Here are a few quick tests of the shiftBoundaries function.
 230
 231 \begin{code}
 232 show_lcs_tests :: [String]
 233 show_lcs_tests = concatMap check_known_shifts known_shifts
 234 check_known_shifts :: ([Int],[Int],String,String,[Int],[Int])
 235                    -> [String]
 236 check_known_shifts (ca, cb, sa, sb, ca', cb') = runST (
 237     do ca_arr <- newListArray (0, length ca) $ toBool (0:ca)
 238        cb_arr <- newListArray (0, length cb) $ toBool (0:cb)
 239        let p_a = listArray (0, length sa) $ B.empty:(toPS sa)
 240            p_b = listArray (0, length sb) $ B.empty:(toPS sb)
 241        shiftBoundaries ca_arr cb_arr p_a 1 1
 242        shiftBoundaries cb_arr ca_arr p_b 1 1
 243        ca_res <- fmap (fromBool . tail) $ getElems ca_arr
 244        cb_res <- fmap (fromBool . tail) $ getElems cb_arr
 245        return $ if ca_res  == ca' && cb_res == cb' then []
 246                 else ["shiftBoundaries failed on "++sa++" and "++sb++" with "
 247                       ++(show (ca,cb))++" expected "++(show (ca', cb'))
 248                       ++" got "++(show (ca_res, cb_res))++"\n"])
 249  where toPS = map (\c -> if c == ' ' then B.empty else BC.pack [c])
 250        toBool = map (>0)
 251        fromBool = map (\b -> if b then 1 else 0)
 252
 253 known_shifts :: [([Int],[Int],String,String,[Int],[Int])]
 254 known_shifts =
 255   [([0,0,0],[0,1,0,1,0],"aaa","aaaaa",
 256     [0,0,0],[0,0,0,1,1]),
 257    ([0,1,0],[0,1,1,0],"cd ","c a ",
 258     [0,1,0],[0,1,1,0]),
 259    ([1,0,0,0,0,0,0,0,0],[1,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","dg{} ih{} if{}",
 260     [1,0,0,0,0,0,0,0,0],[1,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end
 261    ([0,0,0,0,0,0,0,0,0],[0,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","fg{} ih{} if{}",
 262     [0,0,0,0,0,0,0,0,0],[0,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end
 263    ([],[1,1],"","aa",[],[1,1]),
 264    ([1,1],[],"aa","",[1,1],[])]
 265
 266
 267 \end{code}
 268
 269 \chapter{Show/Read tests}
 270
 271 This test involves calling ``show'' to print a string describing a patch,
 272 and then using readPatch to read it back in, and making sure the patch we
 273 read in is the same as the original.  Useful for making sure that I don't
 274 have any stupid IO bugs.
 275
 276 \begin{code}
 277 show_read_tests :: [String]
 278 show_read_tests = unit_tester t_show_read test_patches ++
 279                   unit_tester t_show_read test_patches_named
 280 primitive_show_read_tests :: [String]
 281 primitive_show_read_tests = unit_tester t_show_read primitive_test_patches
 282 t_show_read :: (Eq p, Show p, Patchy p) => PatchUnitTest p
 283 t_show_read p =
 284     case readPatch $ renderPS $ showPatch p of
 285     Just (Sealed p',_) -> if p' == p then []
 286                           else ["Failed to read shown:  "++(show p)++"\n"]
 287     Nothing -> ["Failed to read at all:  "++(show p)++"\n"]
 288
 289 instance MyEq p => Eq (Named p) where
 290     (==) = unsafeCompare
 291 \end{code}
 292
 293 \chapter{Canonization tests}
 294
 295 This is a set of known correct canonizations, to make sure that I'm
 296 canonizing as I ought.
 297
 298 \begin{code}
 299 canonization_tests :: [String]
 300 canonization_tests = concatMap check_known_canon known_canons
 301 check_known_canon :: (Patch, Patch) -> [String]
 302 check_known_canon (p1,p2) =
 303     if (fromPrims $ concatFL $ mapFL_FL canonize $ sort_coalesceFL $ effect p1) == p2
 304     then []
 305     else ["Canonization failed:\n"++show p1++"canonized is\n"
 306           ++show (fromPrims $ concatFL $ mapFL_FL canonize $ sort_coalesceFL $ effect p1 :: Patch)
 307           ++"which is not\n"++show p2]
 308 known_canons :: [(Patch,Patch)]
 309 known_canons =
 310     [(quickhunk 1 "abcde" "ab",  quickhunk 3 "cde"   ""),
 311      (quickhunk 1 "abcde" "bd", join_patches [quickhunk 1 "a" "",
 312                                               quickhunk 2 "c" "",
 313                                               quickhunk 3 "e" ""]),
 314      (join_patches [quickhunk 4 "a" "b",
 315                     quickhunk 1 "c" "d"],
 316       join_patches [quickhunk 1 "c" "d",
 317                     quickhunk 4 "a" "b"]),
 318      (join_patches [quickhunk 1 "a" "",
 319                     quickhunk 1 "" "b"],
 320       quickhunk 1 "a" "b"),
 321      (join_patches [quickhunk 1 "ab" "c",
 322                     quickhunk 1 "cd" "e"],
 323       quickhunk 1 "abd" "e"),
 324      (quickhunk 1 "abcde" "cde", quickhunk 1 "ab" ""),
 325      (quickhunk 1 "abcde" "acde", quickhunk 2 "b" "")]
 326 quickhunk :: Int -> String -> String -> Patch
 327 quickhunk l o n = fromPrim $ hunk "test" l (map (\c -> BC.pack [c]) o)
 328                                              (map (\c -> BC.pack [c]) n)
 329 \end{code}
 330
 331 \chapter{Merge/unmgerge tests}
 332
 333 It should always be true that if two patches can be unmerged, then merging
 334 the resulting patches should give them back again.
 335 \begin{code}
 336 generic_merge_tests :: [String]
 337 generic_merge_tests =
 338   case take 400 [(p1:\/:p2)|
 339                  i <- [0..(length test_patches)-1],
 340                  p1<-[test_patches!!i],
 341                  p2<-drop i test_patches,
 342                  check_a_patch $ join_patches [invert p2,p1]] of
 343   merge_pairs -> (parallel_pair_unit_tester t_merge_either_way_valid merge_pairs) ++
 344                  (parallel_pair_unit_tester t_merge_swap_merge merge_pairs)
 345 t_merge_either_way_valid   :: TwoPatchUnitTest
 346 t_merge_either_way_valid p1 p2 =
 347   case join_patches [p2, quickmerge (p1:\/: p2)] of
 348   combo2 ->
 349     case join_patches [p1, quickmerge (p2:\/: p1)] of
 350     combo1 ->
 351       if not $ check_a_patch $ join_patches [combo1]
 352       then ["oh my combo1 invalid:\n"++show p1++"and...\n"++show p2++show combo1]
 353       else
 354         if check_a_patch $ join_patches [invert combo1, combo2]
 355         then []
 356         else ["merge both ways invalid:\n"++show p1++"and...\n"++show p2++
 357               show combo1++
 358               show combo2]
 359 t_merge_swap_merge   :: TwoPatchUnitTest
 360 t_merge_swap_merge p1 p2 =
 361   if (swapp $ merge (p2:\/: p1)) == merge (p1:\/:p2)
 362   then []
 363   else ["Failed to swap merges:\n"++show p1++"and...\n"++show p2
 364         ++"merged:\n"++show (merge (p1:\/:p2))++"\n"
 365         ++"merged and swapped:\n"++show (swapp $ merge (p2:\/: p1))++"\n"]
 366     where swapp (x :/\: y) = y :/\: x
 367
 368 instance Show p => Show (p :/\: p) where
 369    show (x :/\: y) = show x ++ " :/\\: " ++ show y
 370 instance Eq p => Eq (p :/\: p) where
 371    (x :/\: y) == (x' :/\: y') = x == x' && y == y'
 372 \end{code}
 373
 374 \chapter{Commute/recommute tests}
 375
 376 Here we test to see if commuting patch A and patch B and then commuting the
 377 result gives us patch A and patch B again.  The set of patches (A,B) is
 378 chosen from the set of all pairs of test patches by selecting those which
 379 commutex with one another.
 380
 381 \begin{code}
 382 commute_recommute_tests :: [String]
 383 commute_recommute_tests =
 384   case take 200 [(p2:<p1)|
 385                  p1<-test_patches,
 386                  p2<-filter (\p->checkseq [p1,p]) test_patches,
 387                  commutex (p2:<p1) /= Nothing] of
 388   commute_pairs -> pair_unit_tester t_commute_recommute commute_pairs
 389   where checkseq ps = check_a_patch $ join_patches ps
 390 primitive_commute_recommute_tests :: [String]
 391 primitive_commute_recommute_tests =
 392   pair_unit_tester t_commute_recommute
 393     [(p1:<p2)|
 394      p1<-primitive_test_patches,
 395      p2<-primitive_test_patches,
 396      commutex (p1:<p2) /= Nothing,
 397      check_a_patch $ join_patches [p2,p1]]
 398 t_commute_recommute   :: TwoPatchUnitTest
 399 t_commute_recommute p1 p2 =
 400     if (commutex (p1:<p2) >>= commutex) == Just (p1:<p2)
 401        then []
 402        else ["Failed to recommute:\n"++(show p1)++(show p2)++
 403             "we saw it as:\n"++show (commutex (p1:<p2))++
 404              "\nAnd recommute was:\n"++show (commutex (p1:<p2) >>= commutex)
 405              ++ "\n"]
 406 \end{code}
 407
 408 \chapter{Commute tests}
 409
 410 Here we provide a set of known interesting commutes.
 411 \begin{code}
 412 commute_tests :: [String]
 413 commute_tests =
 414     concatMap check_known_commute known_commutes++
 415     concatMap check_cant_commute known_cant_commute
 416 check_known_commute :: (Patch:< Patch, Patch:< Patch) -> [String]
 417 check_known_commute (p1:<p2,p2':<p1') =
 418    case commutex (p1:<p2) of
 419    Just (p2a:<p1a) ->
 420        if (p2a:< p1a) == (p2':< p1')
 421        then []
 422        else ["Commute gave wrong value!\n"++show p1++"\n"++show p2
 423              ++"should be\n"++show p2'++"\n"++show p1'
 424              ++"but is\n"++show p2a++"\n"++show p1a]
 425    Nothing -> ["Commute failed!\n"++show p1++"\n"++show p2]
 426    ++
 427    case commutex (p2':<p1') of
 428    Just (p1a:<p2a) ->
 429        if (p1a:< p2a) == (p1:< p2)
 430        then []
 431        else ["Commute gave wrong value!\n"++show p2a++"\n"++show p1a
 432              ++"should have been\n"++show p2'++"\n"++show p1']
 433    Nothing -> ["Commute failed!\n"++show p2'++"\n"++show p1']
 434 known_commutes :: [(Patch:<Patch,Patch:<Patch)]
 435 known_commutes = [
 436                   (testhunk 1 [] ["A"]:<
 437                    testhunk 2 [] ["B"],
 438                    testhunk 3 [] ["B"]:<
 439                    testhunk 1 [] ["A"]),
 440                   (fromPrim (tokreplace "test" "A-Za-z_" "old" "new"):<
 441                    testhunk 2
 442                    ["hello world all that is old is good old_"]
 443                    ["I don't like old things"],
 444                    testhunk 2
 445                    ["hello world all that is new is good old_"]
 446                    ["I don't like new things"]:<
 447                    fromPrim (tokreplace "test" "A-Za-z_" "old" "new")),
 448                   (testhunk 1 ["A"] ["B"]:<
 449                    testhunk 2 ["C"] ["D"],
 450                    testhunk 2 ["C"] ["D"]:<
 451                    testhunk 1 ["A"] ["B"]),
 452                   (fromPrim (rmfile "NwNSO"):<
 453                    (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))),
 454                    (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))):<
 455                    fromPrim (rmfile "NwNSO")),
 456
 457                   (quickmerge (testhunk 3 ["o"] ["n"]:\/:
 458                                testhunk 3 ["o"] ["v"]):<
 459                    testhunk 1 [] ["a"],
 460                    testhunk 1 [] ["a"]:<
 461                    quickmerge (testhunk 2 ["o"] ["n"]:\/:
 462                                testhunk 2 ["o"] ["v"])),
 463
 464                   (testhunk 1 ["A"] []:<
 465                    testhunk 3 ["B"] [],
 466                    testhunk 2 ["B"] []:<
 467                    testhunk 1 ["A"] []),
 468
 469                   (testhunk 1 ["A"] ["B"]:<
 470                    testhunk 2 ["B"] ["C"],
 471                    testhunk 2 ["B"] ["C"]:<
 472                    testhunk 1 ["A"] ["B"]),
 473
 474                   (testhunk 1 ["A"] ["B"]:<
 475                    testhunk 3 ["B"] ["C"],
 476                    testhunk 3 ["B"] ["C"]:<
 477                    testhunk 1 ["A"] ["B"]),
 478
 479                   (testhunk 1 ["A"] ["B","C"]:<
 480                    testhunk 2 ["B"] ["C","D"],
 481                    testhunk 3 ["B"] ["C","D"]:<
 482                    testhunk 1 ["A"] ["B","C"])]
 483   where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)
 484
 485 check_cant_commute :: (Patch:< Patch) -> [String]
 486 check_cant_commute (p1:<p2) =
 487     case commutex (p1:<p2) of
 488     Nothing -> []
 489     _ -> [show p1 ++ "\n\n" ++ show p2 ++
 490           "\nArgh, these guys shouldn't commutex!\n"]
 491 known_cant_commute :: [(Patch:< Patch)]
 492 known_cant_commute = [
 493                       (testhunk 2 ["o"] ["n"]:<
 494                        testhunk 1 [] ["A"]),
 495                       (testhunk 1 [] ["A"]:<
 496                        testhunk 1 ["o"] ["n"]),
 497                       (quickmerge (testhunk 2 ["o"] ["n"]:\/:
 498                                    testhunk 2 ["o"] ["v"]):<
 499                        testhunk 1 [] ["a"]),
 500                       (fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])):<
 501                        fromPrim (addfile "test"))]
 502   where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)
 503 \end{code}
 504
 505 \chapter{Merge tests}
 506
 507 Here we provide a set of known interesting merges.
 508 \begin{code}
 509 merge_tests :: [String]
 510 merge_tests =
 511     concatMap check_known_merge_equiv known_merge_equivs++
 512     concatMap check_known_merge known_merges
 513 check_known_merge :: (Patch:\/: Patch, Patch:< Patch) -> [String]
 514 check_known_merge (p1:\/:p2,p1':<p2') =
 515    case merge (p1:\/:p2) of
 516    _ :/\: p1a ->
 517        if (p1a:< p2) == (p1':< p2')
 518        then []
 519        else ["Merge gave wrong value!\n"++show p1++show p2
 520              ++"I expected\n"++show p1'++show p2'
 521              ++"but found instead\n"++show p1a]
 522 known_merges :: [(Patch:\/:Patch,Patch:<Patch)]
 523 known_merges = [
 524                 (testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"]:\/:
 525                  testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"],
 526                  testhunk 3 [BC.pack "c"] [BC.pack "d",BC.pack "e"]:<
 527                  testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]),
 528                 (testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]:\/:
 529                  testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"],
 530                  testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]:<
 531                  testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"]),
 532                 (testhunk 3 [BC.pack "A"] []:\/:
 533                  testhunk 1 [BC.pack "B"] [],
 534                  testhunk 2 [BC.pack "A"] []:<
 535                  testhunk 1 [BC.pack "B"] []),
 536                 (fromPrim (rmdir "./test/world"):\/:
 537                  fromPrim (hunk "./world" 3 [BC.pack "A"] []),
 538                  fromPrim (rmdir "./test/world"):<
 539                  fromPrim (hunk "./world" 3 [BC.pack "A"] [])),
 540
 541                 (join_patches [quickhunk 1 "a" "bc",
 542                                quickhunk 6 "d" "ef"]:\/:
 543                  join_patches [quickhunk 3 "a" "bc",
 544                                quickhunk 8 "d" "ef"],
 545                  join_patches [quickhunk 1 "a" "bc",
 546                                quickhunk 7 "d" "ef"]:<
 547                  join_patches [quickhunk 3 "a" "bc",
 548                                quickhunk 8 "d" "ef"]),
 549
 550                 (testhunk 1 [BC.pack "A"] [BC.pack "B"]:\/:
 551                  testhunk 2 [BC.pack "B"] [BC.pack "C"],
 552                  testhunk 1 [BC.pack "A"] [BC.pack "B"]:<
 553                  testhunk 2 [BC.pack "B"] [BC.pack "C"]),
 554
 555                 (testhunk 2 [BC.pack "A"] [BC.pack "B",BC.pack "C"]:\/:
 556                  testhunk 1 [BC.pack "B"] [BC.pack "C",BC.pack "D"],
 557                  testhunk 3 [BC.pack "A"] [BC.pack "B",BC.pack "C"]:<
 558                  testhunk 1 [BC.pack "B"] [BC.pack "C",BC.pack "D"])]
 559   where testhunk l o n = fromPrim $ hunk "test" l o n
 560 check_known_merge_equiv :: (Patch:\/:Patch,Patch) -> [String]
 561 check_known_merge_equiv (p1:\/: p2, pe) =
 562     case quickmerge (p1:\/:p2) of
 563     p1' -> if check_a_patch $ join_patches [invert p1, p2, p1', invert pe]
 564            then []
 565            else ["Oh no, merger isn't equivalent...\n"++show p1++"\n"++show p2
 566                  ++"in other words\n" ++ show (p1 :\/: p2)
 567                  ++"merges as\n" ++ show (merge $ p1 :\/: p2)
 568                  ++"merges to\n" ++ show (quickmerge $ p1 :\/: p2)
 569                  ++"which is equivalent to\n" ++ show (effect p1')
 570                  ++ "should all work out to\n"
 571                  ++ show pe]
 572 known_merge_equivs :: [(Patch:\/: Patch, Patch)]
 573 known_merge_equivs = [
 574
 575                      -- The following tests are going to be failed by the
 576                      -- Conflictor code as a cleanup.
 577
 578                      --(addfile "test":\/:
 579                      -- adddir "test",
 580                      -- join_patches [adddir "test",
 581                      --               addfile "test-conflict"]),
 582                      --(move "silly" "test":\/:
 583                      -- adddir "test",
 584                      -- join_patches [adddir "test",
 585                      --               move "silly" "test-conflict"]),
 586                      --(addfile "test":\/:
 587                      -- move "old" "test",
 588                      -- join_patches [addfile "test",
 589                      --               move "old" "test-conflict"]),
 590                      --(move "a" "test":\/:
 591                      -- move "old" "test",
 592                      -- join_patches [move "a" "test",
 593                      --               move "old" "test-conflict"]),
 594                      (fromPrim (hunk "test" 1 [] [BC.pack "A"]):\/:
 595                       fromPrim (hunk "test" 1 [] [BC.pack "B"]),
 596                       fromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])),
 597                      (fromPrim (hunk "test" 1 [] [BC.pack "a"]):\/:
 598                       fromPrim (hunk "test" 1 [BC.pack "b"] []),
 599                       identity),
 600                       --hunk "test" 1 [] [BC.pack "v v v v v v v",
 601                       --                  BC.pack "*************",
 602                       --                  BC.pack "a",
 603                       --                  BC.pack "b",
 604                       --                  BC.pack "^ ^ ^ ^ ^ ^ ^"]),
 605                      (quickhunk 4 "a"  "":\/:
 606                       quickhunk 3 "a"  "",
 607                       quickhunk 3 "aa" ""),
 608                      (join_patches [quickhunk 1 "a" "bc",
 609                                     quickhunk 6 "d" "ef"]:\/:
 610                       join_patches [quickhunk 3 "a" "bc",
 611                                     quickhunk 8 "d" "ef"],
 612                       join_patches [quickhunk 3 "a" "bc",
 613                                     quickhunk 8 "d" "ef",
 614                                     quickhunk 1 "a" "bc",
 615                                     quickhunk 7 "d" "ef"]),
 616                      (quickmerge (quickhunk 2 "" "bd":\/:quickhunk 2 "" "a"):\/:
 617                               quickmerge (quickhunk 2 "" "c":\/:quickhunk 2 "" "a"),
 618                               quickhunk 2 "" "abdc")
 619                      ]
 620 \end{code}
 621
 622 It also is useful to verify that it doesn't matter which order we specify
 623 the patches when we merge.
 624
 625 \begin{code}
 626 merge_swap_tests :: [String]
 627 merge_swap_tests =
 628     concat
 629               [check_merge_swap p1 p2 |
 630                p1<-primitive_test_patches,
 631                p2<-primitive_test_patches,
 632                check_a_patch $ join_patches [invert p1,p2]
 633               ]
 634 check_merge_swap :: Patch -> Patch -> [String]
 635 check_merge_swap p1 p2 =
 636     case merge (p2:\/:p1) of
 637     _ :/\: p2' ->
 638         case merge (p1:\/:p2) of
 639         _ :/\: p1' ->
 640             case commutex (p2':<p1) of
 641             Just (p1'b:<_) ->
 642                 if p1'b /= p1'
 643                 then ["Merge swapping problem with...\np1 "++
 644                       show p1++"merged with\np2 "++
 645                       show p2++"p1' is\np1' "++
 646                       show p1'++"p1'b is\np1'b  "++
 647                       show p1'b
 648                      ]
 649                 else []
 650             Nothing -> ["Merge commuting problem with...\np1 "++
 651                         show p1++"merged with\np2 "++
 652                         show p2++"gives\np2' "++
 653                         show p2'++"which doesn't commutex with p1.\n"
 654                        ]
 655 \end{code}
 656
 657 \chapter{Patch test data}
 658
 659 This is where we define the set of patches which we run our tests on.  This
 660 should be kept up to date with as many interesting permutations of patch
 661 types as possible.
 662
 663 \begin{code}
 664 test_patches :: [Patch]
 665 test_patches_named :: [Named Patch]
 666 test_patches_addfile :: [Patch]
 667 test_patches_rmfile :: [Patch]
 668 test_patches_hunk :: [Patch]
 669 primitive_test_patches :: [Patch]
 670 test_patches_binary :: [Patch]
 671 test_patches_composite_nocom :: [Patch]
 672 test_patches_composite :: [Patch]
 673 test_patches_two_composite_hunks :: [Patch]
 674 test_patches_composite_hunks :: [Patch]
 675 test_patches_composite_four_hunks :: [Patch]
 676 test_patches_merged :: [Patch]
 677 valid_patches :: [Patch]
 678
 679 test_patches_named = [unsafePerformIO $
 680                       namepatch "date is" "patch name" "David Roundy" []
 681                                 (fromPrim $ addfile "test"),
 682                       unsafePerformIO $
 683                       namepatch "Sat Oct 19 08:31:13 EDT 2002"
 684                                 "This is another patch" "David Roundy"
 685                                 ["This log file has","two lines in it"]
 686                                 (fromPrim $ rmfile "test")]
 687 test_patches_addfile = map fromPrim
 688                        [addfile "test",adddir "test",addfile "test/test"]
 689 test_patches_rmfile = map invert test_patches_addfile
 690 test_patches_hunk  =
 691     [fromPrim $ hunk file line old new |
 692      file <- ["test"],
 693      line <- [1,2],
 694      old <- map (map BC.pack) partials,
 695      new <- map (map BC.pack) partials,
 696      old /= new
 697     ]
 698     where partials  = [["A"],["B"],[],["B","B2"]]
 699
 700 primitive_test_patches = test_patches_addfile ++
 701                          test_patches_rmfile ++
 702                          test_patches_hunk ++
 703                          [unsafeUnseal.fst.fromJust.readPatch $
 704                           BC.pack "move ./test/test ./hello",
 705                           unsafeUnseal.fst.fromJust.readPatch $
 706                           BC.pack "move ./test ./hello"] ++
 707                          test_patches_binary
 708
 709 test_patches_binary =
 710     [fromPrim $ binary "./hello"
 711      (BC.pack $ "agadshhdhdsa75745457574asdgg" ++
 712       "a326424677373735753246463gadshhdhdsaasdgg" ++
 713       "a326424677373735753246463gadshhdhdsaasdgg" ++
 714       "a326424677373735753246463gadshhdhdsaasdgg")
 715      (BC.pack $ "adafjttkykrehhtrththrthrthre" ++
 716       "a326424677373735753246463gadshhdhdsaasdgg" ++
 717       "a326424677373735753246463gadshhdhdsaasdgg" ++
 718       "a326424677373735753246463gadshhdhdsaagg"),
 719      fromPrim $ binary "./hello"
 720      B.empty
 721      (BC.pack "adafjttkykrere")]
 722
 723 test_patches_composite_nocom =
 724     take 50 [join_patches [p1,p2]|
 725              p1<-primitive_test_patches,
 726              p2<-filter (\p->checkseq [p1,p]) primitive_test_patches,
 727              commutex (p2:<p1) == Nothing]
 728     where checkseq ps = check_a_patch $ join_patches ps
 729
 730 test_patches_composite =
 731     take 100 [join_patches [p1,p2]|
 732               p1<-primitive_test_patches,
 733               p2<-filter (\p->checkseq [p1,p]) primitive_test_patches,
 734               commutex (p2:<p1) /= Nothing,
 735               commutex (p2:<p1) /= Just (p1:<p2)]
 736     where checkseq ps = check_a_patch $ join_patches ps
 737
 738 test_patches_two_composite_hunks =
 739     take 100 [join_patches [p1,p2]|
 740               p1<-test_patches_hunk,
 741               p2<-filter (\p->checkseq [p1,p]) test_patches_hunk]
 742     where checkseq ps = check_a_patch $ join_patches ps
 743
 744 test_patches_composite_hunks =
 745     take 100 [join_patches [p1,p2,p3]|
 746               p1<-test_patches_hunk,
 747               p2<-filter (\p->checkseq [p1,p]) test_patches_hunk,
 748               p3<-filter (\p->checkseq [p1,p2,p]) test_patches_hunk]
 749     where checkseq ps = check_a_patch $ join_patches ps
 750
 751 test_patches_composite_four_hunks =
 752     take 100 [join_patches [p1,p2,p3,p4]|
 753               p1<-test_patches_hunk,
 754               p2<-filter (\p->checkseq [p1,p]) test_patches_hunk,
 755               p3<-filter (\p->checkseq [p1,p2,p]) test_patches_hunk,
 756               p4<-filter (\p->checkseq [p1,p2,p3,p]) test_patches_hunk]
 757     where checkseq ps = check_a_patch $ join_patches ps
 758
 759 test_patches_merged =
 760   take 200
 761     [joinPatches $ flattenFL p2+>+flattenFL (quickmerge (p1:\/:p2)) |
 762      p1<-take 10 (drop 15 test_patches_composite_hunks)++primitive_test_patches
 763          ++take 10 (drop 15 test_patches_two_composite_hunks)
 764          ++ take 2 (drop 4 test_patches_composite_four_hunks),
 765      p2<-take 10 test_patches_composite_hunks++primitive_test_patches
 766          ++take 10 test_patches_two_composite_hunks
 767          ++take 2 test_patches_composite_four_hunks,
 768      check_a_patch $ join_patches [invert p1, p2],
 769      commutex (p1:<p2) /= Just (p2:<p1)
 770     ]
 771
 772 test_patches =  primitive_test_patches ++
 773                 test_patches_composite ++
 774                 test_patches_composite_nocom ++
 775                 test_patches_merged
 776 \end{code}
 777
 778 \chapter{Check patch test}
 779 Check patch is supposed to verify that a patch is valid.
 780
 781 \begin{code}
 782 valid_patches = [(join_patches [quickhunk 4 "a" "b",
 783                                 quickhunk 1 "c" "d"]),
 784                  (join_patches [quickhunk 1 "a" "bc",
 785                                 quickhunk 1 "b" "d"]),
 786                  (join_patches [quickhunk 1 "a" "b",
 787                                 quickhunk 1 "b" "d"])]++test_patches
 788
 789 test_check :: [String]
 790 test_check = unit_tester t_test_check valid_patches
 791 t_test_check :: PatchUnitTest Patch
 792 t_test_check p = if check_a_patch p
 793                  then []
 794                  else ["Failed the check:  "++show p++"\n"]
 795 \end{code}
 796
 797 \begin{code}
 798 prop_hex_conversion :: String -> Bool
 799 prop_hex_conversion s =
 800     fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s
 801 prop_concatPS :: [String] -> Bool
 802 prop_concatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss)
 803 \end{code}
 804
 805 \begin{code}
 806 check_subcommutes :: Testable a => [(String, a)] -> String -> IO ()
 807 check_subcommutes [] _ = return ()
 808 check_subcommutes ((n,c):r) expl =
 809     do putStr $ "Checking " ++ expl ++ " for subcommute " ++ n ++ "... "
 810        quickCheck c
 811        check_subcommutes r expl
 812 \end{code}
 813
 814 \end{document}
 815
 816