mirror of
https://github.com/github/semantic.git
synced 2024-12-11 08:45:48 +03:00
Add a second annotation type parameter to Algorithm.
This commit is contained in:
Rob Rix
parent
bf2de994ac
commit
42b83b0e6d
@ -16,36 +16,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 ann result where
|
||||
data AlgorithmF term diff ann1 ann2 result where
|
||||
-- | Diff two terms with the choice of algorithm left to the interpreter’s discretion.
|
||||
Diff :: term ann -> term ann -> AlgorithmF term diff ann (diff ann)
|
||||
Diff :: term ann -> term ann -> AlgorithmF term diff ann ann (diff ann)
|
||||
-- | Diff two terms recursively in O(n) time, resulting in a single diff node.
|
||||
Linear :: term ann -> term ann -> AlgorithmF term diff ann (diff ann)
|
||||
Linear :: term ann -> term ann -> AlgorithmF term diff ann ann (diff ann)
|
||||
-- | Diff two lists of terms by each element’s similarity in O(n³ log n), resulting in a list of diffs.
|
||||
RWS :: [term ann] -> [term ann] -> AlgorithmF term diff ann [diff ann]
|
||||
RWS :: [term ann] -> [term ann] -> AlgorithmF term diff ann ann [diff ann]
|
||||
-- | Delete a term..
|
||||
Delete :: term ann -> AlgorithmF term diff ann (diff ann)
|
||||
Delete :: term ann -> AlgorithmF term diff ann ann (diff ann)
|
||||
-- | Insert a term.
|
||||
Insert :: term ann -> AlgorithmF term diff ann (diff ann)
|
||||
Insert :: term ann -> AlgorithmF term diff ann ann (diff ann)
|
||||
-- | Replace one term with another.
|
||||
Replace :: term ann -> term ann -> AlgorithmF term diff ann (diff ann)
|
||||
Replace :: term ann -> term ann -> AlgorithmF term diff ann ann (diff ann)
|
||||
|
||||
-- | The free applicative for 'AlgorithmF'. This enables us to construct diff values using <$> and <*> notation.
|
||||
type Algorithm term diff ann = Freer (AlgorithmF term diff ann)
|
||||
type Algorithm term diff ann1 ann2 = Freer (AlgorithmF term diff ann1 ann2)
|
||||
|
||||
|
||||
-- DSL
|
||||
|
||||
-- | Diff two terms without specifying the algorithm to be used.
|
||||
diff :: term ann -> term ann -> Algorithm term diff ann (diff ann)
|
||||
diff :: term ann -> term ann -> Algorithm term diff ann ann (diff ann)
|
||||
diff = (liftF .) . Algorithm.Diff
|
||||
|
||||
-- | Diff a These of terms without specifying the algorithm to be used.
|
||||
diffThese :: These (term ann) (term ann) -> Algorithm term diff ann (diff ann)
|
||||
diffThese :: These (term ann) (term ann) -> Algorithm term diff ann ann (diff ann)
|
||||
diffThese = these byDeleting byInserting diff
|
||||
|
||||
-- | Diff a pair of optional terms without specifying the algorithm to be used.
|
||||
diffMaybe :: Maybe (term ann) -> Maybe (term ann) -> Algorithm term diff ann (Maybe (diff ann))
|
||||
diffMaybe :: Maybe (term ann) -> Maybe (term ann) -> Algorithm term diff ann ann (Maybe (diff ann))
|
||||
diffMaybe a b = case (a, b) of
|
||||
(Just a, Just b) -> Just <$> diff a b
|
||||
(Just a, _) -> Just <$> byDeleting a
|
||||
@ -53,27 +53,27 @@ diffMaybe a b = case (a, b) of
|
||||
_ -> pure Nothing
|
||||
|
||||
-- | Diff two terms linearly.
|
||||
linearly :: term ann -> term ann -> Algorithm term diff ann (diff ann)
|
||||
linearly :: term ann -> term ann -> Algorithm term diff ann ann (diff ann)
|
||||
linearly a b = liftF (Linear a b)
|
||||
|
||||
-- | Diff two terms using RWS.
|
||||
byRWS :: [term ann] -> [term ann] -> Algorithm term diff ann [diff ann]
|
||||
byRWS :: [term ann] -> [term ann] -> Algorithm term diff ann ann [diff ann]
|
||||
byRWS a b = liftF (RWS a b)
|
||||
|
||||
-- | Delete a term.
|
||||
byDeleting :: term ann -> Algorithm term diff ann (diff ann)
|
||||
byDeleting :: term ann -> Algorithm term diff ann ann (diff ann)
|
||||
byDeleting = liftF . Delete
|
||||
|
||||
-- | Insert a term.
|
||||
byInserting :: term ann -> Algorithm term diff ann (diff ann)
|
||||
byInserting :: term ann -> Algorithm term diff ann ann (diff ann)
|
||||
byInserting = liftF . Insert
|
||||
|
||||
-- | Replace one term with another.
|
||||
byReplacing :: term ann -> term ann -> Algorithm term diff ann (diff ann)
|
||||
byReplacing :: term ann -> term ann -> Algorithm term diff ann ann (diff ann)
|
||||
byReplacing = (liftF .) . Replace
|
||||
|
||||
|
||||
instance (Show1 term, Show ann) => Show1 (AlgorithmF term diff ann) where
|
||||
instance (Show1 term, Show ann) => Show1 (AlgorithmF term diff ann ann) 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
|
||||
@ -87,20 +87,20 @@ instance (Show1 term, Show ann) => Show1 (AlgorithmF term diff ann) where
|
||||
|
||||
-- | Diff two terms based on their generic Diffable instances. If the terms are not diffable
|
||||
-- (represented by a Nothing diff returned from algorithmFor) replace one term with another.
|
||||
algorithmForTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Algorithm (Term f) (Diff f) a (Diff f a)
|
||||
algorithmForTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Algorithm (Term f) (Diff f) a a (Diff f a)
|
||||
algorithmForTerms t1 t2 = fromMaybe (byReplacing t1 t2) (algorithmForComparableTerms t1 t2)
|
||||
|
||||
algorithmForComparableTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Maybe (Algorithm (Term f) (Diff f) a (Diff f a))
|
||||
algorithmForComparableTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Maybe (Algorithm (Term f) (Diff f) a a (Diff f a))
|
||||
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 ann) -> f (term ann) -> Maybe (Algorithm term diff ann (f (diff ann)))
|
||||
default algorithmFor :: (Generic1 f, Diffable' (Rep1 f)) => f (term ann) -> f (term ann) -> Maybe (Algorithm term diff ann (f (diff ann)))
|
||||
algorithmFor :: f (term ann) -> f (term ann) -> Maybe (Algorithm term diff ann ann (f (diff ann)))
|
||||
default algorithmFor :: (Generic1 f, Diffable' (Rep1 f)) => f (term ann) -> f (term ann) -> Maybe (Algorithm term diff ann ann (f (diff ann)))
|
||||
algorithmFor = genericAlgorithmFor
|
||||
|
||||
genericAlgorithmFor :: (Generic1 f, Diffable' (Rep1 f)) => f (term ann) -> f (term ann) -> Maybe (Algorithm term diff ann (f (diff ann)))
|
||||
genericAlgorithmFor :: (Generic1 f, Diffable' (Rep1 f)) => f (term ann) -> f (term ann) -> Maybe (Algorithm term diff ann ann (f (diff ann)))
|
||||
genericAlgorithmFor a b = fmap to1 <$> algorithmFor' (from1 a) (from1 b)
|
||||
|
||||
|
||||
@ -117,7 +117,7 @@ instance Diffable [] where
|
||||
|
||||
-- | A generic type class for diffing two terms defined by the Generic1 interface.
|
||||
class Diffable' f where
|
||||
algorithmFor' :: f (term ann) -> f (term ann) -> Maybe (Algorithm term diff ann (f (diff ann)))
|
||||
algorithmFor' :: f (term ann) -> f (term ann) -> Maybe (Algorithm term diff ann ann (f (diff ann)))
|
||||
|
||||
-- | Diff two constructors (M1 is the Generic1 newtype for meta-information (possibly related to type constructors, record selectors, and data types))
|
||||
instance Diffable' f => Diffable' (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 a (Term (Union fs) a)
|
||||
-> Term (Union fs) a
|
||||
-> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs)) a (TermF Context a (Diff (Union fs) a)))
|
||||
-> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs)) a a (TermF Context a (Diff (Union fs) a)))
|
||||
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) a
|
||||
-> TermF Context a (Term (Union fs) a)
|
||||
-> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs)) a (TermF Context a (Diff (Union fs) a)))
|
||||
-> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs)) a a (TermF Context a (Diff (Union fs) a)))
|
||||
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) a
|
||||
-> Term (Union fs) a
|
||||
-> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs)) a (Diff (Union fs) a))
|
||||
-> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs)) a a (Diff (Union fs) a))
|
||||
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 getLabel differ t1 t2 = stripDiff (differ (defaultFeatureVectorDe
|
||||
|
||||
-- | Diff a pair of terms recurisvely, using the supplied continuation and 'ComparabilityRelation'.
|
||||
diffTermsWith :: forall f fields . (Traversable f, GAlign f, Eq1 f, HasField fields FeatureVector)
|
||||
=> (Term f (Record fields) -> Term f (Record fields) -> Algorithm (Term f) (Diff f) (Record fields) (Diff f (Record fields))) -- ^ A function producing syntax-directed continuations of the algorithm.
|
||||
=> (Term f (Record fields) -> Term f (Record fields) -> Algorithm (Term f) (Diff f) (Record fields) (Record fields) (Diff f (Record fields))) -- ^ A function producing syntax-directed continuations of the algorithm.
|
||||
-> ComparabilityRelation f fields -- ^ A relation on terms used to determine comparability and equality.
|
||||
-> Term f (Record fields) -- ^ A term representing the old state.
|
||||
-> Term f (Record fields) -- ^ A term representing the new state.
|
||||
-> Diff f (Record fields) -- ^ The resulting diff.
|
||||
diffTermsWith refine comparable t1 t2 = runFreer decompose (diff t1 t2)
|
||||
where decompose :: AlgorithmF (Term f) (Diff f) (Record fields) result -> Algorithm (Term f) (Diff f) (Record fields) result
|
||||
where decompose :: AlgorithmF (Term f) (Diff f) (Record fields) (Record fields) result -> Algorithm (Term f) (Diff f) (Record fields) (Record fields) 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 (Record fields)
|
||||
-> Term Syntax (Record fields)
|
||||
-> Algorithm (Term Syntax) (Diff Syntax) (Record fields) (Diff Syntax (Record fields))
|
||||
-> Algorithm (Term Syntax) (Diff Syntax) (Record fields) (Record fields) (Diff Syntax (Record fields))
|
||||
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