FINAL

need to uncomment tests

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