-- Copyright (C) 2003,2005 David Roundy -- -- 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.Resolution ( standardResolution , externalResolution , patchsetConflictResolutions , StandardResolution(..) , announceConflicts , warnUnmangled , showUnmangled , showUnravelled ) where import Darcs.Prelude import System.FilePath.Posix ( () ) import System.Exit ( ExitCode( ExitSuccess ) ) import System.Directory ( setCurrentDirectory, getCurrentDirectory ) import Data.List ( intersperse, zip4 ) import Data.List.Ordered ( nubSort ) import Data.Maybe ( catMaybes, isNothing ) import Control.Monad ( when ) import Darcs.Repository.Diff( treeDiff ) import Darcs.Patch ( PrimOf , PrimPatchBase , RepoPatch , applyToTree , effect , effectOnPaths , invert , listConflictedFiles , resolveConflicts ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Commute ( Commute ) import Darcs.Patch.Conflict ( Conflict, ConflictDetails(..), Mangled, Unravelled ) import Darcs.Patch.Inspect ( listTouchedFiles ) import Darcs.Patch.Merge ( mergeList ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Util.Path ( AnchoredPath , anchorPath , displayPath , filterPaths , toFilePath ) import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal, unFreeLeft ) import Darcs.Util.CommandLine ( parseCmd ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd ) import Darcs.Util.Prompt ( askEnter ) import Darcs.Patch.Set ( PatchSet(..), Origin, patchSet2RL ) import Darcs.Repository.Prefs ( filetypeFunction ) import Darcs.Util.Exec ( exec, Redirect(..) ) import Darcs.Util.Lock ( withTempDir ) import Darcs.Util.External ( cloneTree ) import Darcs.Repository.Flags ( AllowConflicts (..) , ExternalMerge (..) , WantGuiPause (..) , DiffAlgorithm (..) ) import qualified Darcs.Util.Tree as Tree import Darcs.Util.Tree.Plain ( writePlainTree, readPlainTree ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Printer ( Doc, renderString, ($$), text, redText, vcat ) import Darcs.Util.Printer.Color ( ePutDocLn ) import Darcs.Patch ( displayPatch ) data StandardResolution prim wX = StandardResolution { mangled :: Mangled prim wX, unmangled :: [Unravelled prim wX], conflictedPaths :: [AnchoredPath] } standardResolution :: (Commute p, PrimPatchBase p, Conflict p) => RL (PatchInfoAnd rt p) wO wX -> RL (PatchInfoAnd rt p) wX wY -> StandardResolution (PrimOf p) wY standardResolution context interesting = case mergeList $ catMaybes $ map conflictMangled conflicts of Right mangled -> StandardResolution {..} Left (Sealed ps, Sealed qs) -> error $ renderString $ redText "resolutions conflict:" $$ displayPatch ps $$ redText "conflicts with" $$ displayPatch qs where conflicts = resolveConflicts context interesting unmangled = map conflictParts $ filter (isNothing . conflictMangled) conflicts conflictedPaths = nubSort $ concatMap (unseal listTouchedFiles) (concatMap conflictParts conflicts) warnUnmangled :: PrimPatch prim => StandardResolution prim wX -> IO () warnUnmangled StandardResolution {..} | null unmangled = return () | otherwise = ePutDocLn $ showUnmangled unmangled showUnmangled :: PrimPatch prim => [Unravelled prim wX] -> Doc showUnmangled = vcat . map showUnmangledConflict where showUnmangledConflict unravelled = redText "Cannot mark these conflicting patches:" $$ showUnravelled (redText "versus") unravelled showUnravelled :: PrimPatch prim => Doc -> Unravelled prim wX -> Doc showUnravelled sep = vcat . intersperse sep . map (unseal displayPatch) announceConflicts :: PrimPatch prim => String -> AllowConflicts -> ExternalMerge -> StandardResolution prim wX -> IO Bool announceConflicts cmd allowConflicts externalMerge conflicts = case nubSort (conflictedPaths conflicts) of [] -> return False cfs -> do ePutDocLn $ vcat $ redText "We have conflicts in the following files:" : map (text . displayPath) cfs when (allowConflicts == YesAllowConflictsAndMark) $ warnUnmangled conflicts if allowConflicts `elem` [YesAllowConflicts,YesAllowConflictsAndMark] || externalMerge /= NoExternalMerge then return True else 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. " externalResolution :: forall p wX wY wZ wA. (RepoPatch p, ApplyState p ~ Tree.Tree) => DiffAlgorithm -> Tree.Tree IO -- ^ working tree -> String -- ^ external merge tool command -> WantGuiPause -- ^ tell whether we want GUI pause -> FL (PrimOf p) wX wY -- ^ our effect -> FL (PrimOf p) wX wZ -- ^ their effect -> FL p wY wA -- ^ them merged (standard_resolution) -> IO (Sealed (FL (PrimOf p) wA)) externalResolution diffa s1 c wantGuiPause p1 p2 pmerged = do sa <- applyToTree (invert p1) s1 sm <- applyToTree pmerged s1 s2 <- applyToTree p2 sa let nms = listConflictedFiles pmerged nas = effectOnPaths (invert (effect pmerged)) nms n1s = effectOnPaths p1 nas n2s = effectOnPaths p2 nas ns = zip4 (tofp nas) (tofp n1s) (tofp n2s) (tofp nms) tofp = map (anchorPath "") write_files tree fs = writePlainTree (Tree.filter (filterPaths fs) tree) "." in do former_dir <- getCurrentDirectory withTempDir "version1" $ \absd1 -> do let d1 = toFilePath absd1 write_files s1 n1s setCurrentDirectory former_dir withTempDir "ancestor" $ \absda -> do let da = toFilePath absda write_files sa nas setCurrentDirectory former_dir withTempDir "merged" $ \absdm -> do let dm = toFilePath absdm write_files sm nms setCurrentDirectory former_dir withTempDir "cleanmerged" $ \absdc -> do let dc = toFilePath absdc cloneTree dm "." setCurrentDirectory former_dir withTempDir "version2" $ \absd2 -> do let d2 = toFilePath absd2 write_files s2 n2s mapM_ (externallyResolveFile c wantGuiPause da d1 d2 dm) ns sc <- readPlainTree dc sfixed <- readPlainTree dm ftf <- filetypeFunction unFreeLeft `fmap` treeDiff diffa ftf sc sfixed externallyResolveFile :: String -- ^ external merge tool command -> WantGuiPause -- ^ tell whether we want GUI pause -> String -- ^ path to merge base -> String -- ^ path to side 1 of the merge -> String -- ^ path to side 2 of the merge -> String -- ^ path where resolved content should go -> (FilePath, FilePath, FilePath, FilePath) -> IO () externallyResolveFile c wantGuiPause da d1 d2 dm (fa, f1, f2, fm) = do putStrLn $ "Merging file "++fm++" by hand." ec <- run c [('1', d1f1), ('2', d2f2), ('a', dafa), ('o', dmfm), ('%', "%")] when (ec /= ExitSuccess) $ putStrLn $ "External merge command exited with " ++ show ec when (wantGuiPause == YesWantGuiPause) $ askEnter "Hit return to move on, ^C to abort the whole operation..." run :: String -> [(Char,String)] -> IO ExitCode run c replacements = case parseCmd replacements c of Left err -> fail $ show err Right (c2,_) -> rr c2 where rr (command:args) = do putStrLn $ "Running command '" ++ unwords (command:args) ++ "'" exec command args (Null,Null,Null) rr [] = return ExitSuccess patchsetConflictResolutions :: RepoPatch p => PatchSet rt p Origin wX -> StandardResolution (PrimOf p) wX patchsetConflictResolutions (PatchSet ts xs) = -- optimization: all patches before the latest known clean tag -- are known to be resolved standardResolution (patchSet2RL (PatchSet ts NilRL)) xs