--  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
  -- exported for testing
  , cleanPatchAuthor
  , cleanPatchAuthorTestCases
  ) 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 (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.Set ( patchSet2FL, inOrderTags )

import Darcs.Repository
    ( RepoJob(..)
    , Repository
    , readPatches
    , repoCache
    , withRepository
    )
import Darcs.Repository.Pristine ( readHashedPristineRoot )
import Darcs.Repository.Traverse ( cleanPristineDir )

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 ( parseFlags, (?), (^) )
import qualified Darcs.UI.Options.All as O

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

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


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

convertExport :: DarcsCommand
convertExport :: DarcsCommand
convertExport = DarcsCommand
    { commandProgramName :: [Char]
commandProgramName = [Char]
"darcs"
    , commandName :: [Char]
commandName = [Char]
"export"
    , commandHelp :: Doc
commandHelp = Doc
convertExportHelp
    , commandDescription :: [Char]
commandDescription = [Char]
"Export a darcs repository to a git-fast-import stream"
    , commandExtraArgs :: Int
commandExtraArgs = Int
0
    , commandExtraArgHelp :: [[Char]]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
fastExport
    , commandPrereq :: [DarcsFlag] -> IO (Either [Char] ())
commandPrereq = [DarcsFlag] -> IO (Either [Char] ())
amInRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [[Char]] -> IO [[Char]]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [[Char]] -> IO [[Char]]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [[Char]] -> IO [[Char]]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [[Char]] -> IO [[Char]]
nodefaults
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
convertExportOpts
    }
  where
    convertExportBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe [Char] -> Maybe AbsolutePath -> Maybe AbsolutePath -> a)
convertExportBasicOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe AbsolutePath -> Maybe AbsolutePath -> a)
  (Maybe [Char])
PrimDarcsOption (Maybe [Char])
O.repoDir PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe AbsolutePath -> Maybe AbsolutePath -> a)
  (Maybe [Char])
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe AbsolutePath -> Maybe AbsolutePath -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe [Char] -> Maybe AbsolutePath -> Maybe AbsolutePath -> 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 AbsolutePath -> Maybe AbsolutePath -> a)
forall a.
DarcsOption a (Maybe AbsolutePath -> Maybe AbsolutePath -> a)
O.marks
    convertExportAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a RemoteDarcs
convertExportAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a RemoteDarcs
PrimDarcsOption RemoteDarcs
O.remoteDarcs
    convertExportOpts :: CommandOptions
convertExportOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> RemoteDarcs
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe [Char]
   -> Maybe AbsolutePath
   -> Maybe AbsolutePath
   -> Maybe StdCmdAction
   -> Verbosity
   -> RemoteDarcs
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe [Char] -> Maybe AbsolutePath -> Maybe AbsolutePath -> a)
convertExportBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> RemoteDarcs
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe [Char]
   -> Maybe AbsolutePath
   -> Maybe AbsolutePath
   -> Maybe StdCmdAction
   -> Verbosity
   -> RemoteDarcs
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (RemoteDarcs
      -> 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])
  (RemoteDarcs
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
PrimDarcsOption RemoteDarcs
convertExportAdvancedOpts

fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
fastExport (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [[Char]]
_ = do
  Marks
marks <- case (forall a.
 PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe AbsolutePath))
-> [DarcsFlag] -> Maybe AbsolutePath
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe AbsolutePath)
forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe AbsolutePath)
O.readMarks [DarcsFlag]
opts of
    Maybe AbsolutePath
Nothing -> Marks -> IO Marks
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Marks
emptyMarks
    Just AbsolutePath
f  -> [Char] -> IO Marks
readMarks (AbsolutePath -> [Char]
forall a. FilePathLike a => a -> [Char]
toFilePath AbsolutePath
f)
  Marks
newMarks <-
    UseCache -> RepoJob 'RO Marks -> IO Marks
