darcs-2.1.2.1: src/Darcs/Patch/Unit.hs
-- Copyright (C) 2007 David Roundy
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING. If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.
{-# OPTIONS_GHC -cpp -fno-warn-deprecations -fno-warn-orphans -fglasgow-exts #-}
{-# LANGUAGE CPP #-}
#include "gadts.h"
module Darcs.Patch.Unit ( run_patch_unit_tests ) where
import Control.Monad ( unless )
import Data.Maybe ( catMaybes )
import qualified Data.ByteString.Char8 as BC ( pack )
import Darcs.Sealed
import Darcs.Patch
import Darcs.Patch.Patchy ( mergeFL, Invert )
import Darcs.Patch.Real ( RealPatch, prim2real, is_consistent, is_forward, is_duplicate )
import Darcs.Patch.Test () -- for instance Eq Patch
import Darcs.Ordered
import Darcs.Patch.Properties ( recommute, commute_inverses, permutivity, partial_permutivity,
inverse_doesnt_commute, patch_and_inverse_commute,
merge_commute, merge_consistent, merge_arguments_consistent,
merge_either_way, show_read,
join_inverses, join_commute )
import Darcs.Patch.Prim ( join )
import Darcs.Patch.QuickCheck
import Printer ( Doc, redText, ($$) )
--import Printer ( greenText )
--import Darcs.ColorPrinter ( traceDoc )
--import Darcs.ColorPrinter ( errorDoc )
import Darcs.ColorPrinter () -- for instance Show Doc
-- import Debug.Trace
-- #include "impossible.h"
run_patch_unit_tests :: IO Int
run_patch_unit_tests =
run_some_tests ""
[--do putStr "Checking with quickcheck that real patches have consistent flattenings... "
-- quickCheck (not . isBottomTimeOut (Just 10) . prop_consistent_tree_flattenings) >> return 0
run_primitive_tests "prim join inverses"
(\(a:\/:_) -> join_inverses join a) mergeables
,do putStr "Checking prim join inverses using QuickCheck... "
simpleCheck (join_inverses join)
,run_primitive_tests "prim inverse doesn't commute"
(\(a:\/:_) -> inverse_doesnt_commute a) mergeables
-- The following fails because of setpref patches...
--,do putStr "Checking prim inverse doesn't commute using QuickCheck... "
-- simpleCheck (inverse_doesnt_commute :: Prim -> Maybe Doc)
,run_primitive_tests "join commute" (join_commute join) prim_permutables
,do putStr "Checking prim join commute using QuickCheck... "
simpleCheck (unseal2 (join_commute join))
,run_primitive_tests "prim recommute"
(recommute commute) $ map mergeable2commutable mergeables
,run_primitive_tests "prim patch and inverse commute"
(patch_and_inverse_commute commute) $ map mergeable2commutable mergeables
,run_primitive_tests "prim inverses commute"
(commute_inverses commute) $ map mergeable2commutable mergeables
-- ,do putStr "Checking prim recommute using QuickCheck... "
-- simpleCheck (recommute
-- (commute :: Prim :> Prim
-- -> Maybe (Prim :> Prim)))
,run_primitive_tests "FL prim recommute"
(recommute commute) $ map mergeable2commutable mergeablesFL
,run_primitive_tests "FL prim patch and inverse commute"
(patch_and_inverse_commute commute) $ map mergeable2commutable mergeablesFL
,run_primitive_tests "FL prim inverses commute"
(commute_inverses commute) $ map mergeable2commutable mergeablesFL
,run_primitive_tests "fails" (commute_fails commute) ([] :: [Prim :> Prim])
,run_primitive_tests "read and show work on Prim" show_read prim_patches
,run_primitive_tests "read and show work on RealPatch" show_read real_patches
,do putStr "Checking that readPatch and showPatch work on RealPatch... "
simpleCheck (unseal $ patchFromTree $ (show_read :: RealPatch -> Maybe Doc))
,do putStr "Checking that readPatch and showPatch work on FL RealPatch... "
simpleCheck (unseal2 $ (show_read :: FL RealPatch -> Maybe Doc))
,run_primitive_tests "example flattenings work"
(\x -> if prop_consistent_tree_flattenings x
then Nothing
else Just $ redText "oops")
real_patch_loop_examples
,do putStr "Checking that tree flattenings are consistent... "
simpleCheck ((\b -> if b then Nothing else Just False) . prop_consistent_tree_flattenings)
,do putStr "Checking with quickcheck that real patches are consistent... "
simpleCheck (unseal $ patchFromTree $ is_consistent)
,run_primitive_tests "real merge input consistent"
(merge_arguments_consistent is_consistent) real_mergeables
,run_primitive_tests "real merge input is forward"
(merge_arguments_consistent is_forward) real_mergeables
,run_primitive_tests "real merge output is forward"
(merge_consistent is_forward) real_mergeables
,run_primitive_tests "real merge output consistent"
(merge_consistent is_consistent) real_mergeables
,run_primitive_tests "real merge either way" merge_either_way real_mergeables
,run_primitive_tests "real merge and commute" merge_commute real_mergeables
,run_primitive_tests "real recommute" (recommute commute) real_commutables
,run_primitive_tests "real inverses commute" (commute_inverses commute) real_commutables
,run_primitive_tests "real permutivity" (permutivity commute) $
filter (not_duplicatestriple) real_triples
,run_primitive_tests "real partial permutivity" (partial_permutivity commute) $
filter (not_duplicatestriple) real_triples
,do putStr "Checking we can do merges using QuickCheck... "
simpleCheck (prop_is_mergeable ::
Sealed (WithStartState RepoModel (Tree Prim))
-> Maybe (Tree RealPatch C(x)))
,do putStr "Checking again we can do merges using QuickCheck... "
thoroughCheck 1000 (prop_is_mergeable ::
Sealed (WithStartState RepoModel (Tree Prim))
-> Maybe (Tree RealPatch C(x)))
,do putStr "Checking recommute using QuickCheck Tree generator... "
simpleCheck (unseal $ commutePairFromTree $
(recommute
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))
,do putStr "Checking recommute using QuickCheck TWFP generator... "
simpleCheck (unseal $ commutePairFromTWFP $
(recommute
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))
,do putStr "Checking nontrivial recommute... "
simpleConditionalCheck (unseal $ commutePairFromTree $ nontrivial_reals)
(unseal $ commutePairFromTree $
(recommute
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))
,do putStr "Checking nontrivial recommute using TWFP... "
simpleConditionalCheck (unseal $ commutePairFromTWFP $ nontrivial_reals)
(unseal $ commutePairFromTWFP $
(recommute
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))
,do putStr "Checking inverses commute using QuickCheck Tree generator... "
simpleCheck (unseal $ commutePairFromTree $
(commute_inverses
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))
,do putStr "Checking inverses commute using QuickCheck TWFP generator... "
simpleCheck (unseal $ commutePairFromTWFP $
(commute_inverses
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))
,do putStr "Checking nontrivial inverses commute... "
simpleConditionalCheck (unseal $ commutePairFromTree $ nontrivial_reals)
(unseal $ commutePairFromTree $
(commute_inverses
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))
,do putStr "Checking nontrivial inverses commute using TWFP... "
simpleConditionalCheck (unseal $ commutePairFromTWFP $ nontrivial_reals)
(unseal $ commutePairFromTWFP $
(commute_inverses
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))
,do putStr "Checking merge either way using QuickCheck TWFP generator... "
simpleCheck (unseal $ mergePairFromTWFP $
(merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))
,do putStr "Checking merge either way using QuickCheck Tree generator... "
simpleCheck (unseal $ mergePairFromTree $
(merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))
,do putStr "Checking nontrivial merge either way... "
simpleConditionalCheck (unseal $ mergePairFromTree $ nontrivial_merge_reals)
(unseal $ mergePairFromTree $
(merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))
,do putStr "Checking nontrivial merge either way using TWFP... "
simpleConditionalCheck (unseal $ mergePairFromTWFP $ nontrivial_merge_reals)
(unseal $ mergePairFromTWFP $
(merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))
,do putStr "Checking permutivity... "
simpleConditionalCheck (unseal $ commuteTripleFromTree not_duplicatestriple)
(unseal $ commuteTripleFromTree $ permutivity
(commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))
,do putStr "Checking partial permutivity... "
simpleConditionalCheck (unseal $ commuteTripleFromTree not_duplicatestriple)
(unseal $ commuteTripleFromTree $ partial_permutivity
(commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))
,do putStr "Checking nontrivial permutivity... "
simpleConditionalCheck (unseal $ commuteTripleFromTree
(\t -> nontrivial_triple t && not_duplicatestriple t))
(unseal $ commuteTripleFromTree $
(permutivity
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))
]
not_duplicatestriple :: RealPatch :> RealPatch :> RealPatch -> Bool
not_duplicatestriple (a :> b :> c) = not $ any is_duplicate [a,b,c]
--not_duplicates_pair :: RealPatch :> RealPatch -> Bool
--not_duplicates_pair (a :> b) = not $ any is_duplicate [a,b]
nontrivial_triple :: RealPatch :> RealPatch :> RealPatch -> Bool
nontrivial_triple (a :> b :> c) =
case commute (a :> b) of
Nothing -> False
Just (b' :> a') ->
case commute (a' :> c) of
Nothing -> False
Just (c'' :> a'') ->
case commute (b :> c) of
Nothing -> False
Just (c' :> b'') -> (not (a `unsafeCompare` a') || not (b `unsafeCompare` b')) &&
(not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) &&
(not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a'))
nontrivial_reals :: RealPatch :> RealPatch -> Bool
nontrivial_reals = nontrivial_commute
nontrivial_commute :: Patchy p => p :> p -> Bool
nontrivial_commute (x :> y) = case commute (x :> y) of
Just (y' :> x') -> not (y' `unsafeCompare` y) ||
not (x' `unsafeCompare` x)
Nothing -> False
nontrivial_merge_reals :: RealPatch :\/: RealPatch -> Bool
nontrivial_merge_reals = nontrivial_merge
nontrivial_merge :: Patchy p => p :\/: p -> Bool
nontrivial_merge (x :\/: y) = case merge (x :\/: y) of
y' :/\: x' -> not (y' `unsafeCompare` y) ||
not (x' `unsafeCompare` x)
run_some_tests :: String -> [IO Int] -> IO Int
run_some_tests name ts = do unless (null name) $ putStr $ "Testing " ++ name ++ "... "
errs <- sum `fmap` sequence ts
unless (null name) $
if errs < 1
then putStrLn "passed."
else putStrLn $ "failed " ++ name ++" in "++ show errs ++ " tests."
return errs
run_primitive_tests :: (Show a, Show b) => String -> (a -> Maybe b) -> [a] -> IO Int
run_primitive_tests name test datas = run_some_tests name $ map test' datas
where test' d = case test d of
Just e -> do putStrLn $ name ++ " failed!"
putStrLn $ "Input: " ++ show d
putStrLn $ "Output: " ++ show e
return 1
Nothing -> return 0
quickhunk :: Int -> String -> String -> Prim
quickhunk l o n = hunk "test" l (map (\c -> BC.pack [c]) o)
(map (\c -> BC.pack [c]) n)
prim_permutables :: [Prim :> Prim :> Prim]
prim_permutables =
[quickhunk 0 "e" "bo" :> quickhunk 3 "" "x" :> quickhunk 2 "f" "qljo"]
mergeables :: [Prim :\/: Prim]
mergeables = [quickhunk 1 "a" "b" :\/: quickhunk 1 "a" "c",
quickhunk 1 "a" "b" :\/: quickhunk 3 "z" "c",
quickhunk 0 "" "a" :\/: quickhunk 1 "" "b",
quickhunk 0 "a" "" :\/: quickhunk 1 "" "b",
quickhunk 0 "a" "" :\/: quickhunk 1 "b" "",
quickhunk 0 "" "a" :\/: quickhunk 1 "b" ""
]
mergeablesFL :: [FL Prim :\/: FL Prim]
mergeablesFL = map (\ (x:\/:y) -> (x :>: NilFL) :\/: (y :>: NilFL)) mergeables ++
[] -- [(quickhunk 1 "a" "b" :>: quickhunk 3 "z" "c" :>: NilFL)
-- :\/: (quickhunk 1 "a" "z" :>: NilFL),
-- (quickhunk 1 "a" "b" :>: quickhunk 1 "b" "c" :>: NilFL)
-- :\/: (quickhunk 1 "a" "z" :>: NilFL)]
mergeable2commutable :: Invert p => p :\/: p -> p :> p
mergeable2commutable (x :\/: y) = invert x :> y
prim_patches :: [Prim]
prim_patches = concatMap mergeable2patches mergeables
where mergeable2patches (x:\/:y) = [x,y]
real_patches :: [RealPatch]
real_patches = concatMap commutable2patches real_commutables
where commutable2patches (x:>y) = [x,y]
real_triples :: [RealPatch :> RealPatch :> RealPatch]
real_triples = [ob' :> oa2 :> a2'',
oa' :> oa2 :> a2''] ++ triple_examples
++ map unsafeUnseal2 (concatMap getTriples realFLs)
where oa = prim2real $ quickhunk 1 "o" "aa"
oa2 = oa
a2 = prim2real $ quickhunk 2 "a34" "2xx"
ob = prim2real $ quickhunk 1 "o" "bb"
ob' :/\: oa' = merge (oa :\/: ob)
a2' :/\: _ = merge (ob' :\/: a2)
a2'' :/\: _ = merge (oa2 :\/: a2')
realFLs :: [FL RealPatch]
realFLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL]
where oa = prim2real $ quickhunk 1 "o" "a"
ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL)
real_commutables :: [RealPatch :> RealPatch]
real_commutables = commute_examples ++ map mergeable2commutable real_mergeables++
[invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs realFLs)
where oa = prim2real $ quickhunk 1 "o" "a"
ob = prim2real $ quickhunk 1 "o" "b"
_ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL)
real_mergeables :: [RealPatch :\/: RealPatch]
real_mergeables = map (\ (x :\/: y) -> prim2real x :\/: prim2real y) mergeables
++ real_igloo_mergeables
++ real_quickcheck_mergeables
++ merge_examples
++ catMaybes (map pair2m (concatMap getPairs realFLs))
++ [(oa :\/: od),
(oa :\/: a2'),
(ob' :\/: od''),
(oe :\/: od),
(of' :\/: oe'),
(ob' :\/: oe'),
(oa :\/: oe'),
(ob' :\/: oc'),
(b2' :\/: oc'''),
(ob' :\/: a2),
(b2' :\/: og'''),
(oc''' :\/: og'''),
(oc'' :\/: og''),
(ob'' :\/: og''),
(ob'' :\/: oc''),
(oc' :\/: od'')]
where oa = prim2real $ quickhunk 1 "o" "aa"
a2 = prim2real $ quickhunk 2 "a34" "2xx"
og = prim2real $ quickhunk 3 "4" "g"
ob = prim2real $ quickhunk 1 "o" "bb"
b2 = prim2real $ quickhunk 2 "b" "2"
oc = prim2real $ quickhunk 1 "o" "cc"
od = prim2real $ quickhunk 7 "x" "d"
oe = prim2real $ quickhunk 7 "x" "e"
pf = prim2real $ quickhunk 7 "x" "f"
od'' = prim2real $ quickhunk 8 "x" "d"
ob' :>: b2' :>: NilFL :/\: _ = mergeFL (oa :\/: ob :>: b2 :>: NilFL)
a2' :/\: _ = merge (ob' :\/: a2)
ob'' :/\: _ = merge (a2 :\/: ob')
og' :/\: _ = merge (oa :\/: og)
og'' :/\: _ = merge (a2 :\/: og')
og''' :/\: _ = merge (ob' :\/: og')
oc' :/\: _ = merge (oa :\/: oc)
oc'' :/\: _ = merge (a2 :\/: oc)
oc''' :/\: _ = merge (ob' :\/: oc')
oe' :/\: _ = merge (od :\/: oe)
of' :/\: _ = merge (od :\/: pf)
pair2m :: Sealed2 (RealPatch :> RealPatch)
-> Maybe (RealPatch :\/: RealPatch)
pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)
return (xx :\/: y')
real_igloo_mergeables :: [RealPatch :\/: RealPatch]
real_igloo_mergeables = [(a :\/: b),
(b :\/: c),
(a :\/: c),
(x :\/: a),
(y :\/: b),
(z :\/: c),
(x' :\/: y'),
(z' :\/: y'),
(x' :\/: z'),
(a :\/: a)]
where a = prim2real $ quickhunk 1 "1" "A"
b = prim2real $ quickhunk 2 "2" "B"
c = prim2real $ quickhunk 3 "3" "C"
x = prim2real $ quickhunk 1 "1BC" "xbc"
y = prim2real $ quickhunk 1 "A2C" "ayc"
z = prim2real $ quickhunk 1 "AB3" "abz"
x' :/\: _ = merge (a :\/: x)
y' :/\: _ = merge (b :\/: y)
z' :/\: _ = merge (c :\/: z)
real_quickcheck_mergeables :: [RealPatch :\/: RealPatch]
real_quickcheck_mergeables = [-- invert k1 :\/: n1
--, invert k2 :\/: n2
hb :\/: k
, b' :\/: b'
, n' :\/: n'
, b :\/: d
, k' :\/: k'
, k3 :\/: k3
] ++ catMaybes (map pair2m pairs)
where hb = prim2real $ quickhunk 0 "" "hb"
k = prim2real $ quickhunk 0 "" "k"
n = prim2real $ quickhunk 0 "" "n"
b = prim2real $ quickhunk 1 "b" ""
d = prim2real $ quickhunk 2 "" "d"
d':/\:_ = merge (b :\/: d)
--k1 :>: n1 :>: NilFL :/\: _ = mergeFL (hb :\/: k :>: n :>: NilFL)
--k2 :>: n2 :>: NilFL :/\: _ =
-- merge (hb :>: b :>: NilFL :\/: k :>: n :>: NilFL)
k' :>: n' :>: NilFL :/\: _ :>: b' :>: _ = merge (hb :>: b :>: d' :>: NilFL :\/: k :>: n :>: NilFL)
pairs = getPairs (hb :>: b :>: d' :>: k' :>: n' :>: NilFL)
pair2m :: Sealed2 (RealPatch :> RealPatch)
-> Maybe (RealPatch :\/: RealPatch)
pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)
return (xx :\/: y')
i = prim2real $ quickhunk 0 "" "i"
x = prim2real $ quickhunk 0 "" "x"
xi = prim2real $ quickhunk 0 "xi" ""
d3 :/\: _ = merge (xi :\/: d)
_ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL)
commute_fails :: (MyEq p, Patchy p) => (p :> p -> Maybe (p :> p)) -> p :> p
-> Maybe Doc
commute_fails c (x :> y) = do y' :> x' <- c (x :> y)
return $ redText "x" $$ showPatch x $$
redText ":> y" $$ showPatch y $$
redText "y'" $$ showPatch y' $$
redText ":> x'" $$ showPatch x'