Weird initial (but complete) display of Darcs patches

src/Data/List/NonEmpty/Local.hs

@@ -16,6 +16,7 @@
 module Data.List.NonEmpty.Local
     ( groupWithExtract
     , groupWithExtractBy
+    , groupWithExtract1
     , groupWithExtractBy1
     , groupAllExtract
     , unionGroupsOrdWith
@@ -50,6 +51,14 @@ groupWithExtractBy
     -> [(b, NonEmpty c)]
 groupWithExtractBy eq f g = map (extract f g) . NE.groupBy (eq `on` f)
 
+groupWithExtract1
+    :: Eq b
+    => (a -> b)
+    -> (a -> c)
+    -> NonEmpty a
+    -> NonEmpty (b, NonEmpty c)
+groupWithExtract1 f g = NE.map (extract f g) . NE.groupWith1 f
+
 groupWithExtractBy1
     :: (b -> b -> Bool)
     -> (a -> b)

src/Vervis/Darcs.hs

@@ -26,17 +26,17 @@ where
 import Prelude hiding (lookup)
 
 import Control.Applicative ((<|>))
-import Control.Arrow (second)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
 import Darcs.Util.Path
 import Darcs.Util.Tree
 import Darcs.Util.Tree.Hashed
+import Data.Bifunctor
 import Data.Bool (bool)
 import Data.ByteString (ByteString)
 import Data.Foldable hiding (find)
-import Data.List.NonEmpty (NonEmpty (..))
+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import Data.Maybe (listToMaybe, mapMaybe, fromMaybe)
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8With, decodeUtf8)
@@ -53,11 +53,12 @@ import System.FilePath ((</>))
 import Text.Email.Validate (emailAddress)
 
 import qualified Data.Attoparsec.Text as A
+import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL (ByteString)
 import qualified Data.ByteString.Base16 as B16 (encode, decode)
 import qualified Data.Foldable as F (find)
-import qualified Data.List.NonEmpty as N
-import qualified Data.Text as T (unpack, takeWhile, stripEnd)
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Text as T
 import qualified Data.Vector as V (empty)
 import qualified Database.Esqueleto as E
 
@@ -71,6 +72,7 @@ import Darcs.Local.Repository
 import Data.Either.Local (maybeRight)
 import Data.EventTime.Local
 import Data.List.Local
+import Data.List.NonEmpty.Local
 import Data.Text.UTF8.Local (decodeStrict)
 import Data.Time.Clock.Local ()
 
@@ -246,11 +248,37 @@ lastChange path now = fmap maybeRight $ runExceptT $ do
             FriendlyConvert $
             now `diffUTCTime` piTime pi
 
+data Change
+    = AddFile FilePath
+    | AddDir FilePath
+    | Move FilePath FilePath
+    | RemoveFile FilePath
+    | RemoveDir FilePath
+    | Replace FilePath Text Text Text
+    | Binary FilePath ByteString ByteString
+    | Pref Text Text Text
+
+splitChange :: P.Change -> Either P.Hunk Change
+splitChange = f
+    where
+    text = decodeUtf8
+    path = T.unpack . text
+    f (P.EditFile h)          = Left h
+    f (P.AddFile p)           = Right $ AddFile (path p)
+    f (P.AddDir p)            = Right $ AddDir (path p)
+    f (P.Move old new)        = Right $ Move (path old) (path new)
+    f (P.RemoveFile p)        = Right $ RemoveFile (path p)
+    f (P.RemoveDir p)         = Right $ RemoveDir (path p)
+    f (P.Replace p r old new) = Right $ Replace (path p) (text r) (text old) (text new)
+    f (P.Binary p old new)    = Right $ Binary (path p) old new
+    f (P.Pref pref old new)   = Right $ Pref (text pref) (text old) (text new)
+
 -- | Group hunks by filename, assuming all the hunks for a given file are
 -- placed together in the patch file, and in increasing line number order.
 groupHunksByFile
-    :: [P.Hunk] -> [(ByteString, NonEmpty (Int, [ByteString], [ByteString]))]
-groupHunksByFile = groupMap P.hunkFile rest
+    :: NonEmpty (P.Hunk)
+    -> NonEmpty (ByteString, NonEmpty (Int, [ByteString], [ByteString]))
+groupHunksByFile = groupWithExtract1 P.hunkFile rest
     where
     rest h = (P.hunkLine h, P.hunkRemove h, P.hunkAdd h)
 
@@ -263,7 +291,7 @@ joinHunks
     :: NonEmpty (Int, [ByteString], [ByteString])
     -> NonEmpty (Bool, Int, Hunk)
 joinHunks =
-    N.map (mkHunk . second groupPairs) .
+    NE.map (mkHunk . second groupPairs) .
     groupMapBy1 consecutive lineNumber lines
   where
     consecutive (n1, r1, _) (n2, _, _) = n1 + length r1 == n2
@@ -287,7 +315,7 @@ readPatch path hash = handle $ runExceptT $ do
     li <- ExceptT $ readLatestInventory path latestInventoryAllP
     mp <- loop pih (liPatches li) (fst <$> liPrevTag li)
     for mp $ \ (pi, pch) -> do
-        (_pir, hunks) <-
+        (_pir, changes) <-
             ExceptT $ readCompressedPatch path pch (P.patch <* A.endOfInput)
         (an, ae) <-
             ExceptT . pure $ A.parseOnly (author <* A.endOfInput) $ piAuthor pi
@@ -303,7 +331,11 @@ readPatch path hash = handle $ runExceptT $ do
             , patchTitle       = piTitle pi
             , patchDescription = fromMaybe "" $ piDescription pi
             , patchDiff        =
-                map (mkedit . second joinHunks) $ groupHunksByFile hunks
+                let (befores, pairs, afters) = groupEithers $ map splitChange changes
+                    befores' = mkedit befores
+                    pairs' = map (bimap arrangeHunks mkedit) pairs
+                    afters' = arrangeHunks <$> nonEmpty afters
+                in  befores' ++ concatMap (NE.toList . uncurry (<>)) pairs' ++ maybe [] NE.toList afters'
             }
   where
     handle a = do
@@ -329,8 +361,20 @@ readPatch path hash = handle $ runExceptT $ do
         <*  A.skip (== '<')
         <*> (A.takeWhile1 (/= '>') >>= email)
         <*  A.skip (== '>')
-    mkedit (file, hunks) =
+    arrangeHunks = NE.map (mkhunk . second joinHunks) . groupHunksByFile
+        where
+        mkhunk (file, hunks) =
             EditTextFile (T.unpack $ decodeUtf8 file) V.empty hunks 0 0
+    mkedit = fmap mkedit'
+        where
+        mkedit' (AddFile fp)               = AddTextFile fp 0 []
+        mkedit' (AddDir fp)                = AddTextFile fp 0 []
+        mkedit' (Move old new)             = MoveFile old 0 new 0
+        mkedit' (RemoveFile fp)            = RemoveTextFile fp 0 []
+        mkedit' (RemoveDir fp)             = RemoveTextFile fp 0 []
+        mkedit' (Replace fp regex old new) = AddTextFile "Replace" 0 [T.concat ["replace ", T.pack fp, " ", regex, " ", old, " ", new]]
+        mkedit' (Binary fp old new)        = EditBinaryFile fp (fromIntegral $ B.length old) 0 (fromIntegral $ B.length new) 0
+        mkedit' (Pref pref old new)        = AddTextFile "Pref" 0 [T.concat ["changepref ", pref, " ", old, " ", new]]
 
 writePostApplyHooks :: WorkerDB ()
 writePostApplyHooks = do