Check.hs

{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}
module Darcs.Test.Patch.Properties.Check ( Check(..), checkAPatch ) where

import Prelude ()
import Darcs.Prelude
import Control.Monad ( liftM )

import Darcs.Test.Patch.Check ( PatchCheck,
                                checkMove, removeDir, createDir,
                                isValid, insertLine, fileEmpty, fileExists,
                                deleteLine, modifyFile, createFile, removeFile,
                                doCheck, inconsistent, FileContents(..)
                              )
import Darcs.Patch.RegChars ( regChars )
import Darcs.Util.ByteString ( linesPS )
import qualified Data.ByteString as B ( ByteString, null, concat )
import qualified Data.ByteString.Char8 as BC ( break, pack )
import Darcs.Util.Path ( fn2fp )
import qualified Data.IntMap as M ( mapMaybe )

import Darcs.Patch ( invert, effect, PrimPatch )
import Darcs.Patch.Invert ( Invert )
import Darcs.Patch.V1 ( )
import Darcs.Patch.V1.Core ( RepoPatchV1(..) )
import Darcs.Patch.V2.RepoPatch ( RepoPatchV2, isConsistent )
import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )
import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )
import Darcs.Patch.V1.Core ( isMerger )
import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim )
import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) )
import Darcs.Patch.Witnesses.Ordered

type Prim1 = V1.Prim
type Prim2 = V2.Prim

class Check p where
   checkPatch :: p wX wY -> PatchCheck ()

instance Check p => Check (FL p) where
   checkPatch NilFL = isValid
   checkPatch (p :>: ps) = checkPatch p >> checkPatch ps

instance Check p => Check (p:>p) where
   checkPatch (p1 :> p2) = checkPatch p1 >> checkPatch p2

checkAPatch :: (Invert p, Check p) => p wX wY -> Bool
checkAPatch p = doCheck $ do checkPatch p
                             checkPatch $ invert p

instance PrimPatch prim => Check (RepoPatchV2 prim) where
  checkPatch p = maybe isValid (const inconsistent) $ isConsistent p

instance Check (RepoPatchV1 Prim1) where
   checkPatch p | isMerger p = checkPatch $ effect p
   checkPatch (Merger _ _ _ _) = impossible
   checkPatch (Regrem _ _ _ _) = impossible
   checkPatch (PP p) = checkPatch p

deriving instance Check Prim1
deriving instance Check Prim2

instance Check FileUUID.Prim where
  checkPatch _ = isValid -- XXX

instance Check Prim where

   checkPatch (FP f RmFile) = removeFile $ fn2fp f
   checkPatch (FP f AddFile) =  createFile $ fn2fp f
   checkPatch (FP f (Hunk line old new)) = do
       fileExists $ fn2fp f
       mapM_ (deleteLine (fn2fp f) line) old
       mapM_ (insertLine (fn2fp f) line) (reverse new)
       isValid
   checkPatch (FP f (TokReplace t old new)) =
       modifyFile (fn2fp f) (tryTokPossibly t old new)
   -- note that the above isn't really a sure check, as it leaves PSomethings
   -- and PNothings which may have contained new...
   checkPatch (FP f (Binary o n)) = do
       fileExists $ fn2fp f
       mapM_ (deleteLine (fn2fp f) 1) (linesPS o)
       fileEmpty $ fn2fp f
       mapM_ (insertLine (fn2fp f) 1) (reverse $ linesPS n)
       isValid

   checkPatch (DP d AddDir) = createDir $ fn2fp d
   checkPatch (DP d RmDir) = removeDir $ fn2fp d

   checkPatch (Move f f') = checkMove (fn2fp f) (fn2fp f')
   checkPatch (ChangePref _ _ _) = isValid

tryTokPossibly :: String -> String -> String
                -> (Maybe FileContents) -> (Maybe FileContents)
tryTokPossibly t o n = liftM $ \contents ->
        let lines' = M.mapMaybe (liftM B.concat
                                  . tryTokInternal t (BC.pack o) (BC.pack n))
                                (fcLines contents)
        in contents { fcLines = lines' }

tryTokInternal :: String -> B.ByteString -> B.ByteString
                 -> B.ByteString -> Maybe [B.ByteString]
tryTokInternal _ _ _ s | B.null s = Just []
tryTokInternal t o n s =
    case BC.break (regChars t) s of
    (before,s') ->
        case BC.break (not . regChars t) s' of
        (tok,after) ->
            case tryTokInternal t o n after of
            Nothing -> Nothing
            Just rest ->
                if tok == o
                then Just $ before : n : rest
                else if tok == n
                     then Nothing
                     else Just $ before : tok : rest