--  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
    , expandDirs
    , doesDirectoryReallyExist
    , checkUnrelatedRepos
    , repoTags
    ) where

import Control.Monad ( when, unless )
import Data.Maybe ( catMaybes, fromJust )

import Prelude ()
import Darcs.Prelude

import System.Exit ( ExitCode(..), exitWith, exitSuccess )
import System.FilePath.Posix ( (</>) )
import System.Posix.Files ( isDirectory )

import Darcs.Patch ( RepoPatch, xmlSummary )
import Darcs.Patch.Depends ( areUnrelatedRepos )
import Darcs.Patch.Info ( toXml, piTag )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefullyM )
import Darcs.Patch.Set ( PatchSet(..), patchSetfMap )
import Darcs.Patch.Witnesses.Ordered ( FL, mapFL )

import Darcs.Repository ( Repository, readRecorded, testTentative )
import Darcs.Repository.State
    ( readUnrecordedFiltered, readWorking, restrictBoring
    , TreeFilter(..), applyTreeFilter
    )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Bundle ( patchFilename )

import Darcs.UI.PrintPatch ( showFriendly )
import Darcs.UI.Options.All
    ( Verbosity(..), SetScriptsExecutable, TestChanges (..)
    , RunTest(..), LeaveTestDir(..), UseIndex, ScanKnown(..)
    , Summary(..), DryRun(..), XmlOutput(..), LookForMoves
    )

import Darcs.Util.Exception ( clarifyErrors )
import Darcs.Util.File ( getFileStatus, withCurrentDirectory )
import Darcs.Util.Path
    ( SubPath, toFilePath, getUniquePathName, floatPath
    , simpleSubPath, toPath, anchorPath
    )
import Darcs.Util.Printer
    ( text, (<+>), hsep, ($$), vcat, vsep
    , putDocLn, insertBeforeLastline, prefix
    )
import Darcs.Util.Prompt ( PromptConfig(..), promptChar, promptYorn )
import Darcs.Util.Text ( pathlist )
import Darcs.Util.Tree.Monad ( virtualTreeIO, exists )
import Darcs.Util.Tree ( Tree )
import qualified Darcs.Util.Tree as Tree


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

testTentativeAndMaybeExit :: Repository rt p wR wU wT
                          -> Verbosity
                          -> TestChanges
                          -> SetScriptsExecutable
                          -> Bool
                          -> String
                          -> String -> Maybe String -> IO ()
testTentativeAndMaybeExit :: Repository rt p wR wU wT
-> Verbosity
-> TestChanges
-> SetScriptsExecutable
-> Bool
-> String
-> String
-> Maybe String
-> IO ()
testTentativeAndMaybeExit repo :: Repository rt p wR wU wT
repo verb :: Verbosity
verb test :: TestChanges
test sse :: SetScriptsExecutable
sse interactive :: Bool
interactive failMessage :: String
failMessage confirmMsg :: String
confirmMsg withClarification :: Maybe String
withClarification = do
    let (rt :: RunTest
rt,ltd :: LeaveTestDir
ltd) = case TestChanges
test of
          NoTestChanges    -> (RunTest
NoRunTest, LeaveTestDir
YesLeaveTestDir)
          YesTestChanges x :: LeaveTestDir
x -> (RunTest
YesRunTest, LeaveTestDir
x)
    ExitCode
testResult <- Repository rt p wR wU wT
-> RunTest
-> LeaveTestDir
-> SetScriptsExecutable
-> Verbosity
-> IO ExitCode
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT
-> RunTest
-> LeaveTestDir
-> SetScriptsExecutable
-> Verbosity
-> IO ExitCode
testTentative Repository rt p wR wU wT
repo RunTest
rt LeaveTestDir
ltd SetScriptsExecutable
sse Verbosity
verb
    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)
-> (String -> IO a -> IO a) -> Maybe String -> 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 -> String -> IO a) -> String -> IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO a -> String -> IO a
forall a. IO a -> String -> IO a
clarifyErrors) Maybe String
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
interactive IO ()
forall a. IO a
doExit
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Looks like " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
failMessage
        let prompt :: String
prompt = "Shall I " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
confirmMsg String -> String -> String
forall a. [a] -> [a] -> [a]
++ " anyway?"
        Char
yn <- PromptConfig -> IO Char
promptChar (String -> String -> String -> Maybe Char -> String -> PromptConfig
PromptConfig String
prompt "yn" [] (Char -> Maybe Char
forall a. a -> Maybe a
Just 'n') [])
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Char
yn Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '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, ApplyState p ~ Tree)
                          => String
                          -> Verbosity -> Summary -> DryRun -> XmlOutput
                          -> Bool -- interactive
                          -> FL (PatchInfoAnd rt p) wX wY
                          -> IO ()
