{-# LANGUAGE AllowAmbiguousTypes  #-}
--  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.

module Darcs.Test.Patch ( testSuite ) where

import Data.Maybe( isNothing )
import Test.Framework ( Test, testGroup )
import Test.Framework.Providers.HUnit ( testCase )
import Test.Framework.Providers.QuickCheck2 ( testProperty )
import Test.QuickCheck.Arbitrary( Arbitrary )
import Test.QuickCheck( Testable )
import Test.HUnit ( assertBool )

import Darcs.Test.Util.TestResult ( TestResult, isOk, fromMaybe )
import Darcs.Test.Patch.Utils ( testConditional )

import Darcs.Patch.Witnesses.Ordered
import Darcs.Patch.Witnesses.Sealed
import Darcs.Patch.Witnesses.Eq ( Eq2, unsafeCompare )
import Darcs.Patch.Witnesses.Show
import Darcs.Patch.Prim( PrimPatch, coalesce, FromPrim, PrimOf )
import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim )
import Darcs.Patch.RepoPatch ( RepoPatch )
import Darcs.Patch.Type ( PatchType(..) )
import Darcs.Patch.V1 as V1 ( RepoPatchV1 )
import qualified Darcs.Patch.V1.Prim as V1 ( Prim )
import qualified Darcs.Patch.V2.Prim as V2 ( Prim )
import Darcs.Patch.V2.RepoPatch ( isConsistent, isForward, RepoPatchV2 )
import Darcs.Patch.Commute ( Commute(..) )
import Darcs.Patch.Invert ( Invert )
import Darcs.Patch.Merge( Merge )
import Darcs.Patch.Show ( ShowPatchBasic )
import Darcs.Patch.Apply( Apply, ApplyState )

import Darcs.Test.Patch.Arbitrary.Generic
import qualified Darcs.Test.Patch.Arbitrary.PrimV1 as P1
import Darcs.Test.Patch.Arbitrary.PrimFileUUID()
import Darcs.Test.Patch.Arbitrary.RepoPatchV1 ()
import Darcs.Test.Patch.Arbitrary.RepoPatchV2
import Darcs.Test.Patch.Arbitrary.PrimV1 ()
import Darcs.Test.Patch.RepoModel
import Darcs.Test.Patch.WithState( WithState, WithStartState )

import qualified Darcs.Test.Patch.Info
import qualified Darcs.Test.Patch.Selection

import qualified Darcs.Test.Patch.Examples.Set1 as Ex
import qualified Darcs.Test.Patch.Examples.Set2Unwitnessed as ExU

import Darcs.Test.Patch.Properties.Check( Check(..) )
import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop1
import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop2
import qualified Darcs.Test.Patch.Properties.Generic as PropG
import qualified Darcs.Test.Patch.Properties.RepoPatchV2 as PropR
import qualified Darcs.Test.Patch.Properties.GenericUnwitnessed as PropU

import qualified Darcs.Test.Patch.Rebase as Rebase

import qualified Darcs.Test.Patch.WSub as WSub


type Prim1 = V1.Prim
type Prim2 = V2.Prim

newtype TestGenerator thing gen = TestGenerator (forall t ctx . ((forall wXx wYy . thing wXx wYy -> t) -> (gen ctx -> t)))
newtype TestCondition thing = TestCondition (forall wYy wZz . thing wYy wZz -> Bool)
newtype TestCheck thing t = TestCheck (forall wYy wZz . thing wYy wZz -> t)

-- arbitraryThing :: (forall wXx wYy . thing wXx wYy -> t) -> (thing wA wB -> t)
arbitraryThing :: x -> TestGenerator thing (thing x)
arbitraryThing _ = TestGenerator (\f p -> f p)

-- | 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.
testCases :: Show a => String               -- ^ The test name
             -> (a -> TestResult)  -- ^ The test function
             -> [a]                -- ^ The test data
             -> Test
testCases name test datas = testCase name (assertBool assertName res)
    where assertName = "Boolean assertion for \"" ++ name ++ "\""
          res        = and $ map (isOk . test) datas

