From b95e9a8006b3ff134f21ef70ad36dc264a45e863 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 31 Oct 2019 10:11:13 +0000 Subject: [PATCH] Weird initial (but complete) display of Darcs patches --- src/Data/List/NonEmpty/Local.hs | 9 +++++ src/Vervis/Darcs.hs | 66 +++++++++++++++++++++++++++------ 2 files changed, 64 insertions(+), 11 deletions(-) diff --git a/src/Data/List/NonEmpty/Local.hs b/src/Data/List/NonEmpty/Local.hs index 7dce6f0..d5e7b07 100644 --- a/src/Data/List/NonEmpty/Local.hs +++ b/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) diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index 3093bbb..e3b17ca 100644 --- a/src/Vervis/Darcs.hs +++ 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) = - EditTextFile (T.unpack $ decodeUtf8 file) V.empty hunks 0 0 + 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