darcs-beta-2.7.98.1: src/Darcs/Test/Patch/Prim/V1.hs
{-# LANGUAGE CPP, MultiParamTypeClasses #-}
#include "gadts.h"
-- | Testing of primitive V1 patches
module Darcs.Test.Patch.Prim.V1
( aHunk, aTokReplace
, aPrim
, aPrimPair
)
where
import Darcs.Test.Patch.RepoModel
import Darcs.Test.Patch.WithState
import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )
import Darcs.Commands.Replace ( defaultToks )
import Darcs.Patch.Prim
import Darcs.Patch.Prim.V1.Core ( Prim(..), FilePatchType(..), DirPatchType(..) )
import Darcs.Witnesses.Ordered ( (:>)(..), FL(..) )
import Darcs.Witnesses.Sealed
import Darcs.Witnesses.Unsafe ( unsafeCoerceP1 )
import Control.Applicative ( (<$>) )
import qualified Data.ByteString.Char8 as BC
import Data.Maybe ( isJust, fromJust )
import Test.QuickCheck
( Arbitrary(..)
, Gen, sized, frequency, choose, elements, vectorOf
)
----------------------------------------------------------------------
-- * QuickCheck generators
----------------------------------------------------------------------
-- ** FilePatchType generators
aHunk :: FORALL(x y) Content -> Gen (FilePatchType C(x y))
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 $ Hunk pos old new
where
contentLen = length content
aTokReplace :: FORALL(x y) Content -> Gen (FilePatchType C(x y))
aTokReplace []
= do w <- vectorOf 1 alpha
w' <- vectorOf 1 alpha
return $ TokReplace defaultToks w w'
aTokReplace content
= do let fileWords = concatMap BC.words content
wB <- elements fileWords
w' <- alphaBS `notIn` fileWords
return $ TokReplace defaultToks (BC.unpack wB) (BC.unpack w')
where
alphaBS = do x <- alpha; return $ BC.pack [x]
----------------------------------------------------------------------
-- ** Prim generators
aHunkP :: FORALL(x y) (AnchoredPath,File) -> Gen (Prim C(x y))
aHunkP (path,file)
= do Hunk pos old new <- aHunk content
return $ hunk (ap2fp path) pos old new
where
content = fileContent file
aTokReplaceP :: FORALL (x y) (AnchoredPath,File) -> Gen (Prim C(x y))
aTokReplaceP (path,file)
= do TokReplace tokchars old new <- aTokReplace content
return $ tokreplace (ap2fp path) tokchars old new
where
content = fileContent file
anAddFileP :: FORALL (x y) (AnchoredPath,Dir) -> Gen (Prim C(x y))
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 (x y) AnchoredPath -- ^ Path of an empty file
-> Prim C(x y)
aRmFileP path = rmfile (ap2fp path)
anAddDirP :: FORALL (x y) (AnchoredPath,Dir) -> Gen (Prim C(x y))
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 (x y) AnchoredPath -- ^ Path of an empty directory
-> Prim C(x y)
aRmDirP path = rmdir (ap2fp path)
aMoveP :: FORALL (x y) Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (Prim C(x y))
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(x y) RepoModel C(x) -> Gen (WithEndState RepoModel (Prim C(x)) C(y))
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 Just repo' = applyPatch patch repo
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(x y) (AnchoredPath,File) -> Gen ((Prim :> Prim) C(x y))
hunkPairP (path,file)
= do h1@(Hunk l1 old1 new1) <- aHunk content
(delta, content') <- selectChunk h1 content
Hunk 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)
aPrimPair :: FORALL(x y) RepoModel C(x) -> Gen (WithEndState RepoModel ((Prim :> Prim) C(x)) C(y))
aPrimPair repo
= do mbFile <- maybeOf repoFiles
frequency
[ ( if isJust mbFile then 1 else 0
, do p1 :> p2 <- hunkPairP $ fromJust mbFile
let Just repo' = applyPatch p1 repo
Just repo'' = applyPatch p2 repo'
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
instance ArbitraryState RepoModel Prim where
arbitraryState s = seal <$> aPrim s
instance Arbitrary (Sealed2 Prim) where
arbitrary = makeGen aSmallRepo
instance Arbitrary (Sealed2 (Prim :> Prim)) where
arbitrary = do repo <- aSmallRepo
WithEndState pp _ <- aPrimPair repo
return $ seal2 pp
instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where
arbitrary = makeGen aSmallRepo
instance Arbitrary (Sealed2 (FL Prim)) where
arbitrary = makeGen aSmallRepo
instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where
arbitrary = makeGen aSmallRepo
instance Arbitrary (Sealed2 (WithState RepoModel Prim)) where
arbitrary = makeWSGen aSmallRepo
instance Arbitrary (Sealed2 (WithState RepoModel (Prim :> Prim))) where
arbitrary = do repo <- aSmallRepo
WithEndState pp repo' <- aPrimPair repo
return $ seal2 $ WithState repo pp repo'
instance Arbitrary (Sealed2 (WithState RepoModel (FL Prim))) where
arbitrary = makeWSGen aSmallRepo
instance Arbitrary (Sealed2 (WithState RepoModel (FL Prim :> FL Prim))) where
arbitrary = makeWSGen aSmallRepo