From 32a0e6359c77b0170af48a9884e808ec03b538cb Mon Sep 17 00:00:00 2001 From: pdavidow Date: Tue, 15 Aug 2023 22:46:16 -0400 Subject: [PATCH] FINAL need to uncomment tests --- simplex-chat.cabal | 8 + src/Simplex/Chat/MarkdownEditing.hs | 167 ++++++++++++++ tests/MarkdownEditingTests.hs | 324 ++++++++++++++++++++++++++++ tests/Test.hs | 28 +-- 4 files changed, 514 insertions(+), 13 deletions(-) create mode 100644 src/Simplex/Chat/MarkdownEditing.hs create mode 100644 tests/MarkdownEditingTests.hs diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 526051edb6..dfaf53e9c3 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -33,6 +33,7 @@ library Simplex.Chat.Core Simplex.Chat.Help Simplex.Chat.Markdown + Simplex.Chat.MarkdownEditing Simplex.Chat.Messages Simplex.Chat.Messages.CIContent Simplex.Chat.Migrations.M20220101_initial @@ -152,6 +153,7 @@ library , http-types ==0.12.* , memory ==0.15.* , mtl ==2.2.* + , myers-diff >= 0.2.0.0 , network >=3.1.2.7 && <3.2 , optparse-applicative >=0.15 && <0.17 , process ==1.6.* @@ -200,6 +202,7 @@ executable simplex-bot , http-types ==0.12.* , memory ==0.15.* , mtl ==2.2.* + , myers-diff >= 0.2.0.0 , network >=3.1.2.7 && <3.2 , optparse-applicative >=0.15 && <0.17 , process ==1.6.* @@ -249,6 +252,7 @@ executable simplex-bot-advanced , http-types ==0.12.* , memory ==0.15.* , mtl ==2.2.* + , myers-diff >= 0.2.0.0 , network >=3.1.2.7 && <3.2 , optparse-applicative >=0.15 && <0.17 , process ==1.6.* @@ -299,6 +303,7 @@ executable simplex-broadcast-bot , http-types ==0.12.* , memory ==0.15.* , mtl ==2.2.* + , myers-diff >= 0.2.0.0 , network >=3.1.2.7 && <3.2 , optparse-applicative >=0.15 && <0.17 , process ==1.6.* @@ -349,6 +354,7 @@ executable simplex-chat , http-types ==0.12.* , memory ==0.15.* , mtl ==2.2.* + , myers-diff >= 0.2.0.0 , network ==3.1.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* @@ -384,6 +390,7 @@ test-suite simplex-chat-test ChatTests.Profiles ChatTests.Utils MarkdownTests + MarkdownEditingTests MobileTests ProtocolTests SchemaDump @@ -415,6 +422,7 @@ test-suite simplex-chat-test , http-types ==0.12.* , memory ==0.15.* , mtl ==2.2.* + , myers-diff >= 0.2.0.0 , network ==3.1.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* diff --git a/src/Simplex/Chat/MarkdownEditing.hs b/src/Simplex/Chat/MarkdownEditing.hs new file mode 100644 index 0000000000..65c840f760 --- /dev/null +++ b/src/Simplex/Chat/MarkdownEditing.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use newtype instead of data" #-} + + +module Simplex.Chat.MarkdownEditing + ( DiffedChar(..) + , DiffedPlainChar(..) + , DiffStatus(..) + , DiffPlainStatus(..) + , DiffFormatStatus(..) + , FormattedChar(..) + , LeftSide(..) + , RightSide(..) + , findDiffs + , findPlainDiffs + , toFormattedChars + ) + where + + +import qualified Data.Foldable as F +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 ( FormattedText(..), Format ) + + +data DiffStatus + = UnchangedChar DiffFormatStatus + | Inserted + | Deleted + deriving (Show, Eq) + + +data DiffPlainStatus + = PlainUnchanged + | PlainInserted + | PlainDeleted + deriving (Show, Eq) + + +data DiffFormatStatus + = UnchangedFormat + | ChangedToFormat (Maybe Format) + deriving (Show, Eq) + + +data DiffedChar = DiffedChar FormattedChar DiffStatus + deriving (Show, Eq) + + +data DiffedPlainChar = DiffedPlainChar Char DiffPlainStatus + deriving (Show, Eq) + + +data FormattedChar = FormattedChar + { char :: Char + , format :: Maybe Format + } + deriving (Show, Eq) + + +newtype LeftSide a = LeftSide a +newtype RightSide a = RightSide a + + +newtype DeleteIndicies = DeleteIndicies (Seq Int) deriving (Show, Eq) +newtype InsertIndicies = InsertIndicies (Seq Int) deriving (Show, Eq) + + +toFormattedChars :: [FormattedText] -> [FormattedChar] +toFormattedChars = concatMap toChars + where toChars (FormattedText f t) = map (`FormattedChar` f) $ T.unpack t + + +toText :: Seq FormattedChar -> T.Text +toText = T.pack . F.toList . fmap char + + +indicesFromEdits :: Seq D.Edit -> (DeleteIndicies, InsertIndicies) +indicesFromEdits = F.foldl' f (DeleteIndicies S.empty, InsertIndicies S.empty) + 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] + + +findPlainDiffs :: LeftSide T.Text -> RightSide T.Text -> Seq DiffedPlainChar +findPlainDiffs (LeftSide left) (RightSide right) = f <$> diffs + where + diffs = findDiffs (LeftSide $ toFormattedCharsFromText left) (RightSide $ toFormattedCharsFromText right) + + toFormattedCharsFromText :: T.Text -> Seq FormattedChar + toFormattedCharsFromText = fmap (`FormattedChar` Nothing) . S.fromList . T.unpack + + f :: DiffedChar -> DiffedPlainChar + f (DiffedChar (FormattedChar c _) diffStatus) = DiffedPlainChar c diffStatusPlain + where diffStatusPlain = case diffStatus of + UnchangedChar _ -> PlainUnchanged + Inserted -> PlainInserted + Deleted -> PlainDeleted + + +findDiffs :: LeftSide (Seq FormattedChar) -> RightSide (Seq FormattedChar) -> Seq DiffedChar +findDiffs (LeftSide left) (RightSide right) = addInserts markDeletesAndUnchangedChars + where + edits = D.diffTexts (toText left) (toText right) + (DeleteIndicies deleteIndicies, InsertIndicies insertIndicies) = indicesFromEdits edits + + unchangedChars :: M.Map Int DiffFormatStatus + unchangedChars = F.foldl' f mempty unchangedCharPairs + where + unchangedCharPairs :: Seq (Int, FormattedChar, FormattedChar) + unchangedCharPairs = g <$> S.zip leftWithoutDeletes rightWithoutInserts + + leftWithoutDeletes :: Seq (Int, FormattedChar) -- indexed in original left + leftWithoutDeletes = S.filter (\(i, _) -> i `notElem` deleteIndicies) leftZ + where leftZ = S.zip (S.fromList [0 .. S.length left]) left + + rightWithoutInserts :: Seq (Int, FormattedChar) -- indexed in original right + rightWithoutInserts = S.filter (\(i, _) -> i `notElem` insertIndicies) rightZ + where rightZ = S.zip (S.fromList [0 .. S.length right]) right + + f :: M.Map Int DiffFormatStatus -> (Int, FormattedChar, FormattedChar) -> M.Map Int DiffFormatStatus + f acc (i, FormattedChar _ fL, FormattedChar _ fR) = M.insert i x acc + where x = if fL == fR then UnchangedFormat else ChangedToFormat fR + + g :: ((Int, FormattedChar), (Int, FormattedChar)) -> (Int, FormattedChar, FormattedChar) + g ((i,c), (_j,d)) = (i,c,d) -- i and _j should always be equal + + markDeletesAndUnchangedChars :: Seq DiffedChar + markDeletesAndUnchangedChars = S.mapWithIndex f left + where + f :: Int -> FormattedChar -> DiffedChar + f i x = DiffedChar x $ + if i `elem` deleteIndicies then Deleted + else UnchangedChar $ unchangedChars M.! i -- should never error + + addInserts :: Seq DiffedChar -> Seq DiffedChar + addInserts base = F.foldr f base edits -- start from end and work backwards, hence foldr + where + f :: D.Edit -> Seq DiffedChar -> Seq DiffedChar + 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 (DiffedChar _ diffStatus) -> + if diffStatus == Deleted then slidePastDeleteBlock (x + 1) + else x + + rightFormatChars = S.take (n - m + 1) $ S.drop m right + inserts = fmap (`DiffedChar` Inserted) rightFormatChars \ No newline at end of file diff --git a/tests/MarkdownEditingTests.hs b/tests/MarkdownEditingTests.hs new file mode 100644 index 0000000000..1ad148eab9 --- /dev/null +++ b/tests/MarkdownEditingTests.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module MarkdownEditingTests where + +import qualified Data.Sequence as S +import Simplex.Chat.Markdown + +import Simplex.Chat.MarkdownEditing + ( FormattedChar(..), + DiffedChar(..), + DiffedPlainChar(..), + DiffStatus(..), + DiffPlainStatus(..), + DiffFormatStatus(..), + LeftSide(..), + RightSide(..), + findDiffs, + findPlainDiffs ) + + +import System.Console.ANSI.Types +import Test.Hspec +import qualified Data.List.NonEmpty as NE + + +markdownEditingTests :: Spec +markdownEditingTests = do + formattedEditedTextTests + + +formattedEditedTextTests :: Spec +formattedEditedTextTests = describe "show edits" do + it "empty no change" do + findDiffs + (LeftSide $ S.fromList + [ + ]) + + (RightSide $ S.fromList + [ + ]) + + `shouldBe` S.fromList + [ + ] + + + it "no change" do + findDiffs + (LeftSide $ S.fromList + [ FormattedChar 'H' Nothing + ]) + + (RightSide $ S.fromList + [ FormattedChar 'H' Nothing + ]) + + `shouldBe` S.fromList + [ DiffedChar (FormattedChar 'H' Nothing) $ UnchangedChar UnchangedFormat + ] + + + it "add 1 char to empty" do + findDiffs + (LeftSide $ S.fromList + [ + ]) + + (RightSide $ S.fromList + [ FormattedChar 'H' Nothing + ]) + + `shouldBe` S.fromList + [ DiffedChar (FormattedChar 'H' Nothing) Inserted + ] + + + it "del the one and only" do + findDiffs + (LeftSide $ S.fromList + [ FormattedChar 'H' Nothing + ]) + + (RightSide $ S.fromList + [ + ]) + + `shouldBe` S.fromList + [ DiffedChar (FormattedChar 'H' Nothing) Deleted + ] + + + it "one character change" do + findDiffs + (LeftSide $ S.fromList + [ FormattedChar 'H' Nothing + , FormattedChar 'r' Nothing + , FormattedChar 'l' Nothing + , FormattedChar 'l' Nothing + , FormattedChar 'o' Nothing + ]) + + (RightSide $ S.fromList + [ FormattedChar 'H' Nothing + , FormattedChar 'e' Nothing + , FormattedChar 'l' Nothing + , FormattedChar 'l' Nothing + , FormattedChar 'o' Nothing + ]) + + `shouldBe` S.fromList + [ DiffedChar (FormattedChar 'H' Nothing) $ UnchangedChar UnchangedFormat + , DiffedChar (FormattedChar 'r' Nothing) Deleted + , DiffedChar (FormattedChar 'e' Nothing) Inserted + , DiffedChar (FormattedChar 'l' Nothing) $ UnchangedChar UnchangedFormat + , DiffedChar (FormattedChar 'l' Nothing) $ UnchangedChar UnchangedFormat + , DiffedChar (FormattedChar 'o' Nothing) $ UnchangedChar UnchangedFormat + ] + + + it "more1" do + findDiffs + (LeftSide $ S.fromList + [ FormattedChar 'H' Nothing + , FormattedChar 'r' Nothing + , FormattedChar 'l' Nothing + , FormattedChar 'l' Nothing + , FormattedChar 'o' Nothing + ]) + + (RightSide $ S.fromList + [ FormattedChar 'H' Nothing + , FormattedChar 'e' Nothing + , FormattedChar 'l' Nothing + , FormattedChar 'l' Nothing + , FormattedChar 'o' Nothing + , FormattedChar 'x' Nothing + , FormattedChar 'y' Nothing + , FormattedChar 'z' Nothing + ]) + + `shouldBe` S.fromList + [ DiffedChar (FormattedChar 'H' Nothing) $ UnchangedChar UnchangedFormat + , DiffedChar (FormattedChar 'r' Nothing) Deleted + , DiffedChar (FormattedChar 'e' Nothing) Inserted + , DiffedChar (FormattedChar 'l' Nothing) $ UnchangedChar UnchangedFormat + , DiffedChar (FormattedChar 'l' Nothing) $ UnchangedChar UnchangedFormat + , DiffedChar (FormattedChar 'o' Nothing) $ UnchangedChar UnchangedFormat + , DiffedChar (FormattedChar 'x' Nothing) Inserted + , DiffedChar (FormattedChar 'y' Nothing) Inserted + , DiffedChar (FormattedChar 'z' Nothing) Inserted + ] + + + it "more2" do + findDiffs + (LeftSide $ S.fromList + [ FormattedChar 'H' Nothing + , FormattedChar 'r' Nothing + , FormattedChar 'l' Nothing + , FormattedChar 'l' Nothing + , FormattedChar 'o' Nothing + ]) + + (RightSide $ S.fromList + [ FormattedChar 'H' Nothing + , FormattedChar 'e' Nothing + , FormattedChar 'x' Nothing + , FormattedChar 'y' Nothing + , FormattedChar 'z' Nothing + , FormattedChar 'o' Nothing + ]) + + `shouldBe` S.fromList + [ DiffedChar (FormattedChar 'H' Nothing) $ UnchangedChar UnchangedFormat + , DiffedChar (FormattedChar 'r' Nothing) Deleted + , DiffedChar (FormattedChar 'l' Nothing) Deleted + , DiffedChar (FormattedChar 'l' Nothing) Deleted + , DiffedChar (FormattedChar 'e' Nothing) Inserted + , DiffedChar (FormattedChar 'x' Nothing) Inserted + , DiffedChar (FormattedChar 'y' Nothing) Inserted + , DiffedChar (FormattedChar 'z' Nothing) Inserted + , DiffedChar (FormattedChar 'o' Nothing) $ UnchangedChar UnchangedFormat + ] + + + it "more3" do + findDiffs + (LeftSide $ S.fromList + [ FormattedChar 'H' (Just Bold) + , FormattedChar 'H' (Just Bold) + , FormattedChar 'r' Nothing + , FormattedChar 'l' (Just Secret) + , FormattedChar 'l' Nothing + , FormattedChar 'o' (Just $ colored Green) + ]) + + (RightSide $ S.fromList + [ FormattedChar 'H' (Just Italic) + , FormattedChar 'H' (Just Bold) + , FormattedChar 'e' (Just $ colored Cyan) + , FormattedChar 'x' Nothing + , FormattedChar 'y' Nothing + , FormattedChar 'z' (Just Secret) + , FormattedChar 'o' (Just $ colored Blue) + ]) + + `shouldBe` S.fromList + [ DiffedChar (FormattedChar 'H' (Just Bold)) $ UnchangedChar (ChangedToFormat (Just Italic)) + , DiffedChar (FormattedChar 'H' (Just Bold)) $ UnchangedChar UnchangedFormat + , DiffedChar (FormattedChar 'r' Nothing) Deleted + , DiffedChar (FormattedChar 'l' (Just Secret)) Deleted + , DiffedChar (FormattedChar 'l' Nothing) Deleted + , DiffedChar (FormattedChar 'e' (Just $ colored Cyan)) Inserted + , DiffedChar (FormattedChar 'x' Nothing) Inserted + , DiffedChar (FormattedChar 'y' Nothing) Inserted + , DiffedChar (FormattedChar 'z' (Just Secret)) Inserted + , DiffedChar (FormattedChar 'o' (Just $ colored Green)) $ UnchangedChar (ChangedToFormat (Just $ colored Blue)) + ] + + + it "more4" do + findDiffs + (LeftSide $ S.fromList + [ FormattedChar 'H' Nothing + , FormattedChar 'r' Nothing + , FormattedChar 'l' Nothing + , FormattedChar '~' Nothing + , FormattedChar '!' Nothing + , FormattedChar '@' Nothing + , FormattedChar 'l' Nothing + , FormattedChar 'o' Nothing + ]) + + (RightSide $ S.fromList + [ FormattedChar 'H' Nothing + , FormattedChar 'e' Nothing + , FormattedChar 'r' Nothing + , FormattedChar 'x' Nothing + , FormattedChar 'y' Nothing + , FormattedChar '!' Nothing + , FormattedChar '@' Nothing + , FormattedChar 'z' Nothing + , FormattedChar 'o' Nothing + , FormattedChar '1' Nothing + , FormattedChar '2' Nothing + ]) + + `shouldBe` S.fromList + [ DiffedChar (FormattedChar 'H' Nothing) (UnchangedChar UnchangedFormat) + , DiffedChar (FormattedChar 'e' Nothing) Inserted + , DiffedChar (FormattedChar 'r' Nothing) (UnchangedChar UnchangedFormat) + , DiffedChar (FormattedChar 'l' Nothing) Deleted + , DiffedChar (FormattedChar '~' Nothing) Deleted + , DiffedChar (FormattedChar 'x' Nothing) Inserted + , DiffedChar (FormattedChar 'y' Nothing) Inserted + , DiffedChar (FormattedChar '!' Nothing) (UnchangedChar UnchangedFormat) + , DiffedChar (FormattedChar '@' Nothing) (UnchangedChar UnchangedFormat) + , DiffedChar (FormattedChar 'l' Nothing) Deleted + , DiffedChar (FormattedChar 'z' Nothing) Inserted + , DiffedChar (FormattedChar 'o' Nothing) (UnchangedChar UnchangedFormat) + , DiffedChar (FormattedChar '1' Nothing) Inserted + , DiffedChar (FormattedChar '2' Nothing) Inserted + ] + + + it "SimplexLink" do + findDiffs + (LeftSide $ S.fromList + [ FormattedChar '>' $ Just $ SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/2/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host1", "host2", "host3"]} + ]) + + (RightSide $ S.fromList + [ FormattedChar '>' $ Just SimplexLink + { linkType = XLContact + , simplexUri = "https://api.twitter.com/3/tweets/:id" + , trustedUri = True + , smpHosts = NE.fromList ["host0", "host2", "host3"] + } + ]) + + `shouldBe` S.fromList + [ DiffedChar + (FormattedChar '>' $ 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 "findPlainDiffs" do + findPlainDiffs (LeftSide "Hrl~!@lo") (RightSide "Herxy!@zo12") + `shouldBe` S.fromList + [ DiffedPlainChar 'H' PlainUnchanged + , DiffedPlainChar 'e' PlainInserted + , DiffedPlainChar 'r' PlainUnchanged + , DiffedPlainChar 'l' PlainDeleted + , DiffedPlainChar '~' PlainDeleted + , DiffedPlainChar 'x' PlainInserted + , DiffedPlainChar 'y' PlainInserted + , DiffedPlainChar '!' PlainUnchanged + , DiffedPlainChar '@' PlainUnchanged + , DiffedPlainChar 'l' PlainDeleted + , DiffedPlainChar 'z' PlainInserted + , DiffedPlainChar 'o' PlainUnchanged + , DiffedPlainChar '1' PlainInserted + , DiffedPlainChar '2' PlainInserted + ] \ No newline at end of file diff --git a/tests/Test.hs b/tests/Test.hs index 9010aefa0f..488898829e 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -3,6 +3,7 @@ import ChatTests import Control.Logger.Simple import Data.Time.Clock.System import MarkdownTests +import MarkdownEditingTests import MobileTests import ProtocolTests import SchemaDump @@ -15,19 +16,20 @@ main :: IO () main = do setLogLevel LogError -- LogDebug withGlobalLogging logCfg . hspec $ do - describe "SimpleX chat markdown" markdownTests - describe "SimpleX chat view" viewTests - describe "SimpleX chat protocol" protocolTests - describe "WebRTC encryption" webRTCTests - describe "Schema dump" schemaDumpTest - around testBracket $ do - describe "Mobile API Tests" mobileTests - describe "SimpleX chat client" chatTests - where - testBracket test = do - t <- getSystemTime - let ts = show (systemSeconds t) <> show (systemNanoseconds t) - withSmpServer $ withTmpFiles $ withTempDirectory "tests/tmp" ts test + describe "SimpleX chat markdown editing" markdownEditingTests + -- describe "SimpleX chat markdown" markdownTests + -- describe "SimpleX chat view" viewTests + -- describe "SimpleX chat protocol" protocolTests + -- describe "WebRTC encryption" webRTCTests + -- describe "Schema dump" schemaDumpTest + -- around testBracket $ do + -- describe "Mobile API Tests" mobileTests + -- describe "SimpleX chat client" chatTests + -- where + -- testBracket test = do + -- t <- getSystemTime + -- let ts = show (systemSeconds t) <> show (systemNanoseconds t) + -- withSmpServer $ withTmpFiles $ withTempDirectory "tests/tmp" ts test logCfg :: LogConfig logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}