--  Copyright (C) 2009-2012 Ganesh Sittampalam
--
--  BSD3
{-# LANGUAGE CPP #-}
module Darcs.Repository.Rebase
    (
      withManualRebaseUpdate
    , rebaseJob
    , startRebaseJob
    , repoJobOnRebaseRepo
    ) where

import Darcs.Util.Global ( darcsdir )

import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.CommuteFn ( commuterIdRL )
import Darcs.Patch.Commute ( selfCommuter )
import Darcs.Patch.PatchInfoAnd ( n2pia, hopefully )
import Darcs.Patch.Rebase ( RebaseFixup
                          , Rebasing
                          , mkSuspended
                          , takeHeadRebase
                          , takeAnyRebase
                          , takeAnyRebaseAndTrailingPatches
                          , countToEdit
                          )
import Darcs.Patch.Rebase.Recontext ( RecontextRebase(..)
                                    , RecontextRebase1(..)
                                    , RecontextRebase2(..)
                                    )
import Darcs.Patch.RepoPatch ( RepoPatch )
import Darcs.Patch.Set ( PatchSet(..) )
import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..), (:>)(..), RL(..), reverseRL
    )
import Darcs.Patch.Witnesses.Sealed
    ( Sealed2(..), FlippedSeal(..) )


import Darcs.Repository.Flags
    ( Compression
    , UpdateWorking(..)
    , Verbosity
    )
import Darcs.Repository.Format
    ( RepoProperty ( RebaseInProgress )
    , formatHas
    , addToFormat
    , removeFromFormat
    , writeRepoFormat
    )
import Darcs.Repository.Internal
    ( tentativelyAddPatch
    , tentativelyAddPatch_
    , tentativelyAddPatches_
    , tentativelyRemovePatches
    , tentativelyRemovePatches_
    , finalizeRepositoryChanges
    , revertRepositoryChanges
    , readTentativeRepo
    , readRepo
    , UpdatePristine(..)
    )
import Darcs.Repository.InternalTypes ( Repository(..) )

import Darcs.Util.Progress ( debugMessage )

import Storage.Hashed.Tree ( Tree )

import Control.Applicative ( (<$>) )
import Control.Exception ( finally )

import System.FilePath.Posix ( (</>) )

#include "impossible.h"

withManualRebaseUpdate
   :: forall p x wR wU wT1 wT2
    . (RepoPatch p, ApplyState p ~ Tree)
   => Compression
   -> Verbosity
   -> UpdateWorking
   -> Repository p wR wU wT1
   -> (Repository p wR wU wT1 -> IO (Repository p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x))
   -> IO (Repository p wR wU wT2, x)
withManualRebaseUpdate compr verb uw r subFunc
 | Just (RecontextRebase1 recontext1) <- recontextRebase :: Maybe (RecontextRebase1 p)
 = do patches <- readTentativeRepo r
      let go :: PatchSet p wS wT1 -> IO (Repository p wR wU wT2, x)
          go (PatchSet NilRL _) = bug "trying to recontext rebase without rebase patch at head (tag)"
          go (PatchSet (q :<: _) _) =
              case recontext1 (hopefully q) of
                 (NotEq, _) -> bug "trying to recontext rebase without rebase patch at head (not match)"
                 (IsEq, recontext2) -> do
                    r' <- tentativelyRemovePatches r compr uw (q :>: NilFL)
                    (r'', fixups, x) <- subFunc r'
                    q' <- n2pia <$> recontextFunc2 recontext2 fixups
                    r''' <- tentativelyAddPatch r'' compr verb uw q'
                    return (r''', x)
      go patches