unit_V1P1:: [Test]
unit_V1P1 =
  [ testCases "known commutes" Prop1.checkCommute Ex.knownCommutes
  , testCases "known non-commutes" Prop1.checkCantCommute Ex.knownCantCommutes
  , testCases "known merges" Prop1.checkMerge Ex.knownMerges
  , testCases "known merges (equiv)" Prop1.checkMergeEquiv Ex.knownMergeEquivs
  , testCases "known canons" Prop1.checkCanon Ex.knownCanons
  , testCases "merge swaps" Prop1.checkMergeSwap Ex.mergePairs2
  , testCases "the patch validation works" Prop1.tTestCheck Ex.validPatches
  , testCases "commute/recommute" (PropG.recommute commute) Ex.commutePairs
  , testCases "merge properties: merge either way valid" Prop1.tMergeEitherWayValid Ex.mergePairs
  , testCases "merge properties: merge swap" PropG.mergeEitherWay Ex.mergePairs
  , testCases "primitive patch IO functions" (Prop1.tShowRead eqFLUnsafe) Ex.primitiveTestPatches
  , testCases "IO functions (test patches)" (Prop1.tShowRead eqFLUnsafe) Ex.testPatches
  , testCases "IO functions (named test patches)" (Prop1.tShowRead unsafeCompare) Ex.testPatchesNamed
  , testCases "primitive commute/recommute" (PropG.recommute commute) Ex.primitiveCommutePairs
  ]