forall a. UseCache -> RepoJob 'RO a -> IO a
withRepository (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) (RepoJob 'RO Marks -> IO Marks) -> RepoJob 'RO Marks -> IO Marks
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RO Marks -> RepoJob 'RO Marks
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RO Marks -> RepoJob 'RO Marks)
-> TreePatchJob 'RO Marks -> RepoJob 'RO Marks
forall a b. (a -> b) -> a -> b
$ \Repository 'RO p wU wR
repo -> Repository 'RO p wU wR -> Marks -> IO Marks
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> Marks -> IO Marks
fastExport' Repository 'RO p wU wR
repo Marks
marks
  case (forall a.
 PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe AbsolutePath))
-> [DarcsFlag] -> Maybe AbsolutePath
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe AbsolutePath)
forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe AbsolutePath)
O.writeMarks [DarcsFlag]
opts of
    Maybe AbsolutePath
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just AbsolutePath
f  -> [Char] -> Marks -> IO ()
writeMarks (AbsolutePath -> [Char]
forall a. FilePathLike a => a -> [Char]
toFilePath AbsolutePath
f) Marks
newMarks

fastExport' :: (RepoPatch p, ApplyState p ~ Tree)
            => Repository rt p wU wR -> Marks -> IO Marks
fastExport' :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> Marks -> IO Marks
fastExport' Repository rt p wU wR
repo Marks
marks = do
  [Char] -> IO ()
putStrLn [Char]
"progress (reading repository)"
  PatchSet p Origin wR
patchset <- Repository rt 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 rt p wU wR
repo
  IORef Marks
marksref <- Marks -> IO (IORef Marks)
forall a. a -> IO (IORef a)
newIORef Marks
marks
  let patches :: FL (PatchInfoAnd p) Origin wR
patches = PatchSet p Origin wR -> FL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX
patchSet2FL PatchSet p Origin wR
patchset
      tags :: [PatchInfo]
tags = PatchSet p Origin wR -> [PatchInfo]
forall (p :: * -> * -> *) wS wX. PatchSet p wS wX -> [PatchInfo]
inOrderTags PatchSet p Origin wR
patchset
      mark :: (PatchInfoAnd p) x y -> Int -> TreeIO ()
      mark :: forall (p :: * -> * -> *) x y.
PatchInfoAnd p x y -> Int -> TreeIO ()
mark PatchInfoAnd p x y
p Int
n = 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] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"mark :" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
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 p x y -> ByteString
forall (p :: * -> * -> *) cX cY. PatchInfoAnd p cX cY -> ByteString
patchHash PatchInfoAnd 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 p) x y -> TreeIO ()
      checkOne :: forall (p :: * -> * -> *) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int -> PatchInfoAnd p x y -> TreeIO ()
checkOne Int
n PatchInfoAnd p x y
p = do PatchInfoAnd p x y -> TreeIO ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PatchInfoAndG (Named p))) m =>
PatchInfoAndG (Named p) wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply PatchInfoAnd p x y
p
                        Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PatchInfo] -> PatchInfoAnd p x y -> Bool
forall (p :: * -> * -> *) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd 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 p x y -> ByteString
forall (p :: * -> * -> *) cX cY. PatchInfoAnd p cX cY -> ByteString
patchHash PatchInfoAnd p x y
p))) (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$
                          [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: Marks do not correspond: expected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                 Maybe ByteString -> [Char]
forall a. Show a => a -> [Char]
show (Marks -> Int -> Maybe ByteString
getMark Marks
marks Int
n) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BC.unpack (PatchInfoAnd p x y -> ByteString
forall (p :: * -> * -> *) cX cY. PatchInfoAnd p cX cY -> ByteString
patchHash PatchInfoAnd 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 p) x y -> TreeIO (Int,  FlippedSeal( FL (PatchInfoAnd p)) y) 
      check :: forall (p :: * -> * -> *) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd p)) y)
