--  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.

{-# 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 = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
 [ String
"This command imports git repositories into new darcs repositories."
 , String
"Further options are accepted (see `darcs help init`)."
 , String
""
 , String
"To convert a git repo to a new darcs one you may run:"
 , String
""
 , String
"    $ (cd gitrepo && git fast-export --all -M) | darcs convert import darcsmirror"
 , String
""
 , String
"WARNING: git repositories with branches will produce weird results,"
 , String
"         use at your own risks."
 , String
""
 , String
"Incremental import with marksfiles is currently not supported."
 ]

convertImport :: DarcsCommand
convertImport :: DarcsCommand
convertImport = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"import"
    , commandHelp :: Doc
commandHelp = Doc
convertImportHelp
    , commandDescription :: String
commandDescription = String
"Import from a git-fast-export stream into darcs"
    , commandExtraArgs :: Int
commandExtraArgs = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"[<DIRECTORY>]"]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastImport
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = \[DarcsFlag]
_ -> Either String () -> IO (Either String ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ () -> Either String ()
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 = OptSpec
  DarcsOptDescr DarcsFlag Any (WithPatchIndex -> UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr DarcsFlag Any (WithPatchIndex -> UMask -> Any)
forall a.
OptSpec DarcsOptDescr DarcsFlag a (WithPatchIndex -> UMask -> a)
convertImportAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
convertImportBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
convertImportOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
convertImportOpts
    }
  where
    convertImportBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
convertImportBasicOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
  (Maybe String)
PrimDarcsOption (Maybe String)
O.newRepo
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
  (Maybe String)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (PatchFormat -> WithWorkingDir -> a)
     (SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (PatchFormat -> WithWorkingDir -> a)
     (Maybe String
      -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (PatchFormat -> WithWorkingDir -> a)
  (SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (PatchFormat -> WithWorkingDir -> a)
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WithWorkingDir -> a)
     (PatchFormat -> WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WithWorkingDir -> a)
     (Maybe String
      -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (WithWorkingDir -> a)
  (PatchFormat -> WithWorkingDir -> a)
PrimDarcsOption PatchFormat
O.patchFormat
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (WithWorkingDir -> a)
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe String
      -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (WithWorkingDir -> a)
PrimDarcsOption WithWorkingDir
O.withWorkingDir
    convertImportAdvancedOpts :: OptSpec DarcsOptDescr DarcsFlag a (WithPatchIndex -> UMask -> a)
convertImportAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag (UMask -> a) WithPatchIndex
PrimDarcsOption WithPatchIndex
O.patchIndexNo PrimOptSpec DarcsOptDescr DarcsFlag (UMask -> a) WithPatchIndex
-> OptSpec DarcsOptDescr DarcsFlag a (UMask -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (WithPatchIndex -> UMask -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (UMask -> a)
PrimDarcsOption UMask
O.umask
    convertImportOpts :: DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
convertImportOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
convertImportBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (WithPatchIndex
      -> UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Maybe String
      -> SetScriptsExecutable
      -> PatchFormat
      -> WithWorkingDir
      -> Maybe StdCmdAction
      -> Verbosity
      -> WithPatchIndex
      -> UMask
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (WithPatchIndex
   -> UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
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 -> String
(Int -> RefId -> ShowS)
-> (RefId -> String) -> ([RefId] -> ShowS) -> Show RefId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RefId] -> ShowS
$cshowList :: [RefId] -> ShowS
show :: RefId -> String
$cshow :: RefId -> String
showsPrec :: Int -> RefId -> ShowS
$cshowsPrec :: Int -> RefId -> ShowS
Show

-- Newish (> 1.7.6.1) Git either quotes filenames or has two
-- non-special-char-containing paths. Older git doesn't do any quoting, so
-- we'll have to manually try and find the correct paths, when we use the
-- paths.
data CopyRenameNames = Quoted B.ByteString B.ByteString
                     | Unquoted B.ByteString deriving Int -> CopyRenameNames -> ShowS
[CopyRenameNames] -> ShowS
CopyRenameNames -> String
(Int -> CopyRenameNames -> ShowS)
-> (CopyRenameNames -> String)
-> ([CopyRenameNames] -> ShowS)
-> Show CopyRenameNames
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CopyRenameNames] -> ShowS
$cshowList :: [CopyRenameNames] -> ShowS
show :: CopyRenameNames -> String
$cshow :: CopyRenameNames -> String
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 -- (mark or content), filename
            | Gitlink B.ByteString
            | Copy CopyRenameNames
            | Rename CopyRenameNames
            | Delete B.ByteString -- filename
            | From Int
            | Merge Int
            | Progress B.ByteString
            | End
            deriving Int -> Object -> ShowS
[Object] -> ShowS
Object -> String
(Int -> Object -> ShowS)
-> (Object -> String) -> ([Object] -> ShowS) -> Show Object
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Object] -> ShowS
$cshowList :: [Object] -> ShowS
show :: Object -> String
$cshow :: Object -> String
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 -> String
show Toplevel {} = String
"Toplevel"
  show InCommit {} = String
"InCommit"
  show State p
Done =  String
"Done"

fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastImport (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String
outrepo] =
  UMask -> IO () -> IO ()
forall a. UMask -> IO a -> IO a
withUMaskFlag (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO () -> IO ()
withNewDirectory String
outrepo (IO () -> IO ()) -> IO () -> IO ()
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 PrimDarcsOption PatchFormat -> [DarcsFlag] -> PatchFormat
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimDarcsOption WithWorkingDir
withWorkingDir PrimDarcsOption WithWorkingDir -> [DarcsFlag] -> WithWorkingDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimDarcsOption WithPatchIndex
patchIndexNo PrimDarcsOption WithPatchIndex -> [DarcsFlag] -> WithPatchIndex
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
    -- TODO implement --dry-run, which would be read-only?
    Repository ('RepoType 'NoRebase) p Origin Origin Origin
_repo <- Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> UpdatePending
-> IO (Repository ('RepoType 'NoRebase) p Origin Origin Origin)
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 <- Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Marks -> IO ()
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
_ <- Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> UpdatePending
-> Compression
-> IO (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
    Repository ('RepoType 'NoRebase) p Origin Origin Origin -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository ('RepoType 'NoRebase) p Origin Origin Origin
_repo
    Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> String -> WithWorkingDir -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String -> WithWorkingDir -> IO ()
createPristineDirectoryTree Repository ('RepoType 'NoRebase) p Origin Origin Origin
_repo String
"." (PrimDarcsOption WithWorkingDir
withWorkingDir PrimDarcsOption WithWorkingDir -> [DarcsFlag] -> WithWorkingDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
marks
fastImport (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [String]
_ = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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' :: Repository rt p r u r -> Marks -> IO ()
fastImport' Repository rt p r u r
repo Marks
marks = do
    Tree IO
pristine <- Repository rt p r u r -> IO (Tree IO)
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 <- Marks -> IO (IORef Marks)
forall a. a -> IO (IORef a)
newIORef Marks
marks
    let initial :: State p
initial = Marked -> Branch -> State p
forall (p :: * -> * -> *). Marked -> Branch -> State p
Toplevel Marked
forall a. Maybe a
Nothing (Branch -> State p) -> Branch -> State p
forall a b. (a -> b) -> a -> b
$ String -> Branch
BC.pack String
"refs/branches/master"

        go :: State p -> B.ByteString -> TreeIO ()
        go :: State p -> Branch -> TreeIO ()
go State p
state Branch
rest = do (Branch
rest', Object
item) <- Branch -> TreeIO (Branch, Object)
parseObject Branch
rest
                           State p
state' <- State p -> Object -> TreeIO (State p)
process State p
state Object
item
                           case State p
state' of
                             State p
Done -> () -> TreeIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                             State p
_ -> State p -> Branch -> TreeIO ()
go State p
state' Branch
rest'

        -- sort marks into buckets, since there can be a *lot* of them
        markpath :: Int -> AnchoredPath
        markpath :: Int -> AnchoredPath
markpath Int
n = String -> AnchoredPath
floatPath (String
darcsdir String -> ShowS
</> String
"marks")
                        AnchoredPath -> Name -> AnchoredPath
`appendPath` ((String -> Name) -> (Name -> Name) -> Either String Name -> Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Name
forall a. HasCallStack => String -> a
error Name -> Name
forall a. a -> a
id (Either String Name -> Name) -> Either String Name -> Name
forall a b. (a -> b) -> a -> b
$ String -> Either String Name
makeName (String -> Either String Name) -> String -> Either String Name
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
1000))
                        AnchoredPath -> Name -> AnchoredPath
`appendPath` ((String -> Name) -> (Name -> Name) -> Either String Name -> Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Name
forall a. HasCallStack => String -> a
error Name -> Name
forall a. a -> a
id (Either String Name -> Name) -> Either String Name -> Name
forall a b. (a -> b) -> a -> b
$ String -> Either String Name
makeName (String -> Either String Name) -> String -> Either String Name
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
1000))

        makeinfo :: Branch -> Branch -> Bool -> m PatchInfo
makeinfo Branch
author Branch
message Bool
tag = do
          let (String
name, [String]
log) = case Branch -> String
unpackPSFromUTF8 Branch
message of
                                      String
"" -> (String
"Unnamed patch", [])
                                      String
msg -> ([String] -> String
forall a. [a] -> a
head ([String] -> String)
-> ([String] -> [String]) -> [String] -> (String, [String])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [String] -> [String]
forall a. [a] -> [a]
tail) ([String] -> (String, [String]))
-> (String -> [String]) -> String -> (String, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> (String, [String])) -> String -> (String, [String])
forall a b. (a -> b) -> a -> b
$ String
msg
              (String
author'', String
date'') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'>') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ Branch -> String
unpackPSFromUTF8 Branch
author
              date' :: String
date' = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (String
"0123456789" :: String)) String
date''
              author' :: String
author' = String
author'' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
              date :: String
date = String -> UTCTime -> String
formatDateTime String
"%Y%m%d%H%M%S" (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe UTCTime
startOfTime (String -> String -> Maybe UTCTime
parseDateTime String
"%s %z" String
date')
          IO PatchInfo -> m PatchInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PatchInfo -> m PatchInfo) -> IO PatchInfo -> m PatchInfo
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> [String] -> IO PatchInfo
patchinfo String
date (if Bool
tag then String
"TAG " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name else String
name) String
author' [String]
log

        addtag :: Branch -> Branch -> m ()
addtag Branch
author Branch
msg =
          do PatchInfo
info_ <- Branch -> Branch -> Bool -> m PatchInfo
forall (m :: * -> *).
MonadIO m =>
Branch -> Branch -> Bool -> m PatchInfo
makeinfo Branch
author Branch
msg Bool
True
             Bool
gotany <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
tentativePristinePath
             [PatchInfo]
deps <- if Bool
gotany then IO [PatchInfo] -> m [PatchInfo]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [PatchInfo] -> m [PatchInfo])
-> IO [PatchInfo] -> m [PatchInfo]
forall a b. (a -> b) -> a -> b
$
                                      PatchSet rt p Origin r -> [PatchInfo]
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> [PatchInfo]
getUncovered (PatchSet rt p Origin r -> [PatchInfo])
-> IO (PatchSet rt p Origin r) -> IO [PatchInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
                                        Repository rt p r u r -> String -> IO (PatchSet rt p Origin r)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, PatchListFormat p, ReadPatch p) =>
Repository rt p wR wU wT -> String -> IO (PatchSet rt p Origin wT)
readTentativeRepo Repository rt p r u r
repo (Repository rt p r u r -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p r u r
repo)
                               else [PatchInfo] -> m [PatchInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
             let patch :: Named p wA wA
                 patch :: Named p wA wA
patch = PatchInfo -> [PatchInfo] -> FL p wA wA -> Named p wA wA
forall (p :: * -> * -> *) wX wY.
PatchInfo -> [PatchInfo] -> FL p wX wY -> Named p wX wY
NamedP PatchInfo
info_ [PatchInfo]
deps FL p wA wA
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
             IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Cache -> Compression -> PatchInfoAnd Any p Any Any -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
Cache -> Compression -> PatchInfoAnd rt p wX wY -> IO ()
addToTentativeInventory (Repository rt p r u r -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p r u r
repo) Compression
GzipCompression (Named p Any Any -> PatchInfoAnd Any p Any Any
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG rt p wX wY
n2pia Named p Any Any
forall wA. Named p wA wA
patch)

        -- processing items
        updateHashes :: RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
updateHashes = do
          let nodarcs :: AnchoredPath -> p -> Bool
nodarcs = \(AnchoredPath (Name
x:[Name]
_)) p
_ -> Name
x Name -> Name -> Bool
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 (ByteString -> Hash) -> m ByteString -> m Hash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Blob m -> m ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob m
blob
                   TreeItem m -> m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeItem m -> m (TreeItem m)) -> TreeItem m -> m (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Blob m -> TreeItem m
forall (m :: * -> *). Blob m -> TreeItem m
File (m ByteString -> Hash -> Blob m
forall (m :: * -> *). m ByteString -> Hash -> Blob m
T.Blob m ByteString
con Hash
hash)
              hashblobs TreeItem m
x = TreeItem m -> m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem m
x
          Tree IO
tree' <- IO (Tree IO) -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree IO) -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO))
-> (Tree IO -> IO (Tree IO))
-> Tree IO
-> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TreeItem IO -> IO (TreeItem IO))
-> (AnchoredPath -> TreeItem IO -> Bool) -> Tree IO -> IO (Tree IO)
forall (m :: * -> *).
Monad m =>
(TreeItem m -> m (TreeItem m))
-> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m)
T.partiallyUpdateTree TreeItem IO -> IO (TreeItem IO)
forall (m :: * -> *). Monad m => TreeItem m -> m (TreeItem m)
hashblobs AnchoredPath -> TreeItem IO -> Bool
forall p. AnchoredPath -> p -> Bool
nodarcs (Tree IO -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO))
-> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
-> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (TreeState IO -> Tree IO)
-> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState IO -> Tree IO
forall (m :: * -> *). TreeState m -> Tree m
tree
          (TreeState IO -> TreeState IO) -> TreeIO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState IO -> TreeState IO) -> TreeIO ())
