{-# 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 :: (RepoPatch p, ApplyState p ~ Tree)
=> String
-> Verbosity -> Summary -> DryRun -> XmlOutput
-> Bool
-> 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 " "
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]
++"'"
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