--  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(..)
    , (+<<+)
    , reverseRL
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft )

import Darcs.Patch.Info ( PatchInfo, patchinfo )
import Darcs.Patch.Prim ( canonizeFL )

import Darcs.Repository
    ( EmptyRepository(..)
    , AccessType(RW)
    , Repository
    , cleanRepository
    , createPristineDirectoryTree
    , createRepository
    , finalizeRepositoryChanges
    , readPatches
    , repoCache
    , revertRepositoryChanges
    , withUMaskFlag
    )
import Darcs.Repository.Diff (treeDiff)
import Darcs.Repository.Hashed (addToTentativeInventory)
import Darcs.Repository.Paths (tentativePristinePath)
import Darcs.Repository.Prefs (FileType(..))
import Darcs.Repository.State (readPristine)

import Darcs.UI.Commands
    ( DarcsCommand(..)
    , nodefaults
    , withStdOpts
    )
import Darcs.UI.Commands.Convert.Util
    ( Marks
    , addMark
    , emptyMarks
    , getMark
    , patchHash
    )
import Darcs.UI.Commands.Util ( commonHelpWithPrefsTemplates )
import Darcs.UI.Completion (noArgs)
import Darcs.UI.Flags
    ( DarcsFlag
    , patchFormat
    , patchIndexNo
    , umask
    , useCache
    , withWorkingDir
    )
import Darcs.UI.Options ( (?), (^) )
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 (encodeBase16, sha256)
import Darcs.Util.Lock (withNewDirectory)
import Darcs.Util.Path
    ( AbsolutePath
    , AnchoredPath(..)
    , appendPath
    , unsafeFloatPath
    , 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
    , treeHasDir
    , treeHasFile
    , 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 ([[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."
 ])
 Doc -> Doc -> Doc
$+$ Doc
commonHelpWithPrefsTemplates

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]
_ -> Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] () -> IO (Either [Char] ()))
-> Either [Char] () -> IO (Either [Char] ())
forall a b. (a -> b) -> a -> b
$ () -> Either [Char] ()
forall a b. b -> Either a b
Right ()
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [[Char]] -> IO [[Char]]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [[Char]] -> IO [[Char]]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [[Char]] -> IO [[Char]]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [[Char]] -> IO [[Char]]
nodefaults
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
opts
    }
  where
    basicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe [Char]
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
basicOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
  (Maybe [Char])
