src/Types.hs Modified

@@ -81,7 +81,7 @@
 -}
 data Commit = Commit
     { commitGit :: Git.Commit LgRepo
-    , commitDiffs :: [Git.Diff]
+    , commitDiffs :: [Diff]
     }
 
 instance ToGVal m Commit where
@@ -118,36 +118,63 @@
 - Each diff has 1 or more hunks
 - Each hunk has a number of lines
 -}
-instance ToGVal m Git.Diff where
-    toGVal :: Git.Diff -> GVal m
+data Diff = Diff
+    { diffNewFile :: Git.TreeFilePath
+    , diffOldFile :: Maybe Git.TreeFilePath
+    , diffStatus :: Delta
+    , diffHunks :: [Hunk]
+    }
+
+data Delta
+    = Unmodified
+    | Added
+    | Deleted
+    | Modified
+    | Renamed
+    | Copied
+    | Ignored
+    | Untracked
+    | Typechange
+    deriving stock (Eq, Ord, Enum, Show)
+
+type HunkHeader = ByteString
+type DiffLine = ByteString
+
+data Hunk = Hunk
+    { hunkHeader :: HunkHeader
+    , hunkLines :: [DiffLine]
+    }
+
+instance ToGVal m Diff where
+    toGVal :: Diff -> GVal m
     toGVal diff =
         def
-            { asHtml = html . bsToText . Git.diffNewFile $ diff
-            , asText = bsToText . Git.diffNewFile $ diff
+            { asHtml = html . bsToText . diffNewFile $ diff
+            , asText = bsToText . diffNewFile $ diff
             , asLookup = Just . diffAsLookup $ diff
             }
 
-diffAsLookup :: Git.Diff -> Text -> Maybe (GVal m)
+diffAsLookup :: Diff -> Text -> Maybe (GVal m)
 diffAsLookup diff = \case
-    "new_file" -> Just . toGVal . Git.diffNewFile $ diff
-    "old_file" -> toGVal <$> Git.diffOldFile diff
-    "status" -> Just . toGVal . drop 5 . show . Git.diffStatus $ diff
-    "hunks" -> Just . toGVal . Git.diffHunks $ diff
+    "new_file" -> Just . toGVal . diffNewFile $ diff
+    "old_file" -> toGVal <$> diffOldFile diff
+    "status" -> Just . toGVal . show . diffStatus $ diff
+    "hunks" -> Just . toGVal . diffHunks $ diff
     _ -> Nothing
 
-instance ToGVal m Git.Hunk where
-    toGVal :: Git.Hunk -> GVal m
+instance ToGVal m Hunk where
+    toGVal :: Hunk -> GVal m
     toGVal hunk =
         def
-            { asHtml = html . bsToText . Git.hunkHeader $ hunk
-            , asText = bsToText . Git.hunkHeader $ hunk
+            { asHtml = html . bsToText . hunkHeader $ hunk
+            , asText = bsToText . hunkHeader $ hunk
             , asLookup = Just . hunkAsLookup $ hunk
             }
 
-hunkAsLookup :: Git.Hunk -> Text -> Maybe (GVal m)
+hunkAsLookup :: Hunk -> Text -> Maybe (GVal m)
 hunkAsLookup hunk = \case
-    "lines" -> Just . toGVal . fmap makeLine . Git.hunkLines $ hunk
-    "header" -> Just . toGVal . bsToText . Git.hunkHeader $ hunk
+    "lines" -> Just . toGVal . fmap makeLine . hunkLines $ hunk
+    "header" -> Just . toGVal . bsToText . hunkHeader $ hunk
     _ -> Nothing
 
 {-
@@ -160,7 +187,7 @@
     , lineClass :: String
     }
 
-makeLine :: Git.DiffLine -> Line
+makeLine :: DiffLine -> Line
 makeLine line = Line text (cls . T.head $ text)
   where
     text = bsToText line

src/Repositories.hs Modified

@@ -9,22 +9,30 @@
     run,
 ) where
 
+import qualified Bindings.Libgit2 as LG
 import Conduit (runConduit, sinkList, (.|))
 import Control.Exception (try)
 import Control.Monad (filterM, unless, when, (<=<))
 import Control.Monad.Extra (ifM)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Reader (ReaderT)
+import Data.Bool (bool)
+import qualified Data.ByteString as B
 import Data.Either (isRight)
 import qualified Data.HashMap.Strict as HashMap
+import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)
 import Data.Maybe (catMaybes, fromJust, listToMaybe, mapMaybe)
 import Data.Tagged (Tagged (..), untag)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Data.Text.Encoding.Error as T
