Skip to content

@paf31 /diff.hs
Last active

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
{-# 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 "")))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.