-> (TreeState IO -> TreeState IO) -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ \TreeState IO
s -> TreeState IO
s { tree :: Tree IO
tree = Tree IO
tree' }
          Tree IO -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO))
-> Tree IO -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> TreeItem IO -> Bool) -> Tree IO -> Tree IO
forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
T.filter AnchoredPath -> TreeItem IO -> Bool
forall p. AnchoredPath -> p -> Bool
nodarcs Tree IO
tree'

        -- Since git doesn't track directores it implicitly deletes
        -- them when they become empty. We should therefore remove any
        -- directories that become empty (except the repo-root
        -- directory!)
        deleteEmptyParents :: AnchoredPath -> RWST (TreeEnv m) () (TreeState m) m ()
deleteEmptyParents AnchoredPath
fp =
          case AnchoredPath -> Maybe AnchoredPath
parent AnchoredPath
fp of
            Maybe AnchoredPath
Nothing -> () -> RWST (TreeEnv m) () (TreeState m) m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just AnchoredPath
directParent -> do
              Maybe (Tree m)
parentTree <- (Tree m -> AnchoredPath -> Maybe (Tree m))
-> AnchoredPath -> Tree m -> Maybe (Tree m)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Tree m -> AnchoredPath -> Maybe (Tree m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree AnchoredPath
directParent (Tree m -> Maybe (Tree m))
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
-> RWST (TreeEnv m) () (TreeState m) m (Maybe (Tree m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Tree m)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree
              case ([(Name, TreeItem m)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(Name, TreeItem m)] -> Bool)
-> (Tree m -> [(Name, TreeItem m)]) -> Tree m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate) (Tree m -> Bool) -> Maybe (Tree m) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Tree m)
parentTree of
                      Just Bool
