From cf756afc4ac2275681a45583ebdf536b04b4cbb0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 May 2018 13:30:35 -0400 Subject: [PATCH] Move diffTermPair into Diffing.Interpreter. --- src/Diffing/Interpreter.hs | 11 +++++++++-- src/Semantic/Diff.hs | 9 +-------- src/Semantic/Task.hs | 14 ++++++-------- 3 files changed, 16 insertions(+), 18 deletions(-) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 04ea43195..c66f23352 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -1,17 +1,18 @@ {-# LANGUAGE DataKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-} module Diffing.Interpreter ( diffTerms +, diffTermPair ) where -import Prologue -import Data.Align.Generic (galignWith) import Analysis.Decorator import Control.Monad.Free.Freer +import Data.Align.Generic (galignWith) import Data.Diff import Data.Record import Data.Term import Diffing.Algorithm import Diffing.Algorithm.RWS +import Prologue -- | Diff two à la carte terms recursively. diffTerms :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax) @@ -22,6 +23,12 @@ diffTerms t1 t2 = stripDiff (fromMaybe (replacing t1' t2') (runAlgorithm (diff t where (t1', t2') = ( defaultFeatureVectorDecorator constructorNameAndConstantFields t1 , defaultFeatureVectorDecorator constructorNameAndConstantFields t2) +-- | Diff a 'These' of terms. +diffTermPair :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Diff syntax (Record fields1) (Record fields2) +diffTermPair (This t1 ) = deleting t1 +diffTermPair (That t2) = inserting t2 +diffTermPair (These t1 t2) = diffTerms t1 t2 + -- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations. runAlgorithm :: forall syntax fields1 fields2 m result . (Diffable syntax, Eq1 syntax, GAlign syntax, Traversable syntax, Alternative m, Monad m) diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index 27923aa85..b2fec8a32 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -10,7 +10,6 @@ import Data.JSON.Fields import Data.Record import Data.Term import Diffing.Algorithm (Diffable) -import Diffing.Interpreter import Parsing.Parser import Prologue hiding (MonadError(..)) import Rendering.Graph @@ -40,14 +39,8 @@ diffBlobPair renderer blobs run parse renderer = do terms <- distributeFor blobs (WrapTask . parse) time "diff" languageTag $ do - diff <- diffTermPair (runJoin terms) + diff <- diff (runJoin terms) writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) render (renderer blobs) diff where languageTag = languageTagForBlobPair blobs - --- | A task to diff 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's. -diffTermPair :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax, Member Task effs) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Eff effs (Diff syntax (Record fields1) (Record fields2)) -diffTermPair (This t1 ) = pure (deleting t1) -diffTermPair (That t2) = pure (inserting t2) -diffTermPair (These t1 t2) = diff diffTerms t1 t2 diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 37ed8923e..40e5f93b5 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -5,7 +5,6 @@ module Semantic.Task , WrappedTask(..) , Level(..) , RAlgebra -, Differ -- * I/O , IO.readBlob , IO.readBlobs @@ -59,6 +58,8 @@ import qualified Data.Error as Error import Data.Record import qualified Data.Syntax as Syntax import Data.Term +import Diffing.Algorithm (Diffable) +import Diffing.Interpreter import Parsing.CMark import Parsing.Parser import Parsing.TreeSitter @@ -87,9 +88,6 @@ type TaskEff = Eff '[Distribute WrappedTask newtype WrappedTask a = WrapTask { unwrapTask :: TaskEff a } deriving (Applicative, Functor, Monad) --- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types. -type Differ syntax ann1 ann2 = Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2 - -- | A function to render terms or diffs. type Renderer i o = i -> o @@ -106,8 +104,8 @@ decorate :: (Functor f, Member Task effs) => RAlgebra (TermF f (Record fields)) decorate algebra = send . Decorate algebra -- | A task which diffs a pair of terms using the supplied 'Differ' function. -diff :: Member Task effs => Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Eff effs (Diff syntax ann1 ann2) -diff differ term1 term2 = send (Semantic.Task.Diff differ term1 term2) +diff :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax, Member Task effs) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Eff effs (Diff syntax (Record fields1) (Record fields2)) +diff terms = send (Semantic.Task.Diff terms) -- | A task which renders some input using the supplied 'Renderer' function. render :: Member Task effs => Renderer input output -> input -> Eff effs output @@ -149,7 +147,7 @@ data Task output where Parse :: Parser term -> Blob -> Task term Analyze :: (Analysis.Evaluator location value effects a -> result) -> Analysis.Evaluator location value effects a -> Task result Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields))) - Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2) + Diff :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Task (Diff syntax (Record fields1) (Record fields2)) Render :: Renderer input output -> input -> Task output Serialize :: Format input -> input -> Task Builder @@ -159,7 +157,7 @@ runTaskF = interpret $ \ task -> case task of Parse parser blob -> runParser blob parser Analyze interpret analysis -> pure (interpret analysis) Decorate algebra term -> pure (decoratorWithAlgebra algebra term) - Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2) + Semantic.Task.Diff terms -> pure (diffTermPair terms) Render renderer input -> pure (renderer input) Serialize format input -> pure (runSerialize format input)