RepoPatchV2.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE UndecidableInstances #-}
module Darcs.Test.Patch.Arbitrary.RepoPatchV2 where
import Darcs.Test.Patch.Arbitrary.Generic
import Darcs.Test.Patch.Arbitrary.PrimV1 ()
import Darcs.Test.Patch.RepoModel

import Darcs.Patch.Witnesses.Ordered
import Darcs.Patch.Merge ( Merge(..) )
import Darcs.Patch.Patchy ( Patchy, Commute(..) )
import Darcs.Patch.Prim ( PrimPatch, anIdentity )
import Darcs.Patch.V2 ( RepoPatchV2 )
import Darcs.Patch.V2.RepoPatch ( isDuplicate )

import Test.QuickCheck
import Darcs.Test.Patch.WithState
import Darcs.Patch.Witnesses.Sealed
import Darcs.Patch.Witnesses.Eq
import Darcs.Patch.Prim ( FromPrim(..) )


nontrivialRepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Bool
nontrivialRepoPatchV2s = nontrivialCommute

nontrivialCommute :: (Patchy p, MyEq p) => (p :> p) wX wY -> Bool
nontrivialCommute (x :> y) = case commute (x :> y) of
                              Just (y' :> x') -> not (y' `unsafeCompare` y) ||
                                                 not (x' `unsafeCompare` x)
                              Nothing -> False

nontrivialMergerepoPatchV2s :: PrimPatch prim => (RepoPatchV2 prim :\/: RepoPatchV2 prim) wX wY -> Bool
nontrivialMergerepoPatchV2s = nontrivialMerge

nontrivialMerge :: (Patchy p, MyEq p, Merge p) => (p :\/: p) wX wY -> Bool
nontrivialMerge (x :\/: y) = case merge (x :\/: y) of
                              y' :/\: x' -> not (y' `unsafeCompare` y) ||
                                            not (x' `unsafeCompare` x)

instance MightHaveDuplicate (RepoPatchV2 prim) where
  hasDuplicate = isDuplicate

instance (RepoModel (ModelOf prim), ArbitraryPrim prim)
         => Arbitrary (Sealed2 (FL (RepoPatchV2 prim))) where
    arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim)))
                   return $ unseal seal2 (flattenOne tree)

instance (RepoModel (ModelOf prim), ArbitraryPrim prim)
         => Arbitrary (Sealed2 (RepoPatchV2 prim)) where
    arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim)))
                   case mapFL seal2 `unseal` flattenOne tree of
                     [] -> return $ seal2 $ fromPrim anIdentity
                     ps -> elements ps

notDuplicatestriple :: (RepoPatchV2 prim :> RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> Bool
notDuplicatestriple (a :> b :> c) = not (isDuplicate a || isDuplicate b || isDuplicate c)

nontrivialTriple :: PrimPatch prim => (RepoPatchV2 prim :> RepoPatchV2 prim :> RepoPatchV2 prim) wX wY -> 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'))