mirror of
https://github.com/github/semantic.git
synced 2025-01-04 21:47:07 +03:00
Fully apply the diff parameter.
This commit is contained in:
Rob Rix
parent
8e6c2e2789
commit
995bcd6dea
@ -15,36 +15,36 @@ 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 term diff ann1 ann2 result where
|
||||
data AlgorithmF term diff result where
|
||||
-- | Diff two terms with the choice of algorithm left to the interpreter’s discretion.
|
||||
Diff :: term ann1 -> term ann2 -> AlgorithmF term diff ann1 ann2 (diff ann1 ann2)
|
||||
Diff :: term ann1 -> term ann2 -> AlgorithmF term (diff ann1 ann2) (diff ann1 ann2)
|
||||
-- | Diff two terms recursively in O(n) time, resulting in a single diff node.
|
||||
Linear :: term ann1 -> term ann2 -> AlgorithmF term diff ann1 ann2 (diff ann1 ann2)
|
||||
Linear :: term ann1 -> term ann2 -> AlgorithmF term (diff ann1 ann2) (diff ann1 ann2)
|
||||
-- | Diff two lists of terms by each element’s similarity in O(n³ log n), resulting in a list of diffs.
|
||||
RWS :: [term ann1] -> [term ann2] -> AlgorithmF term diff ann1 ann2 [diff ann1 ann2]
|
||||
RWS :: [term ann1] -> [term ann2] -> AlgorithmF term (diff ann1 ann2) [diff ann1 ann2]
|
||||
-- | Delete a term..
|
||||
Delete :: term ann1 -> AlgorithmF term diff ann1 ann2 (diff ann1 ann2)
|
||||
Delete :: term ann1 -> AlgorithmF term (diff ann1 ann2) (diff ann1 ann2)
|
||||
-- | Insert a term.
|
||||
Insert :: term ann2 -> AlgorithmF term diff ann1 ann2 (diff ann1 ann2)
|
||||
Insert :: term ann2 -> AlgorithmF term (diff ann1 ann2) (diff ann1 ann2)
|
||||
-- | Replace one term with another.
|
||||
Replace :: term ann1 -> term ann2 -> AlgorithmF term diff ann1 ann2 (diff ann1 ann2)
|
||||
Replace :: term ann1 -> term ann2 -> AlgorithmF term (diff ann1 ann2) (diff ann1 ann2)
|
||||
|
||||
-- | The free applicative for 'AlgorithmF'. This enables us to construct diff values using <$> and <*> notation.
|
||||
type Algorithm term diff ann1 ann2 = Freer (AlgorithmF term diff ann1 ann2)
|
||||
type Algorithm term diff = Freer (AlgorithmF term diff)
|
||||
|
||||
|
||||
-- DSL
|
||||
|
||||
-- | Diff two terms without specifying the algorithm to be used.
|
||||
diff :: term ann1 -> term ann2 -> Algorithm term diff ann1 ann2 (diff ann1 ann2)
|
||||
diff :: term ann1 -> term ann2 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
|
||||
diff = (liftF .) . Algorithm.Diff
|
||||
|
||||
-- | Diff a These of terms without specifying the algorithm to be used.
|
||||
diffThese :: These (term ann1) (term ann2) -> Algorithm term diff ann1 ann2 (diff ann1 ann2)
|
||||
diffThese :: These (term ann1) (term ann2) -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
|
||||
diffThese = these byDeleting byInserting diff
|
||||
|
||||
-- | Diff a pair of optional terms without specifying the algorithm to be used.
|
||||
diffMaybe :: Maybe (term ann1) -> Maybe (term ann2) -> Algorithm term diff ann1 ann2 (Maybe (diff ann1 ann2))
|
||||
diffMaybe :: Maybe (term ann1) -> Maybe (term ann2) -> Algorithm term (diff ann1 ann2) (Maybe (diff ann1 ann2))
|
||||
diffMaybe a b = case (a, b) of
|
||||
(Just a, Just b) -> Just <$> diff a b
|
||||
(Just a, _) -> Just <$> byDeleting a
|
||||
@ -52,27 +52,27 @@ diffMaybe a b = case (a, b) of
|
||||
_ -> pure Nothing
|
||||
|
||||
-- | Diff two terms linearly.
|
||||
linearly :: term ann1 -> term ann2 -> Algorithm term diff ann1 ann2 (diff ann1 ann2)
|
||||
linearly :: term ann1 -> term ann2 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
|
||||
linearly a b = liftF (Linear a b)
|
||||
|
||||
-- | Diff two terms using RWS.
|
||||
byRWS :: [term ann1] -> [term ann2] -> Algorithm term diff ann1 ann2 [diff ann1 ann2]
|
||||
byRWS :: [term ann1] -> [term ann2] -> Algorithm term (diff ann1 ann2) [diff ann1 ann2]
|
||||
byRWS a b = liftF (RWS a b)
|
||||
|
||||
-- | Delete a term.
|
||||
byDeleting :: term ann1 -> Algorithm term diff ann1 ann2 (diff ann1 ann2)
|
||||
byDeleting :: term ann1 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
|
||||
byDeleting = liftF . Delete
|
||||
|
||||
-- | Insert a term.
|
||||
byInserting :: term ann2 -> Algorithm term diff ann1 ann2 (diff ann1 ann2)
|
||||
byInserting :: term ann2 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
|
||||
byInserting = liftF . Insert
|
||||
|
||||
-- | Replace one term with another.
|
||||
byReplacing :: term ann1 -> term ann2 -> Algorithm term diff ann1 ann2 (diff ann1 ann2)
|
||||
byReplacing :: term ann1 -> term ann2 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
|
||||
byReplacing = (liftF .) . Replace
|
||||
|
||||
|
||||
instance (Show1 term, Show ann1, Show ann2) => Show1 (AlgorithmF term diff ann1 ann2) where
|
||||
instance (Show1 term, Show ann1, Show ann2) => Show1 (AlgorithmF term (diff ann1 ann2)) where
|
||||
liftShowsPrec _ _ d algorithm = case algorithm of
|
||||
Algorithm.Diff t1 t2 -> showsBinaryWith showsTerm showsTerm "Diff" d t1 t2
|
||||
Linear t1 t2 -> showsBinaryWith showsTerm showsTerm "Linear" d t1 t2
|
||||
@ -89,23 +89,23 @@ instance (Show1 term, Show ann1, Show ann2) => Show1 (AlgorithmF term diff ann1
|
||||
algorithmForTerms :: (Functor syntax, Diffable syntax)
|
||||
=> Term syntax ann1
|
||||
-> Term syntax ann2
|
||||
-> Algorithm (Term syntax) (Diff syntax) ann1 ann2 (Diff syntax ann1 ann2)
|
||||
-> Algorithm (Term syntax) (Diff syntax ann1 ann2) (Diff syntax ann1 ann2)
|
||||
algorithmForTerms t1 t2 = fromMaybe (byReplacing t1 t2) (algorithmForComparableTerms t1 t2)
|
||||
|
||||
algorithmForComparableTerms :: (Functor syntax, Diffable syntax)
|
||||
=> Term syntax ann1
|
||||
-> Term syntax ann2
|
||||
-> Maybe (Algorithm (Term syntax) (Diff syntax) ann1 ann2 (Diff syntax ann1 ann2))
|
||||
-> Maybe (Algorithm (Term syntax) (Diff syntax ann1 ann2) (Diff syntax ann1 ann2))
|
||||
algorithmForComparableTerms (Term (In ann1 f1)) (Term (In ann2 f2)) = fmap (merge (ann1, ann2)) <$> algorithmFor f1 f2
|
||||
|
||||
|
||||
-- | A type class for determining what algorithm to use for diffing two terms.
|
||||
class Diffable f where
|
||||
algorithmFor :: f (term ann1) -> f (term ann2) -> Maybe (Algorithm term diff ann1 ann2 (f (diff ann1 ann2)))
|
||||
default algorithmFor :: (Generic1 f, GDiffable (Rep1 f)) => f (term ann1) -> f (term ann2) -> Maybe (Algorithm term diff ann1 ann2 (f (diff ann1 ann2)))
|
||||
algorithmFor :: f (term ann1) -> f (term ann2) -> Maybe (Algorithm term (diff ann1 ann2) (f (diff ann1 ann2)))
|
||||
default algorithmFor :: (Generic1 f, GDiffable (Rep1 f)) => f (term ann1) -> f (term ann2) -> Maybe (Algorithm term (diff ann1 ann2) (f (diff ann1 ann2)))
|
||||
algorithmFor = genericAlgorithmFor
|
||||
|
||||
genericAlgorithmFor :: (Generic1 f, GDiffable (Rep1 f)) => f (term ann1) -> f (term ann2) -> Maybe (Algorithm term diff ann1 ann2 (f (diff ann1 ann2)))
|
||||
genericAlgorithmFor :: (Generic1 f, GDiffable (Rep1 f)) => f (term ann1) -> f (term ann2) -> Maybe (Algorithm term (diff ann1 ann2) (f (diff ann1 ann2)))
|
||||
genericAlgorithmFor a b = fmap to1 <$> galgorithmFor (from1 a) (from1 b)
|
||||
|
||||
|
||||
@ -122,7 +122,7 @@ instance Diffable [] where
|
||||
|
||||
-- | A generic type class for diffing two terms defined by the Generic1 interface.
|
||||
class GDiffable f where
|
||||
galgorithmFor :: f (term ann1) -> f (term ann2) -> Maybe (Algorithm term diff ann1 ann2 (f (diff ann1 ann2)))
|
||||
galgorithmFor :: f (term ann1) -> f (term ann2) -> Maybe (Algorithm term (diff ann1 ann2) (f (diff ann1 ann2)))
|
||||
|
||||
-- | 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
|
||||
|
||||
@ -161,19 +161,19 @@ instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
|
||||
algorithmDeletingContext :: (Apply1 Diffable fs, Apply1 Functor fs, Context :< fs)
|
||||
=> TermF Context ann1 (Term (Union fs) ann1)
|
||||
-> Term (Union fs) ann2
|
||||
-> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs)) ann1 ann2 (TermF Context ann1 (Diff (Union fs) ann1 ann2)))
|
||||
-> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs) ann1 ann2) (TermF Context ann1 (Diff (Union fs) ann1 ann2)))
|
||||
algorithmDeletingContext (In a1 (Context n1 s1)) s2 = fmap (In a1 . Context (deleting <$> n1)) <$> algorithmForComparableTerms s1 s2
|
||||
|
||||
algorithmInsertingContext :: (Apply1 Diffable fs, Apply1 Functor fs, Context :< fs)
|
||||
=> Term (Union fs) ann1
|
||||
-> TermF Context ann2 (Term (Union fs) ann2)
|
||||
-> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs)) ann1 ann2 (TermF Context ann2 (Diff (Union fs) ann1 ann2)))
|
||||
-> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs) ann1 ann2) (TermF Context ann2 (Diff (Union fs) ann1 ann2)))
|
||||
algorithmInsertingContext s1 (In a2 (Context n2 s2)) = fmap (In a2 . Context (inserting <$> n2)) <$> algorithmForComparableTerms s1 s2
|
||||
|
||||
algorithmForContextUnions :: (Apply1 Diffable fs, Apply1 Functor fs, Context :< fs)
|
||||
=> Term (Union fs) ann1
|
||||
-> Term (Union fs) ann2
|
||||
-> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs)) ann1 ann2 (Diff (Union fs) ann1 ann2))
|
||||
-> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs) ann1 ann2) (Diff (Union fs) ann1 ann2))
|
||||
algorithmForContextUnions t1 t2
|
||||
| Just algo <- algorithmForComparableTerms t1 t2 = Just algo
|
||||
| Just c1@(In _ Context{}) <- prjTermF (unTerm t1) = fmap (deleteF . hoistTermF inj) <$> algorithmDeletingContext c1 t2
|
||||
|
||||
@ -41,13 +41,13 @@ decoratingWith getLabel1 getLabel2 differ t1 t2 = stripDiff (differ (defaultFeat
|
||||
-- | Diff a pair of terms recurisvely, using the supplied continuation and 'ComparabilityRelation'.
|
||||
diffTermsWith :: forall syntax fields1 fields2
|
||||
. (Eq1 syntax, GAlign syntax, Traversable syntax)
|
||||
=> (Term syntax (Record (FeatureVector ': fields1)) -> Term syntax (Record (FeatureVector ': fields2)) -> Algorithm (Term syntax) (Diff syntax) (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)) (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)))) -- ^ A function producing syntax-directed continuations of the algorithm.
|
||||
=> (Term syntax (Record (FeatureVector ': fields1)) -> Term syntax (Record (FeatureVector ': fields2)) -> Algorithm (Term syntax) (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))) (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)))) -- ^ A function producing syntax-directed continuations of the algorithm.
|
||||
-> ComparabilityRelation syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)) -- ^ A relation on terms used to determine comparability and equality.
|
||||
-> Term syntax (Record (FeatureVector ': fields1)) -- ^ A term representing the old state.
|
||||
-> Term syntax (Record (FeatureVector ': fields2)) -- ^ A term representing the new state.
|
||||
-> Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)) -- ^ The resulting diff.
|
||||
diffTermsWith refine comparable t1 t2 = runFreer decompose (diff t1 t2)
|
||||
where decompose :: AlgorithmF (Term syntax) (Diff syntax) (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)) result -> Algorithm (Term syntax) (Diff syntax) (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)) result
|
||||
where decompose :: AlgorithmF (Term syntax) (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))) result -> Algorithm (Term syntax) (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))) result
|
||||
decompose step = case step of
|
||||
Algorithm.Diff t1 t2 -> refine t1 t2
|
||||
Linear t1 t2 -> case galignWith diffThese (unwrap t1) (unwrap t2) of
|
||||
@ -68,7 +68,7 @@ getLabel (In h t) = (Info.category h, case t of
|
||||
-- | Construct an algorithm to diff a pair of terms.
|
||||
algorithmWithTerms :: Term Syntax ann1
|
||||
-> Term Syntax ann2
|
||||
-> Algorithm (Term Syntax) (Diff Syntax) ann1 ann2 (Diff Syntax ann1 ann2)
|
||||
-> Algorithm (Term Syntax) (Diff Syntax ann1 ann2) (Diff Syntax ann1 ann2)
|
||||
algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of
|
||||
(Indexed a, Indexed b) ->
|
||||
annotate . Indexed <$> byRWS a b
|
||||
|
||||
Loading…
Reference in New Issue
Block a user