{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.Convert.Import ( convertImport ) where
import Darcs.Prelude hiding ( readFile, lex )
import Control.Applicative ((<|>),many)
import Control.Arrow ((&&&), second)
import Control.Monad (unless, void, when)
import Control.Monad.State.Strict (gets, modify)
import Control.Monad.Trans (liftIO)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Attoparsec.ByteString.Char8 ((<?>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.IORef (modifyIORef, newIORef)
import Data.Maybe (fromMaybe)
import Data.Word (Word8)
import System.Directory (doesFileExist)
import System.FilePath.Posix ((</>))
import System.IO (stdin)
import Darcs.Patch.Depends ( getUncovered )
import Darcs.Patch.PatchInfoAnd ( n2pia )
import Darcs.Patch ( PrimOf, RepoPatch, move )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Named ( Named(..), infopatch )
import Darcs.Patch.Witnesses.Ordered
( FL(..)
, RL(..)
, (+<+)
, reverseFL
, reverseRL
)
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft )
import Darcs.Patch.Info ( PatchInfo, patchinfo )
import Darcs.Patch.Prim ( sortCoalesceFL )
import Darcs.Patch.RepoType ( IsRepoType(..) )
import Darcs.Repository
( EmptyRepository(..)
, Repository
, cleanRepository
, createPristineDirectoryTree
, createRepository
, finalizeRepositoryChanges
, readTentativeRepo
, repoCache
, repoLocation
, revertRepositoryChanges
, withUMaskFlag
)
import Darcs.Repository.Diff (treeDiff)
import Darcs.Repository.Flags (Compression(..), DiffAlgorithm(PatienceDiff))
import Darcs.Repository.Hashed (addToTentativeInventory)
import Darcs.Repository.Paths (pristineDirPath, tentativePristinePath)
import Darcs.Repository.Prefs (FileType(..))
import Darcs.Repository.State (readRecorded)
import Darcs.UI.Commands
( DarcsCommand(..)
, nodefaults
, withStdOpts
)
import Darcs.UI.Commands.Convert.Util
( Marks
, addMark
, emptyMarks
, getMark
, patchHash
, updatePending
)
import Darcs.UI.Commands.Util.Tree (treeHasDir, treeHasFile)
import Darcs.UI.Completion (noArgs)
import Darcs.UI.Flags
( DarcsFlag
, patchFormat
, patchIndexNo
, umask
, useCache
, withWorkingDir
)
import Darcs.UI.Options
( (?)
, (^)
, defaultFlags
, ocheck
, odesc
)
import qualified Darcs.UI.Options.All as O
import Darcs.Util.ByteString (decodeLocale, unpackPSFromUTF8)
import Darcs.Util.DateTime
( formatDateTime
, parseDateTime
, startOfTime
)
import Darcs.Util.Global (darcsdir)
import Darcs.Util.Hash (Hash(..), encodeBase16, sha256)
import Darcs.Util.Lock (withNewDirectory)
import Darcs.Util.Path
( AbsolutePath
, AnchoredPath(..)
, appendPath
, floatPath
, makeName
, parent
, darcsdirName
)
import Darcs.Util.Printer ( Doc, text )
import qualified Darcs.Util.Tree as T
import Darcs.Util.Tree
( Tree
, TreeItem(..)
, findTree
, listImmediate
, readBlob
, treeHash
)
import Darcs.Util.Tree.Hashed (darcsAddMissingHashes, hashedTreeIO)
import qualified Darcs.Util.Tree.Monad as TM
import Darcs.Util.Tree.Monad hiding (createDirectory, exists, rename)
convertImportHelp :: Doc
convertImportHelp :: Doc
convertImportHelp = [Char] -> Doc
text forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
[ [Char]
"This command imports git repositories into new darcs repositories."
, [Char]
"Further options are accepted (see `darcs help init`)."
, [Char]
""
, [Char]
"To convert a git repo to a new darcs one you may run:"
, [Char]
""
, [Char]
" $ (cd gitrepo && git fast-export --all -M) | darcs convert import darcsmirror"
, [Char]
""
, [Char]
"WARNING: git repositories with branches will produce weird results,"
, [Char]
" use at your own risks."
, [Char]
""
, [Char]
"Incremental import with marksfiles is currently not supported."
]
convertImport :: DarcsCommand
convertImport :: DarcsCommand
convertImport = DarcsCommand
{ commandProgramName :: [Char]
commandProgramName = [Char]
"darcs"
, commandName :: [Char]
commandName = [Char]
"import"
, commandHelp :: Doc
commandHelp = Doc
convertImportHelp
, commandDescription :: [Char]
commandDescription = [Char]
"Import from a git-fast-export stream into darcs"
, commandExtraArgs :: Int
commandExtraArgs = -Int
1
, commandExtraArgHelp :: [[Char]]
commandExtraArgHelp = [[Char]
"[<DIRECTORY>]"]
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
fastImport
, commandPrereq :: [DarcsFlag] -> IO (Either [Char] ())
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] -> [[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}.
OptSpec DarcsOptDescr DarcsFlag a (WithPatchIndex -> UMask -> a)
convertImportAdvancedOpts
, 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]
-> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
convertImportBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
(Maybe [Char]
-> SetScriptsExecutable
-> PatchFormat
-> WithWorkingDir
-> Maybe StdCmdAction
-> Verbosity
-> WithPatchIndex
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
convertImportOpts
, commandCheckOptions :: [DarcsFlag] -> [[Char]]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [[Char]]
ocheck forall {a}.
DarcsOption
a
(Maybe [Char]
-> SetScriptsExecutable
-> PatchFormat
-> WithWorkingDir
-> Maybe StdCmdAction
-> Verbosity
-> WithPatchIndex
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
convertImportOpts
}
where
convertImportBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe [Char]
-> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
convertImportBasicOpts
= PrimDarcsOption (Maybe [Char])
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 PatchFormat
O.patchFormat
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
convertImportAdvancedOpts :: OptSpec DarcsOptDescr DarcsFlag a (WithPatchIndex -> UMask -> a)
convertImportAdvancedOpts = 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
convertImportOpts :: DarcsOption
a
(Maybe [Char]
-> SetScriptsExecutable
-> PatchFormat
-> WithWorkingDir
-> Maybe StdCmdAction
-> Verbosity
-> WithPatchIndex
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
convertImportOpts = forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe [Char]
-> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
convertImportBasicOpts 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 (WithPatchIndex -> UMask -> a)
convertImportAdvancedOpts
type Marked = Maybe Int
type Branch = B.ByteString
type AuthorInfo = B.ByteString
type Message = B.ByteString
type Content = B.ByteString
type Tag = B.ByteString
data RefId = MarkId Int | HashId B.ByteString | Inline
deriving Int -> RefId -> ShowS
[RefId] -> ShowS
RefId -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RefId] -> ShowS
$cshowList :: [RefId] -> ShowS
show :: RefId -> [Char]
$cshow :: RefId -> [Char]
showsPrec :: Int -> RefId -> ShowS
$cshowsPrec :: Int -> RefId -> ShowS
Show
data CopyRenameNames = Quoted B.ByteString B.ByteString
| Unquoted B.ByteString deriving Int -> CopyRenameNames -> ShowS
[CopyRenameNames] -> ShowS
CopyRenameNames -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CopyRenameNames] -> ShowS
$cshowList :: [CopyRenameNames] -> ShowS
show :: CopyRenameNames -> [Char]
$cshow :: CopyRenameNames -> [Char]
showsPrec :: Int -> CopyRenameNames -> ShowS
$cshowsPrec :: Int -> CopyRenameNames -> ShowS
Show
data Object = Blob (Maybe Int) Content
| Reset Branch (Maybe RefId)
| Commit Branch Marked AuthorInfo Message
| Tag Tag Int AuthorInfo Message
| Modify (Either Int Content) B.ByteString
| Gitlink B.ByteString
| Copy CopyRenameNames
| Rename CopyRenameNames
| Delete B.ByteString
| From Int
| Merge Int
| Progress B.ByteString
| End
deriving Int -> Object -> ShowS
[Object] -> ShowS
Object -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Object] -> ShowS
$cshowList :: [Object] -> ShowS
show :: Object -> [Char]
$cshow :: Object -> [Char]
showsPrec :: Int -> Object -> ShowS
$cshowsPrec :: Int -> Object -> ShowS
Show
type Ancestors = (Marked, [Int])
data State p where
Toplevel :: Marked -> Branch -> State p
InCommit :: Marked -> Ancestors -> Branch -> Tree IO -> RL (PrimOf p) cX cY -> PatchInfo -> State p
Done :: State p
instance Show (State p) where
show :: State p -> [Char]
show Toplevel {} = [Char]
"Toplevel"
show InCommit {} = [Char]
"InCommit"
show State p
Done = [Char]
"Done"
fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
fastImport (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [[Char]
outrepo] =
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
$ [Char] -> IO () -> IO ()
withNewDirectory [Char]
outrepo forall a b. (a -> b) -> a -> b
$ do
EmptyRepository Repository ('RepoType 'NoRebase) p Origin Origin Origin
_repo <- PatchFormat
-> WithWorkingDir
-> WithPatchIndex
-> UseCache
-> IO EmptyRepository
createRepository
(PrimDarcsOption PatchFormat
patchFormat forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(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
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
Repository ('RepoType 'NoRebase) p 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) p Origin Origin Origin
_repo ([DarcsFlag] -> UpdatePending
updatePending [DarcsFlag]
opts)
()
marks <- forall (rt :: RepoType) (p :: * -> * -> *) r u.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p r u r -> Marks -> IO ()
fastImport' Repository ('RepoType 'NoRebase) p Origin Origin Origin
_repo Marks
emptyMarks
Repository ('RepoType 'NoRebase) p Origin Origin Origin
_ <- 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 ('RepoType 'NoRebase) p Origin Origin Origin
_repo ([DarcsFlag] -> UpdatePending
updatePending [DarcsFlag]
opts) Compression
GzipCompression
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository ('RepoType 'NoRebase) p Origin Origin Origin
_repo
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> [Char] -> WithWorkingDir -> IO ()
createPristineDirectoryTree Repository ('RepoType 'NoRebase) p Origin Origin Origin
_repo [Char]
"." (PrimDarcsOption WithWorkingDir
withWorkingDir forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
forall (m :: * -> *) a. Monad m => a -> m a
return ()
marks
fastImport (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [[Char]]
_ = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"I need exactly one output repository."
fastImport' :: forall rt p r u . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p r u r -> Marks -> IO ()
fastImport' :: forall (rt :: RepoType) (p :: * -> * -> *) r u.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p r u r -> Marks -> IO ()
fastImport' Repository rt p r u r
repo Marks
marks = do
Tree IO
pristine <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p r u r
repo
IORef Marks
marksref <- forall a. a -> IO (IORef a)
newIORef Marks
marks
let initial :: State p
initial = forall (p :: * -> * -> *). Maybe Int -> ByteString -> State p
Toplevel forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BC.pack [Char]
"refs/branches/master"
go :: State p -> B.ByteString -> TreeIO ()
go :: State p -> ByteString -> TreeIO ()
go State p
state ByteString
rest = do (ByteString
rest', Object
item) <- ByteString -> TreeIO (ByteString, Object)
parseObject ByteString
rest
State p
state' <- State p -> Object -> TreeIO (State p)
process State p
state Object
item
case State p
state' of
State p
Done -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
State p
_ -> State p -> ByteString -> TreeIO ()
go State p
state' ByteString
rest'
markpath :: Int -> AnchoredPath
markpath :: Int -> AnchoredPath
markpath Int
n = [Char] -> AnchoredPath
floatPath ([Char]
darcsdir [Char] -> ShowS
</> [Char]
"marks")
AnchoredPath -> Name -> AnchoredPath
`appendPath` (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] Name
makeName forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show (Int
n forall a. Integral a => a -> a -> a
`div` Int
1000))
AnchoredPath -> Name -> AnchoredPath
`appendPath` (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] Name
makeName forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show (Int
n forall a. Integral a => a -> a -> a
`mod` Int
1000))
makeinfo :: ByteString -> ByteString -> Bool -> m PatchInfo
makeinfo ByteString
author ByteString
message Bool
tag = do
let ([Char]
name, [[Char]]
log) = case ByteString -> [Char]
unpackPSFromUTF8 ByteString
message of
[Char]
"" -> ([Char]
"Unnamed patch", [])
[Char]
msg -> (forall a. [a] -> a
head forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. [a] -> [a]
tail) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines forall a b. (a -> b) -> a -> b
$ [Char]
msg
([Char]
author'', [Char]
date'') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'>') forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpackPSFromUTF8 ByteString
author
date' :: [Char]
date' = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Char]
"0123456789" :: String)) [Char]
date''
author' :: [Char]
author' = [Char]
author'' forall a. [a] -> [a] -> [a]
++ [Char]
">"
date :: [Char]
date = [Char] -> UTCTime -> [Char]
formatDateTime [Char]
"%Y%m%d%H%M%S" forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe UTCTime
startOfTime ([Char] -> [Char] -> Maybe UTCTime
parseDateTime [Char]
"%s %z" [Char]
date')
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> [[Char]] -> IO PatchInfo
patchinfo [Char]
date (if Bool
tag then [Char]
"TAG " forall a. [a] -> [a] -> [a]
++ [Char]
name else [Char]
name) [Char]
author' [[Char]]
log
addtag :: ByteString -> ByteString -> m ()
addtag ByteString
author ByteString
msg =
do PatchInfo
info_ <- forall {m :: * -> *}.
MonadIO m =>
ByteString -> ByteString -> Bool -> m PatchInfo
makeinfo ByteString
author ByteString
msg Bool
True
Bool
gotany <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
tentativePristinePath
[PatchInfo]
deps <- if Bool
gotany then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> [PatchInfo]
getUncovered forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, PatchListFormat p, ReadPatch p) =>
Repository rt p wR wU wT -> [Char] -> IO (PatchSet rt p Origin wT)
readTentativeRepo Repository rt p r u r
repo (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> [Char]
repoLocation Repository rt p r u r
repo)
else forall (m :: * -> *) a. Monad m => a -> m a
return []
let patch :: Named p wA wA
patch :: forall wA. Named p wA wA
patch = forall (p :: * -> * -> *) wX wY.
PatchInfo -> [PatchInfo] -> FL p wX wY -> Named p wX wY
NamedP PatchInfo
info_ [PatchInfo]
deps forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
Cache -> Compression -> PatchInfoAnd rt p wX wY -> IO ()
addToTentativeInventory (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p r u r
repo) Compression
GzipCompression (forall (p :: * -> * -> *) wX wY (rt :: RepoType).
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG rt p wX wY
n2pia forall wA. Named p wA wA
patch)
updateHashes :: RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
updateHashes = do
let nodarcs :: AnchoredPath -> p -> Bool
nodarcs = \(AnchoredPath (Name
x:[Name]
_)) p
_ -> Name
x forall a. Eq a => a -> a -> Bool
/= Name
darcsdirName
hashblobs :: TreeItem m -> m (TreeItem m)
hashblobs (File blob :: Blob m
blob@(T.Blob m ByteString
con Hash
NoHash)) =
do Hash
hash <- ByteString -> Hash
sha256 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob m
blob
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Blob m -> TreeItem m
File (forall (m :: * -> *). m ByteString -> Hash -> Blob m
T.Blob m ByteString
con Hash
hash)
hashblobs TreeItem m
x = forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem m
x
Tree IO
tree' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Monad m =>
(TreeItem m -> m (TreeItem m))
-> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m)
T.partiallyUpdateTree forall {m :: * -> *}. Monad m => TreeItem m -> m (TreeItem m)
hashblobs forall {p}. AnchoredPath -> p -> Bool
nodarcs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall (m :: * -> *). TreeState m -> Tree m
tree
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \TreeState IO
s -> TreeState IO
s { tree :: Tree IO
tree = Tree IO
tree' }
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
T.filter forall {p}. AnchoredPath -> p -> Bool
nodarcs Tree IO
tree'
deleteEmptyParents :: AnchoredPath -> RWST (TreeEnv m) () (TreeState m) m ()
deleteEmptyParents AnchoredPath
fp =
case AnchoredPath -> Maybe AnchoredPath
parent AnchoredPath
fp of
Maybe AnchoredPath
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just AnchoredPath
directParent -> do
Maybe (Tree m)
parentTree <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree AnchoredPath
directParent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall (m :: * -> *). TreeState m -> Tree m
tree
case (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Tree m)
parentTree of
Just Bool
True -> do forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.unlink AnchoredPath
directParent
AnchoredPath -> RWST (TreeEnv m) () (TreeState m) m ()
deleteEmptyParents AnchoredPath
directParent
Maybe Bool
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
diffCurrent :: State p -> TreeIO (State p)
diffCurrent :: State p -> TreeIO (State p)
diffCurrent (InCommit Maybe Int
mark Ancestors
ancestors ByteString
branch Tree IO
start RL (PrimOf p) cX cY
ps PatchInfo
info_) = do
Tree IO
current <- RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
updateHashes
Sealed FL (PrimOf p) cY wX
diff <- forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) (w :: (* -> * -> *) -> *)
(prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> ([Char] -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff DiffAlgorithm
PatienceDiff (forall a b. a -> b -> a
const FileType
TextFile) Tree IO
start Tree IO
current)
let newps :: RL (PrimOf p) cX wX
newps = RL (PrimOf p) cX cY
ps forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> RL a wY wZ -> RL a wX wZ
+<+ forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PrimOf p) cY wX
diff
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wY cY.
Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) wY cY
-> PatchInfo
-> State p
InCommit Maybe Int
mark Ancestors
ancestors ByteString
branch Tree IO
current RL (PrimOf p) cX wX
newps PatchInfo
info_
diffCurrent State p
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"This is never valid outside of a commit."
process :: State p -> Object -> TreeIO (State p)
process :: State p -> Object -> TreeIO (State p)
process State p
s (Progress ByteString
p) = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char]
"progress " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
decodeLocale ByteString
p)
forall (m :: * -> *) a. Monad m => a -> m a
return State p
s
process (Toplevel Maybe Int
_ ByteString
_) Object
End = do
Tree IO
tree' <- (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsAddMissingHashes) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
updateHashes
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \TreeState IO
s -> TreeState IO
s { tree :: Tree IO
tree = Tree IO
tree' }
let root :: ByteString
root = Hash -> ByteString
encodeBase16 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Tree m -> Hash
treeHash Tree IO
tree'
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
[Char] -> IO ()
putStrLn [Char]
"\\o/ It seems we survived. Enjoy your new repo."
[Char] -> ByteString -> IO ()
B.writeFile [Char]
tentativePristinePath forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BC.concat [[Char] -> ByteString
BC.pack [Char]
"pristine:", ByteString
root]
forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). State p
Done
process (Toplevel Maybe Int
n ByteString
b) (Tag ByteString
tag Int
what ByteString
author ByteString
msg) = do
if forall a. a -> Maybe a
Just Int
what forall a. Eq a => a -> a -> Bool
== Maybe Int
n
then forall {m :: * -> *}. MonadIO m => ByteString -> ByteString -> m ()
addtag ByteString
author ByteString
msg
else 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]
"WARNING: Ignoring out-of-order tag " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
decodeLocale ByteString
tag
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: * -> * -> *). Maybe Int -> ByteString -> State p
Toplevel Maybe Int
n ByteString
b)
process (Toplevel Maybe Int
n ByteString
_) (Reset ByteString
branch Maybe RefId
from) =
do case Maybe RefId
from of
(Just (MarkId Int
k)) | forall a. a -> Maybe a
Just Int
k forall a. Eq a => a -> a -> Bool
== Maybe Int
n ->
forall {m :: * -> *}. MonadIO m => ByteString -> ByteString -> m ()
addtag ([Char] -> ByteString
BC.pack [Char]
"Anonymous Tagger <> 0 +0000") ByteString
branch
Maybe RefId
_ -> 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]
"WARNING: Ignoring out-of-order tag " forall a. [a] -> [a] -> [a]
++
ByteString -> [Char]
decodeLocale ByteString
branch
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *). Maybe Int -> ByteString -> State p
Toplevel Maybe Int
n ByteString
branch
process (Toplevel Maybe Int
n ByteString
b) (Blob (Just Int
m) ByteString
bits) = do
forall (m :: * -> *).
Monad m =>
AnchoredPath -> ByteString -> TreeMonad m ()
TM.writeFile (Int -> AnchoredPath
markpath Int
m) ([ByteString] -> ByteString
BLC.fromChunks [ByteString
bits])
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *). Maybe Int -> ByteString -> State p
Toplevel Maybe Int
n ByteString
b
process State p
x (Gitlink ByteString
link) = 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]
"WARNING: Ignoring gitlink " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
decodeLocale ByteString
link
forall (m :: * -> *) a. Monad m => a -> m a
return State p
x
process (Toplevel Maybe Int
previous ByteString
pbranch) (Commit ByteString
branch Maybe Int
mark ByteString
author ByteString
message) = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
pbranch forall a. Eq a => a -> a -> Bool
/= ByteString
branch) 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 ([Char]
"Tagging branch: " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
decodeLocale ByteString
pbranch)
forall {m :: * -> *}. MonadIO m => ByteString -> ByteString -> m ()
addtag ByteString
author ByteString
pbranch
PatchInfo
info_ <- forall {m :: * -> *}.
MonadIO m =>
ByteString -> ByteString -> Bool -> m PatchInfo
makeinfo ByteString
author ByteString
message Bool
False
Tree IO
startstate <- RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
updateHashes
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wY cY.
Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) wY cY
-> PatchInfo
-> State p
InCommit Maybe Int
mark (Maybe Int
previous, []) ByteString
branch Tree IO
startstate forall (a :: * -> * -> *) wX. RL a wX wX
NilRL PatchInfo
info_
process s :: State p
s@InCommit {} (Modify (Left Int
m) ByteString
path) = do
forall (m :: * -> *).
Monad m =>
AnchoredPath -> AnchoredPath -> TreeMonad m ()
TM.copy (Int -> AnchoredPath
markpath Int
m) (ByteString -> AnchoredPath
decodePath ByteString
path)
State p -> TreeIO (State p)
diffCurrent State p
s
process s :: State p
s@InCommit {} (Modify (Right ByteString
bits) ByteString
path) = do
forall (m :: * -> *).
Monad m =>
AnchoredPath -> ByteString -> TreeMonad m ()
TM.writeFile (ByteString -> AnchoredPath
decodePath ByteString
path) ([ByteString] -> ByteString
BLC.fromChunks [ByteString
bits])
State p -> TreeIO (State p)
diffCurrent State p
s
process s :: State p
s@InCommit {} (Delete ByteString
path) = do
let floatedPath :: AnchoredPath
floatedPath = ByteString -> AnchoredPath
decodePath ByteString
path
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.unlink AnchoredPath
floatedPath
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
deleteEmptyParents AnchoredPath
floatedPath
State p -> TreeIO (State p)
diffCurrent State p
s
process (InCommit Maybe Int
mark (Maybe Int
prev, [Int]
current) ByteString
branch Tree IO
start RL (PrimOf p) cX cY
ps PatchInfo
info_) (From Int
from) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wY cY.
Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) wY cY
-> PatchInfo
-> State p
InCommit Maybe Int
mark (Maybe Int
prev, Int
fromforall a. a -> [a] -> [a]
:[Int]
current) ByteString
branch Tree IO
start RL (PrimOf p) cX cY
ps PatchInfo
info_
process (InCommit Maybe Int
mark (Maybe Int
prev, [Int]
current) ByteString
branch Tree IO
start RL (PrimOf p) cX cY
ps PatchInfo
info_) (Merge Int
from) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wY cY.
Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) wY cY
-> PatchInfo
-> State p
InCommit Maybe Int
mark (Maybe Int
prev, Int
fromforall a. a -> [a] -> [a]
:[Int]
current) ByteString
branch Tree IO
start RL (PrimOf p) cX cY
ps PatchInfo
info_
process s :: State p
s@InCommit {} (Copy CopyRenameNames
names) = do
(ByteString
from, ByteString
to) <- CopyRenameNames -> TreeIO (ByteString, ByteString)
extractNames CopyRenameNames
names
forall (m :: * -> *).
Monad m =>
AnchoredPath -> AnchoredPath -> TreeMonad m ()
TM.copy (ByteString -> AnchoredPath
decodePath ByteString
from) (ByteString -> AnchoredPath
decodePath ByteString
to)
State p -> TreeIO (State p)
diffCurrent State p
s
process s :: State p
s@(InCommit Maybe Int
mark Ancestors
ancestors ByteString
branch Tree IO
start RL (PrimOf p) cX cY
_ PatchInfo
info_) (Rename CopyRenameNames
names) = do
(ByteString
from, ByteString
to) <- CopyRenameNames -> TreeIO (ByteString, ByteString)
extractNames CopyRenameNames
names
let uFrom :: AnchoredPath
uFrom = ByteString -> AnchoredPath
decodePath ByteString
from
uTo :: AnchoredPath
uTo = ByteString -> AnchoredPath
decodePath ByteString
to
case AnchoredPath -> Maybe AnchoredPath
parent AnchoredPath
uTo of
Maybe AnchoredPath
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just AnchoredPath
parentDir -> do
Bool
targetDirExists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
start AnchoredPath
uTo
Bool
targetFileExists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasFile Tree IO
start AnchoredPath
uTo
Bool
parentDirExists <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
start AnchoredPath
parentDir
if Bool
targetDirExists Bool -> Bool -> Bool
|| Bool
targetFileExists
then forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.unlink AnchoredPath
uTo
else forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
parentDirExists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.createDirectory AnchoredPath
parentDir
(InCommit Maybe Int
_ Ancestors
_ ByteString
_ Tree IO
_ RL (PrimOf p) cX cY
newPs PatchInfo
_) <- State p -> TreeIO (State p)
diffCurrent State p
s
forall (m :: * -> *).
Monad m =>
AnchoredPath -> AnchoredPath -> TreeMonad m ()
TM.rename AnchoredPath
uFrom AnchoredPath
uTo
let ps' :: RL (PrimOf p) cX wZ
ps' = RL (PrimOf p) cX cY
newPs forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> AnchoredPath -> prim wX wY
move AnchoredPath
uFrom AnchoredPath
uTo
Tree IO
current <- RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
updateHashes
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
deleteEmptyParents AnchoredPath
uFrom
State p -> TreeIO (State p)
diffCurrent (forall (p :: * -> * -> *) wY cY.
Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) wY cY
-> PatchInfo
-> State p
InCommit Maybe Int
mark Ancestors
ancestors ByteString
branch Tree IO
current forall {wZ}. RL (PrimOf p) cX wZ
ps' PatchInfo
info_)
process (InCommit Maybe Int
mark Ancestors
ancestors ByteString
branch Tree IO
_ RL (PrimOf p) cX cY
ps PatchInfo
info_) Object
x = do
case Ancestors
ancestors of
(Maybe Int
_, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Just Int
n, [Int]
list)
| Int
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
list -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> 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]
"WARNING: Linearising non-linear ancestry:" forall a. [a] -> [a] -> [a]
++
[Char]
" currently at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
n forall a. [a] -> [a] -> [a]
++ [Char]
", ancestors " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Int]
list
(Maybe Int
Nothing, [Int]
list) ->
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]
"WARNING: Linearising non-linear ancestry " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Int]
list
(FL (PrimOf p) cX cY
prims :: FL (PrimOf p) cX cY) <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (prim :: * -> * -> *) wX wY.
PrimCanonize prim =>
FL prim wX wY -> FL prim wX wY
sortCoalesceFL forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (PrimOf p) cX cY
ps
let patch :: Named p cX cY
patch :: Named p cX cY
patch = forall (p :: * -> * -> *) wX wY.
FromPrim p =>
PatchInfo -> FL (PrimOf p) wX wY -> Named p wX wY
infopatch PatchInfo
info_ FL (PrimOf p) cX cY
prims
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
Cache -> Compression -> PatchInfoAnd rt p wX wY -> IO ()
addToTentativeInventory (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p r u r
repo)
Compression
GzipCompression (forall (p :: * -> * -> *) wX wY (rt :: RepoType).
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG rt p wX wY
n2pia Named p cX cY
patch)
case Maybe Int
mark of
Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Int
n -> case Marks -> Int -> Maybe ByteString
getMark Marks
marks Int
n of
Maybe ByteString
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY (rt :: RepoType).
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG rt p wX wY
n2pia Named p cX cY
patch)
Just ByteString
n' -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"FATAL: Mark already exists: " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
decodeLocale ByteString
n'
State p -> Object -> TreeIO (State p)
process (forall (p :: * -> * -> *). Maybe Int -> ByteString -> State p
Toplevel Maybe Int
mark ByteString
branch) Object
x
process State p
state Object
obj = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print Object
obj
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected object in state " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show State p
state
extractNames :: CopyRenameNames
-> TreeIO (BC.ByteString, BC.ByteString)
extractNames :: CopyRenameNames -> TreeIO (ByteString, ByteString)
extractNames CopyRenameNames
names = case CopyRenameNames
names of
Quoted ByteString
f ByteString
t -> forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
f, ByteString
t)
Unquoted ByteString
uqNames -> do
let spaceIndices :: [Int]
spaceIndices = Char -> ByteString -> [Int]
BC.elemIndices Char
' ' ByteString
uqNames
splitStr :: Int -> (ByteString, ByteString)
splitStr = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> ByteString -> ByteString
BC.drop Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> ByteString -> (ByteString, ByteString)
BC.splitAt ByteString
uqNames
spaceComponents :: [(ByteString, ByteString)]
spaceComponents = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> (ByteString, ByteString)
splitStr [Int]
spaceIndices
componentCount :: Int
componentCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ByteString, ByteString)]
spaceComponents
if Int
componentCount forall a. Eq a => a -> a -> Bool
== Int
1
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(ByteString, ByteString)]
spaceComponents
else do
let dieMessage :: [Char]
dieMessage = [[Char]] -> [Char]
unwords
[ [Char]
"Couldn't determine move/rename"
, [Char]
"source/destination filenames, with the"
, [Char]
"data produced by this (old) version of"
, [Char]
"git, since it uses unquoted, but"
, [Char]
"special-character-containing paths."
]
lPathExists :: (ByteString, b) -> TreeMonad m Bool
lPathExists (ByteString
l,b
_) =
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
TM.fileExists forall a b. (a -> b) -> a -> b
$ ByteString -> AnchoredPath
decodePath ByteString
l
finder :: [(ByteString, b)]
-> RWST (TreeEnv m) () (TreeState m) m (ByteString, b)
finder [] = forall a. HasCallStack => [Char] -> a
error [Char]
dieMessage
finder ((ByteString, b)
x : [(ByteString, b)]
rest) = do
Bool
xExists <- forall {m :: * -> *} {b}.
Monad m =>
(ByteString, b) -> TreeMonad m Bool
lPathExists (ByteString, b)
x
if Bool
xExists then forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString, b)
x else [(ByteString, b)]
-> RWST (TreeEnv m) () (TreeState m) m (ByteString, b)
finder [(ByteString, b)]
rest
forall {m :: * -> *} {b}.
Monad m =>
[(ByteString, b)]
-> RWST (TreeEnv m) () (TreeState m) m (ByteString, b)
finder [(ByteString, ByteString)]
spaceComponents
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 (State p -> ByteString -> TreeIO ()
go forall (p :: * -> * -> *). State p
initial ByteString
B.empty) Tree IO
pristine [Char]
pristineDirPath
parseObject :: BC.ByteString -> TreeIO ( BC.ByteString, Object )
parseObject :: ByteString -> TreeIO (ByteString, Object)
parseObject = (ByteString -> Result (Maybe Object))
-> ByteString -> TreeIO (ByteString, Object)
next' ByteString -> Result (Maybe Object)
mbObject
where mbObject :: ByteString -> Result (Maybe Object)
mbObject = forall a. Parser a -> ByteString -> Result a
A.parse Parser ByteString (Maybe Object)
p_maybeObject
p_maybeObject :: Parser ByteString (Maybe Object)
p_maybeObject = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString Object
p_object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall t. Chunk t => Parser t ()
A.endOfInput forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
lex :: Parser ByteString b -> Parser ByteString b
lex Parser ByteString b
p = Parser ByteString b
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
x -> Parser ()
A.skipSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return b
x
lexString :: [Char] -> Parser ()
lexString [Char]
s = ByteString -> Parser ByteString
A.string ([Char] -> ByteString
BC.pack [Char]
s) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
A.skipSpace
line :: Parser ByteString
line = forall {b}. Parser ByteString b -> Parser ByteString b
lex forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString
A.takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
'\n')
optional :: f a -> f (Maybe a)
optional f a
p = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` f a
p forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
p_object :: Parser ByteString Object
p_object = Parser ByteString Object
p_blob
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_reset
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_commit
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_tag
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_modify
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_rename
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_copy
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_from
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_merge
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_delete
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([Char] -> Parser ()
lexString [Char]
"progress" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Object
Progress forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString
line)
p_author :: [Char] -> Parser ByteString
p_author [Char]
name = [Char] -> Parser ()
lexString [Char]
name forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString
line
p_reset :: Parser ByteString Object
p_reset = do [Char] -> Parser ()
lexString [Char]
"reset"
ByteString
branch <- Parser ByteString
line
Maybe RefId
refid <- forall {f :: * -> *} {a}.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ [Char] -> Parser ()
lexString [Char]
"from" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString RefId
p_refid
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe RefId -> Object
Reset ByteString
branch Maybe RefId
refid
p_commit :: Parser ByteString Object
p_commit = do [Char] -> Parser ()
lexString [Char]
"commit"
ByteString
branch <- Parser ByteString
line
Maybe Int
mark <- forall {f :: * -> *} {a}.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional Parser ByteString Int
p_mark
Maybe ByteString
_ <- forall {f :: * -> *} {a}.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ [Char] -> Parser ByteString
p_author [Char]
"author"
ByteString
committer <- [Char] -> Parser ByteString
p_author [Char]
"committer"
ByteString
message <- Parser ByteString
p_data
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Int -> ByteString -> ByteString -> Object
Commit ByteString
branch Maybe Int
mark ByteString
committer ByteString
message
p_tag :: Parser ByteString Object
p_tag = do ()
_ <- [Char] -> Parser ()
lexString [Char]
"tag"
ByteString
tag <- Parser ByteString
line
[Char] -> Parser ()
lexString [Char]
"from"
Int
mark <- Parser ByteString Int
p_marked
ByteString
author <- [Char] -> Parser ByteString
p_author [Char]
"tagger"
ByteString
message <- Parser ByteString
p_data
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> ByteString -> ByteString -> Object
Tag ByteString
tag Int
mark ByteString
author ByteString
message
p_blob :: Parser ByteString Object
p_blob = do [Char] -> Parser ()
lexString [Char]
"blob"
Maybe Int
mark <- forall {f :: * -> *} {a}.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional Parser ByteString Int
p_mark
Maybe Int -> ByteString -> Object
Blob Maybe Int
mark forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString
p_data
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"p_blob"
p_mark :: Parser ByteString Int
p_mark = do [Char] -> Parser ()
lexString [Char]
"mark"
Parser ByteString Int
p_marked
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"p_mark"
p_refid :: Parser ByteString RefId
p_refid = Int -> RefId
MarkId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString Int
p_marked
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([Char] -> Parser ()
lexString [Char]
"inline" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return RefId
Inline)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> RefId
HashId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString
p_hash
p_data :: Parser ByteString
p_data = do [Char] -> Parser ()
lexString [Char]
"data"
Int
len <- forall a. Integral a => Parser a
A.decimal
Char
_ <- Char -> Parser Char
A.char Char
'\n'
forall {b}. Parser ByteString b -> Parser ByteString b
lex forall a b. (a -> b) -> a -> b
$ Int -> Parser ByteString
A.take Int
len
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"p_data"
p_marked :: Parser ByteString Int
p_marked = forall {b}. Parser ByteString b -> Parser ByteString b
lex forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
A.char Char
':' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Integral a => Parser a
A.decimal
p_hash :: Parser ByteString
p_hash = forall {b}. Parser ByteString b -> Parser ByteString b
lex forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString
A.takeWhile1 ([Char] -> Char -> Bool
A.inClass [Char]
"0123456789abcdefABCDEF")
p_from :: Parser ByteString Object
p_from = [Char] -> Parser ()
lexString [Char]
"from" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Object
From forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString Int
p_marked
p_merge :: Parser ByteString Object
p_merge = [Char] -> Parser ()
lexString [Char]
"merge" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Object
Merge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString Int
p_marked
p_delete :: Parser ByteString Object
p_delete = [Char] -> Parser ()
lexString [Char]
"D" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Object
Delete forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString
p_maybeQuotedName
p_rename :: Parser ByteString Object
p_rename = do [Char] -> Parser ()
lexString [Char]
"R"
CopyRenameNames
names <- Parser ByteString CopyRenameNames
p_maybeQuotedCopyRenameNames
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CopyRenameNames -> Object
Rename CopyRenameNames
names
p_copy :: Parser ByteString Object
p_copy = do [Char] -> Parser ()
lexString [Char]
"C"
CopyRenameNames
names <- Parser ByteString CopyRenameNames
p_maybeQuotedCopyRenameNames
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CopyRenameNames -> Object
Copy CopyRenameNames
names
p_modify :: Parser ByteString Object
p_modify = do [Char] -> Parser ()
lexString [Char]
"M"
ByteString
mode <- forall {b}. Parser ByteString b -> Parser ByteString b
lex forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString
A.takeWhile ([Char] -> Char -> Bool
A.inClass [Char]
"01234567890")
RefId
mark <- Parser ByteString RefId
p_refid
ByteString
path <- Parser ByteString
p_maybeQuotedName
case RefId
mark of
HashId ByteString
hash | ByteString
mode forall a. Eq a => a -> a -> Bool
== [Char] -> ByteString
BC.pack [Char]
"160000" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Object
Gitlink ByteString
hash
| Bool
otherwise -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
":(("
MarkId Int
n -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Either Int ByteString -> ByteString -> Object
Modify (forall a b. a -> Either a b
Left Int
n) ByteString
path
RefId
Inline -> do ByteString
bits <- Parser ByteString
p_data
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Either Int ByteString -> ByteString -> Object
Modify (forall a b. b -> Either a b
Right ByteString
bits) ByteString
path
p_maybeQuotedCopyRenameNames :: Parser ByteString CopyRenameNames
p_maybeQuotedCopyRenameNames =
Parser ByteString CopyRenameNames
p_lexTwoQuotedNames forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> CopyRenameNames
Unquoted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString
line
p_lexTwoQuotedNames :: Parser ByteString CopyRenameNames
p_lexTwoQuotedNames = do
ByteString
n1 <- forall {b}. Parser ByteString b -> Parser ByteString b
lex Parser ByteString
p_quotedName
ByteString
n2 <- forall {b}. Parser ByteString b -> Parser ByteString b
lex Parser ByteString
p_quotedName
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> CopyRenameNames
Quoted ByteString
n1 ByteString
n2
p_maybeQuotedName :: Parser ByteString
p_maybeQuotedName = forall {b}. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString
p_quotedName forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString
line)
p_quotedName :: Parser ByteString
p_quotedName = do
Char
_ <- Char -> Parser Char
A.char Char
'"'
[ByteString]
bytes <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser ByteString
p_escaped forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString
p_unescaped)
Char
_ <- Char -> Parser Char
A.char Char
'"'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString]
bytes
p_unescaped :: Parser ByteString
p_unescaped = (Char -> Bool) -> Parser ByteString
A.takeWhile1 (\Char
c->Char
cforall a. Eq a => a -> a -> Bool
/=Char
'"' Bool -> Bool -> Bool
&& Char
cforall a. Eq a => a -> a -> Bool
/=Char
'\\')
p_escaped :: Parser ByteString
p_escaped = do
Char
_ <- Char -> Parser Char
A.char Char
'\\'
Parser ByteString
p_escaped_octal forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString
p_escaped_char
p_escaped_octal :: Parser ByteString
p_escaped_octal = do
let octals :: [Char]
octals :: [Char]
octals = [Char]
"01234567"
ByteString
s <- (Char -> Bool) -> Parser ByteString
A.takeWhile1 (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
octals)
let x :: Word8
x :: Word8
x = forall a. Read a => [Char] -> a
read ([Char]
"0o" forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BC.unpack ByteString
s)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString
B.singleton forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x
p_escaped_char :: Parser ByteString
p_escaped_char =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> ByteString
BC.singleton forall a b. (a -> b) -> a -> b
$
Char
'\r' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
A.char Char
'r' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char
'\n' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
A.char Char
'n' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
A.char Char
'"' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
A.char Char
'\\'
next' :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)
next' :: (ByteString -> Result (Maybe Object))
-> ByteString -> TreeIO (ByteString, Object)
next' ByteString -> Result (Maybe Object)
parser ByteString
rest =
do ByteString
chunk <- if ByteString -> Bool
B.null ByteString
rest then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
B.hGet Handle
stdin (Int
64 forall a. Num a => a -> a -> a
* Int
1024)
else forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
rest
(ByteString -> Result (Maybe Object))
-> ByteString -> TreeIO (ByteString, Object)
next_chunk ByteString -> Result (Maybe Object)
parser ByteString
chunk
next_chunk :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)
next_chunk :: (ByteString -> Result (Maybe Object))
-> ByteString -> TreeIO (ByteString, Object)
next_chunk ByteString -> Result (Maybe Object)
parser ByteString
chunk =
case ByteString -> Result (Maybe Object)
parser ByteString
chunk of
A.Done ByteString
rest Maybe Object
result -> forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
rest, forall b a. b -> (a -> b) -> Maybe a -> b
maybe Object
End forall a. a -> a
id Maybe Object
result)
A.Partial ByteString -> Result (Maybe Object)
cont -> (ByteString -> Result (Maybe Object))
-> ByteString -> TreeIO (ByteString, Object)
next' ByteString -> Result (Maybe Object)
cont ByteString
B.empty
A.Fail ByteString
_ [[Char]]
ctx [Char]
err -> 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]
"=== chunk ===\n" forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
decodeLocale ByteString
chunk forall a. [a] -> [a] -> [a]
++ [Char]
"\n=== end chunk ===="
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Error parsing stream. " forall a. [a] -> [a] -> [a]
++ [Char]
err forall a. [a] -> [a] -> [a]
++ [Char]
"\nContext: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [[Char]]
ctx
decodePath :: BC.ByteString -> AnchoredPath
decodePath :: ByteString -> AnchoredPath
decodePath = [Char] -> AnchoredPath
floatPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
decodeLocale