True -> do AnchoredPath -> RWST (TreeEnv m) () (TreeState m) m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.unlink AnchoredPath
directParent
                                      AnchoredPath -> RWST (TreeEnv m) () (TreeState m) m ()
deleteEmptyParents AnchoredPath
directParent
                      -- Either missing (not possible) or non-empty.
                      Maybe Bool
_ -> () -> RWST (TreeEnv m) () (TreeState m) m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        -- generate a Hunk primitive patch from diffing
        diffCurrent :: State p -> TreeIO (State p)
        diffCurrent :: State p -> TreeIO (State p)
diffCurrent (InCommit Marked
mark Ancestors
ancestors Branch
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 <- FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) cY)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft (FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) cY))
-> RWST
     (TreeEnv IO) () (TreeState IO) IO (FreeLeft (FL (PrimOf p)))
-> RWST
     (TreeEnv IO) () (TreeState IO) IO (Sealed (FL (PrimOf p) cY))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
             IO (FreeLeft (FL (PrimOf p)))
-> RWST
     (TreeEnv IO) () (TreeState IO) IO (FreeLeft (FL (PrimOf p)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (DiffAlgorithm
-> (String -> FileType)
-> Tree IO
-> Tree IO
-> IO (FreeLeft (FL (PrimOf p)))
forall (m :: * -> *) (w :: (* -> * -> *) -> *)
       (prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> (String -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff DiffAlgorithm
PatienceDiff (FileType -> String -> FileType
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 RL (PrimOf p) cX cY -> RL (PrimOf p) cY wX -> RL (PrimOf p) cX wX
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> RL a wY wZ -> RL a wX wZ
+<+ FL (PrimOf p) cY wX -> RL (PrimOf p) cY wX
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PrimOf p) cY wX
diff
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (State p -> TreeIO (State p)) -> State p -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ Marked
-> Ancestors
-> Branch
-> Tree IO
-> RL (PrimOf p) cX wX
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Marked
-> Ancestors
-> Branch
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Marked
mark Ancestors
ancestors Branch
branch Tree IO
current RL (PrimOf p) cX wX
newps PatchInfo
info_
        diffCurrent State p
_ = String -> TreeIO (State p)
forall a. HasCallStack => String -> a
error String
"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 Branch
p) = do
          IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"progress " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Branch -> String
decodeLocale Branch
p)
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return State p
s

        process (Toplevel Marked
_ Branch
_) Object
End = do
          Tree IO
tree' <- (IO (Tree IO) -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree IO) -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO))
-> (Tree IO -> IO (Tree IO))
-> Tree IO
-> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsAddMissingHashes) (Tree IO -> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO))
-> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
-> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
updateHashes
          (TreeState IO -> TreeState IO) -> TreeIO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState IO -> TreeState IO) -> TreeIO ())
-> (TreeState IO -> TreeState IO) -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ \TreeState IO
s -> TreeState IO
s { tree :: Tree IO
tree = Tree IO
tree' } -- lets dump the right tree, without _darcs
          let root :: Branch
root = Hash -> Branch
encodeBase16 (Hash -> Branch) -> Hash -> Branch
forall a b. (a -> b) -> a -> b
$ Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree IO
tree'
          IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
putStrLn String
"\\o/ It seems we survived. Enjoy your new repo."
            String -> Branch -> IO ()
B.writeFile String
tentativePristinePath (Branch -> IO ()) -> Branch -> IO ()
forall a b. (a -> b) -> a -> b
$ [Branch] -> Branch
BC.concat [String -> Branch
BC.pack String
"pristine:", Branch
root]
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return State p
forall (p :: * -> * -> *). State p
Done

        process (Toplevel Marked
n Branch
b) (Tag Branch
tag Int
what Branch
author Branch
msg) = do
          if Int -> Marked
forall a. a -> Maybe a
Just Int
what Marked -> Marked -> Bool
forall a. Eq a => a -> a -> Bool
== Marked
n
             then Branch -> Branch -> TreeIO ()
forall (m :: * -> *). MonadIO m => Branch -> Branch -> m ()
addtag Branch
author Branch
msg
             else IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String
"WARNING: Ignoring out-of-order tag " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Branch -> String
decodeLocale Branch
tag
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (Marked -> Branch -> State p
forall (p :: * -> * -> *). Marked -> Branch -> State p
Toplevel Marked
n Branch
b)

        process (Toplevel Marked
n Branch
_) (Reset Branch
branch Maybe RefId
from) =
          do case Maybe RefId
from of
               (Just (MarkId Int
k)) | Int -> Marked
forall a. a -> Maybe a
Just Int
k Marked -> Marked -> Bool
forall a. Eq a => a -> a -> Bool
== Marked
n ->
                 Branch -> Branch -> TreeIO ()
forall (m :: * -> *). MonadIO m => Branch -> Branch -> m ()
addtag (String -> Branch
BC.pack String
"Anonymous Tagger <> 0 +0000") Branch
branch
               Maybe RefId
_ -> IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING: Ignoring out-of-order tag " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                        Branch -> String
decodeLocale Branch
branch
             State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (State p -> TreeIO (State p)) -> State p -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ Marked -> Branch -> State p
forall (p :: * -> * -> *). Marked -> Branch -> State p
Toplevel Marked
n Branch
branch

        process (Toplevel Marked
n Branch
b) (Blob (Just Int
m) Branch
bits) = do
          AnchoredPath -> ByteString -> TreeIO ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> ByteString -> TreeMonad m ()
TM.writeFile (Int -> AnchoredPath
markpath Int
m) ([Branch] -> ByteString
BLC.fromChunks [Branch
bits])
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (State p -> TreeIO (State p)) -> State p -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ Marked -> Branch -> State p
forall (p :: * -> * -> *). Marked -> Branch -> State p
Toplevel Marked
n Branch
b

        process State p
x (Gitlink Branch
link) = do
          IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING: Ignoring gitlink " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Branch -> String
decodeLocale Branch
link
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return State p
x

        process (Toplevel Marked
previous Branch
pbranch) (Commit Branch
branch Marked
mark Branch
author Branch
message) = do
          Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Branch
pbranch Branch -> Branch -> Bool
forall a. Eq a => a -> a -> Bool
/= Branch
branch) (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ do
            IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"Tagging branch: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Branch -> String
decodeLocale Branch
pbranch)
            Branch -> Branch -> TreeIO ()
