darcs-2.14.2: harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs
{-# LANGUAGE MultiParamTypeClasses #-}
module Darcs.Test.Patch.Arbitrary.PrimV1 where
import qualified Darcs.Test.Patch.Arbitrary.Generic as T
( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP
, mergePairFromTree, mergePairFromTWFP
, patchFromTree )
import Prelude ()
import Darcs.Prelude
import Darcs.Test.Patch.Arbitrary.Generic
import Darcs.Test.Patch.RepoModel
import Control.Monad ( liftM )
import Test.QuickCheck
import Darcs.Test.Patch.WithState
import Darcs.Patch.Witnesses.Sealed
import Darcs.Patch.Witnesses.Eq
import Darcs.Patch.Witnesses.Unsafe
import Darcs.Patch.Witnesses.Ordered
import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk ), isIdentity )
import qualified Darcs.Patch.Prim.V1.Core as Prim ( Prim( FP ) )
import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )
import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )
import Darcs.Patch.RepoPatch ( RepoPatch )
import Darcs.Patch.FileHunk( IsHunk( isHunk ), FileHunk(..) )
import Darcs.Test.Patch.V1Model
import Darcs.Util.Path
import qualified Darcs.Util.Tree as UT ( Tree )
import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )
import Darcs.UI.Commands.Replace ( defaultToks )
import Darcs.Patch.Prim
import Darcs.Patch.Apply ( ApplyState )
import qualified Data.ByteString.Char8 as BC
import Data.Maybe ( isJust )
type Prim1 = V1.Prim
type Prim2 = V2.Prim
patchFromTree :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState V1Model (Tree prim) wX -> t
patchFromTree = T.patchFromTree
mergePairFromTree :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V1Model (Tree prim) wX -> t
mergePairFromTree = T.mergePairFromTree
mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V1Model (TreeWithFlattenPos prim) wX -> t
mergePairFromTWFP = T.mergePairFromTWFP
commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V1Model (TreeWithFlattenPos prim) wX -> t
commutePairFromTWFP = T.commutePairFromTWFP
commutePairFromTree :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V1Model (Tree prim) wX -> t
commutePairFromTree = T.commutePairFromTree
commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ prim) => (forall wY wZ . (p :> p :> p) wY wZ -> t) -> WithStartState V1Model (Tree prim) wX -> t
commuteTripleFromTree = T.commuteTripleFromTree
nonEmptyHunk :: (IsHunk p) => p wX wY -> Bool
nonEmptyHunk p
| Just (FileHunk _ _ [] []) <- isHunk p = False
| otherwise = True
nonEmptyHunksPair :: (IsHunk p) => (p :> p) wX wY -> Bool
nonEmptyHunksPair (p1 :> p2) = nonEmptyHunk p1 && nonEmptyHunk p2
nonEmptyHunksTriple :: (IsHunk p) => (p :> p :> p) wX wY -> Bool
nonEmptyHunksTriple (p1 :> p2 :> p3) = nonEmptyHunk p1 && nonEmptyHunk p2 && nonEmptyHunk p3
nonEmptyHunksFLPair :: (IsHunk p) => (FL p :> FL p) wX wY -> Bool
nonEmptyHunksFLPair (ps :> qs) = allFL nonEmptyHunk ps && allFL nonEmptyHunk qs
type instance ModelOf Prim1 = V1Model
type instance ModelOf Prim2 = V1Model
instance ArbitraryPrim Prim1
instance ArbitraryPrim Prim2
instance NullPatch Prim2 where
nullPatch (V2.Prim (Prim.FP _ fp)) = nullPatch fp
nullPatch p | IsEq <- isIdentity (V2.unPrim p) = IsEq
nullPatch _ = NotEq
instance NullPatch Prim1 where
nullPatch (V1.Prim (Prim.FP _ fp)) = nullPatch fp
nullPatch p | IsEq <- isIdentity (V1.unPrim p) = IsEq
nullPatch _ = NotEq
instance NullPatch FilePatchType where
nullPatch (Hunk _ [] []) = unsafeCoerceP IsEq -- is this safe?
nullPatch _ = NotEq
instance MightBeEmptyHunk Prim1 where
isEmptyHunk (V1.Prim (Prim.FP _ (Hunk _ [] []))) = True
isEmptyHunk _ = False
instance MightBeEmptyHunk Prim2 where
isEmptyHunk (V2.Prim (Prim.FP _ (Hunk _ [] []))) = True
isEmptyHunk _ = False
instance MightHaveDuplicate Prim1
instance MightHaveDuplicate Prim2
instance Arbitrary (Sealed2 (FL (WithState V1Model Prim1))) where
arbitrary = do repo <- ourSmallRepo
liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo
instance Arbitrary (Sealed2 (FL (WithState V1Model Prim2))) where
arbitrary = do repo <- ourSmallRepo
liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo
-- instance Show1 (TreeWithFlattenPos Prim) where
-- showDict1 = ShowDictClass
-- WithState and propFail are handy for debugging arbitrary code
propFail :: Int -> Tree prim wX -> Bool
propFail n xs = sizeTree xs < n
----------------------------------------------------------------------
-- * QuickCheck generators
----------------------------------------------------------------------
-- ** FilePatchType generators
aHunk :: Content -> Gen (Int, [BC.ByteString], [BC.ByteString])
aHunk content
= sized $ \n ->
do pos <- choose (1, contentLen+1)
let prefixLen = pos-1
restLen = contentLen-prefixLen
oldLen <- frequency
[ (75, choose (0, min restLen n))
-- produces small hunks common in real editing
, (25, choose (0, min 10 restLen))
]
-- newLen choice aims to cover all possibilities, that is,
-- remove less/the same/more than added and empty the file.
newLen <- frequency
[ ( 54
, choose (1,min 1 n)
)
, ( if oldLen /= 0 then 42 else 0
, choose (1,min 1 oldLen)
)
, ( if oldLen /= 0 then 2 else 0
, return oldLen
)
, ( if oldLen /= 0 then 2 else 0
, return 0
)
]
new <- vectorOf newLen aLine
let old = take oldLen $ drop prefixLen $ content
return (pos, old, new)
where
contentLen = length content
aTokReplace :: Content -> Gen (String, String, String)
aTokReplace []
= do w <- vectorOf 1 alpha
w' <- vectorOf 1 alpha
return (defaultToks, w, w')
aTokReplace content
= do let fileWords = concatMap BC.words content
wB <- elements fileWords
w' <- alphaBS `notIn` fileWords
return (defaultToks, BC.unpack wB, BC.unpack w')
where
alphaBS = do x <- alpha; return $ BC.pack [x]
----------------------------------------------------------------------
-- ** Prim generators
aHunkP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY)
aHunkP (path,file)
= do (pos, old, new) <- aHunk content
return $ hunk (ap2fp path) pos old new
where
content = fileContent file
aTokReplaceP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY)
aTokReplaceP (path,file)
= do (tokchars, old, new) <- aTokReplace content
return $ tokreplace (ap2fp path) tokchars old new
where
content = fileContent file
anAddFileP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY)
anAddFileP (path,dir)
= do newFilename <- aFilename `notIn` existing
let newPath = path `appendPath` newFilename
return $ addfile (ap2fp newPath)
where
existing = map fst $ filterFiles $ dirContent dir
aRmFileP :: forall prim wX wY . PrimPatch prim => AnchoredPath -- ^ Path of an empty file
-> prim wX wY
aRmFileP path = rmfile (ap2fp path)
anAddDirP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY)
anAddDirP (path,dir)
= do newDirname <- aDirname `notIn` existing
let newPath = path `appendPath` newDirname
return $ adddir (ap2fp newPath)
where
existing = map fst $ filterDirs $ dirContent dir
aRmDirP :: forall prim wX wY . PrimPatch prim => AnchoredPath -- ^ Path of an empty directory
-> prim wX wY
aRmDirP path = rmdir (ap2fp path)
aMoveP :: forall prim wX wY . PrimPatch prim => Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (prim wX wY)
aMoveP nameGen oldPath (dirPath,dir)
= do newName <- nameGen `notIn` existing
let newPath = dirPath `appendPath` newName
return $ move (ap2fp oldPath) (ap2fp newPath)
where
existing = map fst $ dirContent dir
-- | Generates any type of 'prim' patch, except binary and setpref patches.
aPrim :: forall prim wX wY . (PrimPatch prim, ApplyState prim ~ RepoState V1Model)
=> V1Model wX -> Gen (WithEndState V1Model (prim wX) wY)
aPrim repo
= do mbFile <- maybeOf repoFiles
mbEmptyFile <- maybeOf $ filter (isEmpty . snd) repoFiles
dir <- elements (rootDir:repoDirs)
mbOldDir <- maybeOf repoDirs
mbEmptyDir <- maybeOf $ filter (isEmpty . snd) repoDirs
patch <- frequency
[ ( if isJust mbFile then 12 else 0
, aHunkP $ fromJust mbFile
)
, ( if isJust mbFile then 6 else 0
, aTokReplaceP $ fromJust mbFile
)
, ( 2
, anAddFileP dir
)
, ( if isJust mbEmptyFile then 12 else 0
, return $ aRmFileP $ fst $ fromJust mbEmptyFile
)
, ( 2
, anAddDirP dir
)
, ( if isJust mbEmptyDir then 10 else 0
, return $ aRmDirP $ fst $ fromJust mbEmptyDir
)
, ( if isJust mbFile then 3 else 0
, aMoveP aFilename (fst $ fromJust mbFile) dir
)
, let oldPath = fst $ fromJust mbOldDir in
( if isJust mbOldDir
&& not (oldPath `isPrefix` fst dir)
then 4 else 0
, aMoveP aDirname oldPath dir
)
]
let repo' = unFail $ repoApply repo patch
return $ WithEndState patch repo'
where
repoItems = list repo
repoFiles = filterFiles repoItems
repoDirs = filterDirs repoItems
rootDir = (anchoredRoot,root repo)
{- [COVERAGE OF aPrim]
PLEASE,
if you change something that may affect the coverage of aPrim then
a) recalculate it, or if that is not possible;
b) indicate the need to do it.
Patch type
----------
42% hunk
22% tokreplace
14% move
6% rmdir
6% addfile
6% adddir
4% rmfile
-}
----------------------------------------------------------------------
-- *** Pairs of primitive patches
-- Try to generate commutable pairs of hunks
hunkPairP :: forall prim wX wY . PrimPatch prim => (AnchoredPath,File) -> Gen ((prim :> prim) wX wY)
hunkPairP (path,file)
= do (l1, old1, new1) <- aHunk content
(delta, content') <- selectChunk (Hunk l1 old1 new1) content
(l2', old2, new2) <- aHunk content'
let l2 = l2'+delta
return (hunk fpPath l1 old1 new1 :> hunk fpPath l2 old2 new2)
where
content = fileContent file
fpPath = ap2fp path
selectChunk (Hunk l old new) content_
= elements [prefix, suffix]
where
start = l - 1
prefix = (0, take start content_)
suffix = (start + length new, drop (start + length old) content_)
selectChunk _ _ = impossible
aPrimPair :: forall prim wX wY . (PrimPatch prim, ArbitraryState V1Model prim, ApplyState prim ~ RepoState V1Model) => V1Model wX -> Gen (WithEndState V1Model ((prim :> prim) wX) wY)
aPrimPair repo
= do mbFile <- maybeOf repoFiles
frequency
[ ( if isJust mbFile then 1 else 0
, do p1 :> p2 <- hunkPairP $ fromJust mbFile
let repo' = unFail $ repoApply repo p1
repo'' = unFail $ repoApply repo' p2
return $ WithEndState (p1 :> p2) repo''
)
, ( 1
, do Sealed wesP <- arbitraryState repo
return $ unsafeCoerceP1 wesP
)
]
where
repoItems = list repo
repoFiles = filterFiles repoItems
{- [COVERAGE OF aPrimPair]
PLEASE,
if you change something that may affect the coverage of aPrimPair then
a) recalculate it, or if that is not possible;
b) indicate the need to do it.
Rate of ommutable pairs
-----------------------
67% commutable
Commutable coverage (for 1000 tests)
-------------------
21% hunks-B
20% hunks-A
14% file:>dir
12% file:>move
8% trivial-FP
8% hunk:>tok
4% hunks-D
3% tok:>tok
2% hunks-C
1% move:>move
1% dir:>move
1% dir:>dir
0% emptyhunk:>file
-}
----------------------------------------------------------------------
-- Arbitrary instances
ourSmallRepo :: Gen (V1Model wX)
ourSmallRepo = aSmallRepo
instance ArbitraryState V1Model Prim1 where
arbitraryState s = seal <$> aPrim s
instance ArbitraryState V1Model Prim2 where
arbitraryState s = seal <$> aPrim s
instance Arbitrary (Sealed (Prim1 wA)) where
arbitrary = makeSGen ourSmallRepo
instance Arbitrary (Sealed (Prim2 wA)) where
arbitrary = makeSGen ourSmallRepo
instance Arbitrary (Sealed2 Prim1) where
arbitrary = makeS2Gen ourSmallRepo
instance Arbitrary (Sealed2 Prim2) where
arbitrary = makeS2Gen ourSmallRepo
arbitrarySeal2 :: (PrimPatch prim, ApplyState prim ~ UT.Tree,
ArbitraryState V1Model prim)
=> Gen (Sealed2 (prim :> prim))
arbitrarySeal2 = do
repo <- ourSmallRepo
WithEndState pp _ <- aPrimPair repo
return $ seal2 pp
arbitrarySeal :: (PrimPatch prim, ApplyState prim ~ UT.Tree,
ArbitraryState V1Model prim)
=> Gen (Sealed ((:>) prim prim wX))
arbitrarySeal = do
repo <- ourSmallRepo
WithEndState pp _ <- aPrimPair repo
return $ seal pp
instance Arbitrary (Sealed2 (Prim1 :> Prim1)) where
arbitrary = arbitrarySeal2
instance Arbitrary (Sealed2 (Prim2 :> Prim2)) where
arbitrary = arbitrarySeal2
instance Arbitrary (Sealed ((Prim1 :> Prim1) wA)) where
arbitrary = arbitrarySeal
instance Arbitrary (Sealed ((Prim2 :> Prim2) wA)) where
arbitrary = arbitrarySeal
instance Arbitrary (Sealed2 (Prim1 :> Prim1 :> Prim1)) where
arbitrary = makeS2Gen ourSmallRepo
instance Arbitrary (Sealed ((Prim1 :> Prim1 :> Prim1) a)) where
arbitrary = makeSGen ourSmallRepo
instance Arbitrary (Sealed2 (FL Prim1)) where
arbitrary = makeS2Gen ourSmallRepo
instance Arbitrary (Sealed ((FL Prim1) wA)) where
arbitrary = makeSGen ourSmallRepo
instance Arbitrary (Sealed2 (FL Prim1 :> FL Prim1)) where
arbitrary = makeS2Gen ourSmallRepo
instance Arbitrary (Sealed ((FL Prim1 :> FL Prim1) wA)) where
arbitrary = makeSGen ourSmallRepo
instance Arbitrary (Sealed2 (WithState V1Model Prim1)) where
arbitrary = makeWS2Gen ourSmallRepo
instance Arbitrary (Sealed (WithState V1Model Prim1 wA)) where
arbitrary = makeWSGen ourSmallRepo
instance Arbitrary (Sealed (WithState V1Model (FL Prim1) wA)) where
arbitrary = makeWSGen ourSmallRepo
instance Arbitrary (Sealed2 (WithState V1Model (Prim1 :> Prim1))) where
arbitrary = do repo <- ourSmallRepo
WithEndState pp repo' <- aPrimPair repo
return $ seal2 $ WithState repo pp repo'
instance Arbitrary (Sealed (WithState V1Model (Prim1 :> Prim1) a)) where
arbitrary = do repo <- ourSmallRepo
WithEndState pp repo' <- aPrimPair repo
return $ seal $ WithState repo pp repo'
instance Arbitrary (Sealed2 (WithState V1Model (FL Prim1))) where
arbitrary = makeWS2Gen ourSmallRepo
instance Arbitrary (Sealed2 (WithState V1Model (FL Prim1 :> FL Prim1))) where
arbitrary = makeWS2Gen ourSmallRepo
instance Arbitrary (Sealed (WithState V1Model (FL Prim1 :> FL Prim1) a)) where
arbitrary = makeWSGen ourSmallRepo
instance Arbitrary (Sealed2 (Prim2 :> Prim2 :> Prim2)) where
arbitrary = makeS2Gen ourSmallRepo
instance Arbitrary (Sealed ((Prim2 :> Prim2 :> Prim2) a)) where
arbitrary = makeSGen ourSmallRepo
instance Arbitrary (Sealed2 (FL Prim2)) where
arbitrary = makeS2Gen ourSmallRepo
instance Arbitrary (Sealed ((FL Prim2) wA)) where
arbitrary = makeSGen ourSmallRepo
instance Arbitrary (Sealed2 (FL Prim2 :> FL Prim2)) where
arbitrary = makeS2Gen ourSmallRepo
instance Arbitrary (Sealed ((FL Prim2 :> FL Prim2) wA)) where
arbitrary = makeSGen ourSmallRepo
instance Arbitrary (Sealed2 (WithState V1Model Prim2)) where
arbitrary = makeWS2Gen ourSmallRepo
instance Arbitrary (Sealed (WithState V1Model Prim2 wA)) where
arbitrary = makeWSGen ourSmallRepo
instance Arbitrary (Sealed (WithState V1Model (FL Prim2) wA)) where
arbitrary = makeWSGen ourSmallRepo
instance Arbitrary (Sealed2 (WithState V1Model (Prim2 :> Prim2))) where
arbitrary = do repo <- ourSmallRepo
WithEndState pp repo' <- aPrimPair repo
return $ seal2 $ WithState repo pp repo'
instance Arbitrary (Sealed (WithState V1Model (Prim2 :> Prim2) a)) where
arbitrary = do repo <- ourSmallRepo
WithEndState pp repo' <- aPrimPair repo
return $ seal $ WithState repo pp repo'
instance Arbitrary (Sealed2 (WithState V1Model (FL Prim2))) where
arbitrary = makeWS2Gen ourSmallRepo
instance Arbitrary (Sealed2 (WithState V1Model (FL Prim2 :> FL Prim2))) where
arbitrary = makeWS2Gen ourSmallRepo
instance Arbitrary (Sealed (WithState V1Model (FL Prim2 :> FL Prim2) a)) where
arbitrary = makeWSGen ourSmallRepo