--  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.Export ( convertExport ) where

import Darcs.Prelude hiding ( readFile, lex )

import Control.Exception (finally)
import Control.Monad (forM_, unless, void, when)
import Control.Monad.State.Strict (gets)
import Control.Monad.Trans (liftIO)

import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.ByteString.Lazy.UTF8 as BLU
import Data.Char (isSpace)
import Data.IORef (modifyIORef, newIORef, readIORef)
import Data.Maybe (catMaybes, fromJust)
import System.Time (toClockTime)

import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )
import Darcs.Patch ( RepoPatch, apply, effect, listTouchedFiles )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Effect ( Effect )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..)
    , nullFL
    )
import Darcs.Patch.Witnesses.Sealed
    ( FlippedSeal(..)
    , flipSeal
    , unsealFlipped
    )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )

import Darcs.Patch.Info
    ( PatchInfo
    , isTag
    , piAuthor
    , piDate
    , piLog
    , piName
    )
import Darcs.Patch.RepoType ( IsRepoType(..) )
import Darcs.Patch.Set ( patchSet2FL, inOrderTags )

import Darcs.Repository
    ( RepoJob(..)
    , Repository
    , readRepo
    , repoCache
    , withRepository
    )
import Darcs.Repository.Cache (HashedDir(HashedPristineDir))
import Darcs.Repository.Pristine (readHashedPristineRoot)
import Darcs.Repository.HashedIO (cleanHashdir)
import Darcs.Repository.Paths (pristineDirPath)

import Darcs.UI.Commands
    ( DarcsCommand(..)
    , amInRepository
    , nodefaults
    , withStdOpts
    )
import Darcs.UI.Commands.Convert.Util
    ( Marks
    , addMark
    , emptyMarks
    , getMark
    , lastMark
    , readMarks
    , writeMarks
    , patchHash
    )
import Darcs.UI.Completion (noArgs)
import Darcs.UI.Flags ( DarcsFlag , useCache )
import Darcs.UI.Options
    ( (?)
    , (^)
    , defaultFlags
    , ocheck
    , odesc
    , parseFlags
    )
import qualified Darcs.UI.Options.All as O

import Darcs.Util.DateTime ( formatDateTime, fromClockTime )
import Darcs.Util.Path
    ( AbsolutePath
    , AnchoredPath(..)
    , anchorPath
    , appendPath
    )
import Darcs.Util.Printer ( Doc, text )
import Darcs.Util.Tree
    ( Tree
    , emptyTree
    , findTree
    , listImmediate
    )
import Darcs.Util.Tree.Hashed ( hashedTreeIO )

import Darcs.Util.Tree.Monad ( TreeIO )
import qualified Darcs.Util.Tree.Monad as T
    ( directoryExists
    , fileExists
    , readFile
    , tree
    )


convertExportHelp :: Doc
convertExportHelp :: Doc
convertExportHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
 [ String
"This command enables you to export darcs repositories into git."
 , String
""
 , String
"For a one-time export you can use the recipe:"
 , String
""
 , String
"    $ cd repo"
 , String
"    $ git init ../mirror"
 , String
"    $ darcs convert export | (cd ../mirror && git fast-import)"
 , String
""
 , String
"For incremental export using marksfiles:"
 , String
""
 , String
"    $ cd repo"
 , String
"    $ git init ../mirror"
 , String
"    $ touch ../mirror/git.marks"
 , String
"    $ darcs convert export --read-marks darcs.marks --write-marks darcs.marks"
 , String
"       | (cd ../mirror && git fast-import --import-marks=git.marks --export-marks=git.marks)"
 , String
""
 , String
"In the case of incremental export, be careful to never amend, delete or"
 , String
"reorder patches in the source darcs repository."
 , String
""
 , String
"Also, be aware that exporting a darcs repo to git will not be exactly"
 , String
"faithful in terms of history if the darcs repository contains conflicts."
 , String
""
 , String
"Limitations:"
 , String
""
 , String
"  * Empty directories are not supported by the fast-export protocol."
 , String
"  * Unicode filenames are currently not correctly handled."
 , String
"    See http://bugs.darcs.net/issue2359 ."
 ]

