--  Copyright (C) 2002-2014 David Roundy, Petr Rockai, Owen Stephens
--
--  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.

module Darcs.UI.Commands.Convert.Darcs2 ( convertDarcs2 ) where

import Control.Monad ( when, unless )
import qualified Data.ByteString as B
import Data.Maybe ( catMaybes )
import Data.List ( lookup )
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.Progress ( progressFL )
import Darcs.Patch.RepoType ( IsRepoType(..), RebaseType(..), RepoType(..) )
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(..)
    , bunchFL
    , concatFL
    , foldFL_M
    , mapFL_FL
    , mapRL
    )
import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), mapSeal )

import Darcs.Repository
    ( RepoJob(..)
    , Repository
    , applyToWorking
    , createRepositoryV2
    , finalizeRepositoryChanges
    , invalidateIndex
    , readRepo
    , revertRepositoryChanges
    , withRepositoryLocation
    , withUMaskFlag
    )
import qualified Darcs.Repository as R ( setScriptsExecutable )
import Darcs.Repository.Flags ( Compression(..), UpdatePending(..) )
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.Completion ( noArgs )
import Darcs.UI.Flags
    ( verbosity, useCache, umask, withWorkingDir, patchIndexNo
    , DarcsFlag, withNewRepo
    , quiet
    )
import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O

import Darcs.Util.External ( 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 = String -> Doc
text forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
 [ String
"This command converts a repository that uses the old patch semantics"
 , String
"`darcs-1` to a new repository with current `darcs-2` semantics."
 , String
""
 , String
convertDarcs2Help'
 ]

-- | This part of the help is split out because it is used twice: in
-- the help string, and in the prompt for confirmation.
convertDarcs2Help' :: String
convertDarcs2Help' :: String
convertDarcs2Help' = [String] -> String
unlines
 [ String
"WARNING: the repository produced by this command is not understood by"
 , String
"Darcs 1.x, and patches cannot be exchanged between repositories in"
 , String
"darcs-1 and darcs-2 formats."
 , String
""
 , String
"Furthermore, repositories created by different invocations of"
 , String
"this command SHOULD NOT exchange patches."
 ]

convertDarcs2 :: DarcsCommand
convertDarcs2 :: DarcsCommand
convertDarcs2 = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"darcs-2"
    , commandHelp :: Doc
commandHelp = Doc
convertDarcs2Help
    , commandDescription :: String
commandDescription = String
"Convert darcs-1 repository to the darcs-2 patch format"
    , commandExtraArgs :: Int
commandExtraArgs = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"<SOURCE>", String
"[<DESTINATION>]"]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
toDarcs2
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = \[DarcsFlag]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (NetworkOptions -> WithPatchIndex -> UMask -> a)
convertDarcs2AdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> SetScriptsExecutable -> WithWorkingDir -> a)
convertDarcs2BasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags (forall {a}.
DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
convertDarcs2Opts forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a PatchFormat
convertDarcs2SilentOpts)
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck forall {a}.
DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
convertDarcs2Opts
    }
  where
    convertDarcs2BasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> SetScriptsExecutable -> WithWorkingDir -> a)
convertDarcs2BasicOpts = PrimDarcsOption (Maybe String)
O.newRepo forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption WithWorkingDir
O.withWorkingDir
    convertDarcs2AdvancedOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (NetworkOptions -> WithPatchIndex -> UMask -> a)
convertDarcs2AdvancedOpts = PrimDarcsOption NetworkOptions
O.network forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption WithPatchIndex
O.patchIndexNo forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption UMask
O.umask
    convertDarcs2Opts :: DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
convertDarcs2Opts = forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> SetScriptsExecutable -> WithWorkingDir -> a)
convertDarcs2BasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (NetworkOptions -> WithPatchIndex -> UMask -> a)
convertDarcs2AdvancedOpts
    convertDarcs2SilentOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a PatchFormat
