{-# 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)
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 =
mconcat
[ above wrapping multilineContext x y,
separator separatorText,
below wrapping multilineContext x y
]
above :: Wrapping -> MultilineContext -> Text -> Text -> Text
above wrapping multilineContext x y =
let xs = Text.lines x
ys = Text.lines y
in sameLength xs ys
& map ((\(x, y) -> (x, wrap wrapping y)) . above')
& extractContext multilineContext (False, [], [])
& Text.unlines
& Text.dropAround (== '\n')
above' :: (Maybe Text, Maybe Text) -> (Bool, [Text])
above' (Nothing, Just y) =
(True, withDiffLine First down (if y == "" then [Diff.Second ' '] else map Diff.Second $ Text.unpack y))
above' (Just x, Nothing) =
(True, withDiffLine First down (if x == "" then [Diff.First ' '] else map Diff.First $ Text.unpack x))
above' (Just x, Just y) =
let diffs =
Diff.getDiff
(Text.unpack x)
(Text.unpack y)
in ( any hasDiff diffs,
withDiffLine First down diffs
)
below :: Wrapping -> MultilineContext -> Text -> Text -> Text
below wrapping multilineContext x y =
let xs = Text.lines x
ys = Text.lines y
in sameLength xs ys
& map ((\(x, y) -> (x, wrap wrapping y)) . below')
& extractContext multilineContext (False, [], [])
& Text.unlines
& Text.dropAround (== '\n')
below' :: (Maybe Text, Maybe Text) -> (Bool, [Text])
below' (Nothing, Just y) =
(True, withDiffLine Second up (if y == "" then [Diff.Second ' '] else map Diff.Second $ Text.unpack y))
below' (Just x, Nothing) =
(True, withDiffLine Second up (if x == "" then [Diff.First ' '] else map Diff.First $ Text.unpack x))
below' (Just x, Just y) =
let diffs =
Diff.getDiff
(Text.unpack x)
(Text.unpack y)
in ( any hasDiff diffs,
withDiffLine Second up diffs
)
wrap :: Wrapping -> [Text] -> Text
wrap wrapping text =
Text.stripEnd $ case wrapping of
Wrap n ->
text
& fmap (Text.chunksOf n)
& interleaveLists
& filter
( \x ->
not (Text.null (Text.dropAround (== ' ') x) && Text.length x >= n)
)
& Text.unlines
NoWrap -> Text.unlines 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 -> filterEmptyLines [Text.pack indicators & Text.stripEnd, Text.pack content & Text.stripEnd]
Second -> filterEmptyLines [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]
(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] ++ takeRight n xs
else
if length xs <= n
then xs
else [sep] ++ takeRight n xs
takeRight :: Int -> [a] -> [a]
takeRight i xs = reverse (take i (reverse xs))
hasDiff :: Diff.Diff Char -> Bool
hasDiff d =
case d of
Diff.First _ -> True
Diff.Second x -> True
Diff.Both x _ -> False
separator :: Maybe Text -> Text
separator maybeComparison =
[ "\n╷\n",
"│" <> (fromMaybe "" $ ((<>) " ") <$> maybeComparison),
"\n╵\n"
]
& mconcat
interleaveLists :: [[a]] -> [a]
interleaveLists = mconcat . transpose
filterEmptyLines :: [Text] -> [Text]
filterEmptyLines = filter (not . Text.null . Text.strip)
sameLength :: [a] -> [b] -> [(Maybe a, Maybe b)]
sameLength [] ys = map (\y -> (Nothing, Just y)) ys
sameLength xs [] = map (\x -> (Just x, Nothing)) xs
sameLength (x : xs) (y : ys) = (Just x, Just y) : sameLength xs ys