convertExport :: DarcsCommand
convertExport :: DarcsCommand
convertExport = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"export"
    , commandHelp :: Doc
commandHelp = Doc
convertExportHelp
    , commandDescription :: String
commandDescription = String
"Export a darcs repository to a git-fast-import stream"
    , commandExtraArgs :: Int
commandExtraArgs = Int
0
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastExport
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any (NetworkOptions -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (NetworkOptions -> Any)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
convertExportAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String -> Maybe String -> Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String -> Maybe String -> Maybe String -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> Maybe String -> Maybe String -> a)
convertExportBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
convertExportOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
convertExportOpts
    }
  where
    convertExportBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> Maybe String -> Maybe String -> a)
convertExportBasicOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> Maybe String -> a)
  (Maybe String)
PrimDarcsOption (Maybe String)
O.repoDir PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> Maybe String -> a)
  (Maybe String)
-> OptSpec
     DarcsOptDescr DarcsFlag a (Maybe String -> Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe String -> Maybe String -> Maybe String -> 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 (Maybe String -> Maybe String -> a)
forall a. DarcsOption a (Maybe String -> Maybe String -> a)
O.marks
    convertExportAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
convertExportAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
O.network
    convertExportOpts :: DarcsOption
  a
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
convertExportOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> Maybe String -> Maybe String -> a)
convertExportBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (NetworkOptions
      -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Maybe String
      -> Maybe String
      -> Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> NetworkOptions
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (NetworkOptions
   -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
convertExportAdvancedOpts

fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastExport (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ = do
  Marks
marks <- case PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption (Maybe String)
O.readMarks [DarcsFlag]
opts of
    Maybe String
Nothing -> Marks -> IO Marks
forall (m :: * -> *) a. Monad m => a -> m a
return Marks
emptyMarks
    Just String
f  -> String -> IO Marks
readMarks String
f
  Marks
newMarks <-
    UseCache -> RepoJob Marks -> IO Marks
forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob Marks -> IO Marks) -> RepoJob Marks -> IO Marks
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO Marks)
-> RepoJob Marks
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
  Repository rt p wR wU wR -> IO Marks)
 -> RepoJob Marks)
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO Marks)
-> RepoJob Marks
forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repo -> Repository rt p wR wU wR -> Marks -> IO Marks
forall (rt :: RepoType) (p :: * -> * -> *) r u.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p r u r -> Marks -> IO Marks
fastExport' Repository rt p wR wU wR
repo Marks
marks
  case PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption (Maybe String)
O.writeMarks [DarcsFlag]
opts of
    Maybe String
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just String
f  -> String -> Marks -> IO ()
writeMarks String
f Marks
newMarks

fastExport' :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
            => Repository rt p r u r -> Marks -> IO Marks
fastExport' :: Repository rt p r u r -> Marks -> IO Marks
fastExport' Repository rt p r u r
repo Marks
marks = do
  String -> IO ()
putStrLn String
"progress (reading repository)"
  PatchSet rt p Origin r
patchset <- Repository rt p r u r -> IO (PatchSet rt p Origin r)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p r u r
repo
  IORef Marks
marksref <- Marks -> IO (IORef Marks)
forall a. a -> IO (IORef a)
newIORef Marks
marks
  let patches :: FL (PatchInfoAnd rt p) Origin r
patches = PatchSet rt p Origin r -> FL (PatchInfoAnd rt p) Origin r
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet rt p Origin r
patchset
      tags :: [PatchInfo]
tags = PatchSet rt p Origin r -> [PatchInfo]
forall (rt :: RepoType) (p :: * -> * -> *) wS wX.
PatchSet rt p wS wX -> [PatchInfo]
inOrderTags PatchSet rt p Origin r
patchset
      mark :: (PatchInfoAnd rt p) x y -> Int -> TreeIO ()
      mark :: PatchInfoAnd rt p x y -> Int -> TreeIO ()