+import Foreign.C.String (CString)
+import Foreign.C.Types (CChar, CFloat, CInt, CSize)
+import Foreign.Ptr (Ptr)
+import Foreign.Storable (peek)
 import qualified Git
-import Git.Libgit2 (LgRepo, lgFactory)
+import Git.Libgit2 (LgRepo, lgDiffTreeToTree, lgFactory)
 import Path (Abs, Dir, File, Path, Rel, dirname, parseRelDir, parseRelFile, toFilePath, (</>))
 import Path.IO (doesFileExist, ensureDir)
 import qualified System.Directory as D
@@ -194,8 +202,79 @@
             Nothing ->
                 return Nothing
 
-    diffs <- Git.diffTreeToTree oldTree (Just newTree)
-    return $ Commit gitCommit diffs
+    ioref <- liftIO . newIORef $ []
+    lgDiffTreeToTree
+        (fileCallback ioref)
+        (hunkCallback ioref)
+        (dataCallback ioref)
+        oldTree
+        (Just newTree)
+    diffs <- liftIO . readIORef $ ioref
+
+    return . Commit gitCommit . fmap fixupLists $ diffs
+  where
+    fileCallback ::
+        IORef [Diff] ->
+        Ptr LG.C'git_diff_delta ->
+        CFloat ->
+        Ptr () ->
+        IO CInt
+    fileCallback ioref dPtr _progress _payload = do
+        delta <- peek dPtr
+        newFile <- B.packCString . LG.c'git_diff_file'path . LG.c'git_diff_delta'new_file $ delta
+        oldFile <- B.packCString . LG.c'git_diff_file'path . LG.c'git_diff_delta'old_file $ delta
+        let oldFile' = bool Nothing (Just oldFile) (newFile /= oldFile)
+            status = toEnum . fromIntegral . LG.c'git_diff_delta'status $ delta
+            diff = Diff newFile oldFile' status []
+        modifyIORef ioref (diff :)
+        return 0
+
+    hunkCallback ::
+        IORef [Diff] ->
+        Ptr LG.C'git_diff_delta ->
+        Ptr LG.C'git_diff_range ->
+        CString ->
+        CSize ->
+        Ptr () ->
+        IO CInt
+    hunkCallback ioref _dPtr _range header headerLen _payload = do
+        (cur : _, rest) <- splitAt 1 <$> readIORef ioref
+        bs <- curry B.packCStringLen header (fromIntegral headerLen)
+        let hunk = Hunk bs []
+        writeIORef ioref $ cur{diffHunks = hunk : diffHunks cur} : rest
+        return 0
+
+    dataCallback ::
+        IORef [Diff] ->
+        Ptr LG.C'git_diff_delta ->
+        Ptr LG.C'git_diff_range ->
+        CChar ->
+        CString ->
+        CSize ->
+        Ptr () ->
+        IO CInt
+    dataCallback ioref _dPtr _range lineOrigin content contentLen _payload = do
+        bs <- curry B.packCStringLen content (fromIntegral contentLen)
+        let bs' = B.cons (fromIntegral lineOrigin) bs
+        (cur : _, rest) <- splitAt 1 <$> readIORef ioref
+        let (curHunk : _, restHunks) = splitAt 1 . diffHunks $ cur
+        let updated =
+                cur
+                    { diffHunks =
+                        curHunk
+                            { hunkLines = bs' : hunkLines curHunk
+                            } :
+                        restHunks
+                    }
+        writeIORef ioref $ updated : rest
+        return 0
+
+    -- The callbacks prepend and then we put the lists the right way round here.
+    -- This avoids traversing the lists every time we add an item.
+    fixupLists :: Diff -> Diff
+    fixupLists diff = diff{diffHunks = fmap fixupLines . reverse . diffHunks $ diff}
+      where
+        fixupLines hunk = hunk{hunkLines = reverse . hunkLines $ hunk}
 
 {-
 Collect tree information for the given commit. Recurses on directories to list their