From 13bd369de34ce074cb0f04d270439362c16ce086 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Mon, 9 Jul 2018 19:12:11 +0000
Subject: [PATCH] Darcs patch reader: Join adjacent remove-add sequences like
in the Git module
---
src/Data/List/Local.hs | 45 +++++++++++++++++++++++++++++++-
src/Vervis/Darcs.hs | 58 +++++++++++++++++++++++++-----------------
2 files changed, 78 insertions(+), 25 deletions(-)
diff --git a/src/Data/List/Local.hs b/src/Data/List/Local.hs
index e7d5555..14eb7c7 100644
--- a/src/Data/List/Local.hs
+++ b/src/Data/List/Local.hs
@@ -17,12 +17,17 @@ module Data.List.Local
( -- groupByFst
groupJusts
, groupEithers
+ , groupPairs
+ , groupMap
+ , groupMapBy
+ , groupMapBy1
)
where
import Prelude
-import Data.List.NonEmpty (NonEmpty (..), (<|))
+import Data.Function (on)
+import Data.List.NonEmpty (NonEmpty (..), (<|), toList)
-- | Takes a list of pairs and groups them by consecutive ranges with equal
-- first element. Returns a list of pairs, where each pair corresponds to one
@@ -54,3 +59,41 @@ groupEithers = foldr go ([], [], [])
go (Left x) ([] , (xs, ys):ps, as) = ([], (x <| xs, ys) : ps , as)
go (Left x) (b:bs, ps , as) = ([], (x :| [], b :| bs) : ps, as)
go (Right y) (bs, ps, as) = (y : bs, ps, as)
+
+groupPairs
+ :: Foldable f => f ([a], [b]) -> ([b], [(NonEmpty a, NonEmpty b)], [a])
+groupPairs = groupEithers . foldr go []
+ where
+ go (xs, ys) es = map Left xs ++ map Right ys ++ es
+
+-- | @groupMap f g l@ groups elements like 'group', except it compares them by
+-- applying @f@ to elements and comparing these values using the 'Eq' instance.
+-- It then maps the elements in each such equality group using @g@.
+--
+-- >>> groupMap fst snd [(1, 5), (1, 6), (2, 7), (2, 8), (2, 9)]
+-- [(1, [5, 6]), (2, [7, 8, 9])]
+groupMap :: Eq b => (a -> b) -> (a -> c) -> [a] -> [(b, NonEmpty c)]
+groupMap f = groupMapBy ((==) `on` f) f
+
+-- | Like 'groupMap', except it uses a comparison predicate instead of an 'Eq'
+-- instance.
+groupMapBy
+ :: (a -> a -> Bool) -> (a -> b) -> (a -> c) -> [a] -> [(b, NonEmpty c)]
+groupMapBy _ _ _ [] = []
+groupMapBy eq f g (x:xs) = toList $ groupMapBy1 eq f g $ x :| xs
+
+-- | Like 'groupMapBy1', but takes and returns a 'NonEmpty'.
+groupMapBy1
+ :: (a -> a -> Bool)
+ -> (a -> b)
+ -> (a -> c)
+ -> NonEmpty a
+ -> NonEmpty (b, NonEmpty c)
+groupMapBy1 eq f g = go
+ where
+ go (x :| xs) =
+ let (ys, zs) = span (eq x) xs
+ rest = case zs of
+ [] -> []
+ z:l -> toList $ go $ z :| l
+ in (f x, g x :| map g ys) :| rest
diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs
index 52cebaf..f07b91d 100644
--- a/src/Vervis/Darcs.hs
+++ b/src/Vervis/Darcs.hs
@@ -25,12 +25,14 @@ where
import Prelude hiding (lookup)
import Control.Applicative ((<|>))
+import Control.Arrow (second)
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.Bool (bool)
+import Data.ByteString (ByteString)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (listToMaybe, mapMaybe, fromMaybe)
import Data.Text (Text)
@@ -51,6 +53,7 @@ import qualified Data.Attoparsec.Text as A
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.Vector as V (empty)
import qualified Development.Darcs.Internal.Patch.Parser as P
@@ -58,8 +61,10 @@ import qualified Development.Darcs.Internal.Patch.Parser as P
import Darcs.Local.Repository
import Data.Either.Local (maybeRight)
import Data.EventTime.Local
+import Data.List.Local
import Data.Text.UTF8.Local (decodeStrict)
import Data.Time.Clock.Local ()
+
import Vervis.Changes
import Vervis.Foundation (Widget)
import Vervis.Patch
@@ -227,6 +232,31 @@ lastChange path now = fmap maybeRight $ runExceptT $ do
FriendlyConvert $
now `diffUTCTime` piTime pi
+-- | 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
+ where
+ rest h = (P.hunkLine h, P.hunkRemove h, P.hunkAdd h)
+
+-- | Find groups of consecutive sequences of removes and adds, and turn each
+-- such group into a single hunk. This may not actually be necessary, because
+-- the small consecutive hunks would be joined later anyway when adding context
+-- lines, but I'm still doing this here for consistency. In the "Vervis.Git"
+-- module, the hunks are joined like this too.
+joinHunks
+ :: NonEmpty (Int, [ByteString], [ByteString])
+ -> NonEmpty (Bool, Int, Hunk)
+joinHunks =
+ N.map (mkHunk . second groupPairs) .
+ groupMapBy1 consecutive lineNumber lines
+ where
+ consecutive (n1, r1, _) (n2, _, _) = n1 + length r1 == n2
+ lineNumber (n, _, _) = n
+ lines (_, rs, as) = (map decodeUtf8 rs, map decodeUtf8 as)
+ mkHunk (line, (adds, pairs, rems)) = (False, line, Hunk adds pairs rems)
+
-- | Read patch content, both metadata and the actual diff, from a given Darcs
-- repository. Preconditions:
--
@@ -252,7 +282,8 @@ readPatch path hash = do
, patchTime = piTime pi
, patchTitle = piTitle pi
, patchDescription = fromMaybe "" $ piDescription pi
- , patchDiff = map mkedit hunks
+ , patchDiff =
+ map (mkedit . second joinHunks) $ groupHunksByFile hunks
}
where
handle = either (const $ fail "readPatch failed") pure
@@ -274,26 +305,5 @@ readPatch path hash = do
<* " <"
<*> (A.takeWhile1 (/= '>') >>= email)
<* A.skip (== '>')
- mkhunk h = case P.hunkRemove h of
- [] -> Hunk
- { hunkAddFirst = map decodeUtf8 $ P.hunkAdd h
- , hunkRemoveAdd = []
- , hunkRemoveLast = []
- }
- r:rs -> case P.hunkAdd h of
- [] -> Hunk
- { hunkAddFirst = []
- , hunkRemoveAdd = []
- , hunkRemoveLast = map decodeUtf8 $ r : rs
- }
- a:as -> Hunk
- { hunkAddFirst = []
- , hunkRemoveAdd = [(decodeUtf8 <$> r :| rs, decodeUtf8 <$> a :| as)]
- , hunkRemoveLast = []
- }
- mkedit hunk =
- EditTextFile
- (T.unpack $ decodeUtf8 $ P.hunkFile hunk)
- V.empty
- ((False, P.hunkLine hunk, mkhunk hunk) :| [])
- 0 0
+ mkedit (file, hunks) =
+ EditTextFile (T.unpack $ decodeUtf8 file) V.empty hunks 0 0