check Int
_ FL (PatchInfoAnd p) x y
NilFL = (Int, FlippedSeal (FL (PatchInfoAnd p)) y)
-> RWST
     (DumpItem IO)
     ()
     (TreeState IO)
     IO
     (Int, FlippedSeal (FL (PatchInfoAnd p)) y)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1, FL (PatchInfoAnd p) y y -> FlippedSeal (FL (PatchInfoAnd p)) y
forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd p) y y
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
      check Int
n allps :: FL (PatchInfoAnd p) x y
allps@(PatchInfoAnd p x wY
p:>:FL (PatchInfoAnd p) wY y
ps)
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Marks -> Int
lastMark Marks
marks = Int -> PatchInfoAnd p x wY -> TreeIO ()
forall (p :: * -> * -> *) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int -> PatchInfoAnd p x y -> TreeIO ()
checkOne Int
n PatchInfoAnd p x wY
p TreeIO ()
-> RWST
     (DumpItem IO)
     ()
     (TreeState IO)
     IO
     (Int, FlippedSeal (FL (PatchInfoAnd p)) y)
-> RWST
     (DumpItem IO)
     ()
     (TreeState IO)
     IO
     (Int, FlippedSeal (FL (PatchInfoAnd p)) y)
forall a b.
RWST (DumpItem IO) () (TreeState IO) IO a
-> RWST (DumpItem IO) () (TreeState IO) IO b
-> RWST (DumpItem IO) () (TreeState IO) IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int
-> FL (PatchInfoAnd p) wY y
-> RWST
     (DumpItem IO)
     ()
     (TreeState IO)
     IO
     (Int, FlippedSeal (FL (PatchInfoAnd p)) y)
forall (p :: * -> * -> *) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd p)) y)
check ([PatchInfo] -> Int -> PatchInfoAnd p x wY -> Int
forall (p :: * -> * -> *) x y.
Effect p =>
[PatchInfo] -> Int -> PatchInfoAnd p x y -> Int
next [PatchInfo]
tags Int
n PatchInfoAnd p x wY
p) FL (PatchInfoAnd 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 p)) y)
-> RWST
     (DumpItem IO)
     ()
     (TreeState IO)
     IO
     (Int, FlippedSeal (FL (PatchInfoAnd p)) y)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n, FL (PatchInfoAnd p) x y -> FlippedSeal (FL (PatchInfoAnd p)) y
forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd 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 p)) y)
-> RWST
     (DumpItem IO)
     ()
     (TreeState IO)
     IO
     (Int, FlippedSeal (FL (PatchInfoAnd p)) y)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1, FL (PatchInfoAnd p) x y -> FlippedSeal (FL (PatchInfoAnd p)) y
forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd p) x y
allps)
        | Bool
otherwise = RWST
  (DumpItem IO)
  ()
  (TreeState IO)
  IO
  (Int, FlippedSeal (FL (PatchInfoAnd p)) y)
forall a. HasCallStack => a
undefined
  ((Int
n, FlippedSeal (FL (PatchInfoAnd p)) wR
patches'), Tree IO
tree') <- TreeIO (Int, FlippedSeal (FL (PatchInfoAnd p)) wR)
-> Tree IO
-> Cache
-> IO ((Int, FlippedSeal (FL (PatchInfoAnd p)) wR), Tree IO)
forall a. TreeIO a -> Tree IO -> Cache -> IO (a, Tree IO)
hashedTreeIO (Int
-> FL (PatchInfoAnd p) Origin wR
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd p)) wR)
forall (p :: * -> * -> *) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd p)) y)
check Int
1 FL (PatchInfoAnd p) Origin wR
patches) Tree IO
forall (m :: * -> *). Tree m
emptyTree (Repository rt p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository rt p wU wR
repo)
  let patches'' :: FL (PatchInfoAnd p) wB wC
patches'' = (forall wX wY.
 FL (PatchInfoAnd p) wX wY -> FL (PatchInfoAnd p) wB wC)