convertDarcs2SilentOpts = forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a PatchFormat
O.patchFormat

toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
toDarcs2 (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts' [String]
args = do
  (String
inrepodir, [DarcsFlag]
opts) <-
    case [String]
args of
      [String
arg1, String
arg2] -> forall (m :: * -> *) a. Monad m => a -> m a
return (String
arg1, String -> [DarcsFlag] -> [DarcsFlag]
withNewRepo String
arg2 [DarcsFlag]
opts')
      [String
arg1] -> forall (m :: * -> *) a. Monad m => a -> m a
return (String
arg1, [DarcsFlag]
opts')
      [String]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"You must provide either one or two arguments."
  AbsoluteOrRemotePath
typed_repodir <- String -> IO AbsoluteOrRemotePath
ioAbsoluteOrRemote String
inrepodir
  let repodir :: String
repodir = forall a. FilePathOrURL a => a -> String
toPath AbsoluteOrRemotePath
typed_repodir

  RepoFormat
format <- String -> IO RepoFormat
identifyRepoFormat String
repodir
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs2 RepoFormat
format) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Repository is already in darcs 2 format."

  String -> IO ()
putStrLn String
convertDarcs2Help'
  let vow :: String
vow = String
"I understand the consequences of my action"
  String -> IO ()
putStrLn String
"Please confirm that you have read and understood the above"
  String
vow' <- String -> IO String
askUser (String
"by typing `" forall a. [a] -> [a] -> [a]
++ String
vow forall a. [a] -> [a] -> [a]
++ String
"': ")
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
vow' forall a. Eq a => a -> a -> Bool
/= String
vow) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"User didn't understand the consequences."

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([DarcsFlag] -> Bool
quiet [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$ String -> IO ()
showMotd String
repodir

  String
mysimplename <- [DarcsFlag] -> String -> IO String
makeRepoName [DarcsFlag]
opts String
repodir
  forall a. UMask -> IO a -> IO a
withUMaskFlag (PrimDarcsOption UMask
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$ String -> IO () -> IO ()
withNewDirectory String
mysimplename forall a b. (a -> b) -> a -> b
$ do
    Repository
  ('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
_repo <- WithWorkingDir
-> WithPatchIndex
-> UseCache
-> IO
     (Repository
        ('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin)
createRepositoryV2
      (PrimDarcsOption WithWorkingDir
withWorkingDir forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption WithPatchIndex
patchIndexNo forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption UseCache
O.useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
    Repository
  ('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
_repo <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT
-> UpdatePending -> IO (Repository rt p wR wU wR)
revertRepositoryChanges Repository
  ('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
_repo UpdatePending
NoUpdatePending

    forall a. UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) String
repodir forall a b. (a -> b) -> a -> b
$ forall a.
(forall wR wU.
 Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
 -> IO a)
-> RepoJob a
V1Job forall a b. (a -> b) -> a -> b
$ \Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
other -> do
      PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
theirstuff <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
other
      let patches :: FL
  (PatchInfoAndG ('RepoType 'NoRebase) (Named (RepoPatchV2 Prim)))
  Origin
  wR
patches = forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL (forall wX wY.
Named (RepoPatchV1 Prim) wX wY
-> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY
convertNamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully) forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
theirstuff
          outOfOrderTags :: [(PatchInfo, [PatchInfo])]
outOfOrderTags = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL forall {p :: * -> * -> *} {rt :: RepoType} {wX} {wY}.
HasDeps p =>
PatchInfoAndG rt p wX wY -> Maybe (PatchInfo, [PatchInfo])
oot forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
theirstuff
              where oot :: PatchInfoAndG rt p wX wY -> Maybe (PatchInfo, [PatchInfo])
oot PatchInfoAndG rt p wX wY
t = if PatchInfo -> Bool
isTag (forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAndG rt p wX wY
t) Bool -> Bool -> Bool
&& forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAndG rt p wX wY
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall (rt :: RepoType) (p :: * -> * -> *) wS wX.
PatchSet rt p wS wX -> [PatchInfo]
inOrderTags PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
theirstuff
                            then forall a. a -> Maybe a
Just (forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAndG rt p wX wY
t, forall (p :: * -> * -> *) wX wY.
HasDeps p =>
p wX wY -> [PatchInfo]
getdeps forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully PatchInfoAndG rt p wX wY
t)
                            else forall a. Maybe a
Nothing
          fixDep :: PatchInfo -> [PatchInfo]
fixDep PatchInfo
p = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PatchInfo
p [(PatchInfo, [PatchInfo])]
outOfOrderTags of
                     Just [PatchInfo]
d -> PatchInfo
p forall a. a -> [a] -> [a]
: 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
primV1toV2 = forall x y. Prim x y -> Prim x y
V2.Prim forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x y. Prim x y -> Prim x y
V1.unPrim
          convertOne :: RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY
          convertOne :: forall wX wY. RepoPatchV1 wX wY -> FL (RepoPatchV2 Prim) wX wY
convertOne RepoPatchV1 wX wY
x | forall (prim :: * -> * -> *) wA wB. RepoPatchV1 prim wA wB -> Bool
V1.isMerger RepoPatchV1 wX wY
x =
            let ex :: FL Prim wX wY
ex = forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall {x} {y}. Prim x y -> Prim x y
primV1toV2 (forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect RepoPatchV1 wX wY
x) in
            case forall (prim :: * -> * -> *) wX.
PrimPatch prim =>
[Sealed (FL prim wX)] -> Maybe (FlippedSeal (RepoPatchV2 prim) wX)
mergeUnravelled forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal (forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall {x} {y}. Prim x y -> Prim x y
primV1toV2)) forall a b. (a -> b) -> a -> b
$ 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 forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect RepoPatchV2 Prim wX wY
y forall (p :: * -> * -> *) wA wC wB.
Eq2 p =>
p wA wC -> p wB wC -> EqCheck wA wB
=/\= FL Prim wX wY
ex of
                 EqCheck wX wX
IsEq -> RepoPatchV2 Prim wX wY
y forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
                 EqCheck wX wX
NotEq ->
                     forall a. Doc -> a -> a
traceDoc (String -> Doc
text String
"lossy conversion:" Doc -> Doc -> Doc
$$
                               forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch RepoPatchV1 wX wY
x) forall a b. (a -> b) -> a -> b
$
                     forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall (prim :: * -> * -> *) wX wY.
prim wX wY -> RepoPatchV2 prim wX wY
V2.Normal FL Prim wX wY
ex
             Maybe (FlippedSeal (RepoPatchV2 Prim) wY)
Nothing -> forall a. Doc -> a -> a
traceDoc (String -> Doc
text
                                  String
"lossy conversion of complicated conflict:" Doc -> Doc -> Doc
$$
                                  forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch RepoPatchV1 wX wY
x) forall a b. (a -> b) -> a -> b
$
                        forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL 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) = forall (prim :: * -> * -> *) wX wY.
prim wX wY -> RepoPatchV2 prim wX wY
V2.Normal (forall {x} {y}. Prim x y -> Prim x y
primV1toV2 Prim wX wY
x) forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
          convertOne RepoPatchV1 wX wY
_ = forall a. HasCallStack => String -> a
error String
"impossible case"
          convertFL :: FL RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY
          convertFL :: forall wX wY.
FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
convertFL = forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall wX wY. RepoPatchV1 wX wY -> FL (RepoPatchV2 Prim) wX wY
convertOne
          convertNamed :: Named RepoPatchV1 wX wY
                       -> PatchInfoAnd ('RepoType 'NoRebase) RepoPatchV2 wX wY
          convertNamed :: forall wX wY.
Named (RepoPatchV1 Prim) wX wY
-> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY
convertNamed Named (RepoPatchV1 Prim) wX wY
n = forall (p :: * -> * -> *) wX wY (rt :: RepoType).
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG rt p wX wY
n2pia forall a b. (a -> b) -> a -> b
$
                           forall (p :: * -> * -> *) wX wY.
PatchInfo -> [PatchInfo] -> FL p wX wY -> Named p wX wY
NamedP
                            (PatchInfo -> PatchInfo
convertInfo forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. Named p wX wY -> PatchInfo
patch2patchinfo Named (RepoPatchV1 Prim) wX wY
n)
                            (forall a b. (a -> b) -> [a] -> [b]
map PatchInfo -> PatchInfo
convertInfo forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatchInfo -> [PatchInfo]
fixDep forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY.
HasDeps p =>
p wX wY -> [PatchInfo]
getdeps Named (RepoPatchV1 Prim) wX wY
n)
                            (forall wX wY.
FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
convertFL forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. Named p wX wY -> FL p wX wY
patchcontents Named (RepoPatchV1 Prim) wX wY
n)
          convertInfo :: PatchInfo -> PatchInfo
convertInfo PatchInfo
n | PatchInfo
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall (rt :: RepoType) (p :: * -> * -> *) wS wX.
PatchSet rt p wS wX -> [PatchInfo]
inOrderTags PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
theirstuff = PatchInfo
n
                        | Bool
otherwise = forall b a. b -> (a -> b) -> Maybe a -> b
maybe PatchInfo
n (\String
t -> PatchInfo -> String -> PatchInfo
piRename PatchInfo
n (String
"old tag: "forall a. [a] -> [a] -> [a]
++String
t)) forall a b. (a -> b) -> a -> b
$ PatchInfo -> Maybe String
piTag PatchInfo
n

      -- Note: we use bunchFL so we can commit every 100 patches
      Repository ('RepoType 'NoRebase) (RepoPatchV2 Prim) wR wR wR
_ <- forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> Repository rt p wX wX wX
-> FL (FL (PatchInfoAnd rt p)) wX wY
-> IO (Repository rt p wY wY wY)
applyAll [DarcsFlag]
opts Repository
  ('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
_repo forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wX wY.
Int -> FL a wX wY -> FL (FL a) wX wY
bunchFL Int
100 forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Converting patch" FL
  (PatchInfoAndG ('RepoType 'NoRebase) (Named (RepoPatchV2 Prim)))
  Origin
  wR
patches
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable [DarcsFlag]
opts forall a. Eq a => a -> a -> Bool
== SetScriptsExecutable
O.YesSetScriptsExecutable)
        IO ()
R.setScriptsExecutable

      -- Copy over the prefs file
      (String -> Cachable -> IO ByteString
fetchFilePS (String
repodir String -> String -> String
</> String
prefsFilePath) Cachable
Uncachable forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ByteString -> IO ()
B.writeFile String
prefsFilePath)
       forall a. IO a -> IO a -> IO a
`catchall` forall (m :: * -> *) a. Monad m => a -> m a
return ()

      [DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts String
"converting"
  where
    applyOne :: (RepoPatch p, ApplyState p ~ Tree)
             => [DarcsFlag]
             -> W2 (Repository rt p wR) wX
             -> PatchInfoAnd rt p wX wY
             -> IO (W2 (Repository rt p wR) wY)
    applyOne :: forall (p :: * -> * -> *) (rt :: RepoType) wR wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> W2 (Repository rt p wR) wX
-> PatchInfoAnd rt p wX wY
-> IO (W2 (Repository rt p wR) wY)
applyOne [DarcsFlag]
opts (W2 Repository rt p wR wX wX
_repo) PatchInfoAnd rt p wX wY
x = do
      Repository rt p wR wX wY
_repo <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdatePending
-> PatchInfoAnd rt p wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatch_ ([DarcsFlag] -> UpdatePristine
updatePristine [DarcsFlag]
opts) Repository rt p wR wX wX
_repo
        Compression
GzipCompression (PrimDarcsOption Verbosity
verbosity forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) ([DarcsFlag] -> UpdatePending
updatePending [DarcsFlag]
opts) PatchInfoAnd rt p wX wY
x
      Repository rt p wR wY wY
_repo <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking Repository rt p wR wX wY
_repo (PrimDarcsOption Verbosity
verbosity forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect PatchInfoAnd rt p wX wY
x)
      forall t. t -> IO ()
invalidateIndex Repository rt p wR wY wY
_repo
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall (r :: * -> * -> *) wX. r wX wX -> W2 r wX
W2 Repository rt p wR wY wY
_repo)

    applySome :: [DarcsFlag]
-> W3 (Repository rt p) wR
-> FL (PatchInfoAndG rt (Named p)) wR wX
-> IO (W3 (Repository rt p) wX)
applySome [DarcsFlag]
opts (W3 Repository rt p wR wR wR
_repo) FL (PatchInfoAndG rt (Named p)) wR wX
xs = do
      Repository rt p wR wX wX
_repo <- forall (r :: * -> * -> *) wX. W2 r wX -> r wX wX
unW2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (forall (p :: * -> * -> *) (rt :: RepoType) wR wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> W2 (Repository rt p wR) wX
-> PatchInfoAnd rt p wX wY
-> IO (W2 (Repository rt p wR) wY)
applyOne [DarcsFlag]
opts) (forall (r :: * -> * -> *) wX. r wX wX -> W2 r wX
W2 Repository rt p wR wR wR
_repo) FL (PatchInfoAndG rt (Named p)) wR wX
xs
      -- commit after applying a bunch of patches
      Repository rt p wX wX wX
_repo <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdatePending -> Compression -> IO (Repository rt p wT wU wT)
finalizeRepositoryChanges Repository rt p wR wX wX
_repo ([DarcsFlag] -> UpdatePending
updatePending [DarcsFlag]
opts) Compression
GzipCompression
      Repository rt p wX wX wX
_repo <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT
-> UpdatePending -> IO (Repository rt p wR wU wR)
revertRepositoryChanges Repository rt p wX wX wX
_repo ([DarcsFlag] -> UpdatePending
updatePending [DarcsFlag]
opts)
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall (r :: * -> * -> * -> *) wX. r wX wX wX -> W3 r wX
W3 Repository rt p wX wX wX
_repo)

    applyAll :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
             => [DarcsFlag]
             -> Repository rt p wX wX wX
             -> FL (FL (PatchInfoAnd rt p)) wX wY
             -> IO (Repository rt p wY wY wY)
    applyAll :: forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> Repository rt p wX wX wX
-> FL (FL (PatchInfoAnd rt p)) wX wY
-> IO (Repository rt p wY wY wY)
applyAll [DarcsFlag]
opts Repository rt p wX wX wX
r FL (FL (PatchInfoAnd rt p)) wX wY
xss = forall (r :: * -> * -> * -> *) wX. W3 r wX -> r wX wX wX
unW3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (forall {p :: * -> * -> *} {rt :: RepoType} {wR} {wX}.
(ApplyState p ~ ApplyState (PrimOf p), IsRepoType rt,
 Annotate (PrimOf p), Effect p, Check p, Conflict p, FromPrim p,
 IsHunk p, Merge p, PrimPatchBase p, Summary p, ToPrim p, Unwind p,
 Commute p, Eq2 p, PatchInspect p, RepairToFL p, ReadPatch p,
 ShowPatch p, ShowContextPatch p, PatchListFormat p,
 ApplyState p ~ Tree) =>
[DarcsFlag]
-> W3 (Repository rt p) wR
-> FL (PatchInfoAndG rt (Named p)) wR wX
-> IO (W3 (Repository rt p) wX)
applySome [DarcsFlag]
opts) (forall (r :: * -> * -> * -> *) wX. r wX wX wX -> W3 r wX
W3 Repository rt p wX wX wX
r) FL (FL (PatchInfoAnd rt p)) wX wY
xss

    updatePristine :: [DarcsFlag] -> UpdatePristine
    updatePristine :: [DarcsFlag] -> UpdatePristine
updatePristine [DarcsFlag]
opts =
      case PrimDarcsOption WithWorkingDir
withWorkingDir forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
        WithWorkingDir
O.WithWorkingDir -> UpdatePristine
UpdatePristine
        -- this should not be necessary but currently is, because
        -- some commands (e.g. send) cannot cope with a missing pristine
        -- even if the repo is marked as having no working tree
        WithWorkingDir
O.NoWorkingDir -> {- DontUpdatePristineNorRevert -}UpdatePristine
UpdatePristine

-- | Need this to make 'foldFL_M' work with a function that changes
-- the last two (identical) witnesses at the same time.
newtype W2 r wX = W2 {forall (r :: * -> * -> *) wX. W2 r wX -> r wX wX
unW2 :: r wX wX}

-- | Similarly for when the function changes all three witnesses.
newtype W3 r wX = W3 {forall (r :: * -> * -> * -> *) wX. W3 r wX -> r wX wX wX
unW3 :: r wX wX wX}

makeRepoName :: [DarcsFlag] -> FilePath -> IO String
makeRepoName :: [DarcsFlag] -> String -> IO String
makeRepoName [DarcsFlag]
opts String
d =
  case PrimDarcsOption (Maybe String)
O.newRepo forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
    Just String
n -> do
      Bool
exists <- String -> IO Bool
doesDirectoryExist String
n
      Bool
file_exists <- String -> IO Bool
doesFileExist String
n
      if Bool
exists Bool -> Bool -> Bool
|| Bool
file_exists
        then forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Directory or file named '" forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
"' already exists."
        else forall (m :: * -> *) a. Monad m => a -> m a
return String
n
    Maybe String
Nothing ->
      case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'.') forall a b. (a -> b) -> a -> b
$
           forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$
           forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
'/' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
':') forall a b. (a -> b) -> a -> b
$
           forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'/') forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse String
d of
        String
"" -> String -> IO String
modifyRepoName String
"anonymous_repo"
        String
base -> String -> IO String
modifyRepoName String
base

modifyRepoName :: String -> IO String
modifyRepoName :: String -> IO String
modifyRepoName String
name =
    if forall a. [a] -> a
head String
name forall a. Eq a => a -> a -> Bool
== Char
'/'
    then String -> Int -> IO String
mrn String
name (-Int
1)
    else do String
cwd <- IO String
getCurrentDirectory
            String -> Int -> IO String
mrn (String
cwd forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ String
name) (-Int
1)
 where
  mrn :: String -> Int -> IO String
  mrn :: String -> Int -> IO String
mrn String
n Int
i = do
    Bool
exists <- String -> IO Bool
doesDirectoryExist String
thename
    Bool
file_exists <- String -> IO Bool
doesFileExist String
thename
    if Bool -> Bool
not Bool
exists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
file_exists
       then do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i forall a. Eq a => a -> a -> Bool
/= -Int
1) forall a b. (a -> b) -> a -> b
$
                    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Directory '"forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++
                               String
"' already exists, creating repository as '"forall a. [a] -> [a] -> [a]
++
                               String
thename forall a. [a] -> [a] -> [a]
++String
"'"
               forall (m :: * -> *) a. Monad m => a -> m a
return String
thename
       else String -> Int -> IO String
mrn String
n forall a b. (a -> b) -> a -> b
$ Int
iforall a. Num a => a -> a -> a
+Int
1
    where thename :: String
thename = if Int
i forall a. Eq a => a -> a -> Bool
== -Int
1 then String
n else String
nforall a. [a] -> [a] -> [a]
++String
"_"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
i