Re-abstract Algorithm over the term and result types.

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).

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