darcs-2.16.1: harness/Darcs/Test/Patch.hs
-- Copyright (C) 2002-2005,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.
-- UndecidableInstances was added because GHC 8.6 needed it
-- even though GHC 8.2 didn't
{-# LANGUAGE UndecidableInstances #-}
module Darcs.Test.Patch ( testSuite ) where
import Darcs.Prelude
import Data.Constraint ( Dict(..) )
import Test.Framework ( Test, testGroup )
import Test.Framework.Providers.QuickCheck2 ( testProperty )
import Test.QuickCheck( Arbitrary(..) )
import Darcs.Test.Util.TestResult ( TestResult, maybeFailed )
import Darcs.Test.Patch.Utils
( PropList
, TestCheck(..)
, TestCondition(..)
, TestGenerator(..)
, properties
, testCases
, testConditional
, fromNothing
)
import Darcs.Patch.Witnesses.Ordered
import Darcs.Patch.Witnesses.Sealed
import Darcs.Patch.Witnesses.Eq ( Eq2 )
import Darcs.Patch.Witnesses.Show
import Darcs.Patch.Annotate ( Annotate )
import Darcs.Patch.FromPrim ( PrimOf, FromPrim(..) )
import Darcs.Patch.Prim ( PrimPatch, coalesce )
import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim )
import qualified Darcs.Patch.V1.Prim as V1 ( Prim )
import qualified Darcs.Patch.V2.Prim as V2 ( Prim )
import Darcs.Patch.Prim.Named ( NamedPrim )
import Darcs.Patch.V2.RepoPatch ( isConsistent, isForward, RepoPatchV2 )
import Darcs.Patch.V3 ( RepoPatchV3 )
import Darcs.Patch.Commute ( Commute(..) )
import Darcs.Patch.Invert ( Invert )
import Darcs.Patch.Show ( ShowPatchBasic )
import Darcs.Patch.Apply( Apply, ApplyState )
import Darcs.Patch.Merge ( Merge )
import Darcs.Test.Patch.Arbitrary.Generic
import Darcs.Test.Patch.Arbitrary.Named ()
import Darcs.Test.Patch.Arbitrary.PatchTree
import Darcs.Test.Patch.Arbitrary.PrimFileUUID()
import Darcs.Test.Patch.Arbitrary.NamedPrimV1 ()
import Darcs.Test.Patch.Arbitrary.NamedPrimFileUUID ()
import Darcs.Test.Patch.Arbitrary.RepoPatch
import Darcs.Test.Patch.Arbitrary.RepoPatchV2 ()
import Darcs.Test.Patch.Arbitrary.RepoPatchV3 ()
import Darcs.Test.Patch.Arbitrary.PrimV1 ()
import Darcs.Test.Patch.Arbitrary.Shrink ( Shrinkable )
import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )
import Darcs.Test.Patch.RepoModel
import Darcs.Test.Patch.WithState
( ArbitraryState
, PropagateShrink
, ShrinkModel
, WithState
, arbitraryTriple
, makeS2Gen
, makeWS2Gen
, wesPatch
)
import qualified Darcs.Test.Patch.Info
import qualified Darcs.Test.Patch.Selection
import qualified Darcs.Test.Patch.Examples.Set2Unwitnessed as ExU
import Darcs.Test.Patch.Properties.Check( Check(..) )
import Darcs.Test.Patch.Properties.Generic ( PatchProperty, MergeProperty, SequenceProperty )
import qualified Darcs.Test.Patch.Properties.Generic as PropG
import qualified Darcs.Test.Patch.Properties.RepoPatch as PropR
import qualified Darcs.Test.Patch.Properties.RepoPatchV3 as PropR3
import qualified Darcs.Test.Patch.Properties.GenericUnwitnessed as PropU
import qualified Darcs.Test.Patch.Rebase as Rebase
import qualified Darcs.Test.Patch.Unwind as Unwind
import qualified Darcs.Test.Patch.WSub as WSub
type Prim1 = V1.Prim
type Prim2 = V2.Prim
-- Generic Arbitrary instances
-- We define them here so they don't overlap with those for RepoPatchV1,
-- which use a different generator for V1Model.
type ArbitraryModel p = (RepoModel (ModelOf p), ArbitraryState p)
instance ArbitraryModel p => Arbitrary (Sealed2 (WithState (FL p))) where
arbitrary = makeWS2Gen aSmallRepo
instance ArbitraryModel p => Arbitrary (Sealed2 (WithState (FL p :> FL p))) where
arbitrary = makeWS2Gen aSmallRepo
instance ArbitraryModel p => Arbitrary (Sealed2 (FL p :> FL p)) where
arbitrary = makeS2Gen aSmallRepo
instance ArbitraryModel p => Arbitrary (Sealed2 (FL p)) where
arbitrary = makeS2Gen aSmallRepo
instance ArbitraryModel p => Arbitrary (Sealed2 (p :> p :> p)) where
arbitrary = unseal (seal2 . wesPatch) <$> (aSmallRepo >>= arbitraryTriple)
-- End generic instances
unit_V2P1 :: [Test]
unit_V2P1 =
[ testCases "coalesce commute" (PropU.coalesceCommute WSub.coalesce) ExU.primPermutables
, testCases "prim recommute" (PropU.recommute WSub.commute) ExU.commutables
, testCases "square commute law" (PropU.squareCommuteLaw WSub.commute) ExU.commutables
, testCases "prim inverses commute" (PropU.commuteInverses WSub.commute) ExU.commutables
, testCases "FL prim recommute" (PropU.recommute WSub.commute) ExU.commutablesFL
, testCases "FL square commute law" (PropU.squareCommuteLaw WSub.commute) ExU.commutablesFL
, testCases "FL prim inverses commute" (PropU.commuteInverses WSub.commute) $ ExU.commutablesFL
, testCases "fails" (PropU.commuteFails WSub.commute) ([] :: [(Prim2 WSub.:> Prim2) wX wY])
, testCases "read and show work on Prim" PropU.showRead ExU.primPatches
, testCases "read and show work on RepoPatchV2" PropU.showRead ExU.repov2Patches
, testCases "example flattenings work" (PropR.propConsistentTreeFlattenings fromPrim2) ExU.repov2PatchLoopExamples
, testCases "V2 merge input consistent" (PropU.mergeArgumentsConsistent isConsistent) ExU.repov2Mergeables
, testCases "V2 merge input is forward" (PropU.mergeArgumentsConsistent isForward) ExU.repov2Mergeables
, testCases "V2 merge output is forward" (PropU.mergeConsistent isForward) ExU.repov2Mergeables
, testCases "V2 merge output consistent" (PropU.mergeConsistent isConsistent) ExU.repov2Mergeables
, testCases "V2 merge either way" PropU.mergeEitherWay ExU.repov2Mergeables
, testCases "V2 merge and commute" PropU.mergeCommute ExU.repov2Mergeables
, testCases "V2 recommute" (PropU.recommute WSub.commute) ExU.repov2Commutables
, testCases "V2 inverses commute" (PropU.commuteInverses WSub.commute) ExU.repov2Commutables
, testCases "V2 permutivity" (PropU.permutivity WSub.commute) ExU.repov2NonduplicateTriples
]
where
fromPrim2 :: PropR.FromPrimT RepoPatchV2 Prim2
fromPrim2 = fromAnonymousPrim
arbitraryThing :: TestGenerator thing (Sealed2 thing)
arbitraryThing = TestGenerator (\f p -> Just (unseal2 f p))
qc_prim :: forall prim.
( TestablePrim prim
, Show2 prim
, Show1 (ModelOf prim)
, MightBeEmptyHunk prim
, MightHaveDuplicate prim
, Arbitrary (Sealed2 prim)
, Arbitrary (Sealed2 (prim :> prim))
, Arbitrary (Sealed2 (WithState prim))
, Arbitrary (Sealed2 (WithState (prim :> prim)))
) => [Test]
qc_prim =
-- The following fails because of setpref patches:
-- testProperty "prim inverse doesn't commute" (inverseDoesntCommute :: Prim -> Maybe Doc)
(case runCoalesceTests @prim of
Just Dict ->
[ testProperty "prim coalesce effect preserving"
(unseal2 $ PropG.coalesceEffectPreserving coalesce :: Sealed2 (WithState (prim :> prim)) -> TestResult)
]
Nothing -> [])
++ concat
[ pair_properties @prim "arbitrary" arbitraryThing
, pair_properties @(FL prim) "arbitrary FL" arbitraryThing
, coalesce_properties @prim "arbitrary" arbitraryThing
, prim_commute_properties @prim "arbitrary" arbitraryThing
, prim_commute_properties @(FL prim) "arbitrary FL" arbitraryThing
, patch_properties @prim "arbitrary" arbitraryThing
, patch_properties @(FL prim) "arbitrary FL" arbitraryThing
, patch_repo_properties @prim "arbitrary" arbitraryThing
, patch_repo_properties @(FL prim) "arbitrary FL" arbitraryThing
, pair_repo_properties @prim "arbitrary" arbitraryThing
, pair_repo_properties @(FL prim) "arbitrary FL" arbitraryThing
, triple_properties @prim "arbitrary" arbitraryThing
, [ testProperty "readPatch/showPatch"
(unseal2 $ PropG.showRead :: Sealed2 prim -> TestResult)
, testProperty "readPatch/showPatch (FL)"
(unseal2 $ PropG.showRead :: Sealed2 (FL prim) -> TestResult)
]
]
qc_named_prim :: forall prim.
( TestablePrim prim
, Show2 prim
, Show1 (ModelOf (NamedPrim prim))
, MightBeEmptyHunk prim
, Arbitrary (Sealed2 (NamedPrim prim))
, Arbitrary (Sealed2 (NamedPrim prim :> NamedPrim prim))
, Arbitrary (Sealed2 (WithState (NamedPrim prim)))
, Arbitrary (Sealed2 (WithState (NamedPrim prim :> NamedPrim prim)))
) => [Test]
qc_named_prim =
qc_prim @(NamedPrim prim) ++
[ testProperty
"prim inverse doesn't commute"
(unseal2 $ PropG.inverseDoesntCommute :: Sealed2 (NamedPrim prim) -> TestResult)
]
qc_V2 :: forall prim wXx wYy.
( PrimPatch prim
, Annotate prim
, Show1 (ModelOf prim)
, ShrinkModel prim
, PropagateShrink prim prim
, ArbitraryPrim prim
, Shrinkable prim
, RepoState (ModelOf prim) ~ ApplyState prim
)
=> prim wXx wYy -> [Test]
qc_V2 _ =
[ testProperty "with quickcheck that patches are consistent"
(withSingle consistent)
]
++ repoPatchProperties @(RepoPatchV2 prim)
++ concat
[ merge_properties @(RepoPatchV2 prim) "tree" (TestGenerator mergePairFromTree)
, merge_properties @(RepoPatchV2 prim) "twfp" (TestGenerator mergePairFromTWFP)
, pair_properties @(RepoPatchV2 prim) "tree" (TestGenerator commutePairFromTree)
, pair_properties @(RepoPatchV2 prim) "twfp" (TestGenerator commutePairFromTWFP)
, patch_properties @(RepoPatchV2 prim) "tree" (TestGenerator patchFromTree)
, triple_properties @(RepoPatchV2 prim) "tree" (TestGenerator commuteTripleFromTree)
]
where
consistent :: RepoPatchV2 prim wX wY -> TestResult
consistent = maybeFailed . isConsistent
qc_V3 :: forall prim wXx wYy.
( PrimPatch prim
, Annotate prim
, Show1 (ModelOf prim)
, ShrinkModel prim
, PropagateShrink prim prim
, ArbitraryPrim prim
, Shrinkable prim
, RepoState (ModelOf prim) ~ ApplyState prim
)
=> prim wXx wYy
-> [Test]
qc_V3 _ =
[ testProperty "repo invariants"
(withSequence (PropR3.prop_repoInvariants :: SequenceProperty (RepoPatchV3 prim)))
]
++ repoPatchProperties @(RepoPatchV3 prim)
++ difficultRepoPatchProperties @(RepoPatchV3 prim)
repoPatchProperties :: forall p.
( ArbitraryRepoPatch p
, Show2 p
, Show1 (ModelOf p)
, CheckedMerge p
, ShrinkModel (PrimOf p)
, PrimBased p
)
=> [Test]
repoPatchProperties =
[ testProperty "readPatch/showPatch"
(withSingle (PropG.showRead :: PatchProperty p))
, testProperty "readPatch/showPatch (RL)"
(withSequence (PropG.showRead :: SequenceProperty p))
{- we no longer support inversion for RepoPatches
, testProperty "invert involution"
(withSingle (PropG.invertInvolution :: PatchProperty p))
, testProperty "inverse composition"
(withPair (PropG.inverseComposition :: PairProperty p))
-}
, testProperty "resolutions don't conflict"
(withSequence (PropR.propResolutionsDontConflict :: SequenceProperty p))
]
-- | These properties regularly fail for RepoPatchV2 with the standard test
-- case generator when we crank up the number of tests (to e.g. 10000).
difficultRepoPatchProperties :: forall p.
( ArbitraryRepoPatch p
, ShrinkModel (PrimOf p)
, Show2 p
, CheckedMerge p
, MightHaveDuplicate p
, Show1 (ModelOf p)
, PrimBased p
)
=> [Test]
difficultRepoPatchProperties =
[ testProperty "reorderings are consistent"
(PropR.propConsistentReorderings @p)
{- we no longer support inversion for RepoPatches
, testProperty "inverses commute"
(withPair (PropG.commuteInverses com))
, testConditional "nontrivial inverses commute"
(withPair nontrivialCommute)
(withPair (PropG.commuteInverses com))
-}
, testProperty "recommute"
(withPair (PropG.recommute com))
, testConditional "nontrivial recommute"
(fromNothing . withPair nontrivialCommute)
(withPair (PropG.recommute com))
, testConditional "permutivity"
(fromNothing . withTriple notDuplicatestriple)
(withTriple (PropG.permutivity com))
, testConditional "nontrivial permutivity"
(fromNothing . withTriple (\t -> nontrivialTriple t && notDuplicatestriple t))
(withTriple (PropG.permutivity com))
, testProperty "merge either way"
(withFork (PropG.mergeEitherWay :: MergeProperty p))
{- this test relies on inversion and is thereore only valid for prims
, testProperty "merge either way valid"
(withFork (PropG.mergeEitherWayValid :: MergeProperty p))
-}
, testConditional "nontrivial merge either way"
(fromNothing . withFork nontrivialMerge)
(withFork (PropG.mergeEitherWay :: MergeProperty p))
, testProperty "merge commute"
(withFork (PropG.mergeCommute :: MergeProperty p))
, testProperty "resolutions are invariant under reorderings"
(withSequence (PropR.propResolutionsOrderIndependent :: SequenceProperty p))
]
where
com :: (p :> p) wA wB -> Maybe ((p :> p) wA wB)
com = commute
pair_properties :: forall p gen
. ( Show gen, Arbitrary gen, MightHaveDuplicate p
, Commute p, Invert p, ShowPatchBasic p, Eq2 p
)
=> PropList (p :> p) gen
pair_properties genname gen =
properties gen "commute" genname
[ ("recommute" , TestCondition (const True) , TestCheck (PropG.recommute commute) )
, ("nontrivial recommute" , TestCondition nontrivialCommute, TestCheck (PropG.recommute commute) )
, ("inverses commute" , TestCondition (const True) , TestCheck (PropG.commuteInverses commute) )
, ("nontrivial inverses" , TestCondition nontrivialCommute, TestCheck (PropG.commuteInverses commute) )
, ("inverse composition" , TestCondition (const True) , TestCheck PropG.inverseComposition )
]
coalesce_properties :: forall p gen
. ( Show gen, Arbitrary gen, TestablePrim p
, MightBeEmptyHunk p
)
=> PropList (p :> p :> p) gen
coalesce_properties genname gen =
properties gen "commute" genname
(case runCoalesceTests @p of
Just Dict -> [ ("coalesce commutes with commute", TestCondition (const True), TestCheck (PropG.coalesceCommute coalesce)) ]
Nothing -> [])
-- The following properties do not hold for "RepoPatchV2" patches (conflictors and
-- duplicates, specifically) .
prim_commute_properties :: forall p gen
. (Show gen, Arbitrary gen, Commute p, Invert p, ShowPatchBasic p, Eq2 p)
=> PropList (p :> p) gen
prim_commute_properties genname gen =
properties gen "commute" genname
[ ("square commute law", TestCondition (const True) , TestCheck (PropG.squareCommuteLaw commute))
, ("nontrivial square commute law", TestCondition nontrivialCommute, TestCheck (PropG.squareCommuteLaw commute))
]
patch_properties :: forall p gen .
( Show gen
, Arbitrary gen
, Invert p
, Eq2 p
, ShowPatchBasic p
)
=> PropList p gen
patch_properties genname gen =
properties gen "patch" genname
[ ("inverse . inverse is id" , TestCondition (const True) , TestCheck PropG.invertInvolution)
]
patch_repo_properties
:: forall p gen
. ( Show gen, Arbitrary gen
, Invert p, Apply p, ShowPatchBasic p
, RepoModel (ModelOf p)
, RepoState (ModelOf p) ~ ApplyState p
)
=> PropList (WithState p) gen
patch_repo_properties genname gen =
properties gen "patch/repo" genname
[ ("invert rollback" , TestCondition (const True) , TestCheck PropG.invertRollback)
]
merge_properties :: forall p gen .
( Show gen, Arbitrary gen, Commute p
, Invert p, Eq2 p, Merge p, ShowPatchBasic p
, MightHaveDuplicate p, Check p
)
=> PropList (p :\/: p) gen
merge_properties genname gen =
properties gen "merge" genname
[ ("merge either way" , TestCondition (const True) , TestCheck PropG.mergeEitherWay )
, ("merge either way valid" , TestCondition (const True) , TestCheck PropG.mergeEitherWayValid )
, ("nontrivial merge either way", TestCondition nontrivialMerge, TestCheck PropG.mergeEitherWay )
, ("merge commute" , TestCondition (const True) , TestCheck PropG.mergeCommute )
]
triple_properties :: forall p gen .
( Show gen, Arbitrary gen, Commute p
, Eq2 p, ShowPatchBasic p
, MightHaveDuplicate p
)
=> PropList (p :> p :> p) gen
triple_properties genname gen =
properties gen "triple" genname
[ ( "permutivity"
, TestCondition (notDuplicatestriple)
, TestCheck (PropG.permutivity commute) )
, ( "nontrivial permutivity"
, TestCondition (\t -> nontrivialTriple t && notDuplicatestriple t)
, TestCheck (PropG.permutivity commute) )
]
pair_repo_properties
:: forall p gen .
( Show gen
, Arbitrary gen
, Commute p
, Apply p
, ShowPatchBasic p
, MightBeEmptyHunk p
, RepoModel (ModelOf p)
, RepoState (ModelOf p) ~ ApplyState p
)
=> PropList (WithState (p :> p)) gen
pair_repo_properties genname gen =
properties gen "patch/repo" genname
[ ( "commute is effect preserving"
, TestCondition (const True)
, TestCheck (PropG.effectPreserving commute))
]
-- tests (either QuickCheck or Unit) that should be run on any type of patch
general_patchTests
:: forall p
. ( ArbitraryRepoPatch p, CheckedMerge p
, PrimBased p, Commute (OnlyPrim p), ArbitraryPrim (OnlyPrim p)
, ShrinkModel (PrimOf p)
, Show1 (ModelOf (PrimOf p)), Show2 p
)
=> [Test]
general_patchTests =
[ testGroup "Rebase patches" $ Rebase.testSuite @p
, testGroup "Unwind" $ Unwind.testSuite @p
]
-- | This is the big list of tests that will be run using testrunner.
testSuite :: [Test]
testSuite =
[ primTests
, repoPatchV2Tests
, repoPatchV3Tests
, Darcs.Test.Patch.Info.testSuite
, Darcs.Test.Patch.Selection.testSuite
]
where
primTests = testGroup "Prim patches"
[ testGroup "V1.Prim wrapper for Prim.V1" $ qc_prim @Prim1
, testGroup "V2.Prim wrapper for Prim.V1" $ qc_prim @Prim2
, testGroup "Prim.FileUUID" $ qc_prim @FileUUID.Prim
, testGroup "NamedPrim over V2.Prim" $ qc_named_prim @Prim2
, testGroup "NamedPrim over Prim.FileUUID" $ qc_named_prim @FileUUID.Prim
]
repoPatchV2Tests = testGroup "RepoPatchV2"
[ testGroup "using V2.Prim wrapper for Prim.V1" $
unit_V2P1 ++ qc_V2 (undefined :: Prim2 wX wY) ++
general_patchTests @(RepoPatchV2 Prim2)
, testGroup "using Prim.FileUUID" $
qc_V2 (undefined :: FileUUID.Prim wX wY) ++
general_patchTests @(RepoPatchV2 FileUUID.Prim)
]
repoPatchV3Tests = testGroup "RepoPatchV3"
[ testGroup "using V2.Prim wrapper for Prim.V1" $
qc_V3 (undefined :: Prim2 wX wY) ++
general_patchTests @(RepoPatchV3 Prim2)
, testGroup "using Prim.FileUUID" $
qc_V3 (undefined :: FileUUID.Prim wX wY) ++
general_patchTests @(RepoPatchV3 FileUUID.Prim)
]