-- 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.

#include "gadts.h"

module Darcs.Repository.Merge where

import Darcs.Resolution ( standard_resolution, external_resolution )
import Darcs.External ( backupByCopying )
import Control.Monad ( when )

import Darcs.Patch ( Effect )
import Darcs.Hopefully ( PatchInfoAnd, n2pia, hopefully )
import Darcs.Flags
    ( DarcsFlag( AllowConflicts ), want_external_merge )
import Darcs.Witnesses.Ordered
    ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), mapFL_FL )
import Darcs.Patch
    ( RepoPatch, Prim, merge, joinPatches, listTouchedFiles
    , patchcontents, anonymous, fromPrims, effect )
import Progress( debugMessage )
import Darcs.ProgressPatches( progressFL )
import Darcs.Witnesses.Sealed( Sealed(Sealed), seal )
import Darcs.Repository.InternalTypes( Repository(..) )

import Darcs.Repository.State( unrecordedChanges, readUnrecorded )

import Darcs.Repository.Internal
    ( announce_merge_conflicts, check_unrecorded_conflicts
    , MakeChanges(..), setTentativePending
    , tentativelyAddPatch_, applyToTentativePristine, UpdatePristine(..) )

tentativelyMergePatches_ :: forall p C(r u t y x). RepoPatch p
                         => MakeChanges
                         -> Repository p C(r u t) -> String -> [DarcsFlag]
                         -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)
                         -> IO (Sealed (FL Prim C(u)))
tentativelyMergePatches_ mc r cmd opts usi themi =
  do let us = mapFL_FL hopefully usi
         them = mapFL_FL hopefully themi
     _ :/\: pc <- return $ merge (progressFL "Merging them" them :\/: progressFL "Merging us" us)
     pend <- unrecordedChanges opts r []
     anonpend <- anonymous (fromPrims pend)
     pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL)
     let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $ mapFL_FL patchcontents pw
     Sealed standard_resolved_pw <- return $ standard_resolution pwprim
     debugMessage "Checking for conflicts..."
     mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw
     debugMessage "Announcing conflicts..."
     have_conflicts <- announce_merge_conflicts cmd opts standard_resolved_pw
     debugMessage "Checking for unrecorded conflicts..."
     have_unrecorded_conflicts <- check_unrecorded_conflicts opts pc
     debugMessage "Reading working directory..."
     working <- readUnrecorded r
     debugMessage "Working out conflicts in actual working directory..."
     Sealed pw_resolution <-
          case (want_external_merge opts, have_conflicts || have_unrecorded_conflicts) of
          (Nothing,_) -> return $ if AllowConflicts `elem` opts
                                  then seal NilFL
                                  else seal standard_resolved_pw
          (_,False) -> return $ seal standard_resolved_pw
          (Just c, True) -> external_resolution working c
                                                    (effect us +>+ pend)
                                                    (effect them) pwprim
     debugMessage "Applying patches to the local directories..."
     when (mc == MakeChanges) $
          do let doChanges :: FL (PatchInfoAnd p) C(x r) -> IO ()
                 doChanges NilFL = applyps r themi
                 doChanges _     = applyps r (mapFL_FL n2pia pc)
             doChanges usi
             setTentativePending r (effect pend' +>+ pw_resolution)
     return $ seal (effect pwprim +>+ pw_resolution)
  where mapAdd :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> [IO ()]
        mapAdd _ NilFL = []
        mapAdd r'@(Repo dir df rf dr) (a:>:as) =
               -- we construct a new Repository object on the recursive case so that the
               -- recordedstate of the repository can match the fact that we just wrote a patch
               tentativelyAddPatch_ DontUpdatePristine r' opts a : mapAdd (Repo dir df rf dr) as
        applyps :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> IO ()
        applyps repo ps = do debugMessage "Adding patches to inventory..."
                             sequence_ $ mapAdd repo ps
                             debugMessage "Applying patches to pristine..."
                             applyToTentativePristine repo ps

tentativelyMergePatches :: RepoPatch p
                        => Repository p C(r u t) -> String -> [DarcsFlag]
                        -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)
                        -> IO (Sealed (FL Prim C(u)))
tentativelyMergePatches = tentativelyMergePatches_ MakeChanges


considerMergeToWorking :: RepoPatch p
                       => Repository p C(r u t) -> String -> [DarcsFlag]
                       -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)
                       -> IO (Sealed (FL Prim C(u)))
considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges