--  Copyright (C) 2002-2004 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.Util
    ( announceFiles
    , filterExistingPaths
    , testTentativeAndMaybeExit
    , printDryRunMessageAndExit
    , getUniqueRepositoryName
    , getUniqueDPatchName
    , doesDirectoryReallyExist
    , checkUnrelatedRepos
    , preselectPatches
    , getLastPatches
    , matchRange
    , historyEditHelp
    , commonHelpWithPrefsTemplates
    ) where

import Control.Monad ( when, unless )

import Darcs.Prelude

import Control.Exception ( catch )
import Data.Char ( isAlpha, toLower, isDigit, isSpace )
import Data.Maybe ( fromMaybe )

import System.Exit ( ExitCode(..), exitWith, exitSuccess )
import System.Posix.Files ( isDirectory )

import Darcs.Patch ( RepoPatch, xmlSummary )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Depends
    ( areUnrelatedRepos
    , findCommonWithThem
    , patchSetUnion
    )
import Darcs.Patch.Info ( toXml )
import Darcs.Patch.Match
    ( MatchFlag
    , MatchableRP
    , firstMatch
    , matchFirstPatchset
    , matchSecondPatchset
    , matchingHead
    )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefullyM )
import Darcs.Patch.Set ( PatchSet, SealedPatchSet, Origin, emptyPatchSet )
import Darcs.Patch.Witnesses.Ordered ( FL, (:>)(..), mapFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Sealed2(..) )

import Darcs.Repository
    ( ReadingOrWriting(..)
    , Repository
    , identifyRepositoryFor
    , readPristine
    , readPatches
    )
import Darcs.Repository.Prefs ( getDefaultRepo, globalPrefsDirDoc )
import Darcs.Repository.State ( readUnrecordedFiltered )

import Darcs.UI.Commands ( putInfo )
import Darcs.UI.Flags ( DarcsFlag, isInteractive )
import Darcs.UI.PrintPatch ( showFriendly )
import Darcs.UI.Options ( (?) )
import Darcs.UI.Options.All
    ( Verbosity(..)
    , DiffOpts(..)
    , WithSummary(..), DryRun(..), XmlOutput(..)
    )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.TestChanges ( testTree )

import Darcs.Util.English ( anyOfClause, itemizeVertical )
import Darcs.Util.Exception ( clarifyErrors )
import Darcs.Util.File ( getFileStatus )
import Darcs.Util.Path ( AnchoredPath, displayPath, getUniquePathName )
import Darcs.Util.Printer
    ( Doc, formatWords, ($+$), text, (<+>), hsep, ($$), vcat, vsep
    , putDocLn, insertBeforeLastline, prefix
    , putDocLnWith, pathlist
    )
import Darcs.Util.Printer.Color ( fancyPrinters )
import Darcs.Util.Prompt ( PromptConfig(..), promptChar, promptYorn )
import Darcs.Util.Tree.Monad ( virtualTreeIO, exists )
import Darcs.Util.Tree ( Tree )


announceFiles :: Verbosity -> Maybe [AnchoredPath] -> String -> IO ()
announceFiles :: Verbosity -> Maybe [AnchoredPath] -> [Char] -> IO ()
announceFiles Verbosity
Quiet Maybe [AnchoredPath]
_ [Char]
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
announceFiles Verbosity
_ (Just [AnchoredPath]
paths) [Char]
message = Doc -> IO ()
putDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> Doc
text [Char]
message Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text [Char]
":" Doc -> Doc -> Doc
<+> [[Char]] -> Doc
pathlist ((AnchoredPath -> [Char]) -> [AnchoredPath] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map AnchoredPath -> [Char]
displayPath [AnchoredPath]
paths)
announceFiles Verbosity
_ Maybe [AnchoredPath]
_ [Char]
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

testTentativeAndMaybeExit :: Tree IO
                          -> [DarcsFlag]
                          -> String
                          -> String
                          -> Maybe String
                          -> IO ()
testTentativeAndMaybeExit :: Tree IO -> [DarcsFlag] -> [Char] -> [Char] -> Maybe [Char] -> IO ()
testTentativeAndMaybeExit Tree IO
tree [DarcsFlag]
opts [Char]
failMessage [Char]
confirmMsg Maybe [Char]
withClarification = do
  ExitCode
testResult <- [DarcsFlag] -> Tree IO -> IO ExitCode
testTree [DarcsFlag]
opts Tree IO
tree
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
testResult ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let doExit :: IO a
doExit =
          (IO a -> IO a)
-> ([Char] -> IO a -> IO a) -> Maybe [Char] -> IO a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO a -> IO a
forall a. a -> a
id ((IO a -> [Char] -> IO a) -> [Char] -> IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO a -> [Char] -> IO a
forall a. IO a -> [Char] -> IO a
clarifyErrors) Maybe [Char]
withClarification (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith ExitCode
testResult
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
opts) IO ()
forall {a}. IO a
doExit
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Looks like " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
failMessage
    let prompt :: [Char]
prompt = [Char]
"Shall I " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
confirmMsg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" anyway?"
    Char
yn <- PromptConfig -> IO Char
promptChar ([Char] -> [Char] -> [Char] -> Maybe Char -> [Char] -> PromptConfig
PromptConfig [Char]
prompt [Char]
"yn" [] (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'n') [])
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Char
yn Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'y') IO ()
forall {a}. IO a
doExit

-- | @'printDryRunMessageAndExit' action flags patches@ prints a string
-- representing the action that would be taken if the @--dry-run@ option had
-- not been passed to darcs. Then darcs exits successfully.  @action@ is the
-- name of the action being taken, like @\"push\"@ @flags@ is the list of flags
-- which were sent to darcs @patches@ is the sequence of patches which would be
-- touched by @action@.
printDryRunMessageAndExit :: RepoPatch p
                          => String
                          -> Verbosity -> WithSummary -> DryRun -> XmlOutput
                          -> Bool -- interactive
                          -> FL (PatchInfoAnd p) wX wY
                          -> IO ()