printDryRunMessageAndExit :: String
-> Verbosity
-> Summary
-> DryRun
-> XmlOutput
-> Bool
-> FL (PatchInfoAnd rt p) wX wY
-> IO ()
printDryRunMessageAndExit action :: String
action v :: Verbosity
v s :: Summary
s d :: DryRun
d x :: XmlOutput
x interactive :: Bool
interactive patches :: FL (PatchInfoAnd rt 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 [ "Would", String -> Doc
text String
action, "the following changes:" ]
        Doc -> IO ()
putDocLn Doc
put_mode
        Doc -> IO ()
putInfoX (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text ""
        Doc -> IO ()
putInfoX (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "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
&& Summary
s Summary -> Summary -> Bool
forall a. Eq a => a -> a -> Bool
== Summary
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 [ "Will", String -> Doc
text String
action, "the following changes:" ]
        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 String -> Doc
text "<patches>" Doc -> Doc -> Doc
$$
                        [Doc] -> Doc
vcat ((forall wW wZ. PatchInfoAnd rt p wW wZ -> Doc)
-> FL (PatchInfoAnd rt 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 rt p wW wZ -> Doc)
-> PatchInfoAnd rt p wW wZ
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Summary -> PatchInfoAnd rt p wW wZ -> Doc
forall (p :: * -> * -> *) (rt :: RepoType) wA wB.
(CommuteNoConflicts p, Conflict p, PrimPatchBase p) =>
Summary -> PatchInfoAnd rt p wA wB -> Doc
xml_info Summary
s) FL (PatchInfoAnd rt p) wX wY
patches) Doc -> Doc -> Doc
$$
                        String -> Doc
text "</patches>"
                   else [Doc] -> Doc
vsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (forall wW wZ. PatchInfoAnd rt p wW wZ -> Doc)
-> FL (PatchInfoAnd rt p) wX wY -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (Verbosity -> Summary -> PatchInfoAnd rt p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatch p =>
Verbosity -> Summary -> p wX wY -> Doc
showFriendly Verbosity
v Summary
s) FL (PatchInfoAnd rt 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 (m :: * -> *) a. Monad m => a -> m a
return ()) else Doc -> IO ()
putDocLn

    xml_info :: Summary -> PatchInfoAnd rt p wA wB -> Doc
xml_info YesSummary = PatchInfoAnd rt p wA wB -> Doc
forall (p :: * -> * -> *) (rt :: RepoType) wA wB.
(CommuteNoConflicts p, Conflict p, PrimPatchBase p) =>
PatchInfoAnd rt p wA wB -> Doc
xml_with_summary
    xml_info NoSummary  = PatchInfo -> Doc
toXml (PatchInfo -> Doc)
-> (PatchInfoAnd rt p wA wB -> PatchInfo)
-> PatchInfoAnd rt p wA wB
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd rt p wA wB -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info

    xml_with_summary :: PatchInfoAnd rt p wA wB -> Doc
xml_with_summary hp :: PatchInfoAnd rt p wA wB
hp
        | Just p :: WrappedNamed rt p wA wB
p <- PatchInfoAnd rt p wA wB -> Maybe (WrappedNamed rt p wA wB)
forall (m :: * -> *) (rt :: RepoType) (p :: * -> * -> *) wA wB.
MonadFail m =>
PatchInfoAnd rt p wA wB -> m (WrappedNamed rt p wA wB)
hopefullyM PatchInfoAnd rt p wA wB
hp = Doc -> Doc -> Doc
insertBeforeLastline (PatchInfo -> Doc
toXml (PatchInfo -> Doc) -> PatchInfo -> Doc
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p wA wB -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wA wB
hp)
                                        (Doc -> Doc
indent (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ WrappedNamed rt p wA wB -> Doc
forall (p :: * -> * -> *) wX wY.
(Conflict p, PrimPatchBase p) =>
p wX wY -> Doc
xmlSummary WrappedNamed rt p wA wB
p)
    xml_with_summary hp :: PatchInfoAnd rt p wA wB
hp = PatchInfo -> Doc
toXml (PatchInfoAnd rt p wA wB -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wA wB
hp)

    indent :: Doc -> Doc
indent = String -> Doc -> Doc
prefix "    "

-- | Given a repository and two common command options, classify the given list
-- of subpaths 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 wR wU wT
                    -> Verbosity
                    -> UseIndex
                    -> ScanKnown
                    -> LookForMoves
                    -> [SubPath]
                    -> IO ([SubPath],[SubPath])
filterExistingPaths :: Repository rt p wR wU wT
-> Verbosity
-> UseIndex
-> ScanKnown
-> LookForMoves
-> [SubPath]
-> IO ([SubPath], [SubPath])
filterExistingPaths repo :: Repository rt p wR wU wT
repo verb :: Verbosity
verb useidx :: UseIndex
useidx scan :: ScanKnown
scan lfm :: LookForMoves
lfm paths :: [SubPath]
paths = do
      Tree IO
pristine <- Repository rt p wR wU wT -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wT
repo
      Tree IO
working <- Repository rt p wR wU wT
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [SubPath]
-> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [SubPath]
-> IO (Tree IO)
readUnrecordedFiltered Repository rt p wR wU wT
repo UseIndex
useidx ScanKnown
scan LookForMoves
lfm ([SubPath] -> Maybe [SubPath]
forall a. a -> Maybe a
Just [SubPath]
paths)
      let filepaths :: [String]
filepaths = (SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath [SubPath]
paths
          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
$ (String -> RWST AnchoredPath () (TreeState IO) IO Bool)
-> [String] -> TreeIO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AnchoredPath -> RWST AnchoredPath () (TreeState IO) IO Bool
forall (m :: * -> *). TreeRO m => AnchoredPath -> m Bool
exists (AnchoredPath -> RWST AnchoredPath () (TreeState IO) IO Bool)
-> (String -> AnchoredPath)
-> String
-> RWST AnchoredPath () (TreeState IO) IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AnchoredPath
floatPath) [String]
filepaths
      (in_pristine :: [Bool]
in_pristine, _) <- Tree IO -> IO ([Bool], Tree IO)
check Tree IO
pristine
      (in_working :: [Bool]
in_working, _) <- Tree IO -> IO ([Bool], Tree IO)
check Tree IO
working
      let paths_with_info :: [(SubPath, Bool, Bool)]
paths_with_info       = [SubPath] -> [Bool] -> [Bool] -> [(SubPath, Bool, Bool)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [SubPath]
paths [Bool]
in_pristine [Bool]
in_working
          paths_in_neither :: [SubPath]
paths_in_neither      = [ SubPath
p | (p :: SubPath
p,False,False) <- [(SubPath, Bool, Bool)]
paths_with_info ]
          paths_only_in_working :: [SubPath]
paths_only_in_working = [ SubPath
p | (p :: SubPath
p,False,True) <- [(SubPath, Bool, Bool)]
paths_with_info ]
          paths_in_either :: [SubPath]
paths_in_either       = [ SubPath
p | (p :: SubPath
p,inp :: Bool
inp,inw :: Bool
inw) <- [(SubPath, Bool, Bool)]
paths_with_info, Bool
inp Bool -> Bool -> Bool
|| Bool
inw ]
          or_not_added :: Doc
or_not_added          = if ScanKnown
scan ScanKnown -> ScanKnown -> Bool
forall a. Eq a => a -> a -> Bool
== ScanKnown
ScanKnown then " or not added " else " "
      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
|| [SubPath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SubPath]
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
$
        "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
<> "paths:" Doc -> Doc -> Doc
<+>
        [String] -> Doc
pathlist ((SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath [SubPath]
paths_in_neither)
      ([SubPath], [SubPath]) -> IO ([SubPath], [SubPath])
forall (m :: * -> *) a. Monad m => a -> m a
return ([SubPath]
paths_only_in_working, [SubPath]
paths_in_either)

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

getUniqueDPatchName :: FilePath -> IO FilePath
getUniqueDPatchName :: String -> IO String
getUniqueDPatchName name :: String
name = Bool -> (String -> String) -> (Int -> String) -> IO String
getUniquePathName Bool
True String -> String
buildMsg Int -> String
forall a. (Eq a, Num a, Show a) => a -> String
buildName
  where
    buildName :: a -> String
buildName i :: a
i = if a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -1 then String -> String
patchFilename String
name else String -> String
patchFilename (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++"_"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
i
    buildMsg :: String -> String
buildMsg n :: String
n = "Directory or file '"String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 "' already exists, creating dpatch as '"String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++"'"

-- | For each directory in the list of 'SubPath's, add all paths
-- under that directory to the list. If the first argument is 'True', then
-- include even boring files.
--
-- This is used by the add and remove commands to handle the --recursive option.
expandDirs :: Bool -> [SubPath] -> IO [SubPath]
expandDirs :: Bool -> [SubPath] -> IO [SubPath]
expandDirs includeBoring :: Bool
includeBoring subpaths :: [SubPath]
subpaths =
  do
    TreeFilter IO
boringFilter <-
      if Bool
includeBoring
        then TreeFilter IO -> IO (TreeFilter IO)
forall (m :: * -> *) a. Monad m => a -> m a
return ((forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO)
-> TreeFilter IO
forall (m :: * -> *).
(forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
TreeFilter forall a. a -> a
forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
id)
        else Tree IO -> IO (TreeFilter IO)
forall (m :: * -> *). Tree m -> IO (TreeFilter m)
restrictBoring Tree IO
forall (m :: * -> *). Tree m
Tree.emptyTree
    ([String] -> [SubPath]) -> IO [String] -> IO [SubPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> SubPath) -> [String] -> [SubPath]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe SubPath -> SubPath
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe SubPath -> SubPath)
-> (String -> Maybe SubPath) -> String -> SubPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe SubPath
simpleSubPath)) (IO [String] -> IO [SubPath]) -> IO [String] -> IO [SubPath]
forall a b. (a -> b) -> a -> b
$
      [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (SubPath -> IO [String]) -> [SubPath] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TreeFilter IO -> String -> IO [String]
expandOne TreeFilter IO
boringFilter (String -> IO [String])
-> (SubPath -> String) -> SubPath -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubPath -> String
forall a. FilePathOrURL a => a -> String
toPath) [SubPath]
subpaths
  where
    expandOne :: TreeFilter IO -> String -> IO [String]
expandOne boringFilter :: TreeFilter IO
boringFilter "" = TreeFilter IO -> IO [String]
listFiles TreeFilter IO
boringFilter
    expandOne boringFilter :: TreeFilter IO
boringFilter f :: String
f = do
        Bool
isdir <- String -> IO Bool
doesDirectoryReallyExist String
f
        if Bool -> Bool
not Bool
isdir
          then [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
f]
          else do
            [String]
fs <- String -> IO [String] -> IO [String]
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory String
f (TreeFilter IO -> IO [String]
listFiles TreeFilter IO
boringFilter)
            [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String
fString -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
f String -> String -> String
</>) [String]
fs
    listFiles :: TreeFilter IO -> IO [String]
listFiles boringFilter :: TreeFilter IO
boringFilter = do
      Tree IO
working <- TreeFilter IO
-> forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
boringFilter (Tree IO -> Tree IO) -> IO (Tree IO) -> IO (Tree IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Tree IO)
readWorking
      [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ ((AnchoredPath, TreeItem IO) -> String)
-> [(AnchoredPath, TreeItem IO)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnchoredPath -> String
anchorPath "" (AnchoredPath -> String)
-> ((AnchoredPath, TreeItem IO) -> AnchoredPath)
-> (AnchoredPath, TreeItem IO)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredPath, TreeItem IO) -> AnchoredPath
forall a b. (a, b) -> a
fst) ([(AnchoredPath, TreeItem IO)] -> [String])
-> [(AnchoredPath, TreeItem IO)] -> [String]
forall a b. (a -> b) -> a -> b
$ Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
Tree.list Tree IO
working

doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist :: String -> IO Bool
doesDirectoryReallyExist f :: String
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO (Maybe FileStatus)
getFileStatus String
f

checkUnrelatedRepos :: RepoPatch p
                    => Bool
                    -> PatchSet rt p wStart wX
                    -> PatchSet rt p wStart wY
                    -> IO ()
checkUnrelatedRepos :: Bool -> PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> IO ()
checkUnrelatedRepos allowUnrelatedRepos :: Bool
allowUnrelatedRepos us :: PatchSet rt p wStart wX
us them :: PatchSet rt p wStart wY
them =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ( Bool -> Bool
not Bool
allowUnrelatedRepos Bool -> Bool -> Bool
&& PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> Bool
forall (p :: * -> * -> *) (rt :: RepoType) wStart wX wY.
Commute p =>
PatchSet rt p wStart wX -> PatchSet rt p wStart wY -> Bool
areUnrelatedRepos PatchSet rt p wStart wX
us PatchSet rt p wStart wY
them ) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         do Bool
confirmed <- String -> IO Bool
promptYorn "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
$ String -> IO ()
putStrLn "Cancelled." IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess

repoTags :: PatchSet rt p wX wY -> IO [String]
repoTags :: PatchSet rt p wX wY -> IO [String]
repoTags ps :: PatchSet rt p wX wY
ps = [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (forall wW wZ. PatchInfoAnd rt p wW wZ -> IO (Maybe String))
-> PatchSet rt p wX wY -> IO [Maybe String]
forall (rt :: RepoType) (p :: * -> * -> *) a wW' wZ'.
(forall wW wZ. PatchInfoAnd rt p wW wZ -> IO a)
-> PatchSet rt p wW' wZ' -> IO [a]
patchSetfMap (Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> (PatchInfoAnd rt p wW wZ -> Maybe String)
-> PatchInfoAnd rt p wW wZ
-> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> Maybe String
piTag (PatchInfo -> Maybe String)
-> (PatchInfoAnd rt p wW wZ -> PatchInfo)
-> PatchInfoAnd rt p wW wZ
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd rt p wW wZ -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info) PatchSet rt p wX wY
ps