forall (m :: * -> *). MonadIO m => Branch -> Branch -> m ()
addtag Branch
author Branch
pbranch
          PatchInfo
info_ <- Branch
-> Branch
-> Bool
-> RWST (TreeEnv IO) () (TreeState IO) IO PatchInfo
forall (m :: * -> *).
MonadIO m =>
Branch -> Branch -> Bool -> m PatchInfo
makeinfo Branch
author Branch
message Bool
False
          Tree IO
startstate <- RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
updateHashes
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (State p -> TreeIO (State p)) -> State p -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ Marked
-> Ancestors
-> Branch
-> Tree IO
-> RL (PrimOf p) Any Any
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Marked
-> Ancestors
-> Branch
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Marked
mark (Marked
previous, []) Branch
branch Tree IO
startstate RL (PrimOf p) Any Any
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL PatchInfo
info_

        process s :: State p
s@InCommit {} (Modify (Left Int
m) Branch
path) = do
          AnchoredPath -> AnchoredPath -> TreeIO ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> AnchoredPath -> TreeMonad m ()
TM.copy (Int -> AnchoredPath
markpath Int
m) (Branch -> AnchoredPath
decodePath Branch
path)
          State p -> TreeIO (State p)
diffCurrent State p
s

        process s :: State p
s@InCommit {} (Modify (Right Branch
bits) Branch
path) = do
          AnchoredPath -> ByteString -> TreeIO ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> ByteString -> TreeMonad m ()
TM.writeFile (Branch -> AnchoredPath
decodePath Branch
path) ([Branch] -> ByteString
BLC.fromChunks [Branch
bits])
          State p -> TreeIO (State p)
diffCurrent State p
s

        process s :: State p
s@InCommit {} (Delete Branch
path) = do
          let floatedPath :: AnchoredPath
floatedPath = Branch -> AnchoredPath
decodePath Branch
path
          AnchoredPath -> TreeIO ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.unlink AnchoredPath
floatedPath
          AnchoredPath -> TreeIO ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
deleteEmptyParents AnchoredPath
floatedPath
          State p -> TreeIO (State p)
diffCurrent State p
s

        process (InCommit Marked
mark (Marked
prev, [Int]
current) Branch
branch Tree IO
start RL (PrimOf p) cX cY
ps PatchInfo
info_) (From Int
from) =
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (State p -> TreeIO (State p)) -> State p -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ Marked
-> Ancestors
-> Branch
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Marked
-> Ancestors
-> Branch
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Marked
mark (Marked
prev, Int
fromInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
current) Branch
branch Tree IO
start RL (PrimOf p) cX cY
ps PatchInfo
info_

        process (InCommit Marked
mark (Marked
prev, [Int]
current) Branch
branch Tree IO
start RL (PrimOf p) cX cY
ps PatchInfo
info_) (Merge Int
from) =
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (State p -> TreeIO (State p)) -> State p -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ Marked
-> Ancestors
-> Branch
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Marked
-> Ancestors
-> Branch
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Marked
mark (Marked
prev, Int
fromInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
current) Branch
branch Tree IO
start RL (PrimOf p) cX cY
ps PatchInfo
info_

        process s :: State p
s@InCommit {} (Copy CopyRenameNames
names) = do
            (Branch
from, Branch
to) <- CopyRenameNames -> TreeIO (Branch, Branch)
extractNames CopyRenameNames
names
            AnchoredPath -> AnchoredPath -> TreeIO ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> AnchoredPath -> TreeMonad m ()
TM.copy (Branch -> AnchoredPath
decodePath Branch
from) (Branch -> AnchoredPath
decodePath Branch
to)
            -- We can't tell Darcs that a file has been copied, so it'll
            -- show as an addfile.
            State p -> TreeIO (State p)
diffCurrent State p
s

        process s :: State p
s@(InCommit Marked
mark Ancestors
ancestors Branch
branch Tree IO
start RL (PrimOf p) cX cY
_ PatchInfo
info_) (Rename CopyRenameNames
names) = do
          (Branch
from, Branch
to) <- CopyRenameNames -> TreeIO (Branch, Branch)
extractNames CopyRenameNames
names
          let uFrom :: AnchoredPath
uFrom = Branch -> AnchoredPath
decodePath Branch
from
              uTo :: AnchoredPath
uTo = Branch -> AnchoredPath
decodePath Branch
to
          case AnchoredPath -> Maybe AnchoredPath
parent AnchoredPath
uTo of
            Maybe AnchoredPath
Nothing ->
              -- no parents i.e. target is root => nothing to do
              () -> TreeIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just AnchoredPath
parentDir -> do
              Bool
targetDirExists <- IO Bool -> RWST (TreeEnv IO) () (TreeState IO) IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RWST (TreeEnv IO) () (TreeState IO) IO Bool)
-> IO Bool -> RWST (TreeEnv IO) () (TreeState IO) IO Bool
forall a b. (a -> b) -> a -> b
$ Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
start AnchoredPath
uTo
              Bool
targetFileExists <- IO Bool -> RWST (TreeEnv IO) () (TreeState IO) IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RWST (TreeEnv IO) () (TreeState IO) IO Bool)
-> IO Bool -> RWST (TreeEnv IO) () (TreeState IO) IO Bool
forall a b. (a -> b) -> a -> b
$ Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasFile Tree IO
start AnchoredPath
uTo
              Bool
parentDirExists <-
                  IO Bool -> RWST (TreeEnv IO) () (TreeState IO) IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RWST (TreeEnv IO) () (TreeState IO) IO Bool)
-> IO Bool -> RWST (TreeEnv IO) () (TreeState IO) IO Bool
forall a b. (a -> b) -> a -> b
$ Tree IO -> AnchoredPath -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> AnchoredPath -> m Bool
treeHasDir Tree IO
start AnchoredPath
parentDir
              -- If the target exists, remove it; if it doesn't, add all
              -- its parent directories.
              if Bool
targetDirExists Bool -> Bool -> Bool
|| Bool
targetFileExists
                  then AnchoredPath -> TreeIO ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.unlink AnchoredPath
uTo
                  else Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
