diff.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}

import Data.Function (on)
import Data.List (maximumBy)


class Container f where
  data Context f :: * -> *
  children :: f a -> [(a, Context f a)]
  plugIn :: a -> Context f a -> f a
  childAt :: f a -> Context f a -> a

newtype Rec f = Rec { runRec :: f (Rec f) }

deriving instance (Eq (f (Rec f))) => Eq (Rec f)

deriving instance (Show (f (Rec f))) => Show (Rec f)

type Step f = Context f (Rec f)

data Change f = Skip (Step f) | Take (Step f) | Replace (Rec f) (Rec f)

deriving instance (Show (Context f (Rec f)), Show (Rec f)) => Show (Change f)

type Path f = [Change f]

type InContext f = (Rec f, Path f)

subs :: (Container f) => Rec f -> [InContext f]
subs (Rec x) | null $ children x = [(Rec x, [])]
             | otherwise = [ s | (x', ctx) <- children x,
                                 (x'', ctxs) <- subs x',
                                 s <- [(x'', Skip ctx:ctxs), (Rec $ plugIn x'' ctx, Take ctx:ctxs)] ]

type ChangeSet f = (Path f, Path f)

common :: (Container f, Eq (Rec f)) => [InContext f] -> [InContext f] -> [ChangeSet f]
common xs ys = [ (p1, p2) | (s1, p1) <- xs, (s2, p2) <- ys, s1 == s2 ]

takes :: Path f -> Path f
takes = filter take where
  take (Take _) = True
  take _ = False

size :: ChangeSet f -> Int
size (xs, ys) = length (takes xs) + length (takes ys)

largest :: [ChangeSet f] -> ChangeSet f
largest = maximumBy (compare `on` size)

diff :: (Container f, Eq (Rec f)) => Rec f -> Rec f -> ChangeSet f
diff old new = largest $ (common `on` subs) old new


patch :: (Container f, Eq (Rec f)) => Rec f -> ChangeSet f -> Rec f
patch old (inserts, deletes) = foldr wrap (unwrap old inserts) deletes where
  wrap (Skip _) x = x
  wrap (Take ctx) x = Rec $ plugIn x ctx
  wrap (Replace x y) _ = y
  unwrap x [] = x
  unwrap x (Skip ctx:cs) = Rec $ plugIn (unwrap (childAt (runRec x) ctx) cs) ctx
  unwrap x (Take ctx:cs) = unwrap (childAt (runRec x) ctx) cs
  unwrap _ (Replace x y:cs) = unwrap x cs






diff2 :: (Container f, Eq (Context f (Rec f))) => Rec f -> Rec f -> ChangeSet f
diff2 old new 
  | null $ children $ runRec old = ([], [Replace old new])
  | null $ children $ runRec new = ([Replace old new], [])
  | otherwise = let matches = [ (x', y', ctx1)  
                              | (x', ctx1) <- children $ runRec old 
                              , (y', ctx2) <- children $ runRec new
                              , ctx1 == ctx2 ] in
                if null matches then
                  largest $ [ let (xs, ys) = diff2 x' new in (Skip ctx:xs, ys)
                            | (x',ctx) <- children $ runRec old ] ++
                            [ let (xs, ys) = diff2 old y' in (xs, Skip ctx:ys)
                            | (y',ctx) <- children $ runRec new ]
                else
                  largest [ let (xs, ys) = diff2 x' y' in (Take ctx:xs, Take ctx:ys) 
                          | (x', y', ctx) <- matches ]








data ListF a x = Nil | Cons a x deriving (Show, Eq)

type List a = Rec (ListF a)

instance Container (ListF a) where
  data Context (ListF a) x = ListContext a deriving (Show)
  children Nil = []
  children (Cons a x) = [(x, ListContext a)]
  plugIn x (ListContext a) = Cons a x
  childAt (Cons _ x) (ListContext _) = x

nil = Rec Nil

cons a x = Rec $ Cons a x

fromList = foldr cons nil

toList (Rec Nil) = []
toList (Rec (Cons a x)) = (a:toList x)




data ExprF x = App x x | Abst String x | Var String deriving (Show, Eq)

type Expr a = Rec ExprF

instance Container ExprF where
  data Context ExprF x = AppContext (Either x x) | AbstContext String deriving (Show, Eq)
  children (App f x) = [(f, AppContext $ Right x), (x, AppContext $ Left f)]
  children (Abst i x) = [(x, AbstContext i)]
  children (Var _) = []
  plugIn x (AppContext (Left f)) = App f x
  plugIn f (AppContext (Right x)) = App f x
  plugIn x (AbstContext i) = Abst i x
  childAt (App _ x) (AppContext (Left _)) = x
  childAt (App f _) (AppContext (Right _)) = f
  childAt (Abst _ x) (AbstContext _) = x

abst i x = Rec $ Abst i x

app f x = Rec $ App f x

var i = Rec $ Var i

k = abst "x" $ abst "y" $ var "x"

s = abst "x" $ abst "y" $ abst "z" $ app (app (var "x") (var "z")) (app (var "y") (var "z"))

silly = 
  (app 
  (app 
  (app 
  (app 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var ""))) 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var "")))) 
  (app 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var ""))) 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var ""))))) 
  (app 
  (app 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var ""))) 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var "")))) 
  (app 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var ""))) 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var "")))))) 
  (app 
  (app 
  (app 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var ""))) 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var "")))) 
  (app 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var ""))) 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var ""))))) 
  (app 
  (app 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var ""))) 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var "")))) 
  (app 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var ""))) 
  (app 
  (app (var "") (var "")) 
  (app (var "") (var "")))))))