PrimDarcsOption (Maybe [Char])
O.newRepo
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
  (Maybe [Char])
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (PatchFormat -> WithWorkingDir -> a)
     (SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (PatchFormat -> WithWorkingDir -> a)
     (Maybe [Char]
      -> 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 [Char]
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WithWorkingDir -> a)
     (PatchFormat -> WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WithWorkingDir -> a)
     (Maybe [Char]
      -> 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 [Char]
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe [Char]
      -> 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
    advancedOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (DiffAlgorithm
   -> WithPatchIndex -> UMask -> WithPrefsTemplates -> a)
advancedOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (WithPatchIndex -> UMask -> WithPrefsTemplates -> a)
  DiffAlgorithm
PrimDarcsOption DiffAlgorithm
O.diffAlgorithm
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (WithPatchIndex -> UMask -> WithPrefsTemplates -> a)
  DiffAlgorithm
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (UMask -> WithPrefsTemplates -> a)
     (WithPatchIndex -> UMask -> WithPrefsTemplates -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (UMask -> WithPrefsTemplates -> a)
     (DiffAlgorithm
      -> WithPatchIndex -> UMask -> WithPrefsTemplates -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (UMask -> WithPrefsTemplates -> a)
  (WithPatchIndex -> UMask -> WithPrefsTemplates -> a)
PrimDarcsOption WithPatchIndex
O.patchIndexNo
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (UMask -> WithPrefsTemplates -> a)
  (DiffAlgorithm
   -> WithPatchIndex -> UMask -> WithPrefsTemplates -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WithPrefsTemplates -> a)
     (UMask -> WithPrefsTemplates -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WithPrefsTemplates -> a)
     (DiffAlgorithm
      -> WithPatchIndex -> UMask -> WithPrefsTemplates -> 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
  (WithPrefsTemplates -> a)
  (UMask -> WithPrefsTemplates -> a)
PrimDarcsOption UMask
O.umask
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (WithPrefsTemplates -> a)
  (DiffAlgorithm
   -> WithPatchIndex -> UMask -> WithPrefsTemplates -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (WithPrefsTemplates -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (DiffAlgorithm
      -> WithPatchIndex -> UMask -> WithPrefsTemplates -> 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 (WithPrefsTemplates -> a)
PrimDarcsOption WithPrefsTemplates
O.withPrefsTemplates
    opts :: CommandOptions
opts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> DiffAlgorithm
   -> WithPatchIndex
   -> UMask
   -> WithPrefsTemplates
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe [Char]
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> DiffAlgorithm
   -> WithPatchIndex
   -> UMask
   -> WithPrefsTemplates
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe [Char]
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
basicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> DiffAlgorithm
   -> WithPatchIndex
   -> UMask
   -> WithPrefsTemplates
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe [Char]
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Verbosity
   -> DiffAlgorithm
   -> WithPatchIndex
   -> UMask
   -> WithPrefsTemplates
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (DiffAlgorithm
      -> WithPatchIndex
      -> UMask
      -> WithPrefsTemplates
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (DiffAlgorithm
   -> WithPatchIndex
   -> UMask
   -> WithPrefsTemplates
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (DiffAlgorithm
   -> WithPatchIndex -> UMask -> WithPrefsTemplates -> a)
advancedOpts

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]
(Int -> RefId -> ShowS)
-> (RefId -> [Char]) -> ([RefId] -> ShowS) -> Show RefId
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RefId -> ShowS
showsPrec :: Int -> RefId -> ShowS
$cshow :: RefId -> [Char]
show :: RefId -> [Char]
$cshowList :: [RefId] -> ShowS
showList :: [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 -> [Char]
(Int -> CopyRenameNames -> ShowS)
-> (CopyRenameNames -> [Char])
-> ([CopyRenameNames] -> ShowS)
-> Show CopyRenameNames
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CopyRenameNames -> ShowS
showsPrec :: Int -> CopyRenameNames -> ShowS
$cshow :: CopyRenameNames -> [Char]
show :: CopyRenameNames -> [Char]
$cshowList :: [CopyRenameNames] -> ShowS
showList :: [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 -> [Char]
(Int -> Object -> ShowS)
-> (Object -> [Char]) -> ([Object] -> ShowS) -> Show Object
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Object -> ShowS
showsPrec :: Int -> Object -> ShowS
$cshow :: Object -> [Char]
show :: Object -> [Char]
$cshowList :: [Object] -> ShowS
showList :: [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] =
  UMask -> IO () -> IO ()
forall a. UMask -> IO a -> IO a
withUMaskFlag (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
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
$ [Char] -> IO () -> IO ()
withNewDirectory [Char]
outrepo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    EmptyRepository Repository 'RO p Origin Origin
_repo <- PatchFormat
-> WithWorkingDir
-> WithPatchIndex
-> UseCache
-> WithPrefsTemplates
-> IO EmptyRepository
createRepository
      (PrimOptSpec DarcsOptDescr DarcsFlag a PatchFormat
PrimDarcsOption PatchFormat
patchFormat PrimDarcsOption PatchFormat -> [DarcsFlag] -> PatchFormat
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimOptSpec DarcsOptDescr DarcsFlag a WithWorkingDir
PrimDarcsOption WithWorkingDir
withWorkingDir PrimDarcsOption WithWorkingDir -> [DarcsFlag] -> WithWorkingDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimOptSpec DarcsOptDescr DarcsFlag a WithPatchIndex
PrimDarcsOption WithPatchIndex
patchIndexNo PrimDarcsOption WithPatchIndex -> [DarcsFlag] -> WithPatchIndex
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimOptSpec DarcsOptDescr DarcsFlag a WithPrefsTemplates
PrimDarcsOption WithPrefsTemplates
O.withPrefsTemplates PrimDarcsOption WithPrefsTemplates
-> [DarcsFlag] -> WithPrefsTemplates
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 'RW p Origin Origin
_repo <- Repository 'RO p Origin Origin
-> IO (Repository 'RW p Origin Origin)
forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RO p wU wR -> IO (Repository 'RW p wU wR)
revertRepositoryChanges Repository 'RO p Origin Origin
_repo
    ()
marks <-
      Repository 'RW p Origin Origin -> DiffAlgorithm -> Marks -> IO ()
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DiffAlgorithm -> Marks -> IO ()
fastImport' Repository 'RW p Origin Origin
_repo (PrimOptSpec DarcsOptDescr DarcsFlag a DiffAlgorithm
PrimDarcsOption DiffAlgorithm
O.diffAlgorithm PrimDarcsOption DiffAlgorithm -> [DarcsFlag] -> DiffAlgorithm
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) Marks
emptyMarks
    Repository 'RW p Origin Origin -> IO ()
forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
cleanRepository Repository 'RW p Origin Origin
_repo
    Repository 'RO p Origin Origin
_repo <- Repository 'RW p Origin Origin
-> DryRun -> IO (Repository 'RO p Origin Origin)
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
finalizeRepositoryChanges Repository 'RW p Origin Origin
_repo (PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
PrimDarcsOption DryRun
O.dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
    Repository 'RO p Origin Origin -> [Char] -> WithWorkingDir -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> [Char] -> WithWorkingDir -> IO ()
createPristineDirectoryTree Repository 'RO p Origin Origin
_repo [Char]
"." (PrimOptSpec DarcsOptDescr DarcsFlag a WithWorkingDir
PrimDarcsOption WithWorkingDir
withWorkingDir PrimDarcsOption WithWorkingDir -> [DarcsFlag] -> WithWorkingDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
marks
fastImport (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [[Char]]
_ = [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"I need exactly one output repository."

fastImport' :: forall p wU wR . (RepoPatch p, ApplyState p ~ Tree)
            => Repository 'RW p wU wR
            -> O.DiffAlgorithm
            -> Marks
            -> IO ()
fastImport' :: forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DiffAlgorithm -> Marks -> IO ()
fastImport' Repository 'RW p wU wR
repo DiffAlgorithm
diffalg Marks
marks = do
    Tree IO
pristine <- Repository 'RW p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository 'RW p wU wR
repo
    IORef Marks
marksref <- Marks -> IO (IORef Marks)
forall a. a -> IO (IORef a)
newIORef Marks
marks
    let initial :: State p
initial = Maybe Int -> ByteString -> State p
forall (p :: * -> * -> *). Maybe Int -> ByteString -> State p
Toplevel Maybe Int
forall a. Maybe a
Nothing (ByteString -> State p) -> ByteString -> State p
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 -> () -> TreeIO ()
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                             State p
_ -> State p -> ByteString -> TreeIO ()
go State p
state' ByteString
rest'

        -- sort marks into buckets, since there can be a *lot* of them
        markpath :: Int -> AnchoredPath
        markpath :: Int -> AnchoredPath
markpath Int
n = HasCallStack => [Char] -> AnchoredPath
[Char] -> AnchoredPath
unsafeFloatPath ([Char]
darcsdir [Char] -> ShowS
</> [Char]
"marks")
                        AnchoredPath -> Name -> AnchoredPath
`appendPath` (([Char] -> Name) -> (Name -> Name) -> Either [Char] Name -> Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Name
forall a. HasCallStack => [Char] -> a
error Name -> Name
forall a. a -> a
id (Either [Char] Name -> Name) -> Either [Char] Name -> Name
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] Name
makeName ([Char] -> Either [Char] Name) -> [Char] -> Either [Char] Name
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
1000))
                        AnchoredPath -> Name -> AnchoredPath
`appendPath` (([Char] -> Name) -> (Name -> Name) -> Either [Char] Name -> Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Name
forall a. HasCallStack => [Char] -> a
error Name -> Name
forall a. a -> a
id (Either [Char] Name -> Name) -> Either [Char] Name -> Name
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] Name
makeName ([Char] -> Either [Char] Name) -> [Char] -> Either [Char] Name
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
n Int -> Int -> Int
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 -> ([[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head ([[Char]] -> [Char])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> ([Char], [[Char]])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [[Char]] -> [[Char]]
forall a. HasCallStack => [a] -> [a]
tail) ([[Char]] -> ([Char], [[Char]]))
-> ([Char] -> [[Char]]) -> [Char] -> ([Char], [[Char]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines ([Char] -> ([Char], [[Char]])) -> [Char] -> ([Char], [[Char]])
forall a b. (a -> b) -> a -> b
$ [Char]
msg
              ([Char]
author'', [Char]
date'') = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'>') ([Char] -> ([Char], [Char])) -> [Char] -> ([Char], [Char])
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpackPSFromUTF8 ByteString
author
              date' :: [Char]
date' = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Char]
"0123456789" :: String)) [Char]
date''
              author' :: [Char]
author' = [Char]
author'' [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
">"
              date :: [Char]
date = [Char] -> UTCTime -> [Char]
formatDateTime [Char]
"%Y%m%d%H%M%S" (UTCTime -> [Char]) -> UTCTime -> [Char]
forall a b. (a -> b) -> a -> b
$ UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe UTCTime
startOfTime ([Char] -> [Char] -> Maybe UTCTime
parseDateTime [Char]
"%s %z" [Char]
date')
          IO PatchInfo -> m PatchInfo
forall a. IO a -> m a
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
$ [Char] -> [Char] -> [Char] -> [[Char]] -> IO PatchInfo
patchinfo [Char]
date (if Bool
tag then [Char]
"TAG " [Char] -> ShowS
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_ <- ByteString -> ByteString -> Bool -> m PatchInfo
forall {m :: * -> *}.
MonadIO m =>
ByteString -> ByteString -> Bool -> m PatchInfo
makeinfo ByteString
author ByteString
msg Bool
True
             Bool
gotany <- IO Bool -> m Bool
forall a. IO a -> m a
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
$ [Char] -> IO Bool
doesFileExist [Char]
tentativePristinePath
             [PatchInfo]
deps <- if Bool
gotany then IO [PatchInfo] -> m [PatchInfo]
forall a. IO a -> m a
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 p Origin wR -> [PatchInfo]
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> [PatchInfo]
getUncovered (PatchSet p Origin wR -> [PatchInfo])
-> IO (PatchSet p Origin wR) -> IO [PatchInfo]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RW p wU wR
repo
                               else [PatchInfo] -> m [PatchInfo]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
             let patch :: Named p wA wA
                 patch :: forall wA. 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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
                 Cache -> PatchInfoAnd p Any Any -> IO ()
forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
Cache -> PatchInfoAnd p wX wY -> IO ()
addToTentativeInventory (Repository 'RW p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository 'RW p wU wR
repo) (Named p Any Any -> PatchInfoAnd p Any Any
forall (p :: * -> * -> *) wX wY.
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG p wX wY
n2pia Named p Any Any
forall wA. Named p wA wA
patch)

        -- processing items

        -- ugly procedure that does too many things at once:
        -- * it modifies the tree in the state by adding missing hashes
        --   but only for blobs and excluding anything under _darcs
        -- * it also returns the resulting tree with _darcs filtered out
        updateHashes :: RWST (DumpItem IO) () (TreeState IO) IO (Tree IO)
updateHashes = do
          let nodarcs :: AnchoredPath -> p -> Bool
nodarcs = \(AnchoredPath [Name]
xs) p
_ -> [Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
xs 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 Maybe Hash
Nothing)) =
                do Hash
hash <- ByteString -> Hash
sha256 (ByteString -> Hash) -> m ByteString -> m Hash
forall a b. (a -> b) -> m a -> m b
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 a. a -> m a
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 -> Maybe Hash -> Blob m
forall (m :: * -> *). m ByteString -> Maybe Hash -> Blob m
T.Blob m ByteString
con (Hash -> Maybe Hash
forall a. a -> Maybe a
Just Hash
hash))
              hashblobs TreeItem m
x = TreeItem m -> m (TreeItem m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem m
x
          Tree IO
tree' <- IO (Tree IO) -> RWST (DumpItem IO) () (TreeState IO) IO (Tree IO)
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree IO) -> RWST (DumpItem IO) () (TreeState IO) IO (Tree IO))
-> (Tree IO -> IO (Tree IO))
-> Tree IO
-> RWST (DumpItem 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 (DumpItem IO) () (TreeState IO) IO (Tree IO))
-> RWST (DumpItem IO) () (TreeState IO) IO (Tree IO)
-> RWST (DumpItem IO) () (TreeState IO) IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (TreeState IO -> Tree IO)
-> RWST (DumpItem 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' }
          Tree IO -> RWST (DumpItem IO) () (TreeState IO) IO (Tree IO)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO -> RWST (DumpItem IO) () (TreeState IO) IO (Tree IO))
-> Tree IO -> RWST (DumpItem 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 (DumpItem m) () (TreeState m) m ()
deleteEmptyParents AnchoredPath
fp =
          case AnchoredPath -> Maybe AnchoredPath
parent AnchoredPath
fp of
            Maybe AnchoredPath
Nothing -> () -> RWST (DumpItem m) () (TreeState m) m ()
forall a. a -> RWST (DumpItem m) () (TreeState m) m a
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 (DumpItem m) () (TreeState m) m (Tree m)
-> RWST (DumpItem m) () (TreeState m) m (Maybe (Tree m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Tree m)
-> RWST (DumpItem 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 a. [a] -> 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 (DumpItem m) () (TreeState m) m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
TM.unlink AnchoredPath
directParent
                                      AnchoredPath -> RWST (DumpItem m) () (TreeState m) m ()
deleteEmptyParents AnchoredPath
directParent
                      -- Either missing (not possible) or non-empty.
                      Maybe Bool
_ -> () -> RWST (DumpItem m) () (TreeState m) m ()
forall a. a -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        -- generate Hunk primitive patches from diffing
        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 (DumpItem 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
     (DumpItem IO) () (TreeState IO) IO (FreeLeft (FL (PrimOf p)))
-> RWST
     (DumpItem IO) () (TreeState IO) IO (Sealed (FL (PrimOf p) cY))
forall a b.
(a -> b)
-> RWST (DumpItem IO) () (TreeState IO) IO a
-> RWST (DumpItem IO) () (TreeState IO) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
             IO (FreeLeft (FL (PrimOf p)))
-> RWST
     (DumpItem IO) () (TreeState IO) IO (FreeLeft (FL (PrimOf p)))
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (DiffAlgorithm
-> ([Char] -> FileType)
-> Tree IO
-> Tree IO
-> IO (FreeLeft (FL (PrimOf p)))
forall (m :: * -> *) (w :: (* -> * -> *) -> *)
       (prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> ([Char] -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff DiffAlgorithm
diffalg (FileType -> [Char] -> 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 -> FL (PrimOf p) cY wX -> RL (PrimOf p) cX wX
forall (p :: * -> * -> *) wX wY wZ.
RL p wX wY -> FL p wY wZ -> RL p wX wZ
+<<+ FL (PrimOf p) cY wX
diff
          State p -> TreeIO (State p)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
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
$ Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX wX
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX 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
_ = [Char] -> TreeIO (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
          IO () -> TreeIO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char]
"progress " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
decodeLocale ByteString
p)
          State p -> TreeIO (State p)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return State p
s

        process (Toplevel Maybe Int
_ ByteString
_) Object
End = do
          Tree IO
tree' <- (IO (Tree IO) -> RWST (DumpItem IO) () (TreeState IO) IO (Tree IO)
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree IO) -> RWST (DumpItem IO) () (TreeState IO) IO (Tree IO))
-> (Tree IO -> IO (Tree IO))
-> Tree IO
-> RWST (DumpItem 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 (DumpItem IO) () (TreeState IO) IO (Tree IO))
-> RWST (DumpItem IO) () (TreeState IO) IO (Tree IO)
-> RWST (DumpItem IO) () (TreeState IO) IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RWST (DumpItem 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' } -- lets dump the right tree, without _darcs
          let root :: ByteString
root =
                case Tree IO -> Maybe Hash
forall (m :: * -> *). Tree m -> Maybe Hash
treeHash Tree IO
tree' of
                  Maybe Hash
Nothing -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"tree has no hash!"
                  Just Hash
hash -> Hash -> ByteString
encodeBase16 Hash
hash
          IO () -> TreeIO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
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 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BC.concat [[Char] -> ByteString
BC.pack [Char]
"pristine:", ByteString
root]
          State p -> TreeIO (State p)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return State p
forall (p :: * -> * -> *). State p
Done

        process (Toplevel Maybe Int
n ByteString
b) (Tag ByteString
tag Int
what ByteString
author ByteString
msg) = do
          if Int -> Maybe Int
forall a. a -> Maybe a
Just Int
what Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
n
             then ByteString -> ByteString -> TreeIO ()
forall {m :: * -> *}. MonadIO m => ByteString -> ByteString -> m ()
addtag ByteString
author ByteString
msg
             else IO () -> TreeIO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char]
"WARNING: Ignoring out-of-order tag " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
decodeLocale ByteString
tag
          State p -> TreeIO (State p)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> ByteString -> State p
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)) | Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
n ->
                 ByteString -> ByteString -> TreeIO ()
forall {m :: * -> *}. MonadIO m => ByteString -> ByteString -> m ()
addtag ([Char] -> ByteString
BC.pack [Char]
"Anonymous Tagger <> 0 +0000") ByteString
branch
               Maybe RefId
_ -> IO () -> TreeIO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"WARNING: Ignoring out-of-order tag " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                                        ByteString -> [Char]
decodeLocale ByteString
branch
             State p -> TreeIO (State p)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
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
$ Maybe Int -> ByteString -> State p
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
          AnchoredPath -> ByteString -> TreeIO ()
forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> ByteString -> TreeMonad m ()
TM.writeFile (Int -> AnchoredPath
markpath Int
m) ([ByteString] -> ByteString
BLC.fromChunks [ByteString
bits])
          State p -> TreeIO (State p)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
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
$ Maybe Int -> ByteString -> State p
forall (p :: * -> * -> *). Maybe Int -> ByteString -> State p
Toplevel Maybe Int
n ByteString
b

        process State p
x (Gitlink ByteString
link) = do
          IO () -> TreeIO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"WARNING: Ignoring gitlink " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
decodeLocale ByteString
link
          State p -> TreeIO (State p)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
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
          Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
pbranch ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
branch) (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ do
            IO () -> TreeIO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char]
"Tagging branch: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
decodeLocale ByteString
pbranch)
            ByteString -> ByteString -> TreeIO ()
forall {m :: * -> *}. MonadIO m => ByteString -> ByteString -> m ()
addtag ByteString
author ByteString
pbranch
          PatchInfo
info_ <- ByteString
-> ByteString
-> Bool
-> RWST (DumpItem IO) () (TreeState IO) IO PatchInfo
forall {m :: * -> *}.
MonadIO m =>
ByteString -> ByteString -> Bool -> m PatchInfo
makeinfo ByteString
author ByteString
message Bool
False
          Tree IO
startstate <- RWST (DumpItem IO) () (TreeState IO) IO (Tree IO)
updateHashes
          State p -> TreeIO (State p)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
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
$ Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) Any Any
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Maybe Int
mark (Maybe Int
previous, []) ByteString
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) ByteString
path) = do
          AnchoredPath -> AnchoredPath -> TreeIO ()
forall (m :: * -> *).
MonadThrow 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
          AnchoredPath -> ByteString -> TreeIO ()
forall (m :: * -> *).
MonadThrow 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
          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 Maybe Int
mark (Maybe Int
prev, [Int]
current) ByteString
branch Tree IO
start RL (PrimOf p) cX cY
ps PatchInfo
info_) (From Int
from) =
          State p -> TreeIO (State p)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
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
$ Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Maybe Int
mark (Maybe Int
prev, Int
fromInt -> [Int] -> [Int]
forall 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) =
          State p -> TreeIO (State p)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
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
$ Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Maybe Int
mark (Maybe Int
prev, Int
fromInt -> [Int] -> [Int]
forall 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
            AnchoredPath -> AnchoredPath -> TreeIO ()
forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> AnchoredPath -> TreeMonad m ()
TM.copy (ByteString -> AnchoredPath
decodePath ByteString
from) (ByteString -> AnchoredPath
decodePath ByteString
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 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 ->
              -- no parents i.e. target is root => nothing to do
              () -> TreeIO ()
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just AnchoredPath
parentDir -> do
              Bool
targetDirExists <- IO Bool -> RWST (DumpItem IO) () (TreeState IO) IO Bool
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RWST (DumpItem IO) () (TreeState IO) IO Bool)
-> IO Bool -> RWST (DumpItem 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 (DumpItem IO) () (TreeState IO) IO Bool
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RWST (DumpItem IO) () (TreeState IO) IO Bool)
-> IO Bool -> RWST (DumpItem 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 (DumpItem IO) () (TreeState IO) IO Bool
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RWST (DumpItem IO) () (TreeState IO) IO Bool)
-> IO Bool -> RWST (DumpItem 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 Maybe Int
_ Ancestors
_ ByteString
_ Tree IO
_ RL (PrimOf p) cX cY
newPs PatchInfo
_) <- State p -> TreeIO (State p)
diffCurrent State p
s
          AnchoredPath -> AnchoredPath -> TreeIO ()
forall (m :: * -> *).
MonadThrow 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 wX wY. AnchoredPath -> AnchoredPath -> PrimOf p wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> AnchoredPath -> prim wX wY
move AnchoredPath
uFrom AnchoredPath
uTo
          Tree IO
current <- RWST (DumpItem 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 (Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX Any
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Maybe Int
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Maybe Int
mark Ancestors
ancestors ByteString
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 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
_, []) -> () -> TreeIO ()
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
list -> () -> TreeIO ()
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- OK, we base off one of the ancestors
              | Bool
otherwise -> IO () -> TreeIO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                               [Char]
"WARNING: Linearising non-linear ancestry:" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                               [Char]
" currently at " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", ancestors " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show [Int]
list
            (Maybe Int
Nothing, [Int]
list) ->
              IO () -> TreeIO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"WARNING: Linearising non-linear ancestry " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show [Int]
list

          {- current <- updateHashes -} -- why not?
          (FL (PrimOf p) cX cY
prims :: FL (PrimOf p) cX cY) <-
            FL (PrimOf p) cX cY
-> RWST (DumpItem IO) () (TreeState IO) IO (FL (PrimOf p) cX cY)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (PrimOf p) cX cY
 -> RWST (DumpItem IO) () (TreeState IO) IO (FL (PrimOf p) cX cY))
-> FL (PrimOf p) cX cY
-> RWST (DumpItem IO) () (TreeState IO) IO (FL (PrimOf p) cX cY)
forall a b. (a -> b) -> a -> b
$ DiffAlgorithm -> FL (PrimOf p) cX cY -> FL (PrimOf p) cX cY
forall (prim :: * -> * -> *) wX wY.
(IsHunk prim, PrimCoalesce prim, PrimConstruct prim) =>
DiffAlgorithm -> FL prim wX wY -> FL prim wX wY
canonizeFL DiffAlgorithm
diffalg (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 a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$
              Cache -> PatchInfoAnd p cX cY -> IO ()
forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
Cache -> PatchInfoAnd p wX wY -> IO ()
addToTentativeInventory (Repository 'RW p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository 'RW p wU wR
repo) (Named p cX cY -> PatchInfoAnd p cX cY
forall (p :: * -> * -> *) wX wY.
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG p wX wY
n2pia Named p cX cY
patch)
          case Maybe Int
mark of
            Maybe Int
Nothing -> () -> TreeIO ()
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
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 -> IO () -> TreeIO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
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 -> ByteString -> Marks
addMark Marks
m Int
n (PatchInfoAnd p cX cY -> ByteString
forall (p :: * -> * -> *) cX cY. PatchInfoAnd p cX cY -> ByteString
patchHash (PatchInfoAnd p cX cY -> ByteString)
-> PatchInfoAnd p cX cY -> ByteString
forall a b. (a -> b) -> a -> b
$ Named p cX cY -> PatchInfoAnd p cX cY
forall (p :: * -> * -> *) wX wY.
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG p wX wY
n2pia Named p cX cY
patch)
              Just ByteString
n' -> [Char] -> TreeIO ()
forall a. [Char] -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> TreeIO ()) -> [Char] -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"FATAL: Mark already exists: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
decodeLocale ByteString
n'
          State p -> Object -> TreeIO (State p)
process (Maybe Int -> ByteString -> State p
forall (p :: * -> * -> *). Maybe Int -> ByteString -> State p
Toplevel Maybe Int
mark ByteString
branch) Object
x

        process State p
state Object
obj = do
          IO () -> TreeIO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
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
          [Char] -> TreeIO (State p)
forall a. [Char] -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> TreeIO (State p)) -> [Char] -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected object in state " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ State p -> [Char]
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 -> (ByteString, ByteString) -> TreeIO (ByteString, ByteString)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
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 = (ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> ByteString -> ByteString
BC.drop Int
1) ((ByteString, ByteString) -> (ByteString, ByteString))
-> (Int -> (ByteString, ByteString))
-> Int
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> ByteString -> (ByteString, ByteString))
-> ByteString -> Int -> (ByteString, ByteString)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> ByteString -> (ByteString, ByteString)
BC.splitAt ByteString
uqNames
                    -- Reverse the components, so we find the longest
                    -- prefix existing name.
                    spaceComponents :: [(ByteString, ByteString)]
spaceComponents = [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a]
reverse ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ (Int -> (ByteString, ByteString))
-> [Int] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (ByteString, ByteString)
splitStr [Int]
spaceIndices
                    componentCount :: Int
componentCount = [(ByteString, ByteString)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ByteString, ByteString)]
spaceComponents
                if Int
componentCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
                    then (ByteString, ByteString) -> TreeIO (ByteString, ByteString)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, ByteString) -> TreeIO (ByteString, ByteString))
-> (ByteString, ByteString) -> TreeIO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> (ByteString, ByteString)
forall a. HasCallStack => [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
_) =
                                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
$ ByteString -> AnchoredPath
decodePath ByteString
l
                            finder :: [(ByteString, b)]
-> RWST (DumpItem m) () (TreeState m) m (ByteString, b)
finder [] = [Char] -> RWST (DumpItem m) () (TreeState m) m (ByteString, b)
forall a. HasCallStack => [Char] -> a
error [Char]
dieMessage
                            finder ((ByteString, b)
x : [(ByteString, b)]
rest) = do
                                Bool
xExists <- (ByteString, b) -> TreeMonad m Bool
forall {m :: * -> *} {b}.
Monad m =>
(ByteString, b) -> TreeMonad m Bool
lPathExists (ByteString, b)
x
                                if Bool
xExists then (ByteString, b)
-> RWST (DumpItem m) () (TreeState m) m (ByteString, b)
forall a. a -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString, b)
x else [(ByteString, b)]
-> RWST (DumpItem m) () (TreeState m) m (ByteString, b)
finder [(ByteString, b)]
rest
                        [(ByteString, ByteString)] -> TreeIO (ByteString, ByteString)
forall {m :: * -> *} {b}.
Monad m =>
[(ByteString, b)]
-> RWST (DumpItem m) () (TreeState m) m (ByteString, b)
finder [(ByteString, ByteString)]
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 -> Cache -> IO ((), Tree IO)
forall a. TreeIO a -> Tree IO -> Cache -> IO (a, Tree IO)
hashedTreeIO (State p -> ByteString -> TreeIO ()
go State p
forall (p :: * -> * -> *). State p
initial ByteString
B.empty) Tree IO
pristine (Repository 'RW p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository 'RW p wU wR
repo)

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 = Parser (Maybe Object) -> ByteString -> Result (Maybe Object)
forall a. Parser a -> ByteString -> 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 ByteString Object -> Parser (Maybe Object)
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString Object
p_object
                        Parser (Maybe Object)
-> Parser (Maybe Object) -> Parser (Maybe Object)
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput Parser ByteString ()
-> Parser (Maybe Object) -> Parser (Maybe Object)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Object -> Parser (Maybe Object)
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Object
forall a. Maybe a
Nothing)

        lex :: Parser ByteString b -> Parser ByteString b
lex Parser ByteString b
p = Parser ByteString b
p Parser ByteString b
-> (b -> Parser ByteString b) -> Parser ByteString b
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
x -> Parser ByteString ()
A.skipSpace Parser ByteString () -> Parser ByteString b -> Parser ByteString b
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Parser ByteString b
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
        lexString :: [Char] -> Parser ByteString ()
lexString [Char]
s = ByteString -> Parser ByteString
A.string ([Char] -> ByteString
BC.pack [Char]
s) Parser ByteString -> Parser ByteString () -> Parser ByteString ()
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString ()
A.skipSpace
        line :: Parser ByteString
line = Parser ByteString -> Parser ByteString
forall {b}. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString -> Parser ByteString)
-> Parser ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString
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 a b. (a -> b) -> f a -> f b
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 a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a -> f (Maybe a)
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

        p_object :: Parser ByteString Object
p_object = Parser ByteString Object
p_blob
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_reset
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_commit
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_tag
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_modify
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_rename
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_copy
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_from
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_merge
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_delete
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([Char] -> Parser ByteString ()
lexString [Char]
"progress" Parser ByteString ()
-> Parser ByteString Object -> Parser ByteString Object
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Object
Progress (ByteString -> Object)
-> Parser ByteString -> Parser ByteString Object
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
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 ByteString ()
lexString [Char]
name Parser ByteString () -> Parser ByteString -> Parser ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
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 ByteString ()
lexString [Char]
"reset"
                     ByteString
branch <- Parser ByteString
line
                     Maybe RefId
refid <- Parser ByteString RefId -> Parser ByteString (Maybe RefId)
forall {f :: * -> *} {a}.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional (Parser ByteString RefId -> Parser ByteString (Maybe RefId))
-> Parser ByteString RefId -> Parser ByteString (Maybe RefId)
forall a b. (a -> b) -> a -> b
$ [Char] -> Parser ByteString ()
lexString [Char]
"from" Parser ByteString ()
-> Parser ByteString RefId -> Parser ByteString RefId
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString RefId
p_refid
                     Object -> Parser ByteString Object
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
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 ByteString ()
lexString [Char]
"commit"
                      ByteString
branch <- Parser ByteString
line
                      Maybe Int
mark <- Parser ByteString Int -> Parser ByteString (Maybe Int)
forall {f :: * -> *} {a}.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional Parser ByteString Int
p_mark
                      Maybe ByteString
_ <- Parser ByteString -> Parser ByteString (Maybe ByteString)
forall {f :: * -> *} {a}.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional (Parser ByteString -> Parser ByteString (Maybe ByteString))
-> Parser ByteString -> Parser ByteString (Maybe ByteString)
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
                      Object -> Parser ByteString Object
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
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 ByteString ()
lexString [Char]
"tag"
                   ByteString
tag <- Parser ByteString
line
                   [Char] -> Parser ByteString ()
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
                   Object -> Parser ByteString Object
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
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 ByteString ()
lexString [Char]
"blob"
                    Maybe Int
mark <- Parser ByteString Int -> Parser ByteString (Maybe Int)
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 (ByteString -> Object)
-> Parser ByteString -> Parser ByteString Object
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString
p_data
                  Parser ByteString Object -> [Char] -> Parser ByteString Object
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"p_blob"

        p_mark :: Parser ByteString Int
p_mark = do [Char] -> Parser ByteString ()
lexString [Char]
"mark"
                    Parser ByteString Int
p_marked
                  Parser ByteString Int -> [Char] -> Parser ByteString Int
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"p_mark"

        p_refid :: Parser ByteString RefId
p_refid = Int -> RefId
MarkId (Int -> RefId) -> Parser ByteString Int -> Parser ByteString RefId
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString Int
p_marked
                  Parser ByteString RefId
-> Parser ByteString RefId -> Parser ByteString RefId
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([Char] -> Parser ByteString ()
lexString [Char]
"inline" Parser ByteString ()
-> Parser ByteString RefId -> Parser ByteString RefId
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RefId -> Parser ByteString RefId
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return RefId
Inline)
                  Parser ByteString RefId
-> Parser ByteString RefId -> Parser ByteString RefId
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> RefId
HashId (ByteString -> RefId)
-> Parser ByteString -> Parser ByteString RefId
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
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 ByteString ()
lexString [Char]
"data"
                    Int
len <- Parser ByteString Int
forall a. Integral a => Parser a
A.decimal
                    Char
_ <- Char -> Parser Char
A.char Char
'\n'
                    Parser ByteString -> Parser ByteString
forall {b}. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString -> Parser ByteString)
-> Parser ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Parser ByteString
A.take Int
len
                  Parser ByteString -> [Char] -> Parser ByteString
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"p_data"

        p_marked :: Parser ByteString Int
p_marked = Parser ByteString Int -> Parser ByteString Int
forall {b}. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString Int -> Parser ByteString Int)
-> Parser ByteString Int -> Parser ByteString Int
forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
A.char Char
':' Parser Char -> Parser ByteString Int -> Parser ByteString Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString Int
forall a. Integral a => Parser a
A.decimal
        p_hash :: Parser ByteString
p_hash = Parser ByteString -> Parser ByteString
forall {b}. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString -> Parser ByteString)
-> Parser ByteString -> Parser ByteString
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 ByteString ()
lexString [Char]
"from" Parser ByteString ()
-> Parser ByteString Object -> Parser ByteString Object
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Object
From (Int -> Object)
-> Parser ByteString Int -> Parser ByteString Object
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
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 ByteString ()
lexString [Char]
"merge" Parser ByteString ()
-> Parser ByteString Object -> Parser ByteString Object
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Object
Merge (Int -> Object)
-> Parser ByteString Int -> Parser ByteString Object
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
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 ByteString ()
lexString [Char]
"D" Parser ByteString ()
-> Parser ByteString Object -> Parser ByteString Object
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Object
Delete (ByteString -> Object)
-> Parser ByteString -> Parser ByteString Object
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
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 ByteString ()
lexString [Char]
"R"
                      CopyRenameNames
names <- Parser ByteString CopyRenameNames
p_maybeQuotedCopyRenameNames
                      Object -> Parser ByteString Object
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ CopyRenameNames -> Object
Rename CopyRenameNames
names
        p_copy :: Parser ByteString Object
p_copy = do [Char] -> Parser ByteString ()
lexString [Char]
"C"
                    CopyRenameNames
names <- Parser ByteString CopyRenameNames
p_maybeQuotedCopyRenameNames
                    Object -> Parser ByteString Object
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ CopyRenameNames -> Object
Copy CopyRenameNames
names
        p_modify :: Parser ByteString Object
p_modify = do [Char] -> Parser ByteString ()
lexString [Char]
"M"
                      ByteString
mode <- Parser ByteString -> Parser ByteString
forall {b}. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString -> Parser ByteString)
-> Parser ByteString -> Parser ByteString
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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> ByteString
BC.pack [Char]
"160000" -> Object -> Parser ByteString Object
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ ByteString -> Object
Gitlink ByteString
hash
                                    | Bool
otherwise -> [Char] -> Parser ByteString Object
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
":(("
                        MarkId Int
n -> Object -> Parser ByteString Object
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ Either Int ByteString -> ByteString -> Object
Modify (Int -> Either Int ByteString
forall a b. a -> Either a b
Left Int
n) ByteString
path
                        RefId
Inline -> do ByteString
bits <- Parser ByteString
p_data
                                     Object -> Parser ByteString Object
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ Either Int ByteString -> ByteString -> Object
Modify (ByteString -> Either Int ByteString
forall a b. b -> Either a b
Right ByteString
bits) ByteString
path
        p_maybeQuotedCopyRenameNames :: Parser ByteString CopyRenameNames
p_maybeQuotedCopyRenameNames =
            Parser ByteString CopyRenameNames
p_lexTwoQuotedNames Parser ByteString CopyRenameNames
-> Parser ByteString CopyRenameNames
-> Parser ByteString CopyRenameNames
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> CopyRenameNames
Unquoted (ByteString -> CopyRenameNames)
-> Parser ByteString -> Parser ByteString CopyRenameNames
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
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 <- Parser ByteString -> Parser ByteString
forall {b}. Parser ByteString b -> Parser ByteString b
lex Parser ByteString
p_quotedName
            ByteString
n2 <- Parser ByteString -> Parser ByteString
forall {b}. Parser ByteString b -> Parser ByteString b
lex Parser ByteString
p_quotedName
            CopyRenameNames -> Parser ByteString CopyRenameNames
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (CopyRenameNames -> Parser ByteString CopyRenameNames)
-> CopyRenameNames -> Parser ByteString CopyRenameNames
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> CopyRenameNames
Quoted ByteString
n1 ByteString
n2
        p_maybeQuotedName :: Parser ByteString
p_maybeQuotedName = Parser ByteString -> Parser ByteString
forall {b}. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString
p_quotedName Parser ByteString -> Parser ByteString -> Parser ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
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 <- Parser ByteString -> Parser ByteString [ByteString]
forall a. Parser ByteString a -> Parser ByteString [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser ByteString
p_escaped Parser ByteString -> Parser ByteString -> Parser ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString
p_unescaped)
          Char
_ <- Char -> Parser Char
A.char Char
'"'
          ByteString -> Parser ByteString
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Parser ByteString)
-> ByteString -> Parser ByteString
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
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 ByteString
p_escaped = do
          Char
_ <- Char -> Parser Char
A.char Char
'\\'
          Parser ByteString
p_escaped_octal Parser ByteString -> Parser ByteString -> Parser ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
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 (Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
octals)
          let x :: Word8
              x :: Word8
x = [Char] -> Word8
forall a. Read a => [Char] -> a
read ([Char]
"0o" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BC.unpack ByteString
s)
          ByteString -> Parser ByteString
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Parser ByteString)
-> ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString
B.singleton (Word8 -> ByteString) -> Word8 -> ByteString
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 ByteString
p_escaped_char =
          (Char -> ByteString) -> Parser Char -> Parser ByteString
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> ByteString
BC.singleton (Parser Char -> Parser ByteString)
-> Parser Char -> Parser ByteString
forall a b. (a -> b) -> a -> b
$
          Char
'\r' Char -> Parser Char -> Parser Char
forall a b. a -> Parser ByteString b -> Parser ByteString a
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 a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char
'\n' Char -> Parser Char -> Parser Char
forall a b. a -> Parser ByteString b -> Parser ByteString a
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 a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
A.char Char
'"' Parser Char -> Parser Char -> Parser Char
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
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 IO ByteString -> RWST (DumpItem IO) () (TreeState IO) IO ByteString
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString
 -> RWST (DumpItem IO) () (TreeState IO) IO ByteString)
-> IO ByteString
-> RWST (DumpItem IO) () (TreeState IO) IO ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
B.hGet Handle
stdin (Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024)
                                     else ByteString -> RWST (DumpItem IO) () (TreeState IO) IO ByteString
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
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 -> (ByteString, Object) -> TreeIO (ByteString, Object)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
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 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
               IO () -> TreeIO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"=== chunk ===\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
decodeLocale ByteString
chunk [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n=== end chunk ===="
               [Char] -> TreeIO (ByteString, Object)
forall a. [Char] -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> TreeIO (ByteString, Object))
-> [Char] -> TreeIO (ByteString, Object)
forall a b. (a -> b) -> a -> b
$ [Char]
"Error parsing stream. " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
err [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\nContext: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
ctx

decodePath :: BC.ByteString -> AnchoredPath
decodePath :: ByteString -> AnchoredPath
decodePath = HasCallStack => [Char] -> AnchoredPath
[Char] -> AnchoredPath
unsafeFloatPath ([Char] -> AnchoredPath)
-> (ByteString -> [Char]) -> ByteString -> AnchoredPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
decodeLocale