printDryRunMessageAndExit :: forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
[Char]
-> Verbosity
-> WithSummary
-> DryRun
-> XmlOutput
-> Bool
-> FL (PatchInfoAnd p) wX wY
-> IO ()
printDryRunMessageAndExit [Char]
action Verbosity
v WithSummary
s DryRun
d XmlOutput
x Bool
interactive FL (PatchInfoAnd p) wX wY
patches = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DryRun
d DryRun -> DryRun -> Bool
forall a. Eq a => a -> a -> Bool
== DryRun
YesDryRun) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Doc -> IO ()
putInfoX (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep [ Doc
"Would", [Char] -> Doc
text [Char]
action, Doc
"the following patches:" ]
        Printers -> Doc -> IO ()
putDocLnWith Printers
fancyPrinters Doc
put_mode
        Doc -> IO ()
putInfoX (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
""
        Doc -> IO ()
putInfoX (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Making no changes: this is a dry run."
        IO ()
forall {a}. IO a
exitSuccess
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
interactive Bool -> Bool -> Bool
&& WithSummary
s WithSummary -> WithSummary -> Bool
forall a. Eq a => a -> a -> Bool
== WithSummary
YesSummary) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Doc -> IO ()
putInfoX (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep [ Doc
"Will", [Char] -> Doc
text [Char]
action, Doc
"the following patches:" ]
        Doc -> IO ()
putDocLn Doc
put_mode
  where
    put_mode :: Doc
put_mode = if XmlOutput
x XmlOutput -> XmlOutput -> Bool
forall a. Eq a => a -> a -> Bool
== XmlOutput
YesXml
                   then [Char] -> Doc
text [Char]
"<patches>" Doc -> Doc -> Doc
$$
                        [Doc] -> Doc
vcat ((forall wW wZ. PatchInfoAnd p wW wZ -> Doc)
-> FL (PatchInfoAnd p) wX wY -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (Doc -> Doc
indent (Doc -> Doc)
-> (PatchInfoAnd p wW wZ -> Doc) -> PatchInfoAnd p wW wZ -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithSummary -> PatchInfoAnd p wW wZ -> Doc
forall {p :: * -> * -> *} {wA} {wB}.
(Summary p, PrimDetails (PrimOf p)) =>
WithSummary -> PatchInfoAndG p wA wB -> Doc
xml_info WithSummary
s) FL (PatchInfoAnd p) wX wY
patches) Doc -> Doc -> Doc
$$
                        [Char] -> Doc
text [Char]
"</patches>"
                   else [Doc] -> Doc
vsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (forall wW wZ. PatchInfoAnd p wW wZ -> Doc)
-> FL (PatchInfoAnd p) wX wY -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (Verbosity -> WithSummary -> PatchInfoAnd p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatch p =>
Verbosity -> WithSummary -> p wX wY -> Doc
showFriendly Verbosity
v WithSummary
s) FL (PatchInfoAnd p) wX wY
patches

    putInfoX :: Doc -> IO ()
putInfoX = if XmlOutput
x XmlOutput -> XmlOutput -> Bool
forall a. Eq a => a -> a -> Bool
== XmlOutput
YesXml then IO () -> Doc -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) else Doc -> IO ()
putDocLn

    xml_info :: WithSummary -> PatchInfoAndG p wA wB -> Doc
xml_info WithSummary
YesSummary = PatchInfoAndG p wA wB -> Doc
forall {p :: * -> * -> *} {wA} {wB}.
(Summary p, PrimDetails (PrimOf p)) =>
PatchInfoAndG p wA wB -> Doc
xml_with_summary
    xml_info WithSummary
NoSummary  = PatchInfo -> Doc
toXml (PatchInfo -> Doc)
-> (PatchInfoAndG p wA wB -> PatchInfo)
-> PatchInfoAndG p wA wB
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAndG p wA wB -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info

    xml_with_summary :: PatchInfoAndG p wA wB -> Doc
xml_with_summary PatchInfoAndG p wA wB
hp
        | Just p wA wB
p <- PatchInfoAndG p wA wB -> Maybe (p wA wB)
forall (p :: * -> * -> *) wA wB.
PatchInfoAndG p wA wB -> Maybe (p wA wB)
hopefullyM PatchInfoAndG p wA wB
hp = Doc -> Doc -> Doc
insertBeforeLastline (PatchInfo -> Doc
toXml (PatchInfo -> Doc) -> PatchInfo -> Doc
forall a b. (a -> b) -> a -> b
$ PatchInfoAndG p wA wB -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAndG p wA wB
hp)
                                        (Doc -> Doc
indent (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ p wA wB -> Doc
forall (p :: * -> * -> *) wX wY.
(Summary p, PrimDetails (PrimOf p)) =>
p wX wY -> Doc
xmlSummary p wA wB
p)
    xml_with_summary PatchInfoAndG p wA wB
hp = PatchInfo -> Doc
toXml (PatchInfoAndG p wA wB -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAndG p wA wB
hp)

    indent :: Doc -> Doc
indent = [Char] -> Doc -> Doc
prefix [Char]
"    "

-- | Given a repository and two common command options, classify the given list
-- of paths according to whether they exist in the pristine or working tree.
-- Paths which are neither in working nor pristine are reported and dropped.
-- The result is a pair of path lists: those that exist only in the working tree,
-- and those that exist in pristine or working.
filterExistingPaths :: (RepoPatch p, ApplyState p ~ Tree)
                    => Repository rt p wU wR
                    -> Verbosity
                    -> DiffOpts
                    -> [AnchoredPath]
                    -> IO ([AnchoredPath],[AnchoredPath])
filterExistingPaths :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> Verbosity
-> DiffOpts
-> [AnchoredPath]
-> IO ([AnchoredPath], [AnchoredPath])
filterExistingPaths Repository rt p wU wR
repo Verbosity
verb DiffOpts{DiffAlgorithm
UseIndex
LookForMoves
LookForReplaces
LookForAdds
withIndex :: UseIndex
lookForAdds :: LookForAdds
lookForReplaces :: LookForReplaces
lookForMoves :: LookForMoves
diffAlg :: DiffAlgorithm
withIndex :: DiffOpts -> UseIndex
lookForAdds :: DiffOpts -> LookForAdds
lookForReplaces :: DiffOpts -> LookForReplaces
lookForMoves :: DiffOpts -> LookForMoves
diffAlg :: DiffOpts -> DiffAlgorithm
..} [AnchoredPath]
paths = do
      Tree IO
pristine <- Repository rt p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository rt p wU wR
repo
      Tree IO
working <-
        Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
readUnrecordedFiltered Repository rt p wU wR
repo UseIndex
withIndex LookForAdds
lookForAdds LookForMoves
lookForMoves ([AnchoredPath] -> Maybe [AnchoredPath]
forall a. a -> Maybe a
Just [AnchoredPath]
paths)
      let check :: Tree IO -> IO ([Bool], Tree IO)
check = TreeIO [Bool] -> Tree IO -> IO ([Bool], Tree IO)
forall a. TreeIO a -> Tree IO -> IO (a, Tree IO)
virtualTreeIO (TreeIO [Bool] -> Tree IO -> IO ([Bool], Tree IO))
-> TreeIO [Bool] -> Tree IO -> IO ([Bool], Tree IO)
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> RWST (DumpItem IO) () (TreeState IO) IO Bool)
-> [AnchoredPath] -> TreeIO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM AnchoredPath -> RWST (DumpItem IO) () (TreeState IO) IO Bool
forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> TreeMonad m Bool
exists [AnchoredPath]
paths
      ([Bool]
in_pristine, Tree IO
_) <- Tree IO -> IO ([Bool], Tree IO)
check Tree IO
pristine
      ([Bool]
in_working, Tree IO
_) <- Tree IO -> IO ([Bool], Tree IO)
check Tree IO
working
      let paths_with_info :: [(AnchoredPath, Bool, Bool)]
paths_with_info       = [AnchoredPath] -> [Bool] -> [Bool] -> [(AnchoredPath, Bool, Bool)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [AnchoredPath]
paths [Bool]
in_pristine [Bool]
in_working
          paths_in_neither :: [AnchoredPath]
paths_in_neither      = [ AnchoredPath
p | (AnchoredPath
p,Bool
False,Bool
False) <- [(AnchoredPath, Bool, Bool)]
paths_with_info ]
          paths_only_in_working :: [AnchoredPath]
paths_only_in_working = [ AnchoredPath
p | (AnchoredPath
p,Bool
False,Bool
True) <- [(AnchoredPath, Bool, Bool)]
paths_with_info ]
          paths_in_either :: [AnchoredPath]
paths_in_either       = [ AnchoredPath
p | (AnchoredPath
p,Bool
inp,Bool
inw) <- [(AnchoredPath, Bool, Bool)]
paths_with_info, Bool
inp Bool -> Bool -> Bool
|| Bool
inw ]
          or_not_added :: Doc
or_not_added =
            if LookForAdds
lookForAdds LookForAdds -> LookForAdds -> Bool
forall a. Eq a => a -> a -> Bool
== LookForAdds
O.NoLookForAdds
              then Doc
" or not added "
              else Doc
" "
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Quiet Bool -> Bool -> Bool
|| [AnchoredPath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
paths_in_neither) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
putDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
        Doc
"Ignoring non-existing" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
or_not_added Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"paths:" Doc -> Doc -> Doc
<+>
        [[Char]] -> Doc
pathlist ((AnchoredPath -> [Char]) -> [AnchoredPath] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map AnchoredPath -> [Char]
displayPath [AnchoredPath]
paths_in_neither)
      ([AnchoredPath], [AnchoredPath])
-> IO ([AnchoredPath], [AnchoredPath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([AnchoredPath]
paths_only_in_working, [AnchoredPath]
paths_in_either)

getUniqueRepositoryName :: Bool -> FilePath -> IO FilePath
getUniqueRepositoryName :: Bool -> [Char] -> IO [Char]
getUniqueRepositoryName Bool
talkative [Char]
name = Bool -> ([Char] -> [Char]) -> (Int -> [Char]) -> IO [Char]
getUniquePathName Bool
talkative [Char] -> [Char]
buildMsg Int -> [Char]
forall {a}. (Eq a, Num a, Show a) => a -> [Char]
buildName
  where
    buildName :: a -> [Char]
buildName a
i = if a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1 then [Char]
name else [Char]
name[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"_"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++a -> [Char]
forall a. Show a => a -> [Char]
show a
i
    buildMsg :: [Char] -> [Char]
buildMsg [Char]
n = [Char]
"Directory or file '"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                 [Char]
"' already exists, creating repository as '"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                 [Char]
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"'"

getUniqueDPatchName :: FilePath -> IO FilePath
getUniqueDPatchName :: [Char] -> IO [Char]
getUniqueDPatchName [Char]
name =
  IO [Char] -> (IOError -> IO [Char]) -> IO [Char]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
    (Bool -> ([Char] -> [Char]) -> (Int -> [Char]) -> IO [Char]
getUniquePathName Bool
False ([Char] -> [Char] -> [Char]
forall a b. a -> b -> a
const [Char]
"") Int -> [Char]
forall {a}. (Eq a, Num a, Show a) => a -> [Char]
buildName)
    (\(IOError
e :: IOError) ->
      [Char] -> IO [Char]
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"Error constructing filename corresponding to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ IOError -> [Char]
forall a. Show a => a -> [Char]
show IOError
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
             [Char]
"\nConsider using '-o' to specify an output filename."
    )
  where
    buildName :: a -> [Char]
buildName a
i =
      if a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1 then [Char] -> [Char]
patchFilename [Char]
name else [Char] -> [Char]
patchFilename ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
name[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"_"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++a -> [Char]
forall a. Show a => a -> [Char]
show a
i

-- |patchFilename maps a patch description string to a safe (lowercased, spaces
-- removed and only letters/digits) patch filename.
patchFilename :: String -> String
patchFilename :: [Char] -> [Char]
patchFilename [Char]
the_summary = [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".dpatch"
  where
    name :: [Char]
name = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
safeFileChar [Char]
the_summary
    safeFileChar :: Char -> Char
safeFileChar Char
c | Char -> Bool
isAlpha Char
c = Char -> Char
toLower Char
c
                   | Char -> Bool
isDigit Char
c = Char
c
                   | Char -> Bool
isSpace Char
c = Char
'-'
    safeFileChar Char
_ = Char
'_'

doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist :: [Char] -> IO Bool
doesDirectoryReallyExist [Char]
f = Bool -> (FileStatus -> Bool) -> Maybe FileStatus -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False FileStatus -> Bool
isDirectory (Maybe FileStatus -> Bool) -> IO (Maybe FileStatus) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [Char] -> IO (Maybe FileStatus)
getFileStatus [Char]
f

checkUnrelatedRepos :: RepoPatch p
                    => Bool
                    -> PatchSet p Origin wX
                    -> PatchSet p Origin wY
                    -> IO ()
checkUnrelatedRepos :: forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
Bool -> PatchSet p Origin wX -> PatchSet p Origin wY -> IO ()
checkUnrelatedRepos Bool
allowUnrelatedRepos PatchSet p Origin wX
us PatchSet p Origin wY
them =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ( Bool -> Bool
not Bool
allowUnrelatedRepos Bool -> Bool -> Bool
&& PatchSet p Origin wX -> PatchSet p Origin wY -> Bool
forall (p :: * -> * -> *) wX wY.
Commute p =>
PatchSet p Origin wX -> PatchSet p Origin wY -> Bool
areUnrelatedRepos PatchSet p Origin wX
us PatchSet p Origin wY
them ) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         do Bool
confirmed <- [Char] -> IO Bool
promptYorn [Char]
"Repositories seem to be unrelated. Proceed?"
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
confirmed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Cancelled." IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall {a}. IO a
exitSuccess

-- | Get the union of the set of patches in each specified location
remotePatches :: RepoPatch p
              => [DarcsFlag]
              -> Repository rt p wU wR -> [O.NotInRemote]
              -> IO (SealedPatchSet p Origin)
remotePatches :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
[DarcsFlag]
-> Repository rt p wU wR
-> [NotInRemote]
-> IO (SealedPatchSet p Origin)
remotePatches [DarcsFlag]
opts Repository rt p wU wR
repository [NotInRemote]
nirs = do
    [[Char]]
nirsPaths <- (NotInRemote -> IO [Char]) -> [NotInRemote] -> IO [[Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM NotInRemote -> IO [Char]
getNotInRemotePath [NotInRemote]
nirs
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
      Doc
"Determining patches not in" Doc -> Doc -> Doc
<+>
      [[Char]] -> Doc
anyOfClause [[Char]]
nirsPaths Doc -> Doc -> Doc
$$ Int -> [[Char]] -> Doc
itemizeVertical Int
2 [[Char]]
nirsPaths
    [SealedPatchSet p Origin] -> SealedPatchSet p Origin
forall (p :: * -> * -> *).
(Commute p, Merge p) =>
[SealedPatchSet p Origin] -> SealedPatchSet p Origin
patchSetUnion ([SealedPatchSet p Origin] -> SealedPatchSet p Origin)
-> IO [SealedPatchSet p Origin] -> IO (SealedPatchSet p Origin)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ([Char] -> IO (SealedPatchSet p Origin))
-> [[Char]] -> IO [SealedPatchSet p Origin]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> IO (SealedPatchSet p Origin)
readNir [[Char]]
nirsPaths
  where
    readNir :: [Char] -> IO (SealedPatchSet p Origin)
readNir [Char]
n = do
        Repository 'RO p Any Any
r <- ReadingOrWriting
-> Repository rt p wU wR
-> UseCache
-> [Char]
-> IO (Repository 'RO p Any Any)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR vR vU.
ReadingOrWriting
-> Repository rt p wU wR
-> UseCache
-> [Char]
-> IO (Repository 'RO p vR vU)
identifyRepositoryFor ReadingOrWriting
Reading Repository rt p wU wR
repository (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
O.useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) [Char]
n
        PatchSet p Origin Any
rps <- Repository 'RO p Any Any -> IO (PatchSet p Origin Any)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RO p Any Any
r
        SealedPatchSet p Origin -> IO (SealedPatchSet p Origin)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchSet p Origin Any -> SealedPatchSet p Origin
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed PatchSet p Origin Any
rps)

    getNotInRemotePath :: O.NotInRemote -> IO String
    getNotInRemotePath :: NotInRemote -> IO [Char]
getNotInRemotePath (O.NotInRemotePath [Char]
p) = [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
p
    getNotInRemotePath NotInRemote
O.NotInDefaultRepo = do
        Maybe [Char]
defaultRepo <- IO (Maybe [Char])
getDefaultRepo
        let err :: IO a
err = [Char] -> IO a
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char]
"No default push/pull repo configured, please pass a "
                         [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"repo name to --" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
O.notInRemoteFlagName
        IO [Char] -> ([Char] -> IO [Char]) -> Maybe [Char] -> IO [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO [Char]
forall {a}. IO a
err [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
defaultRepo

getLastPatches :: RepoPatch p
               => [O.MatchFlag] -> PatchSet p Origin wR
               -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wR
getLastPatches :: forall (p :: * -> * -> *) wR.
RepoPatch p =>
[MatchFlag]
-> PatchSet p Origin wR
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
getLastPatches [MatchFlag]
matchFlags PatchSet p Origin wR
ps =
  case [MatchFlag]
-> PatchSet p Origin wR -> Maybe (SealedPatchSet p Origin)
forall (p :: * -> * -> *) wStart wX.
MatchableRP p =>
[MatchFlag]
-> PatchSet p wStart wX -> Maybe (SealedPatchSet p wStart)
matchFirstPatchset [MatchFlag]
matchFlags PatchSet p Origin wR
ps of
    Just (Sealed PatchSet p Origin wX
p1s) -> PatchSet p Origin wR
-> PatchSet p Origin wX
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
forall (p :: * -> * -> *) wX wY.
Commute p =>
PatchSet p Origin wX
-> PatchSet p Origin wY
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wX
findCommonWithThem PatchSet p Origin wR
ps PatchSet p Origin wX
p1s
    Maybe (SealedPatchSet p Origin)
Nothing -> [Char] -> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
forall a. HasCallStack => [Char] -> a
error [Char]
"precondition: getLastPatches requires a firstMatch"

preselectPatches
  :: RepoPatch p
  => [DarcsFlag]
  -> Repository rt p wU wR
  -> IO ((PatchSet p :> FL (PatchInfoAnd p)) Origin wR)
preselectPatches :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
[DarcsFlag]
-> Repository rt p wU wR
-> IO ((:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR)
preselectPatches [DarcsFlag]
opts Repository rt p wU wR
repo = do
  PatchSet p Origin wR
allpatches <- Repository rt 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 rt p wU wR
repo
  let matchFlags :: [MatchFlag]
matchFlags = PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
MatchOption
O.matchSeveralOrLast MatchOption -> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
  case PrimOptSpec DarcsOptDescr DarcsFlag a [NotInRemote]
PrimDarcsOption [NotInRemote]
O.notInRemote PrimDarcsOption [NotInRemote] -> [DarcsFlag] -> [NotInRemote]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
    [] -> do
      (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
-> IO ((:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
 -> IO ((:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR))
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
-> IO ((:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR)
forall a b. (a -> b) -> a -> b
$
        if [MatchFlag] -> Bool
firstMatch [MatchFlag]
matchFlags
          then [MatchFlag]
-> PatchSet p Origin wR
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
forall (p :: * -> * -> *) wR.
RepoPatch p =>
[MatchFlag]
-> PatchSet p Origin wR
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
getLastPatches [MatchFlag]
matchFlags PatchSet p Origin wR
allpatches
          else [MatchFlag]
-> PatchSet p Origin wR
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
forall (p :: * -> * -> *) wR.
MatchableRP p =>
[MatchFlag]
-> PatchSet p Origin wR
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
matchingHead [MatchFlag]
matchFlags PatchSet p Origin wR
allpatches
    -- FIXME what about match options when we have --not-in-remote?
    -- It looks like they are simply ignored.
    [NotInRemote]
nirs -> do
      (Sealed PatchSet p Origin wX
thems) <-
        [DarcsFlag]
-> Repository rt p wU wR
-> [NotInRemote]
-> IO (Sealed (PatchSet p Origin))
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
[DarcsFlag]
-> Repository rt p wU wR
-> [NotInRemote]
-> IO (SealedPatchSet p Origin)
remotePatches [DarcsFlag]
opts Repository rt p wU wR
repo [NotInRemote]
nirs
      (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
-> IO ((:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
 -> IO ((:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR))
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
-> IO ((:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR)
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR
-> PatchSet p Origin wX
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wR
forall (p :: * -> * -> *) wX wY.
Commute p =>
PatchSet p Origin wX
-> PatchSet p Origin wY
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wX
findCommonWithThem PatchSet p Origin wR
allpatches PatchSet p Origin wX
thems

matchRange :: MatchableRP p
           => [MatchFlag]
           -> PatchSet p Origin wY
           -> Sealed2 (FL (PatchInfoAnd p))
matchRange :: forall (p :: * -> * -> *) wY.
MatchableRP p =>
[MatchFlag]
-> PatchSet p Origin wY -> Sealed2 (FL (PatchInfoAnd p))
matchRange [MatchFlag]
matchFlags PatchSet p Origin wY
ps =
  case (Sealed (PatchSet p Origin)
sp1s, Sealed (PatchSet p Origin)
sp2s) of
    (Sealed PatchSet p Origin wX
p1s, Sealed PatchSet p Origin wX
p2s) ->
      case PatchSet p Origin wX
-> PatchSet p Origin wX
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wX
forall (p :: * -> * -> *) wX wY.
Commute p =>
PatchSet p Origin wX
-> PatchSet p Origin wY
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) Origin wX
findCommonWithThem PatchSet p Origin wX
p2s PatchSet p Origin wX
p1s of
        PatchSet p Origin wZ
_ :> FL (PatchInfoAnd p) wZ wX
us -> FL (PatchInfoAnd p) wZ wX -> Sealed2 (FL (PatchInfoAnd p))
forall (a :: * -> * -> *) wX wY. a wX wY -> Sealed2 a
Sealed2 FL (PatchInfoAnd p) wZ wX
us
  where
    sp1s :: Sealed (PatchSet p Origin)
sp1s = Sealed (PatchSet p Origin)
-> Maybe (Sealed (PatchSet p Origin)) -> Sealed (PatchSet p Origin)
forall a. a -> Maybe a -> a
fromMaybe (PatchSet p Origin Origin -> Sealed (PatchSet p Origin)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed PatchSet p Origin Origin
forall (p :: * -> * -> *). PatchSet p Origin Origin
emptyPatchSet) (Maybe (Sealed (PatchSet p Origin)) -> Sealed (PatchSet p Origin))
-> Maybe (Sealed (PatchSet p Origin)) -> Sealed (PatchSet p Origin)
forall a b. (a -> b) -> a -> b
$ [MatchFlag]
-> PatchSet p Origin wY -> Maybe (Sealed (PatchSet p Origin))
forall (p :: * -> * -> *) wStart wX.
MatchableRP p =>
[MatchFlag]
-> PatchSet p wStart wX -> Maybe (SealedPatchSet p wStart)
matchFirstPatchset [MatchFlag]
matchFlags PatchSet p Origin wY
ps
    sp2s :: Sealed (PatchSet p Origin)
sp2s = Sealed (PatchSet p Origin)
-> Maybe (Sealed (PatchSet p Origin)) -> Sealed (PatchSet p Origin)
forall a. a -> Maybe a -> a
fromMaybe (PatchSet p Origin wY -> Sealed (PatchSet p Origin)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed PatchSet p Origin wY
ps) (Maybe (Sealed (PatchSet p Origin)) -> Sealed (PatchSet p Origin))
-> Maybe (Sealed (PatchSet p Origin)) -> Sealed (PatchSet p Origin)
forall a b. (a -> b) -> a -> b
$ [MatchFlag]
-> PatchSet p Origin wY -> Maybe (Sealed (PatchSet p Origin))
forall (p :: * -> * -> *) wStart wX.
MatchableRP p =>
[MatchFlag]
-> PatchSet p wStart wX -> Maybe (SealedPatchSet p wStart)
matchSecondPatchset [MatchFlag]
matchFlags PatchSet p Origin wY
ps

historyEditHelp :: Doc
historyEditHelp :: Doc
historyEditHelp = [[Char]] -> Doc
formatWords
  [ [Char]
"Note that this command edits the history of your repo. It is"
  , [Char]
"primarily intended to be used on patches that you authored yourself"
  , [Char]
"and did not yet publish. Using it for patches that are already"
  , [Char]
"published, or even ones you did not author yourself, may cause"
  , [Char]
"confusion and can disrupt your own and other people's work-flow."
  , [Char]
"This depends a lot on how your project is organized, though, so"
  , [Char]
"there may be valid exceptions to this rule."
  ]
  Doc -> Doc -> Doc
$+$ [[Char]] -> Doc
formatWords
  [ [Char]
"Using the `--not-in-remote` option is a good way to guard against"
  , [Char]
"accidentally editing published patches. Without arguments, this"
  , [Char]
"deselects any patches that are also present in the `defaultrepo`."
  , [Char]
"If you work in a clone of some publically hosted repository,"
  , [Char]
"then your `defaultrepo` will be that public repo. You can also"
  , [Char]
"give the option an argument which is a path or URL of some other"
  , [Char]
"repository; you can use the option multiple times with"
  , [Char]
"different repositories, which has the effect of treating all"
  , [Char]
"of them as \"upstream\", that is, it prevents you from selecting"
  , [Char]
"a patch that is contained in any of these repos."
  ]
  Doc -> Doc -> Doc
$+$ [[Char]] -> Doc
formatWords
  [ [Char]
"You can also guard only against editing another developer's patch"
  , [Char]
"by using an appropriate `--match` option with the `author` keyword."
  , [Char]
"For instance, you could add something like `<cmd> match Your Name`"
  , [Char]
"to your `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
globalPrefsDirDoc [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"defaults`."
  ]

commonHelpWithPrefsTemplates :: Doc
commonHelpWithPrefsTemplates :: Doc
commonHelpWithPrefsTemplates = [[Char]] -> Doc
formatWords
  [ [Char]
"Initialize and clone commands create the preferences files in"
  , [Char]
"_darcs/prefs/ directory of the newly created repository. With option"
  , [Char]
"--with-prefs-templates `boring` and `binaries` preferences files will be"
  , [Char]
"filled with default templates. If you want to leave these files empty"
  , [Char]
"use --no-prefs-templates option. If you prefer to keep the relevant"
  , [Char]
"settings globally, it will be convenient to add 'ALL no-prefs-templates'"
  , [Char]
"to your ~/darcs/defaults file."
  ]