-- Copyright (C) 2002-2004,2007-2008 David Roundy
-- Copyright (C) 2005 Juliusz Chroboczek
-- Copyright (C) 2009 Petr Rockai
--
-- 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.Merge
    ( tentativelyMergePatches
    , considerMergeToWorking
    ) where

import Prelude ()
import Darcs.Prelude

import Control.Monad ( when )
import Darcs.Util.Tree( Tree )

import Darcs.Util.External ( backupByCopying )
import Darcs.Repository.Flags
    ( UseIndex
    , ScanKnown
    , AllowConflicts (..)
    , Reorder (..)
    , UpdateWorking (..)
    , ExternalMerge (..)
    , Verbosity (..)
    , Compression (..)
    , WantGuiPause (..)
    , DiffAlgorithm (..)
    )
import Darcs.Patch ( RepoPatch, IsRepoType, PrimOf, merge, listTouchedFiles,
                     fromPrims, effect )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Depends( merge2FL )
import Darcs.Patch.Named.Wrapped ( activecontents, anonymous )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )
import Darcs.Patch.Progress( progressFL )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..), (:\/:)(..), (:/\:)(..), (+>+),
    mapFL_FL, concatFL )
import Darcs.Patch.Witnesses.Sealed( Sealed(Sealed), seal )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd )
import Darcs.Repository.InternalTypes( Repository(..) )
import Darcs.Repository.State( unrecordedChanges, readUnrecorded )
import Darcs.Repository.Resolution ( standardResolution, externalResolution )
import Darcs.Repository.Internal ( announceMergeConflicts,
                                   checkUnrecordedConflicts, MakeChanges(..),
                                   setTentativePending, tentativelyAddPatch_,
                                   applyToTentativePristine,
                                   tentativelyReplacePatches,
                                   UpdatePristine(..) )
import Darcs.Util.Progress( debugMessage )

tentativelyMergePatches_ :: forall rt p wR wU wT wY wX
                          . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
                         => MakeChanges
                         -> Repository rt p wR wU wT -> String
                         -> AllowConflicts -> UpdateWorking
                         -> ExternalMerge -> WantGuiPause
                         -> Compression -> Verbosity -> Reorder
                         -> ( UseIndex, ScanKnown, DiffAlgorithm )
                         -> FL (PatchInfoAnd rt p) wX wT
                         -> FL (PatchInfoAnd rt p) wX wY
                         -> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ mc r cmd allowConflicts updateWorking externalMerge wantGuiPause
  compression verbosity reorder diffingOpts@(_, _, dflag) usi themi = do
    let us = mapFL_FL hopefully usi
        them = mapFL_FL hopefully themi
    ((pc :: FL (PatchInfoAnd rt p) wT wMerged) :/\: us_merged)
         <- return $ merge2FL (progressFL "Merging us" usi)
                              (progressFL "Merging them" themi)
    pend <- unrecordedChanges diffingOpts r Nothing
    anonpend <- n2pia `fmap` anonymous (fromPrims pend)
    pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL)
    let pwprim = concatFL $ progressFL "Examining patches for conflicts" $
                                mapFL_FL (activecontents . hopefully) pw
    Sealed standard_resolved_pw <- return $ standardResolution pwprim
    debugMessage "Checking for conflicts..."
    when (allowConflicts == YesAllowConflictsAndMark) $
        mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw
    debugMessage "Announcing conflicts..."
    have_conflicts <- announceMergeConflicts cmd allowConflicts externalMerge standard_resolved_pw
    debugMessage "Checking for unrecorded conflicts..."
    have_unrecorded_conflicts <- checkUnrecordedConflicts updateWorking $
                                     mapFL_FL hopefully pc
    debugMessage "Reading working directory..."
    working <- readUnrecorded r Nothing
    debugMessage "Working out conflicts in actual working directory..."
    let haveConflicts = have_conflicts || have_unrecorded_conflicts
    Sealed pw_resolution <-
        case (externalMerge , haveConflicts) of
            (NoExternalMerge, _)       -> return $ if allowConflicts == YesAllowConflicts
                                                     then seal NilFL
                                                     else seal standard_resolved_pw
            (_, False)                 -> return $ seal standard_resolved_pw
            (YesExternalMerge c, True) -> externalResolution dflag working c wantGuiPause
                                             (effect us +>+ pend) (effect them) pwprim
    debugMessage "Applying patches to the local directories..."
    when (mc == MakeChanges) $ do
        let doChanges :: FL (PatchInfoAnd rt p) wX wT -> IO (Repository rt p wR wU wMerged)
            -- This first case is a possible optimisation: if 'usi' is empty, then
            -- the merge2FL call above will return pc = themi, but the wMerged
            -- witness is quantified in the :/\: constructor so we lose the
            -- information that wX=wT => wMerged=wY so we have to coerce.
            -- TODO: it's not really clear why if this is an optimisation in
            -- practice, as pc would be trivial to calculate in this case and
            -- there aren't any obvious memory benefits.
            doChanges NilFL = applyps r (unsafeCoercePEnd themi)
            doChanges _     = applyps r pc
        r' <- doChanges usi
        setTentativePending r' updateWorking (effect pend' +>+ pw_resolution)
        when (reorder == Reorder) $
            -- TODO: we end up applying the merged remote patches on top of the unmerged
            -- local patches, then commuting out the unmerged local patches and finally
            -- adding the merged local patches.
            -- It would better to just remove the unmerged local patche, then apply the
            -- unmerged remote patches and then the merged local patches.
            -- The handling of 'unrecorded' might complicate this slightly so this
            -- refactoring may be better deferred until we have reliable witness tracking
            -- for repositories.
            tentativelyReplacePatches r' compression YesUpdateWorking verbosity us_merged
    return $ seal (effect pwprim +>+ pw_resolution)
  where
    mapAdd :: Repository rt p wM wL wI -> FL (PatchInfoAnd rt p) wI wJ
           -> IO (Repository rt p wM wL wJ)
    mapAdd repo NilFL = return repo
    mapAdd repo (a:>:as) = do
        repo' <- tentativelyAddPatch_ DontUpdatePristine repo
                     compression verbosity updateWorking a
        mapAdd repo' as
    applyps :: Repository rt p wM wL wI -> FL (PatchInfoAnd rt p) wI wJ
            -> IO (Repository rt p wM wL wJ)
    applyps repo ps = do
        debugMessage "Adding patches to inventory..."
        repo' <- mapAdd repo ps
        debugMessage "Applying patches to pristine..."
        applyToTentativePristine repo verbosity ps
        return repo'

tentativelyMergePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
                        => Repository rt p wR wU wT -> String
                        -> AllowConflicts -> UpdateWorking
                        -> ExternalMerge -> WantGuiPause
                        -> Compression -> Verbosity -> Reorder
                        -> ( UseIndex, ScanKnown, DiffAlgorithm )
                        -> FL (PatchInfoAnd rt p) wX wT
                        -> FL (PatchInfoAnd rt p) wX wY
                        -> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches = tentativelyMergePatches_ MakeChanges


considerMergeToWorking :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
                       => Repository rt p wR wU wT -> String
                       -> AllowConflicts -> UpdateWorking
                       -> ExternalMerge -> WantGuiPause
                       -> Compression -> Verbosity -> Reorder
                       -> ( UseIndex, ScanKnown, DiffAlgorithm )
                       -> FL (PatchInfoAnd rt p) wX wT
                       -> FL (PatchInfoAnd rt p) wX wY
                       -> IO (Sealed (FL (PrimOf p) wU))
considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges