diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 3d3ae34f7d..64806c8260 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -34,6 +34,7 @@ library Simplex.Chat.Core Simplex.Chat.Help Simplex.Chat.Markdown + Simplex.Chat.MarkdownDiff Simplex.Chat.Messages Simplex.Chat.Messages.CIContent Simplex.Chat.Migrations.M20220101_initial @@ -164,6 +165,7 @@ library , 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.* @@ -212,6 +214,7 @@ executable simplex-bot , 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.* @@ -261,6 +264,7 @@ executable simplex-bot-advanced , 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.* @@ -312,6 +316,7 @@ executable simplex-broadcast-bot , 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.* @@ -362,6 +367,7 @@ executable simplex-chat , http-types ==0.12.* , memory ==0.18.* , mtl ==2.3.* + , myers-diff >= 0.2.0.0 , network ==3.1.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* @@ -452,6 +458,7 @@ test-suite simplex-chat-test ChatTests.Profiles ChatTests.Utils MarkdownTests + MarkdownDiffTests MobileTests ProtocolTests SchemaDump @@ -491,6 +498,7 @@ test-suite simplex-chat-test , http-types ==0.12.* , memory ==0.18.* , mtl ==2.3.* + , myers-diff >= 0.2.0.0 , network ==3.1.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* diff --git a/src/Simplex/Chat/MarkdownDiff.hs b/src/Simplex/Chat/MarkdownDiff.hs new file mode 100644 index 0000000000..c3cbf9e7c4 --- /dev/null +++ b/src/Simplex/Chat/MarkdownDiff.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use newtype instead of data" #-} + + +module Simplex.Chat.MarkdownDiff + ( DiffChar(..) + , DiffPlainChar(..) + , DiffStatus(..) + , DiffPlainStatus(..) + , DiffFormatStatus(..) + , FormatChar(..) + , LeftSide(..) + , RightSide(..) + , diff + , plainDiff + ) + where + + +import qualified Data.Foldable as F +import Data.Function ((&)) +import qualified Data.Map.Strict as M +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) + + +data DiffPlainStatus + = UnchangedP + | InsertedP + | DeletedP + deriving (Show, Eq) + + +data DiffFormatStatus + = UnchangedFormat + | ChangedToFormat (Maybe Format) + deriving (Show, Eq) + + +data DiffChar = DiffChar FormatChar DiffStatus + deriving (Show, Eq) + + +data DiffPlainChar = DiffPlainChar Char DiffPlainStatus + deriving (Show, Eq) + + +data FormatChar = FormatChar + { char :: Char + , format :: Maybe Format + } + 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) + + +plainDiff :: LeftSide T.Text -> RightSide T.Text -> Seq DiffPlainChar +plainDiff (LeftSide left) (RightSide right) = toPlain <$> formattedDiff + where + formattedDiff = diff (LeftSide $ toFormatted left) (RightSide $ toFormatted right) + + toPlain :: DiffChar -> DiffPlainChar + toPlain (DiffChar (FormatChar c _) diffStatus) = DiffPlainChar c diffStatusPlain + where + diffStatusPlain = case diffStatus of + UnchangedChar _ -> UnchangedP + Inserted -> InsertedP + Deleted -> DeletedP + + toFormatted :: T.Text -> Seq FormatChar + 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 + + toText :: Seq FormatChar -> T.Text + toText = T.pack . F.toList . fmap char + + indices :: (DeleteIndicies, InsertIndicies) + indices = F.foldl' f (DeleteIndicies S.empty, InsertIndicies S.empty) edits + 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] + + unchangedChars :: M.Map Int DiffFormatStatus -- indexed in left + unchangedChars = F.foldl' f mempty unchangedCharPairs + where + unchangedCharPairs :: Seq (Int, FormatChar, FormatChar) + unchangedCharPairs = g <$> S.zip leftWithoutDeletes rightWithoutInserts + + 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 + & 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 + + g :: ((Int, FormatChar), (Int, FormatChar)) -> (Int, FormatChar, FormatChar) + g ((i,c), (_,d)) = (i,c,d) + + markDeletesAndUnchangedChars :: Seq DiffChar + markDeletesAndUnchangedChars = S.mapWithIndex f left + where + f :: Int -> FormatChar -> DiffChar + 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 + 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 + + 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 \ No newline at end of file diff --git a/tests/MarkdownDiffTests.hs b/tests/MarkdownDiffTests.hs new file mode 100644 index 0000000000..5d35414d2d --- /dev/null +++ b/tests/MarkdownDiffTests.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module MarkdownDiffTests where + +import qualified Data.Sequence as S +import Simplex.Chat.Markdown + +import Simplex.Chat.MarkdownDiff + ( FormatChar(..), + DiffChar(..), + DiffPlainChar(..), + DiffStatus(..), + DiffPlainStatus(..), + DiffFormatStatus(..), + LeftSide(..), + RightSide(..), + diff, + plainDiff ) + + +import System.Console.ANSI.Types +import Test.Hspec +import qualified Data.List.NonEmpty as NE + + +markdownDiffTests :: Spec +markdownDiffTests = do + formattedEditedTextTests + + +formattedEditedTextTests :: Spec +formattedEditedTextTests = describe "show edits" do + it "empty no change" do + diff + (LeftSide $ S.fromList + [ + ]) + (RightSide $ S.fromList + [ + ]) + `shouldBe` S.fromList + [ + ] + + it "no change" do + diff + (LeftSide $ S.fromList + [ FormatChar 'H' Nothing + ]) + (RightSide $ S.fromList + [ FormatChar 'H' Nothing + ]) + `shouldBe` S.fromList + [ DiffChar (FormatChar 'H' Nothing) $ UnchangedChar UnchangedFormat + ] + + it "add 1 char to empty" do + diff + (LeftSide $ S.fromList + [ + ]) + (RightSide $ S.fromList + [ FormatChar 'H' Nothing + ]) + `shouldBe` S.fromList + [ DiffChar (FormatChar 'H' Nothing) Inserted + ] + + it "del the one and only" do + diff + (LeftSide $ S.fromList + [ FormatChar 'H' Nothing + ]) + (RightSide $ S.fromList + [ + ]) + `shouldBe` S.fromList + [ DiffChar (FormatChar 'H' Nothing) Deleted + ] + + it "one character change" do + diff + (LeftSide $ S.fromList + [ FormatChar 'H' Nothing + , FormatChar 'r' Nothing + , FormatChar 'l' Nothing + , FormatChar 'l' Nothing + , FormatChar 'o' Nothing + ]) + (RightSide $ S.fromList + [ FormatChar 'H' Nothing + , FormatChar 'e' Nothing + , FormatChar 'l' Nothing + , FormatChar 'l' Nothing + , FormatChar 'o' Nothing + ]) + `shouldBe` S.fromList + [ DiffChar (FormatChar 'H' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar 'r' Nothing) Deleted + , DiffChar (FormatChar 'e' Nothing) Inserted + , DiffChar (FormatChar 'l' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar 'l' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar 'o' Nothing) $ UnchangedChar UnchangedFormat + ] + + it "more1" do + diff + (LeftSide $ S.fromList + [ FormatChar 'H' Nothing + , FormatChar 'r' Nothing + , FormatChar 'l' Nothing + , FormatChar 'l' Nothing + , FormatChar 'o' Nothing + ]) + (RightSide $ S.fromList + [ FormatChar 'H' Nothing + , FormatChar 'e' Nothing + , FormatChar 'l' Nothing + , FormatChar 'l' Nothing + , FormatChar 'o' Nothing + , FormatChar 'x' Nothing + , FormatChar 'y' Nothing + , FormatChar 'z' Nothing + ]) + `shouldBe` S.fromList + [ DiffChar (FormatChar 'H' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar 'r' Nothing) Deleted + , DiffChar (FormatChar 'e' Nothing) Inserted + , DiffChar (FormatChar 'l' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar 'l' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar 'o' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar 'x' Nothing) Inserted + , DiffChar (FormatChar 'y' Nothing) Inserted + , DiffChar (FormatChar 'z' Nothing) Inserted + ] + + it "more2" do + diff + (LeftSide $ S.fromList + [ FormatChar 'H' Nothing + , FormatChar 'r' Nothing + , FormatChar 'l' Nothing + , FormatChar 'l' Nothing + , FormatChar 'o' Nothing + ]) + (RightSide $ S.fromList + [ FormatChar 'H' Nothing + , FormatChar 'e' Nothing + , FormatChar 'x' Nothing + , FormatChar 'y' Nothing + , FormatChar 'z' Nothing + , FormatChar 'o' Nothing + ]) + `shouldBe` S.fromList + [ DiffChar (FormatChar 'H' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar 'r' Nothing) Deleted + , DiffChar (FormatChar 'l' Nothing) Deleted + , DiffChar (FormatChar 'l' Nothing) Deleted + , DiffChar (FormatChar 'e' Nothing) Inserted + , DiffChar (FormatChar 'x' Nothing) Inserted + , DiffChar (FormatChar 'y' Nothing) Inserted + , DiffChar (FormatChar 'z' Nothing) Inserted + , DiffChar (FormatChar 'o' Nothing) $ UnchangedChar UnchangedFormat + ] + + it "more3" do + diff + (LeftSide $ S.fromList + [ FormatChar 'H' $ Just Bold + , FormatChar 'H' $ Just Bold + , FormatChar 'r' Nothing + , FormatChar 'l' $ Just Secret + , FormatChar 'l' Nothing + , FormatChar 'o' $ Just $ colored Green + ]) + (RightSide $ S.fromList + [ FormatChar 'H' $ Just Italic + , FormatChar 'H' $ Just Bold + , FormatChar 'e' $ Just $ colored Cyan + , FormatChar 'x' Nothing + , FormatChar 'y' Nothing + , FormatChar 'z' $ Just Secret + , FormatChar 'o' $ Just $ colored Blue + ]) + `shouldBe` S.fromList + [ DiffChar (FormatChar 'H' (Just Bold)) $ UnchangedChar $ ChangedToFormat $ Just Italic + , DiffChar (FormatChar 'H' (Just Bold)) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar 'r' Nothing) Deleted + , DiffChar (FormatChar 'l' (Just Secret)) Deleted + , DiffChar (FormatChar 'l' Nothing) Deleted + , DiffChar (FormatChar 'e' (Just $ colored Cyan)) Inserted + , DiffChar (FormatChar 'x' Nothing) Inserted + , DiffChar (FormatChar 'y' Nothing) Inserted + , DiffChar (FormatChar 'z' (Just Secret)) Inserted + , DiffChar (FormatChar 'o' (Just $ colored Green)) $ UnchangedChar $ ChangedToFormat $ Just $ colored Blue + ] + + it "more4" do + diff + (LeftSide $ S.fromList + [ FormatChar 'H' Nothing + , FormatChar 'r' Nothing + , FormatChar 'l' Nothing + , FormatChar '~' Nothing + , FormatChar '!' Nothing + , FormatChar '@' Nothing + , FormatChar 'l' Nothing + , FormatChar 'o' Nothing + ]) + (RightSide $ S.fromList + [ FormatChar 'H' Nothing + , FormatChar 'e' Nothing + , FormatChar 'r' Nothing + , FormatChar 'x' Nothing + , FormatChar 'y' Nothing + , FormatChar '!' Nothing + , FormatChar '@' Nothing + , FormatChar 'z' Nothing + , FormatChar 'o' Nothing + , FormatChar '1' Nothing + , FormatChar '2' Nothing + ]) + `shouldBe` S.fromList + [ DiffChar (FormatChar 'H' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar 'e' Nothing) Inserted + , DiffChar (FormatChar 'r' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar 'l' Nothing) Deleted + , DiffChar (FormatChar '~' Nothing) Deleted + , DiffChar (FormatChar 'x' Nothing) Inserted + , DiffChar (FormatChar 'y' Nothing) Inserted + , DiffChar (FormatChar '!' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar '@' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar 'l' Nothing) Deleted + , DiffChar (FormatChar 'z' Nothing) Inserted + , DiffChar (FormatChar 'o' Nothing) $ UnchangedChar UnchangedFormat + , DiffChar (FormatChar '1' Nothing) Inserted + , DiffChar (FormatChar '2' Nothing) Inserted + ] + + it "SimplexLink 1" do + diff + (LeftSide $ S.fromList + [ FormatChar '>' $ Just $ SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/2/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host1", "host2", "host3"]} + ]) + (RightSide $ S.fromList + [ FormatChar '>' $ Just SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/3/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host0", "host2", "host3"] + } + ]) + `shouldBe` S.fromList + [ DiffChar + (FormatChar '>' $ Just SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/2/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host1", "host2", "host3"] + } + ) $ + UnchangedChar $ ChangedToFormat $ Just SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/3/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host0", "host2", "host3"] + } + ] + + it "SimplexLink 2" do + diff + (LeftSide $ S.fromList + [ FormatChar '>' $ Just $ SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/2/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host1", "host2", "host3"]} + ]) + (RightSide $ S.fromList + [ FormatChar '>' $ Just SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/3/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host1", "host2", "host3"] + } + ]) + `shouldBe` S.fromList + [ DiffChar + (FormatChar '>' $ Just SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/2/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host1", "host2", "host3"] + } + ) $ + UnchangedChar $ ChangedToFormat $ Just SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/3/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host1", "host2", "host3"] + } + ] + + it "SimplexLink 3" do + diff + (LeftSide $ S.fromList + [ FormatChar '>' $ Just $ SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/2/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host1", "host2", "host3"]} + ]) + (RightSide $ S.fromList + [ FormatChar '>' $ Just SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/2/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host0", "host2", "host3"] + } + ]) + `shouldBe` S.fromList + [ DiffChar + (FormatChar '>' $ Just SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/2/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host1", "host2", "host3"] + } + ) $ + UnchangedChar $ ChangedToFormat $ Just SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/2/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host0", "host2", "host3"] + } + ] + + it "plainDiff 1" do + plainDiff + (LeftSide "https://api.twitter.com/2/tweets/:id") + (RightSide "https://api.twitter.com/3/tweets/:id") + `shouldBe` S.fromList + [ DiffPlainChar 'h' UnchangedP + , DiffPlainChar 't' UnchangedP + , DiffPlainChar 't' UnchangedP + , DiffPlainChar 'p' UnchangedP + , DiffPlainChar 's' UnchangedP + , DiffPlainChar ':' UnchangedP + , DiffPlainChar '/' UnchangedP + , DiffPlainChar '/' UnchangedP + , DiffPlainChar 'a' UnchangedP + , DiffPlainChar 'p' UnchangedP + , DiffPlainChar 'i' UnchangedP + , DiffPlainChar '.' UnchangedP + , DiffPlainChar 't' UnchangedP + , DiffPlainChar 'w' UnchangedP + , DiffPlainChar 'i' UnchangedP + , DiffPlainChar 't' UnchangedP + , DiffPlainChar 't' UnchangedP + , DiffPlainChar 'e' UnchangedP + , DiffPlainChar 'r' UnchangedP + , DiffPlainChar '.' UnchangedP + , DiffPlainChar 'c' UnchangedP + , DiffPlainChar 'o' UnchangedP + , DiffPlainChar 'm' UnchangedP + , DiffPlainChar '/' UnchangedP + , DiffPlainChar '2' DeletedP + , DiffPlainChar '3' InsertedP + , DiffPlainChar '/' UnchangedP + , DiffPlainChar 't' UnchangedP + , DiffPlainChar 'w' UnchangedP + , DiffPlainChar 'e' UnchangedP + , DiffPlainChar 'e' UnchangedP + , DiffPlainChar 't' UnchangedP + , DiffPlainChar 's' UnchangedP + , DiffPlainChar '/' UnchangedP + , DiffPlainChar ':' UnchangedP + , DiffPlainChar 'i' UnchangedP + , DiffPlainChar 'd' UnchangedP + ] + + it "plainDiff 2" do + plainDiff + (LeftSide "Hrl~!@lo") + (RightSide "Herxy!@zo12") + `shouldBe` S.fromList + [ DiffPlainChar 'H' UnchangedP + , DiffPlainChar 'e' InsertedP + , DiffPlainChar 'r' UnchangedP + , DiffPlainChar 'l' DeletedP + , DiffPlainChar '~' DeletedP + , DiffPlainChar 'x' InsertedP + , DiffPlainChar 'y' InsertedP + , DiffPlainChar '!' UnchangedP + , DiffPlainChar '@' UnchangedP + , DiffPlainChar 'l' DeletedP + , DiffPlainChar 'z' InsertedP + , DiffPlainChar 'o' UnchangedP + , DiffPlainChar '1' InsertedP + , DiffPlainChar '2' InsertedP + ] \ No newline at end of file diff --git a/tests/Test.hs b/tests/Test.hs index 455d5459c7..bf74d27a17 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -6,6 +6,7 @@ import ChatTests.Utils (xdescribe'') import Control.Logger.Simple import Data.Time.Clock.System import MarkdownTests +import MarkdownDiffTests import MobileTests import ProtocolTests import SchemaDump