From 9c1ef71a782b103ebacb1433cef468d8df300834 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Sep 2017 22:24:50 -0400 Subject: [PATCH] Re-abstract Algorithm over the term and result types. --- src/Algorithm.hs | 77 +++++++++++++++++++++++----------------------- src/Interpreter.hs | 6 +++- 2 files changed, 43 insertions(+), 40 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 9de34c8ae..a409f1162 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -4,6 +4,7 @@ module Algorithm where import Control.Applicative (Alternative(..)) import Control.Monad (guard) import Control.Monad.Free.Freer +import Data.Align.Generic import Data.Functor.Classes import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe @@ -15,81 +16,79 @@ import GHC.Generics import Term -- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm. -data AlgorithmF syntax ann1 ann2 result where +data AlgorithmF term1 term2 result partial where -- | Diff two terms with the choice of algorithm left to the interpreter’s discretion. - Diff :: Term syntax ann1 -> Term syntax ann2 -> AlgorithmF syntax ann1 ann2 (Diff syntax ann1 ann2) + Diff :: term1 -> term2 -> AlgorithmF term1 term2 result result -- | Diff two terms recursively in O(n) time, resulting in a single diff node. - Linear :: syntax (Term syntax ann1) -> syntax (Term syntax ann2) -> AlgorithmF syntax ann1 ann2 (syntax (Diff syntax ann1 ann2)) + Linear :: (GAlign syntax, Show1 syntax, Traversable syntax) => syntax term1 -> syntax term2 -> AlgorithmF term1 term2 result (syntax result) -- | Diff two lists of terms by each element’s similarity in O(n³ log n), resulting in a list of diffs. - RWS :: [Term syntax ann1] -> [Term syntax ann2] -> AlgorithmF syntax ann1 ann2 [Diff syntax ann1 ann2] + RWS :: [term1] -> [term2] -> AlgorithmF term1 term2 result [result] -- | Delete a term. - Delete :: Term syntax ann1 -> AlgorithmF syntax ann1 ann2 (Diff syntax ann1 ann2) + Delete :: term1 -> AlgorithmF term1 term2 result result -- | Insert a term. - Insert :: Term syntax ann2 -> AlgorithmF syntax ann1 ann2 (Diff syntax ann1 ann2) + Insert :: term2 -> AlgorithmF term1 term2 result result -- | Replace one term with another. - Replace :: Term syntax ann1 -> Term syntax ann2 -> AlgorithmF syntax ann1 ann2 (Diff syntax ann1 ann2) + Replace :: term1 -> term2 -> AlgorithmF term1 term2 result result -- | An 'Algorithm' that always fails. - Empty :: AlgorithmF syntax ann1 ann2 a + Empty :: AlgorithmF term1 term2 result a -- | An 'Algorithm' to try one of two alternatives. - Alt :: a -> a -> AlgorithmF syntax ann1 ann2 a + Alt :: a -> a -> AlgorithmF term1 term2 result a -- | The free(r) monad for 'AlgorithmF'. This enables us to construct algorithms to diff using '<$>', '<*>', '>>=', and do-notation. -type Algorithm syntax ann1 ann2 = Freer (AlgorithmF syntax ann1 ann2) +type Algorithm term1 term2 result = Freer (AlgorithmF term1 term2 result) -- DSL -- | Diff two terms without specifying the algorithm to be used. -diff :: Term syntax ann1 -> Term syntax ann2 -> Algorithm syntax ann1 ann2 (Diff syntax ann1 ann2) +diff :: term1 -> term2 -> Algorithm term1 term2 result result diff = (liftF .) . Algorithm.Diff -- | Diff a These of terms without specifying the algorithm to be used. -diffThese :: These (Term syntax ann1) (Term syntax ann2) -> Algorithm syntax ann1 ann2 (Diff syntax ann1 ann2) +diffThese :: These term1 term2 -> Algorithm term1 term2 result result diffThese = these byDeleting byInserting diff -- | Diff a pair of optional terms without specifying the algorithm to be used. -diffMaybe :: Maybe (Term syntax ann1) -> Maybe (Term syntax ann2) -> Algorithm syntax ann1 ann2 (Maybe (Diff syntax ann1 ann2)) +diffMaybe :: Maybe term1 -> Maybe term2 -> Algorithm term1 term2 result (Maybe result) diffMaybe (Just a) (Just b) = Just <$> diff a b diffMaybe (Just a) _ = Just <$> byDeleting a diffMaybe _ (Just b) = Just <$> byInserting b diffMaybe _ _ = pure Nothing -- | Diff two terms linearly. -linearly :: Term syntax ann1 -> Term syntax ann2 -> Algorithm syntax ann1 ann2 (Diff syntax ann1 ann2) -linearly (Term (In ann1 f1)) (Term (In ann2 f2)) = merge (ann1, ann2) <$> liftF (Linear f1 f2) +linearly :: (GAlign syntax, Show1 syntax, Traversable syntax) => syntax term1 -> syntax term2 -> Algorithm term1 term2 result (syntax result) +linearly f1 f2 = liftF (Linear f1 f2) -- | Diff two terms using RWS. -byRWS :: [Term syntax ann1] -> [Term syntax ann2] -> Algorithm syntax ann1 ann2 [Diff syntax ann1 ann2] +byRWS :: [term1] -> [term2] -> Algorithm term1 term2 result [result] byRWS a b = liftF (RWS a b) -- | Delete a term. -byDeleting :: Term syntax ann1 -> Algorithm syntax ann1 ann2 (Diff syntax ann1 ann2) +byDeleting :: term1 -> Algorithm term1 term2 result result byDeleting = liftF . Delete -- | Insert a term. -byInserting :: Term syntax ann2 -> Algorithm syntax ann1 ann2 (Diff syntax ann1 ann2) +byInserting :: term2 -> Algorithm term1 term2 result result byInserting = liftF . Insert -- | Replace one term with another. -byReplacing :: Term syntax ann1 -> Term syntax ann2 -> Algorithm syntax ann1 ann2 (Diff syntax ann1 ann2) +byReplacing :: term1 -> term2 -> Algorithm term1 term2 result result byReplacing = (liftF .) . Replace -instance (Show1 syntax, Show ann1, Show ann2) => Show1 (AlgorithmF syntax ann1 ann2) where +instance (Show term1, Show term2) => Show1 (AlgorithmF term1 term2 result) where liftShowsPrec sp _ d algorithm = case algorithm of - Algorithm.Diff t1 t2 -> showsBinaryWith showsTerm showsTerm "Diff" d t1 t2 - Linear t1 t2 -> showsBinaryWith (liftShowsPrec showsTerm (liftShowList showsPrec showList)) (liftShowsPrec showsTerm (liftShowList showsPrec showList)) "Linear" d t1 t2 - RWS as bs -> showsBinaryWith (liftShowsPrec showsTerm (liftShowList showsPrec showList)) (liftShowsPrec showsTerm (liftShowList showsPrec showList)) "RWS" d as bs - Delete t1 -> showsUnaryWith showsTerm "Delete" d t1 - Insert t2 -> showsUnaryWith showsTerm "Insert" d t2 - Replace t1 t2 -> showsBinaryWith showsTerm showsTerm "Replace" d t1 t2 + Algorithm.Diff t1 t2 -> showsBinaryWith showsPrec showsPrec "Diff" d t1 t2 + Linear t1 t2 -> showsBinaryWith (liftShowsPrec showsPrec showList) (liftShowsPrec showsPrec showList) "Linear" d t1 t2 + RWS as bs -> showsBinaryWith (liftShowsPrec showsPrec showList) (liftShowsPrec showsPrec showList) "RWS" d as bs + Delete t1 -> showsUnaryWith showsPrec "Delete" d t1 + Insert t2 -> showsUnaryWith showsPrec "Insert" d t2 + Replace t1 t2 -> showsBinaryWith showsPrec showsPrec "Replace" d t1 t2 Empty -> showString "Empty" Alt a b -> showsBinaryWith sp sp "Alt" d a b - where showsTerm :: (Show1 syntax, Show ann) => Int -> Term syntax ann -> ShowS - showsTerm = liftShowsPrec showsPrec showList -instance Alternative (Algorithm syntax ann1 ann2) where +instance Alternative (Algorithm term1 term2 result) where empty = Empty `Then` return (Empty `Then` _) <|> b = b @@ -102,7 +101,7 @@ instance Alternative (Algorithm syntax ann1 ann2) where algorithmForTerms :: Diffable syntax => Term syntax ann1 -> Term syntax ann2 - -> Algorithm syntax ann1 ann2 (Diff syntax ann1 ann2) + -> Algorithm (Term syntax ann1) (Term syntax ann2) (Diff syntax ann1 ann2) (Diff syntax ann1 ann2) algorithmForTerms t1@(Term (In ann1 f1)) t2@(Term (In ann2 f2)) = mergeFor t1 t2 <|> deleteF . In ann1 <$> subalgorithmFor byDeleting (flip mergeFor t2) f1 @@ -111,14 +110,14 @@ algorithmForTerms t1@(Term (In ann1 f1)) t2@(Term (In ann2 f2)) -- | A type class for determining what algorithm to use for diffing two terms. class Diffable f where - algorithmFor :: f (Term syntax ann1) - -> f (Term syntax ann2) - -> Algorithm syntax ann1 ann2 (f (Diff syntax ann1 ann2)) + algorithmFor :: f term1 + -> f term2 + -> Algorithm term1 term2 result (f result) default algorithmFor :: (Generic1 f, GDiffable (Rep1 f)) - => f (Term syntax ann1) - -> f (Term syntax ann2) - -> Algorithm syntax ann1 ann2 (f (Diff syntax ann1 ann2)) + => f term1 + -> f term2 + -> Algorithm term1 term2 result (f result) algorithmFor = genericAlgorithmFor subalgorithmFor :: Alternative g @@ -128,7 +127,7 @@ class Diffable f where -> g (f b) subalgorithmFor _ _ _ = empty -genericAlgorithmFor :: (Generic1 f, GDiffable (Rep1 f)) => f (Term syntax ann1) -> f (Term syntax ann2) -> Algorithm syntax ann1 ann2 (f (Diff syntax ann1 ann2)) +genericAlgorithmFor :: (Generic1 f, GDiffable (Rep1 f)) => f term1 -> f term2 -> Algorithm term1 term2 result (f result) genericAlgorithmFor a b = to1 <$> galgorithmFor (from1 a) (from1 b) @@ -155,7 +154,7 @@ instance Diffable NonEmpty where -- | A generic type class for diffing two terms defined by the Generic1 interface. class GDiffable f where - galgorithmFor :: f (Term syntax ann1) -> f (Term syntax ann2) -> Algorithm syntax ann1 ann2 (f (Diff syntax ann1 ann2)) + galgorithmFor :: f term1 -> f term2 -> Algorithm term1 term2 result (f result) -- | Diff two constructors (M1 is the Generic1 newtype for meta-information (possibly related to type constructors, record selectors, and data types)) instance GDiffable f => GDiffable (M1 i c f) where @@ -176,7 +175,7 @@ instance (GDiffable f, GDiffable g) => GDiffable (f :+: g) where -- | Diff two parameters (Par1 is the Generic1 newtype representing a type parameter). -- i.e. data Foo a = Foo a (the 'a' is captured by Par1). instance GDiffable Par1 where - galgorithmFor (Par1 a) (Par1 b) = Par1 <$> linearly a b + galgorithmFor (Par1 a) (Par1 b) = Par1 <$> diff a b -- | Diff two constant parameters (K1 is the Generic1 newtype representing type parameter constants). -- i.e. data Foo = Foo Int (the 'Int' is a constant parameter). diff --git a/src/Interpreter.hs b/src/Interpreter.hs index eac0b000d..db1e63e03 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -56,7 +56,11 @@ diffTermsWith comparable eqTerms t1 t2 = fromMaybe (replacing t1 t2) (runAlgorit runAlgorithm :: (Diffable syntax, GAlign syntax, Traversable syntax, Alternative m, Monad m) => ComparabilityRelation syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)) -- ^ A relation on terms used to determine comparability and equality. -> (Term syntax (Record (FeatureVector ': fields1)) -> Term syntax (Record (FeatureVector ': fields2)) -> Bool) -- ^ A relation used to determine term equivalence. - -> Algorithm syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)) (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))) + -> Algorithm + (Term syntax (Record (FeatureVector ': fields1))) + (Term syntax (Record (FeatureVector ': fields2))) + (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))) + (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))) -> m (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))) runAlgorithm comparable eqTerms = go where go = iterFreerA (\ step yield -> case step of