{-# 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