hpaste-0.3: DiffHtml.hs

-----------------------------------------------------------------------------
-- |
-- Module      : DiffHtml
-- Copyright   : (c) Eric Mertens 2007
-- License     : BSD3-style (see LICENSE)
-- 
-- Maintainer  : emertens@gmail.com
-- Stability   : unstable
-- Portability : portable
--
-----------------------------------------------------------------------------
--
-- The DiffHtml printer
--

module DiffHtml (htmlDiff, textDiff) where

import Data.Array
import Text.XHtml.Strict hiding ((!))
import qualified Text.XHtml.Strict as X
import qualified Data.ByteString.Char8 as B

tabulate :: (Ix a) => (a,a) -> (a -> b) -> Array a b
tabulate bs f = array bs [(i,f i) | i <- range bs]

dp :: (Ix a) => (a,a) -> ((a->b) -> a -> b) -> a -> b
dp bs f = (memo!)
        where memo = tabulate bs (f (memo!))

textDiff :: [Char] -> [Char] -> [Char]
textDiff xs ys = xs `seq` ys `seq` concat $ map convert $ lcs xs ys
  where
    convert (YPart y) = " +" ++ [y]
    convert (XPart x) = " -" ++ [x]
    convert (MatchPart m) = " " ++ [m]

-- | Diff two bytestrings, render as html
htmlDiff :: B.ByteString -> B.ByteString -> Html
htmlDiff xs ys
        = xs `seq` ys `seq` primHtml
        . unlines
        . map (show . convertDiff) .
        lcs (B.lines xs) $ (B.lines ys)

-- | Mark up a diff
convertDiff :: DiffRes B.ByteString -> Html
convertDiff (YPart y)     = pprDiff "addsub" "+ " y
convertDiff (XPart x)     = pprDiff "delsub" "- " x
convertDiff (MatchPart m) = pprDiff "matchsub" "  " m

-- | And render it
pprDiff :: String -> [Char] -> B.ByteString -> Html
pprDiff c q t = (X.!) thespan [theclass c] << primHtml (q ++ B.unpack t)

------------------------------------------------------------------------

data DiffRes a = YPart !a | XPart !a | MatchPart !a
   deriving (Ord, Eq)

lcs :: Ord a => [a] -> [a] -> [DiffRes a]
{-# SPECIALIZE lcs :: [B.ByteString] -> [B.ByteString] -> [DiffRes B.ByteString] #-}
lcs xs ys = snd $ longest lenx leny xarr yarr (0,0)
  where
    lenx = length xs
    leny = length ys
    xarr = listArray (0,lenx-1) xs
    yarr = listArray (0,leny-1) ys

longest :: Ord a
        => Int -> Int
        -> Array Int a
        -> Array Int a -> (Int, Int)
        -> (Int, [DiffRes a])
longest a b c d| a `seq` b `seq` c `seq` d `seq` False = undefined
longest lenx leny xarr yarr = dp ((0,0),(lenx,leny)) f
  where
    f rec (x,y)
      | x'ge'lenx && y'ge'leny = (0, [])
      | x'ge'lenx              = y'
      | y'ge'leny              = x'
      | xarr ! x == yarr ! y   = max (match $ rec (x+1,y+1)) m
      | otherwise              = m
      where
        m = max y' x'
        x'ge'lenx = x >= lenx
        y'ge'leny = y >= leny

        y' = miss (YPart (yarr ! y)) $ rec (x,y+1)
        x' = miss (XPart (xarr ! x)) $ rec (x+1,y)
        match (n,xs) = (n+1,(MatchPart (yarr ! y)):xs)
        miss z (n,xs) = (n,z:xs)