parentDirExists (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> TreeIO ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.createDirectory AnchoredPath
parentDir
          (InCommit Marked
_ Ancestors
_ Branch
_ Tree IO
_ RL (PrimOf p) cX cY
newPs PatchInfo
_) <- State p -> TreeIO (State p)
diffCurrent State p
s
          AnchoredPath -> AnchoredPath -> TreeIO ()
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 RL (PrimOf p) cX cY -> PrimOf p cY wZ -> RL (PrimOf p) cX wZ
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: AnchoredPath -> AnchoredPath -> PrimOf p cY 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
          -- ensure empty dirs get deleted
          AnchoredPath -> TreeIO ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
deleteEmptyParents AnchoredPath
uFrom
          -- run diffCurrent to add the dir deletions prims
          State p -> TreeIO (State p)
diffCurrent (Marked
-> Ancestors
-> Branch
-> Tree IO
-> RL (PrimOf p) cX Any
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Marked
-> Ancestors
-> Branch
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Marked
mark Ancestors
ancestors Branch
branch Tree IO
current RL (PrimOf p) cX Any
forall wZ. RL (PrimOf p) cX wZ
ps' PatchInfo
info_)

        -- When we leave the commit, create a patch for the cumulated
        -- prims.
        process (InCommit Marked
mark Ancestors
ancestors Branch
branch Tree IO
_ RL (PrimOf p) cX cY
ps PatchInfo
info_) Object
x = do
          case Ancestors
ancestors of
            (Marked
_, []) -> () -> TreeIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- OK, previous commit is the ancestor
            (Just Int
n, [Int]
list)
              | Int
n Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
list -> () -> TreeIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- OK, we base off one of the ancestors
              | Bool
otherwise -> IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                               String
"WARNING: Linearising non-linear ancestry:" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                               String
" currently at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", ancestors " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
list
            (Marked
Nothing, [Int]
list) ->
              IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING: Linearising non-linear ancestry " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
list

          {- current <- updateHashes -} -- why not?
          (prims :: FL (PrimOf p) cX cY)  <- FL (PrimOf p) cX cY
-> RWST (TreeEnv IO) () (TreeState IO) IO (FL (PrimOf p) cX cY)
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (PrimOf p) cX cY
 -> RWST (TreeEnv IO) () (TreeState IO) IO (FL (PrimOf p) cX cY))
-> FL (PrimOf p) cX cY
-> RWST (TreeEnv IO) () (TreeState IO) IO (FL (PrimOf p) cX cY)
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) cX cY -> FL (PrimOf p) cX cY
forall (prim :: * -> * -> *) wX wY.
PrimCanonize prim =>
FL prim wX wY -> FL prim wX wY
sortCoalesceFL (FL (PrimOf p) cX cY -> FL (PrimOf p) cX cY)
-> FL (PrimOf p) cX cY -> FL (PrimOf p) cX cY
forall a b. (a -> b) -> a -> b
$ RL (PrimOf p) cX cY -> FL (PrimOf p) cX cY
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 = PatchInfo -> FL (PrimOf p) cX cY -> Named p cX cY
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
          IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ Cache -> Compression -> PatchInfoAnd Any p cX cY -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
Cache -> Compression -> PatchInfoAnd rt p wX wY -> IO ()
addToTentativeInventory (Repository rt p r u r -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p r u r
repo)
                                                  Compression
GzipCompression (Named p cX cY -> PatchInfoAnd Any p cX cY
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 Marked
mark of
            Marked
Nothing -> () -> TreeIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Int
n -> case Marks -> Int -> Maybe Branch
getMark Marks
marks Int
n of
              Maybe Branch
Nothing -> IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ IORef Marks -> (Marks -> Marks) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Marks
marksref ((Marks -> Marks) -> IO ()) -> (Marks -> Marks) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Marks
m -> Marks -> Int -> Branch -> Marks
addMark Marks
m Int
n (PatchInfoAnd Any p cX cY -> Branch
forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> Branch
patchHash (PatchInfoAnd Any p cX cY -> Branch)
-> PatchInfoAnd Any p cX cY -> Branch
forall a b. (a -> b) -> a -> b
$ Named p cX cY -> PatchInfoAnd Any p cX cY
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 Branch
n' -> String -> TreeIO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TreeIO ()) -> String -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String
"FATAL: Mark already exists: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Branch -> String
decodeLocale Branch
n'
          State p -> Object -> TreeIO (State p)
process (Marked -> Branch -> State p
forall (p :: * -> * -> *). Marked -> Branch -> State p
Toplevel Marked
mark Branch
branch) Object
x

        process State p
state Object
obj = do
          IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ Object -> IO ()
forall a. Show a => a -> IO ()
print Object
obj
          String -> TreeIO (State p)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TreeIO (State p)) -> String -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ String
"Unexpected object in state " String -> ShowS
forall a. [a] -> [a] -> [a]
++ State p -> String
forall a. Show a => a -> String
show State p
state

        extractNames :: CopyRenameNames
                     -> TreeIO (BC.ByteString, BC.ByteString)
        extractNames :: CopyRenameNames -> TreeIO (Branch, Branch)
extractNames CopyRenameNames
names = case CopyRenameNames
names of
            Quoted Branch
f Branch
t -> (Branch, Branch) -> TreeIO (Branch, Branch)
forall (m :: * -> *) a. Monad m => a -> m a
return (Branch
f, Branch
t)
            Unquoted Branch
uqNames -> do
                let spaceIndices :: [Int]
spaceIndices = Char -> Branch -> [Int]
BC.elemIndices Char
' ' Branch
uqNames
                    splitStr :: Int -> (Branch, Branch)
splitStr = (Branch -> Branch) -> (Branch, Branch) -> (Branch, Branch)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> Branch -> Branch
BC.drop Int
1) ((Branch, Branch) -> (Branch, Branch))
-> (Int -> (Branch, Branch)) -> Int -> (Branch, Branch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Branch -> (Branch, Branch))
-> Branch -> Int -> (Branch, Branch)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Branch -> (Branch, Branch)
BC.splitAt Branch
uqNames
                    -- Reverse the components, so we find the longest
                    -- prefix existing name.
                    spaceComponents :: [(Branch, Branch)]
spaceComponents = [(Branch, Branch)] -> [(Branch, Branch)]
forall a. [a] -> [a]
reverse ([(Branch, Branch)] -> [(Branch, Branch)])
-> [(Branch, Branch)] -> [(Branch, Branch)]
forall a b. (a -> b) -> a -> b
$ (Int -> (Branch, Branch)) -> [Int] -> [(Branch, Branch)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (Branch, Branch)
splitStr [Int]
spaceIndices
                    componentCount :: Int
componentCount = [(Branch, Branch)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Branch, Branch)]
spaceComponents
                if Int
componentCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
                    then (Branch, Branch) -> TreeIO (Branch, Branch)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Branch, Branch) -> TreeIO (Branch, Branch))
-> (Branch, Branch) -> TreeIO (Branch, Branch)
forall a b. (a -> b) -> a -> b
$ [(Branch, Branch)] -> (Branch, Branch)
forall a. [a] -> a
head [(Branch, Branch)]
spaceComponents
                    else do
                        let dieMessage :: String
