From 8008be776e602ada681ed16c252bb5a68556bd52 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:12:31 -0400 Subject: [PATCH 01/65] Define Algorithm over AlgorithmF. --- src/Algorithm.hs | 20 +++++++++++++++++--- src/Interpreter.hs | 1 - 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 0fb8ae129..970b9c7d6 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -1,7 +1,21 @@ module Algorithm where -import Control.Monad.Trans.Free -import Operation +import Diff +import Prologue +import Term + +-- | A single step in a diffing algorithm. +data AlgorithmF + a -- ^ The type of leaves in the syntax tree, typically String, but possibly some datatype representing different leaves more precisely. + annotation -- ^ The type of annotations. + f -- ^ The type representing another level of the diffing algorithm. Often Algorithm. + -- | Recursively diff two terms and pass the result to the continuation. + = Recursive (Term a annotation) (Term a annotation) (Diff a annotation -> f) + -- | Diff two dictionaries and pass the result to the continuation. + -- | Diff two arrays and pass the result to the continuation. + | ByIndex [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) + | ByRandomWalkSimilarity [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) + deriving Functor -- | A lazily-produced AST for diffing. -type Algorithm a annotation = Free (Operation a annotation) +type Algorithm a annotation = Free (AlgorithmF a annotation) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 16f396538..f3b43ab52 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -11,7 +11,6 @@ import Data.Record import Data.These import Diff import Info -import Operation import Patch import Prologue hiding (lookup) import SES From 9a14248c084dbcc62d11b98c0c02a5ab29ef569c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:12:58 -0400 Subject: [PATCH 02/65] :fire: Operation. --- semantic-diff.cabal | 1 - src/Operation.hs | 18 ------------------ 2 files changed, 19 deletions(-) delete mode 100644 src/Operation.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 0ba91c38d..277247b9b 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -30,7 +30,6 @@ library , Info , Interpreter , Language - , Operation , Parser , Patch , Patch.Arbitrary diff --git a/src/Operation.hs b/src/Operation.hs deleted file mode 100644 index a718e14ae..000000000 --- a/src/Operation.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Operation where - -import Prologue -import Diff -import Term - --- | A single step in a diffing algorithm. -data Operation - a -- ^ The type of leaves in the syntax tree, typically String, but possibly some datatype representing different leaves more precisely. - annotation -- ^ The type of annotations. - f -- ^ The type representing another level of the diffing algorithm. Often Algorithm. - -- | Recursively diff two terms and pass the result to the continuation. - = Recursive (Term a annotation) (Term a annotation) (Diff a annotation -> f) - -- | Diff two dictionaries and pass the result to the continuation. - -- | Diff two arrays and pass the result to the continuation. - | ByIndex [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) - | ByRandomWalkSimilarity [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) - deriving Functor From f6c8cd81da3f0dd346535b3db420bf90f5d72a34 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:15:18 -0400 Subject: [PATCH 03/65] Add a smart constructor for Recursive operations. --- src/Algorithm.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 970b9c7d6..4a6f7dc7c 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -19,3 +19,6 @@ data AlgorithmF -- | A lazily-produced AST for diffing. type Algorithm a annotation = Free (AlgorithmF a annotation) + +recursively :: Term leaf annotation -> Term leaf annotation -> Algorithm leaf annotation (Diff leaf annotation) +recursively a b = wrap (Recursive a b pure) From d7ab1d017eb9f29545d5bc056d9408083189fc0f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:17:23 -0400 Subject: [PATCH 04/65] :fire: a redundant comment. --- src/Algorithm.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 4a6f7dc7c..3e4e5c329 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -11,7 +11,6 @@ data AlgorithmF f -- ^ The type representing another level of the diffing algorithm. Often Algorithm. -- | Recursively diff two terms and pass the result to the continuation. = Recursive (Term a annotation) (Term a annotation) (Diff a annotation -> f) - -- | Diff two dictionaries and pass the result to the continuation. -- | Diff two arrays and pass the result to the continuation. | ByIndex [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) | ByRandomWalkSimilarity [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) From 1835308f7e78b614688c41de59fe340d8ce4a579 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:38:35 -0400 Subject: [PATCH 05/65] Add a smart constructor for Indexed algorithms. --- src/Algorithm.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 3e4e5c329..500adb878 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -21,3 +21,6 @@ type Algorithm a annotation = Free (AlgorithmF a annotation) recursively :: Term leaf annotation -> Term leaf annotation -> Algorithm leaf annotation (Diff leaf annotation) recursively a b = wrap (Recursive a b pure) + +byIndex :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm leaf annotation [Diff leaf annotation] +byIndex a b = wrap (ByIndex a b pure) From f8ad7ecea10759d36cf1380a889127c54fb975b7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:38:49 -0400 Subject: [PATCH 06/65] Use the smart constructor to diff indexed terms. --- src/Interpreter.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index f3b43ab52..0b315c777 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -34,7 +34,9 @@ constructAndRun construct comparable cost t1 t2 | (category <$> t1) == (category <$> t2) = hylo construct runCofree <$> zipTerms t1 t2 | otherwise = run construct comparable cost $ algorithm a b where - algorithm (Indexed a') (Indexed b') = wrap $! ByIndex a' b' (annotate . Indexed) + algorithm (Indexed a') (Indexed b') = do + diffs <- byIndex a' b' + annotate (Indexed diffs) algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b' algorithm a' b' = wrap $! Recursive (cofree (annotation1 :< a')) (cofree (annotation2 :< b')) pure (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) From 14b38dff8bdafbe9e3b538ec716aff51fd715b36 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:39:33 -0400 Subject: [PATCH 07/65] Use the smart constructor to diff recursively. --- src/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 0b315c777..5611f43e4 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -38,7 +38,7 @@ constructAndRun construct comparable cost t1 t2 diffs <- byIndex a' b' annotate (Indexed diffs) algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b' - algorithm a' b' = wrap $! Recursive (cofree (annotation1 :< a')) (cofree (annotation2 :< b')) pure + algorithm _ _ = recursively t1 t2 (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) annotate = pure . construct . (both annotation1 annotation2 :<) From 6694b800823dc08700145a8b211a8a04f4803170 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:40:17 -0400 Subject: [PATCH 08/65] Add a smart constructor for RWS diffs. --- src/Algorithm.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 500adb878..cf2a29cb7 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -24,3 +24,6 @@ recursively a b = wrap (Recursive a b pure) byIndex :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm leaf annotation [Diff leaf annotation] byIndex a b = wrap (ByIndex a b pure) + +bySimilarity :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm leaf annotation [Diff leaf annotation] +bySimilarity a b = wrap (ByRandomWalkSimilarity a b pure) From fb8d95203f9b9332d0af162a61ffc486e56a664b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:43:36 -0400 Subject: [PATCH 09/65] Replace the type parameters to AlgorithmF. --- src/Algorithm.hs | 18 +++++++++--------- src/Interpreter.hs | 2 +- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index cf2a29cb7..be4072b20 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -6,24 +6,24 @@ import Term -- | A single step in a diffing algorithm. data AlgorithmF - a -- ^ The type of leaves in the syntax tree, typically String, but possibly some datatype representing different leaves more precisely. - annotation -- ^ The type of annotations. + term -- ^ The type of terms. + diff -- ^ The type of diffs. f -- ^ The type representing another level of the diffing algorithm. Often Algorithm. -- | Recursively diff two terms and pass the result to the continuation. - = Recursive (Term a annotation) (Term a annotation) (Diff a annotation -> f) + = Recursive term term (diff -> f) -- | Diff two arrays and pass the result to the continuation. - | ByIndex [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) - | ByRandomWalkSimilarity [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) + | ByIndex [term] [term] ([diff] -> f) + | ByRandomWalkSimilarity [term] [term] ([diff] -> f) deriving Functor -- | A lazily-produced AST for diffing. -type Algorithm a annotation = Free (AlgorithmF a annotation) +type Algorithm term diff = Free (AlgorithmF term diff) -recursively :: Term leaf annotation -> Term leaf annotation -> Algorithm leaf annotation (Diff leaf annotation) +recursively :: Term leaf annotation -> Term leaf annotation -> Algorithm (Term leaf annotation) (Diff leaf annotation) (Diff leaf annotation) recursively a b = wrap (Recursive a b pure) -byIndex :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm leaf annotation [Diff leaf annotation] +byIndex :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm (Term leaf annotation) (Diff leaf annotation) [Diff leaf annotation] byIndex a b = wrap (ByIndex a b pure) -bySimilarity :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm leaf annotation [Diff leaf annotation] +bySimilarity :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm (Term leaf annotation) (Diff leaf annotation) [Diff leaf annotation] bySimilarity a b = wrap (ByRandomWalkSimilarity a b pure) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 5611f43e4..546ea1f4b 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -43,7 +43,7 @@ constructAndRun construct comparable cost t1 t2 annotate = pure . construct . (both annotation1 annotation2 :<) -- | Runs the diff algorithm -run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm leaf (Record fields) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) +run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) run construct comparable cost algorithm = case runFree algorithm of Pure diff -> Just diff Free (Recursive t1 t2 f) -> run construct comparable cost . f $ recur a b where From 9f6fb541a75aee9876e1db238069656ccc572287 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:58:37 -0400 Subject: [PATCH 10/65] Define run by iteration. --- src/Interpreter.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 546ea1f4b..c6e2d683f 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -44,9 +44,8 @@ constructAndRun construct comparable cost t1 t2 -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) -run construct comparable cost algorithm = case runFree algorithm of - Pure diff -> Just diff - Free (Recursive t1 t2 f) -> run construct comparable cost . f $ recur a b where +run construct comparable cost algorithm = (`iter` fmap Just algorithm) $ \case + Recursive t1 t2 f -> f $ recur a b where (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) annotate = construct . (both annotation1 annotation2 :<) @@ -54,9 +53,9 @@ run construct comparable cost algorithm = case runFree algorithm of diffThese = these (pure . Delete) (pure . Insert) (diffTerms construct comparable cost) - Free (ByIndex a b f) -> run construct comparable cost . f $ ses (constructAndRun construct comparable cost) cost a b + ByIndex a b f -> f $ ses (constructAndRun construct comparable cost) cost a b - Free (ByRandomWalkSimilarity a b f) -> run construct comparable cost . f $ rws (constructAndRun construct comparable cost) getLabel a b + ByRandomWalkSimilarity a b f -> f $ rws (constructAndRun construct comparable cost) getLabel a b where getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) From 840720d86e34cc8603fe6f709882bad777ac85ba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 19:48:51 -0400 Subject: [PATCH 11/65] Define a runAlgorithm function. --- src/Interpreter.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index c6e2d683f..2bc7fc49b 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} module Interpreter (Comparable, DiffConstructor, diffTerms) where import Algorithm @@ -59,3 +60,14 @@ run construct comparable cost algorithm = (`iter` fmap Just algorithm) $ \case where getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) + +runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Hashable label) => + (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -> + SES.Cost (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> + (forall b. CofreeF f annotation b -> label) -> + Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -> + a +runAlgorithm recur cost getLabel = iter $ \case + Recursive a b f -> f (maybe (pure (Replace a b)) (wrap . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (pure (Replace a b)) .) . recur))) (galign (unwrap a) (unwrap b))) + ByIndex as bs f -> f (ses recur cost as bs) + ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) From 10e38a8895d15d33e1b1176fd9bbaee42116583e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 19:50:16 -0400 Subject: [PATCH 12/65] Algorithm is defined in the Church encoded free monad. --- src/Algorithm.hs | 3 ++- src/Interpreter.hs | 5 +++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index be4072b20..96d21ce9c 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -1,5 +1,6 @@ module Algorithm where +import Control.Monad.Free.Church import Diff import Prologue import Term @@ -17,7 +18,7 @@ data AlgorithmF deriving Functor -- | A lazily-produced AST for diffing. -type Algorithm term diff = Free (AlgorithmF term diff) +type Algorithm term diff = F (AlgorithmF term diff) recursively :: Term leaf annotation -> Term leaf annotation -> Algorithm (Term leaf annotation) (Diff leaf annotation) (Diff leaf annotation) recursively a b = wrap (Recursive a b pure) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 2bc7fc49b..6221fed6b 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -11,6 +11,7 @@ import Data.RandomWalkSimilarity import Data.Record import Data.These import Diff +import qualified Control.Monad.Free.Church as F import Info import Patch import Prologue hiding (lookup) @@ -45,7 +46,7 @@ constructAndRun construct comparable cost t1 t2 -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) -run construct comparable cost algorithm = (`iter` fmap Just algorithm) $ \case +run construct comparable cost algorithm = (`F.iter` fmap Just algorithm) $ \case Recursive t1 t2 f -> f $ recur a b where (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) annotate = construct . (both annotation1 annotation2 :<) @@ -67,7 +68,7 @@ runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annot (forall b. CofreeF f annotation b -> label) -> Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -> a -runAlgorithm recur cost getLabel = iter $ \case +runAlgorithm recur cost getLabel = F.iter $ \case Recursive a b f -> f (maybe (pure (Replace a b)) (wrap . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (pure (Replace a b)) .) . recur))) (galign (unwrap a) (unwrap b))) ByIndex as bs f -> f (ses recur cost as bs) ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) From 78701ddd9002c63ef55aa067b41727d54fee9079 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 20:08:20 -0400 Subject: [PATCH 13/65] Defines a constructor of algorithms over terms. --- src/Interpreter.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 6221fed6b..a1627f139 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -44,6 +44,15 @@ constructAndRun construct comparable cost t1 t2 (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) annotate = pure . construct . (both annotation1 annotation2 :<) +algorithmWithTerms :: Eq leaf => Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) +algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of + (Indexed a, Indexed b) -> do + diffs <- byIndex a b + annotate (Indexed diffs) + (Leaf a, Leaf b) | a == b -> annotate (Leaf b) + _ -> recursively t1 t2 + where annotate = pure . wrap . (both (extract t1) (extract t2) :<) + -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) run construct comparable cost algorithm = (`F.iter` fmap Just algorithm) $ \case From f9969601e848980ba2b1621d660ff8a0cf23167e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 20:14:33 -0400 Subject: [PATCH 14/65] runAlgorithm receives a constructing function. --- src/Interpreter.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index a1627f139..743bd2769 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -72,12 +72,13 @@ run construct comparable cost algorithm = (`F.iter` fmap Just algorithm) $ \case _ -> Nothing) runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Hashable label) => + (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -> SES.Cost (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> (forall b. CofreeF f annotation b -> label) -> Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -> a -runAlgorithm recur cost getLabel = F.iter $ \case - Recursive a b f -> f (maybe (pure (Replace a b)) (wrap . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (pure (Replace a b)) .) . recur))) (galign (unwrap a) (unwrap b))) +runAlgorithm construct recur cost getLabel = F.iter $ \case + Recursive a b f -> f (maybe (pure (Replace a b)) (construct . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (pure (Replace a b)) .) . recur))) (galign (unwrap a) (unwrap b))) ByIndex as bs f -> f (ses recur cost as bs) ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) From b3d09f538e5fd98d77b76febda75088d814ace15 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 20:14:41 -0400 Subject: [PATCH 15/65] Define run in terms of runAlgorithm. --- src/Interpreter.hs | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 743bd2769..82077ba13 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -55,21 +55,10 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) -run construct comparable cost algorithm = (`F.iter` fmap Just algorithm) $ \case - Recursive t1 t2 f -> f $ recur a b where - (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) - annotate = construct . (both annotation1 annotation2 :<) - - recur a b = maybe (pure (Replace t1 t2)) (annotate . fmap diffThese) (galign a b) - - diffThese = these (pure . Delete) (pure . Insert) (diffTerms construct comparable cost) - - ByIndex a b f -> f $ ses (constructAndRun construct comparable cost) cost a b - - ByRandomWalkSimilarity a b f -> f $ rws (constructAndRun construct comparable cost) getLabel a b - where getLabel (h :< t) = (category h, case t of - Leaf s -> Just s - _ -> Nothing) +run construct comparable cost = runAlgorithm construct (constructAndRun construct comparable cost) cost getLabel . fmap Just + where getLabel (h :< t) = (category h, case t of + Leaf s -> Just s + _ -> Nothing) runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Hashable label) => (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> From 53dfd9a3bd520250c9ff101afdb6350e34ef7f3b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 09:05:17 -0400 Subject: [PATCH 16/65] Extract a function to construct replacements. --- src/Interpreter.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 82077ba13..462362edd 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -68,6 +68,7 @@ runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annot Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -> a runAlgorithm construct recur cost getLabel = F.iter $ \case - Recursive a b f -> f (maybe (pure (Replace a b)) (construct . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (pure (Replace a b)) .) . recur))) (galign (unwrap a) (unwrap b))) + Recursive a b f -> f (maybe (replacing a b) (construct . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (replacing a b) .) . recur))) (galign (unwrap a) (unwrap b))) ByIndex as bs f -> f (ses recur cost as bs) ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) + where replacing = (pure .) . Replace From 663bb97a3ddfc02a4ac35ffba25b3354a06d90e6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 09:25:18 -0400 Subject: [PATCH 17/65] Define a DSL for constructing Patches. --- src/Patch.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/Patch.hs b/src/Patch.hs index c2b38dfaa..8ed640887 100644 --- a/src/Patch.hs +++ b/src/Patch.hs @@ -1,5 +1,8 @@ module Patch ( Patch(..) +, replacing +, inserting +, deleting , after , before , unPatch @@ -18,6 +21,19 @@ data Patch a | Delete a deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable) + +-- DSL + +replacing :: Applicative f => a -> a -> f (Patch a) +replacing = (pure .) . Replace + +inserting :: Applicative f => a -> f (Patch a) +inserting = pure . Insert + +deleting :: Applicative f => a -> f (Patch a) +deleting = pure . Delete + + -- | Return the item from the after side of the patch. after :: Patch a -> Maybe a after = maybeSnd . unPatch From 1ee3dcff66c18fc7f81df382289f174ddede8ee7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 09:25:33 -0400 Subject: [PATCH 18/65] Use the Patch DSL to construct replacements. --- src/Interpreter.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 462362edd..f8dc5c21f 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -71,4 +71,3 @@ runAlgorithm construct recur cost getLabel = F.iter $ \case Recursive a b f -> f (maybe (replacing a b) (construct . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (replacing a b) .) . recur))) (galign (unwrap a) (unwrap b))) ByIndex as bs f -> f (ses recur cost as bs) ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) - where replacing = (pure .) . Replace From b41ae038b9b2f75cfa8c38d1d1601126a3798fb3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 09:26:13 -0400 Subject: [PATCH 19/65] Traverse the recursive structure instead of embedding it. --- src/Interpreter.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index f8dc5c21f..cdff19875 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -60,7 +60,7 @@ run construct comparable cost = runAlgorithm construct (constructAndRun construc Leaf s -> Just s _ -> Nothing) -runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Hashable label) => +runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Traversable f, Hashable label) => (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -> SES.Cost (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> @@ -68,6 +68,8 @@ runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annot Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -> a runAlgorithm construct recur cost getLabel = F.iter $ \case - Recursive a b f -> f (maybe (replacing a b) (construct . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (replacing a b) .) . recur))) (galign (unwrap a) (unwrap b))) + Recursive a b f -> f (maybe (replacing a b) (construct . (both (extract a) (extract b) :<)) $ do + aligned <- galign (unwrap a) (unwrap b) + traverse (these (Just . deleting) (Just . inserting) recur) aligned) ByIndex as bs f -> f (ses recur cost as bs) ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) From 3808b89fe41e6be8c2c70c91f24e784e4d1dc225 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:32:05 -0400 Subject: [PATCH 20/65] Use replacing in diffTerms. --- src/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index cdff19875..77872b8fa 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -27,7 +27,7 @@ type DiffConstructor leaf annotation = CofreeF (Syntax leaf) (Both annotation) ( -- | Diff two terms, given a function that determines whether two terms can be compared and a cost function. diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Diff leaf (Record fields) -diffTerms construct comparable cost a b = fromMaybe (pure $ Replace a b) $ constructAndRun construct comparable cost a b +diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ constructAndRun construct comparable cost a b -- | Constructs an algorithm and runs it constructAndRun :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) From 5acf6ff0f23facfb46e3d89d3fcf3d10549137f3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:32:55 -0400 Subject: [PATCH 21/65] Check for comparability in `diffTerms`. --- src/Interpreter.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 77872b8fa..9080f56ea 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -27,7 +27,9 @@ type DiffConstructor leaf annotation = CofreeF (Syntax leaf) (Both annotation) ( -- | Diff two terms, given a function that determines whether two terms can be compared and a cost function. diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Diff leaf (Record fields) -diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ constructAndRun construct comparable cost a b +diffTerms construct comparable cost a b + | not (comparable a b) = replacing a b + | otherwise = fromMaybe (replacing a b) $ run construct comparable cost (algorithmWithTerms a b) -- | Constructs an algorithm and runs it constructAndRun :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) From d12dd5d56717c638a18febdb347449eda60c11dc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:33:37 -0400 Subject: [PATCH 22/65] Extract the recur function into the where clause. --- src/Interpreter.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 9080f56ea..2b2f773b1 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -57,8 +57,9 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) -run construct comparable cost = runAlgorithm construct (constructAndRun construct comparable cost) cost getLabel . fmap Just - where getLabel (h :< t) = (category h, case t of +run construct comparable cost = runAlgorithm construct recur cost getLabel . fmap Just + where recur = constructAndRun construct comparable cost + getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) From 05b9aee4eaaa00377486c6ec4c74de939801ab86 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:34:14 -0400 Subject: [PATCH 23/65] Guard `recur` on the comparability of its operands. --- src/Interpreter.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 2b2f773b1..2705bf29a 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -58,7 +58,9 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) run construct comparable cost = runAlgorithm construct recur cost getLabel . fmap Just - where recur = constructAndRun construct comparable cost + where recur a b = do + guard (comparable a b) + constructAndRun construct comparable cost a b getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) From c0d702c22d9fb2995a50cff4a845d50652a7630b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:46:48 -0400 Subject: [PATCH 24/65] Add a diffComparableTerms function. --- src/Interpreter.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 2705bf29a..01af0e716 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -31,6 +31,12 @@ diffTerms construct comparable cost a b | not (comparable a b) = replacing a b | otherwise = fromMaybe (replacing a b) $ run construct comparable cost (algorithmWithTerms a b) +diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) +diffComparableTerms construct comparable cost a b + | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b + | comparable a b = run construct comparable cost (algorithmWithTerms a b) + | otherwise = Nothing + -- | Constructs an algorithm and runs it constructAndRun :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) constructAndRun construct comparable cost t1 t2 From 99b076df800100cb65b99755cea9ef6d07786490 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:47:31 -0400 Subject: [PATCH 25/65] Define diffTerms in terms of diffComparableTerms. --- src/Interpreter.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 01af0e716..2d773f1f5 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -27,9 +27,7 @@ type DiffConstructor leaf annotation = CofreeF (Syntax leaf) (Both annotation) ( -- | Diff two terms, given a function that determines whether two terms can be compared and a cost function. diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Diff leaf (Record fields) -diffTerms construct comparable cost a b - | not (comparable a b) = replacing a b - | otherwise = fromMaybe (replacing a b) $ run construct comparable cost (algorithmWithTerms a b) +diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) diffComparableTerms construct comparable cost a b From 7809ae1756720dcfa86645de8c6831148ddfa39a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:54:36 -0400 Subject: [PATCH 26/65] Unpack the annotations &c inline. --- src/Interpreter.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 2d773f1f5..380e867fa 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -41,14 +41,13 @@ constructAndRun construct comparable cost t1 t2 | not $ comparable t1 t2 = Nothing | (category <$> t1) == (category <$> t2) = hylo construct runCofree <$> zipTerms t1 t2 | otherwise = - run construct comparable cost $ algorithm a b where + run construct comparable cost $ algorithm (unwrap t1) (unwrap t2) where algorithm (Indexed a') (Indexed b') = do diffs <- byIndex a' b' annotate (Indexed diffs) algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b' algorithm _ _ = recursively t1 t2 - (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) - annotate = pure . construct . (both annotation1 annotation2 :<) + annotate = pure . construct . (both (extract t1) (extract t2) :<) algorithmWithTerms :: Eq leaf => Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of From 0953d430b944c1468086b76252f825d0fdfd4737 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:56:20 -0400 Subject: [PATCH 27/65] Rearrange the definition of constructAndRun a little. --- src/Interpreter.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 380e867fa..401515283 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -38,16 +38,15 @@ diffComparableTerms construct comparable cost a b -- | Constructs an algorithm and runs it constructAndRun :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) constructAndRun construct comparable cost t1 t2 - | not $ comparable t1 t2 = Nothing | (category <$> t1) == (category <$> t2) = hylo construct runCofree <$> zipTerms t1 t2 - | otherwise = - run construct comparable cost $ algorithm (unwrap t1) (unwrap t2) where - algorithm (Indexed a') (Indexed b') = do - diffs <- byIndex a' b' - annotate (Indexed diffs) - algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b' - algorithm _ _ = recursively t1 t2 - annotate = pure . construct . (both (extract t1) (extract t2) :<) + | comparable t1 t2 = run construct comparable cost $ algorithm (unwrap t1) (unwrap t2) + | otherwise = Nothing + where algorithm (Indexed a') (Indexed b') = do + diffs <- byIndex a' b' + annotate (Indexed diffs) + algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b' + algorithm _ _ = recursively t1 t2 + annotate = pure . construct . (both (extract t1) (extract t2) :<) algorithmWithTerms :: Eq leaf => Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of From 58fe4fdc898ba41ad93dbde91362d4c8e29f23aa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:58:29 -0400 Subject: [PATCH 28/65] Define constructAndRun.algorithm by case analysis. --- src/Interpreter.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 401515283..344347af9 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -41,11 +41,12 @@ constructAndRun construct comparable cost t1 t2 | (category <$> t1) == (category <$> t2) = hylo construct runCofree <$> zipTerms t1 t2 | comparable t1 t2 = run construct comparable cost $ algorithm (unwrap t1) (unwrap t2) | otherwise = Nothing - where algorithm (Indexed a') (Indexed b') = do - diffs <- byIndex a' b' - annotate (Indexed diffs) - algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b' - algorithm _ _ = recursively t1 t2 + where algorithm a b = case (a, b) of + (Indexed a', Indexed b') -> do + diffs <- byIndex a' b' + annotate (Indexed diffs) + (Leaf a', Leaf b') | a' == b' -> annotate $ Leaf b' + _ -> recursively t1 t2 annotate = pure . construct . (both (extract t1) (extract t2) :<) algorithmWithTerms :: Eq leaf => Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) From 47c2bdc60e7a2b92da7c221185e3dec59ee9cc70 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:00:29 -0400 Subject: [PATCH 29/65] Use the diff constructor within algorithmWithTerms to compute costs &c. --- src/Interpreter.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 344347af9..de297ec3e 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -32,7 +32,7 @@ diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffCompar diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) diffComparableTerms construct comparable cost a b | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b - | comparable a b = run construct comparable cost (algorithmWithTerms a b) + | comparable a b = run construct comparable cost (algorithmWithTerms construct a b) | otherwise = Nothing -- | Constructs an algorithm and runs it @@ -49,14 +49,14 @@ constructAndRun construct comparable cost t1 t2 _ -> recursively t1 t2 annotate = pure . construct . (both (extract t1) (extract t2) :<) -algorithmWithTerms :: Eq leaf => Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of +algorithmWithTerms :: Eq leaf => DiffConstructor leaf (Record fields) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) +algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> do diffs <- byIndex a b annotate (Indexed diffs) (Leaf a, Leaf b) | a == b -> annotate (Leaf b) _ -> recursively t1 t2 - where annotate = pure . wrap . (both (extract t1) (extract t2) :<) + where annotate = pure . construct . (both (extract t1) (extract t2) :<) -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) From 1df66429a68e1ff2d5e98035c56310392ddd81fe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:01:25 -0400 Subject: [PATCH 30/65] `run` recurs via `diffComparableTerms`. --- src/Interpreter.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index de297ec3e..1582f05a7 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -61,9 +61,7 @@ algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) run construct comparable cost = runAlgorithm construct recur cost getLabel . fmap Just - where recur a b = do - guard (comparable a b) - constructAndRun construct comparable cost a b + where recur a b = diffComparableTerms construct comparable cost a b getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) From 27786f33269f26e4e082b3a191623a26b91d9e2d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:01:29 -0400 Subject: [PATCH 31/65] :fire: constructAndRun. --- src/Interpreter.hs | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 1582f05a7..9f584abc7 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -35,20 +35,6 @@ diffComparableTerms construct comparable cost a b | comparable a b = run construct comparable cost (algorithmWithTerms construct a b) | otherwise = Nothing --- | Constructs an algorithm and runs it -constructAndRun :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) -constructAndRun construct comparable cost t1 t2 - | (category <$> t1) == (category <$> t2) = hylo construct runCofree <$> zipTerms t1 t2 - | comparable t1 t2 = run construct comparable cost $ algorithm (unwrap t1) (unwrap t2) - | otherwise = Nothing - where algorithm a b = case (a, b) of - (Indexed a', Indexed b') -> do - diffs <- byIndex a' b' - annotate (Indexed diffs) - (Leaf a', Leaf b') | a' == b' -> annotate $ Leaf b' - _ -> recursively t1 t2 - annotate = pure . construct . (both (extract t1) (extract t2) :<) - algorithmWithTerms :: Eq leaf => DiffConstructor leaf (Record fields) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> do From 0598e0727e32afaadda42a9a082be5fd8e2ba6c5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:03:13 -0400 Subject: [PATCH 32/65] algorithmWithTerms does not constrain the annotation type. --- src/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 9f584abc7..e16a05cac 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -35,7 +35,7 @@ diffComparableTerms construct comparable cost a b | comparable a b = run construct comparable cost (algorithmWithTerms construct a b) | otherwise = Nothing -algorithmWithTerms :: Eq leaf => DiffConstructor leaf (Record fields) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) +algorithmWithTerms :: Eq leaf => DiffConstructor leaf a -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) (Diff leaf a) (Diff leaf a) algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> do diffs <- byIndex a b From 7a2c4ed783c47f3d9c6392efc45a98a09fd9eaf3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:06:19 -0400 Subject: [PATCH 33/65] Generalize the Algorithm DSL over the term & diff types. --- src/Algorithm.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 96d21ce9c..592377d6c 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -1,9 +1,7 @@ module Algorithm where import Control.Monad.Free.Church -import Diff import Prologue -import Term -- | A single step in a diffing algorithm. data AlgorithmF @@ -20,11 +18,11 @@ data AlgorithmF -- | A lazily-produced AST for diffing. type Algorithm term diff = F (AlgorithmF term diff) -recursively :: Term leaf annotation -> Term leaf annotation -> Algorithm (Term leaf annotation) (Diff leaf annotation) (Diff leaf annotation) +recursively :: term -> term -> Algorithm term diff diff recursively a b = wrap (Recursive a b pure) -byIndex :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm (Term leaf annotation) (Diff leaf annotation) [Diff leaf annotation] +byIndex :: [term] -> [term] -> Algorithm term diff [diff] byIndex a b = wrap (ByIndex a b pure) -bySimilarity :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm (Term leaf annotation) (Diff leaf annotation) [Diff leaf annotation] +bySimilarity :: [term] -> [term] -> Algorithm term diff [diff] bySimilarity a b = wrap (ByRandomWalkSimilarity a b pure) From 401b78099c4002f291e93ecc2779ed6675b3b2ff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:08:08 -0400 Subject: [PATCH 34/65] Generalize `algorithmWithTerms` over the diff type. --- src/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index e16a05cac..92b716773 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -35,7 +35,7 @@ diffComparableTerms construct comparable cost a b | comparable a b = run construct comparable cost (algorithmWithTerms construct a b) | otherwise = Nothing -algorithmWithTerms :: Eq leaf => DiffConstructor leaf a -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) (Diff leaf a) (Diff leaf a) +algorithmWithTerms :: Eq leaf => (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> do diffs <- byIndex a b From 78a5e8cf32a14238a430dca5b0972bc5cf204c13 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:09:48 -0400 Subject: [PATCH 35/65] Pare `algorithmWithTerms` down to its essentials. --- src/Interpreter.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 92b716773..9207ee5a8 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -35,12 +35,11 @@ diffComparableTerms construct comparable cost a b | comparable a b = run construct comparable cost (algorithmWithTerms construct a b) | otherwise = Nothing -algorithmWithTerms :: Eq leaf => (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff +algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> do diffs <- byIndex a b annotate (Indexed diffs) - (Leaf a, Leaf b) | a == b -> annotate (Leaf b) _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) From 360863cc2181af6a27700cffc6e8fe411515b3d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:11:12 -0400 Subject: [PATCH 36/65] Define `diffComparableTerms` in terms of `runAlgorithm`. --- src/Interpreter.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 9207ee5a8..d356cdeee 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -32,8 +32,12 @@ diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffCompar diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) diffComparableTerms construct comparable cost a b | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b - | comparable a b = run construct comparable cost (algorithmWithTerms construct a b) + | comparable a b = runAlgorithm construct recur cost getLabel (Just <$> algorithmWithTerms construct a b) | otherwise = Nothing + where recur a b = diffComparableTerms construct comparable cost a b + getLabel (h :< t) = (category h, case t of + Leaf s -> Just s + _ -> Nothing) algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of From d9a1bd29f265ef04e5509835923d871181680600 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:11:22 -0400 Subject: [PATCH 37/65] :fire: `run`. --- src/Interpreter.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index d356cdeee..af5179c0d 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -47,14 +47,6 @@ algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) --- | Runs the diff algorithm -run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) -run construct comparable cost = runAlgorithm construct recur cost getLabel . fmap Just - where recur a b = diffComparableTerms construct comparable cost a b - getLabel (h :< t) = (category h, case t of - Leaf s -> Just s - _ -> Nothing) - runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Traversable f, Hashable label) => (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -> From e41a0589d56703e371e10b7ede910a42ca4b2776 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:12:52 -0400 Subject: [PATCH 38/65] Define recur by closing over the higher-order functions. --- src/Interpreter.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index af5179c0d..67baa7dfd 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -30,11 +30,11 @@ diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Catego diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) -diffComparableTerms construct comparable cost a b - | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b - | comparable a b = runAlgorithm construct recur cost getLabel (Just <$> algorithmWithTerms construct a b) - | otherwise = Nothing - where recur a b = diffComparableTerms construct comparable cost a b +diffComparableTerms construct comparable cost = recur + where recur a b + | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b + | comparable a b = runAlgorithm construct recur cost getLabel (Just <$> algorithmWithTerms construct a b) + | otherwise = Nothing getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) From a138cf5ec22f5ac355ff8669dfd380c01e5da550 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:40:27 -0400 Subject: [PATCH 39/65] Split out the Indexed handling into a helper function. --- src/Interpreter.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 67baa7dfd..6ca2f27b1 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -41,11 +41,10 @@ diffComparableTerms construct comparable cost = recur algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of - (Indexed a, Indexed b) -> do - diffs <- byIndex a b - annotate (Indexed diffs) + (Indexed a, Indexed b) -> byIndex Indexed a b _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) + byIndex constructor a b = Algorithm.byIndex a b >>= annotate . constructor runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Traversable f, Hashable label) => (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> From bb40b363ba975cc2cfbe7a92513da34317f9bdd3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:40:35 -0400 Subject: [PATCH 40/65] Diff Array nodes byIndex. --- src/Interpreter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 6ca2f27b1..340430b1a 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -42,6 +42,7 @@ diffComparableTerms construct comparable cost = recur algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> byIndex Indexed a b + (Array a, Array b) -> byIndex Array a b _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) byIndex constructor a b = Algorithm.byIndex a b >>= annotate . constructor From 00e538fadb22ac9f177f3a9e3a1db0e8a4b8b5d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:46:02 -0400 Subject: [PATCH 41/65] =?UTF-8?q?Diff=20Commented=20nodes=E2=80=99=20comme?= =?UTF-8?q?nts=20byIndex.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Interpreter.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 340430b1a..dae64adc6 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -42,6 +42,9 @@ diffComparableTerms construct comparable cost = recur algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> byIndex Indexed a b + (Commented commentsA a, Commented commentsB b) -> do + wrapped <- sequenceA (recursively <$> a <*> b) + byIndex (`Commented` wrapped) commentsA commentsB (Array a, Array b) -> byIndex Array a b _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) From 6f39c764fd5c316deb4b91577433b05163b177c4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:48:17 -0400 Subject: [PATCH 42/65] :fire: a redundant import. --- src/Interpreter.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index dae64adc6..092b80c54 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -2,7 +2,6 @@ module Interpreter (Comparable, DiffConstructor, diffTerms) where import Algorithm -import Category import Data.Align.Generic import Data.Functor.Foldable import Data.Functor.Both From 15460768bd1dea7d1ce4059758a0cae3f0d0c29d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:48:28 -0400 Subject: [PATCH 43/65] =?UTF-8?q?Diff=20switch=20statements=E2=80=99=20cas?= =?UTF-8?q?es=20byIndex.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Interpreter.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 092b80c54..16b0e043b 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -15,7 +15,7 @@ import Info import Patch import Prologue hiding (lookup) import SES -import Syntax +import Syntax as S import Term -- | Returns whether two terms are comparable @@ -41,6 +41,9 @@ diffComparableTerms construct comparable cost = recur algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> byIndex Indexed a b + (S.Switch exprA casesA, S.Switch exprB casesB) -> do + expr <- recursively exprA exprB + byIndex (S.Switch expr) casesA casesB (Commented commentsA a, Commented commentsB b) -> do wrapped <- sequenceA (recursively <$> a <*> b) byIndex (`Commented` wrapped) commentsA commentsB From 970ae647d2bdd02a1a5fbdf45d74a7a1a8444f5f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:51:44 -0400 Subject: [PATCH 44/65] Diff class definitions byIndex. --- src/Interpreter.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 16b0e043b..9cba6379e 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -48,6 +48,10 @@ algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of wrapped <- sequenceA (recursively <$> a <*> b) byIndex (`Commented` wrapped) commentsA commentsB (Array a, Array b) -> byIndex Array a b + (S.Class identifierA paramsA expressionsA, S.Class identifierB paramsB expressionsB) -> do + identifier <- recursively identifierA identifierB + params <- sequenceA (recursively <$> paramsA <*> paramsB) + byIndex (S.Class identifier params) expressionsA expressionsB _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) byIndex constructor a b = Algorithm.byIndex a b >>= annotate . constructor From efeb01e970c05159c2cf1f51269b752accb8fe88 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:53:08 -0400 Subject: [PATCH 45/65] Diff objects byIndex. --- src/Interpreter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 9cba6379e..d9741f598 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -44,6 +44,7 @@ algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (S.Switch exprA casesA, S.Switch exprB casesB) -> do expr <- recursively exprA exprB byIndex (S.Switch expr) casesA casesB + (S.Object a, S.Object b) -> byIndex S.Object a b (Commented commentsA a, Commented commentsB b) -> do wrapped <- sequenceA (recursively <$> a <*> b) byIndex (`Commented` wrapped) commentsA commentsB From ba1601f0891c500bd7531f362a906ff3075ef904 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:54:42 -0400 Subject: [PATCH 46/65] Diff function call arguments byIndex. --- src/Interpreter.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index d9741f598..28cb06a83 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -41,6 +41,9 @@ diffComparableTerms construct comparable cost = recur algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> byIndex Indexed a b + (S.FunctionCall identifierA argsA, S.FunctionCall identifierB argsB) -> do + identifier <- recursively identifierA identifierB + byIndex (S.FunctionCall identifier) argsA argsB (S.Switch exprA casesA, S.Switch exprB casesB) -> do expr <- recursively exprA exprB byIndex (S.Switch expr) casesA casesB From f533059ab2fe58dc7a891b8f8c6fa5064fc41aaa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:00:33 -0400 Subject: [PATCH 47/65] =?UTF-8?q?Diff=20methods=E2=80=99=20parameters=20&?= =?UTF-8?q?=20expressions=20byIndex.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Interpreter.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 28cb06a83..0c8f1a3e9 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -56,6 +56,11 @@ algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of identifier <- recursively identifierA identifierB params <- sequenceA (recursively <$> paramsA <*> paramsB) byIndex (S.Class identifier params) expressionsA expressionsB + (S.Method identifierA paramsA expressionsA, S.Method identifierB paramsB expressionsB) -> do + identifier <- recursively identifierA identifierB + params <- Algorithm.byIndex paramsA paramsB + expressions <- Algorithm.byIndex expressionsA expressionsB + annotate $! S.Method identifier params expressions _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) byIndex constructor a b = Algorithm.byIndex a b >>= annotate . constructor From 494274315dc44bf8c187b1479499ccbc8a76e376 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:06:15 -0400 Subject: [PATCH 48/65] Rename ByRandomWalkSimilarity to BySimilarity. --- src/Algorithm.hs | 4 ++-- src/Interpreter.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 592377d6c..a8e02ade8 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -12,7 +12,7 @@ data AlgorithmF = Recursive term term (diff -> f) -- | Diff two arrays and pass the result to the continuation. | ByIndex [term] [term] ([diff] -> f) - | ByRandomWalkSimilarity [term] [term] ([diff] -> f) + | BySimilarity [term] [term] ([diff] -> f) deriving Functor -- | A lazily-produced AST for diffing. @@ -25,4 +25,4 @@ byIndex :: [term] -> [term] -> Algorithm term diff [diff] byIndex a b = wrap (ByIndex a b pure) bySimilarity :: [term] -> [term] -> Algorithm term diff [diff] -bySimilarity a b = wrap (ByRandomWalkSimilarity a b pure) +bySimilarity a b = wrap (BySimilarity a b pure) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 0c8f1a3e9..d4264797c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -77,4 +77,4 @@ runAlgorithm construct recur cost getLabel = F.iter $ \case aligned <- galign (unwrap a) (unwrap b) traverse (these (Just . deleting) (Just . inserting) recur) aligned) ByIndex as bs f -> f (ses recur cost as bs) - ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) + BySimilarity as bs f -> f (rws recur getLabel as bs) From dfd807c945ef537bb02cc03b78427f989d760b44 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:07:19 -0400 Subject: [PATCH 49/65] Clarify the :memo: for ByIndex. --- src/Algorithm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index a8e02ade8..4324832e9 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -10,7 +10,7 @@ data AlgorithmF f -- ^ The type representing another level of the diffing algorithm. Often Algorithm. -- | Recursively diff two terms and pass the result to the continuation. = Recursive term term (diff -> f) - -- | Diff two arrays and pass the result to the continuation. + -- | Diff two lists by each element’s position, and pass the resulting list of diffs to the continuation. | ByIndex [term] [term] ([diff] -> f) | BySimilarity [term] [term] ([diff] -> f) deriving Functor From b4683ffc4fd1a5f056e5ea46a81c2688b581885b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:07:24 -0400 Subject: [PATCH 50/65] :memo: BySimilarity. --- src/Algorithm.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 4324832e9..94fe707c3 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -12,6 +12,7 @@ data AlgorithmF = Recursive term term (diff -> f) -- | Diff two lists by each element’s position, and pass the resulting list of diffs to the continuation. | ByIndex [term] [term] ([diff] -> f) + -- | Diff two lists by each element’s similarity and pass the resulting list of diffs to the continuation. | BySimilarity [term] [term] ([diff] -> f) deriving Functor From e1bb2297af232945c06043b84443b57cdf6bc4eb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:08:18 -0400 Subject: [PATCH 51/65] :memo: the Algorithm DSL. --- src/Algorithm.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 94fe707c3..77542eea6 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -19,11 +19,14 @@ data AlgorithmF -- | A lazily-produced AST for diffing. type Algorithm term diff = F (AlgorithmF term diff) +-- | Constructs a 'Recursive' diff of two terms. recursively :: term -> term -> Algorithm term diff diff recursively a b = wrap (Recursive a b pure) +-- | Constructs a 'ByIndex' diff of two lists of terms. byIndex :: [term] -> [term] -> Algorithm term diff [diff] byIndex a b = wrap (ByIndex a b pure) +-- | Constructs a 'BySimilarity' diff of two lists of terms. bySimilarity :: [term] -> [term] -> Algorithm term diff [diff] bySimilarity a b = wrap (BySimilarity a b pure) From e23b78f1bc5ef2b9a9c118b2b421b9e59f1cd4c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:08:34 -0400 Subject: [PATCH 52/65] Section header for the DSL. --- src/Algorithm.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 77542eea6..3692e9559 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -19,6 +19,9 @@ data AlgorithmF -- | A lazily-produced AST for diffing. type Algorithm term diff = F (AlgorithmF term diff) + +-- DSL + -- | Constructs a 'Recursive' diff of two terms. recursively :: term -> term -> Algorithm term diff diff recursively a b = wrap (Recursive a b pure) From 49d0fa798046d5205c376d0669550358f0c90db3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:10:19 -0400 Subject: [PATCH 53/65] Correct the :memo: of Algorithm. --- src/Algorithm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 3692e9559..c196f6d79 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -16,7 +16,7 @@ data AlgorithmF | BySimilarity [term] [term] ([diff] -> f) deriving Functor --- | A lazily-produced AST for diffing. +-- | The free monad for 'AlgorithmF'. This enables us to construct diff values using do-notation. We use the Church-encoded free monad 'F' for efficiency. type Algorithm term diff = F (AlgorithmF term diff) From 04a3d5200729a512856d3060dd6609b208a37b4d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:13:48 -0400 Subject: [PATCH 54/65] :memo: diffTerms. --- src/Interpreter.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index d4264797c..d8f1ddd18 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -24,8 +24,14 @@ type Comparable leaf annotation = Term leaf annotation -> Term leaf annotation - -- | Constructs a diff from the CofreeF containing its annotation and syntax. This function has the opportunity to, for example, cache properties in the annotation. type DiffConstructor leaf annotation = CofreeF (Syntax leaf) (Both annotation) (Diff leaf annotation) -> Diff leaf annotation --- | Diff two terms, given a function that determines whether two terms can be compared and a cost function. -diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Diff leaf (Record fields) +-- | Diff two terms recursively, given functions characterizing the diffing. +diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => + DiffConstructor leaf (Record fields) -> -- ^ A function to wrap up & possibly annotate every produced diff. + Comparable leaf (Record fields) -> -- ^ A function to determine whether or not two terms should even be compared. + SES.Cost (Diff leaf (Record fields)) -> -- ^ A function to compute the cost of a given diff node. + Term leaf (Record fields) -> -- ^ A term representing the old state. + Term leaf (Record fields) -> -- ^ A term representing the new state. + Diff leaf (Record fields) diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) From 7378668b2c116ca798ee188db95e52a698a435c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:25:56 -0400 Subject: [PATCH 55/65] Put the = before the first constructor. --- src/Syntax.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index b5b6e39ed..1357e2d8e 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -11,9 +11,8 @@ import SourceSpan data Syntax a -- ^ The type of leaves in the syntax tree, typically String, but possibly some datatype representing different leaves more precisely. f -- ^ The type representing another level of the tree, e.g. the children of branches. Often Cofree or Fix or similar. - = -- | A terminal syntax node, e.g. an identifier, or atomic literal. - Leaf a + = Leaf a -- | An ordered branch of child nodes, expected to be variadic in the grammar, e.g. a list of statements or uncurried function parameters. | Indexed [f] -- | An ordered branch of child nodes, expected to be of fixed length in the grammar, e.g. a binary operator & its operands. From af34a7bf1ccdcfbc99d204afa00ec615916d5a45 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:26:07 -0400 Subject: [PATCH 56/65] Haddock-friendly docs for Syntax. --- src/Syntax.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index 1357e2d8e..d7cc56f0c 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -8,9 +8,10 @@ import Test.QuickCheck hiding (Fixed) import SourceSpan -- | A node in an abstract syntax tree. -data Syntax - a -- ^ The type of leaves in the syntax tree, typically String, but possibly some datatype representing different leaves more precisely. - f -- ^ The type representing another level of the tree, e.g. the children of branches. Often Cofree or Fix or similar. +-- +-- 'a' is the type of leaves in the syntax tree, typically 'Text', but possibly some datatype representing different leaves more precisely. +-- 'f' is the type representing another level of the tree, e.g. the children of branches. Often 'Cofree', 'Free' or similar. +data Syntax a f -- | A terminal syntax node, e.g. an identifier, or atomic literal. = Leaf a -- | An ordered branch of child nodes, expected to be variadic in the grammar, e.g. a list of statements or uncurried function parameters. From d2cbccede25e79a1e49593c7e81a2b378cee13e5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:30:23 -0400 Subject: [PATCH 57/65] Haddock-friendly :memo: for rws. --- src/Data/RandomWalkSimilarity.hs | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/src/Data/RandomWalkSimilarity.hs b/src/Data/RandomWalkSimilarity.hs index 6f95a90bf..6c71c9cfd 100644 --- a/src/Data/RandomWalkSimilarity.hs +++ b/src/Data/RandomWalkSimilarity.hs @@ -18,16 +18,12 @@ import Test.QuickCheck hiding (Fixed) import Test.QuickCheck.Random -- | Given a function comparing two terms recursively, and a function to compute a Hashable label from an unpacked term, compute the diff of a pair of lists of terms using a random walk similarity metric, which completes in log-linear time. This implementation is based on the paper [_RWS-Diff—Flexible and Efficient Change Detection in Hierarchical Data_](https://github.com/github/semantic-diff/files/325837/RWS-Diff.Flexible.and.Efficient.Change.Detection.in.Hierarchical.Data.pdf). -rws :: (Hashable label, Eq annotation, Prologue.Foldable f, Functor f, Eq (f (Cofree f annotation))) => - -- | A function which comapres a pair of terms recursively, returning 'Just' their diffed value if appropriate, or 'Nothing' if they should not be compared. - (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -> - -- | A function to compute a label for an unpacked term. - (forall b. CofreeF f annotation b -> label) -> - -- | The old list of terms. - [Cofree f annotation] -> - -- | The new list of terms. - [Cofree f annotation] -> - [Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))] +rws :: (Hashable label, Eq annotation, Prologue.Foldable f, Functor f, Eq (f (Cofree f annotation))) + => (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -- ^ A function which comapres a pair of terms recursively, returning 'Just' their diffed value if appropriate, or 'Nothing' if they should not be compared. + -> (forall b. CofreeF f annotation b -> label) -- ^ A function to compute a label for an unpacked term. + -> [Cofree f annotation] -- ^ The list of old terms. + -> [Cofree f annotation] -- ^ The list of new terms. + -> [Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))] rws compare getLabel as bs | null as, null bs = [] | null as = insert <$> bs From e0da05538ee61898bbd016bdc77b2bb4154fae98 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:31:18 -0400 Subject: [PATCH 58/65] Haddock-friendly :memo: of AlgorithmF. --- src/Algorithm.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index c196f6d79..0f98ac5c7 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -4,10 +4,11 @@ import Control.Monad.Free.Church import Prologue -- | A single step in a diffing algorithm. -data AlgorithmF - term -- ^ The type of terms. - diff -- ^ The type of diffs. - f -- ^ The type representing another level of the diffing algorithm. Often Algorithm. +-- +-- 'term' is the type of terms. +-- 'diff' is the type of diffs. +-- 'f' represents the continuation after diffing. Often 'Algorithm'. +data AlgorithmF term diff f -- | Recursively diff two terms and pass the result to the continuation. = Recursive term term (diff -> f) -- | Diff two lists by each element’s position, and pass the resulting list of diffs to the continuation. From 11a3f324325839cc91f47d71a7bcc1d4fb6a1f66 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:33:09 -0400 Subject: [PATCH 59/65] Haddock-friendly :memo: of diffTerms. --- src/Interpreter.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index d8f1ddd18..3162c38a1 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -25,13 +25,13 @@ type Comparable leaf annotation = Term leaf annotation -> Term leaf annotation - type DiffConstructor leaf annotation = CofreeF (Syntax leaf) (Both annotation) (Diff leaf annotation) -> Diff leaf annotation -- | Diff two terms recursively, given functions characterizing the diffing. -diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => - DiffConstructor leaf (Record fields) -> -- ^ A function to wrap up & possibly annotate every produced diff. - Comparable leaf (Record fields) -> -- ^ A function to determine whether or not two terms should even be compared. - SES.Cost (Diff leaf (Record fields)) -> -- ^ A function to compute the cost of a given diff node. - Term leaf (Record fields) -> -- ^ A term representing the old state. - Term leaf (Record fields) -> -- ^ A term representing the new state. - Diff leaf (Record fields) +diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) + => DiffConstructor leaf (Record fields) -- ^ A function to wrap up & possibly annotate every produced diff. + -> Comparable leaf (Record fields) -- ^ A function to determine whether or not two terms should even be compared. + -> SES.Cost (Diff leaf (Record fields)) -- ^ A function to compute the cost of a given diff node. + -> Term leaf (Record fields) -- ^ A term representing the old state. + -> Term leaf (Record fields) -- ^ A term representing the new state. + -> Diff leaf (Record fields) diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) From 071e9568f0bc375a922443bddd7356c4c07b05b1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:42:26 -0400 Subject: [PATCH 60/65] :memo: runAlgorithm. --- src/Interpreter.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 3162c38a1..f7f97a968 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -71,13 +71,14 @@ algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of where annotate = pure . construct . (both (extract t1) (extract t2) :<) byIndex constructor a b = Algorithm.byIndex a b >>= annotate . constructor -runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Traversable f, Hashable label) => - (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> - (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -> - SES.Cost (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> - (forall b. CofreeF f annotation b -> label) -> - Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -> - a +-- | Run an algorithm, given functions characterizing the evaluation. +runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Traversable f, Hashable label) + => (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -- ^ A function to wrap up & possibly annotate every produced diff. + -> (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -- ^ A function to diff two subterms recursively, if they are comparable, or else return 'Nothing'. + -> SES.Cost (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -- ^ A function to compute the cost of a given diff node. + -> (forall b. CofreeF f annotation b -> label) -- ^ A function to compute a label for a given term. + -> Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -- ^ The algorithm to run. + -> a runAlgorithm construct recur cost getLabel = F.iter $ \case Recursive a b f -> f (maybe (replacing a b) (construct . (both (extract a) (extract b) :<)) $ do aligned <- galign (unwrap a) (unwrap b) From 9374ed5a4a2cf97d8bd3ccbfc4ec155f7bedaa3c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:47:56 -0400 Subject: [PATCH 61/65] :memo: algorithmWithTerms. --- src/Interpreter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index f7f97a968..4ef568168 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -44,6 +44,7 @@ diffComparableTerms construct comparable cost = recur Leaf s -> Just s _ -> Nothing) +-- | Construct an algorithm to diff a pair of terms. algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> byIndex Indexed a b From 26b5f5b41bfcc3d8c17490b9b2bf1869d1058110 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:48:27 -0400 Subject: [PATCH 62/65] :memo: diffComparableTerms. --- src/Interpreter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 4ef568168..3c15317c3 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -34,6 +34,7 @@ diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Catego -> Diff leaf (Record fields) diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b +-- | Diff two terms recursively, given functions characterizing the diffing. If the terms are incomparable, returns 'Nothing'. diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) diffComparableTerms construct comparable cost = recur where recur a b From 6b84266ac6669bde7cf28dbf15b1d1a1c22c3ef5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:51:05 -0400 Subject: [PATCH 63/65] :memo: the Patch DSL. --- src/Patch.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Patch.hs b/src/Patch.hs index 8ed640887..c4dcc8e69 100644 --- a/src/Patch.hs +++ b/src/Patch.hs @@ -24,12 +24,15 @@ data Patch a -- DSL +-- | Constructs the replacement of one value by another in an Applicative context. replacing :: Applicative f => a -> a -> f (Patch a) replacing = (pure .) . Replace +-- | Constructs the insertion of a value in an Applicative context. inserting :: Applicative f => a -> f (Patch a) inserting = pure . Insert +-- | Constructs the deletion of a value in an Applicative context. deleting :: Applicative f => a -> f (Patch a) deleting = pure . Delete From c308cd2b0149a90608b34ce892855f7ba48b1e63 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:51:36 -0400 Subject: [PATCH 64/65] Use the Patch DSL in SES. --- src/SES.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/SES.hs b/src/SES.hs index 5c59470f6..97ad55d1a 100644 --- a/src/SES.hs +++ b/src/SES.hs @@ -38,8 +38,8 @@ diffAt diffTerms cost (i, j) as bs | null bs = pure $ foldr delete [] as | otherwise = pure [] where - delete = consWithCost cost . pure . Delete - insert = consWithCost cost . pure . Insert + delete = consWithCost cost . deleting + insert = consWithCost cost . inserting costOf [] = 0 costOf ((_, c) : _) = c best = minimumBy (comparing costOf) From a6f8194b14e3e353bb8cfc94ee1734191792541d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:51:41 -0400 Subject: [PATCH 65/65] Use the Patch DSL in RWS. --- src/Data/RandomWalkSimilarity.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Data/RandomWalkSimilarity.hs b/src/Data/RandomWalkSimilarity.hs index 6c71c9cfd..6b10ffe36 100644 --- a/src/Data/RandomWalkSimilarity.hs +++ b/src/Data/RandomWalkSimilarity.hs @@ -26,12 +26,10 @@ rws :: (Hashable label, Eq annotation, Prologue.Foldable f, Functor f, Eq (f (Co -> [Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))] rws compare getLabel as bs | null as, null bs = [] - | null as = insert <$> bs - | null bs = delete <$> as + | null as = inserting <$> bs + | null bs = deleting <$> as | otherwise = fmap snd . uncurry deleteRemaining . (`runState` (negate 1, fas)) $ traverse findNearestNeighbourTo fbs - where insert = pure . Insert - delete = pure . Delete - (p, q, d) = (2, 2, 15) + where (p, q, d) = (2, 2, 15) fas = zipWith featurize [0..] as fbs = zipWith featurize [0..] bs kdas = KdTree.build (Vector.toList . feature) fas @@ -39,14 +37,14 @@ rws compare getLabel as bs findNearestNeighbourTo kv@(UnmappedTerm _ _ v) = do (previous, unmapped) <- get let (UnmappedTerm i _ _) = KdTree.nearest kdas kv - fromMaybe (pure (negate 1, insert v)) $ do + fromMaybe (pure (negate 1, inserting v)) $ do found <- find ((== i) . termIndex) unmapped guard (i >= previous) compared <- compare (term found) v pure $! do put (i, List.delete found unmapped) pure (i, compared) - deleteRemaining diffs (_, unmapped) = foldl' (flip (List.insertBy (comparing fst))) diffs ((termIndex &&& delete . term) <$> unmapped) + deleteRemaining diffs (_, unmapped) = foldl' (flip (List.insertBy (comparing fst))) diffs ((termIndex &&& deleting . term) <$> unmapped) -- | A term which has not yet been mapped by `rws`, along with its feature vector summary & index. data UnmappedTerm a = UnmappedTerm { termIndex :: {-# UNPACK #-} !Int, feature :: !(Vector.Vector Double), term :: !a }