darcs-2.5.1: src/Darcs/Test/Patch/QuickCheck.hs
{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans -fglasgow-exts #-}
{-# LANGUAGE CPP, UndecidableInstances, ScopedTypeVariables, ViewPatterns #-}
#include "gadts.h"
module Darcs.Test.Patch.QuickCheck ( WithStartState, RepoModel, Tree,
mergeExamples, commuteExamples, tripleExamples,
propConsistentTreeFlattenings, propFail,
propIsMergeable,
flattenOne, testConditional,
commutePairFromTree, mergePairFromTree,
commuteTripleFromTree,
commutePairFromTWFP, mergePairFromTWFP, getPairs, getTriples,
patchFromTree,
quickCheck, realPatchLoopExamples, shrink
) where
import Control.Arrow ( (***) )
import Control.Monad ( liftM, replicateM, mplus, mzero )
import qualified Data.ByteString.Char8 as BC (pack, head)
import qualified Data.ByteString as B (ByteString, length)
import Test.QuickCheck
import Test.Framework ( Test )
import Test.Framework.Providers.QuickCheck2 ( testProperty )
import Darcs.Witnesses.Sealed
import Darcs.Patch ( Patch )
import Darcs.Witnesses.Ordered
import Darcs.Patch.Patchy (--showPatch,
Invert(..), Commute(..))
import Darcs.Patch.Prim (Prim(..), Effect(..), FilePatchType(..), FromPrim(..), isIdentity )
import Darcs.Patch.Real ( RealPatch, prim2real )
import Darcs.Patch.Set ( Origin )
--import Darcs.ColorPrinter ( errorDoc )
--import Darcs.ColorPrinter ( traceDoc )
import Darcs.Witnesses.Show
--import Printer ( greenText, ($$) )
import Darcs.Patch.FileName ( FileName, fp2fn )
#include "impossible.h"
tripleExamples :: (FromPrim p, Commute p, Invert p) => [Sealed2 (p :> p :> p)]
tripleExamples = [commuteTripleFromTree seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "g"]))
(SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j"]))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "s"])) NilTree)))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "e"])) NilTree))
,commuteTripleFromTree seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file",
rmFileContents = [BC.pack "j"] })
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "s"]))
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree)))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "j"] [])) NilTree))
]
mergeExamples :: (FromPrim p, Commute p, Invert p) => [Sealed2 (p :\/: p)]
mergeExamples = map (unseal2 (mergePairFromCommutePair seal2)) commuteExamples
commuteExamples :: (FromPrim p, Commute p) => [Sealed2 (p :> p)]
commuteExamples = [
commutePairFromTWFP seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })
(TWFP 3
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"])) NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "b"]))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"]))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"]))
(SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] [])) NilTree)))))),
commutePairFromTWFP seal2 $
WithStartState
(RepoModel { rmFileName = fp2fn "./file",
rmFileContents = [BC.pack "f",BC.pack "s",BC.pack "d"] })
(TWFP 3
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "d"] [])) NilTree)
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f"] [])) NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f"] []))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "s",BC.pack "d"] []))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree)))))),
{- commutePairFromTWFP seal2 $
WithStartState
(RepoModel { rmFileName = fp2fn "./file",
rmFileContents = [BC.pack "f",BC.pack "u",
BC.pack "s",BC.pack "d"] })
(TWFP 5
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 4 [] [BC.pack "x"]))
(SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "d"] [])) NilTree))
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f",BC.pack "u"] [])) NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f"] []))
(SeqTree (FP(fp2fn "./file") (Hunk 0 [BC.pack "u",BC.pack "s",BC.pack "d"] []))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "a"]))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "a"] [])) NilTree))))))),-}
commutePairFromTree seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file",
rmFileContents = [BC.pack "n",BC.pack "t",BC.pack "h"] })
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "n",BC.pack "t",BC.pack "h"] []))
NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "h"] []))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "n"] []))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "t"] [])) NilTree)))),
commutePairFromTree seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "n"])) NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "i"]))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "i"])) NilTree))),
commutePairFromTree seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "c"]))
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "c"] [BC.pack "r"])) NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"]))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "d"])) NilTree))))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) NilTree)),
commutePairFromTWFP seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })
(TWFP 1
(ParTree
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "t"])) NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "t"])) NilTree))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) NilTree))),
commutePairFromTWFP seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file",
rmFileContents = [BC.pack "f",BC.pack " r",
BC.pack "c",BC.pack "v"] })
(TWFP 4
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "c",BC.pack "v"] []))
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "r"] []))
(SeqTree (FP (fp2fn "fi le") (Hunk 0 [BC.pack "f"] [])) NilTree))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f",BC.pack "r"] []))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "y"])) NilTree))))
(SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "v"] [])) NilTree))),
commutePairFromTree seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "z"])) NilTree)
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) NilTree)
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "r"])) NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "d"])) NilTree))))
, commutePairFromTree seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file",
rmFileContents = [BC.pack "t",BC.pack "r",
BC.pack "h"] })
(ParTree
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "t",BC.pack "r",BC.pack "h"] []))
NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "o"])) NilTree))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "t"] []))
(SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "h"] [])) NilTree)))
, commutePairFromTWFP seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) $
TWFP 2
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"])) NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "y"]))
(SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "m"]))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree))))
, commutePairFromTree seal2 $
WithStartState (RepoModel {rmFileName = fp2fn "./file",rmFileContents = [] })
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "p"]))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "p"] []))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "c"])) NilTree)))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "z"])) NilTree))
, commutePairFromTree seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "j" ]))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "j"] [])) NilTree))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree))
, commutePairFromTree seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "j" ]))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "j"] [])) NilTree)))
, commutePairFromTree seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file",
rmFileContents = [BC.pack "x",BC.pack "c"] })
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"]))
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "c"] [])) NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "x"] []))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "j"])) NilTree))))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "l"])) NilTree))
, commutePairFromTree seal2 $
WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })
(ParTree
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] (packStringLetters "s"))) NilTree)
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] (packStringLetters "k")))
(SeqTree (FP (fp2fn "./file") (Hunk 0 (packStringLetters "k") []))
(SeqTree (FP (fp2fn "./file") (Hunk 0 [] (packStringLetters "m")))
(SeqTree (FP (fp2fn "./file") (Hunk 0 (packStringLetters "m") [])) NilTree)))))
]
-- | Turns a condition and a test function into a conditional quickcheck
-- property that can be run by test-framework.
testConditional :: (Arbitrary p, Show p, Show q) => String -- ^ Test name
-> (p -> Bool) -- ^ Condition
-> (p -> Maybe q) -- ^ Test function
-> Test
testConditional name nottrivial t = testProperty name t'
where t' p = nottrivial p ==> case t p of
Nothing -> True
Just q -> error $ show q
data RepoModel C(x)
= RepoModel {
rmFileName :: !FileName,
rmFileContents :: [B.ByteString]
} deriving (Eq)
instance Show (RepoModel C(x)) where
showsPrec d rm = showParen (d > appPrec) $
showString "RepoModel { rmFileName = " . showsPrec 0 (rmFileName rm) .
showString ", rmFileContents = " . showsPrec' 0 (rmFileContents rm) .
showString " }"
where showsPrec' n lines | all ((==1) . B.length) lines = showsPrecC n lines
| otherwise = showsPrec n lines
showsPrecC _ [] = showString "[]"
showsPrecC n ss = showParen (n > 0) $ showString "packStringLetters " . showsPrec (appPrec + 1) (map BC.head ss)
instance Show1 RepoModel where
showDict1 = ShowDictClass
-- | The initial repository model. The repository contains a single file named
-- @./file@, which is empty.
initRepoModel :: RepoModel C(Origin)
initRepoModel = RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }
rebuildRepoModel :: RepoModel C(x) -> RepoModel C(y)
rebuildRepoModel rm = RepoModel { rmFileName = rmFileName rm, rmFileContents = rmFileContents rm }
-- | A combination of a patch and its final state. The state, in this module, is
-- typically represented by a 'RepoModel' value. The @px@ type is typically a
-- patch type applied to its pre-state, e.g. @Prim x@.
data WithEndState px s C(y) = WithEndState { wesPatch :: px C(y), _wesState :: s C(y) }
-- | A type class to generate arbitrary values, threading a state through the
-- arbitrary calls. So this can be used to generate a patch that comes after
-- another patch. The post-state of the generated patch is hidden by the
-- 'Sealed'.
class ArbitraryState s p where
arbitraryState :: s C(x) -> Gen (Sealed (WithEndState (p C(x)) s))
-- does a coarbitrary make sense?
-- | Generate a patch to a certain state.
class ArbitraryStateIn s p where
arbitraryStateIn :: s C(x) -> Gen (p C(x))
instance ArbitraryState RepoModel Prim where
arbitraryState rm = oneof [arbitraryFP rm]
instance Arbitrary (Sealed2 (FL Prim)) where
arbitrary = do Sealed2 ps1 <- liftM (unseal (seal2 . wesPatch)) $ arbitraryState initRepoModel
return $ Sealed2 $ mapFL_FL make_identity_identity ps1
where make_identity_identity :: Prim C(x y) -> Prim C(x y)
make_identity_identity p | IsEq <- isIdentity p = identity
| otherwise = p
instance Arbitrary (Sealed2 (FL (WithState RepoModel Prim))) where
arbitrary = liftM (unseal (seal2 . wesPatch)) $ arbitraryState initRepoModel
propConsistentTreeFlattenings :: Sealed (WithStartState RepoModel (Tree Prim)) -> Bool
propConsistentTreeFlattenings (Sealed (WithStartState start t))
= fromJust $
do Sealed (G2 flat) <- return $ flattenTree $ mapTree prim2real t
rms <- return $ map (applyPatch start) flat
return $ and $ zipWith assertEqualFst (zip rms flat) (tail $ zip rms flat)
assertEqualFst :: (Eq a, Show a, Show b, Show c) => (a, b) -> (a, c) -> Bool
assertEqualFst (x,bx) (y,by)
| x == y = True
| otherwise = error ("Not really equal:\n" ++ show x ++ "\nand\n" ++ show y
++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by)
-- WithState and propFail are handy for debugging arbitrary code
data WithState s p C(x y) = WithState (s C(x)) (p C(x y)) (s C(y))
deriving Show
data WithStartState s p C(x) = WithStartState (s C(x)) (p C(x))
instance (Show1 s, Show1 p) => Show (WithStartState s p C(x)) where
showsPrec d (WithStartState s p) = showParen (d > appPrec) $ showString "WithStartState " .
showsPrec1 (appPrec + 1) s . showString " " .
showsPrec1 (appPrec + 1) p
instance (Show1 s, Show1 p) => Show1 (WithStartState s p) where
showDict1 = ShowDictClass
propFail :: Int -> Tree Prim C(x) -> Bool
propFail n xs = sizeTree xs < n
instance ArbitraryState s p => ArbitraryState s (WithState s p) where
arbitraryState rm = do Sealed (WithEndState x rm') <- arbitraryState rm
return $ seal $ WithEndState (WithState rm x rm') rm'
instance ArbitraryState s p => ArbitraryState s (FL p) where
arbitraryState rm1 = sized $ \n -> do k <- choose (0, n)
arbitraryList k rm1
where arbitraryList :: FORALL(x) Int -> s C(x) -> Gen (Sealed (WithEndState (FL p C(x)) s))
arbitraryList 0 rm = return $ seal $ WithEndState NilFL rm
arbitraryList n rm = do Sealed (WithEndState x rm') <- arbitraryState rm
Sealed (WithEndState xs rm'') <- arbitraryList (n-1) rm'
return $ seal $ WithEndState (x :>: xs) rm''
arbitraryList _ _ = impossible
data Tree p C(x) where
NilTree :: Tree p C(x)
SeqTree :: p C(x y) -> Tree p C(y) -> Tree p C(x)
ParTree :: Tree p C(x) -> Tree p C(x) -> Tree p C(x)
mapTree :: (FORALL(y z) p C(y z) -> q C(y z)) -> Tree p C(x) -> Tree q C(x)
mapTree _ NilTree = NilTree
mapTree f (SeqTree p t) = SeqTree (f p) (mapTree f t)
mapTree f (ParTree t1 t2) = ParTree (mapTree f t1) (mapTree f t2)
instance Show2 p => Show (Tree p C(x)) where
showsPrec _ NilTree = showString "NilTree"
showsPrec d (SeqTree a t) = showParen (d > appPrec) $ showString "SeqTree " .
showsPrec2 (appPrec + 1) a . showString " " .
showsPrec (appPrec + 1) t
showsPrec d (ParTree t1 t2) = showParen (d > appPrec) $ showString "ParTree " .
showsPrec (appPrec + 1) t1 . showString " " .
showsPrec (appPrec + 1) t2
instance Show2 p => Show1 (Tree p) where
showDict1 = ShowDictClass
sizeTree :: Tree p C(x) -> Int
sizeTree NilTree = 0
sizeTree (SeqTree _ t) = 1 + sizeTree t
sizeTree (ParTree t1 t2) = 1 + sizeTree t1 + sizeTree t2
-- newtype G1 l p C(x) = G1 { _unG1 :: l (p C(x)) }
newtype G2 l p C(x y) = G2 { unG2 :: l (p C(x y)) }
flattenTree :: (Commute p) => Tree p C(z) -> Sealed (G2 [] (FL p) C(z))
flattenTree NilTree = seal $ G2 $ return NilFL
flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t
flattenTree (ParTree (flattenTree -> Sealed gpss1) (flattenTree -> Sealed gpss2))
= seal $ G2 $
do ps1 <- unG2 gpss1
ps2 <- unG2 gpss2
ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2)
-- We can't prove that the existential type in the result
-- of merge will be the same for each pair of
-- ps1 and ps2.
map unsafeCoerceP [ps1 +>+ ps2', ps2 +>+ ps1']
instance ArbitraryState s p => ArbitraryStateIn s (Tree p) where
-- don't generate trees deeper than 5 with default QuickCheck size
arbitraryStateIn rm = sized $ \s -> arbitraryTree rm (s `div` 17)
-- | Generate a tree of patches, bounded by the size @maxSize@.
arbitraryTree :: ArbitraryState s p => s C(x) -> Int -> Gen (Tree p C(x))
arbitraryTree rm maxDepth
| maxDepth == 0 = return NilTree
| otherwise = frequency [(2, return NilTree)
,(2, do Sealed (WithEndState p rm') <- arbitraryState rm
t <- arbitraryTree rm' maxDepth
return (SeqTree p t))
,(1, do t1 <- arbitraryTree rm (maxDepth - 1)
t2 <- arbitraryTree rm (maxDepth - 1)
return (ParTree t1 t2))]
shrinkWSSTree :: Sealed (WithStartState RepoModel (Tree Prim))
-> [Sealed (WithStartState RepoModel (Tree Prim))]
shrinkWSSTree = unseal doShrinkWSSTree
where
doShrinkWSSTree wss@(WithStartState rm t)
= shrinkWSSTree' wss -- shrink the tree
`mplus`
do -- shrink the starting context
pos <- [0 .. length (rmFileContents rm) - 1]
let rmFileContents' = take pos (rmFileContents rm) ++ drop (pos+1) (rmFileContents rm)
t' = shrinkPosStart pos (canonizeTree t)
return $ seal $ WithStartState (rm { rmFileContents = rmFileContents' }) (canonizeTree t')
-- If we had a more general repo model, then Int would need to be more general too
class ShrinkablePos p where
shrinkPos :: Int -> p C(x y) -> (p C(x y), Maybe Int)
shrinkPatch :: p C(x y) -> [(p C(x y), Maybe Int)]
nullPatch :: p C(x y) -> EqCheck C(x y)
class ShrinkablePosStart p where
shrinkPosStart :: Int -> p C(x) -> p C(x)
instance ShrinkablePos p => ShrinkablePosStart (Tree p) where
shrinkPosStart _ NilTree = NilTree
shrinkPosStart pos (SeqTree p t)
= let (p', mpos') = shrinkPos pos p
in case mpos' of
Nothing -> SeqTree p' t
Just pos' -> SeqTree p' (shrinkPosStart pos' t)
shrinkPosStart pos (ParTree t1 t2) = ParTree (shrinkPosStart pos t1) (shrinkPosStart pos t2)
smartFP :: FileName -> FilePatchType C(x y) -> Prim C(x y)
smartFP _ (Hunk _ [] []) | avoidEmptyHunks = unsafeCoerceP Identity
smartFP fn filepatch = FP fn filepatch
instance ShrinkablePos Prim where
shrinkPos pos (FP fn fp) = (smartFP fn *** id) (shrinkPos pos fp)
shrinkPos pos Identity = (Identity, Just pos)
shrinkPos _ _ = impossible
shrinkPatch (FP fn fp) = map (smartFP fn *** id) (shrinkPatch fp)
shrinkPatch Identity = []
shrinkPatch _ = impossible
nullPatch (FP _ fp) = nullPatch fp
nullPatch Identity = IsEq
nullPatch _ = impossible
avoidEmptyHunks :: Bool
avoidEmptyHunks = True
instance ShrinkablePos FilePatchType where
shrinkPos pos (Hunk n old new)
| pos < n = (Hunk (n-1) old new, Just pos)
| pos >= n + length old = (Hunk n old new, Just (pos + length new - length old))
| otherwise = (Hunk n (take pos' old ++ drop (pos'+1) old) new, Nothing)
where pos' = pos - n
shrinkPos _ _ = bug "foo1 in ShrinkablePos"
shrinkPatch (Hunk n [] []) | n > 0 = [(Hunk (n-1) [] [], Nothing)]
shrinkPatch (Hunk n old new)
= do i <- [0 .. length new - 1]
return (Hunk n old (take i new ++ drop (i+1) new), Just (n + i))
shrinkPatch _ = bug "foo in ShrinkablePos"
nullPatch (Hunk _ [] []) = unsafeCoerceP IsEq -- is this safe?
nullPatch _ = NotEq
shrinkWSSTree'
-- start a new line here because apparently ' confuses CPP..
:: WithStartState RepoModel (Tree Prim) C(x)
-> [Sealed (WithStartState RepoModel (Tree Prim))]
shrinkWSSTree' (WithStartState _ NilTree) = []
shrinkWSSTree' (WithStartState rm t@(SeqTree p t'))
= return (seal (WithStartState (applyPatch rm p) (canonizeTree t')))
`mplus`
liftM (seal . WithStartState rm) (map canonizeTree $ shrinkTree t)
shrinkWSSTree' (WithStartState rm t@(ParTree _ _))
= liftM (seal . WithStartState rm) (map canonizeTree $ shrinkTree t)
-- canonize a tree, removing any dead branches
canonizeTree :: ShrinkablePos p => Tree p C(x) -> Tree p C(x)
canonizeTree NilTree = NilTree
canonizeTree (ParTree t1 t2)
| NilTree <- canonizeTree t1 = canonizeTree t2
| NilTree <- canonizeTree t2 = canonizeTree t1
| otherwise = ParTree (canonizeTree t1) (canonizeTree t2)
canonizeTree (SeqTree p t) | IsEq <- nullPatch p = canonizeTree t
| otherwise = SeqTree p (canonizeTree t)
-- shrink the tree without changing the starting context
shrinkTree :: ShrinkablePos p => Tree p C(x) -> [Tree p C(x)]
shrinkTree NilTree = []
shrinkTree (SeqTree p t) = do case nullPatch p of
IsEq -> return t
NotEq -> mzero
`mplus`
do (p', pos) <- shrinkPatch p
return (SeqTree p' (maybe id shrinkPosStart pos t))
`mplus`
do t' <- shrinkTree t
return (SeqTree p t')
shrinkTree (ParTree t1 t2) = [t1, t2]
`mplus`
do t1' <- shrinkTree t1
return (ParTree t1' t2)
`mplus`
do t2' <- shrinkTree t2
return (ParTree t1 t2')
instance Arbitrary (Sealed (WithStartState RepoModel (Tree Prim))) where
arbitrary = do Sealed (WithStartState rm tree) <-
liftM (seal . WithStartState initRepoModel) (arbitraryStateIn initRepoModel)
return $ Sealed $ WithStartState rm (canonizeTree tree)
shrink = shrinkWSSTree
propIsMergeable :: forall p C(x) . (FromPrim p, Commute p)
=> Sealed (WithStartState RepoModel (Tree Prim))
-> Maybe (Tree p C(x))
propIsMergeable (Sealed (WithStartState _ t))
= case flattenOne t of
Sealed ps -> let _ = seal2 ps :: Sealed2 (FL p)
in case lengthFL ps of
_ -> Nothing
flattenOne :: (FromPrim p, Commute p) => Tree Prim C(x) -> Sealed (FL p C(x))
flattenOne NilTree = seal NilFL
flattenOne (SeqTree p (flattenOne -> Sealed ps)) = seal (fromPrim p :>: ps)
flattenOne (ParTree (flattenOne -> Sealed ps1) (flattenOne -> Sealed ps2)) =
--traceDoc (greenText "flattening two parallel series: ps1" $$ showPatch ps1 $$
-- greenText "ps2" $$ showPatch ps2) $
case merge (ps1 :\/: ps2) of
ps2' :/\: _ -> seal (ps1 +>+ ps2')
instance Arbitrary (Sealed2 (FL RealPatch)) where
arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState RepoModel (Tree Prim)))
return $ unseal seal2 (flattenOne tree)
instance Arbitrary (Sealed2 RealPatch) where
arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState RepoModel (Tree Prim)))
case mapFL seal2 `unseal` flattenOne tree of
[] -> return $ seal2 $ fromPrim Identity
ps -> elements ps
instance (Arbitrary (Sealed2 (FL p)), Commute p) => Arbitrary (Sealed2 (p :\/: p)) where
arbitrary = do Sealed2 (a :> b) <- arbitrary
case commute (a :> b) of
Just (b' :> _) -> return (seal2 (a :\/: b'))
Nothing -> arbitrary
instance Arbitrary (Sealed2 (FL p)) => Arbitrary (Sealed2 (p :> p)) where
arbitrary = do Sealed2 ps <- arbitrary
let pairs = getPairs ps
case pairs of
[] -> arbitrary
_ -> elements pairs
instance (Invert p, Arbitrary (Sealed2 (FL p))) => Arbitrary (Sealed2 (p :> p :> p)) where
arbitrary = do Sealed2 ps <- arbitrary
return $ last_triple ps
where last_triple :: FL p C(x y) -> Sealed2 (p :> p :> p)
last_triple NilFL = seal2 $ identity :> identity :> identity
last_triple (a :>: NilFL) = seal2 $ a :> invert a :> identity
last_triple (a :>: b :>: NilFL) = seal2 $ invert a :> a :> b
last_triple (a :>: b :>: c :>: NilFL) = seal2 $ a :> b :> c
last_triple (_ :>: xs) = last_triple xs
data TreeWithFlattenPos p C(x) = TWFP Int (Tree p C(x))
commutePairFromTWFP :: (FromPrim p, Commute p)
=> (FORALL (y z) (p :> p) C(y z) -> t)
-> (WithStartState RepoModel (TreeWithFlattenPos Prim) C(x) -> t)
commutePairFromTWFP handlePair (WithStartState _ (TWFP n t))
= unseal2 handlePair $
let xs = unseal getPairs (flattenOne t)
in if length xs > n && n >= 0 then xs!!n else seal2 (fromPrim Identity :> fromPrim Identity)
commutePairFromTree :: (FromPrim p, Commute p)
=> (FORALL (y z) (p :> p) C(y z) -> t)
-> (WithStartState RepoModel (Tree Prim) C(x) -> t)
commutePairFromTree handlePair (WithStartState _ t)
= unseal2 handlePair $
case flattenOne t of
Sealed ps ->
let xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $
getPairs ps
in if null xs then seal2 (fromPrim Identity :> fromPrim Identity) else last xs
commuteTripleFromTree :: (FromPrim p, Commute p)
=> (FORALL (y z) (p :> p :> p) C(y z) -> t)
-> (WithStartState RepoModel (Tree Prim) C(x) -> t)
commuteTripleFromTree handle (WithStartState _ t)
= unseal2 handle $
case flattenOne t of
Sealed ps ->
let xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $
getTriples ps
in if null xs
then seal2 (fromPrim Identity :> fromPrim Identity :> fromPrim Identity)
else last xs
mergePairFromCommutePair :: (Commute p, Invert p)
=> (FORALL (y z) (p :\/: p) C(y z) -> t)
-> (FORALL (y z) (p :> p) C(y z) -> t)
mergePairFromCommutePair handlePair (a :> b)
= case commute (a :> b) of
Just (b' :> _) -> handlePair (a :\/: b')
Nothing -> handlePair (b :\/: b)
-- impredicativity problems mean we can't use (.) in the definitions below
mergePairFromTWFP :: (FromPrim p, Commute p, Invert p)
=> (FORALL (y z) (p :\/: p) C(y z) -> t)
-> (WithStartState RepoModel (TreeWithFlattenPos Prim) C(x) -> t)
mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x)
mergePairFromTree :: (FromPrim p, Commute p, Invert p)
=> (FORALL (y z) (p :\/: p) C(y z) -> t)
-> (WithStartState RepoModel (Tree Prim) C(x) -> t)
mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x)
patchFromCommutePair :: (Commute p, Invert p)
=> (FORALL (y z) p C(y z) -> t)
-> (FORALL (y z) (p :> p) C(y z) -> t)
patchFromCommutePair handle (_ :> b) = handle b
patchFromTree :: (FromPrim p, Commute p, Invert p)
=> (FORALL (y z) p C(y z) -> t)
-> (WithStartState RepoModel (Tree Prim) C(x) -> t)
patchFromTree x = commutePairFromTree (patchFromCommutePair x)
instance Show2 p => Show (TreeWithFlattenPos p C(x)) where
showsPrec d (TWFP n t) = showParen (d > appPrec) $ showString "TWFP " .
showsPrec (appPrec + 1) n . showString " " .
showsPrec1 (appPrec + 1) t
instance Show1 (TreeWithFlattenPos Prim) where
showDict1 = ShowDictClass
instance Arbitrary (Sealed (WithStartState RepoModel (TreeWithFlattenPos Prim))) where
arbitrary = do Sealed (WithStartState rm t) <- arbitrary
let num = unseal (length . getPairs) (flattenOneRP t)
if num == 0 then return $ Sealed $ WithStartState rm $ TWFP 0 NilTree
else do n <- choose (0, num - 1)
return $ Sealed $ WithStartState rm $ TWFP n t
where -- just used to get the length. In principle this should be independent of the patch type.
flattenOneRP :: Tree Prim C(x) -> Sealed (FL RealPatch C(x))
flattenOneRP = flattenOne
shrink (Sealed (WithStartState rm (TWFP n t))) =
[Sealed (WithStartState rm' (TWFP n' t')) | Sealed (WithStartState rm' t') <- shrink (Sealed (WithStartState rm t)),
n' <- [0..n]]
getPairs :: FL p C(x y) -> [Sealed2 (p :> p)]
getPairs NilFL = []
getPairs (_:>:NilFL) = []
getPairs (a:>:b:>:c) = seal2 (a:>b) : getPairs (b:>:c)
getTriples :: FL p C(x y) -> [Sealed2 (p :> p :> p)]
getTriples NilFL = []
getTriples (_:>:NilFL) = []
getTriples (_:>:_:>:NilFL) = []
getTriples (a:>:b:>:c:>:d) = seal2 (a:>b:>c) : getTriples (b:>:c:>:d)
arbitraryFP :: RepoModel C(x) -> Gen (Sealed (WithEndState (Prim C(x)) RepoModel))
arbitraryFP rm
= do (fp, newcontents) <- arbitraryFilePatchType (rmFileContents rm)
return $ seal $ WithEndState (FP (rmFileName rm) fp) (rebuildRepoModel (rm { rmFileContents = newcontents }))
-- Really [B.ByteString] should be parametrised by x y, and the result tuple sealed on y
arbitraryFilePatchType :: [B.ByteString] -> Gen (FilePatchType C(x y), [B.ByteString])
arbitraryFilePatchType contents = oneof [arbitraryHunk contents]
arbitraryHunk :: [B.ByteString] -> Gen (FilePatchType C(x y), [B.ByteString])
arbitraryHunk contents
= sized $ \n ->
do start <- choose (0, min n (length contents))
(removelen, _)
<- frequency $ zip (if start == length contents then [1, 13, 0, 0] else [1, 3, 5, 3])
[return (0, 0)
,do xa <- choose (0, n)
return (0, xa)
,do xr <- choose (1, min n (length contents - start))
return (xr, 0)
,do xr <- choose (1, min n (length contents - start))
xa <- choose (0, n)
return (xr, xa)
]
addlen <- choose (0, n)
additems <- replicateM addlen (do c <- choose ('a', 'z')
return $ BC.pack [c])
let newcontents = take start contents ++ additems ++ drop (start + removelen) contents
return (Hunk start (take removelen $ drop start $ contents) additems, newcontents)
class Applyable p where
applyPatch :: RepoModel C(x) -> p C(x y) -> RepoModel C(y)
instance Applyable p => Applyable (FL p) where
applyPatch rm NilFL = rm
applyPatch rm (p :>: ps) = applyPatch (applyPatch rm p) ps
instance Applyable RealPatch where
applyPatch rm p = applyPatch rm (effect p)
instance Applyable Prim where
applyPatch (rm@RepoModel { rmFileName = filename, rmFileContents = oldcontents }) (FP filename' fp)
| filename == filename' = rebuildRepoModel (rm { rmFileContents = applyFilePatchType oldcontents fp })
applyPatch rm Identity = rm
applyPatch _ _ = bug "We haven't defined applyPatch on Prim for all patch types."
applyFilePatchType :: [B.ByteString] -> FilePatchType C(x y) -> [B.ByteString]
applyFilePatchType oldcontents (Hunk n old new)
= if take (length old) (drop n oldcontents) == old
then take n oldcontents ++ new ++ drop (n + length old) oldcontents
else error "Bad patch context"
applyFilePatchType _ _ = bug "We haven't defined applyFilePatchType for all patch types."
packStringLetters :: String -> [B.ByteString]
packStringLetters = map (BC.pack . (:[]))
realPatchLoopExamples :: [Sealed (WithStartState RepoModel (Tree Prim))]
realPatchLoopExamples =
[Sealed (WithStartState (RepoModel { rmFileName = fx, rmFileContents = [] })
$ canonizeTree
(ParTree
(SeqTree (FP fx (Hunk 0 [] (packStringLetters "pkotufogbvdabnmbzajvolwviqebieonxvcvuvigkfgybmqhzuaaurjspd")))
(ParTree
(SeqTree (FP fx (Hunk 46 (packStringLetters "qhzu") (packStringLetters "zafybdcokyjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmh")))
(ParTree
(ParTree
NilTree
(ParTree
(ParTree
(ParTree
(SeqTree (FP fx (Hunk 14 (packStringLetters "mbzajvolwviqebieonxvcvuvigkfgyb") (packStringLetters "vujnxnhvybvpouyciaabszfmgssezlwwjgnethvrpnfrkubphzvdgymjjoacppqps")))
(ParTree
NilTree
(ParTree
(SeqTree (FP fx (Hunk 39 (packStringLetters "ssezlwwjgnethvrpnfrkubphzvdgymjjoacppqpsmzafybdcokyjskcgnvhkbz") (packStringLetters "wnesidpccwoiqiichxaaejdsyrhrusqljlcoro")))
(ParTree
(ParTree
(SeqTree (FP fx (Hunk 11 (packStringLetters "abnvujnxnhvybvpouyciaabszfmgwnesidpccwoiqii") (packStringLetters "czfdhqkipdstfjycqaxwnbxrihrufdeyneqiiiafwzlmg"))) NilTree)
NilTree)
NilTree))
(SeqTree (FP fx (Hunk 24 [] (packStringLetters "dihgmsotezucqdgxczvcivijootyvhlwymbiueufnvpwpeukmskqllalfe"))) NilTree))))
(SeqTree (FP fx (Hunk 55 (packStringLetters "yjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmhaaurjsp") (packStringLetters "xldhrutyhcyaqeezwujiguawfyawjjqlirxshjddvq"))) NilTree))
(SeqTree (FP fx (Hunk 19 [] (packStringLetters "ooygwiyogqrqnytixqtmvdxx")))
(SeqTree (FP fx (Hunk 25 (packStringLetters "yogqrqnytixqtmvdxxvolwviqebieonxvcvuvigkfgybmzafybdcokyjskcgnvhkbz") (packStringLetters "akhsmlbkdxnvfoikmiatfbpzdrsyykkpoxvvddeaspzxe")))
(SeqTree (FP fx (Hunk 38 [] (packStringLetters "ji")))
(ParTree
NilTree
(ParTree
NilTree
(ParTree
(ParTree
NilTree
(SeqTree (FP fx (Hunk 25 (packStringLetters "akhsmlbkdxnvfjioikmiatfbpzdrsyykkpoxvvddeaspzxepysaafnjjhcstgrczplxs") (packStringLetters "onjbhddskcj")))
(SeqTree (FP fx (Hunk 38 [] (packStringLetters "fyscunxxxjjtyqpfxeznhtwvlphmp"))) NilTree)))
(ParTree
NilTree
(SeqTree (FP fx (Hunk 43 [] (packStringLetters "xcchzwmzoezxkmkhcmesplnjpqriypshgiqklgdnbmmkldnydiy")))
(ParTree
NilTree
(SeqTree (FP fx (Hunk 63 (packStringLetters "plnjpqriypshgiqklgdnbmmkldnydiymiatfbpzdrsyykkpoxvvddeaspzxepysaafn") (packStringLetters "anjlzfdqbjqbcplvqvkhwjtkigp"))) NilTree)))))))))))
(ParTree
NilTree
NilTree)))
NilTree))
NilTree))
(ParTree
NilTree
(SeqTree (FP fx (Hunk 0 [] (packStringLetters "ti")))
(SeqTree (FP fx (Hunk 0 (packStringLetters "t") (packStringLetters "ybcop")))
(SeqTree (FP fx (Hunk 1 [] (packStringLetters "dvlhgwqlpaeweerqrhnjtfolczbqbzoccnvdsyqiefqitrqneralf")))
(SeqTree (FP fx (Hunk 14 [] (packStringLetters "yairbjphwtnaerccdlfewujvjvmjakbc")))
(SeqTree (FP fx (Hunk 50 [] (packStringLetters "xayvfuwaiiogginufnhsrmktpmlbvxiakjwllddkiyofyfw")))
(ParTree
NilTree
NilTree)))))))))]
fx :: FileName
fx = fp2fn "./F"