Pending.hs

-- Copyright (C) 2002-2004,2007-2008 David Roundy
-- Copyright (C) 2005 Juliusz Chroboczek
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

module Darcs.Repository.Pending
    ( readPending
    , siftForPending
    , tentativelyRemoveFromPending
    , finalizePending
    , makeNewPending
    , tentativelyAddToPending
    , setTentativePending
    , prepend
    -- deprecated interface:
    , pendingName
    ) where

import Prelude ()
import Darcs.Prelude

import Control.Applicative
import qualified Data.ByteString as B ( empty )

import Control.Exception ( catch, IOException )
import Data.Maybe ( fromMaybe )

import Darcs.Util.Printer ( errorDoc )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Lock
    ( writeDocBinFile
    , removeFileMayNotExist
    )
import Darcs.Repository.InternalTypes ( Repository, withRepoLocation )
import Darcs.Repository.Flags
    ( UpdateWorking (..))
import Darcs.Patch
    ( readPatch, RepoPatch, PrimOf, tryToShrink
    , primIsHunk, primIsBinary, commute, invert
    , primIsAddfile, primIsAdddir, commuteFLorComplain
    , effect, primIsSetpref, applyToTree )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )
import Darcs.Patch.Progress (progressFL)
import Darcs.Patch.Permutations ( commuteWhatWeCanFL
                                , removeFL
                                )

import Darcs.Patch.Prim ( tryShrinkingInverse
                        , PrimPatch
                        )
import Darcs.Patch.Read ( ReadPatch(..), bracketedFL )
import Darcs.Patch.ReadMonads ( ParserM )
import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(ForStorage) )
import Darcs.Patch.Apply ( ApplyState )

import Darcs.Util.Tree ( Tree )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.Workaround ( renameFile )
import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )
import Darcs.Patch.Witnesses.Sealed
    ( Sealed(Sealed), mapSeal, seal
    , FlippedSeal(FlippedSeal)
    , flipSeal
    )
import Darcs.Patch.Witnesses.Unsafe
    ( unsafeCoerceP, unsafeCoercePStart )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..), RL(..), (:>)(..), (+>+)
    , lengthFL, allFL, filterOutFLFL
    , reverseFL, mapFL )
import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Printer ( Doc, ($$), (<>), text, vcat, (<+>) )
import Darcs.Util.Progress ( debugMessage )

pendingName :: String
pendingName = darcsdir ++ "/patches/pending"

newSuffix, tentativeSuffix :: String
newSuffix = ".new"
tentativeSuffix = ".tentative"

-- | Read the contents of pending.
-- The return type is currently incorrect as it refers to the tentative
-- state rather than the recorded state.
readPending :: RepoPatch p => Repository rt p wR wU wT
            -> IO (Sealed (FL (PrimOf p) wT))
readPending = readPendingFile ""

-- |Read the contents of tentative pending.
readTentativePending :: RepoPatch p => Repository rt p wR wU wT
                     -> IO (Sealed (FL (PrimOf p) wT))
readTentativePending = readPendingFile tentativeSuffix

-- |Read the contents of tentative pending.
readNewPending :: RepoPatch p => Repository rt p wR wU wT
               -> IO (Sealed (FL (PrimOf p) wT))
readNewPending = readPendingFile newSuffix

-- |Read the pending file with the given suffix. CWD should be the repository
-- directory.
readPendingFile :: ReadPatch prim => String -> Repository rt p wR wU wT
                -> IO (Sealed (FL prim wX))
readPendingFile suffix _ = do
    pend <- gzReadFilePS (pendingName ++ suffix) `catchall` return B.empty
    return . maybe (Sealed NilFL) (mapSeal unFLM) . readPatch $ pend

-- Wrapper around FL where printed format uses { } except around singletons.
-- Now that the Show behaviour of FL p can be customised (using
-- showFLBehavior (*)), we could instead change the general behaviour of FL Prim;
-- but since the pending code can be kept nicely compartmentalised, it's nicer
-- to do it this way.
-- (*) bf: This function does not exist.
newtype FLM p wX wY = FLM { unFLM :: FL p wX wY }

instance ReadPatch p => ReadPatch (FLM p) where
    readPatch' = mapSeal FLM <$> readMaybeBracketedFL readPatch' '{' '}'