unit_V2P1 :: [Test]
unit_V2P1 =
  [ testCases "coalesce commute" (PropU.coalesceCommute WSub.coalesce) ExU.primPermutables
  , testCases "prim recommute" (PropU.recommute WSub.commute) ExU.commutables
  , testCases "prim patch and inverse commute" (PropU.patchAndInverseCommute 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 prim patch and inverse commute" (PropU.patchAndInverseCommute 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.show_read ExU.primPatches
  , testCases "read and show work on RepoPatchV2" PropU.show_read ExU.repov2Patches
  , testCases "example flattenings work" PropU.consistentTreeFlattenings 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
  , testCases "V2 partial permutivity" (PropU.partialPermutivity WSub.commute) ExU.repov2NonduplicateTriples
  ]

qc_prim :: forall prim wX wY wA model.
           (PrimPatch prim, ArbitraryPrim prim, Show2 prim
           , model ~ ModelOf prim, RepoModel model
           , RepoState model ~ ApplyState (PrimOf prim)
           , Show1 (ModelOf prim)
           , Check prim, PrimOf prim ~ prim
           , FromPrim prim
           , MightBeEmptyHunk prim
           , MightHaveDuplicate prim
           , Show1 (prim wA)
           , Arbitrary (Sealed ((prim :> prim) wA))
           , Arbitrary (Sealed ((prim :> prim :> prim) wA))
           , Arbitrary (Sealed (prim wA))
           , Arbitrary (Sealed (FL prim wA))
           , Arbitrary (Sealed ((FL prim :> FL prim) wA))
           , Arbitrary (Sealed (WithState model prim wA))
           , Arbitrary (Sealed (WithState model (FL prim) wA))
           , Arbitrary (Sealed2 (WithState model (prim :> prim)))
           , Arbitrary (Sealed ((WithState model (prim :> prim)) wA))
           , Arbitrary (Sealed ((WithState model (FL prim :> FL prim)) wA))
           ) => prim wX wY -> [Test]
qc_prim p =
  -- The following fails because of setpref patches...
  -- testProperty "prim inverse doesn't commute" (inverseDoesntCommute :: Prim -> Maybe Doc)
  (if runCoalesceTests p then
    [ testProperty "prim coalesce effect preserving... "
      (unseal2 $ PropG.coalesceEffectPreserving coalesce :: Sealed2 (WithState model (prim :> prim)) -> TestResult)
    ]
   else [])
    ++ concat
  [ pair_properties            (undefined :: prim wX wY)    "arbitrary"    arbitraryThing'
  , pair_properties            (undefined :: FL prim wX wY) "arbitrary FL" arbitraryThing'
  , coalesce_properties        (undefined :: prim wX wY)    "arbitrary"    arbitraryThing'
  , nonrpv2_commute_properties (undefined :: prim wX wY)    "arbitrary"    arbitraryThing'
  , nonrpv2_commute_properties (undefined :: FL prim wX wY) "arbitrary FL" arbitraryThing'
  , patch_properties           (undefined :: prim wX wA)    "arbitrary"    arbitraryThing'
  , patch_properties           (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing'
  , patch_repo_properties      (undefined :: prim wX wA)    "arbitrary"    arbitraryThing'
  , patch_repo_properties      (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing'
  , pair_repo_properties       (undefined :: prim wX wA)    "arbitrary"    arbitraryThing'
  , pair_repo_properties       (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing'
  ]
      where arbitraryThing' = arbitraryThing (undefined :: wA) -- bind the witness for generator

consistentV2 :: RepoPatchV2 Prim2 wX wY -> TestResult
consistentV2 = fromMaybe . isConsistent

commuteRepoPatchV2s :: (RepoPatchV2 Prim2 :> RepoPatchV2 Prim2) wX wY -> Maybe ((RepoPatchV2 Prim2 :> RepoPatchV2 Prim2) wX wY)
commuteRepoPatchV2s = commute

qc_V2P1 :: [Test]
qc_V2P1 =
  [ testProperty "tree flattenings are consistent... "
    (PropR.propConsistentTreeFlattenings :: Sealed (WithStartState (ModelOf Prim2) (Tree Prim2)) -> Bool)
  , testProperty "with quickcheck that RepoPatchV2 patches are consistent... "
    (unseal $ P1.patchFromTree $ consistentV2)
  -- permutivity ----------------------------------------------------------------------------
  , testConditional "permutivity"
    (unseal $ P1.commuteTripleFromTree notDuplicatestriple)
    (unseal $ P1.commuteTripleFromTree $ PropG.permutivity commuteRepoPatchV2s)
  , testConditional "partial permutivity"
    (unseal $ P1.commuteTripleFromTree notDuplicatestriple)
    (unseal $ P1.commuteTripleFromTree $ PropG.partialPermutivity commuteRepoPatchV2s)
  , testConditional "nontrivial permutivity"
    (unseal $ P1.commuteTripleFromTree (\t -> nontrivialTriple t && notDuplicatestriple t))
    (unseal $ P1.commuteTripleFromTree $ (PropG.permutivity commuteRepoPatchV2s))
  ]

qc_V2 :: forall prim wXx wYy . (PrimPatch prim, Show1 (ModelOf prim), RepoModel (ModelOf prim),
                                  ArbitraryPrim prim, Show2 prim,
                                  RepoState (ModelOf prim) ~ ApplyState prim)
      => prim wXx wYy -> [Test]
qc_V2 _ =
  [ testProperty "readPatch and showPatch work on RepoPatchV2... "
    (unseal $ patchFromTree $ (PropG.show_read :: RepoPatchV2 prim wX wY -> TestResult))
  , testProperty "readPatch and showPatch work on FL RepoPatchV2... "
    (unseal2 $ (PropG.show_read :: FL (RepoPatchV2 prim) wX wY -> TestResult))
  , testProperty "we can do merges using QuickCheck"
    (isNothing . (PropG.propIsMergeable ::
                     Sealed (WithStartState (ModelOf prim) (Tree prim))
                     -> Maybe (Tree (RepoPatchV2 prim) wX)))
  ]
  ++ concat
  [ merge_properties   (undefined :: RepoPatchV2 prim wX wY) "tree" (TestGenerator mergePairFromTree)
  , merge_properties   (undefined :: RepoPatchV2 prim wX wY) "twfp" (TestGenerator mergePairFromTWFP)
  , pair_properties    (undefined :: RepoPatchV2 prim wX wY) "tree" (TestGenerator commutePairFromTree)
  , pair_properties    (undefined :: RepoPatchV2 prim wX wY) "twfp" (TestGenerator commutePairFromTWFP)
  , patch_properties   (undefined :: RepoPatchV2 prim wX wY) "tree" (TestGenerator patchFromTree)
  ]

properties :: forall thing gen. (Show1 gen, Arbitrary (Sealed gen)) =>
              TestGenerator thing gen
           -- -> forall xx yy. thing xx yy
           -> String -> String
           -> forall t. Testable t => [(String, TestCondition thing, TestCheck thing t)]
           -> [Test]
properties (TestGenerator gen) prefix genname tests =
  [ cond name condition check | (name, condition, check) <- tests ]
  where cond :: forall testable. Testable testable
             => String -> TestCondition thing -> TestCheck thing testable -> Test
        cond t (TestCondition c) (TestCheck p) =
          testConditional (prefix ++ " (" ++ genname ++ "): " ++ t) (unseal $ gen c) (unseal $ gen p)

type PropList what gen = String -> TestGenerator what gen -> [Test]

pair_properties :: forall p gen x y
                 . ( Show1 gen, Arbitrary (Sealed gen), MightHaveDuplicate p
                   , Commute p, Invert p, ShowPatchBasic p, Eq2 p
                   )
                => p x y -> 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 x y
                     . ( Show1 gen, Arbitrary (Sealed gen), PrimPatch p
                       , ArbitraryPrim p, MightBeEmptyHunk p
                       )
                    => p x y -> PropList (p :> p :> p) gen
coalesce_properties p genname gen =
  properties gen "commute" genname
   (if runCoalesceTests p then [ ("coalesce commutes with commute", TestCondition (const True), TestCheck (PropG.coalesceCommute coalesce)) ] else [])

-- The following properties do not hold for "RepoPatchV2" patches (conflictors and
-- duplicates, specifically) .
nonrpv2_commute_properties :: forall p gen x y
                            . (Show1 gen, Arbitrary (Sealed gen), Commute p, Invert p, ShowPatchBasic p, Eq2 p)
                           => p x y -> PropList (p :> p) gen
nonrpv2_commute_properties _ genname gen =
  properties gen "commute" genname
  [ ("patch & inverse commute", TestCondition (const True)     , TestCheck (PropG.patchAndInverseCommute commute))
  , ("patch & inverse commute", TestCondition nontrivialCommute, TestCheck (PropG.patchAndInverseCommute commute))
  ]

patch_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Invert p, Apply p, Eq2 p)
                 => p x y -> PropList p gen
patch_properties _ genname gen =
  properties gen "patch" genname
  [ ("inverse . inverse is id"  , TestCondition (const True)     , TestCheck PropG.invertSymmetry)
  ]

patch_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen),
                                            Invert p, Apply p, ShowPatchBasic p,
                                            RepoModel (ModelOf (PrimOf p)),
                                            RepoState (ModelOf (PrimOf p)) ~ ApplyState p)
                      => p x y -> PropList (WithState (ModelOf (PrimOf p)) p) gen
patch_repo_properties _ genname gen =
  properties gen "patch/repo" genname
  [ ("invert rollback"          , TestCondition (const True)     , TestCheck PropG.invertRollback)
  ]

pair_repo_properties
  :: forall p gen x y.
     ( Show1 gen
     , Arbitrary (Sealed gen)
     , Commute p
     , Apply p
     , ShowPatchBasic p
     , MightBeEmptyHunk p
     , RepoModel (ModelOf p)
     , RepoState (ModelOf p) ~ ApplyState p
     )
  => p x y -> PropList (WithState (ModelOf p) (p :> p)) gen
pair_repo_properties _ genname gen =
  properties
    gen
    "patch/repo"
    genname
    [ ( "commute is effect preserving"
      , TestCondition (const True)
      , TestCheck (PropG.effectPreserving commute))
    ]

merge_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen)
                                      , Invert p, Eq2 p, Merge p, ShowPatchBasic p
                                      , MightHaveDuplicate p, Show2 p, Check p)
                 => p x y -> 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 Prop1.tMergeEitherWayValid)
  , ("nontrivial merge either way", TestCondition nontrivialMerge, TestCheck PropG.mergeEitherWay      )
  , ("merge commute"              , TestCondition (const True)   , TestCheck PropG.mergeCommute        )
  ]

