{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.Convert.Export ( convertExport ) where
import Darcs.Prelude hiding ( readFile, lex )
import Control.Exception (finally)
import Control.Monad (forM_, unless, void, when)
import Control.Monad.State.Strict (gets)
import Control.Monad.Trans (liftIO)
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.ByteString.Lazy.UTF8 as BLU
import Data.Char (isSpace)
import Data.IORef (modifyIORef, newIORef, readIORef)
import Data.Maybe (catMaybes, fromJust)
import System.Time (toClockTime)
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )
import Darcs.Patch ( RepoPatch, apply, effect, listTouchedFiles )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Effect ( Effect )
import Darcs.Patch.Witnesses.Ordered
( FL(..)
, nullFL
)
import Darcs.Patch.Witnesses.Sealed
( FlippedSeal(..)
, flipSeal
, unsealFlipped
)
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )
import Darcs.Patch.Info
( PatchInfo
, isTag
, piAuthor
, piDate
, piLog
, piName
)
import Darcs.Patch.RepoType ( IsRepoType(..) )
import Darcs.Patch.Set ( patchSet2FL, inOrderTags )
import Darcs.Repository
( RepoJob(..)
, Repository
, readRepo
, repoCache
, withRepository
)
import Darcs.Repository.Cache (HashedDir(HashedPristineDir))
import Darcs.Repository.Pristine (readHashedPristineRoot)
import Darcs.Repository.HashedIO (cleanHashdir)
import Darcs.Repository.Paths (pristineDirPath)
import Darcs.UI.Commands
( DarcsCommand(..)
, amInRepository
, nodefaults
, withStdOpts
)
import Darcs.UI.Commands.Convert.Util
( Marks
, addMark
, emptyMarks
, getMark
, lastMark
, readMarks
, writeMarks
, patchHash
)
import Darcs.UI.Completion (noArgs)
import Darcs.UI.Flags ( DarcsFlag , useCache )
import Darcs.UI.Options
( (?)
, (^)
, defaultFlags
, ocheck
, odesc
, parseFlags
)
import qualified Darcs.UI.Options.All as O
import Darcs.Util.DateTime ( formatDateTime, fromClockTime )
import Darcs.Util.Path
( AbsolutePath
, AnchoredPath(..)
, anchorPath
, appendPath
)
import Darcs.Util.Printer ( Doc, text )
import Darcs.Util.Tree
( Tree
, emptyTree
, findTree
, listImmediate
)
import Darcs.Util.Tree.Hashed ( hashedTreeIO )
import Darcs.Util.Tree.Monad ( TreeIO )
import qualified Darcs.Util.Tree.Monad as T
( directoryExists
, fileExists
, readFile
, tree
)
convertExportHelp :: Doc
convertExportHelp :: Doc
convertExportHelp = [Char] -> Doc
text forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
[ [Char]
"This command enables you to export darcs repositories into git."
, [Char]
""
, [Char]
"For a one-time export you can use the recipe:"
, [Char]
""
, [Char]
" $ cd repo"
, [Char]
" $ git init ../mirror"
, [Char]
" $ darcs convert export | (cd ../mirror && git fast-import)"
, [Char]
""
, [Char]
"For incremental export using marksfiles:"
, [Char]
""
, [Char]
" $ cd repo"
, [Char]
" $ git init ../mirror"
, [Char]
" $ touch ../mirror/git.marks"
, [Char]
" $ darcs convert export --read-marks darcs.marks --write-marks darcs.marks"
, [Char]
" | (cd ../mirror && git fast-import --import-marks=git.marks --export-marks=git.marks)"
, [Char]
""
, [Char]
"In the case of incremental export, be careful to never amend, delete or"
, [Char]
"reorder patches in the source darcs repository."
, [Char]
""
, [Char]
"Also, be aware that exporting a darcs repo to git will not be exactly"
, [Char]
"faithful in terms of history if the darcs repository contains conflicts."
, [Char]
""
, [Char]
"Limitations:"
, [Char]
""
, [Char]
" * Empty directories are not supported by the fast-export protocol."
, [Char]
" * Unicode filenames are currently not correctly handled."
, [Char]
" See http://bugs.darcs.net/issue2359 ."
]
convertExport :: DarcsCommand
convertExport :: DarcsCommand
convertExport = DarcsCommand
{ commandProgramName :: [Char]
commandProgramName = [Char]
"darcs"
, commandName :: [Char]
commandName = [Char]
"export"
, commandHelp :: Doc
commandHelp = Doc
convertExportHelp
, commandDescription :: [Char]
commandDescription = [Char]
"Export a darcs repository to a git-fast-import stream"
, commandExtraArgs :: Int
commandExtraArgs = Int
0
, commandExtraArgHelp :: [[Char]]
commandExtraArgHelp = []
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
fastExport
, commandPrereq :: [DarcsFlag] -> IO (Either [Char] ())
commandPrereq = [DarcsFlag] -> IO (Either [Char] ())
amInRepository
, 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
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
convertExportAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> a)
convertExportBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
(Maybe [Char]
-> Maybe [Char]
-> Maybe [Char]
-> Maybe StdCmdAction
-> Verbosity
-> NetworkOptions
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
convertExportOpts
, commandCheckOptions :: [DarcsFlag] -> [[Char]]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [[Char]]
ocheck forall {a}.
DarcsOption
a
(Maybe [Char]
-> Maybe [Char]
-> Maybe [Char]
-> Maybe StdCmdAction
-> Verbosity
-> NetworkOptions
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
convertExportOpts
}
where
convertExportBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> a)
convertExportBasicOpts = PrimDarcsOption (Maybe [Char])
O.repoDir forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ forall a. DarcsOption a (Maybe [Char] -> Maybe [Char] -> a)
O.marks
convertExportAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
convertExportAdvancedOpts = forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
O.network
convertExportOpts :: DarcsOption
a
(Maybe [Char]
-> Maybe [Char]
-> Maybe [Char]
-> Maybe StdCmdAction
-> Verbosity
-> NetworkOptions
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
convertExportOpts = forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> a)
convertExportBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall {a}. PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
convertExportAdvancedOpts
fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
fastExport (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [[Char]]
_ = do
Marks
marks <- case forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption (Maybe [Char])
O.readMarks [DarcsFlag]
opts of
Maybe [Char]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Marks
emptyMarks
Just [Char]
f -> [Char] -> IO Marks
readMarks [Char]
f
Marks
newMarks <-
forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$ forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repo -> forall (rt :: RepoType) (p :: * -> * -> *) r u.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p r u r -> Marks -> IO Marks
fastExport' Repository rt p wR wU wR
repo Marks
marks
case forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption (Maybe [Char])
O.writeMarks [DarcsFlag]
opts of
Maybe [Char]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just [Char]
f -> [Char] -> Marks -> IO ()
writeMarks [Char]
f Marks
newMarks
fastExport' :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p r u r -> Marks -> IO Marks
fastExport' :: forall (rt :: RepoType) (p :: * -> * -> *) r u.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p r u r -> Marks -> IO Marks
fastExport' Repository rt p r u r
repo Marks
marks = do
[Char] -> IO ()
putStrLn [Char]
"progress (reading repository)"
PatchSet rt p Origin r
patchset <- 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 rt p r u r
repo
IORef Marks
marksref <- forall a. a -> IO (IORef a)
newIORef Marks
marks
let patches :: FL (PatchInfoAnd rt p) Origin r
patches = forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet rt p Origin r
patchset
tags :: [PatchInfo]
tags = forall (rt :: RepoType) (p :: * -> * -> *) wS wX.
PatchSet rt p wS wX -> [PatchInfo]
inOrderTags PatchSet rt p Origin r
patchset
mark :: (PatchInfoAnd rt p) x y -> Int -> TreeIO ()
mark :: forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> Int -> TreeIO ()
mark PatchInfoAnd rt p x y
p Int
n = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"mark :" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
n
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Marks
marksref forall a b. (a -> b) -> a -> b
$ \Marks
m -> Marks -> Int -> ByteString -> Marks
addMark Marks
m Int
n (forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash PatchInfoAnd rt p x y
p)
checkOne :: (RepoPatch p, ApplyState p ~ Tree)
=> Int -> (PatchInfoAnd rt p) x y -> TreeIO ()
checkOne :: forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int -> PatchInfoAnd rt p x y -> TreeIO ()
checkOne Int
n PatchInfoAnd rt p x y
p = do forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply PatchInfoAnd rt p x y
p
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p x y
p Bool -> Bool -> Bool
||
(Marks -> Int -> Maybe ByteString
getMark Marks
marks Int
n forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash PatchInfoAnd rt p x y
p))) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"FATAL: Marks do not correspond: expected " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> [Char]
show (Marks -> Int -> Maybe ByteString
getMark Marks
marks Int
n) forall a. [a] -> [a] -> [a]
++ [Char]
", got " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BC.unpack (forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash PatchInfoAnd rt p x y
p)
check :: (RepoPatch p, ApplyState p ~ Tree)
=> Int -> FL (PatchInfoAnd rt p) x y -> TreeIO (Int, FlippedSeal( FL (PatchInfoAnd rt p)) y)
check :: forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
check Int
_ FL (PatchInfoAnd rt p) x y
NilFL = forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1, forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
check Int
n allps :: FL (PatchInfoAnd rt p) x y
allps@(PatchInfoAnd rt p x wY
p:>:FL (PatchInfoAnd rt p) wY y
ps)
| Int
n forall a. Ord a => a -> a -> Bool
<= Marks -> Int
lastMark Marks
marks = forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int -> PatchInfoAnd rt p x y -> TreeIO ()
checkOne Int
n PatchInfoAnd rt p x wY
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
check (forall (p :: * -> * -> *) (rt :: RepoType) x y.
Effect p =>
[PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next [PatchInfo]
tags Int
n PatchInfoAnd rt p x wY
p) FL (PatchInfoAnd rt p) wY y
ps
| Int
n forall a. Ord a => a -> a -> Bool
> Marks -> Int
lastMark Marks
marks = forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n, forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd rt p) x y
allps)
| Marks -> Int
lastMark Marks
marks forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1, forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd rt p) x y
allps)
| Bool
otherwise = forall a. HasCallStack => a
undefined
((Int
n, FlippedSeal (FL (PatchInfoAnd rt p)) r
patches'), Tree IO
tree') <- forall a. TreeIO a -> Tree IO -> [Char] -> IO (a, Tree IO)
hashedTreeIO (forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
check Int
1 FL (PatchInfoAnd rt p) Origin r
patches) forall (m :: * -> *). Tree m
emptyTree [Char]
pristineDirPath
let patches'' :: FL (PatchInfoAnd rt p) wB wC
patches'' = forall (a :: * -> * -> *) b wZ.
(forall wX wY. a wX wY -> b) -> FlippedSeal a wZ -> b
unsealFlipped forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP FlippedSeal (FL (PatchInfoAnd rt p)) r
patches'
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. TreeIO a -> Tree IO -> [Char] -> IO (a, Tree IO)
hashedTreeIO (forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
[PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO ()
dumpPatches [PatchInfo]
tags forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> Int -> TreeIO ()
mark Int
n forall {wB} {wC}. FL (PatchInfoAnd rt p) wB wC
patches'') Tree IO
tree' [Char]
pristineDirPath
forall a. IORef a -> IO a
readIORef IORef Marks
marksref
forall a b. IO a -> IO b -> IO a
`finally` do
[Char] -> IO ()
putStrLn [Char]
"progress (cleaning up)"
Maybe PristineHash
current <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Maybe PristineHash)
readHashedPristineRoot Repository rt p r u r
repo
Cache -> HashedDir -> [PristineHash] -> IO ()
cleanHashdir (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p r u r
repo) HashedDir
HashedPristineDir forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe PristineHash
current]
[Char] -> IO ()
putStrLn [Char]
"progress done"
dumpPatches :: (RepoPatch p, ApplyState p ~ Tree)
=> [PatchInfo]
-> (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ())
-> Int -> FL (PatchInfoAnd rt p) x y -> TreeIO ()
dumpPatches :: forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
[PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO ()
dumpPatches [PatchInfo]
_ forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
_ Int
_ FL (PatchInfoAnd rt p) x y
NilFL = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"progress (patches converted)"
dumpPatches [PatchInfo]
tags forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark Int
n (PatchInfoAnd rt p x wY
p:>:FL (PatchInfoAnd rt p) wY y
ps) = do
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply PatchInfoAnd rt p x wY
p
if forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p x wY
p Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
> Int
0
then forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpTag PatchInfoAnd rt p x wY
p Int
n
else do forall (rt :: RepoType) (p :: * -> * -> *) x y.
(forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpPatch forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark PatchInfoAnd rt p x wY
p Int
n
[AnchoredPath] -> TreeIO ()
dumpFiles forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles PatchInfoAnd rt p x wY
p
forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
[PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO ()
dumpPatches [PatchInfo]
tags forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark (forall (p :: * -> * -> *) (rt :: RepoType) x y.
Effect p =>
[PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next [PatchInfo]
tags Int
n PatchInfoAnd rt p x wY
p) FL (PatchInfoAnd rt p) wY y
ps
dumpTag :: (PatchInfoAnd rt p) x y -> Int -> TreeIO ()
dumpTag :: forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpTag PatchInfoAnd rt p x y
p Int
n =
[ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"progress TAG " forall a. [a] -> [a] -> [a]
++ forall {rt :: RepoType} {p :: * -> * -> *} {wA} {wB}.
PatchInfoAndG rt p wA wB -> [Char]
cleanTagName PatchInfoAnd rt p x y
p
, [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"tag " forall a. [a] -> [a] -> [a]
++ forall {rt :: RepoType} {p :: * -> * -> *} {wA} {wB}.
PatchInfoAndG rt p wA wB -> [Char]
cleanTagName PatchInfoAnd rt p x y
p
, [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"from :" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
n forall a. Num a => a -> a -> a
- Int
1)
, [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]
"tagger", forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> [Char]
patchAuthor PatchInfoAnd rt p x y
p, forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> [Char]
patchDate PatchInfoAnd rt p x y
p]
, [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"data "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ByteString -> Int64
BL.length (forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p) forall a. Num a => a -> a -> a
- Int64
3)
, Int64 -> ByteString -> ByteString
BL.drop Int64
4 forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p ]
where
cleanTagName :: PatchInfoAndG rt p wA wB -> [Char]
cleanTagName = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
cleanup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
4 forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> [Char]
piName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info
where cleanup :: Char -> Char
cleanup Char
x | Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
bad = Char
'_'
| Bool
otherwise = Char
x
bad :: String
bad :: [Char]
bad = [Char]
" ~^:"
dumpFiles :: [AnchoredPath] -> TreeIO ()
dumpFiles :: [AnchoredPath] -> TreeIO ()
dumpFiles [AnchoredPath]
files = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [AnchoredPath]
files forall a b. (a -> b) -> a -> b
$ \AnchoredPath
file -> do
let quotedPath :: [Char]
quotedPath = [Char] -> [Char]
quotePath forall a b. (a -> b) -> a -> b
$ [Char] -> AnchoredPath -> [Char]
anchorPath [Char]
"" AnchoredPath
file
Bool
isfile <- forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
T.fileExists AnchoredPath
file
Bool
isdir <- forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
T.directoryExists AnchoredPath
file
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isfile forall a b. (a -> b) -> a -> b
$ do ByteString
bits <- forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m ByteString
T.readFile AnchoredPath
file
[ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"M 100644 inline " forall a. [a] -> [a] -> [a]
++ [Char]
quotedPath
, [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"data " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ByteString -> Int64
BL.length ByteString
bits)
, ByteString
bits ]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isdir forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"D " forall a. [a] -> [a] -> [a]
++ [Char]
quotedPath
Tree IO
tt <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall (m :: * -> *). TreeState m -> Tree m
T.tree
let subs :: [AnchoredPath]
subs = [ AnchoredPath
file AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
n | (Name
n, TreeItem IO
_) <-
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree Tree IO
tt AnchoredPath
file ]
[AnchoredPath] -> TreeIO ()
dumpFiles [AnchoredPath]
subs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isfile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isdir) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"D " forall a. [a] -> [a] -> [a]
++ [Char]
quotedPath
where
quotePath :: FilePath -> String
quotePath :: [Char] -> [Char]
quotePath [Char]
path = case forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ([Char], Bool) -> ([Char], Bool)
escapeChars ([Char]
"", Bool
False) [Char]
path of
([Char]
_, Bool
False) -> [Char]
path
([Char]
path', Bool
True) -> [Char] -> [Char]
quote [Char]
path'
quote :: [Char] -> [Char]
quote [Char]
str = [Char]
"\"" forall a. [a] -> [a] -> [a]
++ [Char]
str forall a. [a] -> [a] -> [a]
++ [Char]
"\""
escapeChars :: Char -> ([Char], Bool) -> ([Char], Bool)
escapeChars Char
c ([Char]
processed, Bool
haveEscaped) = case Char -> ([Char], Bool)
escapeChar Char
c of
([Char]
escaped, Bool
didEscape) ->
([Char]
escaped forall a. [a] -> [a] -> [a]
++ [Char]
processed, Bool
didEscape Bool -> Bool -> Bool
|| Bool
haveEscaped)
escapeChar :: Char -> ([Char], Bool)
escapeChar Char
c = case Char
c of
Char
'\n' -> ([Char]
"\\n", Bool
True)
Char
'\r' -> ([Char]
"\\r", Bool
True)
Char
'"' -> ([Char]
"\\\"", Bool
True)
Char
'\\' -> ([Char]
"\\\\", Bool
True)
Char
_ -> ([Char
c], Bool
False)
dumpPatch :: (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ())
-> (PatchInfoAnd rt p) x y -> Int
-> TreeIO ()
dumpPatch :: forall (rt :: RepoType) (p :: * -> * -> *) x y.
(forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpPatch forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark PatchInfoAnd rt p x y
p Int
n =
do [ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"progress " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
n forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ PatchInfo -> [Char]
piName (forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p)
, ByteString
"commit refs/heads/master" ]
forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark PatchInfoAnd rt p x y
p Int
n
[ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"committer " forall a. [a] -> [a] -> [a]
++ forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> [Char]
patchAuthor PatchInfoAnd rt p x y
p forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> [Char]
patchDate PatchInfoAnd rt p x y
p
, [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"data " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ByteString -> Int64
BL.length forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p)
, forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p ]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ [ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString forall a b. (a -> b) -> a -> b
$ [Char]
"from :" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
n forall a. Num a => a -> a -> a
- Int
1) ]
dumpBits :: [BL.ByteString] -> TreeIO ()
dumpBits :: [ByteString] -> TreeIO ()
dumpBits = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
BLC.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> ByteString
BL.intercalate ByteString
"\n"
patchAuthor :: (PatchInfoAnd rt p) x y -> String
patchAuthor :: forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> [Char]
patchAuthor PatchInfoAnd rt p x y
p
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
author = [Char] -> [Char]
unknownEmail [Char]
"unknown"
| Bool
otherwise = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'<') [Char]
author of
([Char]
"", [Char]
email) -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'@') (forall a. [a] -> [a]
tail [Char]
email) of
([Char]
n, [Char]
"") -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'>') [Char]
n of
([Char]
name, [Char]
_) -> [Char] -> [Char]
unknownEmail [Char]
name
([Char]
user, [Char]
rest) -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
'>') (forall a. [a] -> [a]
tail [Char]
rest) of
([Char]
dom, [Char]
_) -> [Char] -> [Char] -> [Char]
mkAuthor [Char]
user forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
emailPad ([Char]
user forall a. [a] -> [a] -> [a]
++ [Char]
"@" forall a. [a] -> [a] -> [a]
++ [Char]
dom)
([Char]
_, [Char]
"") -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'@') [Char]
author of
([Char]
n, [Char]
"") -> [Char] -> [Char]
unknownEmail [Char]
n
([Char]
name, [Char]
_) -> [Char] -> [Char] -> [Char]
mkAuthor [Char]
name forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
emailPad [Char]
author
([Char]
n, [Char]
rest) -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'>') forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [Char]
rest of
([Char]
email, [Char]
_) -> [Char]
n forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
emailPad [Char]
email
where
author :: [Char]
author = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ PatchInfo -> [Char]
piAuthor (forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p)
unknownEmail :: [Char] -> [Char]
unknownEmail = forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> [Char] -> [Char]
mkAuthor [Char]
"<unknown>"
emailPad :: [Char] -> [Char]
emailPad [Char]
email = [Char]
"<" forall a. [a] -> [a] -> [a]
++ [Char]
email forall a. [a] -> [a] -> [a]
++ [Char]
">"
mkAuthor :: [Char] -> [Char] -> [Char]
mkAuthor [Char]
name [Char]
email = [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
email
patchDate :: (PatchInfoAnd rt p) x y -> String
patchDate :: forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> [Char]
patchDate = [Char] -> UTCTime -> [Char]
formatDateTime [Char]
"%s +0000" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClockTime -> UTCTime
fromClockTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. CalendarTime -> ClockTime
toClockTime forall b c a. (b -> c) -> (a -> b) -> a -> c
.
PatchInfo -> CalendarTime
piDate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info
patchMessage :: (PatchInfoAnd rt p) x y -> BLU.ByteString
patchMessage :: forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p = [ByteString] -> ByteString
BL.concat [ [Char] -> ByteString
BLU.fromString (PatchInfo -> [Char]
piName forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p)
, case [[Char]] -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> [[Char]]
piLog forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p of
[Char]
"" -> ByteString
BL.empty
[Char]
plog -> [Char] -> ByteString
BLU.fromString ([Char]
"\n\n" forall a. [a] -> [a] -> [a]
++ [Char]
plog)
]
inOrderTag :: (Effect p) => [PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag :: forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p wX wZ
p = PatchInfo -> Bool
isTag (forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wX wZ
p) Bool -> Bool -> Bool
&& forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wX wZ
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PatchInfo]
tags Bool -> Bool -> Bool
&& forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL (forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect PatchInfoAnd rt p wX wZ
p)
next :: (Effect p) => [PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next :: forall (p :: * -> * -> *) (rt :: RepoType) x y.
Effect p =>
[PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next [PatchInfo]
tags Int
n PatchInfoAnd rt p x y
p = if forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p x y
p then Int
n else Int
n forall a. Num a => a -> a -> a
+ Int
1