PrimFileUUID.hs

{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE OverloadedStrings #-}
module Darcs.Test.Patch.Arbitrary.PrimFileUUID where

import Prelude ()
import Darcs.Prelude

import Darcs.Test.Patch.Arbitrary.Generic
import Darcs.Test.Patch.Arbitrary.Shrink
import Darcs.Test.Patch.RepoModel

import Test.QuickCheck
import Darcs.Test.Patch.WithState
import Darcs.Test.Patch.Types.Pair ( Pair(..) )
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.Test.Patch.FileUUIDModel
import Darcs.Test.Util.QuickCheck ( notIn, maybeOf )

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

type instance ModelOf Prim = FileUUIDModel
instance ArbitraryPrim Prim where
    runCoalesceTests = Nothing
    hasPrimConstruct = Nothing
    usesV1Model = Nothing

-- TODO add some useful shrinking, at least to
-- shrinkAtEnd/shrinkAtStart
instance Shrinkable Prim where
  shrinkInternally _ = []
  shrinkAtEnd _ = []
  shrinkAtStart _ = []

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 PropagateShrink Prim Prim where
  propagateShrink = propagatePrim

instance ShrinkModel Prim where
  -- no shrinking for now
  shrinkModelPatch _ = []

----------------------------------------------------------------------
-- * 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 _ = error "impossible case"

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 _ _ = error "impossible case"

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 (Sealed (WithEndState FileUUIDModel (Prim wX)))
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 not manifested
       mbManifested <- maybeOf manifested -- something 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 "") Nothing) ) -- 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 $ seal $ 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 _ = error "impossible case"

aPrimPair :: FileUUIDModel wX
          -> Gen (Sealed (WithEndState FileUUIDModel (Pair Prim wX)))
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 $ seal $ WithEndState (Pair (p1 :> p2)) repo''
            )
          , ( 1
            , do
                -- construct the underlying pair directly to avoid any
                -- risk of indirectly calling arbitraryStatePair (which
                -- would cause a loop).
                Sealed (WithEndState pair repo') <- arbitraryState repo
                return $ seal $ WithEndState (Pair pair) repo'
            )
          ]
  where
      repoFiles = [ (uuid, Blob x y) | (uuid, Blob x y) <- repoObjects repo ]

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

instance ArbitraryState Prim where
  arbitraryState = aPrim
  arbitraryStatePair = aPrimPair

instance ArbitraryWS Prim where
  arbitraryWS = makeWS2Gen aSmallRepo