module Darcs.UI.Commands.Convert.Darcs2 ( convertDarcs2 ) where
import Control.Monad ( when, unless, void )
import qualified Data.ByteString as B
import Data.Char ( toLower )
import Data.Maybe ( catMaybes )
import Data.List ( lookup )
import Safe ( headErr )
import System.FilePath.Posix ( (</>) )
import System.Directory ( doesDirectoryExist, doesFileExist )
import Darcs.Prelude
import Darcs.Patch ( RepoPatch, effect, displayPatch )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Info ( isTag, piRename, piTag )
import Darcs.Patch.Named ( Named(..), getdeps, patch2patchinfo, patchcontents )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info, n2pia )
import Darcs.Patch.Permutations ( (=/~\=) )
import Darcs.Patch.Progress ( progressFL )
import Darcs.Patch.Set ( inOrderTags, patchSet2FL, patchSet2RL )
import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 )
import Darcs.Patch.V1.Commute ( publicUnravel )
import qualified Darcs.Patch.V1.Core as V1 ( RepoPatchV1(PP), isMerger )
import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )
import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )
import qualified Darcs.Patch.V2.RepoPatch as V2 ( RepoPatchV2(Normal) )
import Darcs.Patch.V2.RepoPatch ( mergeUnravelled )
import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )
import Darcs.Patch.Witnesses.Ordered
( FL(..)
, concatFL
, foldFL_M
, mapFL_FL
, mapRL
, reverseFL
)
import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), mapSeal )
import Darcs.Repository
( RepoJob(..)
, Repository
, AccessType(..)
, applyToWorking
, createRepositoryV2
, finalizeRepositoryChanges
, readPatches
, revertRepositoryChanges
, withRepositoryLocation
, withUMaskFlag
)
import qualified Darcs.Repository as R ( setAllScriptsExecutable )
import Darcs.Repository.Format
( RepoProperty(Darcs2)
, formatHas
, identifyRepoFormat
)
import Darcs.Repository.Hashed ( UpdatePristine(..), tentativelyAddPatch_ )
import Darcs.Repository.Prefs ( showMotd, prefsFilePath )
import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, putFinished, withStdOpts )
import Darcs.UI.Commands.Convert.Util ( updatePending )
import Darcs.UI.Commands.Util ( commonHelpWithPrefsTemplates )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags
( verbosity, useCache, umask, withWorkingDir, patchIndexNo
, DarcsFlag, withNewRepo
, quiet
)
import Darcs.UI.Options ( parseFlags, (?), (^) )
import qualified Darcs.UI.Options.All as O
import Darcs.Util.File ( fetchFilePS, Cachable(Uncachable) )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.Lock ( withNewDirectory )
import Darcs.Util.Path( ioAbsoluteOrRemote, toPath, AbsolutePath )
import Darcs.Util.Printer ( Doc, text, ($$), ($+$) )
import Darcs.Util.Printer.Color ( traceDoc )
import Darcs.Util.Prompt ( askUser )
import Darcs.Util.Tree( Tree )
import Darcs.Util.Workaround ( getCurrentDirectory )
type RepoPatchV1 = V1.RepoPatchV1 V1.Prim
type RepoPatchV2 = V2.RepoPatchV2 V2.Prim
convertDarcs2Help :: Doc
convertDarcs2Help :: Doc
convertDarcs2Help = [Char] -> Doc
text ([[Char]] -> [Char]
unlines
[ [Char]
"This command converts a repository that uses the old patch semantics"
, [Char]
"`darcs-1` to a new repository with current `darcs-2` semantics."
, [Char]
""
, [Char]
convertDarcs2Help'
])
Doc -> Doc -> Doc
$+$ Doc
commonHelpWithPrefsTemplates
convertDarcs2Help' :: String
convertDarcs2Help' :: [Char]
convertDarcs2Help' = [[Char]] -> [Char]
unlines
[ [Char]
"WARNING: the repository produced by this command is not understood by"
, [Char]
"Darcs 1.x, and patches cannot be exchanged between repositories in"
, [Char]
"darcs-1 and darcs-2 formats. Also, you should not exchange patches"
, [Char]
"between repositories created by different invocations of this command."
, [Char]
"This means:"
, [Char]
"- Before doing this conversion, you should merge into this repo any patches"
, [Char]
" existing elsewhere that you might want to merge in future, so that they"
, [Char]
" will remain mergeable. (You can always remove them again after converting)."
, [Char]
"- After converting, you should tell everyone with a fork of this repo"
, [Char]
" to discard it and make a new fork of the converted repo."
]
convertDarcs2 :: DarcsCommand
convertDarcs2 :: DarcsCommand
convertDarcs2 = DarcsCommand
{ commandProgramName :: [Char]
commandProgramName = [Char]
"darcs"
, commandName :: [Char]
commandName = [Char]
"darcs-2"
, commandHelp :: Doc
commandHelp = Doc
convertDarcs2Help
, commandDescription :: [Char]
commandDescription = [Char]
"Convert darcs-1 repository to the darcs-2 patch format"
, commandExtraArgs :: Int
commandExtraArgs = -Int
1
, commandExtraArgHelp :: [[Char]]
commandExtraArgHelp = [[Char]
"<SOURCE>", [Char]
"[<DESTINATION>]"]
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
toDarcs2
, commandPrereq :: [DarcsFlag] -> IO (Either [Char] ())
commandPrereq = \[DarcsFlag]
_ -> Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] () -> IO (Either [Char] ()))
-> Either [Char] () -> IO (Either [Char] ())
forall a b. (a -> b) -> a -> b
$ () -> Either [Char] ()
forall a b. b -> Either a b
Right ()
, commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [[Char]] -> IO [[Char]]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [[Char]] -> IO [[Char]]
noArgs
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [[Char]] -> IO [[Char]]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [[Char]] -> IO [[Char]]
nodefaults
, commandOptions :: CommandOptions
commandOptions = CommandOptions
opts
}
where
basicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe [Char] -> SetScriptsExecutable -> WithWorkingDir -> a)
basicOpts = PrimOptSpec
DarcsOptDescr
DarcsFlag
(SetScriptsExecutable -> WithWorkingDir -> a)
(Maybe [Char])
PrimDarcsOption (Maybe [Char])
O.newRepo PrimOptSpec
DarcsOptDescr
DarcsFlag
(SetScriptsExecutable -> WithWorkingDir -> a)
(Maybe [Char])
-> OptSpec
DarcsOptDescr
DarcsFlag
(WithWorkingDir -> a)
(SetScriptsExecutable -> WithWorkingDir -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(WithWorkingDir -> a)
(Maybe [Char] -> SetScriptsExecutable -> WithWorkingDir -> 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
(WithWorkingDir -> a)
(SetScriptsExecutable -> WithWorkingDir -> a)
PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable OptSpec
DarcsOptDescr
DarcsFlag
(WithWorkingDir -> a)
(Maybe [Char] -> SetScriptsExecutable -> WithWorkingDir -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (WithWorkingDir -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe [Char] -> SetScriptsExecutable -> WithWorkingDir -> 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 (WithWorkingDir -> a)
PrimDarcsOption WithWorkingDir
O.withWorkingDir
advancedOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(RemoteDarcs -> WithPatchIndex -> UMask -> PatchFormat -> a)
advancedOpts = PrimOptSpec
DarcsOptDescr
DarcsFlag
(WithPatchIndex -> UMask -> PatchFormat -> a)
RemoteDarcs
PrimDarcsOption RemoteDarcs
O.remoteDarcs PrimOptSpec
DarcsOptDescr
DarcsFlag
(WithPatchIndex -> UMask -> PatchFormat -> a)
RemoteDarcs
-> OptSpec
DarcsOptDescr
DarcsFlag
(UMask -> PatchFormat -> a)
(WithPatchIndex -> UMask -> PatchFormat -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(UMask -> PatchFormat -> a)
(RemoteDarcs -> WithPatchIndex -> UMask -> PatchFormat -> 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
(UMask -> PatchFormat -> a)
(WithPatchIndex -> UMask -> PatchFormat -> a)
PrimDarcsOption WithPatchIndex
O.patchIndexNo OptSpec
DarcsOptDescr
DarcsFlag
(UMask -> PatchFormat -> a)
(RemoteDarcs -> WithPatchIndex -> UMask -> PatchFormat -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(PatchFormat -> a)
(UMask -> PatchFormat -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(PatchFormat -> a)
(RemoteDarcs -> WithPatchIndex -> UMask -> PatchFormat -> 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
(PatchFormat -> a)
(UMask -> PatchFormat -> a)
PrimDarcsOption UMask
O.umask OptSpec
DarcsOptDescr
DarcsFlag
(PatchFormat -> a)
(RemoteDarcs -> WithPatchIndex -> UMask -> PatchFormat -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (PatchFormat -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
a
(RemoteDarcs -> WithPatchIndex -> UMask -> PatchFormat -> 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 (PatchFormat -> a)
PrimDarcsOption PatchFormat
O.patchFormat
opts :: CommandOptions
opts = OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Verbosity
-> RemoteDarcs
-> WithPatchIndex
-> UMask
-> PatchFormat
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
(Maybe [Char]
-> SetScriptsExecutable
-> WithWorkingDir
-> Maybe StdCmdAction
-> Verbosity
-> RemoteDarcs
-> WithPatchIndex
-> UMask
-> PatchFormat
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe [Char] -> SetScriptsExecutable -> WithWorkingDir -> a)
basicOpts OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Verbosity
-> RemoteDarcs
-> WithPatchIndex
-> UMask
-> PatchFormat
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
(Maybe [Char]
-> SetScriptsExecutable
-> WithWorkingDir
-> Maybe StdCmdAction
-> Verbosity
-> RemoteDarcs
-> WithPatchIndex
-> UMask
-> PatchFormat
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
-> DarcsOption
(UseCache
-> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
(RemoteDarcs
-> WithPatchIndex
-> UMask
-> PatchFormat
-> 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])
(RemoteDarcs
-> WithPatchIndex
-> UMask
-> PatchFormat
-> UseCache
-> UseIndex
-> HooksConfig
-> Bool
-> Bool
-> [DarcsFlag])
forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(RemoteDarcs -> WithPatchIndex -> UMask -> PatchFormat -> a)
advancedOpts
toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
toDarcs2 (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts' [[Char]]
args = do
(inrepodir, opts) <-
case [[Char]]
args of
[[Char]
arg1, [Char]
arg2] -> ([Char], [DarcsFlag]) -> IO ([Char], [DarcsFlag])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
arg1, [Char] -> [DarcsFlag] -> [DarcsFlag]
withNewRepo [Char]
arg2 [DarcsFlag]
opts')
[[Char]
arg1] -> ([Char], [DarcsFlag]) -> IO ([Char], [DarcsFlag])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
arg1, [DarcsFlag]
opts')
[[Char]]
_ -> [Char] -> IO ([Char], [DarcsFlag])
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"You must provide either one or two arguments."
typed_repodir <- ioAbsoluteOrRemote inrepodir
let repodir = AbsoluteOrRemotePath -> [Char]
forall a. FilePathOrURL a => a -> [Char]
toPath AbsoluteOrRemotePath
typed_repodir
format <- identifyRepoFormat repodir
when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format."
putStrLn convertDarcs2Help'
answer <- askUser ("Do you still want to proceed ? If so, please type \"yes\": ")
when (map toLower answer /= "yes") $ fail "Ok, doing nothing."
unless (quiet opts) $ showMotd repodir
mysimplename <- makeRepoName opts repodir
withUMaskFlag (umask ? opts) $ withNewDirectory mysimplename $ do
_repo <-
createRepositoryV2 (withWorkingDir ? opts) (patchIndexNo ? opts)
(O.useCache ? opts) (O.withPrefsTemplates ? opts)
_repo <- revertRepositoryChanges _repo
withRepositoryLocation (useCache ? opts) repodir $ V1Job $ \Repository 'RO p wU wR
other -> do
theirstuff <- Repository 'RO 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 'RO p wU wR
other
let patches = (forall wW wY.
PatchInfoAnd p wW wY
-> PatchInfoAndG (Named (RepoPatchV2 Prim)) wW wY)
-> FL (PatchInfoAnd p) Origin wR
-> FL (PatchInfoAndG (Named (RepoPatchV2 Prim))) Origin wR
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL (Named (RepoPatchV1 Prim) wW wY
-> PatchInfoAnd (RepoPatchV2 Prim) wW wY
forall wX wY.
Named (RepoPatchV1 Prim) wX wY
-> PatchInfoAnd (RepoPatchV2 Prim) wX wY
convertNamed (Named (RepoPatchV1 Prim) wW wY
-> PatchInfoAnd (RepoPatchV2 Prim) wW wY)
-> (PatchInfoAnd p wW wY -> Named (RepoPatchV1 Prim) wW wY)
-> PatchInfoAnd p wW wY
-> PatchInfoAnd (RepoPatchV2 Prim) wW wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p wW wY -> Named (RepoPatchV1 Prim) wW wY
PatchInfoAndG (Named (RepoPatchV1 Prim)) wW wY
-> Named (RepoPatchV1 Prim) wW wY
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> p wA wB
hopefully) (FL (PatchInfoAnd p) Origin wR
-> FL (PatchInfoAndG (Named (RepoPatchV2 Prim))) Origin wR)
-> FL (PatchInfoAnd p) Origin wR
-> FL (PatchInfoAndG (Named (RepoPatchV2 Prim))) Origin wR
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR -> FL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX
patchSet2FL PatchSet p Origin wR
theirstuff
outOfOrderTags = [Maybe (PatchInfo, [PatchInfo])] -> [(PatchInfo, [PatchInfo])]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (PatchInfo, [PatchInfo])] -> [(PatchInfo, [PatchInfo])])
-> [Maybe (PatchInfo, [PatchInfo])] -> [(PatchInfo, [PatchInfo])]
forall a b. (a -> b) -> a -> b
$ (forall wW wZ.
PatchInfoAnd p wW wZ -> Maybe (PatchInfo, [PatchInfo]))
-> RL (PatchInfoAnd p) Origin wR
-> [Maybe (PatchInfo, [PatchInfo])]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL PatchInfoAndG (Named p) wW wZ -> Maybe (PatchInfo, [PatchInfo])
forall wW wZ.
PatchInfoAnd p wW wZ -> Maybe (PatchInfo, [PatchInfo])
forall {p :: * -> * -> *} {wX} {wY}.
HasDeps p =>
PatchInfoAndG p wX wY -> Maybe (PatchInfo, [PatchInfo])
oot (RL (PatchInfoAnd p) Origin wR -> [Maybe (PatchInfo, [PatchInfo])])
-> RL (PatchInfoAnd p) Origin wR
-> [Maybe (PatchInfo, [PatchInfo])]
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR -> RL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX
patchSet2RL PatchSet p Origin wR
theirstuff
where oot :: PatchInfoAndG p wX wY -> Maybe (PatchInfo, [PatchInfo])
oot PatchInfoAndG p wX wY
t = if PatchInfo -> Bool
isTag (PatchInfoAndG p wX wY -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAndG p wX wY
t) Bool -> Bool -> Bool
&& PatchInfoAndG p wX wY -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAndG p wX wY
t PatchInfo -> [PatchInfo] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` PatchSet p Origin wR -> [PatchInfo]
forall (p :: * -> * -> *) wS wX. PatchSet p wS wX -> [PatchInfo]
inOrderTags PatchSet p Origin wR
theirstuff
then (PatchInfo, [PatchInfo]) -> Maybe (PatchInfo, [PatchInfo])
forall a. a -> Maybe a
Just (PatchInfoAndG p wX wY -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAndG p wX wY
t, p wX wY -> [PatchInfo]
forall wX wY. p wX wY -> [PatchInfo]
forall (p :: * -> * -> *) wX wY.
HasDeps p =>
p wX wY -> [PatchInfo]
getdeps (p wX wY -> [PatchInfo]) -> p wX wY -> [PatchInfo]
forall a b. (a -> b) -> a -> b
$ PatchInfoAndG p wX wY -> p wX wY
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> p wA wB
hopefully PatchInfoAndG p wX wY
t)
else Maybe (PatchInfo, [PatchInfo])
forall a. Maybe a
Nothing
fixDep PatchInfo
p = case PatchInfo -> [(PatchInfo, [PatchInfo])] -> Maybe [PatchInfo]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PatchInfo
p [(PatchInfo, [PatchInfo])]
outOfOrderTags of
Just [PatchInfo]
d -> PatchInfo
p PatchInfo -> [PatchInfo] -> [PatchInfo]
forall a. a -> [a] -> [a]
: (PatchInfo -> [PatchInfo]) -> [PatchInfo] -> [PatchInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatchInfo -> [PatchInfo]
fixDep [PatchInfo]
d
Maybe [PatchInfo]
Nothing -> [PatchInfo
p]
primV1toV2 = Prim x y -> Prim x y
forall x y. Prim x y -> Prim x y
V2.Prim (Prim x y -> Prim x y)
-> (Prim x y -> Prim x y) -> Prim x y -> Prim x y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prim x y -> Prim x y
forall x y. Prim x y -> Prim x y
V1.unPrim
convertOne :: RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY
convertOne RepoPatchV1 wX wY
x | RepoPatchV1 wX wY -> Bool
forall (prim :: * -> * -> *) wA wB. RepoPatchV1 prim wA wB -> Bool
V1.isMerger RepoPatchV1 wX wY
x =
let ex :: FL Prim wX wY
ex = (forall wW wY. Prim wW wY -> Prim wW wY)
-> FL Prim wX wY -> FL Prim wX wY
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL Prim wW wY -> Prim wW wY
forall wW wY. Prim wW wY -> Prim wW wY
primV1toV2 (RepoPatchV1 wX wY -> FL (PrimOf (RepoPatchV1 Prim)) wX wY
forall wX wY.
RepoPatchV1 Prim wX wY -> FL (PrimOf (RepoPatchV1 Prim)) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect RepoPatchV1 wX wY
x) in
case [Sealed (FL Prim wY)] -> Maybe (FlippedSeal (RepoPatchV2 Prim) wY)
forall (prim :: * -> * -> *) wX.
PrimPatch prim =>
[Sealed (FL prim wX)] -> Maybe (FlippedSeal (RepoPatchV2 prim) wX)
mergeUnravelled ([Sealed (FL Prim wY)]
-> Maybe (FlippedSeal (RepoPatchV2 Prim) wY))
-> [Sealed (FL Prim wY)]
-> Maybe (FlippedSeal (RepoPatchV2 Prim) wY)
forall a b. (a -> b) -> a -> b
$ (Sealed (FL Prim wY) -> Sealed (FL Prim wY))
-> [Sealed (FL Prim wY)] -> [Sealed (FL Prim wY)]
forall a b. (a -> b) -> [a] -> [b]
map ((forall wX. FL Prim wY wX -> FL Prim wY wX)
-> Sealed (FL Prim wY) -> Sealed (FL Prim wY)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal ((forall wW wY. Prim wW wY -> Prim wW wY)
-> FL Prim wY wX -> FL Prim wY wX
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL Prim wW wY -> Prim wW wY
forall wW wY. Prim wW wY -> Prim wW wY
primV1toV2)) ([Sealed (FL Prim wY)] -> [Sealed (FL Prim wY)])
-> [Sealed (FL Prim wY)] -> [Sealed (FL Prim wY)]
forall a b. (a -> b) -> a -> b
$ RepoPatchV1 wX wY -> [Sealed (FL Prim wY)]
forall (prim :: * -> * -> *) wX wY.
PrimPatch prim =>
RepoPatchV1 prim wX wY -> [Sealed (FL prim wY)]
publicUnravel RepoPatchV1 wX wY
x of
Just (FlippedSeal RepoPatchV2 Prim wX wY
y) ->
case FL Prim wX wY -> RL Prim wX wY
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL (RepoPatchV2 Prim wX wY -> FL (PrimOf (RepoPatchV2 Prim)) wX wY
forall wX wY.
RepoPatchV2 Prim wX wY -> FL (PrimOf (RepoPatchV2 Prim)) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect RepoPatchV2 Prim wX wY
y) RL Prim wX wY -> RL Prim wX wY -> EqCheck wX wX
forall (p :: * -> * -> *) wA wB wC.
(Commute p, Eq2 p) =>
RL p wA wC -> RL p wB wC -> EqCheck wA wB
=/~\= FL Prim wX wY -> RL Prim wX wY
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL Prim wX wY
ex of
EqCheck wX wX
IsEq -> RepoPatchV2 Prim wX wY
RepoPatchV2 Prim wX wY
y RepoPatchV2 Prim wX wY
-> FL (RepoPatchV2 Prim) wY wY -> FL (RepoPatchV2 Prim) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (RepoPatchV2 Prim) wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
EqCheck wX wX
NotEq ->
Doc -> FL (RepoPatchV2 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
forall a. Doc -> a -> a
traceDoc ([Char] -> Doc
text [Char]
"lossy conversion:" Doc -> Doc -> Doc
$$
RepoPatchV1 wX wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch RepoPatchV1 wX wY
x) (FL (RepoPatchV2 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY)
-> FL (RepoPatchV2 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
forall a b. (a -> b) -> a -> b
$
(forall wW wY. Prim wW wY -> RepoPatchV2 wW wY)
-> FL Prim wX wY -> FL (RepoPatchV2 Prim) wX wY
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL Prim wW wY -> RepoPatchV2 Prim wW wY
forall wW wY. Prim wW wY -> RepoPatchV2 wW wY
forall (prim :: * -> * -> *) wX wY.
prim wX wY -> RepoPatchV2 prim wX wY
V2.Normal FL Prim wX wY
ex
Maybe (FlippedSeal (RepoPatchV2 Prim) wY)
Nothing -> Doc -> FL (RepoPatchV2 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
forall a. Doc -> a -> a
traceDoc ([Char] -> Doc
text
[Char]
"lossy conversion of complicated conflict:" Doc -> Doc -> Doc
$$
RepoPatchV1 wX wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch RepoPatchV1 wX wY
x) (FL (RepoPatchV2 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY)
-> FL (RepoPatchV2 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
forall a b. (a -> b) -> a -> b
$
(forall wW wY. Prim wW wY -> RepoPatchV2 wW wY)
-> FL Prim wX wY -> FL (RepoPatchV2 Prim) wX wY
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL Prim wW wY -> RepoPatchV2 Prim wW wY
forall wW wY. Prim wW wY -> RepoPatchV2 wW wY
forall (prim :: * -> * -> *) wX wY.
prim wX wY -> RepoPatchV2 prim wX wY
V2.Normal FL Prim wX wY
ex
convertOne (V1.PP Prim wX wY
x) = Prim wX wY -> RepoPatchV2 Prim wX wY
forall (prim :: * -> * -> *) wX wY.
prim wX wY -> RepoPatchV2 prim wX wY
V2.Normal (Prim wX wY -> Prim wX wY
forall wW wY. Prim wW wY -> Prim wW wY
primV1toV2 Prim wX wY
x) RepoPatchV2 Prim wX wY
-> FL (RepoPatchV2 Prim) wY wY -> FL (RepoPatchV2 Prim) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (RepoPatchV2 Prim) wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
convertOne RepoPatchV1 wX wY
_ = [Char] -> FL (RepoPatchV2 Prim) wX wY
forall a. Partial => [Char] -> a
error [Char]
"impossible case"
convertFL :: FL RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY
convertFL = FL (FL (RepoPatchV2 Prim)) wX wY -> FL (RepoPatchV2 Prim) wX wY
forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL (FL (FL (RepoPatchV2 Prim)) wX wY -> FL (RepoPatchV2 Prim) wX wY)
-> (FL (RepoPatchV1 Prim) wX wY
-> FL (FL (RepoPatchV2 Prim)) wX wY)
-> FL (RepoPatchV1 Prim) wX wY
-> FL (RepoPatchV2 Prim) wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall wX wY. RepoPatchV1 wX wY -> FL (RepoPatchV2 Prim) wX wY)
-> FL (RepoPatchV1 Prim) wX wY -> FL (FL (RepoPatchV2 Prim)) wX wY
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL RepoPatchV1 wW wY -> FL (RepoPatchV2 Prim) wW wY
forall wX wY. RepoPatchV1 wX wY -> FL (RepoPatchV2 Prim) wX wY
convertOne
convertNamed :: Named RepoPatchV1 wX wY
-> PatchInfoAnd RepoPatchV2 wX wY
convertNamed Named (RepoPatchV1 Prim) wX wY
n = Named (RepoPatchV2 Prim) wX wY
-> PatchInfoAndG (Named (RepoPatchV2 Prim)) wX wY
forall (p :: * -> * -> *) wX wY.
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG p wX wY
n2pia (Named (RepoPatchV2 Prim) wX wY
-> PatchInfoAndG (Named (RepoPatchV2 Prim)) wX wY)
-> Named (RepoPatchV2 Prim) wX wY
-> PatchInfoAndG (Named (RepoPatchV2 Prim)) wX wY
forall a b. (a -> b) -> a -> b
$
PatchInfo
-> [PatchInfo]
-> FL (RepoPatchV2 Prim) wX wY
-> Named (RepoPatchV2 Prim) wX wY
forall (p :: * -> * -> *) wX wY.
PatchInfo -> [PatchInfo] -> FL p wX wY -> Named p wX wY
NamedP
(PatchInfo -> PatchInfo
convertInfo (PatchInfo -> PatchInfo) -> PatchInfo -> PatchInfo
forall a b. (a -> b) -> a -> b
$ Named (RepoPatchV1 Prim) wX wY -> PatchInfo
forall (p :: * -> * -> *) wX wY. Named p wX wY -> PatchInfo
patch2patchinfo Named (RepoPatchV1 Prim) wX wY
n)
((PatchInfo -> PatchInfo) -> [PatchInfo] -> [PatchInfo]
forall a b. (a -> b) -> [a] -> [b]
map PatchInfo -> PatchInfo
convertInfo ([PatchInfo] -> [PatchInfo]) -> [PatchInfo] -> [PatchInfo]
forall a b. (a -> b) -> a -> b
$ (PatchInfo -> [PatchInfo]) -> [PatchInfo] -> [PatchInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatchInfo -> [PatchInfo]
fixDep ([PatchInfo] -> [PatchInfo]) -> [PatchInfo] -> [PatchInfo]
forall a b. (a -> b) -> a -> b
$ Named (RepoPatchV1 Prim) wX wY -> [PatchInfo]
forall wX wY. Named (RepoPatchV1 Prim) wX wY -> [PatchInfo]
forall (p :: * -> * -> *) wX wY.
HasDeps p =>
p wX wY -> [PatchInfo]
getdeps Named (RepoPatchV1 Prim) wX wY
n)
(FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
forall wX wY.
FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
convertFL (FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY)
-> FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
forall a b. (a -> b) -> a -> b
$ Named (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV1 Prim) wX wY
forall (p :: * -> * -> *) wX wY. Named p wX wY -> FL p wX wY
patchcontents Named (RepoPatchV1 Prim) wX wY
n)
convertInfo PatchInfo
n | PatchInfo
n PatchInfo -> [PatchInfo] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` PatchSet p Origin wR -> [PatchInfo]
forall (p :: * -> * -> *) wS wX. PatchSet p wS wX -> [PatchInfo]
inOrderTags PatchSet p Origin wR
theirstuff = PatchInfo
n
| Bool
otherwise = PatchInfo -> ([Char] -> PatchInfo) -> Maybe [Char] -> PatchInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PatchInfo
n (\[Char]
t -> PatchInfo -> [Char] -> PatchInfo
piRename PatchInfo
n ([Char]
"old tag: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
t)) (Maybe [Char] -> PatchInfo) -> Maybe [Char] -> PatchInfo
forall a b. (a -> b) -> a -> b
$ PatchInfo -> Maybe [Char]
piTag PatchInfo
n
_ <- applyAll opts _repo $ progressFL "Converting patch" patches
void $ finalizeRepositoryChanges _repo (O.dryRun ? opts)
when (parseFlags O.setScriptsExecutable opts == O.YesSetScriptsExecutable)
R.setAllScriptsExecutable
(fetchFilePS (repodir </> prefsFilePath) Uncachable >>= B.writeFile prefsFilePath)
`catchall` return ()
putFinished opts "converting"
where
applyOne :: (RepoPatch p, ApplyState p ~ Tree)
=> [DarcsFlag]
-> W2 (Repository 'RW p) wX
-> PatchInfoAnd p wX wY
-> IO (W2 (Repository 'RW p) wY)
applyOne :: forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> W2 (Repository 'RW p) wX
-> PatchInfoAnd p wX wY
-> IO (W2 (Repository 'RW p) wY)
applyOne [DarcsFlag]
opts (W2 Repository 'RW p wX wX
_repo) PatchInfoAnd p wX wY
x = do
_repo <-
UpdatePristine
-> Repository 'RW p wX wX
-> UpdatePending
-> PatchInfoAnd p wX wY
-> IO (Repository 'RW p wX wY)
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> PatchInfoAnd p wR wY
-> IO (Repository 'RW p wU wY)
tentativelyAddPatch_ ([DarcsFlag] -> UpdatePristine
updatePristine [DarcsFlag]
opts) Repository 'RW p wX wX
_repo ([DarcsFlag] -> UpdatePending
updatePending [DarcsFlag]
opts) PatchInfoAnd p wX wY
x
_repo <- applyToWorking _repo (verbosity ? opts) (effect x)
return (W2 _repo)
applyAll :: (RepoPatch p, ApplyState p ~ Tree)
=> [DarcsFlag]
-> Repository 'RW p wX wX
-> FL (PatchInfoAnd p) wX wY
-> IO (Repository 'RW p wY wY)
applyAll :: forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> Repository 'RW p wX wX
-> FL (PatchInfoAnd p) wX wY
-> IO (Repository 'RW p wY wY)
applyAll [DarcsFlag]
opts Repository 'RW p wX wX
r FL (PatchInfoAnd p) wX wY
xss = W2 (Repository 'RW p) wY -> Repository 'RW p wY wY
forall (r :: * -> * -> *) wX. W2 r wX -> r wX wX
unW2 (W2 (Repository 'RW p) wY -> Repository 'RW p wY wY)
-> IO (W2 (Repository 'RW p) wY) -> IO (Repository 'RW p wY wY)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall wA wB.
W2 (Repository 'RW p) wA
-> PatchInfoAnd p wA wB -> IO (W2 (Repository 'RW p) wB))
-> W2 (Repository 'RW p) wX
-> FL (PatchInfoAnd p) wX wY
-> IO (W2 (Repository 'RW p) wY)
forall (m :: * -> *) (r :: * -> *) (p :: * -> * -> *) wX wY.
Monad m =>
(forall wA wB. r wA -> p wA wB -> m (r wB))
-> r wX -> FL p wX wY -> m (r wY)
foldFL_M ([DarcsFlag]
-> W2 (Repository 'RW p) wA
-> PatchInfoAndG (Named p) wA wB
-> IO (W2 (Repository 'RW p) wB)
forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> W2 (Repository 'RW p) wX
-> PatchInfoAnd p wX wY
-> IO (W2 (Repository 'RW p) wY)
applyOne [DarcsFlag]
opts) (Repository 'RW p wX wX -> W2 (Repository 'RW p) wX
forall (r :: * -> * -> *) wX. r wX wX -> W2 r wX
W2 Repository 'RW p wX wX
r) FL (PatchInfoAnd p) wX wY
xss
updatePristine :: [DarcsFlag] -> UpdatePristine
updatePristine :: [DarcsFlag] -> UpdatePristine
updatePristine [DarcsFlag]
opts =
case PrimOptSpec DarcsOptDescr DarcsFlag a WithWorkingDir
PrimDarcsOption WithWorkingDir
withWorkingDir PrimDarcsOption WithWorkingDir -> [DarcsFlag] -> WithWorkingDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
WithWorkingDir
O.WithWorkingDir -> UpdatePristine
UpdatePristine
WithWorkingDir
O.NoWorkingDir -> UpdatePristine
UpdatePristine
newtype W2 r wX = W2 {forall (r :: * -> * -> *) wX. W2 r wX -> r wX wX
unW2 :: r wX wX}
makeRepoName :: [DarcsFlag] -> FilePath -> IO String
makeRepoName :: [DarcsFlag] -> [Char] -> IO [Char]
makeRepoName [DarcsFlag]
opts [Char]
d =
case PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe [Char])
PrimDarcsOption (Maybe [Char])
O.newRepo PrimDarcsOption (Maybe [Char]) -> [DarcsFlag] -> Maybe [Char]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
Just [Char]
n -> do
exists <- [Char] -> IO Bool
doesDirectoryExist [Char]
n
file_exists <- doesFileExist n
if exists || file_exists
then fail $ "Directory or file named '" ++ n ++ "' already exists."
else return n
Maybe [Char]
Nothing ->
case (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
[Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
(Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
(Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
d of
[Char]
"" -> [Char] -> IO [Char]
modifyRepoName [Char]
"anonymous_repo"
[Char]
base -> [Char] -> IO [Char]
modifyRepoName [Char]
base
modifyRepoName :: String -> IO String
modifyRepoName :: [Char] -> IO [Char]
modifyRepoName [Char]
name =
if [Char] -> Char
forall a. Partial => [a] -> a
headErr [Char]
name Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'
then [Char] -> Int -> IO [Char]
mrn [Char]
name (-Int
1)
else do cwd <- IO [Char]
getCurrentDirectory
mrn (cwd ++ "/" ++ name) (-1)
where
mrn :: String -> Int -> IO String
mrn :: [Char] -> Int -> IO [Char]
mrn [Char]
n Int
i = do
exists <- [Char] -> IO Bool
doesDirectoryExist [Char]
thename
file_exists <- doesFileExist thename
if not exists && not file_exists
then do when (i /= -1) $
putStrLn $ "Directory '"++ n ++
"' already exists, creating repository as '"++
thename ++"'"
return thename
else mrn n $ i+1
where thename :: [Char]
thename = if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 then [Char]
n else [Char]
n[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"_"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i