%  Copyright (C) 2005 Juliusz Chroboczek
%
%  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.


\begin{code}
{-# OPTIONS -fffi -fno-warn-unused-binds #-}
module Git ( GitFile, GitSlurpy, emptyGitSlurpy, readGitFile, gitFileType,
             assertGitFileType, gitFileContents,
             gitFileLinesPSetc, gitReadCache, gitHeadCommit,
             GitCommit, readGitCommit, gitCommitToPatchInfo,
             gitCommitDate, gitCommitDatePS,
             gitCommitParents, gitCommitTree, gitCommitToPatch,
             gitCommitToPatch', gitSlurpyToSlurpy, slurpGitCommit,
             applyToGitSlurpy, purifyGitSlurpy, writeGitCommit, updateHead
           ) where
import Monad
import Maybe ( fromMaybe )
import Foreign
import CForeign
import CString
import ForeignPtr
import FastPackedString
import List ( sort, insert )
import PatchCore ( Patch(..), addfile, rmfile, adddir, rmdir, is_merger,
                   FilePatchType(..), DirPatchType(..) )
import PatchCommute ( merger_equivalent )
import Patch ( join_patches )
import PatchInfo ( PatchInfo(..) )
import PatchApply ( applyBinary, applyHunkLines )
import SlurpDirectory ( Slurpy(..), FileContents, emptyFileContents,
                        undefined_time, undefined_size )
import FileName ( fp2fn, fn2fp )
import Diff ( diff_files )
import DarcsUtils ( withCurrentDirectory )
import System.IO.Unsafe ( unsafeInterleaveIO )

#include "impossible.h"

foreign import ccall unsafe "gitlib.h git_read_file" git_read_file
  :: CString -> IO (Ptr GitFileStruct)

foreign import ccall unsafe "gitlib.h & git_file_done" git_file_done
  :: FunPtr (Ptr GitFileStruct -> IO ())

type GitFile = ForeignPtr GitFileStruct
data GitFileStruct = GF !(Ptr Word8) !CString !CULong

instance Storable GitFileStruct where
    sizeOf (GF a b c) = sizeOf a + sizeOf b + sizeOf c
    alignment _ = 1
    peek p = do a <- peek (castPtr p)
                b <- peekByteOff (castPtr p) (sizeOf a)
                c <- peekByteOff (castPtr p) (sizeOf a + sizeOf b)
                return (GF a b c)
    poke p (GF a b c) = do poke (castPtr p) a
                           pokeByteOff (castPtr p) (sizeOf a) b
                           pokeByteOff (castPtr p) (sizeOf a + sizeOf b) c

readGitFile :: String -> IO GitFile
readGitFile sha1 = do f <- withCString sha1 $ git_read_file
                      when (f == nullPtr) $
                          fail $ "Couldn't read Git file " ++ sha1
                      newForeignPtr git_file_done f

gitFileType :: GitFile -> IO String
gitFileType gf = do (GF _ t _) <- withForeignPtr gf peek
                    peekCString t

assertGitFileType :: GitFile -> String -> IO ()
assertGitFileType gf t = do gft <- gitFileType gf
                            when (gft /= t) $
                                fail ("Unexpected Git type " ++ gft ++
                                      " expected " ++ t)
                            return ()

gitFileContentsPS :: GitFile -> IO PackedString
gitFileContentsPS gf =
    do (GF c _ l) <- withForeignPtr gf peek
       constructPS c (fromIntegral l) (touchForeignPtr gf)

gitFileLinesPSetc :: GitFile -> IO FileContents
gitFileLinesPSetc gf = do ps <- gitFileContentsPS gf
                          return (linesPS ps, Just ps)

gitFileContents :: GitFile -> IO String
gitFileContents gf = do s <- unpackPS `liftM` gitFileContentsPS gf
                        return s

foreign import ccall unsafe "gitlib.h read_cache" git_read_cache
  :: IO ()

gitReadCache :: IO ()
gitReadCache = git_read_cache   -- for now

foreign import ccall unsafe "git_head" git_head :: CString -> IO CString

foreign import ccall unsafe "git_update_head" git_update_head
    :: CString -> CString -> IO CInt

gitHeadCommit :: String -> IO String
gitHeadCommit s = do h <- (withCString (".git/" ++ s) git_head)
                     when (h == nullPtr) $ fail ("No file .git/" ++ s)
                     peekCString h

type GitCommit = ([(PackedString, PackedString)], PackedString)

readGitCommit :: String -> String -> GitCommit
readGitCommit repo sha1 = unsafePerformIO $
                          withCurrentDirectory repo $
                              do gf <- readGitFile sha1
                                 assertGitFileType gf "commit"
                                 parseGitCommit `liftM` gitFileContentsPS gf

parseGitCommit :: PackedString -> GitCommit
parseGitCommit c = let (headers, body) = fromJust $ break2PS '\n' '\n' c
                   in ((map parseGitHeaderLine (linesPS headers)), body)
    where break2PS a b cc = (\(x,y) -> (initPS x, tailPS y)) `liftM`
                            breakFirstPairPS a b cc

trimPS :: PackedString -> PackedString
trimPS ps = if (lastPS ps) == '\n' then (initPS ps) else ps

parseGitHeaderLine :: PackedString -> (PackedString, PackedString)
parseGitHeaderLine l =
    let (Just (k, rest)) = breakFirstPS ' ' l
    in (k, trimPS rest)

gitCommitValue :: String -> GitCommit -> [String]
gitCommitValue s gc = map unpackPS $ gitCommitValuePS (packString s) gc

gitCommitValuePS :: PackedString -> GitCommit -> [PackedString]
gitCommitValuePS key (kl, _) = gitCommitValue' kl []
    where gitCommitValue' [] r = reverse r
          gitCommitValue' ((k, v) : rest) r | k == key =
              gitCommitValue' rest (v : r)
          gitCommitValue' (_ : rest) r = gitCommitValue' rest r

gitSingleCommitValue :: String -> GitCommit -> String
gitSingleCommitValue s gc =
    unpackPS $ gitSingleCommitValuePS s gc

gitSingleCommitValuePS :: String -> GitCommit -> PackedString
gitSingleCommitValuePS key gc = case gitCommitValuePS (packString key) gc of
                                [s] -> s
                                [] -> error $ "There is no " ++ key
                                _ -> error $ "More than one " ++ key

gitCommitterHeader :: String
gitCommitterHeader = "Git-Committer: "

gitCommitToPatchInfo :: String -> GitCommit -> PatchInfo
gitCommitToPatchInfo _ gc =
    let author = gitSingleCommitValuePS "author" gc
        committer = gitSingleCommitValuePS "committer" gc
        (darcs_author, darcs_date) = parseAuthorLine author
        comment = linesPS (snd gc)
        name = head comment
        darcs_log' = tail comment
        darcs_log =
            if (author == committer)
               then darcs_log'
               else (darcs_log' ++
                     [(packString $ gitCommitterHeader ++
                                    (unpackPS committer))])
    in PatchInfo darcs_date name darcs_author darcs_log False

-- the date of the commit -- not the date in the author header, which
-- is available in the PatchInfo.
gitCommitDatePS :: String -> GitCommit -> PackedString
gitCommitDatePS _ gc =
    let committer = gitSingleCommitValuePS "committer" gc
        (_, date) = parseAuthorLine committer
    in date

gitCommitDate :: String -> GitCommit -> String
gitCommitDate sha1 gc = unpackPS (gitCommitDatePS sha1 gc)

parseAuthorLine :: PackedString -> (PackedString, PackedString)
parseAuthorLine s =
    let Just (a, d') = breakFirstPairPS '>' ' ' s
        d = tailPS d'
    in (a, (gitDateToDarcsDate d))

foreign import ccall unsafe "gitlib.h git_parse_time" git_parse_time
  :: CULong -> CString

foreign import ccall unsafe "gitlib.h git_format_time" git_format_time
  :: CString -> CULong

parseGitTime :: CULong -> PackedString
parseGitTime s = unsafePerformIO $ mallocedCString2PS (git_parse_time s)

formatGitTime :: String -> CULong
formatGitTime s = unsafePerformIO $
    withCString s $ return . git_format_time

gitDateToDarcsDate :: PackedString -> PackedString
gitDateToDarcsDate d = parseGitTime (fst (head (reads (unpackPS d))))

gitCommitParents :: GitCommit -> [String]
gitCommitParents gc = gitCommitValue "parent" gc

gitCommitTree :: GitCommit -> String
gitCommitTree = gitSingleCommitValue "tree"

foreign import ccall unsafe "gitlib.h strcmp" git_strcmp
  :: CString -> CString -> IO CInt

compareCString :: CString -> CString -> Ordering
compareCString s1 s2 =
    unsafePerformIO $
        do rc <- git_strcmp s1 s2
           if(rc < 0) then return LT
               else if(rc == 0) then return EQ
                   else return GT

-- according to The Law, we must do a raw comparison of the bytes in a
-- filename, except that trees compare as though they had an appended
-- slash.
linusCompatibleCompare :: (String, Bool) -> (String, Bool) -> Ordering
linusCompatibleCompare (n1, t1) (n2, t2) =
    unsafePerformIO $
        withCString (tweak n1 t1) $ \c1 ->
            withCString (tweak n2 t2) $ \c2 ->
                do rc <- git_strcmp c1 c2
                   if (rc < 0) then return LT
                       else if(rc == 0) then return EQ
                           else return GT
             where tweak n False = n
                   tweak n True = n ++ "/"

data GitFileInfo = GFI { gfi_repo :: String,
                         gfi_mode :: !CUInt,
                         gfi_name :: !PackedString,
                         gfi_sha1 :: !PackedString }
                   deriving ( Eq )
data GitFileInfoStruct = GFIS

foreign import ccall unsafe "gitlib.h git_file_info_done" git_file_info_done
  :: Ptr GitFileInfoStruct -> IO ()

gfistruct2gfi :: String -> Ptr GitFileInfoStruct -> IO GitFileInfo
gfistruct2gfi repo p =
    do mode <- peek $ castPtr p
       name <- peekByteOff (castPtr p) (sizeOf (0::CUInt)) >>= peekCString
       sha1words <- peekArray 20 $ (castPtr p) `plusPtr`
                    (sizeOf (0::CUInt) + sizeOf (nullPtr::CString))
       git_file_info_done p
       return $ GFI repo mode (packString name)
                  (fromPS2Hex $ packWords sha1words)

sameContents :: GitFileInfo -> GitFileInfo -> Bool
sameContents a b = gfi_mode a == gfi_mode b && gfi_sha1 a == gfi_sha1 b

foreign import ccall unsafe "gitlib.h git_is_tree" git_is_tree
  :: CUInt -> CInt

foreign import ccall unsafe "gitlib.h git_default_file_mode" git_default_file_mode
  :: CUInt -> CUInt

(+/+) :: String -> String -> String
[] +/+ s = s
_ +/+ s@('/' : _) = s
p +/+ s | p /= "" && last p == '/' = p ++ s
p +/+ s = p ++ "/" ++ s

nopath :: String -> String
nopath s = reverse (takeWhile (\c -> c /= '/') (reverse s))

noname :: String -> String
noname s | not ('/' `elem` s) = s
noname s = take (length s - length (nopath s) - 1) s

isPrefix :: String -> String -> Bool
isPrefix "" p = p == "" || head p == '/'
isPrefix (_:a) (_:b) = isPrefix a b
isPrefix _ _ = False

isDirectPrefix :: String -> String -> Bool
isDirectPrefix p f = noname f == p

makeGitFileInfo :: String -> String -> GitFileInfo
                -> GitFileInfo
makeGitFileInfo repo prefix p =
    p { gfi_repo = repo,
        gfi_name = packString $ prefix +/+ (unpackPS $ gfi_name p) }

gitIsTree :: GitFileInfo -> Bool
gitIsTree gfi = git_is_tree (gfi_mode gfi) /= 0

gitFileInfoToGitFile :: GitFileInfo -> GitFile
gitFileInfoToGitFile gfi =
    unsafePerformIO $ withCurrentDirectory (gfi_repo gfi) $
                    readGitFile $ unpackPS (gfi_sha1 gfi)

-- keeps a reference to the underlying GitFile to keep it from getting
-- finalised.

type GitTreeIterator = Ptr GitTreeIteratorStruct

data GitTreeIteratorStruct = GTIS

foreign import ccall unsafe "gitlib.h git_tree_begin" git_tree_begin
  :: (Ptr Word8) -> CULong -> IO (Ptr GitTreeIteratorStruct)

foreign import ccall unsafe "gitlib.h git_tree_next" git_tree_next
  :: (Ptr GitTreeIteratorStruct) -> IO (Ptr GitFileInfoStruct)

foreign import ccall unsafe "gitlib.h git_tree_done" git_tree_done
  :: (Ptr GitTreeIteratorStruct) -> IO ()

iterateGitTree :: String -> String -> GitFile -> [GitFileInfo]
iterateGitTree repo prefix gf =
    unsafePerformIO $
       do assertGitFileType gf "tree"
          (GF c _ l) <- withForeignPtr gf peek
          iter <- git_tree_begin c l
          igt iter
           where
               igt i = unsafeInterleaveIO $
                   do p <- git_tree_next i
                      if p == nullPtr
                          then do git_tree_done i
                                  touchForeignPtr gf
                                  return []
                          else do gfi <- gfistruct2gfi repo p
                                  rest <- igt i
                                  return (makeGitFileInfo repo prefix gfi:rest)

-- GitSlurpy is similar to Slurpy, but keeps the sha1 around.
-- It also keeps the lists sorted, which makes generating patches simpler.

data GitSlurpy = GST !GitFileInfo [GitSlurpy]
               | GSF !GitFileInfo
               | GST_dirty !String CUInt [GitSlurpy]
               | GSF_dirty !String CUInt FileContents

instance Eq GitSlurpy where
    (GST a _) == (GST b _) = a == b
    (GSF a) == (GSF b) = a == b
    (GST_dirty a _ _) == (GST_dirty b _ _) = a == b
    (GSF_dirty a _ _) == (GSF_dirty b _ _) = a == b
    _ == _ = False

-- pure and dirty must sort alike, so that purification and dirtying
-- can preserve sortedness.
instance Ord GitSlurpy where
    compare a b = linusCompatibleCompare (frob a) (frob b)
                      where frob x = (slurpyName x, slurpyIsTree x)

instance Show GitSlurpy where
    show s@(GST _ l) =
        "Tree " ++ slurpyName s ++ "\n" ++
              concat (map show l) ++ "End Tree " ++ slurpyName s ++ "\n"
    show s@(GSF _) = "Blob " ++ slurpyName s ++ "\n"
    show (GST_dirty n _ l) =
        "Tree " ++ n ++ " (dirty)\n" ++
              concat (map show l) ++ "End Tree " ++ n ++ "\n"
    show (GSF_dirty n _ _) = "Blob " ++ n ++ " (dirty)\n"

-- Git trees are monotonic: once an object is created, it will never
-- disappear, and its value will never change.  This is why it is
-- safe to slurp Git trees outside of the IO monad.

emptyGitSlurpy :: GitSlurpy
emptyGitSlurpy = GST_dirty "." (git_default_file_mode 1) []

slurpyIsTree :: GitSlurpy -> Bool
slurpyIsTree (GST _ _) = True
slurpyIsTree (GST_dirty _ _ _) = True
slurpyIsTree _ = False

slurpyName :: GitSlurpy -> String
slurpyName (GST gfi _) = unpackPS $ gfi_name gfi
slurpyName (GSF gfi) = unpackPS $ gfi_name gfi
slurpyName (GST_dirty n _ _) = n
slurpyName (GSF_dirty n _ _) = n

slurpySameName :: GitSlurpy -> GitSlurpy -> Bool
slurpySameName s1 s2 = (slurpyName s1) == (slurpyName s2)

slurpyMode :: GitSlurpy -> CUInt
slurpyMode (GST gfi _) = gfi_mode gfi
slurpyMode (GSF gfi) = gfi_mode gfi
slurpyMode (GST_dirty _ m _) = m
slurpyMode (GSF_dirty _ m _) = m

slurpySameContents :: GitSlurpy -> GitSlurpy -> Bool
slurpySameContents (GST gfi1 _) (GST gfi2 _) = sameContents gfi1 gfi2
slurpySameContents (GSF gfi1) (GSF gfi2) = sameContents gfi1 gfi2
slurpySameContents _ _ = False

slurpyChildren :: GitSlurpy -> [GitSlurpy]
slurpyChildren (GST _ l) = l
slurpyChildren (GST_dirty _ _ l) = l
slurpyChildren _ = impossible

slurpGitTree' :: String -> String -> String -> [GitSlurpy]
slurpGitTree' repo prefix sha1 =
    unsafePerformIO $ withCurrentDirectory repo $
        do treefile <- readGitFile sha1
           let gfis = iterateGitTree repo prefix treefile
           -- Note: the sort below makes this non-lazy.  :(
           return $ sort $ map (slurpGitFile repo) gfis

slurpGitTree :: String -> GitFileInfo -> GitSlurpy
slurpGitTree repo gfi = GST gfi $ slurpGitTree' repo
                        (unpackPS $ gfi_name gfi) (unpackPS $ gfi_sha1 gfi)

slurpGitFile :: String -> GitFileInfo -> GitSlurpy
slurpGitFile repo gfi =
    if (gitIsTree gfi) then slurpGitTree repo gfi
                       else (GSF gfi)

data CacheEntryStruct = CES

foreign import ccall unsafe "gitlib.h git_cache_entry" git_cache_entry
  :: CString -> IO(Ptr CacheEntryStruct)

foreign import ccall unsafe "gitlib.h git_cache_entry_sha1"
    git_cache_entry_sha1_unsafe
  :: (Ptr CacheEntryStruct) -> IO CString

foreign import ccall unsafe "gitlib.h git_cache_entry_size" git_cache_entry_size
  :: (Ptr CacheEntryStruct) -> CUInt

foreign import ccall unsafe "gitlib.h git_cache_entry_mtime" git_cache_entry_mtime
  :: (Ptr CacheEntryStruct) -> CUInt

foreign import ccall unsafe "gitlib.h git_validate" git_validate
  :: (Ptr CChar) -> (Ptr CChar) -> CInt -> IO CInt

validateCacheEntry :: (Ptr CacheEntryStruct) -> GitFileInfo -> IO Bool
validateCacheEntry entry gfi =
    do shaPtr <- git_cache_entry_sha1_unsafe entry
       withCStringPS (gfi_sha1 gfi) $ \s -> do v <- git_validate s shaPtr 20
                                               return (v == 1)

gitSlurpyToSlurpy :: GitSlurpy -> Slurpy
gitSlurpyToSlurpy (GST gfi l) =
    SlurpDir (fp2fn $ nopath $ unpackPS $ gfi_name gfi)
                 (map gitSlurpyToSlurpy l)
gitSlurpyToSlurpy (GSF (gfi@(GFI repo _ name _))) =
    unsafePerformIO $ withCurrentDirectory repo $
        do cacheEntry <- withCStringPS name $ \n -> git_cache_entry n
           validCacheEntry <-
               if cacheEntry == nullPtr
                  then return False
                  else validateCacheEntry cacheEntry gfi
           let gf = gitFileInfoToGitFile gfi
           let mtime = if validCacheEntry
                           then fromIntegral $ git_cache_entry_mtime cacheEntry
                           else undefined_time
           let size = if validCacheEntry
                          then fromIntegral $ git_cache_entry_size cacheEntry
                          else undefined_size
           contents <- unsafeInterleaveIO $ gitFileLinesPSetc gf
           return $ SlurpFile (fp2fn $ nopath $ unpackPS name)
                      (mtime, size) contents
gitSlurpyToSlurpy (GST_dirty name _ l) =
    SlurpDir (fp2fn $ nopath name) (map gitSlurpyToSlurpy l)
gitSlurpyToSlurpy (GSF_dirty name _ c) =
    SlurpFile (fp2fn $ nopath name) (undefined_time, undefined_size) c

slurpGitCommit :: String -> GitCommit -> GitSlurpy
slurpGitCommit repo gc = slurpGitTree repo $
                         GFI repo (git_default_file_mode 1)
                         (packString ".") (packString $ gitCommitTree gc)

-- assumes both lists are sorted
gitListToPatches
  :: String -> String -> [GitSlurpy] -> [GitSlurpy] -> [Patch]
gitListToPatches repo p l1 l2 =
    case (l1, l2) of
        ([], []) -> []
        (s1:l1', []) -> (gitToPatches repo p (Just s1) Nothing) ++
                        (gitListToPatches repo p l1' l2)
        ([], s2:l2') -> (gitToPatches repo p Nothing (Just s2)) ++
                        (gitListToPatches repo p l1 l2')
        (s1:l1', s2:l2') | s1 `slurpySameName` s2 ->
            (gitToPatches repo p (Just s1) (Just s2)) ++
            (gitListToPatches repo p l1' l2')
        ((s1:l1'), (s2:_)) | s1 < s2 ->
            (gitToPatches repo p (Just s1) Nothing) ++
            (gitListToPatches repo p l1' l2)
        ((s1:_), (s2:l2')) | s1 > s2 ->
            (gitToPatches repo p Nothing (Just s2)) ++
            (gitListToPatches repo p l1 l2')
        _ -> impossible

gitToPatches ::
  String -> String -> (Maybe GitSlurpy) -> (Maybe GitSlurpy) -> [Patch]
gitToPatches repo prefix m1 m2 =
    case (m1, m2) of
    (Nothing, Nothing) -> impossible
    (Just a, Just b) | slurpySameContents a b -> []
    (Just a, Just b) | (slurpyIsTree a) /= (slurpyIsTree b) ->
        -- split to del + add
        (gitToPatches repo prefix m1 Nothing) ++
        (gitToPatches repo prefix Nothing m2)
    (Just a, _) | slurpyIsTree a -> gitTreeToPatches repo prefix m1 m2
    (_, Just b) | slurpyIsTree b -> gitTreeToPatches repo prefix m1 m2
    (_, _) -> gitBlobToPatches repo prefix m1 m2

gitBlobToPatches
  :: String -> String -> (Maybe GitSlurpy) -> (Maybe GitSlurpy) -> [Patch]
gitBlobToPatches _ _ m1 m2 =
    case (m1, m2) of
    (Nothing, Nothing) -> []
    (Nothing, Just _) -> (addfile name) : patches
    (Just _, Nothing) -> patches ++ [rmfile name]
    (Just _, Just _) -> patches
    where name = slurpyName $ fromMaybe (fromJust m2) m1
          f1 = contents m1
          f2 = contents m2
          patches = fileContentsToPatches name f1 f2
          contents (Just (GSF gfi)) = unsafePerformIO $
              gitFileLinesPSetc $ gitFileInfoToGitFile gfi
          contents (Just (GSF_dirty _ _ c)) = c
          contents Nothing = emptyFileContents
          contents _ = impossible

gitTreeToPatches
  :: String -> String -> (Maybe GitSlurpy) -> (Maybe GitSlurpy) -> [Patch]
gitTreeToPatches repo prefix m1 m2 =
    case (m1, m2) of
    (Nothing, Nothing) -> impossible
    (Nothing, Just _) -> (adddir name) : patches
    (Just _, Nothing) -> patches ++ [rmdir name]
    (Just _, Just _) -> patches
    where name = slurpyName $ fromMaybe (fromJust m2) m1
          ml1 = slurpyChildren `liftM` m1
          ml2 = slurpyChildren `liftM` m2
          patches = gitListToPatches repo prefix
                                     (fromMaybe [] ml1) (fromMaybe [] ml2)

fileContentsToPatches :: String -> FileContents -> FileContents -> [Patch]
fileContentsToPatches name fc1 fc2 = diff_files name fc1 fc2 []

gitCommitToPatch :: String -> GitCommit -> Maybe GitCommit -> Patch
gitCommitToPatch repo gc mgc =
    gitCommitToPatch' repo gc (slurpGitCommit repo `liftM` mgc)

gitCommitToPatch'
  :: String -> GitCommit -> Maybe GitSlurpy -> Patch
gitCommitToPatch' repo gc reference =
    let pinfo = gitCommitToPatchInfo repo gc
        slurpy = slurpGitCommit repo gc
        -- don't include addir "./"
        reference' = case reference of
                     Nothing -> Just emptyGitSlurpy
                     _ -> reference
    in NamedP pinfo []
       (join_patches (gitToPatches repo "" reference' (Just slurpy)))

applyToGitSlurpy :: Bool -> Patch -> GitSlurpy -> GitSlurpy
applyToGitSlurpy lax (NamedP _ _ p) s = applyToGitSlurpy lax p s
applyToGitSlurpy _ (ComP []) s = s
applyToGitSlurpy lax (ComP (p:ps)) s =
    applyToGitSlurpy lax (ComP ps) $ applyToGitSlurpy lax p s
applyToGitSlurpy _ (Split []) s = s
applyToGitSlurpy lax (Split (p:ps)) s =
    applyToGitSlurpy lax (Split ps) $ applyToGitSlurpy lax p s
applyToGitSlurpy _ (FP f RmFile) s = applyF (fn2fp f) False False s
applyToGitSlurpy _ (FP f AddFile) s = applyF (fn2fp f) False True s
applyToGitSlurpy _ (DP d RmDir) s = applyF (fn2fp d) True False s
applyToGitSlurpy _ (DP d AddDir) s = applyF (fn2fp d) True True s
applyToGitSlurpy _ (FP f (Hunk line o n)) s =
    gitModfile (fn2fp f) (applyHunkLines [(line, o, n)]) s
applyToGitSlurpy _ (FP f (Binary o n)) s =
    gitModfile (fn2fp f) (applyBinary o n) s
applyToGitSlurpy True p s | is_merger p =
    applyToGitSlurpy True (merger_equivalent p) s
applyToGitSlurpy _ _ _ = error "Cannot apply patch to Git slurpy."

applyF :: String -> Bool -> Bool -> GitSlurpy -> GitSlurpy
applyF f dir add (GST_dirty n m l) | isDirectPrefix n f =
    GST_dirty n m (applyF_direct f dir add l)
applyF f dir add s@(GST _ l) | isPrefix (slurpyName s) f =
    applyF f dir add (GST_dirty (slurpyName s) (slurpyMode s) l)
applyF f dir add (GST_dirty n m l) | isPrefix n f =
    GST_dirty n m (map (applyF f dir add) l)
applyF _ _ _ s = s

applyF_direct :: String -> Bool -> Bool -> [GitSlurpy] -> [GitSlurpy]
applyF_direct _ _ False [] = impossible
applyF_direct f _ False (s:ss) | slurpyName s == f = ss
applyF_direct f dir False (s:ss) = s:(applyF_direct f dir False ss)
applyF_direct f False True l =
    insert (GSF_dirty f (git_default_file_mode 0) emptyFileContents) l
applyF_direct f True True l =
    insert (GST_dirty f (git_default_file_mode 1) []) l

gitModfile :: String -> (FileContents -> Maybe FileContents) ->
              GitSlurpy -> GitSlurpy
gitModfile f p s@(GST _ l) | isPrefix (slurpyName s) f =
    gitModfile f p (GST_dirty (slurpyName s) (slurpyMode s) l)
gitModfile f p (GST_dirty n m l) | isPrefix n f =
    GST_dirty n m (map (gitModfile f p) l)
gitModfile f p s@(GSF gfi) | f == (slurpyName s) =
    gitModfile f p
        (GSF_dirty (slurpyName s) (slurpyMode s) $ unsafePerformIO $
             (gitFileLinesPSetc (gitFileInfoToGitFile gfi)))
gitModfile f p (GSF_dirty n mode c) | f == n =
    GSF_dirty n mode $ fromJust (p c)
gitModfile _ _ s = s

foreign import ccall unsafe "gitlib.h git_write_file" git_write_file
  :: CString -> CString -> CUInt -> (Ptr CChar) -> CUInt ->
     IO (Ptr GitFileInfoStruct)

foreign import ccall unsafe "gitlib.h git_write_tree_begin" git_write_tree_begin
  :: IO (Ptr CChar)

foreign import ccall unsafe "gitlib.h git_write_tree_next" git_write_tree_next
  :: (Ptr CChar) -> CString -> CUInt -> CString -> IO (CInt)

foreign import ccall unsafe "gitlib.h git_write_tree_done" git_write_tree_done
  :: (Ptr CChar) -> CString -> CUInt -> IO (Ptr GitFileInfoStruct)

writeGitFile :: String -> String -> String -> CUInt -> PackedString ->
                IO GitFileInfo
writeGitFile repo tp name mode contents =
    do p <- withCString (nopath name) $ \n ->
              withCString tp $ \t ->
                unsafeWithInternals contents $ \pc lc ->
                    git_write_file t n mode (castPtr pc) (fromIntegral lc)
       gfistruct2gfi repo p

writeGitTree :: String -> String -> CUInt -> [GitSlurpy] -> IO GitFileInfo
writeGitTree repo n m l =
    do iter <- git_write_tree_begin
       sequence_ $ map (write_tree_helper iter) l
       p <- withCString (nopath n) $
                \cn -> git_write_tree_done iter cn m
       gfistruct2gfi repo p
    where write_tree_helper iter (GST gfi _) =
              withCString (nopath $ unpackPS $ gfi_name gfi) $ \cn ->
              withCStringPS (gfi_sha1 gfi) $ \s ->
                  git_write_tree_next iter cn (gfi_mode gfi) s
          write_tree_helper iter (GSF gfi) =
              withCString (nopath $ unpackPS $ gfi_name gfi) $ \cn ->
              withCStringPS (gfi_sha1 gfi) $ \s ->
                  git_write_tree_next iter cn (gfi_mode gfi) s
          write_tree_helper _ _ = impossible

purifyGitSlurpy :: String -> GitSlurpy -> IO GitSlurpy
purifyGitSlurpy _ s@(GST _ _) = return s
purifyGitSlurpy _ s@(GSF _) = return s
purifyGitSlurpy repo (GSF_dirty n m (cl, mc)) =
    do gfi <- writeGitFile repo "blob" n m (fromMaybe (unlinesPS cl) mc)
       return $ GSF gfi
purifyGitSlurpy repo (GST_dirty n m l) =
    do l' <- mapM (purifyGitSlurpy repo) l
       gfi <- writeGitTree repo n m l'
       return $ GST gfi l'

butlast :: [a] -> [a]
butlast [] = impossible
butlast [_] = []
butlast (h:t) = h : (butlast t)

parseGitCommitter :: String -> Maybe String
parseGitCommitter s =
   let (a, b) = splitAt (length gitCommitterHeader) s
   in if (a == gitCommitterHeader)
      then Just b
      else Nothing

writeGitCommit :: PatchInfo -> GitSlurpy -> String -> IO (String)
writeGitCommit pinfo s parent =
    do tree <- case s of (GST gfi _) -> return (unpackPS $ gfi_sha1 gfi)
                         (GSF _) -> fail "Cannot commit non-tree."
                         _ -> fail "Cannot commit impure slurpy."
       let (date, author, loglines) =
               let (PatchInfo ct name auth l _) = pinfo
               in ((show $ formatGitTime $ unpackPS ct) ++
                   " +0000",
                   (unpackPS auth),
                   (unpackPS name) : (map unpackPS l))
       let (committer, lg) =
               let mc = parseGitCommitter (last loglines)
               in case mc of
                   (Just c) -> (c, unlines (butlast loglines))
                   Nothing -> (author, unlines loglines)
       commit <- writeGitFile "" "commit" "" 0 $
                     packString $
                         "tree " ++ tree ++ "\n" ++
                         "parent " ++ parent ++ "\n" ++
                         "author " ++ author ++ " " ++ date ++ "\n" ++
                         "committer " ++ committer ++ " " ++ date ++ "\n" ++
                         "\n" ++ lg
       return $ unpackPS $ gfi_sha1 commit

updateHead :: String -> String -> IO ()
updateHead h s = do rc <- withCString (".git/" ++ h) $ \ch ->
                             withCString s $ \cs ->
                                 git_update_head ch cs
                    when (rc < 0) $ fail "Couldn't update Git head"
                    return ()
\end{code}