mark PatchInfoAnd rt p x y
p Int
n = IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"mark :" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
                             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 rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash PatchInfoAnd rt p x y
p)
      -- apply a single patch to build the working tree of the last exported version
      checkOne :: (RepoPatch p, ApplyState p ~ Tree)
               => Int -> (PatchInfoAnd rt p) x y -> TreeIO ()
      checkOne :: Int -> PatchInfoAnd rt p x y -> TreeIO ()
checkOne Int
n PatchInfoAnd rt p x y
p = do PatchInfoAnd rt p x y -> TreeIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply PatchInfoAnd rt p x y
p
                        Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PatchInfo] -> PatchInfoAnd rt p x y -> Bool
forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p x y
p Bool -> Bool -> Bool
||
                                (Marks -> Int -> Maybe ByteString
getMark Marks
marks Int
n Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash PatchInfoAnd rt p x y
p))) (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$
                          String -> TreeIO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TreeIO ()) -> String -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String
"FATAL: Marks do not correspond: expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                 Maybe ByteString -> String
forall a. Show a => a -> String
show (Marks -> Int -> Maybe ByteString
getMark Marks
marks Int
n) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BC.unpack (PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash PatchInfoAnd rt p x y
p)
      -- build the working tree of the last version exported by convert --export
      check :: (RepoPatch p, ApplyState p ~ Tree)
            => Int -> FL (PatchInfoAnd rt p) x y -> TreeIO (Int,  FlippedSeal( FL (PatchInfoAnd rt p)) y) 
      check :: Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
check Int
_ FL (PatchInfoAnd rt p) x y
NilFL = (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1, FL (PatchInfoAnd rt p) y y
-> FlippedSeal (FL (PatchInfoAnd rt p)) y
forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd rt p) y y
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
      check Int
n allps :: FL (PatchInfoAnd rt p) x y
allps@(PatchInfoAnd rt p x wY
p:>:FL (PatchInfoAnd rt p) wY y
ps)
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Marks -> Int
lastMark Marks
marks = Int -> PatchInfoAnd rt p x wY -> TreeIO ()
forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int -> PatchInfoAnd rt p x y -> TreeIO ()
checkOne Int
n PatchInfoAnd rt p x wY
p TreeIO ()
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int
-> FL (PatchInfoAnd rt p) wY y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
check ([PatchInfo] -> Int -> PatchInfoAnd rt p x wY -> Int
forall (p :: * -> * -> *) (rt :: RepoType) x y.
Effect p =>
[PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next [PatchInfo]
tags Int
n PatchInfoAnd rt p x wY
p) FL (PatchInfoAnd rt p) wY y
ps
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Marks -> Int
lastMark Marks
marks = (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n, FL (PatchInfoAnd rt p) x y
-> FlippedSeal (FL (PatchInfoAnd rt p)) y
forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd rt p) x y
allps)
        | Marks -> Int
lastMark Marks
marks Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1, FL (PatchInfoAnd rt p) x y
-> FlippedSeal (FL (PatchInfoAnd rt p)) y
forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd rt p) x y
allps)
        | Bool
otherwise = TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
forall a. HasCallStack => a
undefined
  ((Int
n, FlippedSeal (FL (PatchInfoAnd rt p)) r
patches'), Tree IO
tree') <- TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) r)
-> Tree IO
-> String
-> IO ((Int, FlippedSeal (FL (PatchInfoAnd rt p)) r), Tree IO)
forall a. TreeIO a -> Tree IO -> String -> IO (a, Tree IO)
hashedTreeIO (Int
-> FL (PatchInfoAnd rt p) Origin r
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) r)
forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
check Int
1 FL (PatchInfoAnd rt p) Origin r
patches) Tree IO
forall (m :: * -> *). Tree m
emptyTree String
pristineDirPath
  let patches'' :: FL (PatchInfoAnd rt p) wB wC
patches'' = (forall wX wY.
 FL (PatchInfoAnd rt p) wX wY -> FL (PatchInfoAnd rt p) wB wC)