qc_V1P1 :: [Test]
qc_V1P1 =
  [
    testProperty "show and read work right" (unseal Prop2.propReadShow)
  ]
  ++ Prop2.checkSubcommutes Prop2.subcommutesInverse "patch and inverse both commute"
  ++ Prop2.checkSubcommutes Prop2.subcommutesNontrivialInverse "nontrivial commutes are correct"
  ++ Prop2.checkSubcommutes Prop2.subcommutesFailure "inverses fail"
  ++
  [ testProperty "commuting by patch and its inverse is ok" Prop2.propCommuteInverse
  -- , testProperty "conflict resolution is valid... " Prop.propResolveConflictsValid
  , testProperty "a patch followed by its inverse is identity"
    Prop2.propPatchAndInverseIsIdentity
  , testProperty "'simple smart merge'" Prop2.propSimpleSmartMergeGoodEnough
  , testProperty "commutes are equivalent" Prop2.propCommuteEquivalency
  , testProperty "merges are valid" Prop2.propMergeValid
  , testProperty "inverses being valid" Prop2.propInverseValid
  , testProperty "other inverse being valid" Prop2.propOtherInverseValid
  -- The patch generator isn't smart enough to generate correct test cases for
  -- the following: (which will be obsoleted soon, anyhow)
  -- , testProperty "the order dependence of unravel... " Prop.propUnravelOrderIndependent
  -- , testProperty "the unravelling of three merges... " Prop.propUnravelThreeMerge
  -- , testProperty "the unravelling of a merge of a sequence... " Prop.propUnravelSeqMerge
  , testProperty "the order of commutes" Prop2.propCommuteEitherOrder
  , testProperty "commute either way" Prop2.propCommuteEitherWay
  , testProperty "the double commute" Prop2.propCommuteTwice
  , testProperty "merges commute and are well behaved"
    Prop2.propMergeIsCommutableAndCorrect
  , testProperty "merges can be swapped" Prop2.propMergeIsSwapable
  , testProperty "again that merges can be swapped (I'm paranoid) " Prop2.propMergeIsSwapable

  ] -- the following properties are disabled, because they routinely lead to
    -- exponential cases, making the tests run for ever and ever; nevertheless,
    -- we would expect them to hold
 {- ++ merge_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "tree" mergePairFromTree
    ++ merge_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "twfp" mergePairFromTWFP
    ++ commute_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "tree" commutePairFromTree
    ++ commute_properties (undefined :: V1.RepoPatchV1 Prim1 wX wY) "twfp" commutePairFromTWFP -}