-> FlippedSeal (FL (PatchInfoAnd p)) wR
-> FL (PatchInfoAnd p) wB wC
forall (a :: * -> * -> *) b wZ.
(forall wX wY. a wX wY -> b) -> FlippedSeal a wZ -> b
unsealFlipped FL (PatchInfoAnd p) wX wY -> FL (PatchInfoAnd p) wB wC
forall wX wY.
FL (PatchInfoAnd p) wX wY -> FL (PatchInfoAnd p) wB wC
forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP FlippedSeal (FL (PatchInfoAnd p)) wR
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 -> Cache -> IO ((), Tree IO)
forall a. TreeIO a -> Tree IO -> Cache -> IO (a, Tree IO)
hashedTreeIO ([PatchInfo]
-> (forall (p :: * -> * -> *) x y.
    PatchInfoAnd p x y -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd p) Any Any
-> TreeIO ()
forall (p :: * -> * -> *) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
[PatchInfo]
-> (forall (p :: * -> * -> *) x y.
    PatchInfoAnd p x y -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd p) x y
-> TreeIO ()
dumpPatches [PatchInfo]
tags PatchInfoAnd p0 x0 y0 -> Int -> TreeIO ()
forall (p :: * -> * -> *) x y.
PatchInfoAnd p x y -> Int -> TreeIO ()
mark Int
n FL (PatchInfoAnd p) Any Any
forall {wB} {wC}. FL (PatchInfoAnd p) wB wC
patches'') Tree IO
tree' (Repository rt p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository rt p wU wR
repo)
  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
  [Char] -> IO ()
putStrLn [Char]
"progress (cleaning up)"
  PristineHash
current <- Repository rt p wU wR -> IO PristineHash
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO PristineHash
readHashedPristineRoot Repository rt p wU wR
repo
  Cache -> [PristineHash] -> IO ()
cleanPristineDir (Repository rt p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository rt p wU wR
repo) [PristineHash
current]
  [Char] -> IO ()
putStrLn [Char]
"progress done"

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

dumpTag :: (PatchInfoAnd p) x y  -> Int -> TreeIO () 
dumpTag :: forall (p :: * -> * -> *) x y.
PatchInfoAnd p x y -> Int -> TreeIO ()
dumpTag PatchInfoAnd p x y
p Int
n =
  [ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"progress TAG " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PatchInfoAnd p x y -> [Char]
forall {p :: * -> * -> *} {wA} {wB}.
PatchInfoAndG p wA wB -> [Char]
cleanTagName PatchInfoAnd p x y
p
           , [Char] -> ByteString
BLU.fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"tag " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PatchInfoAnd p x y -> [Char]
forall {p :: * -> * -> *} {wA} {wB}.
PatchInfoAndG p wA wB -> [Char]
cleanTagName PatchInfoAnd p x y
p -- FIXME is this valid?
           , [Char] -> ByteString
BLU.fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"from :" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
           , [Char] -> ByteString
BLU.fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]
"tagger", PatchInfoAnd p x y -> [Char]
forall (p :: * -> * -> *) x y. PatchInfoAnd p x y -> [Char]
patchAuthor PatchInfoAnd p x y
p, PatchInfoAnd p x y -> [Char]
forall (p :: * -> * -> *) x y. PatchInfoAnd p x y -> [Char]
patchDate PatchInfoAnd p x y
p]
           -- -3 == (-4 for "TAG " and +1 for newline)
           , [Char] -> ByteString
BLU.fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"data "
                 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int64 -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> Int64
