diff --git a/src/Simplex/Chat/Markdown.hs b/src/Simplex/Chat/Markdown.hs index 1e1809d548..1384610fbd 100644 --- a/src/Simplex/Chat/Markdown.hs +++ b/src/Simplex/Chat/Markdown.hs @@ -32,6 +32,7 @@ data Format | Snippet | Secret | Colored FormatColor + | Uri deriving (Eq, Show, Generic) colored :: Color -> Format @@ -42,7 +43,19 @@ markdown = Markdown . Just instance ToJSON Format where toEncoding = J.genericToEncoding $ sumTypeJSON fstToLower -instance Semigroup Markdown where (<>) = (:|:) +instance Semigroup Markdown where + m <> (Markdown _ "") = m + (Markdown _ "") <> m = m + m1@(Markdown f1 s1) <> m2@(Markdown f2 s2) + | f1 == f2 = Markdown f1 $ s1 <> s2 + | otherwise = m1 :|: m2 + m1@(Markdown f1 s1) <> ms@(Markdown f2 s2 :|: m3) + | f1 == f2 = Markdown f1 (s1 <> s2) :|: m3 + | otherwise = m1 :|: ms + ms@(m1 :|: Markdown f2 s2) <> m3@(Markdown f3 s3) + | f2 == f3 = m1 :|: Markdown f2 (s2 <> s3) + | otherwise = ms :|: m3 + m1 <> m2 = m1 :|: m2 instance Monoid Markdown where mempty = unmarked "" @@ -125,20 +138,18 @@ parseMarkdown :: Text -> Markdown parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s markdownP :: Parser Markdown -markdownP = merge <$> A.many' fragmentP +markdownP = mconcat <$> A.many' fragmentP where - merge :: [Markdown] -> Markdown - merge [] = "" - merge fs = foldr1 (:|:) fs fragmentP :: Parser Markdown fragmentP = - A.anyChar >>= \case - ' ' -> unmarked . T.cons ' ' <$> A.takeWhile (== ' ') - c -> case M.lookup c formats of - Just Secret -> secretP - Just (Colored (FormatColor White)) -> coloredP - Just f -> formattedP c "" f - Nothing -> unformattedP c + A.peekChar >>= \case + Just ' ' -> unmarked <$> A.takeWhile (== ' ') + Just c -> case M.lookup c formats of + Just Secret -> A.char secretMD *> secretP + Just (Colored (FormatColor White)) -> A.char colorMD *> coloredP + Just f -> A.char c *> formattedP c "" f + Nothing -> wordsP + Nothing -> fail "" formattedP :: Char -> Text -> Format -> Parser Markdown formattedP c p f = do s <- A.takeTill (== c) @@ -166,15 +177,18 @@ markdownP = merge <$> A.many' fragmentP in (A.char ' ' *> formattedP colorMD (color `T.snoc` ' ') f) <|> noFormat (colorMD `T.cons` color) _ -> noFormat (colorMD `T.cons` color) - unformattedP :: Char -> Parser Markdown - unformattedP c = unmarked . T.cons c <$> wordsP - wordsP :: Parser Text + wordsP :: Parser Markdown wordsP = do - s <- (<>) <$> A.takeTill (== ' ') <*> A.takeWhile (== ' ') + word <- wordMD <$> A.takeTill (== ' ') + s <- (word <>) <$> (unmarked <$> A.takeWhile (== ' ')) A.peekChar >>= \case Nothing -> pure s Just c -> case M.lookup c formats of Just _ -> pure s Nothing -> (s <>) <$> wordsP + wordMD :: Text -> Markdown + wordMD s + | "http://" `T.isPrefixOf` s || "https://" `T.isPrefixOf` s || "simplex:/" `T.isPrefixOf` s = markdown Uri s + | otherwise = unmarked s noFormat :: Text -> Parser Markdown noFormat = pure . unmarked diff --git a/src/Simplex/Chat/Styled.hs b/src/Simplex/Chat/Styled.hs index 3f7cf261b6..a7814bb079 100644 --- a/src/Simplex/Chat/Styled.hs +++ b/src/Simplex/Chat/Styled.hs @@ -74,7 +74,7 @@ sgr = \case StrikeThrough -> [SetSwapForegroundBackground True] Colored (FormatColor c) -> [SetColor Foreground Vivid c] Secret -> [SetColor Foreground Dull Black, SetColor Background Dull Black] - Snippet -> [] + _ -> [] unStyle :: StyledString -> String unStyle (Styled _ s) = s diff --git a/tests/MarkdownTests.hs b/tests/MarkdownTests.hs index 43ef1a47c0..8443567f1a 100644 --- a/tests/MarkdownTests.hs +++ b/tests/MarkdownTests.hs @@ -13,40 +13,41 @@ markdownTests = do textFormat secretText textColor + textWithUri textFormat :: Spec textFormat = describe "text format (bold)" do it "correct markdown" do parseMarkdown "this is *bold formatted* text" - `shouldBe` "this is " <> markdown Bold "bold formatted" <> " " <> "text" + `shouldBe` "this is " <> markdown Bold "bold formatted" <> " text" parseMarkdown "*bold formatted* text" - `shouldBe` markdown Bold "bold formatted" <> " " <> "text" + `shouldBe` markdown Bold "bold formatted" <> " text" parseMarkdown "this is *bold*" `shouldBe` "this is " <> markdown Bold "bold" parseMarkdown " *bold* text" - `shouldBe` " " <> markdown Bold "bold" <> " " <> "text" + `shouldBe` " " <> markdown Bold "bold" <> " text" parseMarkdown " *bold* text" - `shouldBe` " " <> markdown Bold "bold" <> " " <> "text" + `shouldBe` " " <> markdown Bold "bold" <> " text" parseMarkdown "this is *bold* " `shouldBe` "this is " <> markdown Bold "bold" <> " " parseMarkdown "this is *bold* " `shouldBe` "this is " <> markdown Bold "bold" <> " " it "ignored as markdown" do parseMarkdown "this is * unformatted * text" - `shouldBe` "this is " <> "* unformatted *" <> " " <> "text" + `shouldBe` "this is * unformatted * text" parseMarkdown "this is *unformatted * text" - `shouldBe` "this is " <> "*unformatted *" <> " " <> "text" + `shouldBe` "this is *unformatted * text" parseMarkdown "this is * unformatted* text" - `shouldBe` "this is " <> "* unformatted*" <> " " <> "text" + `shouldBe` "this is * unformatted* text" parseMarkdown "this is **unformatted** text" - `shouldBe` "this is " <> "**" <> "unformatted** text" + `shouldBe` "this is **unformatted** text" parseMarkdown "this is*unformatted* text" `shouldBe` "this is*unformatted* text" parseMarkdown "this is *unformatted text" - `shouldBe` "this is " <> "*unformatted text" + `shouldBe` "this is *unformatted text" it "ignored internal markdown" do parseMarkdown "this is *long _bold_ (not italic)* text" - `shouldBe` "this is " <> markdown Bold "long _bold_ (not italic)" <> " " <> "text" + `shouldBe` "this is " <> markdown Bold "long _bold_ (not italic)" <> " text" parseMarkdown "snippet: `this is *bold text*`" `shouldBe` "snippet: " <> markdown Snippet "this is *bold text*" @@ -54,36 +55,36 @@ secretText :: Spec secretText = describe "secret text" do it "correct markdown" do parseMarkdown "this is #black_secret# text" - `shouldBe` "this is " <> markdown Secret "black_secret" <> " " <> "text" + `shouldBe` "this is " <> markdown Secret "black_secret" <> " text" parseMarkdown "##black_secret### text" - `shouldBe` markdown Secret "#black_secret##" <> " " <> "text" + `shouldBe` markdown Secret "#black_secret##" <> " text" parseMarkdown "this is #black secret# text" - `shouldBe` "this is " <> markdown Secret "black secret" <> " " <> "text" + `shouldBe` "this is " <> markdown Secret "black secret" <> " text" parseMarkdown "##black secret### text" - `shouldBe` markdown Secret "#black secret##" <> " " <> "text" + `shouldBe` markdown Secret "#black secret##" <> " text" parseMarkdown "this is #secret#" `shouldBe` "this is " <> markdown Secret "secret" parseMarkdown " #secret# text" - `shouldBe` " " <> markdown Secret "secret" <> " " <> "text" + `shouldBe` " " <> markdown Secret "secret" <> " text" parseMarkdown " #secret# text" - `shouldBe` " " <> markdown Secret "secret" <> " " <> "text" + `shouldBe` " " <> markdown Secret "secret" <> " text" parseMarkdown "this is #secret# " `shouldBe` "this is " <> markdown Secret "secret" <> " " parseMarkdown "this is #secret# " `shouldBe` "this is " <> markdown Secret "secret" <> " " it "ignored as markdown" do parseMarkdown "this is # unformatted # text" - `shouldBe` "this is " <> "# unformatted #" <> " " <> "text" + `shouldBe` "this is # unformatted # text" parseMarkdown "this is #unformatted # text" - `shouldBe` "this is " <> "#unformatted #" <> " " <> "text" + `shouldBe` "this is #unformatted # text" parseMarkdown "this is # unformatted# text" - `shouldBe` "this is " <> "# unformatted#" <> " " <> "text" + `shouldBe` "this is # unformatted# text" parseMarkdown "this is ## unformatted ## text" - `shouldBe` "this is " <> "## unformatted ##" <> " " <> "text" + `shouldBe` "this is ## unformatted ## text" parseMarkdown "this is#unformatted# text" `shouldBe` "this is#unformatted# text" parseMarkdown "this is #unformatted text" - `shouldBe` "this is " <> "#unformatted text" + `shouldBe` "this is #unformatted text" it "ignored internal markdown" do parseMarkdown "snippet: `this is #secret_text#`" `shouldBe` "snippet: " <> markdown Snippet "this is #secret_text#" @@ -95,34 +96,48 @@ textColor :: Spec textColor = describe "text color (red)" do it "correct markdown" do parseMarkdown "this is !1 red color! text" - `shouldBe` "this is " <> red "red color" <> " " <> "text" + `shouldBe` "this is " <> red "red color" <> " text" parseMarkdown "!1 red! text" - `shouldBe` red "red" <> " " <> "text" + `shouldBe` red "red" <> " text" parseMarkdown "this is !1 red!" `shouldBe` "this is " <> red "red" parseMarkdown " !1 red! text" - `shouldBe` " " <> red "red" <> " " <> "text" + `shouldBe` " " <> red "red" <> " text" parseMarkdown " !1 red! text" - `shouldBe` " " <> red "red" <> " " <> "text" + `shouldBe` " " <> red "red" <> " text" parseMarkdown "this is !1 red! " `shouldBe` "this is " <> red "red" <> " " parseMarkdown "this is !1 red! " `shouldBe` "this is " <> red "red" <> " " it "ignored as markdown" do parseMarkdown "this is !1 unformatted ! text" - `shouldBe` "this is " <> "!1 unformatted !" <> " " <> "text" + `shouldBe` "this is !1 unformatted ! text" parseMarkdown "this is !1 unformatted ! text" - `shouldBe` "this is " <> "!1 unformatted !" <> " " <> "text" + `shouldBe` "this is !1 unformatted ! text" parseMarkdown "this is !1 unformatted! text" - `shouldBe` "this is " <> "!1 unformatted!" <> " " <> "text" + `shouldBe` "this is !1 unformatted! text" -- parseMarkdown "this is !!1 unformatted!! text" -- `shouldBe` "this is " <> "!!1" <> "unformatted!! text" parseMarkdown "this is!1 unformatted! text" `shouldBe` "this is!1 unformatted! text" parseMarkdown "this is !1 unformatted text" - `shouldBe` "this is " <> "!1 unformatted text" + `shouldBe` "this is !1 unformatted text" it "ignored internal markdown" do parseMarkdown "this is !1 long *red* (not bold)! text" - `shouldBe` "this is " <> red "long *red* (not bold)" <> " " <> "text" + `shouldBe` "this is " <> red "long *red* (not bold)" <> " text" parseMarkdown "snippet: `this is !1 red text!`" `shouldBe` "snippet: " <> markdown Snippet "this is !1 red text!" + +uri :: Text -> Markdown +uri = Markdown $ Just Uri + +textWithUri :: Spec +textWithUri = describe "text with Uri" do + it "correct markdown" do + parseMarkdown "https://simplex.chat" `shouldBe` uri "https://simplex.chat" + parseMarkdown "http://simplex.chat" `shouldBe` uri "http://simplex.chat" + parseMarkdown "this is https://simplex.chat" `shouldBe` "this is " <> uri "https://simplex.chat" + parseMarkdown "https://simplex.chat site" `shouldBe` uri "https://simplex.chat" <> " site" + it "ignored as markdown" do + parseMarkdown "_https://simplex.chat" `shouldBe` "_https://simplex.chat" + parseMarkdown "this is _https://simplex.chat" `shouldBe` "this is _https://simplex.chat"