-> FlippedSeal (FL (PatchInfoAnd rt p)) r
-> FL (PatchInfoAnd rt p) wB wC
forall (a :: * -> * -> *) b wZ.
(forall wX wY. a wX wY -> b) -> FlippedSeal a wZ -> b
unsealFlipped forall wX wY.
FL (PatchInfoAnd rt p) wX wY -> FL (PatchInfoAnd rt p) wB wC
forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP FlippedSeal (FL (PatchInfoAnd rt p)) r
patches'
  IO ((), Tree IO) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ((), Tree IO) -> IO ()) -> IO ((), Tree IO) -> IO ()
forall a b. (a -> b) -> a -> b
$ TreeIO () -> Tree IO -> String -> IO ((), Tree IO)
forall a. TreeIO a -> Tree IO -> String -> IO (a, Tree IO)
hashedTreeIO ([PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) Any Any
-> TreeIO ()
forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
[PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO ()
dumpPatches [PatchInfo]
tags forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> Int -> TreeIO ()
forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark Int
n FL (PatchInfoAnd rt p) Any Any
forall wB wC. FL (PatchInfoAnd rt p) wB wC
patches'') Tree IO
tree' String
pristineDirPath
  IORef Marks -> IO Marks
forall a. IORef a -> IO a
readIORef IORef Marks
marksref
 IO Marks -> IO () -> IO Marks
forall a b. IO a -> IO b -> IO a
`finally` do
  String -> IO ()
putStrLn String
"progress (cleaning up)"
  Maybe PristineHash
current <- Repository rt p r u r -> IO (Maybe PristineHash)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Maybe PristineHash)
readHashedPristineRoot Repository rt p r u r
repo
  Cache -> HashedDir -> [PristineHash] -> IO ()
cleanHashdir (Repository rt p r u r -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p r u r
repo) HashedDir
HashedPristineDir ([PristineHash] -> IO ()) -> [PristineHash] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Maybe PristineHash] -> [PristineHash]
forall a. [Maybe a] -> [a]
catMaybes [Maybe PristineHash
current]
  String -> IO ()
putStrLn String
"progress done"

dumpPatches ::  (RepoPatch p, ApplyState p ~ Tree)
            =>  [PatchInfo]
            -> (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ())
            -> Int -> FL (PatchInfoAnd rt p) x y -> TreeIO ()