BL.length (PatchInfoAnd p x y -> ByteString
forall (p :: * -> * -> *) x y. PatchInfoAnd p x y -> ByteString
patchMessage PatchInfoAnd 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 p x y -> ByteString
forall (p :: * -> * -> *) x y. PatchInfoAnd p x y -> ByteString
patchMessage PatchInfoAnd 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 p wA wB -> [Char]
cleanTagName = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
cleanup ([Char] -> [Char])
-> (PatchInfoAndG p wA wB -> [Char])
-> PatchInfoAndG p wA wB
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
4 ([Char] -> [Char])
-> (PatchInfoAndG p wA wB -> [Char])
-> PatchInfoAndG p wA wB
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> [Char]
piName (PatchInfo -> [Char])
-> (PatchInfoAndG p wA wB -> PatchInfo)
-> PatchInfoAndG p wA wB
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAndG p wA wB -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info
         where cleanup :: Char -> Char
cleanup Char
x | Char
x Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
bad = Char
'_'
                         | Bool
otherwise = Char
x
               bad :: String
               bad :: [Char]
bad = [Char]
" ~^:"

dumpFiles :: [AnchoredPath] -> TreeIO ()
dumpFiles :: [AnchoredPath] -> TreeIO ()
dumpFiles [AnchoredPath]
files = [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 :: [Char]
quotedPath = [Char] -> [Char]
quotePath ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> AnchoredPath -> [Char]
anchorPath [Char]
"" 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 :: * -> *).
MonadThrow m =>
AnchoredPath -> TreeMonad m ByteString
T.readFile AnchoredPath
file
                   [ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"M 100644 inline " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
quotedPath
                            , [Char] -> ByteString
BLU.fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"data " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int64 -> [Char]
forall a. Show a => a -> [Char]
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 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]
"D " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
quotedPath
                  Tree IO
tt <- (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
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 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]
"D " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
quotedPath
  where
    -- |quotePath escapes and quotes paths containing newlines, double-quotes
    -- or backslashes.
    quotePath :: FilePath -> String
    quotePath :: [Char] -> [Char]
quotePath [Char]
path = case (Char -> ([Char], Bool) -> ([Char], Bool))
-> ([Char], Bool) -> [Char] -> ([Char], Bool)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ([Char], Bool) -> ([Char], Bool)
escapeChars ([Char]
"", Bool
False) [Char]
path of
        ([Char]
_, Bool
False) -> [Char]
path
        ([Char]
path', Bool
True) -> [Char] -> [Char]
quote [Char]
path'

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

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

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


dumpPatch ::  (forall p0 x0 y0 . (PatchInfoAnd p0) x0 y0 -> Int -> TreeIO ())
          -> (PatchInfoAnd p) x y -> Int
          -> TreeIO ()
dumpPatch :: forall (p :: * -> * -> *) x y.
(forall (p :: * -> * -> *) x y.
 PatchInfoAnd p x y -> Int -> TreeIO ())
-> PatchInfoAnd p x y -> Int -> TreeIO ()
dumpPatch forall (p :: * -> * -> *) x y.
PatchInfoAnd p x y -> Int -> TreeIO ()
mark PatchInfoAnd p x y
p Int
n =
  do [ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"progress " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PatchInfo -> [Char]
piName (PatchInfoAnd p x y -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAnd p x y
p)
              , ByteString
"commit refs/heads/master" ]
     PatchInfoAnd p x y -> Int -> TreeIO ()
forall (p :: * -> * -> *) x y.
PatchInfoAnd p x y -> Int -> TreeIO ()
mark PatchInfoAnd p x y
p Int
n
     [ByteString] -> TreeIO ()
dumpBits [ [Char] -> ByteString
BLU.fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"committer " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PatchInfoAnd p x y -> [Char]
forall (p :: * -> * -> *) x y. PatchInfoAnd p x y -> [Char]
patchAuthor PatchInfoAnd p x y
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PatchInfoAnd p x y -> [Char]
forall (p :: * -> * -> *) x y. PatchInfoAnd p x y -> [Char]
patchDate PatchInfoAnd p x y
p
              , [Char] -> ByteString
BLU.fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"data " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int64 -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> Int64
BL.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd p x y -> ByteString
forall (p :: * -> * -> *) x y. PatchInfoAnd p x y -> ByteString
patchMessage PatchInfoAnd p x y
p)
              , PatchInfoAnd p x y -> ByteString
forall (p :: * -> * -> *) x y. PatchInfoAnd p x y -> ByteString
patchMessage PatchInfoAnd 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 [ [Char] -> ByteString
BLU.fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"from :" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
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 a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
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 p) x y -> String
patchAuthor :: forall (p :: * -> * -> *) x y. PatchInfoAnd p x y -> [Char]
patchAuthor = [Char] -> [Char]
cleanPatchAuthor ([Char] -> [Char])
-> (PatchInfoAnd p x y -> [Char]) -> PatchInfoAnd p x y -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> [Char]
piAuthor (PatchInfo -> [Char])
-> (PatchInfoAnd p x y -> PatchInfo)
-> PatchInfoAnd p x y
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p x y -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info

cleanPatchAuthor :: String -> String
cleanPatchAuthor :: [Char] -> [Char]
cleanPatchAuthor [Char]
authorString
 | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
author = [Char] -> [Char]
unknownEmail [Char]
"unknown"
 | Bool
otherwise = case (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]
author of
               -- No name, but have email (nothing spanned)
               ([Char]
"", Char
_:[Char]
email) -> case (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]
email of
                   -- Not a real email address (no @).
                   ([Char]
n, [Char]
"") -> case (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]
n of
                       ([Char]
name, [Char]
_) -> [Char] -> [Char]
unknownEmail [Char]
name
                   -- A "real" email address.
                   ([Char]
user, Char
_:[Char]
rest) -> case (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]
rest of
                       ([Char]
dom, [Char]
_) -> [Char] -> [Char] -> [Char]
mkAuthor [Char]
user ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
emailPad ([Char]
user [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"@" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
dom)
               -- No email (everything spanned)
               ([Char]
_, [Char]
"") -> case (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]
author of
                   ([Char]
n, [Char]
"") -> [Char] -> [Char]
unknownEmail [Char]
n
                   ([Char]
name, [Char]
_) -> [Char] -> [Char] -> [Char]
mkAuthor [Char]
name ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
emailPad [Char]
author
               -- Name and email
               ([Char]
n, Char
_:[Char]
rest) -> case (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]
rest of
                   ([Char]
email, [Char]
_) -> [Char]
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
emailPad [Char]
email
 where
   author :: [Char]
author = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
authorString
   unknownEmail :: [Char] -> [Char]
unknownEmail = ([Char] -> [Char] -> [Char]) -> [Char] -> [Char] -> [Char]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> [Char] -> [Char]
mkAuthor [Char]
"<unknown>"
   emailPad :: [Char] -> [Char]
emailPad [Char]
email = [Char]
"<" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
email [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">"
   mkAuthor :: [Char] -> [Char] -> [Char]
mkAuthor [Char]
name [Char]
email = [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
email

cleanPatchAuthorTestCases :: [(String, String)]
cleanPatchAuthorTestCases :: [([Char], [Char])]
cleanPatchAuthorTestCases =
  [ ([Char]
"<john@home>", [Char]
"john <john@home>")
  , ([Char]
"john@home", [Char]
"john <john@home>")
  , ([Char]
"john <john@home>", [Char]
"john <john@home>")
  , ([Char]
"john <john@home", [Char]
"john <john@home>")
  , ([Char]
"<john>", [Char]
"john <unknown>")
  , ([Char]
"", [Char]
"unknown <unknown>")
  , ([Char]
" ", [Char]
"unknown <unknown>")
  ]

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

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

inOrderTag :: (Effect p) => [PatchInfo] -> PatchInfoAnd p wX wZ -> Bool
inOrderTag :: forall (p :: * -> * -> *) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd p wX wZ
p = PatchInfo -> Bool
isTag (PatchInfoAnd p wX wZ -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAnd p wX wZ
p) Bool -> Bool -> Bool
&& PatchInfoAnd p wX wZ -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAnd p wX wZ
p PatchInfo -> [PatchInfo] -> Bool
forall a. Eq a => a -> [a] -> 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 p wX wZ -> FL (PrimOf (PatchInfoAndG (Named p))) wX wZ
forall wX wY.
PatchInfoAndG (Named p) wX wY
-> FL (PrimOf (PatchInfoAndG (Named p))) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect PatchInfoAnd p wX wZ
p)

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