-- tests (either QuickCheck or Unit) that should be run on any type of patch
general_patchTests :: (RepoPatch p, ArbitraryPrim (PrimOf p), Show2 (PrimOf p)) => PatchType rt p -> [Test]
general_patchTests pt =
     [ testGroup "Rebase patches" $ Rebase.testSuite pt
     ]

-- | This is the big list of tests that will be run using testrunner.
testSuite :: [Test]
testSuite =
  [ testGroup "Darcs.Patch.Prim.V1 for V1" $ qc_prim (undefined :: Prim1 wX wY)
    -- testing both Prim1 and Prim2 here is redundant, since they differ
    -- only in their read/show behavior, which is not tested in qc_prim;
    -- we still include them because such tests might be added in the future
  , testGroup "Darcs.Patch.Prim.V1 for V2" $ qc_prim (undefined :: Prim2 wX wY)
  , testGroup "Darcs.Patch.Prim.FileUUID" $ qc_prim (undefined :: FileUUID.Prim wX wY)
  , testGroup "Darcs.Patch.V1 (using Prim.V1)" $
      unit_V1P1 ++ qc_V1P1 ++
      general_patchTests (PatchType :: PatchType rt (V1.RepoPatchV1 Prim1))
  , testGroup "Darcs.Patch.V2 (using Prim.V1)" $
      unit_V2P1 ++ qc_V2 (undefined :: Prim2 wX wY) ++ qc_V2P1 ++
      general_patchTests (PatchType :: PatchType rt (RepoPatchV2 Prim2))
  , testGroup "Darcs.Patch.V2 (using Prim.FileUUID)" $
      qc_V2 (undefined :: FileUUID.Prim wX wY) ++
      general_patchTests (PatchType :: PatchType rt (RepoPatchV2 FileUUID.Prim))
  , Darcs.Test.Patch.Info.testSuite
  , Darcs.Test.Patch.Selection.testSuite
  ]