dieMessage = [String] -> String
unwords
                                [ String
"Couldn't determine move/rename"
                                , String
"source/destination filenames, with the"
                                , String
"data produced by this (old) version of"
                                , String
"git, since it uses unquoted, but"
                                , String
"special-character-containing paths."
                                ]
                            lPathExists :: (Branch, b) -> TreeMonad m Bool
lPathExists (Branch
l,b
_) =
                                AnchoredPath -> TreeMonad m Bool
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
TM.fileExists (AnchoredPath -> TreeMonad m Bool)
-> AnchoredPath -> TreeMonad m Bool
forall a b. (a -> b) -> a -> b
$ Branch -> AnchoredPath
decodePath Branch
l
                            finder :: [(Branch, b)] -> RWST (TreeEnv m) () (TreeState m) m (Branch, b)
finder [] = String -> RWST (TreeEnv m) () (TreeState m) m (Branch, b)
forall a. HasCallStack => String -> a
error String
dieMessage
                            finder ((Branch, b)
x : [(Branch, b)]
rest) = do
                                Bool
xExists <- (Branch, b) -> TreeMonad m Bool
forall (m :: * -> *) b. Monad m => (Branch, b) -> TreeMonad m Bool
lPathExists (Branch, b)
x
                                if Bool
xExists then (Branch, b) -> RWST (TreeEnv m) () (TreeState m) m (Branch, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Branch, b)
x else [(Branch, b)] -> RWST (TreeEnv m) () (TreeState m) m (Branch, b)
finder [(Branch, b)]
rest
                        [(Branch, Branch)] -> TreeIO (Branch, Branch)
forall (m :: * -> *) b.
Monad m =>
[(Branch, b)] -> RWST (TreeEnv m) () (TreeState m) m (Branch, b)
finder [(Branch, Branch)]
spaceComponents

    IO ((), Tree IO) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ((), Tree IO) -> IO ()) -> IO ((), Tree IO) -> IO ()
forall a b. (a -> b) -> a -> b
$ TreeIO () -> Tree IO -> String -> IO ((), Tree IO)
forall a. TreeIO a -> Tree IO -> String -> IO (a, Tree IO)
hashedTreeIO (State p -> Branch -> TreeIO ()
go State p
forall (p :: * -> * -> *). State p
initial Branch
B.empty) Tree IO
pristine String
pristineDirPath

parseObject :: BC.ByteString -> TreeIO ( BC.ByteString, Object )
parseObject :: Branch -> TreeIO (Branch, Object)
parseObject = (Branch -> Result (Maybe Object))
-> Branch -> TreeIO (Branch, Object)
next' Branch -> Result (Maybe Object)
mbObject
  where mbObject :: Branch -> Result (Maybe Object)
mbObject = Parser (Maybe Object) -> Branch -> Result (Maybe Object)
forall a. Parser a -> Branch -> Result a
A.parse Parser (Maybe Object)
p_maybeObject

        p_maybeObject :: Parser (Maybe Object)
p_maybeObject = Object -> Maybe Object
forall a. a -> Maybe a
Just (Object -> Maybe Object)
-> Parser Branch Object -> Parser (Maybe Object)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Branch Object
p_object
                        Parser (Maybe Object)
-> Parser (Maybe Object) -> Parser (Maybe Object)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser Branch ()
forall t. Chunk t => Parser t ()
A.endOfInput Parser Branch () -> Parser (Maybe Object) -> Parser (Maybe Object)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Object -> Parser (Maybe Object)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Object
forall a. Maybe a
Nothing)

        lex :: Parser Branch b -> Parser Branch b
lex Parser Branch b
p = Parser Branch b
p Parser Branch b -> (b -> Parser Branch b) -> Parser Branch b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
x -> Parser Branch ()
A.skipSpace Parser Branch () -> Parser Branch b -> Parser Branch b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Parser Branch b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
        lexString :: String -> Parser Branch ()
lexString String
s = Branch -> Parser Branch
A.string (String -> Branch
BC.pack String
s) Parser Branch -> Parser Branch () -> Parser Branch ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Branch ()
A.skipSpace
        line :: Parser Branch
line = Parser Branch -> Parser Branch
forall b. Parser Branch b -> Parser Branch b
lex (Parser Branch -> Parser Branch) -> Parser Branch -> Parser Branch
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Branch
A.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n')

        optional :: f a -> f (Maybe a)
