Diff.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
module Test.Hspec.Core.Formatters.Diff (
  Diff (..)
, diff

, LineDiff(..)
, lineDiff

, splitLines

#ifdef TEST
, partition
, breakList
#endif
) where

import           Prelude ()
import           Test.Hspec.Core.Compat

import           Data.Char
import qualified Data.Algorithm.Diff as Diff

data Diff = First String | Second String | Both String
  deriving (Eq, Show)

data LineDiff =
    LinesFirst [String]
  | LinesSecond [String]
  | LinesBoth [String]
  | SingleLineDiff [Diff]
  | LinesOmitted Int
  deriving (Eq, Show)

lineDiff :: Maybe Int -> String -> String -> [LineDiff]
lineDiff context expected actual = maybe id applyContext context $ singleLineDiffs diffs
  where
    diffs :: [LineDiff]
    diffs = Diff.getGroupedDiff expectedLines actualLines <&> \ case
      Diff.First xs -> LinesFirst xs
      Diff.Second xs -> LinesSecond xs
      Diff.Both xs _ -> LinesBoth xs

    expectedLines :: [String]
    expectedLines = splitLines expected

    actualLines :: [String]
    actualLines = splitLines actual

singleLineDiffs :: [LineDiff] -> [LineDiff]
singleLineDiffs = go
  where
    go = \ case
      [] -> []
      LinesFirst [first_] : LinesSecond [second_] : xs -> SingleLineDiff (diff first_ second_) : go xs
      x : xs -> x : go xs

splitLines :: String -> [String]
splitLines = go
  where
    go :: String -> [String]
    go xs = case break (== '\n') xs of
      (ys, '\n' : zs) -> ys : go zs
      _ -> [xs]

data TrimMode = FirstChunk | Chunk | LastChunk

applyContext :: Int -> [LineDiff] -> [LineDiff]
applyContext context = \ diffs -> case diffs of
  [] -> []
  x : xs -> trimChunk FirstChunk x (go xs)
  where
    omitThreshold :: Int
    omitThreshold = 3

    go :: [LineDiff] -> [LineDiff]
    go diffs = case diffs of
      [] -> []
      [x] -> trimChunk LastChunk x []
      x : xs -> trimChunk Chunk x (go xs)

    trimChunk :: TrimMode -> LineDiff -> [LineDiff] -> [LineDiff]
    trimChunk mode chunk = case chunk of
      LinesBoth allLines | meetsThreshold -> keep start . (LinesOmitted omitted :) . keep end
        where
          meetsThreshold :: Bool
          meetsThreshold = omitThreshold <= omitted

          lastLineHasNL = case (mode, reverse allLines) of
            (LastChunk, "" : _) -> True
            _ -> False

          omitted :: Int
          omitted = n - keepStart - keepEnd

          keepStart :: Int
          keepStart = case mode of
            FirstChunk -> 0
            _ -> context

          keepEnd :: Int
          keepEnd = case mode of
            LastChunk -> 0
            _ -> context

          n :: Int
          n = length allLines - case lastLineHasNL of
            False -> 0
            True -> 1

          start :: [String]
          start = take keepStart allLines

          end :: [String]
          end = drop (keepStart + omitted) allLines

      _ -> (chunk :)

keep :: [String] -> [LineDiff] -> [LineDiff]
keep xs
  | null xs = id
  | otherwise = (LinesBoth xs :)

diff :: String -> String -> [Diff]
diff expected actual = diffs
  where
    diffs :: [Diff]
    diffs = map (toDiff . fmap concat) $ Diff.getGroupedDiff expectedChunks actualChunks

    expectedChunks :: [String]
    expectedChunks = partition expected

    actualChunks :: [String]
    actualChunks = partition actual

toDiff :: Diff.Diff String -> Diff
toDiff d = case d of
  Diff.First xs -> First xs
  Diff.Second xs -> Second xs
  Diff.Both xs _ -> Both xs

partition :: String -> [String]
partition = filter (not . null) . mergeBackslashes . breakList isAlphaNum
  where
    mergeBackslashes :: [String] -> [String]
    mergeBackslashes xs = case xs of
      ['\\'] : (splitEscape -> Just (escape, ys)) : zs -> ("\\" ++ escape) : ys : mergeBackslashes zs
      z : zs -> z : mergeBackslashes zs
      [] -> []

breakList :: (a -> Bool) -> [a] -> [[a]]
breakList _ [] = []
breakList p xs = case break p xs of
  (y, ys) -> map return y ++ case span p ys of
    (z, zs) -> z `cons` breakList p zs
  where
    cons x
      | null x = id
      | otherwise = (x :)

splitEscape :: String -> Maybe (String, String)
splitEscape xs = splitNumericEscape xs <|> msum (map split escapes)
  where
    split :: String -> Maybe (String, String)
    split escape = (,) escape <$> stripPrefix escape xs

splitNumericEscape :: String -> Maybe (String, String)
splitNumericEscape xs = case span isDigit xs of
  ("", _) -> Nothing
  r -> Just r

escapes :: [String]
escapes = [
    "ACK"
  , "CAN"
  , "DC1"
  , "DC2"
  , "DC3"
  , "DC4"
  , "DEL"
  , "DLE"
  , "ENQ"
  , "EOT"
  , "ESC"
  , "ETB"
  , "ETX"
  , "NAK"
  , "NUL"
  , "SOH"
  , "STX"
  , "SUB"
  , "SYN"
  , "EM"
  , "FS"
  , "GS"
  , "RS"
  , "SI"
  , "SO"
  , "US"
  , "a"
  , "b"
  , "f"
  , "n"
  , "r"
  , "t"
  , "v"
  , "&"
  , "'"
  , "\""
  , "\\"
  ]