PrimFileUUID.hs

-- TODO: Remove these warning disabling flags...
{-# OPTIONS_GHC -w #-}
{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings #-}
module Darcs.Test.Patch.Arbitrary.PrimFileUUID where

import qualified Darcs.Test.Patch.Arbitrary.Generic as T
     ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP
     , mergePairFromTree, mergePairFromTWFP
     , patchFromTree )
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.FileUUID ()
import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Location, Hunk(..), UUID(..) )
import Darcs.Patch.RepoPatch ( RepoPatch )

import Darcs.Test.Patch.FileUUIDModel
import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )

import Darcs.UI.Commands.Replace ( defaultToks )
import Darcs.Patch.Prim

import Control.Applicative ( (<$>) )
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString as BS
import Data.Maybe ( isJust )
import qualified Data.Map as M
import Darcs.Util.Hash( Hash(..) )

#include "impossible.h"

patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t
patchFromTree = T.patchFromTree

mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t
mergePairFromTree = T.mergePairFromTree

mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState FileUUIDModel (TreeWithFlattenPos Prim) wX -> t
mergePairFromTWFP = T.mergePairFromTWFP

commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState FileUUIDModel (TreeWithFlattenPos Prim) wX -> t
commutePairFromTWFP = T.commutePairFromTWFP

commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t
commutePairFromTree = T.commutePairFromTree

commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p :> p) wY wZ -> t) -> WithStartState FileUUIDModel (Tree Prim) wX -> t
commuteTripleFromTree = T.commuteTripleFromTree

type instance ModelOf Prim = FileUUIDModel
instance ArbitraryPrim Prim where
    runCoalesceTests _ = False
    hasPrimConstruct _ = False

hunkIdentity (Hunk _ old new) | old == new = unsafeCoerceP IsEq
hunkIdentity _ = NotEq

instance NullPatch Prim where
  nullPatch (BinaryHunk _ x) = hunkIdentity x
  nullPatch (TextHunk _ x) = hunkIdentity x
  nullPatch _ = NotEq

instance Arbitrary (Sealed2 (FL (WithState FileUUIDModel Prim))) 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

aHunk :: forall wX wY . BS.ByteString -> Gen (Hunk wX wY)
aHunk content
 = sized $ \n ->
     do pos <- choose (0, BS.length content)
        let prefixLen = pos
            restLen   = BS.length content - prefixLen
        oldLen <- frequency
                      [ (75, choose (0, min restLen n))
                      , (25, choose (0, min 10 restLen))
                      ]
        let nonempty x = if oldLen /= 0 then x else 0
        newLen <- frequency
                      [ ( 54, choose (1,min 1 n) )
                      , ( nonempty 42, choose (1,min 1 oldLen) )
                      , ( nonempty 2, return oldLen )
                      , ( nonempty 2, return 0 )
                      ]
        new <- BS.concat <$> vectorOf newLen aLine
        let old = BS.take oldLen $ BS.drop prefixLen $ content
        return $ Hunk pos old new

aTextHunk :: forall wX wY . (UUID, Object Fail) -> Gen (Prim wX wY)
aTextHunk (uuid, (Blob text _)) =
  do hunk <- aHunk (unFail text)
     return $ TextHunk uuid hunk

aManifest :: forall wX wY . UUID -> Location -> Object Fail -> Gen (Prim wX wY)
aManifest uuid loc (Directory dir) =
  do newFilename <- aFilename `notIn` (M.keys dir)
     return $ Manifest uuid loc

aDemanifest :: forall wX wY . UUID -> Location -> Gen (Prim wX wY)
aDemanifest uuid loc = return $ Demanifest uuid loc

-- | Generates any type of 'Prim' patch, except binary and setpref patches.
aPrim :: forall wX wY . FileUUIDModel wX -> Gen (WithEndState FileUUIDModel (Prim wX) wY)
aPrim repo
  = do mbFile <- maybeOf repoFiles
       mbDir <- maybeOf repoDirs
       mbExisting <- maybeOf $ repoObjects repo
       mbManifested <- maybeOf manifested
       fresh <- anUUID
       filename <- aFilename
       dir  <- elements (rootDir:repoDirs)
       mbOtherDir <- maybeOf repoDirs
       let whenfile x = if isJust mbFile then x else 0
           whendir x = if isJust mbDir then x else 0
           whenexisting x = if isJust mbExisting then x else 0
           whenmanifested x = if isJust mbManifested then x else 0
       patch <- frequency
                  [ ( whenfile 12, aTextHunk $ fromJust mbFile )
                  , ( 2, aTextHunk (fresh, Blob (return "") NoHash) ) -- create an empty thing
                  , ( whenexisting (whendir 2), -- manifest an existing object
                      aManifest (fst $ fromJust mbExisting)
                                (fst $ fromJust mbDir, filename)
                                (snd $ fromJust mbDir))
                  , ( whenmanifested 2, uncurry aDemanifest $ fromJust mbManifested )
                    -- TODO: demanifest
                  ]
       let repo' = unFail $ repoApply repo patch
       return $ WithEndState patch repo'
  where
      manifested = [ (id, (dirid, name)) | (dirid, Directory dir) <- repoDirs
                                         , (name, id) <- M.toList dir ]
      repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ]
      repoDirs  = [ (id, Directory x) | (id, Directory x) <- repoObjects repo ]
      rootDir   = (UUID "ROOT", root repo)

