--  Copyright (C) 2002-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.

{-# LANGUAGE OverloadedStrings #-}

module Darcs.UI.Commands.MarkConflicts ( markconflicts ) where

import Darcs.Prelude

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

import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.Util.Path ( AbsolutePath, AnchoredPath, anchorPath )
import Darcs.Util.Printer
    ( Doc, formatWords, pathlist, text, debugDocLn
    , vcat, vsep, (<+>), ($$) )

import Darcs.UI.Commands
    ( DarcsCommand(..)
    , withStdOpts
    , nodefaults
    , amInHashedRepository
    , putInfo
    , putFinished
    )
import Darcs.UI.Commands.Util ( filterExistingPaths )
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.UI.Flags
    ( DarcsFlag, diffingOpts, verbosity, dryRun, umask
    , useCache, pathSetFromArgs )
import Darcs.UI.Options ( (^), (?) )
import qualified Darcs.UI.Options.All as O

import Darcs.Repository
    ( withRepoLock
    , RepoJob(..)
    , addToPending
    , finalizeRepositoryChanges
    , applyToWorking
    , readPatches
    , unrecordedChanges )

import Darcs.Patch ( invert, listTouchedFiles, effectOnPaths )
import Darcs.Patch.Show
import Darcs.Patch.TouchesFiles ( chooseTouching )
import Darcs.Patch.Witnesses.Ordered ( mapFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )
import Darcs.Repository.Resolution
    ( StandardResolution(..)
    , patchsetConflictResolutions
    , warnUnmangled
    )
import Darcs.Patch.Named ( anonymous )
import Darcs.Patch.PatchInfoAnd ( n2pia )
import Darcs.Patch.Set ( patchSetSnoc )

-- * The mark-conflicts command

markconflictsDescription :: String
markconflictsDescription :: String
markconflictsDescription =
 String
"Mark unresolved conflicts in working tree, for manual resolution."

markconflictsHelp :: Doc
markconflictsHelp :: Doc
markconflictsHelp = [Doc] -> Doc
vsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
  [ [String] -> Doc
formatWords
    [ String
"Darcs requires human guidance to reconcile independent changes to the same"
    , String
"part of a file.  When a conflict first occurs, darcs will add the"
    , String
"initial state and all conflicting choices to the working tree, delimited"
    , String
" by the markers `v v v`, `=====`,  `* * *` and `^ ^ ^`, as follows:"
    ]
  , [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
    [ String
"    v v v v v v v"
    , String
"    initial state"
    , String
"    ============="
    , String
"    first choice"
    , String
"    *************"
    , String
"    ...more choices..."
    , String
"    *************"
    , String
"    last choice"
    , String
"    ^ ^ ^ ^ ^ ^ ^"
    ]
  ] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ ([String] -> Doc) -> [[String]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> Doc
formatWords
  [ [ String
"If you happened to revert or manually delete this conflict markup without"
    , String
"actually resolving the conflict, `darcs mark-conflicts` can be used to"
    , String
"re-create it; and similarly if you have used `darcs apply` or `darcs pull`"
    , String
"with `--allow-conflicts`, where conflicts aren't marked initially."
    ]
  , [ String
"In Darcs, a conflict counts as resolved when all of the changes"
    , String
"involved in the conflict (which can be more than two) are depended on by"
    , String
"one or more later patches. If you record a resolution for a particular"
    , String
"conflict, `darcs mark-conflicts` will no longer mark it, indicating that"
    , String
"it is resolved. If you have unrecorded changes, these count as (potential)"
    , String
"conflict resolutions, too, just as if you had already recorded them."
    ]
  , [ String
"This principle extends to explicit \"semantic\" dependencies. For instance,"
    , String
"recording a tag will automatically mark all conflicts as resolved."
    ]
  , [ String
"In the above schematic example the \"initial state\" corresponds to the"
    , String
"recorded state of the file in your repository. That is to say, the"
    , String
"recorded effect of a conflict is to apply none of the conflicting changes."
    , String
"This is usually not a state you would regard as a successful resolution"
    , String
"of the conflict; but there are exceptional situations where this may be"
    , String
"exactly what you want. In order to tell Darcs that you want this conflict"
    , String
"to be regarded as resolved, use `darcs record --ask-deps` to record a"
    , String
"patch that explicitly depends on all patches involved in the conflict."
    ]
 ]

markconflicts :: DarcsCommand
markconflicts :: DarcsCommand
markconflicts = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"mark-conflicts"
    , commandHelp :: Doc
commandHelp = Doc
markconflictsHelp
    , commandDescription :: String
commandDescription = String
markconflictsDescription
    , commandExtraArgs :: Int
commandExtraArgs = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"[FILE or DIRECTORY]..."]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
markconflictsCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
knownFileArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
markconflictsOpts
    }
  where
    markconflictsBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
markconflictsBasicOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (DiffAlgorithm -> DryRun -> XmlOutput -> a)
  (Maybe String)
PrimDarcsOption (Maybe String)
O.repoDir
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (DiffAlgorithm -> DryRun -> XmlOutput -> a)
  (Maybe String)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DryRun -> XmlOutput -> a)
     (DiffAlgorithm -> DryRun -> XmlOutput -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DryRun -> XmlOutput -> a)
     (Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (DryRun -> XmlOutput -> a)
  (DiffAlgorithm -> DryRun -> XmlOutput -> a)
PrimDarcsOption DiffAlgorithm
O.diffAlgorithm
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (DryRun -> XmlOutput -> a)
  (Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (DryRun -> XmlOutput -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (DryRun -> XmlOutput -> a)
forall a. DarcsOption a (DryRun -> XmlOutput -> a)
O.dryRunXml
    markconflictsAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
markconflictsAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
O.umask
    markconflictsOpts :: CommandOptions
markconflictsOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
markconflictsBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> XmlOutput
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UMask
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
PrimDarcsOption UMask
markconflictsAdvancedOpts

markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
markconflictsCmd (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
opts [String]
args = do
  Only [AnchoredPath]
paths <- Maybe [AnchoredPath] -> Only [AnchoredPath]
forall a. Maybe a -> Only a
maybeToOnly (Maybe [AnchoredPath] -> Only [AnchoredPath])
-> IO (Maybe [AnchoredPath]) -> IO (Only [AnchoredPath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AbsolutePath, AbsolutePath)
-> [String] -> IO (Maybe [AnchoredPath])
pathSetFromArgs (AbsolutePath, AbsolutePath)
fps [String]
args
  Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"::: paths =" Doc -> Doc -> Doc
<+>  (String -> Doc
text (String -> Doc)
-> (Only [AnchoredPath] -> String) -> Only [AnchoredPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [AnchoredPath] -> String
forall a. Show a => a -> String
show) Only [AnchoredPath]
paths
  UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
_repository -> do

{-
    What we do here:
    * read the unrecorded changes (all of them)
    * extract functions representing path rename effects from unrecorded
    * convert argument paths to pre-pending
    * read conflict resolutions that touch pre-pending argument paths
    * affected paths = intersection of paths touched by resolutions
                       and pre-pending argument paths
    * apply the conflict resolutions for affected paths
-}

    Only ([AnchoredPath], [AnchoredPath])
classified_paths <-
      ([AnchoredPath] -> IO ([AnchoredPath], [AnchoredPath]))
-> Only [AnchoredPath]
-> IO (Only ([AnchoredPath], [AnchoredPath]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Only a -> f (Only b)
traverse
        (Repository 'RW p wU wR
-> Verbosity
-> DiffOpts
-> [AnchoredPath]
-> IO ([AnchoredPath], [AnchoredPath])
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> Verbosity
-> DiffOpts
-> [AnchoredPath]
-> IO ([AnchoredPath], [AnchoredPath])
filterExistingPaths Repository 'RW p wU wR
_repository (PrimOptSpec DarcsOptDescr DarcsFlag a Verbosity
PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) ([DarcsFlag] -> DiffOpts
diffingOpts [DarcsFlag]
opts))
        Only [AnchoredPath]
paths

    FL (PrimOf p) wR wU
unrecorded <-
      DiffOpts
-> Repository 'RW p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
unrecordedChanges ([DarcsFlag] -> DiffOpts
diffingOpts [DarcsFlag]
opts) Repository 'RW p wU wR
_repository (Only [AnchoredPath] -> Maybe [AnchoredPath]
forall a. Only a -> Maybe a
fromOnly Only [AnchoredPath]
forall a. Only a
Everything)
    PatchInfoAndG (Named p) wR wU
anonpw <- Named p wR wU -> PatchInfoAndG (Named p) wR wU
forall (p :: * -> * -> *) wX wY.
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG p wX wY
n2pia (Named p wR wU -> PatchInfoAndG (Named p) wR wU)
-> IO (Named p wR wU) -> IO (PatchInfoAndG (Named p) wR wU)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FL (PrimOf p) wR wU -> IO (Named p wR wU)
forall (p :: * -> * -> *) wX wY.
FromPrim p =>
FL (PrimOf p) wX wY -> IO (Named p wX wY)
anonymous FL (PrimOf p) wR wU
unrecorded

    let forward_renames :: [AnchoredPath] -> [AnchoredPath]
forward_renames = FL (PrimOf p) wR wU -> [AnchoredPath] -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> [AnchoredPath] -> [AnchoredPath]
effectOnPaths FL (PrimOf p) wR wU
unrecorded
        backward_renames :: [AnchoredPath] -> [AnchoredPath]
backward_renames = FL (PrimOf p) wU wR -> [AnchoredPath] -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> [AnchoredPath] -> [AnchoredPath]
effectOnPaths (FL (PrimOf p) wR wU -> FL (PrimOf p) wU wR
forall wX wY. FL (PrimOf p) wX wY -> FL (PrimOf p) wY wX
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL (PrimOf p) wR wU
unrecorded)
        existing_paths :: Only [AnchoredPath]
existing_paths = (([AnchoredPath], [AnchoredPath]) -> [AnchoredPath])
-> Only ([AnchoredPath], [AnchoredPath]) -> Only [AnchoredPath]
forall a b. (a -> b) -> Only a -> Only b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([AnchoredPath], [AnchoredPath]) -> [AnchoredPath]
forall a b. (a, b) -> b
snd Only ([AnchoredPath], [AnchoredPath])
classified_paths
        pre_pending_paths :: Only [AnchoredPath]
pre_pending_paths = ([AnchoredPath] -> [AnchoredPath])
-> Only [AnchoredPath] -> Only [AnchoredPath]
forall a b. (a -> b) -> Only a -> Only b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [AnchoredPath] -> [AnchoredPath]
backward_renames Only [AnchoredPath]
existing_paths
    Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"::: pre_pending_paths =" Doc -> Doc -> Doc
<+> (String -> Doc
text (String -> Doc)
-> (Only [AnchoredPath] -> String) -> Only [AnchoredPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [AnchoredPath] -> String
forall a. Show a => a -> String
show) Only [AnchoredPath]
pre_pending_paths

    PatchSet p Origin wR
r <- Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RW p wU wR
_repository
    -- by including anonpw in the patch set, we regard unrecorded changes
    -- as potential conflict resolutions "under construction"
    Sealed FL (PrimOf p) wU wX
res <- case PatchSet p Origin wU -> StandardResolution (PrimOf p) wU
forall (p :: * -> * -> *) wX.
RepoPatch p =>
PatchSet p Origin wX -> StandardResolution (PrimOf p) wX
patchsetConflictResolutions (PatchSet p Origin wU -> StandardResolution (PrimOf p) wU)
-> PatchSet p Origin wU -> StandardResolution (PrimOf p) wU
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR
-> PatchInfoAndG (Named p) wR wU -> PatchSet p Origin wU
forall (p :: * -> * -> *) wX wY wZ.
PatchSet p wX wY -> PatchInfoAnd p wY wZ -> PatchSet p wX wZ
patchSetSnoc PatchSet p Origin wR
r PatchInfoAndG (Named p) wR wU
anonpw of
      StandardResolution (PrimOf p) wU
conflicts -> do
        Maybe [AnchoredPath] -> StandardResolution (PrimOf p) wU -> IO ()
forall (prim :: * -> * -> *) wX.
PrimPatch prim =>
Maybe [AnchoredPath] -> StandardResolution prim wX -> IO ()
warnUnmangled (Only [AnchoredPath] -> Maybe [AnchoredPath]
forall a. Only a -> Maybe a
fromOnly Only [AnchoredPath]
pre_pending_paths) StandardResolution (PrimOf p) wU
conflicts
        Sealed FL (PrimOf p) wU wX
mangled_res <- Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU)))
-> Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU))
forall a b. (a -> b) -> a -> b
$ StandardResolution (PrimOf p) wU -> Sealed (FL (PrimOf p) wU)
forall (prim :: * -> * -> *) wX.
StandardResolution prim wX -> Mangled prim wX
mangled StandardResolution (PrimOf p) wU
conflicts
        let raw_res_paths :: Only [AnchoredPath]
raw_res_paths = [AnchoredPath] -> Only [AnchoredPath]
forall a. Ord a => [a] -> PathSet a
pathSet ([AnchoredPath] -> Only [AnchoredPath])
-> [AnchoredPath] -> Only [AnchoredPath]
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wU wX -> [AnchoredPath]
forall wX wY. FL (PrimOf p) wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles FL (PrimOf p) wU wX
mangled_res
        Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"::: raw_res_paths =" Doc -> Doc -> Doc
<+>  (String -> Doc
text (String -> Doc)
-> (Only [AnchoredPath] -> String) -> Only [AnchoredPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [AnchoredPath] -> String
forall a. Show a => a -> String
show) Only [AnchoredPath]
raw_res_paths
        Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU)))
-> Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU))
forall a b. (a -> b) -> a -> b
$ Maybe [AnchoredPath]
-> FL (PrimOf p) wU wX -> Sealed (FL (PrimOf p) wU)
forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
Maybe [AnchoredPath] -> FL p wX wY -> Sealed (FL p wX)
chooseTouching (Only [AnchoredPath] -> Maybe [AnchoredPath]
forall a. Only a -> Maybe a
fromOnly Only [AnchoredPath]
pre_pending_paths) FL (PrimOf p) wU wX
mangled_res
    let res_paths :: Only [AnchoredPath]
