{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Pretty.Diff
(
Config (Config, separatorText, wrapping, multilineContext),
Wrapping (Wrap, NoWrap),
MultilineContext (FullContext, Surrounding),
pretty,
above,
below,
)
where
import qualified Data.Algorithm.Diff as Diff
import Data.Default (Default, def)
import Data.Function ((&))
import Data.List (take, transpose, zipWith)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as Text
import Prelude
data Config = Config
{
separatorText :: Maybe Text,
wrapping :: Wrapping,
multilineContext :: MultilineContext
}
instance Default Config where
def = Config {separatorText = Nothing, wrapping = NoWrap, multilineContext = Surrounding 2 "..."}
data Wrapping
= Wrap Int
| NoWrap
data MultilineContext
= FullContext
| Surrounding Int Text
pretty :: Config -> Text -> Text -> Text
pretty Config {separatorText, wrapping, multilineContext} x y =
let xs = Text.lines x
ys = Text.lines y
in [ zipWith (above' wrapping) xs ys & extractContext multilineContext (False, [], []) & mconcat,
separator separatorText,
zipWith (below' wrapping) xs ys & extractContext multilineContext (False, [], []) & mconcat
]
& mconcat
above :: Wrapping -> Text -> Text -> Text
above wrapping x y =
let (_, res) = above' wrapping x y
in res
above' :: Wrapping -> Text -> Text -> (Bool, Text)
above' wrapping x y =
let diffs =
Diff.getDiff
(Text.unpack x)
(Text.unpack y)
in ( any (hasDiff First) diffs,
withDiffLine First down diffs
& wrap wrapping
& filterEmptyLines
& Text.unlines
)
below :: Wrapping -> Text -> Text -> Text
below wrapping x y =
let (_, res) = below' wrapping x y
in res
below' :: Wrapping -> Text -> Text -> (Bool, Text)
below' wrapping x y =
let diffs =
Diff.getDiff
(Text.unpack x)
(Text.unpack y)
in ( any (hasDiff Second) diffs,
withDiffLine Second up diffs
& wrap wrapping
& filterEmptyLines
& Text.unlines
)
wrap :: Wrapping -> [Text] -> [Text]
wrap wrapping text =
case wrapping of
Wrap n ->
text
& fmap (Text.chunksOf n)
& interleaveLists
NoWrap -> text
down :: Char
down = '▼'
up :: Char
up = '▲'
data Position = First | Second
withDiffLine :: Position -> Char -> [Diff.Diff Char] -> [Text]
withDiffLine pos differ diffs =
let (content, indicators) =
diffs
& mapMaybe (toDiffLine pos differ)
& unzip
in case pos of
First -> [Text.pack indicators & Text.stripEnd, Text.pack content & Text.stripEnd]
Second -> [Text.pack content & Text.stripEnd, Text.pack indicators & Text.stripEnd]
toDiffLine :: Position -> Char -> Diff.Diff Char -> Maybe (Char, Char)
toDiffLine pos c d =
case d of
Diff.First x -> case pos of
First -> Just (x, c)
Second -> Nothing
Diff.Second x -> case pos of
First -> Nothing
Second -> Just (x, c)
Diff.Both x _ -> Just (x, ' ')
extractContext :: MultilineContext -> (Bool, [Text], [Text]) -> [(Bool, Text)] -> [Text]
extractContext FullContext _ xs = map snd xs
extractContext context@(Surrounding c sep) (hadDiff, acc, before) xs =
case xs of
[] ->
if length before <= c
then acc ++ before
else acc ++ take c before ++ [sep, "\n"]
(True, x) : rest ->
extractContext
context
( True,
acc ++ splitSurrounding c sep hadDiff before ++ [x],
[]
)
rest
(False, x) : rest ->
extractContext
context
( hadDiff,
acc,
before ++ [x]
)
rest
splitSurrounding :: Int -> Text -> Bool -> [Text] -> [Text]
splitSurrounding n sep hadDiff xs =
if hadDiff
then
if length xs <= n * 2
then xs
else take n xs ++ [sep, "\n"] ++ takeRight n xs
else
if length xs <= n
then xs
else [sep, "\n"] ++ takeRight n xs
takeRight :: Int -> [a] -> [a]
takeRight i xs = reverse (take i (reverse xs))
hasDiff :: Position -> Diff.Diff Char -> Bool
hasDiff pos d =
case d of
Diff.First _ -> case pos of
First -> True
Second -> False
Diff.Second x -> case pos of
First -> False
Second -> True
Diff.Both x _ -> False
separator :: Maybe Text -> Text
separator maybeComparison =
[ "╷",
"│" <> (fromMaybe "" $ ((<>) " ") <$> maybeComparison),
"╵"
]
& Text.unlines
interleaveLists :: [[a]] -> [a]
interleaveLists = mconcat . transpose
filterEmptyLines :: [Text] -> [Text]
filterEmptyLines = filter (not . Text.null . Text.strip)