--  Copyright (C) 2009-2012 Ganesh Sittampalam
--
--  BSD3
module Darcs.Repository.Rebase
    ( RebaseJobFlags(..)
    , withManualRebaseUpdate
    , rebaseJob
    , startRebaseJob
    , maybeDisplaySuspendedStatus
    ) where

import Prelude ()
import Darcs.Prelude

import Darcs.Util.Global ( darcsdir )

import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.CommuteFn ( commuterIdRL )
import Darcs.Patch.Commute ( selfCommuter )
import Darcs.Patch.Named.Wrapped ( WrappedNamed(..), mkRebase )
import Darcs.Patch.PatchInfoAnd ( n2pia, hopefully )
import Darcs.Patch.Rebase
  ( takeHeadRebase
  , takeAnyRebase
  , takeAnyRebaseAndTrailingPatches
  )
import Darcs.Patch.Rebase.Container ( Suspended(..), countToEdit, simplifyPushes )
import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )
import Darcs.Patch.RepoPatch ( RepoPatch )
import Darcs.Patch.RepoType
  ( RepoType(..), IsRepoType(..), SRepoType(..)
  , RebaseType(..), SRebaseType(..)
  )
import Darcs.Patch.Set ( PatchSet(..) )
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.Hashed
    ( tentativelyAddPatch
    , tentativelyAddPatch_
    , tentativelyAddPatches_
    , tentativelyRemovePatches
    , tentativelyRemovePatches_
    , finalizeRepositoryChanges
    , revertRepositoryChanges
    , readTentativeRepo
    , readRepo
    , UpdatePristine(..)
    )
import Darcs.Repository.InternalTypes ( Repository, repoFormat, repoLocation )

import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )
import Darcs.Util.Printer ( ePutDocLn, text )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Tree ( Tree )

import Control.Exception ( finally )

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

-- | Some common flags that are needed to run rebase jobs.
-- Normally flags are captured directly by the implementation of the specific
-- job's function, but the rebase infrastructure needs to do work on the repository
-- directly that sometimes needs these options, so they have to be passed
-- as part of the job definition.
data RebaseJobFlags =
  RebaseJobFlags
  { rjoCompression   :: Compression
  , rjoVerbosity     :: Verbosity
  , rjoUpdateWorking :: UpdateWorking
  }

withManualRebaseUpdate
   :: forall rt p x wR wU wT1 wT2
    . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
   => RebaseJobFlags
   -> Repository rt p wR wU wT1
   -> (Repository rt p wR wU wT1 -> IO (Repository rt p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x))
   -> IO (Repository rt p wR wU wT2, x)
withManualRebaseUpdate (RebaseJobFlags compr verb uw) r subFunc
 | SRepoType SIsRebase <- singletonRepoType :: SRepoType rt
 = do patches <- readTentativeRepo r (repoLocation r)
      let go :: PatchSet rt p wS wT1 -> IO (Repository rt p wR wU wT2, x)
          go (PatchSet _ NilRL) = bug "trying to recontext rebase without rebase patch at head (tag)"
          go (PatchSet _ (_ :<: q)) =
              case hopefully q of
                  NormalP {} ->
                      bug "trying to recontext rebase without a rebase patch at head (not match)"
                  RebaseP _ s -> do
                      r' <- tentativelyRemovePatches r compr uw (q :>: NilFL)
                      (r'', fixups, x) <- subFunc r'
                      q' <- n2pia <$> mkRebase (simplifyPushes D.MyersDiff fixups s)
                      r''' <- tentativelyAddPatch r'' compr verb uw q'
                      return (r''', x)
      go patches
withManualRebaseUpdate _flags r subFunc
 = do (r', _, x) <- subFunc r
      return (r', x)

-- got a rebase operation to run where it is required that a rebase is already in progress
rebaseJob :: (RepoPatch p, ApplyState p ~ Tree)
          => (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
          -> Repository ('RepoType 'IsRebase) p wR wU wR
          -> RebaseJobFlags
          -> IO a
rebaseJob job repo flags = do
    repo' <- moveRebaseToEnd repo flags
    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' flags

-- got a rebase operation to run where we may need to initialise the rebase state first
startRebaseJob :: (RepoPatch p, ApplyState p ~ Tree)
               => (Repository ('RepoType 'IsRebase) p wR wU wR -> IO a)
               -> Repository ('RepoType 'IsRebase) p wR wU wR
               -> RebaseJobFlags
               -> IO a
startRebaseJob job repo flags = do
    repo' <- startRebaseIfNecessary repo flags
    rebaseJob job repo' flags

checkSuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree)
                     => Repository ('RepoType 'IsRebase) p wR wU wR
                     -> RebaseJobFlags
                     -> IO ()
checkSuspendedStatus repo flags@(RebaseJobFlags compr _verb uw) = do
    (_, Sealed2 ps) <- takeAnyRebase <$> readRepo repo
    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 flags
               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 (repoFormat repo))
                  (darcsdir </> "format")
               putStrLn "Rebase finished!"
         n -> ePutDocLn $ text $ "Rebase in progress: " ++ show n ++ " suspended patches"

moveRebaseToEnd :: (RepoPatch p, ApplyState p ~ Tree)
                => Repository ('RepoType 'IsRebase) p wR wU wR
                -> RebaseJobFlags
                -> IO (Repository ('RepoType 'IsRebase) p wR wU wR)
moveRebaseToEnd repo (RebaseJobFlags 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 => Repository ('RepoType 'IsRebase) p wR wU wR -> IO ()
displaySuspendedStatus repo = do
    (_, Sealed2 ps) <- takeAnyRebase <$> readRepo repo
    ePutDocLn $ text $ "Rebase in progress: " ++ show (countToEdit ps) ++ " suspended patches"

maybeDisplaySuspendedStatus
  :: RepoPatch p
  => SRebaseType rebaseType -> Repository ('RepoType rebaseType) p wR wU wR -> IO ()
maybeDisplaySuspendedStatus SIsRebase repo = displaySuspendedStatus repo
maybeDisplaySuspendedStatus SNoRebase _    = return ()

startRebaseIfNecessary :: (RepoPatch p, ApplyState p ~ Tree)
                       => Repository ('RepoType 'IsRebase) p wR wU wT
                       -> RebaseJobFlags
                       -> IO (Repository ('RepoType 'IsRebase) p wR wU wT)
startRebaseIfNecessary repo (RebaseJobFlags compr verb uw) =
  let rf = repoFormat repo
  in
    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 <- mkRebase (Items NilFL)
           repo' <- tentativelyAddPatch_ UpdatePristine repo compr verb uw $ n2pia mypatch
           finalizeRepositoryChanges repo' uw compr
           return repo'