withManualRebaseUpdate _compr _verb _uw r subFunc
 = do (r', _, x) <- subFunc r
      return (r', x)


-- got a normal darcs operation to run on a repo that happens to have a rebase in progress
repoJobOnRebaseRepo :: (RepoPatch p, ApplyState p ~ Tree)
                    => (Repository (Rebasing p) wR wU wR -> IO a)
                    -> Repository (Rebasing p) wR wU wR
                    -> IO a
repoJobOnRebaseRepo job repo = do
    res <- job repo -- TODO can we munge the repo here to hide the rebase patch?
    displaySuspendedStatus repo
    return res

-- got a rebase operation to run where it is required that a rebase is already in progress
rebaseJob :: (RepoPatch p, ApplyState p ~ Tree)
          => (Repository (Rebasing p) wR wU wR -> IO a)
          -> Repository (Rebasing p) wR wU wR
          -> Compression
          -> Verbosity
          -> UpdateWorking
          -> IO a
rebaseJob job repo compr verb uw = do
    repo' <- moveRebaseToEnd repo compr verb uw
    job repo'
      -- the use of finally here is because various things in job
      -- might cause an "expected" early exit leaving us needing
      -- to remove the rebase-in-progress state (e.g. when suspending,
      -- conflicts with recorded, user didn't specify any patches).
      -- It's a bit questionable/non-standard as it's doing quite a bit
      -- of cleanup and if there was an unexpected error then this
      -- may may things worse.
      -- The better fix would be to standardise expected early exits
      -- e.g. using a layer on top of IO or a common Exception type
      -- and then just catch those.
      `finally` checkSuspendedStatus repo' compr verb uw

-- got a rebase operation to run where we may need to initialise the rebase state first
startRebaseJob :: (RepoPatch p, ApplyState p ~ Tree)
               => (Repository (Rebasing p) wR wU wR -> IO a)
               -> Repository (Rebasing p) wR wU wR
               -> Compression
               -> Verbosity
               -> UpdateWorking
               -> IO a
startRebaseJob job repo compr verb uw = do
    repo' <- startRebaseIfNecessary repo compr verb uw
    rebaseJob job repo' compr verb uw

checkSuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree)
                     => Repository (Rebasing p) wR wU wR
                     -> Compression
                     -> Verbosity
                     -> UpdateWorking
                     -> IO ()
checkSuspendedStatus repo@(Repo _ rf _ _) compr verb uw = do
    allpatches <- readRepo repo
    (_, Sealed2 ps) <- return $ takeAnyRebase allpatches
    case countToEdit ps of
         0 -> do
               debugMessage "Removing the rebase patch file..."
               -- this shouldn't actually be necessary since the count should
               -- only go to zero after an actual rebase operation which would
               -- leave the patch at the end anyway, but be defensive.
               repo' <- moveRebaseToEnd repo compr verb uw
               revertRepositoryChanges repo' uw
               -- in theory moveRebaseToEnd could just return the commuted one,
               -- but since the repository has been committed and re-opened
               -- best to just do things carefully
               (rebase, _, _) <- takeHeadRebase <$> readRepo repo'
               repo'' <- tentativelyRemovePatches repo' compr uw (rebase :>: NilFL)
               finalizeRepositoryChanges repo'' uw compr
               writeRepoFormat (removeFromFormat RebaseInProgress rf) (darcsdir </> "format")
               putStrLn "Rebase finished!"
         n -> putStrLn $ "Rebase in progress: " ++ show n ++ " suspended patches"

moveRebaseToEnd :: (RepoPatch p, ApplyState p ~ Tree)
                => Repository (Rebasing p) wR wU wR
                -> Compression
                -> Verbosity
                -> UpdateWorking
                -> IO (Repository (Rebasing p) wR wU wR)
moveRebaseToEnd repo compr verb uw = do
    allpatches <- readRepo repo
    case takeAnyRebaseAndTrailingPatches allpatches of
        FlippedSeal (_ :> NilRL) -> return repo -- already at head
        FlippedSeal (r :> ps) -> do
            Just (ps' :> r') <- return $ commuterIdRL selfCommuter (r :> ps)
            debugMessage "Moving rebase patch to head..."
            revertRepositoryChanges repo uw
            repo' <- tentativelyRemovePatches_ DontUpdatePristine repo compr uw (reverseRL ps)
            repo'' <- tentativelyRemovePatches_ DontUpdatePristine repo' compr uw (r :>: NilFL)
            repo''' <- tentativelyAddPatches_ DontUpdatePristine repo'' compr verb uw (reverseRL ps')
            repo'''' <- tentativelyAddPatch_ DontUpdatePristine repo''' compr verb uw r'
            finalizeRepositoryChanges repo'''' uw compr
            return repo''''

displaySuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree) => Repository (Rebasing p) wR wU wR -> IO ()
displaySuspendedStatus repo = do
    allpatches <- readRepo repo
    (_, Sealed2 ps) <- return $ takeAnyRebase allpatches
    putStrLn $ "Rebase in progress: " ++ show (countToEdit ps) ++ " suspended patches"

startRebaseIfNecessary :: (RepoPatch p, ApplyState p ~ Tree)
                       => Repository (Rebasing p) wR wU wT
                       -> Compression
                       -> Verbosity
                       -> UpdateWorking
                       -> IO (Repository (Rebasing p) wR wU wT)
startRebaseIfNecessary repo@(Repo _ rf _ _) compr verb uw =
    if formatHas RebaseInProgress rf
    then return repo
    else do -- TODO this isn't under the repo lock, and it should be
           writeRepoFormat (addToFormat RebaseInProgress rf) (darcsdir </> "format")
           debugMessage "Writing the rebase patch file..."
           revertRepositoryChanges repo uw
           mypatch <- mkSuspended NilFL
           repo' <- tentativelyAddPatch_ UpdatePristine repo compr verb uw $ n2pia mypatch
           finalizeRepositoryChanges repo' uw compr
           return repo'