res_paths = [AnchoredPath] -> Only [AnchoredPath]
forall a. Ord a => [a] -> PathSet a
pathSet ([AnchoredPath] -> Only [AnchoredPath])
-> [AnchoredPath] -> Only [AnchoredPath]
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wU wX -> [AnchoredPath]
forall wX wY. FL (PrimOf p) wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles FL (PrimOf p) wU wX
res
    Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"::: res_paths =" Doc -> Doc -> Doc
<+>  (String -> Doc
text (String -> Doc)
-> (Only [AnchoredPath] -> String) -> Only [AnchoredPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [AnchoredPath] -> String
forall a. Show a => a -> String
show) Only [AnchoredPath]
res_paths

    let affected_paths :: Only [AnchoredPath]
affected_paths = Only [AnchoredPath]
res_paths Only [AnchoredPath] -> Only [AnchoredPath] -> Only [AnchoredPath]
forall a. Ord a => PathSet a -> PathSet a -> PathSet a
`isectPathSet` Only [AnchoredPath]
pre_pending_paths
    Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"::: affected_paths =" Doc -> Doc -> Doc
<+>  (String -> Doc
text (String -> Doc)
-> (Only [AnchoredPath] -> String) -> Only [AnchoredPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [AnchoredPath] -> String
forall a. Show a => a -> String
show) Only [AnchoredPath]
affected_paths

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Only [AnchoredPath]
affected_paths Only [AnchoredPath] -> Only [AnchoredPath] -> Bool
forall a. Eq a => a -> a -> Bool
== [AnchoredPath] -> Only [AnchoredPath]
forall a. a -> Only a
Only []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"No conflicts to mark."
      IO ()
forall a. IO a
exitSuccess

    let post_pending_affected_paths :: Only [AnchoredPath]
post_pending_affected_paths = [AnchoredPath] -> [AnchoredPath]
forward_renames ([AnchoredPath] -> [AnchoredPath])
-> Only [AnchoredPath] -> Only [AnchoredPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Only [AnchoredPath]
affected_paths
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"Marking conflicts in:" Doc -> Doc -> Doc
<+> Only [AnchoredPath] -> Doc
showPathSet Only [AnchoredPath]
post_pending_affected_paths Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."

    Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"::: res = " Doc -> Doc -> Doc
$$ [Doc] -> Doc
vsep ((forall wW wZ. PrimOf p wW wZ -> Doc)
-> FL (PrimOf p) wU wX -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL PrimOf p wW wZ -> Doc
forall wW wZ. PrimOf p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimOf p) wU wX
res)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DryRun -> Bool
forall a. YesNo a => a -> Bool
O.yes (PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"Conflicts will not be marked: this is a dry run."
        IO ()
forall a. IO a
exitSuccess

    Repository 'RW p wU wR -> DiffOpts -> FL (PrimOf p) wU wX -> IO ()
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DiffOpts -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository 'RW p wU wR
_repository ([DarcsFlag] -> DiffOpts
diffingOpts [DarcsFlag]
opts) FL (PrimOf p) wU wX
res
    IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Repository 'RO p wU wR
_repository <- Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
finalizeRepositoryChanges Repository 'RW p wU wR
_repository (PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
PrimDarcsOption DryRun
O.dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DryRun -> Bool
forall a. YesNo a => a -> Bool
O.yes (PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
PrimDarcsOption DryRun
O.dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO (Repository 'RO p wX wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository 'RO p wX wR) -> IO ())
-> IO (Repository 'RO p wX wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository 'RO p wU wR
-> Verbosity -> FL (PrimOf p) wU wX -> IO (Repository 'RO p wX wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wU wR
-> Verbosity -> FL (PrimOf p) wU wY -> IO (Repository rt p wY wR)
applyToWorking Repository 'RO p wU wR
_repository (PrimOptSpec DarcsOptDescr DarcsFlag a Verbosity
PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PrimOf p) wU wX
res
    [DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts String
"marking conflicts"

-- * Generic 'PathSet' support

{- $SupportCode

What follows is generic support code for working with argument path lists
that are used to restrict operations to a subset of the working or pristine
tree. The rest of Darcs uses two types for this:

 * @'Maybe' ['SubPath']@

 * @'Maybe' ['FilePath']@

The problem with both is the contra-intuitive name 'Nothing', which here
stands for 'Everything'. To make the intended use clearer, we use the 'Only'
type instead (which is is isomorphic to 'Maybe') and the synonym 'PathSet'
defined below.

These abstractions should get their own module (or become integrated into
Darcs.Util.Path) if and when someone decides to reuse it elsewhere. The
functionality provided is intentionally minimal and light-weight.
-}

-- | 'Only' is isomorphic to 'Maybe' but with the opposite semantics.
--
-- About the name: I like the data constructor names, they are pretty
-- suggestive. The data type name is up for grabs; a possible alternative
-- is @AtMost@.
data Only a = Everything | Only a deriving (Only a -> Only a -> Bool
(Only a -> Only a -> Bool)
-> (Only a -> Only a -> Bool) -> Eq (Only a)
forall a. Eq a => Only a -> Only a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Only a -> Only a -> Bool
== :: Only a -> Only a -> Bool
$c/= :: forall a. Eq a => Only a -> Only a -> Bool
/= :: Only a -> Only a -> Bool
Eq, Eq (Only a)
Eq (Only a) =>
(Only a -> Only a -> Ordering)
-> (Only a -> Only a -> Bool)
-> (Only a -> Only a -> Bool)
-> (Only a -> Only a -> Bool)
-> (Only a -> Only a -> Bool)
-> (Only a -> Only a -> Only a)
-> (Only a -> Only a -> Only a)
-> Ord (Only a)
Only a -> Only a -> Bool
Only a -> Only a -> Ordering
Only a -> Only a -> Only a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Only a)
forall a. Ord a => Only a -> Only a -> Bool
forall a. Ord a => Only a -> Only a -> Ordering
forall a. Ord a => Only a -> Only a -> Only a
$ccompare :: forall a. Ord a => Only a -> Only a -> Ordering
compare :: Only a -> Only a -> Ordering
$c< :: forall a. Ord a => Only a -> Only a -> Bool
< :: Only a -> Only a -> Bool
$c<= :: forall a. Ord a => Only a -> Only a -> Bool
<= :: Only a -> Only a -> Bool
$c> :: forall a. Ord a => Only a -> Only a -> Bool
> :: Only a -> Only a -> Bool
$c>= :: forall a. Ord a => Only a -> Only a -> Bool
>= :: Only a -> Only a -> Bool
$cmax :: forall a. Ord a => Only a -> Only a -> Only a
max :: Only a -> Only a -> Only a
$cmin :: forall a. Ord a => Only a -> Only a -> Only a
min :: Only a -> Only a -> Only a
Ord, Int -> Only a -> ShowS
[Only a] -> ShowS
Only a -> String
(Int -> Only a -> ShowS)
-> (Only a -> String) -> ([Only a] -> ShowS) -> Show (Only a)
forall a. Show a => Int -> Only a -> ShowS
forall a. Show a => [Only a] -> ShowS
forall a. Show a => Only a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Only a -> ShowS
showsPrec :: Int -> Only a -> ShowS
$cshow :: forall a. Show a => Only a -> String
show :: Only a -> String
$cshowList :: forall a. Show a => [Only a] -> ShowS
showList :: [Only a] -> ShowS
Show)

instance Functor Only where
  fmap :: forall a b. (a -> b) -> Only a -> Only b
fmap a -> b
_ Only a
Everything = Only b
forall a. Only a
Everything
  fmap a -> b
f (Only a
x) = b -> Only b
forall a. a -> Only a
Only (a -> b
f a
x)

instance Foldable Only where
  foldMap :: forall m a. Monoid m => (a -> m) -> Only a -> m
foldMap a -> m
_ Only a
Everything = m
forall a. Monoid a => a
mempty
  foldMap a -> m
f (Only a
x) = a -> m
f a
x

instance Traversable Only where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Only a -> f (Only b)
traverse a -> f b
_ Only a
Everything = Only b -> f (Only b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Only b
forall a. Only a
Everything
  traverse a -> f b
f (Only a
x) = b -> Only b
forall a. a -> Only a
Only (b -> Only b) -> f b -> f (Only b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x

-- | This is mostly for conversion to legacy APIs
fromOnly :: Only a -> Maybe a
fromOnly :: forall a. Only a -> Maybe a
fromOnly Only a
Everything = Maybe a
forall a. Maybe a
Nothing
fromOnly (Only a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x

maybeToOnly :: Maybe a -> Only a
maybeToOnly :: forall a. Maybe a -> Only a
maybeToOnly Maybe a
Nothing = Only a
forall a. Only a
Everything
maybeToOnly (Just a
x) = a -> Only a
forall a. a -> Only a
Only a
x

{- | A set of repository paths. 'Everything' means every path in the repo,
it usually originates from an empty list of path arguments. The list of
'AnchoredPath's is always kept in sorted order with no duplicates.

It uses lists because the number of elements is expected to be small.
-}
type PathSet a = Only [a]

-- | Intersection of two 'PathSet's
isectPathSet :: Ord a => PathSet a -> PathSet a -> PathSet a
isectPathSet :: forall a. Ord a => PathSet a -> PathSet a -> PathSet a
isectPathSet Only [a]
Everything Only [a]
ys = Only [a]
ys
isectPathSet Only [a]
xs Only [a]
Everything = Only [a]
xs
isectPathSet (Only [a]
xs) (Only [a]
ys) = [a] -> Only [a]
forall a. a -> Only a
Only ([a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
isect [a]
xs [a]
ys)

{-
-- | Union of two 'PathSet's
union :: PathSet -> PathSet -> PathSet
union Everything ys = Everything
union xs Everything = Everything
union (Only xs) (Only ys) = Only (union xs ys)
-}

pathSet :: Ord a => [a] -> PathSet a
pathSet :: forall a. Ord a => [a] -> PathSet a
pathSet = [a] -> Only [a]
forall a. a -> Only a
Only ([a] -> Only [a]) -> ([a] -> [a]) -> [a] -> Only [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. Ord a => [a] -> [a]
nubSort

-- | Convert a 'PathSet' to a 'Doc'. Uses the English module
-- to generate a nicely readable list of file names.
showPathSet :: PathSet AnchoredPath -> Doc
showPathSet :: Only [AnchoredPath] -> Doc
showPathSet Only [AnchoredPath]
Everything = String -> Doc
text String
"all paths"
showPathSet (Only [AnchoredPath]
xs) = [String] -> Doc
pathlist ((AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnchoredPath -> String
anchorPath String
"") [AnchoredPath]
xs)