darcs-2.4.1: src/Darcs/Test/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.Test.Patch.Unit ( patch_unit_tests ) where
import Data.Maybe ( catMaybes, isNothing )
import qualified Data.ByteString.Char8 as BC ( pack )
import Darcs.Witnesses.Sealed
import Darcs.Patch
import Darcs.Patch.Patchy ( mergeFL, Invert )
import Darcs.Patch.Real ( RealPatch, prim2real, is_consistent, is_forward, is_duplicate )
import Darcs.Test.Patch.Test () -- for instance Eq Patch
import Darcs.Witnesses.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.Test.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 Test.HUnit ( assertBool )
import Test.Framework.Providers.HUnit ( testCase )
import Test.Framework.Providers.QuickCheck2 ( testProperty )
import Test.Framework ( Test )
-- import Debug.Trace
-- #include "impossible.h"
-- | The unit tests defined about patches
patch_unit_tests :: [Test]
patch_unit_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,
testProperty "Checking prim join inverses using QuickCheck... " (isNothing . 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,
testProperty "Checking prim join commute using QuickCheck... " (unseal2 (isNothing . 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,
testProperty "Checking that readPatch and showPatch work on RealPatch... "
(isNothing . (unseal $ patchFromTree $ (show_read :: RealPatch -> Maybe Doc))),
testProperty "Checking that readPatch and showPatch work on FL RealPatch... "
(isNothing . (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,
testProperty "Checking that tree flattenings are consistent... " prop_consistent_tree_flattenings,
testProperty "Checking with quickcheck that real patches are consistent... "
(isNothing . (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,
testProperty "Checking we can do merges using QuickCheck"
(isNothing . (prop_is_mergeable ::
Sealed (WithStartState RepoModel (Tree Prim))
-> Maybe (Tree RealPatch C(x)))),
testProperty "Checking recommute using QuickCheck Tree generator"
(isNothing. (unseal $ commutePairFromTree $
(recommute
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))),
testProperty "Checking recommute using QuickCheck TWFP generator"
(isNothing . (unseal $ commutePairFromTWFP $
(recommute
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))),
testConditional "Checking nontrivial recommute"
(unseal $ commutePairFromTree $ nontrivial_reals)
(unseal $ commutePairFromTree $
(recommute
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch)))),
testConditional "Checking nontrivial recommute using TWFP"
(unseal $ commutePairFromTWFP $ nontrivial_reals)
(unseal $ commutePairFromTWFP $
(recommute
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch)))),
testProperty "Checking inverses commute using QuickCheck Tree generator"
(isNothing . (unseal $ commutePairFromTree $
(commute_inverses
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))),
testProperty "Checking inverses commute using QuickCheck TWFP generator"
(isNothing . (unseal $ commutePairFromTWFP $
(commute_inverses
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch))))),
testConditional "Checking nontrivial inverses commute"
(unseal $ commutePairFromTree $ nontrivial_reals)
(unseal $ commutePairFromTree $
(commute_inverses
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch)))),
testConditional "Checking nontrivial inverses commute using TWFP"
(unseal $ commutePairFromTWFP $ nontrivial_reals)
(unseal $ commutePairFromTWFP $
(commute_inverses
(commute :: RealPatch :> RealPatch
-> Maybe (RealPatch :> RealPatch)))),
testProperty "Checking merge either way using QuickCheck TWFP generator"
(isNothing . (unseal $ mergePairFromTWFP $
(merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))),
testProperty "Checking merge either way using QuickCheck Tree generator"
(isNothing . (unseal $ mergePairFromTree $
(merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))),
testConditional "Checking nontrivial merge either way"
(unseal $ mergePairFromTree $ nontrivial_merge_reals)
(unseal $ mergePairFromTree $
(merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc)),
testConditional "Checking nontrivial merge either way using TWFP"
(unseal $ mergePairFromTWFP $ nontrivial_merge_reals)
(unseal $ mergePairFromTWFP $
(merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc)),
testConditional "Checking permutivity"
(unseal $ commuteTripleFromTree not_duplicatestriple)
(unseal $ commuteTripleFromTree $ permutivity
(commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))),
testConditional "Checking partial permutivity"
(unseal $ commuteTripleFromTree not_duplicatestriple)
(unseal $ commuteTripleFromTree $ partial_permutivity
(commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))),
testConditional "Checking nontrivial permutivity"
(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 a test function on a set of data, using HUnit. The test function should
-- return @Nothing@ upon success and a @Just x@ upon failure.
run_primitive_tests :: (Show a, Show b) => String -- ^ The test name
-> (a -> Maybe b) -- ^ The test function
-> [a] -- ^ The test data
-> Test
run_primitive_tests name test datas = testCase name (assertBool assertName res)
where assertName = "Boolean assertion for \"" ++ name ++ "\""
res = and $ map (isNothing . test) datas
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'