Patience.hs

-- loosely based on the patience-0.1.1 package which is:
--
--     Copyright (c) Keegan McAllister 2011
--
module Data.Git.Diff.Patience
    ( Item(..)
    , diff
    ) where

import           Data.List
import           Data.Function (on)
import qualified Data.Map      as M
import qualified Data.IntMap   as IM

data Card a = Card !Int a !(Maybe (Card a))

-- sort using patience making stack of card with the list of elements,
-- then take the highest stack (maxView) and flatten the path back into a list
-- to get the longest increasing path
longestIncreasing :: [(Int,a)] -> [(Int,a)]
longestIncreasing =
      maybe [] (flatten . head . fst)
    . IM.maxView
    . foldl' ins IM.empty
  where
    ins :: IM.IntMap [Card a] -> (Int, a) -> IM.IntMap [Card a]
    ins m (x,a) =
        case IM.minViewWithKey gt of
            Nothing        -> IM.insert x [new] m
            Just ((k,_),_) ->
                case IM.updateLookupWithKey (\_ _ -> Nothing) k m of
                    (Just v, mm) -> IM.insert x (new : v) mm
                    (Nothing, _) -> m
      where
            (lt, gt) = IM.split x m
            prev = (head . fst) `fmap` IM.maxView lt
            new  = Card x a prev

    flatten :: Card a -> [(Int, a)]
    flatten (Card x a c) = (x,a) : maybe [] flatten c

-- Type for decomposing a diff problem.  We either have two
-- lines that match, or a recursive subproblem.
data Piece a =
      Match !a !a
    | Diff [a] [a]
    deriving (Show)

-- Get the longest common subsequence
lcs :: Ord t => [t] -> [t] -> [Piece t]
lcs ma mb =
      chop ma mb
    $ longestIncreasing
    $ sortBy (compare `on` snd)
    $ M.elems
    $ M.intersectionWith (,) (unique ma) (unique mb)
  where
    unique = M.mapMaybe id . foldr ins M.empty . zip [0..]
      where
        ins (a,x) = M.insertWith (\_ _ -> Nothing) x (Just a)

    -- Subdivides a diff problem according to the indices of matching lines.
    chop :: [t] -> [t] -> [(Int,Int)] -> [Piece t]
    chop xs ys []
        | null xs && null ys = []
        | otherwise = [Diff xs ys]
    chop xs ys ((nx,ny):ns) =
        let (xsr, (x : xse)) = splitAt nx xs
            (ysr, (y : yse)) = splitAt ny ys
         in  Diff xse yse : Match x y : chop xsr ysr ns

-- | An element of a computed difference.
data Item t =
      Old  !t
    | New  !t
    | Both !t !t
    deriving (Show,Eq)

instance Functor Item where
    fmap f (Old  x)   = Old  (f x)
    fmap f (New  x)   = New  (f x)
    fmap f (Both x y) = Both (f x) (f y)

-- | The difference between two lists using the patience algorithm
diff :: Ord t => [t] -> [t] -> [Item t]
diff = matchPrefix []
  where
    -- match the prefix between old and new document
    matchPrefix acc (x:xs) (y:ys)
        | x == y    = Both x y : matchPrefix acc xs ys
    matchPrefix acc l r = matchSuffix acc (reverse l) (reverse r)

    -- match the suffix between old and new document, accumulating the
    -- matched item in a reverse accumulator to keep TCO
    matchSuffix acc (x:xs) (y:ys)
        | x == y = matchSuffix (Both x y : acc) xs ys
    matchSuffix acc l r = diffInner (reverse acc) (reverse l) (reverse r)

    -- prefix and suffix are striped, and now do the LCS
    diffInner acc l r =
        case lcs l r of
            -- If we fail to subdivide, just record the chunk as is.
            [Diff _ _] -> fmap Old l ++ fmap New r ++ acc
            ps -> recur acc ps

    recur acc [] = acc
    recur acc (Match x y  : ps) = recur (Both x y : acc) ps
    recur acc (Diff xs ys : ps) = recur [] ps ++ matchPrefix acc xs ys