-- 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
    , announceMergeConflicts
    ) where

import Prelude ()
import Darcs.Prelude

import Control.Monad ( when, unless )
import Data.List.Ordered ( nubSort )
import System.Exit ( exitSuccess )

import Darcs.Util.Tree( Tree )
import Darcs.Util.External ( backupByCopying )

import Darcs.Patch
    ( RepoPatch, IsRepoType, PrimOf, merge, listTouchedFiles
    , fromPrims, effect, WrappedNamed
    , listConflictedFiles )
import Darcs.Patch.Prim ( PrimPatch )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Depends( merge2FL )
import Darcs.Patch.Named.Wrapped ( activecontents, anonymous, namedIsInternal )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )
import Darcs.Patch.Progress( progressFL )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..), (:\/:)(..), (:/\:)(..), (+>+),
    mapFL_FL, concatFL, filterOutFLFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal )

import Darcs.Repository.Flags
    ( UseIndex
    , ScanKnown
    , AllowConflicts (..)
    , Reorder (..)
    , UpdateWorking (..)
    , ExternalMerge (..)
    , Verbosity (..)
    , Compression (..)
    , WantGuiPause (..)
    , DiffAlgorithm (..)
    , UseCache(..)
    , LookForMoves(..)
    , LookForReplaces(..)
    )
import Darcs.Repository.Hashed
    ( tentativelyAddPatches_
    , applyToTentativePristine
    , tentativelyRemovePatches_
    , UpdatePristine(..) )
import Darcs.Repository.Identify ( identifyRepository )
import Darcs.Repository.InternalTypes ( Repository )
import Darcs.Repository.Pending ( setTentativePending, readPending )
import Darcs.Repository.Resolution ( standardResolution, externalResolution )
import Darcs.Repository.State ( unrecordedChanges, readUnrecorded )

import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Progress( debugMessage )
import Darcs.Util.Printer.Color (fancyPrinters)
import Darcs.Util.Printer ( text, ($$), redText, putDocLnWith, ($$) )

data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq )

tentativelyMergePatches_ :: forall rt p wR wU wT wY wX
                          . (IsRepoType rt, RepoPatch p, ApplyState 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) us them = do
    (them_merged :/\: us_merged)
         <- return $ merge2FL (progressFL "Merging us" us)
                              (progressFL "Merging them" them)
    pend <- unrecordedChanges diffingOpts NoLookForMoves NoLookForReplaces r Nothing
    anonpend <- n2pia `fmap` anonymous (fromPrims pend)
    pend' :/\: pw <- return $ merge (them_merged :\/: 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 them_merged
    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
        -- these two cases result in the same trees (that's the idea of
        -- merging), so we only operate on the set of patches and do the
        -- adaption of pristine and pending in the common code below
        r' <- case reorder of
            NoReorder -> do
                tentativelyAddPatches_ DontUpdatePristine r
                    compression verbosity updateWorking them_merged
            Reorder -> do
                -- we do not actually remove any effect in the end, so
                -- it would be wrong to update the unrevert bundle or
                -- the working tree or pending
                r1 <- tentativelyRemovePatches_ DontUpdatePristineNorRevert r
                          compression NoUpdateWorking
                          (filterOutFLFL (namedIsInternal . hopefully) us)
                r2 <- tentativelyAddPatches_ DontUpdatePristine r1
                          compression verbosity NoUpdateWorking them
                tentativelyAddPatches_ DontUpdatePristine r2
                    compression verbosity NoUpdateWorking
                    (filterOutFLFL (namedIsInternal . hopefully) us_merged)
        -- must use the original r, not the updated one here:
        applyToTentativePristine r verbosity them_merged
        setTentativePending r' updateWorking (effect pend' +>+ pw_resolution)
    return $ seal (effect pwprim +>+ pw_resolution)

tentativelyMergePatches :: (IsRepoType rt, RepoPatch p, ApplyState 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)
                       => 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


announceMergeConflicts :: (PrimPatch p)
                       => String
                       -> AllowConflicts
                       -> ExternalMerge
                       -> FL p wX wY
                       -> IO Bool
announceMergeConflicts cmd allowConflicts externalMerge resolved_pw =
  case nubSort $ listTouchedFiles resolved_pw of
    [] -> return False
    cfs -> if allowConflicts `elem` [YesAllowConflicts,YesAllowConflictsAndMark]
              || externalMerge /= NoExternalMerge
           then do putDocLnWith fancyPrinters $
                     redText "We have conflicts in the following files:" $$ text (unlines cfs)
                   return True
           else do putDocLnWith fancyPrinters $
                     redText "There are conflicts in the following files:" $$ text (unlines cfs)
                   fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++
                          "If you would rather apply the patch and mark the conflicts,\n"++
                          "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++
                          "These can set as defaults by adding\n"++
                          " "++cmd++" mark-conflicts\n"++
                          "to "++darcsdir++"/prefs/defaults in the target repo. "

checkUnrecordedConflicts :: forall rt p wT wY. RepoPatch p
                         => UpdateWorking
                         -> FL (WrappedNamed rt p) wT wY
                         -> IO Bool
checkUnrecordedConflicts NoUpdateWorking _
 = return False -- because we are called by `darcs convert` hence we don't care
checkUnrecordedConflicts _ pc =
    do repository <- identifyRepository NoUseCache "."
       cuc repository
    where cuc :: Repository rt p wR wU wT -> IO Bool
          cuc r = do Sealed (mpend :: FL (PrimOf p) wT wX) <- readPending r :: IO (Sealed (FL (PrimOf p) wT))
                     case mpend of
                       NilFL -> return False
                       pend ->
                           case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of
                           _ :/\: pend' ->
                               case listConflictedFiles pend' of
                               [] -> return False
                               fs -> do putStrLn ("You have conflicting local changes to:\n"
                                                 ++ unwords fs)
                                        confirmed <- promptYorn "Proceed?"
                                        unless confirmed $
                                             do putStrLn "Cancelled."
                                                exitSuccess
                                        return True
          fromPrims_ :: FL (PrimOf p) wA wB -> FL p wA wB
          fromPrims_ = fromPrims