instance ShowPatchBasic p => ShowPatchBasic (FLM p) where
    showPatch f = showMaybeBracketedFL (showPatch f) '{' '}' . unFLM

readMaybeBracketedFL :: forall m p wX . ParserM m
                     => (forall wY . m (Sealed (p wY))) -> Char -> Char
                     -> m (Sealed (FL p wX))
readMaybeBracketedFL parser pre post =
    bracketedFL parser pre post <|> (mapSeal (:>:NilFL) <$> parser)

showMaybeBracketedFL :: (forall wX wY . p wX wY -> Doc) -> Char -> Char
                     -> FL p wA wB -> Doc
showMaybeBracketedFL _ pre post NilFL = text [pre] $$ text [post]
showMaybeBracketedFL printer _ _ (p :>: NilFL) = printer p
showMaybeBracketedFL printer pre post ps = text [pre] $$
                                           vcat (mapFL printer ps) $$
                                           text [post]

-- |Write the contents of tentative pending.
writeTentativePending :: RepoPatch p => Repository rt p wR wU wT
                      -> FL (PrimOf p) wT wY -> IO ()
writeTentativePending = writePendingFile tentativeSuffix

-- |Write the contents of new pending. CWD should be the repository directory.
writeNewPending :: RepoPatch p => Repository rt p wR wU wT
                               -> FL (PrimOf p) wT wY -> IO ()
writeNewPending = writePendingFile newSuffix

-- Write a pending file, with the given suffix. CWD should be the repository
-- directory.
writePendingFile :: ShowPatchBasic prim => String -> Repository rt p wR wU wT
                 -> FL prim wX wY -> IO ()
writePendingFile suffix _ = writePatch name . FLM
  where
    name = pendingName ++ suffix

writePatch :: ShowPatchBasic p => FilePath -> p wX wY -> IO ()
writePatch f p = writeDocBinFile f $ showPatch ForStorage p <> text "\n"