----------------------------------------------------------------------
-- *** Pairs of primitive patches

-- Try to generate commutable pairs of hunks
hunkPair :: forall wX wY . (UUID, Object Fail) -> Gen ((Prim :> Prim) wX wY)
hunkPair (uuid, (Blob file _)) =
  do h1@(Hunk l1 old1 new1) <- aHunk (unFail file)
     (delta, content') <- selectChunk h1 (unFail file)
     Hunk l2' old2 new2 <- aHunk content'
     let l2 = l2'+delta
     return (TextHunk uuid (Hunk l1 old1 new1) :> TextHunk uuid (Hunk l2 old2 new2))
  where
     selectChunk (Hunk l old new) content = elements [prefix, suffix]
       where start = l - 1
             prefix = (0, BS.take start content)
             suffix = (start + BS.length new, BS.drop (start + BS.length old) content)
     selectChunk _ _ = impossible

aPrimPair :: forall wX wY . FileUUIDModel wX -> Gen (WithEndState FileUUIDModel ((Prim :> Prim) wX) wY)
aPrimPair repo
  = do mbFile <- maybeOf repoFiles
       frequency
          [ ( if isJust mbFile then 1 else 0
            , do p1 :> p2 <- hunkPair $ 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
      repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ]

----------------------------------------------------------------------
-- Arbitrary instances

ourSmallRepo :: Gen (FileUUIDModel wX)
ourSmallRepo = aSmallRepo

instance ArbitraryState FileUUIDModel Prim where
  arbitraryState s = seal <$> aPrim s


instance Arbitrary (Sealed2 Prim) where
  arbitrary = makeS2Gen ourSmallRepo

instance Arbitrary (Sealed (Prim x)) where
  arbitrary = makeSGen ourSmallRepo

instance Arbitrary (Sealed2 (Prim :> Prim)) where
  arbitrary = do repo <- ourSmallRepo
                 WithEndState pp _ <- aPrimPair repo
                 return $ seal2 pp

instance Arbitrary (Sealed ((Prim :> Prim) wA)) where
  arbitrary = do repo <- ourSmallRepo
                 WithEndState pp _ <- aPrimPair repo
                 return $ seal pp

instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where
  arbitrary = makeS2Gen ourSmallRepo

instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where
  arbitrary = makeSGen ourSmallRepo

instance Arbitrary (Sealed2 (FL Prim)) where
  arbitrary = makeS2Gen ourSmallRepo

instance Arbitrary (Sealed ((FL Prim) wA)) where
  arbitrary = makeSGen ourSmallRepo

instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where
  arbitrary = makeS2Gen ourSmallRepo

instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where
  arbitrary = makeSGen ourSmallRepo

instance Arbitrary (Sealed2 (WithState FileUUIDModel Prim)) where
  arbitrary = makeWS2Gen ourSmallRepo

instance Arbitrary (Sealed (WithState FileUUIDModel Prim wA)) where
  arbitrary = makeWSGen ourSmallRepo

instance Arbitrary (Sealed (WithState FileUUIDModel (FL Prim) wA)) where
  arbitrary = makeWSGen ourSmallRepo

instance Arbitrary (Sealed2 (WithState FileUUIDModel (Prim :> Prim))) where
  arbitrary = do repo <- ourSmallRepo
                 WithEndState pp repo' <- aPrimPair repo
                 return $ seal2 $ WithState repo pp repo'

instance Arbitrary (Sealed (WithState FileUUIDModel (Prim :> Prim) a)) where
  arbitrary = do repo <- ourSmallRepo
                 WithEndState pp repo' <- aPrimPair repo
                 return $ seal $ WithState repo pp repo'


instance Arbitrary (Sealed2 (WithState FileUUIDModel (FL Prim))) where
  arbitrary = makeWS2Gen ourSmallRepo

instance Arbitrary (Sealed2 (WithState FileUUIDModel (FL Prim :> FL Prim))) where
  arbitrary = makeWS2Gen ourSmallRepo

instance Arbitrary (Sealed (WithState FileUUIDModel (FL Prim :> FL Prim) a)) where
  arbitrary = makeWSGen ourSmallRepo