PrimFileUUID.hs

{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-}
module Darcs.Test.Patch.Arbitrary.PrimFileUUID where

import Prelude ()
import Darcs.Prelude

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 ( notIn, maybeOf )

import Darcs.Patch.Prim

import qualified Data.ByteString as B
import Data.Maybe ( fromJust, isJust )
import qualified Data.Map as M
import Darcs.Util.Hash( Hash(..) )

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

instance MightBeEmptyHunk Prim
instance MightHaveDuplicate Prim

instance NullPatch Prim where
  nullPatch Identity = IsEq
  nullPatch (Hunk _ (H _ old new))
    | old == new = unsafeCoerceP IsEq
  nullPatch _ = NotEq

-- 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 :: B.ByteString -> Gen (Hunk wX wY)
aHunk content = do
  pos <- choose (0, B.length content)
  oldLen <- choose (0, B.length content - pos)
  new <- scale (`div` 8) aContent
  let old = B.take oldLen $ B.drop pos $ content
  return $ H pos old new

aTextHunk :: (UUID, Object Fail) -> Gen (Prim wX wY)
aTextHunk (uuid, (Blob text _)) =
  do h <- aHunk (unFail text)
     return $ Hunk uuid h
aTextHunk _ = impossible

aManifest :: UUID -> (UUID, Object Fail) -> Gen (Prim wX wY)
aManifest uuid (dirId, Directory dir) =
  do filename <- aFilename `notIn` (M.keys dir)
     return $ Manifest uuid (L dirId filename)
aManifest _ _ = impossible

aDemanifest :: 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 :: FileUUIDModel wX -> Gen (WithEndState FileUUIDModel (Prim wX) wY)
aPrim repo
  = do mbFile <- maybeOf repoFiles -- some file, not necessarily manifested
       dir <- elements repoDirs -- some directory, not necessarily manifested
       -- note, the root directory always exists and is never manifested nor demanifested
       mbDemanifested <- maybeOf notManifested -- something manifested
       mbManifested <- maybeOf manifested -- something not manifested
       fresh <- anUUID `notIn` repoIds repo -- a fresh uuid
       let whenjust m x = if isJust m then x else 0
           whenfile = whenjust mbFile
           whendemanifested = whenjust mbDemanifested
           whenmanifested = whenjust mbManifested
       patch <- frequency
                  [ ( whenfile 12, aTextHunk $ fromJust mbFile ) -- edit an existing file
                  , ( 2, aTextHunk (fresh, Blob (return "") NoHash) ) -- edit a new file
                  , ( whendemanifested 2 -- manifest an existing object
                    , aManifest (fromJust mbDemanifested) dir
                    )
                  , ( whenmanifested 2
                    , uncurry aDemanifest $ fromJust mbManifested
                    )
                  ]
       let repo' = unFail $ repoApply repo patch
       return $ WithEndState patch repo'
  where
      manifested = [ (uuid, (L dirid name)) | (dirid, Directory dir) <- repoDirs
                                          , (name, uuid) <- M.toList dir ]
      notManifested = [ uuid | (uuid, _) <- nonRootObjects
                           , not (uuid `elem` map fst manifested) ]
      repoFiles = [ (uuid, Blob x y) | (uuid, Blob x y) <- repoObjects repo ]
      repoDirs  = [ (uuid, Directory x) | (uuid, Directory x) <- repoObjects repo ]
      nonRootObjects = filter notRoot $ repoObjects repo where
        notRoot (uuid, _) = uuid == rootId

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

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

aPrimPair :: 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 = [ (uuid, Blob x y) | (uuid, 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 (FL (WithState FileUUIDModel Prim))) where
  arbitrary = do repo <- ourSmallRepo
                 liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo


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