blade/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2024-12-17 17:20:21 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

simplify types, make changed char have new format

Browse Source
This commit is contained in:
Evgeny Poberezkin
2023-10-02 21:54:56 +01:00
parent 7c73a44a51
commit ef02b27bca
4 changed files with 340 additions and 484 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Markdown.hs
+14 -6
View File
@@ -17,7 +17,7 @@ import qualified Data.Attoparsec.Text as A
import Data.Char (isDigit)
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.List (intercalate, foldl')
import Data.List (foldl', intercalate)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe, isNothing)
@@ -51,8 +51,16 @@ data Format
| SimplexLink {linkType :: SimplexLinkType, simplexUri :: Text, trustedUri :: Bool, smpHosts :: NonEmpty Text}
| Email
| Phone
| Edited EditAction Format
deriving (Eq, Show, Generic)
data EditAction = EAInsert | EADelete | EAChangeFormat
deriving (Eq, Show, Generic)
instance ToJSON EditAction where
toJSON = J.genericToJSON . enumJSON $ dropPrefix "EA"
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "EA"
data SimplexLinkType = XLContact | XLInvitation | XLGroup
deriving (Eq, Show, Generic)
@@ -129,7 +137,7 @@ parseMaybeMarkdownList s
| otherwise = Just . reverse $ foldl' acc [] ml
where
ml = intercalate ["\n"] . map (markdownToList . parseMarkdown) $ T.lines s
acc [] m = [m]
acc [] m = [m]
acc ms@(FormattedText f t : ms') ft@(FormattedText f' t')
| f == f' = FormattedText f (t <> t') : ms'
| otherwise = ft : ms
@@ -170,14 +178,14 @@ markdownP = mconcat <$> A.many' fragmentP
md :: Char -> Format -> Text -> Markdown
md c f s
| T.null s || T.head s == ' ' || T.last s == ' ' =
unmarked $ c `T.cons` s `T.snoc` c
unmarked $ c `T.cons` s `T.snoc` c
| otherwise = markdown f s
secretP :: Parser Markdown
secretP = secret <$> A.takeWhile (== '#') <*> A.takeTill (== '#') <*> A.takeWhile (== '#')
secret :: Text -> Text -> Text -> Markdown
secret b s a
| T.null a || T.null s || T.head s == ' ' || T.last s == ' ' =
unmarked $ '#' `T.cons` ss
unmarked $ '#' `T.cons` ss
| otherwise = markdown Secret $ T.init ss
where
ss = b <> s <> a
@@ -218,8 +226,8 @@ markdownP = mconcat <$> A.many' fragmentP
wordMD s
| T.null s = unmarked s
| isUri s = case strDecode $ encodeUtf8 s of
Right cReq -> markdown (simplexUriFormat cReq) s
_ -> markdown Uri s
Right cReq -> markdown (simplexUriFormat cReq) s
_ -> markdown Uri s
| isEmail s = markdown Email s
| otherwise = unmarked s
isUri s = T.length s >= 10 && any (`T.isPrefixOf` s) ["http://", "https://", "simplex:/"]
src/Simplex/Chat/MarkdownDiff.hs
+37 -59
View File
@@ -7,12 +7,8 @@
module Simplex.Chat.MarkdownDiff
( DiffChar (..),
DiffPlainChar (..),
DiffStatus (..),
DiffPlainStatus (..),
DiffFormatStatus (..),
FormatChar (..),
LeftSide (..),
RightSide (..),
diff,
plainDiff,
)
@@ -20,34 +16,22 @@ where
import qualified Data.Diff.Myers as D
import qualified Data.Foldable as F
import Data.Function ((&))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Sequence (Seq (..), (><))
import qualified Data.Sequence as S
import qualified Data.Text as T
import Simplex.Chat.Markdown (Format)
data DiffStatus
= UnchangedChar DiffFormatStatus
| Inserted
| Deleted
deriving (Show, Eq)
data DiffPlainStatus
= UnchangedP
| InsertedP
| DeletedP
deriving (Show, Eq)
import Simplex.Chat.Markdown (EditAction (..), Format)
data DiffFormatStatus
= UnchangedFormat
| ChangedToFormat (Maybe Format)
deriving (Show, Eq)
data DiffChar = DiffChar FormatChar DiffStatus
data DiffChar = DiffChar FormatChar (Maybe EditAction)
deriving (Show, Eq)
data DiffPlainChar = DiffPlainChar Char DiffPlainStatus
data DiffPlainChar = DiffPlainChar Char (Maybe EditAction)
deriving (Show, Eq)
data FormatChar = FormatChar
@@ -56,48 +40,44 @@ data FormatChar = FormatChar
}
deriving (Show, Eq)
newtype LeftSide a = LeftSide a deriving (Show, Eq)
newtype DeleteIndices = DeleteIndices (Seq Int) deriving (Show, Eq)
newtype RightSide a = RightSide a deriving (Show, Eq)
newtype InsertIndices = InsertIndices (Seq Int) 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
plainDiff :: T.Text -> T.Text -> Seq DiffPlainChar
plainDiff left right = toPlain <$> formattedDiff
where
formattedDiff = diff (LeftSide $ toFormatted left) (RightSide $ toFormatted right)
formattedDiff = diff (toFormatted left) (toFormatted right)
toPlain :: DiffChar -> DiffPlainChar
toPlain (DiffChar (FormatChar c _) diffStatus) = DiffPlainChar c diffStatusPlain
toPlain (DiffChar (FormatChar c _) editAction) = DiffPlainChar c editActionPlain
where
diffStatusPlain = case diffStatus of
UnchangedChar _ -> UnchangedP
Inserted -> InsertedP
Deleted -> DeletedP
editActionPlain = case editAction of
Just EAInsert -> Just EAInsert
Just EADelete -> Just EADelete
Just EAChangeFormat -> Nothing
Nothing -> Nothing
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
diff :: Seq FormatChar -> Seq FormatChar -> Seq DiffChar
diff left right = addInserts markDeletesAndUnchangedChars
where
edits = D.diffTexts (toText left) (toText right)
(DeleteIndicies deleteIndicies, InsertIndicies insertIndicies) = indices
(DeleteIndices deleteIndicies, InsertIndices 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
indices :: (DeleteIndices, InsertIndices)
indices = F.foldl' f (DeleteIndices S.empty, InsertIndices 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]
f :: (DeleteIndices, InsertIndices) -> D.Edit -> (DeleteIndices, InsertIndices)
f (x@(DeleteIndices ds), y@(InsertIndices is)) e = case e of
D.EditDelete m n -> (x', y) where x' = DeleteIndices $ ds >< S.fromList [m .. n]
D.EditInsert _ m n -> (x, y') where y' = InsertIndices $ is >< S.fromList [m .. n]
unchangedChars :: M.Map Int DiffFormatStatus -- indexed in left
unchangedChars :: Map Int DiffFormatStatus -- indexed in left
unchangedChars = F.foldl' f mempty unchangedCharPairs
where
unchangedCharPairs :: Seq (Int, FormatChar, FormatChar)
@@ -105,17 +85,15 @@ diff (LeftSide left) (RightSide right) = addInserts markDeletesAndUnchangedChars
leftWithoutDeletes :: Seq (Int, FormatChar)
leftWithoutDeletes =
left
& S.zip (S.fromList [0 .. S.length left - 1])
& S.filter (\(i, _) -> i `notElem` deleteIndicies)
S.filter (\(i, _) -> i `notElem` deleteIndicies) $
S.zip (S.fromList [0 .. S.length left - 1]) left
rightWithoutInserts :: Seq (Int, FormatChar)
rightWithoutInserts =
right
& S.zip (S.fromList [0 .. S.length right - 1])
& S.filter (\(i, _) -> i `notElem` insertIndicies)
S.filter (\(i, _) -> i `notElem` insertIndicies) $
S.zip (S.fromList [0 .. S.length right - 1]) right
f :: M.Map Int DiffFormatStatus -> (Int, FormatChar, FormatChar) -> M.Map Int DiffFormatStatus
f :: Map Int DiffFormatStatus -> (Int, FormatChar, FormatChar) -> 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
@@ -127,11 +105,11 @@ diff (LeftSide left) (RightSide right) = addInserts markDeletesAndUnchangedChars
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
f i x@(FormatChar c _)
| i `elem` deleteIndicies = DiffChar x (Just EADelete)
| otherwise = case unchangedChars M.! i of -- should never error
UnchangedFormat -> DiffChar x Nothing
ChangedToFormat f' -> DiffChar (FormatChar c f') (Just EAChangeFormat)
addInserts :: Seq DiffChar -> Seq DiffChar
addInserts base = F.foldr f base edits -- start from end and work backwards, hence foldr
where
@@ -150,9 +128,9 @@ diff (LeftSide left) (RightSide right) = addInserts markDeletesAndUnchangedChars
slidePastDeleteBlock x = case S.lookup x acc of
Nothing -> x
Just (DiffChar _ diffStatus) ->
if diffStatus == Deleted
if diffStatus == Just EADelete
then slidePastDeleteBlock (x + 1)
else x
rightFormatChars = S.take (n - m + 1) $ S.drop m right
inserts = fmap (`DiffChar` Inserted) rightFormatChars
inserts = fmap (`DiffChar` Just EAInsert) rightFormatChars