dumpPatches :: [PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO ()
dumpPatches [PatchInfo]
_ forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
_ Int
_ FL (PatchInfoAnd rt p) x y
NilFL = IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"progress (patches converted)"
dumpPatches [PatchInfo]
tags forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark Int
n (PatchInfoAnd rt p x wY
p:>:FL (PatchInfoAnd rt p) wY y
ps) = do
  PatchInfoAnd rt p x wY -> TreeIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply PatchInfoAnd rt p x wY
p
  if [PatchInfo] -> PatchInfoAnd rt p x wY -> Bool
forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p x wY
p Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
     then PatchInfoAnd rt p x wY -> Int -> TreeIO ()
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpTag PatchInfoAnd rt p x wY
p Int
n
     else do (forall (p0 :: * -> * -> *) x0 y0.
 PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> PatchInfoAnd rt p x wY -> Int -> TreeIO ()
forall (rt :: RepoType) (p :: * -> * -> *) x y.
(forall (p0 :: * -> * -> *) x0 y0.
 PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpPatch forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark PatchInfoAnd rt p x wY
p Int
n
             [AnchoredPath] -> TreeIO ()
dumpFiles ([AnchoredPath] -> TreeIO ()) -> [AnchoredPath] -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p x wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles PatchInfoAnd rt p x wY
p
  [PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) wY y
-> TreeIO ()
forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
[PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO ()
dumpPatches [PatchInfo]
tags forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark ([PatchInfo] -> Int -> PatchInfoAnd rt p x wY -> Int
forall (p :: * -> * -> *) (rt :: RepoType) x y.
Effect p =>
[PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next [PatchInfo]
tags Int
n PatchInfoAnd rt p x wY
p) FL (PatchInfoAnd rt p) wY y
ps

dumpTag :: (PatchInfoAnd rt p) x y  -> Int -> TreeIO () 
dumpTag :: PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpTag PatchInfoAnd rt p x y
p Int
n =
  [ByteString] -> TreeIO ()
dumpBits [ String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"progress TAG " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInfoAnd rt p x y -> String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> String
cleanTagName PatchInfoAnd rt p x y
p
           , String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInfoAnd rt p x y -> String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> String
cleanTagName PatchInfoAnd rt p x y
p -- FIXME is this valid?
           , String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"from :" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
           , String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"tagger", PatchInfoAnd rt p x y -> String
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> String
patchAuthor PatchInfoAnd rt p x y
p, PatchInfoAnd rt p x y -> String
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> String
patchDate PatchInfoAnd rt p x y
p]
           -- -3 == (-4 for "TAG " and +1 for newline)
           , String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"data "
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length (PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
3)
           , Int64 -> ByteString -> ByteString
BL.drop Int64
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p ]
   where
     -- FIXME forbidden characters and subsequences in tags:
     -- https://www.kernel.org/pub/software/scm/git/docs/git-check-ref-format.html
     cleanTagName :: PatchInfoAndG rt p wA wB -> String
cleanTagName = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
cleanup (String -> String)
-> (PatchInfoAndG rt p wA wB -> String)
-> PatchInfoAndG rt p wA wB
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
4 (String -> String)
-> (PatchInfoAndG rt p wA wB -> String)
-> PatchInfoAndG rt p wA wB
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> String
piName (PatchInfo -> String)
-> (PatchInfoAndG rt p wA wB -> PatchInfo)
-> PatchInfoAndG rt p wA wB
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAndG rt p wA wB -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info
         where cleanup :: Char -> Char
cleanup Char
x | Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
bad = Char
'_'
                         | Bool
otherwise = Char
x
               bad :: String
               bad :: String
bad = String
" ~^:"

dumpFiles :: [AnchoredPath] -> TreeIO ()
dumpFiles :: [AnchoredPath] -> TreeIO ()
dumpFiles [AnchoredPath]
files = [AnchoredPath] -> (AnchoredPath -> TreeIO ()) -> TreeIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [AnchoredPath]
files ((AnchoredPath -> TreeIO ()) -> TreeIO ())
-> (AnchoredPath -> TreeIO ()) -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ \AnchoredPath
file -> do
  let quotedPath :: String
quotedPath = String -> String
quotePath (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> AnchoredPath -> String
anchorPath String
"" AnchoredPath
file
  Bool
isfile <- AnchoredPath -> TreeMonad IO Bool
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
T.fileExists AnchoredPath
file
  Bool
isdir <- AnchoredPath -> TreeMonad IO Bool
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
T.directoryExists AnchoredPath
file
  Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isfile (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ do ByteString
bits <- AnchoredPath -> TreeMonad IO ByteString
forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m ByteString
T.readFile AnchoredPath
file
                   [ByteString] -> TreeIO ()
dumpBits [ String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"M 100644 inline " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
quotedPath
                            , String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length ByteString
bits)
                            , ByteString
bits ]
  Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isdir (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ do -- Always delete directory before dumping its contents. This fixes
                  -- a corner case when a same patch moves dir1 to dir2, and creates
                  -- another directory dir1.
                  -- As we always dump its contents anyway this is not more costly.
                  IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"D " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
quotedPath
                  Tree IO
tt <- (TreeState IO -> Tree IO)
-> RWST (TreeEnv IO) () (TreeState IO) IO (Tree IO)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState IO -> Tree IO
forall (m :: * -> *). TreeState m -> Tree m
T.tree -- ick
                  let subs :: [AnchoredPath]
subs = [ AnchoredPath
file AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
n | (Name
n, TreeItem IO
_) <-
                                  Tree IO -> [(Name, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate (Tree IO -> [(Name, TreeItem IO)])
-> Tree IO -> [(Name, TreeItem IO)]
forall a b. (a -> b) -> a -> b
$ Maybe (Tree IO) -> Tree IO
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Tree IO) -> Tree IO) -> Maybe (Tree IO) -> Tree IO
forall a b. (a -> b) -> a -> b
$ Tree IO -> AnchoredPath -> Maybe (Tree IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree Tree IO
tt AnchoredPath
file ]
                  [AnchoredPath] -> TreeIO ()
dumpFiles [AnchoredPath]
subs
  Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isfile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isdir) (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"D " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
quotedPath
  where
    -- |quotePath escapes and quotes paths containing newlines, double-quotes
    -- or backslashes.
    quotePath :: FilePath -> String
    quotePath :: String -> String
quotePath String
path = case (Char -> (String, Bool) -> (String, Bool))
-> (String, Bool) -> String -> (String, Bool)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> (String, Bool) -> (String, Bool)
escapeChars (String
"", Bool
False) String
path of
        (String
_, Bool
False) -> String
path
        (String
path', Bool
True) -> String -> String
quote String
path'

    quote :: String -> String
quote String
str = String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

    escapeChars :: Char -> (String, Bool) -> (String, Bool)
escapeChars Char
c (String
processed, Bool
haveEscaped) = case Char -> (String, Bool)
escapeChar Char
c of
        (String
escaped, Bool
didEscape) ->
            (String
escaped String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
processed, Bool
didEscape Bool -> Bool -> Bool
|| Bool
haveEscaped)

    escapeChar :: Char -> (String, Bool)
escapeChar Char
c = case Char
c of
        Char
'\n' -> (String
"\\n", Bool
True)
        Char
'\r' -> (String
"\\r", Bool
True)
        Char
'"'  -> (String
"\\\"", Bool
True)
        Char
'\\' -> (String
"\\\\", Bool
True)
        Char
_    -> ([Char
c], Bool
False)


dumpPatch ::  (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ())
          -> (PatchInfoAnd rt p) x y -> Int
          -> TreeIO ()
dumpPatch :: (forall (p0 :: * -> * -> *) x0 y0.
 PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpPatch forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark PatchInfoAnd rt p x y
p Int
n =
  do [ByteString] -> TreeIO ()
dumpBits [ String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"progress " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInfo -> String
piName (PatchInfoAnd rt p x y -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p)
              , ByteString
"commit refs/heads/master" ]
     PatchInfoAnd rt p x y -> Int -> TreeIO ()
forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark PatchInfoAnd rt p x y
p Int
n
     [ByteString] -> TreeIO ()
dumpBits [ String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"committer " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInfoAnd rt p x y -> String
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> String
patchAuthor PatchInfoAnd rt p x y
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInfoAnd rt p x y -> String
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> String
patchDate PatchInfoAnd rt p x y
p
              , String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p)
              , PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p ]
     Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> TreeIO ()
dumpBits [ String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"from :" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ]

dumpBits :: [BL.ByteString] -> TreeIO ()
dumpBits :: [ByteString] -> TreeIO ()
dumpBits = IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ())
-> ([ByteString] -> IO ()) -> [ByteString] -> TreeIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
BLC.putStrLn (ByteString -> IO ())
-> ([ByteString] -> ByteString) -> [ByteString] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> ByteString
BL.intercalate ByteString
"\n"

-- patchAuthor attempts to fixup malformed author strings
-- into format: "Name <Email>"
-- e.g.
-- <john@home>      -> john <john@home>
-- john@home        -> john <john@home>
-- john <john@home> -> john <john@home>
-- john <john@home  -> john <john@home>
-- <john>           -> john <unknown>
patchAuthor :: (PatchInfoAnd rt p) x y -> String
patchAuthor :: PatchInfoAnd rt p x y -> String
patchAuthor PatchInfoAnd rt p x y
p
 | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
author = String -> String
unknownEmail String
"unknown"
 | Bool
otherwise = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'<') String
author of
               -- No name, but have email (nothing spanned)
               (String
"", String
email) -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'@') (String -> String
forall a. [a] -> [a]
tail String
email) of
                   -- Not a real email address (no @).
                   (String
n, String
"") -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'>') String
n of
                       (String
name, String
_) -> String -> String
unknownEmail String
name
                   -- A "real" email address.
                   (String
user, String
rest) -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'>') (String -> String
forall a. [a] -> [a]
tail String
rest) of
                       (String
dom, String
_) -> String -> String -> String
mkAuthor String
user (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
emailPad (String
user String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"@" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dom)
               -- No email (everything spanned)
               (String
_, String
"") -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'@') String
author of
                   (String
n, String
"") -> String -> String
unknownEmail String
n
                   (String
name, String
_) -> String -> String -> String
mkAuthor String
name (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
emailPad String
author
               -- Name and email
               (String
n, String
rest) -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'>') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail String
rest of
                   (String
email, String
_) -> String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
emailPad String
email
 where
   author :: String
author = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ PatchInfo -> String
piAuthor (PatchInfoAnd rt p x y -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p)
   unknownEmail :: String -> String
unknownEmail = (String -> String -> String) -> String -> String -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> String
mkAuthor String
"<unknown>"
   emailPad :: String -> String
emailPad String
email = String
"<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
email String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
   mkAuthor :: String -> String -> String
mkAuthor String
name String
email = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
email

patchDate :: (PatchInfoAnd rt p) x y -> String
patchDate :: PatchInfoAnd rt p x y -> String
patchDate = String -> UTCTime -> String
formatDateTime String
"%s +0000" (UTCTime -> String)
-> (PatchInfoAnd rt p x y -> UTCTime)
-> PatchInfoAnd rt p x y
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClockTime -> UTCTime
fromClockTime (ClockTime -> UTCTime)
-> (PatchInfoAnd rt p x y -> ClockTime)
-> PatchInfoAnd rt p x y
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CalendarTime -> ClockTime
toClockTime (CalendarTime -> ClockTime)
-> (PatchInfoAnd rt p x y -> CalendarTime)
-> PatchInfoAnd rt p x y
-> ClockTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  PatchInfo -> CalendarTime
piDate (PatchInfo -> CalendarTime)
-> (PatchInfoAnd rt p x y -> PatchInfo)
-> PatchInfoAnd rt p x y
-> CalendarTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd rt p x y -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info

patchMessage :: (PatchInfoAnd rt p) x y -> BLU.ByteString
patchMessage :: PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p = [ByteString] -> ByteString
BL.concat [ String -> ByteString
BLU.fromString (PatchInfo -> String
piName (PatchInfo -> String) -> PatchInfo -> String
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p x y -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p)
                           , case [String] -> String
unlines ([String] -> String)
-> (PatchInfo -> [String]) -> PatchInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> [String]
piLog (PatchInfo -> String) -> PatchInfo -> String
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p x y -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p of
                                 String
"" -> ByteString
BL.empty
                                 String
plog -> String -> ByteString
BLU.fromString (String
"\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
plog)
                           ]

inOrderTag :: (Effect p) => [PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag :: [PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p wX wZ
p = PatchInfo -> Bool
isTag (PatchInfoAnd rt p wX wZ -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wX wZ
p) Bool -> Bool -> Bool
&& PatchInfoAnd rt p wX wZ -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wX wZ
p PatchInfo -> [PatchInfo] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PatchInfo]
tags Bool -> Bool -> Bool
&& FL (PrimOf p) wX wZ -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL (PatchInfoAnd rt p wX wZ
-> FL (PrimOf (PatchInfoAndG rt (Named p))) wX wZ
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect PatchInfoAnd rt p wX wZ
p)

next :: (Effect p) => [PatchInfo] -> Int ->  PatchInfoAnd rt p x y -> Int
next :: [PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next [PatchInfo]
tags Int
n PatchInfoAnd rt p x y
p = if [PatchInfo] -> PatchInfoAnd rt p x y -> Bool
forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p x y
p then Int
n else Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1