-- | @siftForPending ps@ simplifies the candidate pending patch @ps@
--   through a combination of looking for self-cancellations
--   (sequences of patches followed by their inverses), coalescing,
--   and getting rid of any hunk/binary patches we can commute out
--   the back
--
--   The visual image of sifting can be quite helpful here.  We are
--   repeatedly tapping (shrinking) the patch sequence and
--   shaking it (sift). Whatever falls out is the pending we want
--   to keep. We do this until the sequence looks about as clean as
--   we can get it
siftForPending :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> Sealed (FL prim wX)
siftForPending simple_ps =
    if allFL (\p -> primIsAddfile p || primIsAdddir p) oldps
       then seal oldps
       else fromJust $ do
           Sealed x <- return $ sift NilFL $ reverseFL oldps
           return $ case tryToShrink x of
               ps | lengthFL ps < lengthFL oldps -> siftForPending ps
                  | otherwise -> seal ps
  where
    oldps = fromMaybe simple_ps $ tryShrinkingInverse $ crudeSift simple_ps
    -- get rid of any hunk/binary patches that we can commute out the
    -- back (ie. we work our way backwards, pushing the patches down
    -- to the very end and popping them off; so in (addfile f :> hunk)
    -- we can nuke the hunk, but not so in (hunk :> replace)
    sift :: FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC)
    sift sofar NilRL = seal sofar
    sift sofar (ps:<:p) | primIsHunk p || primIsBinary p =
        case commuteFLorComplain (p :> sofar) of
            Right (sofar' :> _) -> sift sofar'      ps
            Left _              -> sift (p:>:sofar) ps
    sift sofar (ps:<:p) = sift (p:>:sofar) ps

-- | 'crudeSift' can be seen as a first pass approximation of 'siftForPending'
--    that works without having to do any commutation.  It either returns a
--    sifted pending (if the input is simple enough for this crude approach)
--    or has no effect.
crudeSift :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> FL prim wX wY
crudeSift xs =
    if isSimple xs then filterOutFLFL ishunkbinary xs else xs
  where
    ishunkbinary :: prim wA wB -> EqCheck wA wB
    ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq
                   | otherwise = NotEq

-- | @tentativelyRemoveFromPending p@ is used by Darcs whenever it
--   adds a patch to the repository (eg. with apply or record).
--   Think of it as one part of transferring patches from pending to
--   somewhere else.
--
--   Question (Eric Kow): how do we detect patch equivalence?
tentativelyRemoveFromPending :: forall rt p wR wU wT wX wY. (RepoPatch p)
                 => Repository rt p wR wU wT
                 -> UpdateWorking
                 -> PatchInfoAnd rt p wX wY
                 -> IO ()
tentativelyRemoveFromPending _    NoUpdateWorking  _ = return ()
tentativelyRemoveFromPending repo YesUpdateWorking p = do
    Sealed pend <- readTentativePending repo
    -- Question (Eric Kow): why does pending being all simple matter for
    -- changepref patches in p? isSimple includes changepref, so what do
    -- adddir/etc have to do with it?  Why don't we we systematically
    -- crudeSift/not?
    let effectp = if isSimple pend
                     then crudeSift $ effect p
                     else effect p
    Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp)
                               (unsafeCoercePStart pend)
    writeTentativePending repo (unsafeCoercePStart newpend)
  where
    -- @rmpend effect pending@ removes as much of @effect@ from @pending@
    -- as possible
    --
    -- Note that @effect@ and @pending@ must start from the same context
    -- This is not a bad thing to assume because @effect@ is a patch we want to
    -- add to the repository anyway so it'd kind of have to start from wR anyway
    --
    -- Question (Eric Kow), ok then why not
    -- @PatchInfoAnd p wR wY@ in the type signature above?
    rmpend :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wB)
    rmpend NilFL x = Sealed x
    rmpend _ NilFL = Sealed NilFL
    rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys
    rmpend (x:>:xs) ys =
        case commuteWhatWeCanFL (x:>xs) of
            a:>x':>b -> case rmpend a ys of
                Sealed ys' -> case commute (invert (x':>:b) :> ys') of
                    Just (ys'' :> _) -> seal ys''
                    Nothing          -> seal $ invert (x':>:b)+>+ys'
                    -- DJR: I don't think this last case should be
                    -- reached, but it also shouldn't lead to corruption.

-- | A sequence of primitive patches (candidates for the pending patch)
--   is considered simple if we can reason about their continued status as
--   pending patches solely on the basis of them being hunk/binary patches.
--
--   Simple here seems to mean that all patches are either hunk/binary
--   patches, or patches that cannot (indirectly) depend on hunk/binary
--   patches.  For now, the only other kinds of patches in this category
--   are changepref patches.
--
--   It might be tempting to add, say, adddir patches but it's probably not a
--   good idea because Darcs also inverts patches a lot in its reasoning so an
--   innocent addir may be inverted to a rmdir which in turn may depend on
--   a rmfile, which in turn depends on a hunk/binary. Likewise, we would
--   not want to add move patches to this category for similar reasons of
--   a potential dependency chain forming.
isSimple :: PrimPatch prim => FL prim wX wY -> Bool
isSimple =
    allFL isSimp
  where
    isSimp x = primIsHunk x || primIsBinary x || primIsSetpref x

-- | @makeNewPending repo YesUpdateWorking pendPs@ verifies that the
--   @pendPs@ could be applied to pristine if we wanted to, and if so
--   writes it to disk.  If it can't be applied, @pendPs@ must
--   be somehow buggy, so we save it for forensics and crash.
makeNewPending :: (RepoPatch p, ApplyState p ~ Tree)
                 => Repository rt p wR wU wT
                 -> UpdateWorking
                 -> FL (PrimOf p) wT wY
                 -> Tree IO  -- ^recorded state of the repository, to check if pending can be applied
                 -> IO ()
makeNewPending _                  NoUpdateWorking _ _ = return ()
makeNewPending repo YesUpdateWorking origp recordedState =
    withRepoLocation repo $
    do let newname = pendingName ++ ".new"
       debugMessage $ "Writing new pending:  " ++ newname
       Sealed sfp <- return $ siftForPending origp
       writeNewPending repo sfp
       Sealed p <- readNewPending repo
       -- We don't ever use the resulting tree.
       _ <- catch (applyToTree p recordedState) $ \(err :: IOException) -> do
         let buggyname = pendingName ++ "_buggy"
         renameFile newname buggyname
         errorDoc $ text ("There was an attempt to write an invalid pending! " ++ show err)
                    $$ text "If possible, please send the contents of"
                    <+> text buggyname
                    $$ text "along with a bug report."
       renameFile newname pendingName
       debugMessage $ "Finished writing new pending:  " ++ newname

-- | Replace the pending patch with the tentative pending.
--   If @NoUpdateWorking@, this merely deletes the tentative pending
--   without replacing the current one.
--
--   Question (Eric Kow): shouldn't this also delete the tentative
--   pending if @YesUpdateWorking@?  I'm just puzzled by the seeming
--   inconsistency of the @NoUpdateWorking@ doing deletion, but
--   @YesUpdateWorking@ not bothering.
finalizePending :: (RepoPatch p, ApplyState p ~ Tree)
                => Repository rt p wR wU wT
                -> UpdateWorking
                -> Tree IO
                -> IO ()
finalizePending repo NoUpdateWorking _ =
  withRepoLocation repo $ removeFileMayNotExist pendingName
finalizePending repo updateWorking@YesUpdateWorking recordedState =
  withRepoLocation repo $ do
      Sealed tpend <- readTentativePending repo
      Sealed new_pending <- return $ siftForPending tpend
      makeNewPending repo updateWorking new_pending recordedState

-- | @tentativelyAddToPending repo NoDryRun YesUpdateWorking pend ps@
--   appends @ps@ to the pending patch.
--
--   It has no effect with @NoUpdateWorking@.
--
--   This fuction is unsafe because it accepts a patch that works on the
--   tentative pending and we don't currently track the state of the
--   tentative pending.
tentativelyAddToPending :: forall rt p wR wU wT wX wY. RepoPatch p
                        => Repository rt p wR wU wT
                        -> UpdateWorking
                        -> FL (PrimOf p) wX wY
                        -> IO ()
tentativelyAddToPending _                   NoUpdateWorking  _     = return ()
tentativelyAddToPending repo YesUpdateWorking patch =
    withRepoLocation repo $ do
        Sealed pend <- readTentativePending repo
        FlippedSeal newpend_ <- return $
            newpend (unsafeCoerceP pend :: FL (PrimOf p) wA wX) patch
        writeTentativePending repo (unsafeCoercePStart newpend_)
  where
    newpend :: FL prim wA wB -> FL prim wB wC -> FlippedSeal (FL prim) wC
    newpend NilFL patch_ = flipSeal patch_
    newpend p     patch_ = flipSeal $ p +>+ patch_

-- | setTentativePending is basically unsafe.  It overwrites the pending
--   state with a new one, not related to the repository state.
setTentativePending :: forall rt p wR wU wT wX wY. RepoPatch p
                    => Repository rt p wR wU wT
                    -> UpdateWorking
                    -> FL (PrimOf p) wX wY
                    -> IO ()
setTentativePending _                   NoUpdateWorking  _ = return ()
setTentativePending repo YesUpdateWorking patch = do
    Sealed prims <- return $ siftForPending patch
    withRepoLocation repo $ writeTentativePending repo (unsafeCoercePStart prims)

-- | @prepend repo YesUpdateWorking ps@ prepends @ps@ to the pending patch
--   It's used right before removing @ps@ from the repo.  This ensures that
--   the pending patch can still be applied on top of the recorded state.
--
--   This function is basically unsafe.  It overwrites the pending state
--   with a new one, not related to the repository state.
prepend :: forall rt p wR wU wT wX wY. RepoPatch p
        => Repository rt p wR wU wT
        -> UpdateWorking
        -> FL (PrimOf p) wX wY
        -> IO ()
prepend _    NoUpdateWorking  _     = return ()
prepend repo YesUpdateWorking patch = do
    Sealed pend <- readTentativePending repo
    Sealed newpend_ <- return $ newpend (unsafeCoerceP pend) patch
    writeTentativePending repo (unsafeCoercePStart $ crudeSift newpend_)
  where
    newpend :: FL prim wB wC -> FL prim wA wB -> Sealed (FL prim wA)
    newpend NilFL patch_ = seal patch_
    newpend p     patch_ = seal $ patch_ +>+ p