-- 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 ( patchUnitTests ) 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, isConsistent, isForward, isDuplicate ) import Darcs.Test.Patch.Test () -- for instance Eq Patch import Darcs.Witnesses.Ordered import Darcs.Patch.Properties ( recommute, commuteInverses, permutivity, partialPermutivity, inverseDoesntCommute, patchAndInverseCommute, mergeCommute, mergeConsistent, mergeArgumentsConsistent, mergeEitherWay, show_read, joinInverses, joinCommute ) 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 patchUnitTests :: [Test] patchUnitTests = [--do putStr "Checking with quickcheck that real patches have consistent flattenings... " -- quickCheck (not . isBottomTimeOut (Just 10) . propConsistentTreeFlattenings) >> return 0 runPrimitiveTests "prim join inverses" (\ (a:\/:_) -> joinInverses join a) mergeables, testProperty "Checking prim join inverses using QuickCheck... " (isNothing . joinInverses join), runPrimitiveTests "prim inverse doesn't commute" (\ (a:\/:_) -> inverseDoesntCommute a) mergeables, -- The following fails because of setpref patches... --,do putStr "Checking prim inverse doesn't commute using QuickCheck... " -- simpleCheck (inverseDoesntCommute :: Prim -> Maybe Doc) runPrimitiveTests "join commute" (joinCommute join) primPermutables, testProperty "Checking prim join commute using QuickCheck... " (unseal2 (isNothing . joinCommute join)), runPrimitiveTests "prim recommute" (recommute commute) $ map mergeable2commutable mergeables, runPrimitiveTests "prim patch and inverse commute" (patchAndInverseCommute commute) $ map mergeable2commutable mergeables, runPrimitiveTests "prim inverses commute" (commuteInverses commute) $ map mergeable2commutable mergeables, --,do putStr "Checking prim recommute using QuickCheck... " -- simpleCheck (recommute -- (commute :: Prim :> Prim -- -> Maybe (Prim :> Prim))) runPrimitiveTests "FL prim recommute" (recommute commute) $ map mergeable2commutable mergeablesFL, runPrimitiveTests "FL prim patch and inverse commute" (patchAndInverseCommute commute) $ map mergeable2commutable mergeablesFL, runPrimitiveTests "FL prim inverses commute" (commuteInverses commute) $ map mergeable2commutable mergeablesFL, runPrimitiveTests "fails" (commuteFails commute) ([] :: [Prim :> Prim]), runPrimitiveTests "read and show work on Prim" show_read primPatches, runPrimitiveTests "read and show work on RealPatch" show_read realPatches, 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))), runPrimitiveTests "example flattenings work" (\x -> if propConsistentTreeFlattenings x then Nothing else Just $ redText "oops") realPatchLoopExamples, testProperty "Checking that tree flattenings are consistent... " propConsistentTreeFlattenings, testProperty "Checking with quickcheck that real patches are consistent... " (isNothing . (unseal $ patchFromTree $ isConsistent)), runPrimitiveTests "real merge input consistent" (mergeArgumentsConsistent isConsistent) realMergeables, runPrimitiveTests "real merge input is forward" (mergeArgumentsConsistent isForward) realMergeables, runPrimitiveTests "real merge output is forward" (mergeConsistent isForward) realMergeables, runPrimitiveTests "real merge output consistent" (mergeConsistent isConsistent) realMergeables, runPrimitiveTests "real merge either way" mergeEitherWay realMergeables, runPrimitiveTests "real merge and commute" mergeCommute realMergeables, runPrimitiveTests "real recommute" (recommute commute) realCommutables, runPrimitiveTests "real inverses commute" (commuteInverses commute) realCommutables, runPrimitiveTests "real permutivity" (permutivity commute) $ filter (notDuplicatestriple) realTriples, runPrimitiveTests "real partial permutivity" (partialPermutivity commute) $ filter (notDuplicatestriple) realTriples, testProperty "Checking we can do merges using QuickCheck" (isNothing . (propIsMergeable :: 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 $ nontrivialReals) (unseal $ commutePairFromTree $ (recommute (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))), testConditional "Checking nontrivial recommute using TWFP" (unseal $ commutePairFromTWFP $ nontrivialReals) (unseal $ commutePairFromTWFP $ (recommute (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))), testProperty "Checking inverses commute using QuickCheck Tree generator" (isNothing . (unseal $ commutePairFromTree $ (commuteInverses (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))))), testProperty "Checking inverses commute using QuickCheck TWFP generator" (isNothing . (unseal $ commutePairFromTWFP $ (commuteInverses (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))))), testConditional "Checking nontrivial inverses commute" (unseal $ commutePairFromTree $ nontrivialReals) (unseal $ commutePairFromTree $ (commuteInverses (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))), testConditional "Checking nontrivial inverses commute using TWFP" (unseal $ commutePairFromTWFP $ nontrivialReals) (unseal $ commutePairFromTWFP $ (commuteInverses (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))), testProperty "Checking merge either way using QuickCheck TWFP generator" (isNothing . (unseal $ mergePairFromTWFP $ (mergeEitherWay :: RealPatch :\/: RealPatch -> Maybe Doc))), testProperty "Checking merge either way using QuickCheck Tree generator" (isNothing . (unseal $ mergePairFromTree $ (mergeEitherWay :: RealPatch :\/: RealPatch -> Maybe Doc))), testConditional "Checking nontrivial merge either way" (unseal $ mergePairFromTree $ nontrivialMergeReals) (unseal $ mergePairFromTree $ (mergeEitherWay :: RealPatch :\/: RealPatch -> Maybe Doc)), testConditional "Checking nontrivial merge either way using TWFP" (unseal $ mergePairFromTWFP $ nontrivialMergeReals) (unseal $ mergePairFromTWFP $ (mergeEitherWay :: RealPatch :\/: RealPatch -> Maybe Doc)), testConditional "Checking permutivity" (unseal $ commuteTripleFromTree notDuplicatestriple) (unseal $ commuteTripleFromTree $ permutivity (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))), testConditional "Checking partial permutivity" (unseal $ commuteTripleFromTree notDuplicatestriple) (unseal $ commuteTripleFromTree $ partialPermutivity (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch))), testConditional "Checking nontrivial permutivity" (unseal $ commuteTripleFromTree (\t -> nontrivialTriple t && notDuplicatestriple t)) (unseal $ commuteTripleFromTree $ (permutivity (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))) ] notDuplicatestriple :: RealPatch :> RealPatch :> RealPatch -> Bool notDuplicatestriple (a :> b :> c) = not $ any isDuplicate [a,b,c] --not_duplicates_pair :: RealPatch :> RealPatch -> Bool --not_duplicates_pair (a :> b) = not $ any isDuplicate [a,b] nontrivialTriple :: RealPatch :> RealPatch :> RealPatch -> Bool nontrivialTriple (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')) nontrivialReals :: RealPatch :> RealPatch -> Bool nontrivialReals = nontrivialCommute nontrivialCommute :: Patchy p => p :> p -> Bool nontrivialCommute (x :> y) = case commute (x :> y) of Just (y' :> x') -> not (y' `unsafeCompare` y) || not (x' `unsafeCompare` x) Nothing -> False nontrivialMergeReals :: RealPatch :\/: RealPatch -> Bool nontrivialMergeReals = nontrivialMerge nontrivialMerge :: Patchy p => p :\/: p -> Bool nontrivialMerge (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. runPrimitiveTests :: (Show a, Show b) => String -- ^ The test name -> (a -> Maybe b) -- ^ The test function -> [a] -- ^ The test data -> Test runPrimitiveTests 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) primPermutables :: [Prim :> Prim :> Prim] primPermutables = [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 primPatches :: [Prim] primPatches = concatMap mergeable2patches mergeables where mergeable2patches (x:\/:y) = [x,y] realPatches :: [RealPatch] realPatches = concatMap commutable2patches realCommutables where commutable2patches (x:>y) = [x,y] realTriples :: [RealPatch :> RealPatch :> RealPatch] realTriples = [ob' :> oa2 :> a2'', oa' :> oa2 :> a2''] ++ map unsafeUnseal2 tripleExamples ++ 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) realCommutables :: [RealPatch :> RealPatch] realCommutables = map unsafeUnseal2 commuteExamples++ map mergeable2commutable realMergeables++ [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) realMergeables :: [RealPatch :\/: RealPatch] realMergeables = map (\ (x :\/: y) -> prim2real x :\/: prim2real y) mergeables ++ realIglooMergeables ++ realQuickcheckMergeables ++ map unsafeUnseal2 mergeExamples ++ 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') realIglooMergeables :: [RealPatch :\/: RealPatch] realIglooMergeables = [(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) realQuickcheckMergeables :: [RealPatch :\/: RealPatch] realQuickcheckMergeables = [-- 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) commuteFails :: (MyEq p, Patchy p) => (p :> p -> Maybe (p :> p)) -> p :> p -> Maybe Doc commuteFails 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'