RepoPatchV2.hs

module Darcs.Test.Patch.Properties.RepoPatchV2
       ( propConsistentTreeFlattenings ) where

import Prelude ()
import Darcs.Prelude

import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenTree, G2(..), mapTree )
import Darcs.Test.Patch.WithState
import Darcs.Test.Patch.RepoModel ( RepoModel, repoApply, showModel, eqModel, RepoState
                                  , Fail, maybeFail )
import qualified Darcs.Util.Tree as T ( Tree )

import Darcs.Patch.Prim ( fromPrim )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
import qualified Darcs.Patch.V2.Prim as V2 ( Prim )
import Darcs.Patch.V2 ( RepoPatchV2 )

type Prim2 = V2.Prim

fromPrim2 :: Prim2 wX wY -> RepoPatchV2 Prim2 wX wY
fromPrim2 = fromPrim

assertEqualFst :: (RepoModel a, Show b, Show c) => (Fail (a x), b) -> (Fail (a x), c) -> Bool
assertEqualFst (x,bx) (y,by)
    | Just x' <- maybeFail x, Just y' <- maybeFail y, x' `eqModel` y' = True
    | Nothing <- maybeFail x, Nothing <- maybeFail y = True
    | otherwise = error ("Not really equal:\n" ++ showx ++ "\nand\n" ++ showy
                         ++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by)
      where showx | Just x' <- maybeFail x = showModel x'
                  | otherwise = "Nothing"
            showy | Just y' <- maybeFail y = showModel y'
                  | otherwise = "Nothing"

propConsistentTreeFlattenings :: (RepoState model ~ T.Tree, RepoModel model)
                              => Sealed (WithStartState model (Tree Prim2))
                              -> Bool
propConsistentTreeFlattenings (Sealed (WithStartState start t))
  = fromJust $
    do Sealed (G2 flat) <- return $ flattenTree $ mapTree fromPrim2 t
       rms <- return $ map (start `repoApply`) flat
       return $ and $ zipWith assertEqualFst (zip rms flat) (tail $ zip rms flat)