From 5c0d162a1a6b2476cebc44f26eb3f4be22c821cb Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 24 Sep 2023 23:37:09 +0100 Subject: [PATCH] format with ormolu --- package.yaml | 1 + src/Simplex/Chat/MarkdownDiff.hs | 179 +++++++++++++++---------------- 2 files changed, 87 insertions(+), 93 deletions(-) diff --git a/package.yaml b/package.yaml index ff88ec5c5d..abc30115ee 100644 --- a/package.yaml +++ b/package.yaml @@ -32,6 +32,7 @@ dependencies: - http-types == 0.12.* - memory == 0.18.* - mtl == 2.3.* + - myers-diff >= 0.2.0.0 - network >= 3.1.2.7 && < 3.2 - optparse-applicative >= 0.15 && < 0.17 - process == 1.6.* diff --git a/src/Simplex/Chat/MarkdownDiff.hs b/src/Simplex/Chat/MarkdownDiff.hs index c3cbf9e7c4..851f312f3e 100644 --- a/src/Simplex/Chat/MarkdownDiff.hs +++ b/src/Simplex/Chat/MarkdownDiff.hs @@ -4,162 +4,155 @@ {-# HLINT ignore "Use newtype instead of data" #-} - module Simplex.Chat.MarkdownDiff - ( DiffChar(..) - , DiffPlainChar(..) - , DiffStatus(..) - , DiffPlainStatus(..) - , DiffFormatStatus(..) - , FormatChar(..) - , LeftSide(..) - , RightSide(..) - , diff - , plainDiff - ) - where - + ( DiffChar (..), + DiffPlainChar (..), + DiffStatus (..), + DiffPlainStatus (..), + DiffFormatStatus (..), + FormatChar (..), + LeftSide (..), + RightSide (..), + diff, + plainDiff, + ) +where +import qualified Data.Diff.Myers as D import qualified Data.Foldable as F -import Data.Function ((&)) +import Data.Function ((&)) import qualified Data.Map.Strict as M -import Data.Sequence (Seq(..), (><)) +import Data.Sequence (Seq (..), (><)) import qualified Data.Sequence as S import qualified Data.Text as T -import qualified Data.Diff.Myers as D -import Simplex.Chat.Markdown (Format) - - -data DiffStatus - = UnchangedChar DiffFormatStatus - | Inserted - | Deleted - deriving (Show, Eq) +import Simplex.Chat.Markdown (Format) +data DiffStatus + = UnchangedChar DiffFormatStatus + | Inserted + | Deleted + deriving (Show, Eq) data DiffPlainStatus - = UnchangedP - | InsertedP - | DeletedP - deriving (Show, Eq) - + = UnchangedP + | InsertedP + | DeletedP + deriving (Show, Eq) data DiffFormatStatus - = UnchangedFormat - | ChangedToFormat (Maybe Format) - deriving (Show, Eq) - + = UnchangedFormat + | ChangedToFormat (Maybe Format) + deriving (Show, Eq) data DiffChar = DiffChar FormatChar DiffStatus - deriving (Show, Eq) - + deriving (Show, Eq) data DiffPlainChar = DiffPlainChar Char DiffPlainStatus - deriving (Show, Eq) + deriving (Show, Eq) +data FormatChar = FormatChar + { char :: Char, + format :: Maybe Format + } + deriving (Show, Eq) -data FormatChar = FormatChar - { char :: Char - , format :: Maybe Format - } - deriving (Show, Eq) +newtype LeftSide a = LeftSide a deriving (Show, Eq) - -newtype LeftSide a = LeftSide a deriving (Show, Eq) newtype RightSide a = RightSide a deriving (Show, Eq) - newtype DeleteIndicies = DeleteIndicies (Seq Int) deriving (Show, Eq) -newtype InsertIndicies = InsertIndicies (Seq Int) deriving (Show, Eq) +newtype InsertIndicies = InsertIndicies (Seq Int) deriving (Show, Eq) plainDiff :: LeftSide T.Text -> RightSide T.Text -> Seq DiffPlainChar plainDiff (LeftSide left) (RightSide right) = toPlain <$> formattedDiff - where + where formattedDiff = diff (LeftSide $ toFormatted left) (RightSide $ toFormatted right) toPlain :: DiffChar -> DiffPlainChar toPlain (DiffChar (FormatChar c _) diffStatus) = DiffPlainChar c diffStatusPlain - where + where diffStatusPlain = case diffStatus of - UnchangedChar _ -> UnchangedP - Inserted -> InsertedP - Deleted -> DeletedP + UnchangedChar _ -> UnchangedP + Inserted -> InsertedP + Deleted -> DeletedP toFormatted :: T.Text -> Seq FormatChar - toFormatted = fmap (`FormatChar` Nothing) . S.fromList . T.unpack - + toFormatted = fmap (`FormatChar` Nothing) . S.fromList . T.unpack diff :: LeftSide (Seq FormatChar) -> RightSide (Seq FormatChar) -> Seq DiffChar diff (LeftSide left) (RightSide right) = addInserts markDeletesAndUnchangedChars - where - edits = D.diffTexts (toText left) (toText right) - (DeleteIndicies deleteIndicies, InsertIndicies insertIndicies) = indices - + where + edits = D.diffTexts (toText left) (toText right) + (DeleteIndicies deleteIndicies, InsertIndicies insertIndicies) = indices + toText :: Seq FormatChar -> T.Text - toText = T.pack . F.toList . fmap char + toText = T.pack . F.toList . fmap char indices :: (DeleteIndicies, InsertIndicies) indices = F.foldl' f (DeleteIndicies S.empty, InsertIndicies S.empty) edits - where + where f :: (DeleteIndicies, InsertIndicies) -> D.Edit -> (DeleteIndicies, InsertIndicies) f (x@(DeleteIndicies ds), y@(InsertIndicies is)) e = case e of - D.EditDelete m n -> (x', y) where x' = DeleteIndicies $ ds >< S.fromList [m .. n] - D.EditInsert _ m n -> (x , y') where y' = InsertIndicies $ is >< S.fromList [m .. n] + D.EditDelete m n -> (x', y) where x' = DeleteIndicies $ ds >< S.fromList [m .. n] + D.EditInsert _ m n -> (x, y') where y' = InsertIndicies $ is >< S.fromList [m .. n] unchangedChars :: M.Map Int DiffFormatStatus -- indexed in left unchangedChars = F.foldl' f mempty unchangedCharPairs - where - unchangedCharPairs :: Seq (Int, FormatChar, FormatChar) + where + unchangedCharPairs :: Seq (Int, FormatChar, FormatChar) unchangedCharPairs = g <$> S.zip leftWithoutDeletes rightWithoutInserts - leftWithoutDeletes :: Seq (Int, FormatChar) - leftWithoutDeletes = - left + leftWithoutDeletes :: Seq (Int, FormatChar) + leftWithoutDeletes = + left & S.zip (S.fromList [0 .. S.length left - 1]) & S.filter (\(i, _) -> i `notElem` deleteIndicies) - rightWithoutInserts :: Seq (Int, FormatChar) - rightWithoutInserts = - right + rightWithoutInserts :: Seq (Int, FormatChar) + rightWithoutInserts = + right & S.zip (S.fromList [0 .. S.length right - 1]) & S.filter (\(i, _) -> i `notElem` insertIndicies) f :: M.Map Int DiffFormatStatus -> (Int, FormatChar, FormatChar) -> M.Map Int DiffFormatStatus f acc (i, FormatChar _ fL, FormatChar _ fR) = M.insert i x acc - where x = if fL == fR then UnchangedFormat else ChangedToFormat fR + where + x = if fL == fR then UnchangedFormat else ChangedToFormat fR g :: ((Int, FormatChar), (Int, FormatChar)) -> (Int, FormatChar, FormatChar) - g ((i,c), (_,d)) = (i,c,d) + g ((i, c), (_, d)) = (i, c, d) markDeletesAndUnchangedChars :: Seq DiffChar markDeletesAndUnchangedChars = S.mapWithIndex f left - where + where f :: Int -> FormatChar -> DiffChar - f i x = DiffChar x $ - if i `elem` deleteIndicies then Deleted - else UnchangedChar $ unchangedChars M.! i -- should never error - + f i x = + DiffChar x $ + if i `elem` deleteIndicies + then Deleted + else UnchangedChar $ unchangedChars M.! i -- should never error addInserts :: Seq DiffChar -> Seq DiffChar addInserts base = F.foldr f base edits -- start from end and work backwards, hence foldr - where + where f :: D.Edit -> Seq DiffChar -> Seq DiffChar f e acc = case e of - D.EditDelete _ _ -> acc - D.EditInsert i m n -> S.take i' acc >< inserts >< S.drop i' acc - -- D.EditInsert i m n -> S.take i acc >< inserts >< S.drop i acc - -- if ok to have inserts before deletes, use i not i' - -- Using i of course is faster, but perhaps i' approach can be optimised - - where - i' = slidePastDeleteBlock i + D.EditDelete _ _ -> acc + D.EditInsert i m n -> S.take i' acc >< inserts >< S.drop i' acc + where + -- D.EditInsert i m n -> S.take i acc >< inserts >< S.drop i acc + -- if ok to have inserts before deletes, use i not i' + -- Using i of course is faster, but perhaps i' approach can be optimised - slidePastDeleteBlock :: Int -> Int - slidePastDeleteBlock x = case S.lookup x acc of - Nothing -> x - Just (DiffChar _ diffStatus) -> - if diffStatus == Deleted then slidePastDeleteBlock (x + 1) - else x + i' = slidePastDeleteBlock i - rightFormatChars = S.take (n - m + 1) $ S.drop m right - inserts = fmap (`DiffChar` Inserted) rightFormatChars \ No newline at end of file + slidePastDeleteBlock :: Int -> Int + slidePastDeleteBlock x = case S.lookup x acc of + Nothing -> x + Just (DiffChar _ diffStatus) -> + if diffStatus == Deleted + then slidePastDeleteBlock (x + 1) + else x + + rightFormatChars = S.take (n - m + 1) $ S.drop m right + inserts = fmap (`DiffChar` Inserted) rightFormatChars