optional f a
p = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> f a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` f a
p f (Maybe a) -> f (Maybe a) -> f (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a -> f (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

        p_object :: Parser Branch Object
p_object = Parser Branch Object
p_blob
                   Parser Branch Object
-> Parser Branch Object -> Parser Branch Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Branch Object
p_reset
                   Parser Branch Object
-> Parser Branch Object -> Parser Branch Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Branch Object
p_commit
                   Parser Branch Object
-> Parser Branch Object -> Parser Branch Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Branch Object
p_tag
                   Parser Branch Object
-> Parser Branch Object -> Parser Branch Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Branch Object
p_modify
                   Parser Branch Object
-> Parser Branch Object -> Parser Branch Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Branch Object
p_rename
                   Parser Branch Object
-> Parser Branch Object -> Parser Branch Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Branch Object
p_copy
                   Parser Branch Object
-> Parser Branch Object -> Parser Branch Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Branch Object
p_from
                   Parser Branch Object
-> Parser Branch Object -> Parser Branch Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Branch Object
p_merge
                   Parser Branch Object
-> Parser Branch Object -> Parser Branch Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Branch Object
p_delete
                   Parser Branch Object
-> Parser Branch Object -> Parser Branch Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> Parser Branch ()
lexString String
"progress" Parser Branch () -> Parser Branch Object -> Parser Branch Object
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Branch -> Object
Progress (Branch -> Object) -> Parser Branch -> Parser Branch Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Branch
line)

        p_author :: String -> Parser Branch
p_author String
name = String -> Parser Branch ()
lexString String
name Parser Branch () -> Parser Branch -> Parser Branch
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Branch
line

        p_reset :: Parser Branch Object
p_reset = do String -> Parser Branch ()
lexString String
"reset"
                     Branch
branch <- Parser Branch
line
                     Maybe RefId
refid <- Parser Branch RefId -> Parser Branch (Maybe RefId)
forall (f :: * -> *) a.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional (Parser Branch RefId -> Parser Branch (Maybe RefId))
-> Parser Branch RefId -> Parser Branch (Maybe RefId)
forall a b. (a -> b) -> a -> b
$ String -> Parser Branch ()
lexString String
"from" Parser Branch () -> Parser Branch RefId -> Parser Branch RefId
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Branch RefId
p_refid
                     Object -> Parser Branch Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser Branch Object) -> Object -> Parser Branch Object
forall a b. (a -> b) -> a -> b
$ Branch -> Maybe RefId -> Object
Reset Branch
branch Maybe RefId
refid

        p_commit :: Parser Branch Object
p_commit = do String -> Parser Branch ()
lexString String
"commit"
                      Branch
branch <- Parser Branch
line
                      Marked
mark <- Parser Branch Int -> Parser Branch Marked
forall (f :: * -> *) a.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional Parser Branch Int
p_mark
                      Maybe Branch
_ <- Parser Branch -> Parser Branch (Maybe Branch)
forall (f :: * -> *) a.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional (Parser Branch -> Parser Branch (Maybe Branch))
-> Parser Branch -> Parser Branch (Maybe Branch)
forall a b. (a -> b) -> a -> b
$ String -> Parser Branch
p_author String
"author"
                      Branch
committer <- String -> Parser Branch
p_author String
"committer"
                      Branch
message <- Parser Branch
p_data
                      Object -> Parser Branch Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser Branch Object) -> Object -> Parser Branch Object
forall a b. (a -> b) -> a -> b
$ Branch -> Marked -> Branch -> Branch -> Object
Commit Branch
branch Marked
mark Branch
committer Branch
message

        p_tag :: Parser Branch Object
p_tag = do ()
_ <- String -> Parser Branch ()
lexString String
"tag"
                   Branch
tag <- Parser Branch
line
                   String -> Parser Branch ()
lexString String
"from"
                   Int
mark <- Parser Branch Int
p_marked
                   Branch
author <- String -> Parser Branch
p_author String
"tagger"
                   Branch
message <- Parser Branch
p_data
                   Object -> Parser Branch Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser Branch Object) -> Object -> Parser Branch Object
forall a b. (a -> b) -> a -> b
$ Branch -> Int -> Branch -> Branch -> Object
Tag Branch
tag Int
mark Branch
author Branch
message

        p_blob :: Parser Branch Object
p_blob = do String -> Parser Branch ()
lexString String
"blob"
                    Marked
mark <- Parser Branch Int -> Parser Branch Marked
forall (f :: * -> *) a.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional Parser Branch Int
p_mark
                    Marked -> Branch -> Object
Blob Marked
mark (Branch -> Object) -> Parser Branch -> Parser Branch Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Branch
p_data
                  Parser Branch Object -> String -> Parser Branch Object
forall i a. Parser i a -> String -> Parser i a
<?> String
"p_blob"

        p_mark :: Parser Branch Int
p_mark = do String -> Parser Branch ()
lexString String
"mark"
                    Parser Branch Int
p_marked
                  Parser Branch Int -> String -> Parser Branch Int
forall i a. Parser i a -> String -> Parser i a
<?> String
"p_mark"

        p_refid :: Parser Branch RefId
p_refid = Int -> RefId
MarkId (Int -> RefId) -> Parser Branch Int -> Parser Branch RefId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Branch Int
p_marked
                  Parser Branch RefId -> Parser Branch RefId -> Parser Branch RefId
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> Parser Branch ()
lexString String
"inline" Parser Branch () -> Parser Branch RefId -> Parser Branch RefId
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RefId -> Parser Branch RefId
forall (m :: * -> *) a. Monad m => a -> m a
return RefId
Inline)
                  Parser Branch RefId -> Parser Branch RefId -> Parser Branch RefId
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Branch -> RefId
HashId (Branch -> RefId) -> Parser Branch -> Parser Branch RefId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Branch
p_hash

        p_data :: Parser Branch
p_data = do String -> Parser Branch ()
lexString String
"data"
                    Int
len <- Parser Branch Int
forall a. Integral a => Parser a
A.decimal
                    Char
_ <- Char -> Parser Char
A.char Char
'\n'
                    Parser Branch -> Parser Branch
forall b. Parser Branch b -> Parser Branch b
lex (Parser Branch -> Parser Branch) -> Parser Branch -> Parser Branch
forall a b. (a -> b) -> a -> b
$ Int -> Parser Branch
A.take Int
len
                  Parser Branch -> String -> Parser Branch
forall i a. Parser i a -> String -> Parser i a
<?> String
"p_data"

        p_marked :: Parser Branch Int
p_marked = Parser Branch Int -> Parser Branch Int
forall b. Parser Branch b -> Parser Branch b
lex (Parser Branch Int -> Parser Branch Int)
-> Parser Branch Int -> Parser Branch Int
forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
A.char Char
':' Parser Char -> Parser Branch Int -> Parser Branch Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Branch Int
forall a. Integral a => Parser a
A.decimal
        p_hash :: Parser Branch
p_hash = Parser Branch -> Parser Branch
forall b. Parser Branch b -> Parser Branch b
lex (Parser Branch -> Parser Branch) -> Parser Branch -> Parser Branch
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Branch
A.takeWhile1 (String -> Char -> Bool
A.inClass String
"0123456789abcdefABCDEF")
        p_from :: Parser Branch Object
p_from = String -> Parser Branch ()
lexString String
"from" Parser Branch () -> Parser Branch Object -> Parser Branch Object
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Object
From (Int -> Object) -> Parser Branch Int -> Parser Branch Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Branch Int
p_marked
        p_merge :: Parser Branch Object
p_merge = String -> Parser Branch ()
lexString String
"merge" Parser Branch () -> Parser Branch Object -> Parser Branch Object
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Object
Merge (Int -> Object) -> Parser Branch Int -> Parser Branch Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Branch Int
p_marked
        p_delete :: Parser Branch Object
p_delete = String -> Parser Branch ()
lexString String
"D" Parser Branch () -> Parser Branch Object -> Parser Branch Object
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Branch -> Object
Delete (Branch -> Object) -> Parser Branch -> Parser Branch Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Branch
p_maybeQuotedName
        p_rename :: Parser Branch Object
p_rename = do String -> Parser Branch ()
lexString String
"R"
                      CopyRenameNames
names <- Parser Branch CopyRenameNames
p_maybeQuotedCopyRenameNames
                      Object -> Parser Branch Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser Branch Object) -> Object -> Parser Branch Object
forall a b. (a -> b) -> a -> b
$ CopyRenameNames -> Object
Rename CopyRenameNames
names
        p_copy :: Parser Branch Object
p_copy = do String -> Parser Branch ()
lexString String
"C"
                    CopyRenameNames
names <- Parser Branch CopyRenameNames
p_maybeQuotedCopyRenameNames
                    Object -> Parser Branch Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser Branch Object) -> Object -> Parser Branch Object
forall a b. (a -> b) -> a -> b
$ CopyRenameNames -> Object
Copy CopyRenameNames
names
        p_modify :: Parser Branch Object
p_modify = do String -> Parser Branch ()
lexString String
"M"
                      Branch
mode <- Parser Branch -> Parser Branch
forall b. Parser Branch b -> Parser Branch b
lex (Parser Branch -> Parser Branch) -> Parser Branch -> Parser Branch
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Branch
A.takeWhile (String -> Char -> Bool
A.inClass String
"01234567890")
                      RefId
mark <- Parser Branch RefId
p_refid
                      Branch
path <- Parser Branch
p_maybeQuotedName
                      case RefId
mark of
                        HashId Branch
hash | Branch
mode Branch -> Branch -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Branch
BC.pack String
"160000" -> Object -> Parser Branch Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser Branch Object) -> Object -> Parser Branch Object
forall a b. (a -> b) -> a -> b
$ Branch -> Object
Gitlink Branch
hash
                                    | Bool
otherwise -> String -> Parser Branch Object
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
":(("
                        MarkId Int
n -> Object -> Parser Branch Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser Branch Object) -> Object -> Parser Branch Object
forall a b. (a -> b) -> a -> b
$ Either Int Branch -> Branch -> Object
Modify (Int -> Either Int Branch
forall a b. a -> Either a b
Left Int
n) Branch
path
                        RefId
Inline -> do Branch
bits <- Parser Branch
p_data
                                     Object -> Parser Branch Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser Branch Object) -> Object -> Parser Branch Object
forall a b. (a -> b) -> a -> b
$ Either Int Branch -> Branch -> Object
Modify (Branch -> Either Int Branch
forall a b. b -> Either a b
Right Branch
bits) Branch
path
        p_maybeQuotedCopyRenameNames :: Parser Branch CopyRenameNames
p_maybeQuotedCopyRenameNames =
            Parser Branch CopyRenameNames
p_lexTwoQuotedNames Parser Branch CopyRenameNames
-> Parser Branch CopyRenameNames -> Parser Branch CopyRenameNames
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Branch -> CopyRenameNames
Unquoted (Branch -> CopyRenameNames)
-> Parser Branch -> Parser Branch CopyRenameNames
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Branch
line
        p_lexTwoQuotedNames :: Parser Branch CopyRenameNames
p_lexTwoQuotedNames = do
            Branch
n1 <- Parser Branch -> Parser Branch
forall b. Parser Branch b -> Parser Branch b
lex Parser Branch
p_quotedName
            Branch
n2 <- Parser Branch -> Parser Branch
forall b. Parser Branch b -> Parser Branch b
lex Parser Branch
p_quotedName
            CopyRenameNames -> Parser Branch CopyRenameNames
forall (m :: * -> *) a. Monad m => a -> m a
return (CopyRenameNames -> Parser Branch CopyRenameNames)
-> CopyRenameNames -> Parser Branch CopyRenameNames
forall a b. (a -> b) -> a -> b
$ Branch -> Branch -> CopyRenameNames
Quoted Branch
n1 Branch
n2
        p_maybeQuotedName :: Parser Branch
p_maybeQuotedName = Parser Branch -> Parser Branch
forall b. Parser Branch b -> Parser Branch b
lex (Parser Branch
p_quotedName Parser Branch -> Parser Branch -> Parser Branch
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Branch
line)
        p_quotedName :: Parser Branch
p_quotedName = do
          Char
_ <- Char -> Parser Char
A.char Char
'"'
          [Branch]
bytes <- Parser Branch -> Parser Branch [Branch]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Branch
p_escaped Parser Branch -> Parser Branch -> Parser Branch
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Branch
p_unescaped)
          Char
_ <- Char -> Parser Char
A.char Char
'"'
          Branch -> Parser Branch
forall (m :: * -> *) a. Monad m => a -> m a
return (Branch -> Parser Branch) -> Branch -> Parser Branch
forall a b. (a -> b) -> a -> b
$ [Branch] -> Branch
B.concat [Branch]
bytes
        p_unescaped :: Parser Branch
p_unescaped = (Char -> Bool) -> Parser Branch
A.takeWhile1 (\Char
c->Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'"' Bool -> Bool -> Bool
&& Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\\')
        p_escaped :: Parser Branch
p_escaped = do
          Char
_ <- Char -> Parser Char
A.char Char
'\\'
          Parser Branch
p_escaped_octal Parser Branch -> Parser Branch -> Parser Branch
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Branch
p_escaped_char
        p_escaped_octal :: Parser Branch
p_escaped_octal = do
          let octals :: [Char]
              octals :: String
octals = String
"01234567"
          Branch
s <- (Char -> Bool) -> Parser Branch
A.takeWhile1 (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
octals)
          let x :: Word8
              x :: Word8
x = String -> Word8
forall a. Read a => String -> a
read (String
"0o" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Branch -> String
BC.unpack Branch
s)
          Branch -> Parser Branch
forall (m :: * -> *) a. Monad m => a -> m a
return (Branch -> Parser Branch) -> Branch -> Parser Branch
forall a b. (a -> b) -> a -> b
$ Word8 -> Branch
B.singleton (Word8 -> Branch) -> Word8 -> Branch
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x
        p_escaped_char :: Parser Branch
p_escaped_char =
          (Char -> Branch) -> Parser Char -> Parser Branch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Branch
BC.singleton (Parser Char -> Parser Branch) -> Parser Char -> Parser Branch
forall a b. (a -> b) -> a -> b
$
          Char
'\r' Char -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
A.char Char
'r' Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char
'\n' Char -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
A.char Char
'n' Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
A.char Char
'"' Parser Char -> Parser Char -> Parser 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' :: (Branch -> Result (Maybe Object))
-> Branch -> TreeIO (Branch, Object)
next' Branch -> Result (Maybe Object)
parser Branch
rest =
          do Branch
chunk <- if Branch -> Bool
B.null Branch
rest then IO Branch -> RWST (TreeEnv IO) () (TreeState IO) IO Branch
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Branch -> RWST (TreeEnv IO) () (TreeState IO) IO Branch)
-> IO Branch -> RWST (TreeEnv IO) () (TreeState IO) IO Branch
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO Branch
B.hGet Handle
stdin (Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024)
                                     else Branch -> RWST (TreeEnv IO) () (TreeState IO) IO Branch
forall (m :: * -> *) a. Monad m => a -> m a
return Branch
rest
             (Branch -> Result (Maybe Object))
-> Branch -> TreeIO (Branch, Object)
next_chunk Branch -> Result (Maybe Object)
parser Branch
chunk

        next_chunk :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)
        next_chunk :: (Branch -> Result (Maybe Object))
-> Branch -> TreeIO (Branch, Object)
next_chunk Branch -> Result (Maybe Object)
parser Branch
chunk =
          case Branch -> Result (Maybe Object)
parser Branch
chunk of
             A.Done Branch
rest Maybe Object
result -> (Branch, Object) -> TreeIO (Branch, Object)
forall (m :: * -> *) a. Monad m => a -> m a
return (Branch
rest, Object -> (Object -> Object) -> Maybe Object -> Object
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Object
End Object -> Object
forall a. a -> a
id Maybe Object
result) -- not sure about the maybe
             A.Partial Branch -> Result (Maybe Object)
cont -> (Branch -> Result (Maybe Object))
-> Branch -> TreeIO (Branch, Object)
next' Branch -> Result (Maybe Object)
cont Branch
B.empty
             A.Fail Branch
_ [String]
ctx String
err -> do
               IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"=== chunk ===\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Branch -> String
decodeLocale Branch
chunk String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n=== end chunk ===="
               String -> TreeIO (Branch, Object)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TreeIO (Branch, Object))
-> String -> TreeIO (Branch, Object)
forall a b. (a -> b) -> a -> b
$ String
"Error parsing stream. " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nContext: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
ctx

decodePath :: BC.ByteString -> AnchoredPath
decodePath :: Branch -> AnchoredPath
decodePath = String -> AnchoredPath
floatPath (String -> AnchoredPath)
-> (Branch -> String) -> Branch -> AnchoredPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch -> String
decodeLocale