github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into typescript-assignment

Browse Source
This commit is contained in:
joshvera 2017-09-19 11:54:51 -04:00
commit b03d17de34
33 changed files with 584 additions and 519 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
semantic-diff.cabal
View File

@ -77,7 +77,6 @@ library
, Semantic.Util , Semantic.Util
, SemanticCmdLine , SemanticCmdLine
, SES , SES
, SES.Myers
, SplitDiff , SplitDiff
, Syntax , Syntax
, Term , Term
@ -172,7 +171,7 @@ test-suite test
, SemanticCmdLineSpec , SemanticCmdLineSpec
, InterpreterSpec , InterpreterSpec
, PatchOutputSpec , PatchOutputSpec
, SES.Myers.Spec , SES.Spec
, SourceSpec , SourceSpec
, SpecHelpers , SpecHelpers
, TermSpec , TermSpec

103
src/Algorithm.hs
View File

@ -4,7 +4,6 @@ module Algorithm where
import Control.Applicative (liftA2) import Control.Applicative (liftA2)
import Control.Monad (guard, join) import Control.Monad (guard, join)
import Control.Monad.Free.Freer import Control.Monad.Free.Freer
import Data.Function (on)
import Data.Functor.Classes import Data.Functor.Classes
import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe import Data.Maybe
@ -18,17 +17,17 @@ import Term
-- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm. -- | 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 result where data AlgorithmF term diff result where
-- | Diff two terms with the choice of algorithm left to the interpreter’s discretion. -- | Diff two terms with the choice of algorithm left to the interpreter’s discretion.
Diff :: term -> term -> AlgorithmF term diff diff 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. -- | Diff two terms recursively in O(n) time, resulting in a single diff node.
Linear :: term -> term -> AlgorithmF term diff diff 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. -- | Diff two lists of terms by each element’s similarity in O(n³ log n), resulting in a list of diffs.
RWS :: [term] -> [term] -> AlgorithmF term diff [diff] RWS :: [term ann1] -> [term ann2] -> AlgorithmF term (diff ann1 ann2) [diff ann1 ann2]
-- | Delete a term.. -- | Delete a term..
Delete :: term -> AlgorithmF term diff diff Delete :: term ann1 -> AlgorithmF term (diff ann1 ann2) (diff ann1 ann2)
-- | Insert a term. -- | Insert a term.
Insert :: term -> AlgorithmF term diff diff Insert :: term ann2 -> AlgorithmF term (diff ann1 ann2) (diff ann1 ann2)
-- | Replace one term with another. -- | Replace one term with another.
Replace :: term -> term -> AlgorithmF term diff diff 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. -- | The free applicative for 'AlgorithmF'. This enables us to construct diff values using <$> and <*> notation.
type Algorithm term diff = Freer (AlgorithmF term diff) type Algorithm term diff = Freer (AlgorithmF term diff)
@ -37,15 +36,15 @@ type Algorithm term diff = Freer (AlgorithmF term diff)
-- DSL -- DSL
-- | Diff two terms without specifying the algorithm to be used. -- | Diff two terms without specifying the algorithm to be used.
diff :: term -> term -> Algorithm term diff diff diff :: term ann1 -> term ann2 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
diff = (liftF .) . Algorithm.Diff diff = (liftF .) . Algorithm.Diff
-- | Diff a These of terms without specifying the algorithm to be used. -- | Diff a These of terms without specifying the algorithm to be used.
diffThese :: These term term -> Algorithm term diff diff diffThese :: These (term ann1) (term ann2) -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
diffThese = these byDeleting byInserting diff diffThese = these byDeleting byInserting diff
-- | Diff a pair of optional terms without specifying the algorithm to be used. -- | Diff a pair of optional terms without specifying the algorithm to be used.
diffMaybe :: Maybe term -> Maybe term -> Algorithm term diff (Maybe diff) diffMaybe :: Maybe (term ann1) -> Maybe (term ann2) -> Algorithm term (diff ann1 ann2) (Maybe (diff ann1 ann2))
diffMaybe a b = case (a, b) of diffMaybe a b = case (a, b) of
(Just a, Just b) -> Just <$> diff a b (Just a, Just b) -> Just <$> diff a b
(Just a, _) -> Just <$> byDeleting a (Just a, _) -> Just <$> byDeleting a
@ -53,53 +52,61 @@ diffMaybe a b = case (a, b) of
_ -> pure Nothing _ -> pure Nothing
-- | Diff two terms linearly. -- | Diff two terms linearly.
linearly :: term -> term -> Algorithm term diff diff linearly :: term ann1 -> term ann2 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
linearly a b = liftF (Linear a b) linearly a b = liftF (Linear a b)
-- | Diff two terms using RWS. -- | Diff two terms using RWS.
byRWS :: [term] -> [term] -> Algorithm term diff [diff] byRWS :: [term ann1] -> [term ann2] -> Algorithm term (diff ann1 ann2) [diff ann1 ann2]
byRWS a b = liftF (RWS a b) byRWS a b = liftF (RWS a b)
-- | Delete a term. -- | Delete a term.
byDeleting :: term -> Algorithm term diff diff byDeleting :: term ann1 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
byDeleting = liftF . Delete byDeleting = liftF . Delete
-- | Insert a term. -- | Insert a term.
byInserting :: term -> Algorithm term diff diff byInserting :: term ann2 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
byInserting = liftF . Insert byInserting = liftF . Insert
-- | Replace one term with another. -- | Replace one term with another.
byReplacing :: term -> term -> Algorithm term diff diff byReplacing :: term ann1 -> term ann2 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
byReplacing = (liftF .) . Replace byReplacing = (liftF .) . Replace
instance Show term => Show1 (AlgorithmF term diff) where instance (Show1 term, Show ann1, Show ann2) => Show1 (AlgorithmF term (diff ann1 ann2)) where
liftShowsPrec _ _ d algorithm = case algorithm of liftShowsPrec _ _ d algorithm = case algorithm of
Algorithm.Diff t1 t2 -> showsBinaryWith showsPrec showsPrec "Diff" d t1 t2 Algorithm.Diff t1 t2 -> showsBinaryWith showsTerm showsTerm "Diff" d t1 t2
Linear t1 t2 -> showsBinaryWith showsPrec showsPrec "Linear" d t1 t2 Linear t1 t2 -> showsBinaryWith showsTerm showsTerm "Linear" d t1 t2
RWS as bs -> showsBinaryWith showsPrec showsPrec "RWS" d as bs RWS as bs -> showsBinaryWith (liftShowsPrec showsTerm (liftShowList showsPrec showList)) (liftShowsPrec showsTerm (liftShowList showsPrec showList)) "RWS" d as bs
Delete t1 -> showsUnaryWith showsPrec "Delete" d t1 Delete t1 -> showsUnaryWith showsTerm "Delete" d t1
Insert t2 -> showsUnaryWith showsPrec "Insert" d t2 Insert t2 -> showsUnaryWith showsTerm "Insert" d t2
Replace t1 t2 -> showsBinaryWith showsPrec showsPrec "Replace" d t1 t2 Replace t1 t2 -> showsBinaryWith showsTerm showsTerm "Replace" d t1 t2
where showsTerm :: (Show1 term, Show ann) => Int -> term ann -> ShowS
showsTerm = liftShowsPrec showsPrec showList
-- | Diff two terms based on their generic Diffable instances. If the terms are not diffable -- | 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. -- (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 a) (Diff f a) (Diff f a) algorithmForTerms :: (Functor syntax, Diffable syntax)
=> Term syntax ann1
-> Term syntax ann2
-> Algorithm (Term syntax) (Diff syntax ann1 ann2) (Diff syntax ann1 ann2)
algorithmForTerms t1 t2 = fromMaybe (byReplacing t1 t2) (algorithmForComparableTerms t1 t2) 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 a) (Diff f a) (Diff f a)) algorithmForComparableTerms :: (Functor syntax, Diffable syntax)
=> Term syntax ann1
-> Term syntax 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 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. -- | A type class for determining what algorithm to use for diffing two terms.
class Diffable f where class Diffable f where
algorithmFor :: f term -> f term -> Maybe (Algorithm term diff (f diff)) algorithmFor :: f (term ann1) -> f (term ann2) -> Maybe (Algorithm term (diff ann1 ann2) (f (diff ann1 ann2)))
default algorithmFor :: (Generic1 f, Diffable' (Rep1 f)) => f term -> f term -> Maybe (Algorithm term diff (f diff)) 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 algorithmFor = genericAlgorithmFor
genericAlgorithmFor :: (Generic1 f, Diffable' (Rep1 f)) => f term -> f term -> Maybe (Algorithm term diff (f diff)) 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 <$> algorithmFor' (from1 a) (from1 b) genericAlgorithmFor a b = fmap to1 <$> galgorithmFor (from1 a) (from1 b)
-- | Diff a Union of Syntax terms. Left is the "rest" of the Syntax terms in the Union, -- | Diff a Union of Syntax terms. Left is the "rest" of the Syntax terms in the Union,
@ -114,46 +121,46 @@ instance Diffable [] where
algorithmFor a b = Just (byRWS a b) algorithmFor a b = Just (byRWS a b)
-- | A generic type class for diffing two terms defined by the Generic1 interface. -- | A generic type class for diffing two terms defined by the Generic1 interface.
class Diffable' f where class GDiffable f where
algorithmFor' :: f term -> f term -> Maybe (Algorithm term diff (f diff)) 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)) -- | 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 instance GDiffable f => GDiffable (M1 i c f) where
algorithmFor' (M1 a) (M1 b) = fmap M1 <$> algorithmFor' a b galgorithmFor (M1 a) (M1 b) = fmap M1 <$> galgorithmFor a b
-- | Diff the fields of a product type. -- | Diff the fields of a product type.
-- i.e. data Foo a b = Foo a b (the 'Foo a b' is captured by 'a :*: b'). -- i.e. data Foo a b = Foo a b (the 'Foo a b' is captured by 'a :*: b').
instance (Diffable' f, Diffable' g) => Diffable' (f :*: g) where instance (GDiffable f, GDiffable g) => GDiffable (f :*: g) where
algorithmFor' (a1 :*: b1) (a2 :*: b2) = liftA2 (:*:) <$> algorithmFor' a1 a2 <*> algorithmFor' b1 b2 galgorithmFor (a1 :*: b1) (a2 :*: b2) = liftA2 (:*:) <$> galgorithmFor a1 a2 <*> galgorithmFor b1 b2
-- | Diff the constructors of a sum type. -- | Diff the constructors of a sum type.
-- i.e. data Foo a = Foo a | Bar a (the 'Foo a' is captured by L1 and 'Bar a' is R1). -- i.e. data Foo a = Foo a | Bar a (the 'Foo a' is captured by L1 and 'Bar a' is R1).
instance (Diffable' f, Diffable' g) => Diffable' (f :+: g) where instance (GDiffable f, GDiffable g) => GDiffable (f :+: g) where
algorithmFor' (L1 a) (L1 b) = fmap L1 <$> algorithmFor' a b galgorithmFor (L1 a) (L1 b) = fmap L1 <$> galgorithmFor a b
algorithmFor' (R1 a) (R1 b) = fmap R1 <$> algorithmFor' a b galgorithmFor (R1 a) (R1 b) = fmap R1 <$> galgorithmFor a b
algorithmFor' _ _ = Nothing galgorithmFor _ _ = Nothing
-- | Diff two parameters (Par1 is the Generic1 newtype representing a type parameter). -- | 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). -- i.e. data Foo a = Foo a (the 'a' is captured by Par1).
instance Diffable' Par1 where instance GDiffable Par1 where
algorithmFor' (Par1 a) (Par1 b) = Just (Par1 <$> linearly a b) galgorithmFor (Par1 a) (Par1 b) = Just (Par1 <$> linearly a b)
-- | Diff two constant parameters (K1 is the Generic1 newtype representing type parameter constants). -- | 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). -- i.e. data Foo = Foo Int (the 'Int' is a constant parameter).
instance Eq c => Diffable' (K1 i c) where instance Eq c => GDiffable (K1 i c) where
algorithmFor' (K1 a) (K1 b) = guard (a == b) *> Just (pure (K1 a)) galgorithmFor (K1 a) (K1 b) = guard (a == b) *> Just (pure (K1 a))
-- | Diff two terms whose constructors contain 0 type parameters. -- | Diff two terms whose constructors contain 0 type parameters.
-- i.e. data Foo = Foo. -- i.e. data Foo = Foo.
instance Diffable' U1 where instance GDiffable U1 where
algorithmFor' _ _ = Just (pure U1) galgorithmFor _ _ = Just (pure U1)
-- | Diff two lists of parameters. -- | Diff two lists of parameters.
instance Diffable' (Rec1 []) where instance GDiffable (Rec1 []) where
algorithmFor' a b = fmap Rec1 <$> Just ((byRWS `on` unRec1) a b) galgorithmFor a b = Just (Rec1 <$> byRWS (unRec1 a) (unRec1 b))
-- | Diff two non-empty lists of parameters. -- | Diff two non-empty lists of parameters.
instance Diffable' (Rec1 NonEmpty) where instance GDiffable (Rec1 NonEmpty) where
algorithmFor' (Rec1 (a:|as)) (Rec1 (b:|bs)) = Just $ do galgorithmFor (Rec1 (a:|as)) (Rec1 (b:|bs)) = Just $ do
d:ds <- byRWS (a:as) (b:bs) d:ds <- byRWS (a:as) (b:bs)
pure (Rec1 (d :| ds)) pure (Rec1 (d :| ds))

4
src/Alignment.hs
View File

@ -46,13 +46,13 @@ hasChanges :: (Foldable f, Functor f) => SplitDiff f annotation -> Bool
hasChanges = or . (True <$) hasChanges = or . (True <$)
-- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side. -- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side.
alignDiff :: (HasField fields Range, Traversable f) => Both Source -> Diff f (Record fields) -> [Join These (SplitDiff [] (Record fields))] alignDiff :: (HasField fields Range, Traversable f) => Both Source -> Diff f (Record fields) (Record fields) -> [Join These (SplitDiff [] (Record fields))]
alignDiff sources = cata $ \ diff -> case diff of alignDiff sources = cata $ \ diff -> case diff of
Patch patch -> alignPatch sources patch Patch patch -> alignPatch sources patch
Merge (In (ann1, ann2) syntax) -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (In (both ann1 ann2) syntax) Merge (In (ann1, ann2) syntax) -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (In (both ann1 ann2) syntax)
-- | Align the contents of a patch into a list of lines on the corresponding side(s) of the diff. -- | Align the contents of a patch into a list of lines on the corresponding side(s) of the diff.
alignPatch :: forall fields f. (Traversable f, HasField fields Range) => Both Source -> Patch (TermF f (Record fields) [Join These (SplitDiff [] (Record fields))]) -> [Join These (SplitDiff [] (Record fields))] alignPatch :: forall fields f. (Traversable f, HasField fields Range) => Both Source -> Patch (TermF f (Record fields) [Join These (SplitDiff [] (Record fields))]) (TermF f (Record fields) [Join These (SplitDiff [] (Record fields))]) -> [Join These (SplitDiff [] (Record fields))]
alignPatch sources patch = case patch of alignPatch sources patch = case patch of
Delete term -> fmap (pure . SplitDelete) <$> alignSyntax' this (fst sources) term Delete term -> fmap (pure . SplitDelete) <$> alignSyntax' this (fst sources) term
Insert term -> fmap (pure . SplitInsert) <$> alignSyntax' that (snd sources) term Insert term -> fmap (pure . SplitInsert) <$> alignSyntax' that (snd sources) term

18
src/Data/Syntax.hs
View File

@ -165,21 +165,21 @@ instance Eq1 Context where liftEq = genericLiftEq
instance Show1 Context where liftShowsPrec = genericLiftShowsPrec instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
algorithmDeletingContext :: (Apply Diffable fs, Apply Functor fs, Context :< fs) algorithmDeletingContext :: (Apply Diffable fs, Apply Functor fs, Context :< fs)
=> TermF Context a (Term (Union fs) a) => TermF Context ann1 (Term (Union fs) ann1)
-> Term (Union fs) a -> Term (Union fs) ann2
-> Maybe (Algorithm (Term (Union fs) a) (Diff (Union fs) a) (TermF Context a (Diff (Union fs) a))) -> 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 algorithmDeletingContext (In a1 (Context n1 s1)) s2 = fmap (In a1 . Context (deleting <$> n1)) <$> algorithmForComparableTerms s1 s2
algorithmInsertingContext :: (Apply Diffable fs, Apply Functor fs, Context :< fs) algorithmInsertingContext :: (Apply Diffable fs, Apply Functor fs, Context :< fs)
=> Term (Union fs) a => Term (Union fs) ann1
-> TermF Context a (Term (Union fs) a) -> TermF Context ann2 (Term (Union fs) ann2)
-> Maybe (Algorithm (Term (Union fs) a) (Diff (Union fs) a) (TermF Context a (Diff (Union fs) a))) -> 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 algorithmInsertingContext s1 (In a2 (Context n2 s2)) = fmap (In a2 . Context (inserting <$> n2)) <$> algorithmForComparableTerms s1 s2
algorithmForContextUnions :: (Apply Diffable fs, Apply Functor fs, Context :< fs) algorithmForContextUnions :: (Apply Diffable fs, Apply Functor fs, Context :< fs)
=> Term (Union fs) a => Term (Union fs) ann1
-> Term (Union fs) a -> Term (Union fs) ann2
-> Maybe (Algorithm (Term (Union fs) a) (Diff (Union fs) a) (Diff (Union fs) a)) -> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs) ann1 ann2) (Diff (Union fs) ann1 ann2))
algorithmForContextUnions t1 t2 algorithmForContextUnions t1 t2
| Just algo <- algorithmForComparableTerms t1 t2 = Just algo | Just algo <- algorithmForComparableTerms t1 t2 = Just algo
| Just c1@(In _ Context{}) <- prjTermF (unTerm t1) = fmap (deleteF . hoistTermF inj) <$> algorithmDeletingContext c1 t2 | Just c1@(In _ Context{}) <- prjTermF (unTerm t1) = fmap (deleteF . hoistTermF inj) <$> algorithmDeletingContext c1 t2

182
src/Diff.hs
View File

@ -12,176 +12,204 @@ import Data.JSON.Fields
import Data.Mergeable import Data.Mergeable
import Data.Record import Data.Record
import Patch import Patch
import Syntax
import Term import Term
import Text.Show import Text.Show
-- | A recursive structure indicating the changed & unchanged portions of a labelled tree. -- | A recursive structure indicating the changed & unchanged portions of a labelled tree.
newtype Diff syntax ann = Diff { unDiff :: DiffF syntax ann (Diff syntax ann) } newtype Diff syntax ann1 ann2 = Diff { unDiff :: DiffF syntax ann1 ann2 (Diff syntax ann1 ann2) }
-- | A single entry within a recursive 'Diff'. -- | A single entry within a recursive 'Diff'.
data DiffF syntax ann recur data DiffF syntax ann1 ann2 recur
-- | A changed node, represented as 'Insert'ed, 'Delete'd, or 'Replace'd 'TermF's, consisting of syntax labelled with an annotation. -- | A changed node, represented as 'Insert'ed, 'Delete'd, or 'Replace'd 'TermF's, consisting of syntax labelled with an annotation.
= Patch (Patch (TermF syntax ann recur)) = Patch (Patch (TermF syntax ann1 recur)
(TermF syntax ann2 recur))
-- | An unchanged node, consisting of syntax labelled with both the original annotations. -- | An unchanged node, consisting of syntax labelled with both the original annotations.
| Merge (TermF syntax (ann, ann) recur) | Merge (TermF syntax (ann1, ann2) recur)
deriving (Foldable, Functor, Traversable)
-- | Constructs a 'Diff' replacing one 'Term' with another recursively. -- | Constructs a 'Diff' replacing one 'Term' with another recursively.
replacing :: Functor syntax => Term syntax ann -> Term syntax ann -> Diff syntax ann replacing :: Functor syntax => Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2
replacing (Term (In a1 r1)) (Term (In a2 r2)) = Diff (Patch (Replace (In a1 (deleting <$> r1)) (In a2 (inserting <$> r2)))) replacing (Term (In a1 r1)) (Term (In a2 r2)) = Diff (Patch (Replace (In a1 (deleting <$> r1)) (In a2 (inserting <$> r2))))
-- | Constructs a 'Diff' inserting a 'Term' recursively. -- | Constructs a 'Diff' inserting a 'Term' recursively.
inserting :: Functor syntax => Term syntax ann -> Diff syntax ann inserting :: Functor syntax => Term syntax ann2 -> Diff syntax ann1 ann2
inserting = cata insertF inserting = cata insertF
-- | Constructs a 'Diff' inserting a single 'TermF' populated by further 'Diff's. -- | Constructs a 'Diff' inserting a single 'TermF' populated by further 'Diff's.
insertF :: TermF syntax ann (Diff syntax ann) -> Diff syntax ann insertF :: TermF syntax ann2 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
insertF = Diff . Patch . Insert insertF = Diff . Patch . Insert
-- | Constructs a 'Diff' deleting a 'Term' recursively. -- | Constructs a 'Diff' deleting a 'Term' recursively.
deleting :: Functor syntax => Term syntax ann -> Diff syntax ann deleting :: Functor syntax => Term syntax ann1 -> Diff syntax ann1 ann2
deleting = cata deleteF deleting = cata deleteF
-- | Constructs a 'Diff' deleting a single 'TermF' populated by further 'Diff's. -- | Constructs a 'Diff' deleting a single 'TermF' populated by further 'Diff's.
deleteF :: TermF syntax ann (Diff syntax ann) -> Diff syntax ann deleteF :: TermF syntax ann1 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
deleteF = Diff . Patch . Delete deleteF = Diff . Patch . Delete
-- | Constructs a 'Diff' merging two annotations for a single syntax functor populated by further 'Diff's. -- | Constructs a 'Diff' merging two annotations for a single syntax functor populated by further 'Diff's.
merge :: (ann, ann) -> syntax (Diff syntax ann) -> Diff syntax ann merge :: (ann1, ann2) -> syntax (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
merge = (Diff .) . (Merge .) . In merge = (Diff .) . (Merge .) . In
type SyntaxDiff fields = Diff Syntax (Record fields) diffSum :: (Foldable syntax, Functor syntax) => (forall a b. Patch a b -> Int) -> Diff syntax ann1 ann2 -> Int
diffSum :: (Foldable syntax, Functor syntax) => (forall a. Patch a -> Int) -> Diff syntax ann -> Int
diffSum patchCost = cata $ \ diff -> case diff of diffSum patchCost = cata $ \ diff -> case diff of
Patch patch -> patchCost patch + sum (sum <$> patch) Patch patch -> patchCost patch + sum (sum <$> patch)
Merge merge -> sum merge Merge merge -> sum merge
-- | The sum of the node count of the diff’s patches. -- | The sum of the node count of the diff’s patches.
diffCost :: (Foldable syntax, Functor syntax) => Diff syntax ann -> Int diffCost :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> Int
diffCost = diffSum (const 1) diffCost = diffSum (const 1)
diffPatch :: Diff syntax ann -> Maybe (Patch (TermF syntax ann (Diff syntax ann))) diffPatch :: Diff syntax ann1 ann2 -> Maybe (Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2)))
diffPatch diff = case unDiff diff of diffPatch diff = case unDiff diff of
Patch patch -> Just patch Patch patch -> Just patch
_ -> Nothing _ -> Nothing
diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann -> [Patch (TermF syntax ann (Diff syntax ann))] diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> [Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))]
diffPatches = para $ \ diff -> case diff of diffPatches = para $ \ diff -> case diff of
Patch patch -> fmap (fmap fst) patch : foldMap (foldMap (toList . diffPatch . fst)) patch Patch patch -> bimap (fmap fst) (fmap fst) patch : bifoldMap (foldMap (toList . diffPatch . fst)) (foldMap (toList . diffPatch . fst)) patch
Merge merge -> foldMap (toList . diffPatch . fst) merge Merge merge -> foldMap (toList . diffPatch . fst) merge
-- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch. -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch.
mergeMaybe :: (Mergeable syntax, Traversable syntax) => (DiffF syntax ann (Maybe (Term syntax ann)) -> Maybe (Term syntax ann)) -> Diff syntax ann -> Maybe (Term syntax ann) mergeMaybe :: (Mergeable syntax, Traversable syntax) => (DiffF syntax ann1 ann2 (Maybe (Term syntax combined)) -> Maybe (Term syntax combined)) -> Diff syntax ann1 ann2 -> Maybe (Term syntax combined)
mergeMaybe = cata mergeMaybe = cata
-- | Recover the before state of a diff. -- | Recover the before state of a diff.
beforeTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann -> Maybe (Term syntax ann) beforeTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann1 ann2 -> Maybe (Term syntax ann1)
beforeTerm = mergeMaybe $ \ diff -> case diff of beforeTerm = mergeMaybe $ \ diff -> case diff of
Patch patch -> before patch >>= \ (In a l) -> termIn a <$> sequenceAlt l Patch patch -> before patch >>= \ (In a l) -> termIn a <$> sequenceAlt l
Merge (In (a, _) l) -> termIn a <$> sequenceAlt l Merge (In (a, _) l) -> termIn a <$> sequenceAlt l
-- | Recover the after state of a diff. -- | Recover the after state of a diff.
afterTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann -> Maybe (Term syntax ann) afterTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann1 ann2 -> Maybe (Term syntax ann2)
afterTerm = mergeMaybe $ \ diff -> case diff of afterTerm = mergeMaybe $ \ diff -> case diff of
Patch patch -> after patch >>= \ (In b r) -> termIn b <$> sequenceAlt r Patch patch -> after patch >>= \ (In b r) -> termIn b <$> sequenceAlt r
Merge (In (_, b) r) -> termIn b <$> sequenceAlt r Merge (In (_, b) r) -> termIn b <$> sequenceAlt r
-- | Strips the head annotation off a diff annotated with non-empty records. -- | Strips the head annotation off a diff annotated with non-empty records.
stripDiff :: Functor f stripDiff :: Functor syntax
=> Diff f (Record (h ': t)) => Diff syntax (Record (h1 ': t1)) (Record (h2 ': t2))
-> Diff f (Record t) -> Diff syntax (Record t1) (Record t2)
stripDiff = fmap rtail stripDiff = bimap rtail rtail
type instance Base (Diff syntax ann) = DiffF syntax ann type instance Base (Diff syntax ann1 ann2) = DiffF syntax ann1 ann2
instance Functor syntax => Recursive (Diff syntax ann) where project = unDiff instance Functor syntax => Recursive (Diff syntax ann1 ann2) where project = unDiff
instance Functor syntax => Corecursive (Diff syntax ann) where embed = Diff instance Functor syntax => Corecursive (Diff syntax ann1 ann2) where embed = Diff
instance Eq1 f => Eq1 (Diff f) where instance Eq1 syntax => Eq2 (Diff syntax) where
liftEq eqA = go where go (Diff d1) (Diff d2) = liftEq2 eqA go d1 d2 liftEq2 eq1 eq2 = go where go (Diff d1) (Diff d2) = liftEq3 eq1 eq2 go d1 d2
instance (Eq1 f, Eq a) => Eq (Diff f a) where instance (Eq1 syntax, Eq ann1, Eq ann2) => Eq (Diff syntax ann1 ann2) where
(==) = eq1 (==) = eq2
instance Eq1 f => Eq2 (DiffF f) where instance Eq1 syntax => Eq3 (DiffF syntax) where
liftEq2 eqA eqB d1 d2 = case (d1, d2) of liftEq3 eq1 eq2 eqRecur d1 d2 = case (d1, d2) of
(Patch p1, Patch p2) -> liftEq (liftEq2 eqA eqB) p1 p2 (Patch p1, Patch p2) -> liftEq2 (liftEq2 eq1 eqRecur) (liftEq2 eq2 eqRecur) p1 p2
(Merge t1, Merge t2) -> liftEq2 (liftEq2 eqA eqA) eqB t1 t2 (Merge t1, Merge t2) -> liftEq2 (liftEq2 eq1 eq2) eqRecur t1 t2
_ -> False _ -> False
instance (Eq1 f, Eq a) => Eq1 (DiffF f a) where instance (Eq1 syntax, Eq ann1, Eq ann2) => Eq1 (DiffF syntax ann1 ann2) where
liftEq = liftEq2 (==) liftEq = liftEq3 (==) (==)
instance (Eq1 f, Eq a, Eq b) => Eq (DiffF f a b) where instance (Eq1 syntax, Eq ann1, Eq ann2, Eq recur) => Eq (DiffF syntax ann1 ann2 recur) where
(==) = eq1 (==) = eq3
instance Show1 f => Show1 (Diff f) where instance Show1 syntax => Show2 (Diff syntax) where
liftShowsPrec sp sl = go where go d = showsUnaryWith (liftShowsPrec2 sp sl go (showListWith (go 0))) "Diff" d . unDiff liftShowsPrec2 sp1 sl1 sp2 sl2 = go where go d = showsUnaryWith (liftShowsPrec3 sp1 sl1 sp2 sl2 go (showListWith (go 0))) "Diff" d . unDiff
instance (Show1 f, Show a) => Show (Diff f a) where instance (Show1 syntax, Show ann1, Show ann2) => Show (Diff syntax ann1 ann2) where
showsPrec = showsPrec1 showsPrec = showsPrec2
instance Show1 f => Show2 (DiffF f) where instance Show1 syntax => Show3 (DiffF syntax) where
liftShowsPrec2 spA slA spB slB d diff = case diff of liftShowsPrec3 sp1 sl1 sp2 sl2 spRecur slRecur d diff = case diff of
Patch patch -> showsUnaryWith (liftShowsPrec (liftShowsPrec2 spA slA spB slB) (liftShowList2 spA slA spB slB)) "Patch" d patch Patch patch -> showsUnaryWith (liftShowsPrec2 (liftShowsPrec2 sp1 sl1 spRecur slRecur) (liftShowList2 sp1 sl1 spRecur slRecur) (liftShowsPrec2 sp2 sl2 spRecur slRecur) (liftShowList2 sp2 sl2 spRecur slRecur)) "Patch" d patch
Merge term  -> showsUnaryWith (liftShowsPrec2 spBoth slBoth spB slB) "Merge" d term Merge term  -> showsUnaryWith (liftShowsPrec2 spBoth slBoth spRecur slRecur) "Merge" d term
where spBoth = liftShowsPrec2 spA slA spA slA where spBoth = liftShowsPrec2 sp1 sl1 sp2 sl2
slBoth = liftShowList2 spA slA spA slA slBoth = liftShowList2 sp1 sl1 sp2 sl2
instance (Show1 f, Show a) => Show1 (DiffF f a) where instance (Show1 syntax, Show ann1, Show ann2) => Show1 (DiffF syntax ann1 ann2) where
liftShowsPrec = liftShowsPrec2 showsPrec showList liftShowsPrec = liftShowsPrec3 showsPrec showList showsPrec showList
instance (Show1 f, Show a, Show b) => Show (DiffF f a b) where instance (Show1 syntax, Show ann1, Show ann2, Show recur) => Show (DiffF syntax ann1 ann2 recur) where
showsPrec = showsPrec1 showsPrec = showsPrec3
instance Functor f => Functor (Diff f) where instance Functor syntax => Bifunctor (Diff syntax) where
fmap f = go where go = Diff . bimap f go . unDiff bimap f g = go where go = Diff . trimap f g go . unDiff
instance Foldable f => Foldable (Diff f) where instance Foldable syntax => Bifoldable (Diff syntax) where
foldMap f = go where go = bifoldMap f go . unDiff bifoldMap f g = go where go = trifoldMap f g go . unDiff
instance Traversable f => Traversable (Diff f) where instance Traversable syntax => Bitraversable (Diff syntax) where
traverse f = go where go = fmap Diff . bitraverse f go . unDiff bitraverse f g = go where go = fmap Diff . tritraverse f g go . unDiff
instance Functor syntax => Bifunctor (DiffF syntax) where instance Functor syntax => Functor (DiffF syntax ann1 ann2) where
bimap f g (Patch patch) = Patch (bimap f g <$> patch) fmap = trimap id id
bimap f g (Merge term) = Merge (bimap (bimap f f) g term)
instance Foldable f => Bifoldable (DiffF f) where instance Functor syntax => Trifunctor (DiffF syntax) where
bifoldMap f g (Patch patch) = foldMap (bifoldMap f g) patch trimap f g h (Patch patch) = Patch (bimap (bimap f h) (bimap g h) patch)
bifoldMap f g (Merge term) = bifoldMap (bifoldMap f f) g term trimap f g h (Merge term) = Merge (bimap (bimap f g) h term)
instance Traversable f => Bitraversable (DiffF f) where instance Foldable syntax => Foldable (DiffF syntax ann1 ann2) where
bitraverse f g (Patch patch) = Patch <$> traverse (bitraverse f g) patch foldMap = trifoldMap (const mempty) (const mempty)
bitraverse f g (Merge term) = Merge <$> bitraverse (bitraverse f f) g term
instance Foldable syntax => Trifoldable (DiffF syntax) where
trifoldMap f g h (Patch patch) = bifoldMap (bifoldMap f h) (bifoldMap g h) patch
trifoldMap f g h (Merge term) = bifoldMap (bifoldMap f g) h term
instance Traversable syntax => Traversable (DiffF syntax ann1 ann2) where
traverse = tritraverse pure pure
instance Traversable syntax => Tritraversable (DiffF syntax) where
tritraverse f g h (Patch patch) = Patch <$> bitraverse (bitraverse f h) (bitraverse g h) patch
tritraverse f g h (Merge term) = Merge <$> bitraverse (bitraverse f g) h term
instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Diff f a) where instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2) => ToJSON (Diff syntax ann1 ann2) where
toJSON = object . toJSONFields toJSON = object . toJSONFields
toEncoding = pairs . mconcat . toJSONFields toEncoding = pairs . mconcat . toJSONFields
instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Diff f a) where instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2) => ToJSONFields (Diff syntax ann1 ann2) where
toJSONFields = toJSONFields . unDiff toJSONFields = toJSONFields . unDiff
instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields1 (DiffF f a) where instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2) => ToJSONFields1 (DiffF syntax ann1 ann2) where
toJSONFields1 (Patch patch) = [ "patch" .= JSONFields patch ] toJSONFields1 (Patch patch) = [ "patch" .= JSONFields patch ]
toJSONFields1 (Merge term) = [ "merge" .= JSONFields term ] toJSONFields1 (Merge term) = [ "merge" .= JSONFields term ]
instance (ToJSONFields1 f, ToJSONFields a, ToJSON b) => ToJSONFields (DiffF f a b) where instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2, ToJSON recur) => ToJSONFields (DiffF syntax ann1 ann2 recur) where
toJSONFields = toJSONFields1 toJSONFields = toJSONFields1
instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSON (DiffF f a b) where instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2, ToJSON recur) => ToJSON (DiffF syntax ann1 ann2 recur) where
toJSON = object . toJSONFields toJSON = object . toJSONFields
toEncoding = pairs . mconcat . toJSONFields toEncoding = pairs . mconcat . toJSONFields
class Eq3 f where
liftEq3 :: (a1 -> a2 -> Bool) -> (b1 -> b2 -> Bool) -> (c1 -> c2 -> Bool) -> f a1 b1 c1 -> f a2 b2 c2 -> Bool
eq3 :: (Eq3 f, Eq a, Eq b, Eq c) => f a b c -> f a b c -> Bool
eq3 = liftEq3 (==) (==) (==)
class Show3 f where
liftShowsPrec3 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> (Int -> b -> ShowS) -> ([b] -> ShowS) -> (Int -> c -> ShowS) -> ([c] -> ShowS) -> Int -> f a b c -> ShowS
showsPrec3 :: (Show3 f, Show a, Show b, Show c) => Int -> f a b c -> ShowS
showsPrec3 = liftShowsPrec3 showsPrec showList showsPrec showList showsPrec showList
class Trifunctor f where
trimap :: (a -> a') -> (b -> b') -> (c -> c') -> f a b c -> f a' b' c'
class Trifoldable f where
trifoldMap :: Monoid m => (a -> m) -> (b -> m) -> (c -> m) -> f a b c -> m
class Tritraversable f where
tritraverse :: Applicative g => (a -> g a') -> (b -> g b') -> (c -> g c') -> f a b c -> g (f a' b' c')

69
src/Interpreter.hs
View File

@ -9,14 +9,11 @@ module Interpreter
import Algorithm import Algorithm
import Control.Monad.Free.Freer import Control.Monad.Free.Freer
import Data.Align.Generic import Data.Align.Generic
import Data.Functor.Both
import Data.Functor.Foldable (cata)
import Data.Functor.Classes (Eq1) import Data.Functor.Classes (Eq1)
import Data.Hashable (Hashable) import Data.Hashable (Hashable)
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Data.Record import Data.Record
import Data.Text (Text) import Data.Text (Text)
import Data.These
import Diff import Diff
import Info hiding (Return) import Info hiding (Return)
import RWS import RWS
@ -25,33 +22,38 @@ import Term
-- | Diff two terms recursively, given functions characterizing the diffing. -- | Diff two terms recursively, given functions characterizing the diffing.
diffTerms :: HasField fields Category diffTerms :: (HasField fields1 Category, HasField fields2 Category)
=> Both (SyntaxTerm fields) -- ^ A pair of terms representing the old and new state, respectively. => Term Syntax (Record fields1) -- ^ A term representing the old state.
-> SyntaxDiff fields -> Term Syntax (Record fields2) -- ^ A term representing the new state.
diffTerms = decoratingWith getLabel (diffTermsWith algorithmWithTerms comparableByCategory) -> Diff Syntax (Record fields1) (Record fields2)
diffTerms = decoratingWith getLabel getLabel (diffTermsWith algorithmWithTerms comparableByCategory)
-- | Diff two terms by decorating with feature vectors computed using the supplied labelling algebra, and stripping the feature vectors from the resulting diff. -- | Diff two terms by decorating with feature vectors computed using the supplied labelling algebra, and stripping the feature vectors from the resulting diff.
decoratingWith :: (Hashable label, Traversable f) decoratingWith :: (Hashable label, Traversable syntax)
=> (forall a. TermF f (Record fields) a -> label) => (forall a. TermF syntax (Record fields1) a -> label)
-> (Both (Term f (Record (FeatureVector ': fields))) -> Diff f (Record (FeatureVector ': fields))) -> (forall a. TermF syntax (Record fields2) a -> label)
-> Both (Term f (Record fields)) -> (Term syntax (Record (FeatureVector ': fields1)) -> Term syntax (Record (FeatureVector ': fields2)) -> Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)))
-> Diff f (Record fields) -> Term syntax (Record fields1)
decoratingWith getLabel differ = stripDiff . differ . fmap (defaultFeatureVectorDecorator getLabel) -> Term syntax (Record fields2)
-> Diff syntax (Record fields1) (Record fields2)
decoratingWith getLabel1 getLabel2 differ t1 t2 = stripDiff (differ (defaultFeatureVectorDecorator getLabel1 t1) (defaultFeatureVectorDecorator getLabel2 t2))
-- | Diff a pair of terms recurisvely, using the supplied continuation and 'ComparabilityRelation'. -- | 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) diffTermsWith :: forall syntax fields1 fields2
=> (Term f (Record fields) -> Term f (Record fields) -> Algorithm (Term f (Record fields)) (Diff f (Record fields)) (Diff f (Record fields))) -- ^ A function producing syntax-directed continuations of the algorithm. . (Eq1 syntax, GAlign syntax, Traversable syntax)
-> ComparabilityRelation f fields -- ^ A relation on terms used to determine comparability and equality. => (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.
-> Both (Term f (Record fields)) -- ^ A pair of terms. -> ComparabilityRelation syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)) -- ^ A relation on terms used to determine comparability and equality.
-> Diff f (Record fields) -- ^ The resulting diff. -> Term syntax (Record (FeatureVector ': fields1)) -- ^ A term representing the old state.
diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b) -> Term syntax (Record (FeatureVector ': fields2)) -- ^ A term representing the new state.
where decompose :: AlgorithmF (Term f (Record fields)) (Diff f (Record fields)) result -> Algorithm (Term f (Record fields)) (Diff f (Record fields)) result -> 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
decompose step = case step of decompose step = case step of
Algorithm.Diff t1 t2 -> refine t1 t2 Algorithm.Diff t1 t2 -> refine t1 t2
Linear t1 t2 -> case galignWith diffThese (unwrap t1) (unwrap t2) of Linear t1 t2 -> case galignWith diffThese (unwrap t1) (unwrap t2) of
Just result -> merge (extract t1, extract t2) <$> sequenceA result Just result -> merge (extract t1, extract t2) <$> sequenceA result
_ -> byReplacing t1 t2 _ -> byReplacing t1 t2
RWS as bs -> traverse diffThese (rws (editDistanceUpTo defaultM) comparable as bs) RWS as bs -> traverse diffThese (rws comparable as bs)
Delete a -> pure (deleting a) Delete a -> pure (deleting a)
Insert b -> pure (inserting b) Insert b -> pure (inserting b)
Replace a b -> pure (replacing a b) Replace a b -> pure (replacing a b)
@ -64,9 +66,9 @@ getLabel (In h t) = (Info.category h, case t of
-- | Construct an algorithm to diff a pair of terms. -- | Construct an algorithm to diff a pair of terms.
algorithmWithTerms :: SyntaxTerm fields algorithmWithTerms :: Term Syntax ann1
-> SyntaxTerm fields -> Term Syntax ann2
-> Algorithm (SyntaxTerm fields) (SyntaxDiff fields) (SyntaxDiff fields) -> Algorithm (Term Syntax) (Diff Syntax ann1 ann2) (Diff Syntax ann1 ann2)
algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of
(Indexed a, Indexed b) -> (Indexed a, Indexed b) ->
annotate . Indexed <$> byRWS a b annotate . Indexed <$> byRWS a b
@ -108,24 +110,9 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of
-- | Test whether two terms are comparable by their Category. -- | Test whether two terms are comparable by their Category.
comparableByCategory :: HasField fields Category => ComparabilityRelation f fields comparableByCategory :: (HasField fields1 Category, HasField fields2 Category) => ComparabilityRelation syntax (Record fields1) (Record fields2)
comparableByCategory (In a _) (In b _) = category a == category b comparableByCategory (In a _) (In b _) = category a == category b
-- | Test whether two terms are comparable by their constructor. -- | Test whether two terms are comparable by their constructor.
comparableByConstructor :: GAlign f => ComparabilityRelation f fields comparableByConstructor :: GAlign syntax => ComparabilityRelation syntax ann1 ann2
comparableByConstructor (In _ a) (In _ b) = isJust (galign a b) comparableByConstructor (In _ a) (In _ b) = isJust (galign a b)
-- | How many nodes to consider for our constant-time approximation to tree edit distance.
defaultM :: Integer
defaultM = 10
-- | Return an edit distance as the sum of it's term sizes, given an cutoff and a syntax of terms 'f a'.
-- | Computes a constant-time approximation to the edit distance of a diff. This is done by comparing at most _m_ nodes, & assuming the rest are zero-cost.
editDistanceUpTo :: (GAlign f, Foldable f, Functor f) => Integer -> These (Term f (Record fields)) (Term f (Record fields)) -> Int
editDistanceUpTo m = these termSize termSize (\ a b -> diffCost m (approximateDiff a b))
where diffCost = flip . cata $ \ diff m -> case diff of
_ | m <= 0 -> 0
Merge body -> sum (fmap ($ pred m) body)
body -> succ (sum (fmap ($ pred m) body))
approximateDiff a b = maybe (replacing a b) (merge (extract a, extract b)) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b))

4
src/Language.hs
View File

@ -53,13 +53,13 @@ toTuple child | S.Fixed [key,value] <- unwrap child = [termIn (extract child) (S
toTuple child | S.Leaf c <- unwrap child = [termIn (extract child) (S.Comment c)] toTuple child | S.Leaf c <- unwrap child = [termIn (extract child) (S.Comment c)]
toTuple child = pure child toTuple child = pure child
toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields)) toPublicFieldDefinition :: HasField fields Category => [Term S.Syntax (Record fields)] -> Maybe (S.Syntax (Term S.Syntax (Record fields)))
toPublicFieldDefinition children = case break (\x -> category (extract x) == Identifier) children of toPublicFieldDefinition children = case break (\x -> category (extract x) == Identifier) children of
(prev, [identifier, assignment]) -> Just $ S.VarAssignment (prev ++ [identifier]) assignment (prev, [identifier, assignment]) -> Just $ S.VarAssignment (prev ++ [identifier]) assignment
(_, [_]) -> Just $ S.VarDecl children (_, [_]) -> Just $ S.VarDecl children
_ -> Nothing _ -> Nothing
toInterface :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields)) toInterface :: HasField fields Category => [Term S.Syntax (Record fields)] -> Maybe (S.Syntax (Term S.Syntax (Record fields)))
toInterface (id : rest) = case break (\x -> category (extract x) == Other "object_type") rest of toInterface (id : rest) = case break (\x -> category (extract x) == Other "object_type") rest of
(clauses, [body]) -> Just $ S.Interface id clauses (toList (unwrap body)) (clauses, [body]) -> Just $ S.Interface id clauses (toList (unwrap body))
_ -> Nothing _ -> Nothing

5
src/Language/Go.hs
View File

@ -5,6 +5,7 @@ import Control.Comonad
import Control.Comonad.Cofree import Control.Comonad.Cofree
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.Maybe import Data.Maybe
import Data.Record
import Data.Source import Data.Source
import Data.Text import Data.Text
import Info import Info
@ -14,8 +15,8 @@ import Term
termAssignment termAssignment
:: Source -- ^ The source of the term. :: Source -- ^ The source of the term.
-> Category -- ^ The category for the term. -> Category -- ^ The category for the term.
-> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term. -> [ Term S.Syntax (Record DefaultFields) ] -- ^ The child nodes of the term.
-> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe. -> Maybe (S.Syntax (Term S.Syntax (Record DefaultFields))) -- ^ The resulting term, in Maybe.
termAssignment source category children = case (category, children) of termAssignment source category children = case (category, children) of
(Module, [moduleName]) -> Just $ S.Module moduleName [] (Module, [moduleName]) -> Just $ S.Module moduleName []
(Import, [importName]) -> Just $ S.Import importName [] (Import, [importName]) -> Just $ S.Import importName []

5
src/Language/Ruby.hs
View File

@ -3,6 +3,7 @@ module Language.Ruby where
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.List (partition) import Data.List (partition)
import Data.Record
import Data.Semigroup import Data.Semigroup
import Data.Source import Data.Source
import Data.Text (Text) import Data.Text (Text)
@ -14,8 +15,8 @@ import Term
termAssignment termAssignment
:: Source -- ^ The source of the term. :: Source -- ^ The source of the term.
-> Category -- ^ The category for the term. -> Category -- ^ The category for the term.
-> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term. -> [ Term S.Syntax (Record DefaultFields) ] -- ^ The child nodes of the term.
-> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe. -> Maybe (S.Syntax (Term S.Syntax (Record DefaultFields))) -- ^ The resulting term, in Maybe.
termAssignment _ category children termAssignment _ category children
= case (category, children) of = case (category, children) of
(ArgumentPair, [ k, v ] ) -> Just $ S.Pair k v (ArgumentPair, [ k, v ] ) -> Just $ S.Pair k v

8
src/Parser.hs
View File

@ -47,14 +47,14 @@ data Parser term where
-> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's. -> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's.
-> Parser (Term (Union fs) (Record Location)) -- ^ A parser producing 'Term's. -> Parser (Term (Union fs) (Record Location)) -- ^ A parser producing 'Term's.
-- | A tree-sitter parser. -- | A tree-sitter parser.
TreeSitterParser :: Ptr TS.Language -> Parser (SyntaxTerm DefaultFields) TreeSitterParser :: Ptr TS.Language -> Parser (Term Syntax (Record DefaultFields))
-- | A parser for 'Markdown' using cmark. -- | A parser for 'Markdown' using cmark.
MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar)) MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar))
-- | A parser which will parse any input 'Source' into a top-level 'Term' whose children are leaves consisting of the 'Source's lines. -- | A parser which will parse any input 'Source' into a top-level 'Term' whose children are leaves consisting of the 'Source's lines.
LineByLineParser :: Parser (SyntaxTerm DefaultFields) LineByLineParser :: Parser (Term Syntax (Record DefaultFields))
-- | Return a 'Language'-specific 'Parser', if one exists, falling back to the 'LineByLineParser'. -- | Return a 'Language'-specific 'Parser', if one exists, falling back to the 'LineByLineParser'.
parserForLanguage :: Maybe Language -> Parser (SyntaxTerm DefaultFields) parserForLanguage :: Maybe Language -> Parser (Term Syntax (Record DefaultFields))
parserForLanguage Nothing = LineByLineParser parserForLanguage Nothing = LineByLineParser
parserForLanguage (Just language) = case language of parserForLanguage (Just language) = case language of
Go -> TreeSitterParser tree_sitter_go Go -> TreeSitterParser tree_sitter_go
@ -82,6 +82,6 @@ markdownParser = AssignmentParser MarkdownParser Markdown.assignment
-- | A fallback parser that treats a file simply as rows of strings. -- | A fallback parser that treats a file simply as rows of strings.
lineByLineParser :: Source -> SyntaxTerm DefaultFields lineByLineParser :: Source -> Term Syntax (Record DefaultFields)
lineByLineParser source = termIn (totalRange source :. Program :. totalSpan source :. Nil) (Indexed (zipWith toLine [1..] (sourceLineRanges source))) lineByLineParser source = termIn (totalRange source :. Program :. totalSpan source :. Nil) (Indexed (zipWith toLine [1..] (sourceLineRanges source)))
where toLine line range = termIn (range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) (Leaf (toText (slice range source))) where toLine line range = termIn (range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) (Leaf (toText (slice range source)))

87
src/Patch.hs
View File

@ -4,68 +4,79 @@ module Patch
( Patch(..) ( Patch(..)
, after , after
, before , before
, unPatch , patch
, maybeFst
, maybeSnd
, mapPatch
) where ) where
import Data.Aeson import Data.Aeson
import Data.Align import Data.Align
import Data.Functor.Classes.Eq.Generic import Data.Bifoldable
import Data.Functor.Classes.Show.Generic import Data.Bifunctor
import Data.Bitraversable
import Data.Functor.Classes
import Data.JSON.Fields import Data.JSON.Fields
import Data.These import Data.These
import GHC.Generics import GHC.Generics
-- | An operation to replace, insert, or delete an item. -- | An operation to replace, insert, or delete an item.
data Patch a data Patch a b
= Replace a a = Delete a
| Insert a | Insert b
| Delete a | Replace a b
deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable) deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
-- | Return the item from the after side of the patch. -- | Return the item from the after side of the patch.
after :: Patch a -> Maybe a after :: Patch before after -> Maybe after
after = maybeSnd . unPatch after = patch (const Nothing) Just (\ _ b -> Just b)
-- | Return the item from the before side of the patch. -- | Return the item from the before side of the patch.
before :: Patch a -> Maybe a before :: Patch before after -> Maybe before
before = maybeFst . unPatch before = patch Just (const Nothing) (\ a _ -> Just a)
-- | Return both sides of a patch. -- | Return both sides of a patch.
unPatch :: Patch a -> These a a patch :: (before -> result) -> (after -> result) -> (before -> after -> result) -> Patch before after -> result
unPatch (Replace a b) = These a b patch ifDelete _ _ (Delete a) = ifDelete a
unPatch (Insert b) = That b patch _ ifInsert _ (Insert b) = ifInsert b
unPatch (Delete a) = This a patch _ _ ifReplace (Replace a b) = ifReplace a b
mapPatch :: (a -> b) -> (a -> b) -> Patch a -> Patch b
mapPatch f _ (Delete a ) = Delete (f a)
mapPatch _ g (Insert b) = Insert (g b)
mapPatch f g (Replace a b) = Replace (f a) (g b)
-- | Return Just the value in This, or the first value in These, if any.
maybeFst :: These a b -> Maybe a
maybeFst = these Just (const Nothing) ((Just .) . const)
-- | Return Just the value in That, or the second value in These, if any.
maybeSnd :: These a b -> Maybe b
maybeSnd = these (const Nothing) Just ((Just .) . flip const)
-- Instances -- Instances
instance Crosswalk Patch where instance Bifunctor Patch where
crosswalk f (Replace a b) = alignWith (these Delete Insert Replace) (f a) (f b) bimap f _ (Delete a) = Delete (f a)
crosswalk f (Insert b) = Insert <$> f b bimap _ g (Insert b) = Insert (g b)
crosswalk f (Delete a) = Delete <$> f a bimap f g (Replace a b) = Replace (f a) (g b)
instance Eq1 Patch where liftEq = genericLiftEq instance Bifoldable Patch where
instance Show1 Patch where liftShowsPrec = genericLiftShowsPrec bifoldMap f _ (Delete a) = f a
bifoldMap _ g (Insert b) = g b
bifoldMap f g (Replace a b) = f a `mappend` g b
instance Bitraversable Patch where
bitraverse f _ (Delete a) = Delete <$> f a
bitraverse _ g (Insert b) = Insert <$> g b
bitraverse f g (Replace a b) = Replace <$> f a <*> g b
instance Bicrosswalk Patch where
bicrosswalk f _ (Delete a) = Delete <$> f a
bicrosswalk _ g (Insert b) = Insert <$> g b
bicrosswalk f g (Replace a b) = alignWith (these Delete Insert Replace) (f a) (g b)
instance Eq2 Patch where
liftEq2 eqBefore eqAfter p1 p2 = case (p1, p2) of
(Delete a1, Delete a2) -> eqBefore a1 a2
(Insert b1, Insert b2) -> eqAfter b1 b2
(Replace a1 b1, Replace a2 b2) -> eqBefore a1 a2 && eqAfter b1 b2
_ -> False
instance Show2 Patch where
liftShowsPrec2 spBefore _ spAfter _ d p = case p of
Delete a -> showsUnaryWith spBefore "Delete" d a
Insert b -> showsUnaryWith spAfter "Insert" d b
Replace a b -> showsBinaryWith spBefore spAfter "Replace" d a b
instance ToJSONFields a => ToJSONFields (Patch a) where instance (ToJSONFields a, ToJSONFields b) => ToJSONFields (Patch a b) where
toJSONFields (Insert a) = [ "insert" .= object (toJSONFields a) ] toJSONFields (Insert a) = [ "insert" .= object (toJSONFields a) ]
toJSONFields (Delete a) = [ "delete" .= object (toJSONFields a) ] toJSONFields (Delete a) = [ "delete" .= object (toJSONFields a) ]
toJSONFields (Replace a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ] toJSONFields (Replace a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ]

240
src/RWS.hs
View File

@ -1,25 +1,25 @@
{-# LANGUAGE GADTs, DataKinds, RankNTypes, TypeOperators #-} {-# LANGUAGE GADTs, DataKinds, RankNTypes, TypeOperators #-}
module RWS ( module RWS
rws ( rws
, ComparabilityRelation , ComparabilityRelation
, FeatureVector , FeatureVector(..)
, defaultFeatureVectorDecorator , defaultFeatureVectorDecorator
, featureVectorDecorator , featureVectorDecorator
, pqGramDecorator , pqGramDecorator
, Gram(..) , Gram(..)
, defaultD , defaultD
) where ) where
import Control.Applicative (empty) import Control.Applicative (empty)
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Data.Align.Generic
import Data.Foldable import Data.Foldable
import Data.Function ((&), on) import Data.Function ((&))
import Data.Functor.Foldable import Data.Functor.Foldable
import Data.Hashable import Data.Hashable
import Data.List (sortOn) import Data.List (sortOn)
import Data.Maybe import Data.Maybe
import Data.Monoid (First(..))
import Data.Record import Data.Record
import Data.Semigroup hiding (First(..)) import Data.Semigroup hiding (First(..))
import Data.These import Data.These
@ -27,9 +27,9 @@ import Data.Traversable
import Term import Term
import Data.Array.Unboxed import Data.Array.Unboxed
import Data.Functor.Classes import Data.Functor.Classes
import Diff (DiffF(..), deleting, inserting, merge, replacing)
import SES import SES
import qualified Data.Functor.Both as Both import Data.KdMap.Static hiding (elems, empty)
import Data.KdTree.Static hiding (empty, toList)
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
import Control.Monad.Random import Control.Monad.Random
@ -40,61 +40,64 @@ type Label f fields label = forall b. TermF f (Record fields) b -> label
-- | A relation on 'Term's, guaranteed constant-time in the size of the 'Term' by parametricity. -- | A relation on 'Term's, guaranteed constant-time in the size of the 'Term' by parametricity.
-- --
-- This is used both to determine whether two root terms can be compared in O(1), and, recursively, to determine whether two nodes are equal in O(n); thus, comparability is defined s.t. two terms are equal if they are recursively comparable subterm-wise. -- This is used both to determine whether two root terms can be compared in O(1), and, recursively, to determine whether two nodes are equal in O(n); thus, comparability is defined s.t. two terms are equal if they are recursively comparable subterm-wise.
type ComparabilityRelation f fields = forall a b. TermF f (Record fields) a -> TermF f (Record fields) b -> Bool type ComparabilityRelation syntax ann1 ann2 = forall a b. TermF syntax ann1 a -> TermF syntax ann2 b -> Bool
type FeatureVector = UArray Int Double newtype FeatureVector = FV { unFV :: UArray Int Double }
deriving (Eq, Ord, Show)
-- | A term which has not yet been mapped by `rws`, along with its feature vector summary & index. -- | A term which has not yet been mapped by `rws`, along with its feature vector summary & index.
data UnmappedTerm f fields = UnmappedTerm { data UnmappedTerm syntax ann = UnmappedTerm
termIndex :: {-# UNPACK #-} !Int -- ^ The index of the term within its root term. { termIndex :: {-# UNPACK #-} !Int -- ^ The index of the term within its root term.
, feature :: {-# UNPACK #-} !FeatureVector -- ^ Feature vector , feature :: {-# UNPACK #-} !FeatureVector -- ^ Feature vector
, term :: Term f (Record fields) -- ^ The unmapped term , term :: Term syntax ann -- ^ The unmapped term
} }
-- | Either a `term`, an index of a matched term, or nil. -- | Either a `term`, an index of a matched term, or nil.
data TermOrIndexOrNone term = Term term | Index {-# UNPACK #-} !Int | None data TermOrIndexOrNone term = Term term | Index {-# UNPACK #-} !Int | None
rws :: (HasField fields FeatureVector, Functor f, Eq1 f) rws :: (Eq1 syntax, Foldable syntax, Functor syntax, GAlign syntax)
=> (Diff f fields -> Int) => ComparabilityRelation syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))
-> ComparabilityRelation f fields -> [Term syntax (Record (FeatureVector ': fields1))]
-> [Term f (Record fields)] -> [Term syntax (Record (FeatureVector ': fields2))]
-> [Term f (Record fields)] -> RWSEditScript syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))
-> RWSEditScript f fields rws _ as [] = This <$> as
rws _ _ as [] = This <$> as rws _ [] bs = That <$> bs
rws _ _ [] bs = That <$> bs rws canCompare [a] [b] = if canCompareTerms canCompare a b then [These a b] else [That b, This a]
rws _ canCompare [a] [b] = if canCompareTerms canCompare a b then [These a b] else [That b, This a] rws canCompare as bs =
rws editDistance canCompare as bs =
let sesDiffs = ses (equalTerms canCompare) as bs let sesDiffs = ses (equalTerms canCompare) as bs
(featureAs, featureBs, mappedDiffs, allDiffs) = genFeaturizedTermsAndDiffs sesDiffs (featureAs, featureBs, mappedDiffs, allDiffs) = genFeaturizedTermsAndDiffs sesDiffs
(diffs, remaining) = findNearestNeighboursToDiff editDistance canCompare allDiffs featureAs featureBs (diffs, remaining) = findNearestNeighboursToDiff canCompare allDiffs featureAs featureBs
diffs' = deleteRemaining diffs remaining diffs' = deleteRemaining diffs remaining
rwsDiffs = insertMapped mappedDiffs diffs' rwsDiffs = insertMapped mappedDiffs diffs'
in fmap snd rwsDiffs in fmap snd rwsDiffs
-- | An IntMap of unmapped terms keyed by their position in a list of terms. -- | An IntMap of unmapped terms keyed by their position in a list of terms.
type UnmappedTerms f fields = IntMap.IntMap (UnmappedTerm f fields) type UnmappedTerms syntax ann = IntMap.IntMap (UnmappedTerm syntax ann)
type Diff f fields = These (Term f (Record fields)) (Term f (Record fields)) type Edit syntax ann1 ann2 = These (Term syntax ann1) (Term syntax ann2)
-- A Diff paired with both its indices -- A Diff paired with both its indices
type MappedDiff f fields = (These Int Int, Diff f fields) type MappedDiff syntax ann1 ann2 = (These Int Int, Edit syntax ann1 ann2)
type RWSEditScript f fields = [Diff f fields] type RWSEditScript syntax ann1 ann2 = [Edit syntax ann1 ann2]
insertMapped :: Foldable t => t (MappedDiff f fields) -> [MappedDiff f fields] -> [MappedDiff f fields] insertMapped :: Foldable t
=> t (MappedDiff syntax ann1 ann2)
-> [MappedDiff syntax ann1 ann2]
-> [MappedDiff syntax ann1 ann2]
insertMapped diffs into = foldl' (flip insertDiff) into diffs insertMapped diffs into = foldl' (flip insertDiff) into diffs
deleteRemaining :: (Traversable t) deleteRemaining :: Traversable t
=> [MappedDiff f fields] => [MappedDiff syntax ann1 ann2]
-> t (UnmappedTerm f fields) -> t (UnmappedTerm syntax ann1)
-> [MappedDiff f fields] -> [MappedDiff syntax ann1 ann2]
deleteRemaining diffs unmappedAs = deleteRemaining diffs unmappedAs =
foldl' (flip insertDiff) diffs ((This . termIndex &&& This . term) <$> unmappedAs) foldl' (flip insertDiff) diffs ((This . termIndex &&& This . term) <$> unmappedAs)
-- | Inserts an index and diff pair into a list of indices and diffs. -- | Inserts an index and diff pair into a list of indices and diffs.
insertDiff :: MappedDiff f fields insertDiff :: MappedDiff syntax ann1 ann2
-> [MappedDiff f fields] -> [MappedDiff syntax ann1 ann2]
-> [MappedDiff f fields] -> [MappedDiff syntax ann1 ann2]
insertDiff inserted [] = [ inserted ] insertDiff inserted [] = [ inserted ]
insertDiff a@(ij1, _) (b@(ij2, _):rest) = case (ij1, ij2) of insertDiff a@(ij1, _) (b@(ij2, _):rest) = case (ij1, ij2) of
(These i1 i2, These j1 j2) -> if i1 <= j1 && i2 <= j2 then a : b : rest else b : insertDiff a rest (These i1 i2, These j1 j2) -> if i1 <= j1 && i2 <= j2 then a : b : rest else b : insertDiff a rest
@ -117,44 +120,46 @@ insertDiff a@(ij1, _) (b@(ij2, _):rest) = case (ij1, ij2) of
That j2 -> if i2 <= j2 then (before, each : after) else (each : before, after) That j2 -> if i2 <= j2 then (before, each : after) else (each : before, after)
These _ _ -> (before, after) These _ _ -> (before, after)
findNearestNeighboursToDiff :: (These (Term f (Record fields)) (Term f (Record fields)) -> Int) -- ^ A function computes a constant-time approximation to the edit distance between two terms. findNearestNeighboursToDiff :: (Foldable syntax, Functor syntax, GAlign syntax)
-> ComparabilityRelation f fields -- ^ A relation determining whether two terms can be compared. => ComparabilityRelation syntax ann1 ann2 -- ^ A relation determining whether two terms can be compared.
-> [TermOrIndexOrNone (UnmappedTerm f fields)] -> [TermOrIndexOrNone (UnmappedTerm syntax ann2)]
-> [UnmappedTerm f fields] -> [UnmappedTerm syntax ann1]
-> [UnmappedTerm f fields] -> [UnmappedTerm syntax ann2]
-> ([(These Int Int, These (Term f (Record fields)) (Term f (Record fields)))], UnmappedTerms f fields) -> ([MappedDiff syntax ann1 ann2], UnmappedTerms syntax ann1)
findNearestNeighboursToDiff editDistance canCompare allDiffs featureAs featureBs = (diffs, remaining) findNearestNeighboursToDiff canCompare allDiffs featureAs featureBs = (diffs, remaining)
where where
(diffs, (_, remaining, _)) = (diffs, (_, remaining, _)) =
traverse (findNearestNeighbourToDiff' editDistance canCompare (toKdTree <$> Both.both featureAs featureBs)) allDiffs & traverse (findNearestNeighbourToDiff' canCompare (toKdMap featureAs) (toKdMap featureBs)) allDiffs &
fmap catMaybes & fmap catMaybes &
(`runState` (minimumTermIndex featureAs, toMap featureAs, toMap featureBs)) (`runState` (minimumTermIndex featureAs, toMap featureAs, toMap featureBs))
findNearestNeighbourToDiff' :: (Diff f fields -> Int) -- ^ A function computes a constant-time approximation to the edit distance between two terms. findNearestNeighbourToDiff' :: (Foldable syntax, Functor syntax, GAlign syntax)
-> ComparabilityRelation f fields -- ^ A relation determining whether two terms can be compared. => ComparabilityRelation syntax ann1 ann2 -- ^ A relation determining whether two terms can be compared.
-> Both.Both (KdTree Double (UnmappedTerm f fields)) -> KdMap Double FeatureVector (UnmappedTerm syntax ann1)
-> TermOrIndexOrNone (UnmappedTerm f fields) -> KdMap Double FeatureVector (UnmappedTerm syntax ann2)
-> State (Int, UnmappedTerms f fields, UnmappedTerms f fields) -> TermOrIndexOrNone (UnmappedTerm syntax ann2)
(Maybe (MappedDiff f fields)) -> State (Int, UnmappedTerms syntax ann1, UnmappedTerms syntax ann2)
findNearestNeighbourToDiff' editDistance canCompare kdTrees termThing = case termThing of (Maybe (MappedDiff syntax ann1 ann2))
findNearestNeighbourToDiff' canCompare kdTreeA kdTreeB termThing = case termThing of
None -> pure Nothing None -> pure Nothing
RWS.Term term -> Just <$> findNearestNeighbourTo editDistance canCompare kdTrees term RWS.Term term -> Just <$> findNearestNeighbourTo canCompare kdTreeA kdTreeB term
Index i -> modify' (\ (_, unA, unB) -> (i, unA, unB)) >> pure Nothing Index i -> modify' (\ (_, unA, unB) -> (i, unA, unB)) >> pure Nothing
-- | Construct a diff for a term in B by matching it against the most similar eligible term in A (if any), marking both as ineligible for future matches. -- | Construct a diff for a term in B by matching it against the most similar eligible term in A (if any), marking both as ineligible for future matches.
findNearestNeighbourTo :: (Diff f fields -> Int) -- ^ A function computes a constant-time approximation to the edit distance between two terms. findNearestNeighbourTo :: (Foldable syntax, Functor syntax, GAlign syntax)
-> ComparabilityRelation f fields -- ^ A relation determining whether two terms can be compared. => ComparabilityRelation syntax ann1 ann2 -- ^ A relation determining whether two terms can be compared.
-> Both.Both (KdTree Double (UnmappedTerm f fields)) -> KdMap Double FeatureVector (UnmappedTerm syntax ann1)
-> UnmappedTerm f fields -> KdMap Double FeatureVector (UnmappedTerm syntax ann2)
-> State (Int, UnmappedTerms f fields, UnmappedTerms f fields) -> UnmappedTerm syntax ann2
(MappedDiff f fields) -> State (Int, UnmappedTerms syntax ann1, UnmappedTerms syntax ann2)
findNearestNeighbourTo editDistance canCompare kdTrees term@(UnmappedTerm j _ b) = do (MappedDiff syntax ann1 ann2)
findNearestNeighbourTo canCompare kdTreeA kdTreeB term@(UnmappedTerm j _ b) = do
(previous, unmappedA, unmappedB) <- get (previous, unmappedA, unmappedB) <- get
fromMaybe (insertion previous unmappedA unmappedB term) $ do fromMaybe (insertion previous unmappedA unmappedB term) $ do
-- Look up the nearest unmapped term in `unmappedA`. -- Look up the nearest unmapped term in `unmappedA`.
foundA@(UnmappedTerm i _ a) <- nearestUnmapped editDistance canCompare (termsWithinMoveBoundsFrom previous unmappedA) (Both.fst kdTrees) term foundA@(UnmappedTerm i _ a) <- nearestUnmapped canCompare (termsWithinMoveBoundsFrom previous unmappedA) kdTreeA term
-- Look up the nearest `foundA` in `unmappedB` -- Look up the nearest `foundA` in `unmappedB`
UnmappedTerm j' _ _ <- nearestUnmapped editDistance canCompare (termsWithinMoveBoundsFrom (pred j) unmappedB) (Both.snd kdTrees) foundA UnmappedTerm j' _ _ <- nearestUnmapped (flip canCompare) (termsWithinMoveBoundsFrom (pred j) unmappedB) kdTreeB foundA
-- Return Nothing if their indices don't match -- Return Nothing if their indices don't match
guard (j == j') guard (j == j')
guard (canCompareTerms canCompare a b) guard (canCompareTerms canCompare a b)
@ -171,18 +176,23 @@ isInMoveBounds previous i = previous < i && i < previous + defaultMoveBound
-- RWS can produce false positives in the case of e.g. hash collisions. Therefore, we find the _l_ nearest candidates, filter out any which have already been mapped, and select the minimum of the remaining by (a constant-time approximation of) edit distance. -- RWS can produce false positives in the case of e.g. hash collisions. Therefore, we find the _l_ nearest candidates, filter out any which have already been mapped, and select the minimum of the remaining by (a constant-time approximation of) edit distance.
-- --
-- cf §4.2 of RWS-Diff -- cf §4.2 of RWS-Diff
nearestUnmapped nearestUnmapped :: (Foldable syntax, Functor syntax, GAlign syntax)
:: (Diff f fields -> Int) -- ^ A function computes a constant-time approximation to the edit distance between two terms. => ComparabilityRelation syntax ann1 ann2 -- ^ A relation determining whether two terms can be compared.
-> ComparabilityRelation f fields -- ^ A relation determining whether two terms can be compared. -> UnmappedTerms syntax ann1 -- ^ A set of terms eligible for matching against.
-> UnmappedTerms f fields -- ^ A set of terms eligible for matching against. -> KdMap Double FeatureVector (UnmappedTerm syntax ann1) -- ^ The k-d tree to look up nearest neighbours within.
-> KdTree Double (UnmappedTerm f fields) -- ^ The k-d tree to look up nearest neighbours within. -> UnmappedTerm syntax ann2 -- ^ The term to find the nearest neighbour to.
-> UnmappedTerm f fields -- ^ The term to find the nearest neighbour to. -> Maybe (UnmappedTerm syntax ann1) -- ^ The most similar unmapped term, if any.
-> Maybe (UnmappedTerm f fields) -- ^ The most similar unmapped term, if any. nearestUnmapped canCompare unmapped tree key = listToMaybe (sortOn approximateEditDistance candidates)
nearestUnmapped editDistance canCompare unmapped tree key = getFirst $ foldMap (First . Just) (sortOn (editDistanceIfComparable editDistance canCompare (term key) . term) (toList (IntMap.intersection unmapped (toMap (kNearest tree defaultL key))))) where candidates = toList (IntMap.intersection unmapped (toMap (fmap snd (kNearest tree defaultL (feature key)))))
approximateEditDistance = editDistanceIfComparable (flip canCompare) (term key) . term
editDistanceIfComparable :: Bounded t => (These (Term f (Record fields)) (Term f (Record fields)) -> t) -> ComparabilityRelation f fields -> Term f (Record fields) -> Term f (Record fields) -> t editDistanceIfComparable :: (Foldable syntax, Functor syntax, GAlign syntax)
editDistanceIfComparable editDistance canCompare a b = if canCompareTerms canCompare a b => ComparabilityRelation syntax ann1 ann2
then editDistance (These a b) -> Term syntax ann1
-> Term syntax ann2
-> Int
editDistanceIfComparable canCompare a b = if canCompareTerms canCompare a b
then editDistanceUpTo defaultM (These a b)
else maxBound else maxBound
defaultD, defaultL, defaultP, defaultQ, defaultMoveBound :: Int defaultD, defaultL, defaultP, defaultQ, defaultMoveBound :: Int
@ -196,46 +206,57 @@ defaultMoveBound = 2
-- Returns a state (insertion index, old unmapped terms, new unmapped terms), and value of (index, inserted diff), -- Returns a state (insertion index, old unmapped terms, new unmapped terms), and value of (index, inserted diff),
-- given a previous index, two sets of umapped terms, and an unmapped term to insert. -- given a previous index, two sets of umapped terms, and an unmapped term to insert.
insertion :: Int insertion :: Int
-> UnmappedTerms f fields -> UnmappedTerms syntax ann1
-> UnmappedTerms f fields -> UnmappedTerms syntax ann2
-> UnmappedTerm f fields -> UnmappedTerm syntax ann2
-> State (Int, UnmappedTerms f fields, UnmappedTerms f fields) -> State (Int, UnmappedTerms syntax ann1, UnmappedTerms syntax ann2)
(MappedDiff f fields) (MappedDiff syntax ann1 ann2)
insertion previous unmappedA unmappedB (UnmappedTerm j _ b) = do insertion previous unmappedA unmappedB (UnmappedTerm j _ b) = do
put (previous, unmappedA, IntMap.delete j unmappedB) put (previous, unmappedA, IntMap.delete j unmappedB)
pure (That j, That b) pure (That j, That b)
genFeaturizedTermsAndDiffs :: (Functor f, HasField fields FeatureVector) genFeaturizedTermsAndDiffs :: Functor syntax
=> RWSEditScript f fields => RWSEditScript syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))
-> ([UnmappedTerm f fields], [UnmappedTerm f fields], [MappedDiff f fields], [TermOrIndexOrNone (UnmappedTerm f fields)]) -> ( [UnmappedTerm syntax (Record (FeatureVector ': fields1))]
, [UnmappedTerm syntax (Record (FeatureVector ': fields2))]
, [MappedDiff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))]
, [TermOrIndexOrNone (UnmappedTerm syntax (Record (FeatureVector ': fields2)))]
)
genFeaturizedTermsAndDiffs sesDiffs = let Mapping _ _ a b c d = foldl' combine (Mapping 0 0 [] [] [] []) sesDiffs in (reverse a, reverse b, reverse c, reverse d) genFeaturizedTermsAndDiffs sesDiffs = let Mapping _ _ a b c d = foldl' combine (Mapping 0 0 [] [] [] []) sesDiffs in (reverse a, reverse b, reverse c, reverse d)
where combine (Mapping counterA counterB as bs mappedDiffs allDiffs) diff = case diff of where combine (Mapping counterA counterB as bs mappedDiffs allDiffs) diff = case diff of
This term -> Mapping (succ counterA) counterB (featurize counterA term : as) bs mappedDiffs (None : allDiffs) This term -> Mapping (succ counterA) counterB (featurize counterA term : as) bs mappedDiffs (None : allDiffs)
That term -> Mapping counterA (succ counterB) as (featurize counterB term : bs) mappedDiffs (RWS.Term (featurize counterB term) : allDiffs) That term -> Mapping counterA (succ counterB) as (featurize counterB term : bs) mappedDiffs (RWS.Term (featurize counterB term) : allDiffs)
These a b -> Mapping (succ counterA) (succ counterB) as bs ((These counterA counterB, These a b) : mappedDiffs) (Index counterA : allDiffs) These a b -> Mapping (succ counterA) (succ counterB) as bs ((These counterA counterB, These a b) : mappedDiffs) (Index counterA : allDiffs)
data Mapping f fields = Mapping {-# UNPACK #-} !Int {-# UNPACK #-} !Int ![UnmappedTerm f fields] ![UnmappedTerm f fields] ![MappedDiff f fields] ![TermOrIndexOrNone (UnmappedTerm f fields)] data Mapping syntax ann1 ann2
= Mapping
{-# UNPACK #-} !Int
{-# UNPACK #-} !Int
![UnmappedTerm syntax ann1]
![UnmappedTerm syntax ann2]
![MappedDiff syntax ann1 ann2]
![TermOrIndexOrNone (UnmappedTerm syntax ann2)]
featurize :: (HasField fields FeatureVector, Functor f) => Int -> Term f (Record fields) -> UnmappedTerm f fields featurize :: Functor syntax => Int -> Term syntax (Record (FeatureVector ': fields)) -> UnmappedTerm syntax (Record (FeatureVector ': fields))
featurize index term = UnmappedTerm index (getField (extract term)) (eraseFeatureVector term) featurize index term = UnmappedTerm index (getField (extract term)) (eraseFeatureVector term)
eraseFeatureVector :: (Functor f, HasField fields FeatureVector) => Term f (Record fields) -> Term f (Record fields) eraseFeatureVector :: Functor syntax => Term syntax (Record (FeatureVector ': fields)) -> Term syntax (Record (FeatureVector ': fields))
eraseFeatureVector (Term.Term (In record functor)) = termIn (setFeatureVector record nullFeatureVector) functor eraseFeatureVector (Term.Term (In record functor)) = termIn (setFeatureVector record nullFeatureVector) functor
nullFeatureVector :: FeatureVector nullFeatureVector :: FeatureVector
nullFeatureVector = listArray (0, 0) [0] nullFeatureVector = FV $ listArray (0, 0) [0]
setFeatureVector :: HasField fields FeatureVector => Record fields -> FeatureVector -> Record fields setFeatureVector :: Record (FeatureVector ': fields) -> FeatureVector -> Record (FeatureVector ': fields)
setFeatureVector = setField setFeatureVector = setField
minimumTermIndex :: [RWS.UnmappedTerm f fields] -> Int minimumTermIndex :: [UnmappedTerm syntax ann] -> Int
minimumTermIndex = pred . maybe 0 getMin . getOption . foldMap (Option . Just . Min . termIndex) minimumTermIndex = pred . maybe 0 getMin . getOption . foldMap (Option . Just . Min . termIndex)
toMap :: [UnmappedTerm f fields] -> IntMap.IntMap (UnmappedTerm f fields) toMap :: [UnmappedTerm syntax ann] -> IntMap.IntMap (UnmappedTerm syntax ann)
toMap = IntMap.fromList . fmap (termIndex &&& id) toMap = IntMap.fromList . fmap (termIndex &&& id)
toKdTree :: [UnmappedTerm f fields] -> KdTree Double (UnmappedTerm f fields) toKdMap :: [UnmappedTerm syntax ann] -> KdMap Double FeatureVector (UnmappedTerm syntax ann)
toKdTree = build (elems . feature) toKdMap = build (elems . unFV) . fmap (feature &&& id)
-- | A `Gram` is a fixed-size view of some portion of a tree, consisting of a `stem` of _p_ labels for parent nodes, and a `base` of _q_ labels of sibling nodes. Collectively, the bag of `Gram`s for each node of a tree (e.g. as computed by `pqGrams`) form a summary of the tree. -- | A `Gram` is a fixed-size view of some portion of a tree, consisting of a `stem` of _p_ labels for parent nodes, and a `base` of _q_ labels of sibling nodes. Collectively, the bag of `Gram`s for each node of a tree (e.g. as computed by `pqGrams`) form a summary of the tree.
data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] } data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] }
@ -258,8 +279,8 @@ featureVectorDecorator getLabel p q d
addSubtermVector :: Functor f => FeatureVector -> Term f (Record (FeatureVector ': fields)) -> FeatureVector addSubtermVector :: Functor f => FeatureVector -> Term f (Record (FeatureVector ': fields)) -> FeatureVector
addSubtermVector v term = addVectors v (rhead (extract term)) addSubtermVector v term = addVectors v (rhead (extract term))
addVectors :: UArray Int Double -> UArray Int Double -> UArray Int Double addVectors :: FeatureVector -> FeatureVector -> FeatureVector
addVectors as bs = listArray (0, d - 1) (fmap (\ i -> as ! i + bs ! i) [0..(d - 1)]) addVectors (FV as) (FV bs) = FV $ listArray (0, d - 1) (fmap (\ i -> as ! i + bs ! i) [0..(d - 1)])
-- | Annotates a term with the corresponding p,q-gram at each node. -- | Annotates a term with the corresponding p,q-gram at each node.
pqGramDecorator pqGramDecorator
@ -290,21 +311,36 @@ pqGramDecorator getLabel p q = cata algebra
-- | Computes a unit vector of the specified dimension from a hash. -- | Computes a unit vector of the specified dimension from a hash.
unitVector :: Int -> Int -> FeatureVector unitVector :: Int -> Int -> FeatureVector
unitVector d hash = listArray (0, d - 1) ((* invMagnitude) <$> components) unitVector d hash = FV $ listArray (0, d - 1) ((* invMagnitude) <$> components)
where where
invMagnitude = 1 / sqrt (sum (fmap (** 2) components)) invMagnitude = 1 / sqrt (sum (fmap (** 2) components))
components = evalRand (sequenceA (replicate d (liftRand randomDouble))) (pureMT (fromIntegral hash)) components = evalRand (sequenceA (replicate d (liftRand randomDouble))) (pureMT (fromIntegral hash))
-- | Test the comparability of two root 'Term's in O(1). -- | Test the comparability of two root 'Term's in O(1).
canCompareTerms :: ComparabilityRelation f fields -> Term f (Record fields) -> Term f (Record fields) -> Bool canCompareTerms :: ComparabilityRelation syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Bool
canCompareTerms canCompare = canCompare `on` unTerm canCompareTerms canCompare t1 t2 = canCompare (unTerm t1) (unTerm t2)
-- | Recursively test the equality of two 'Term's in O(n). -- | Recursively test the equality of two 'Term's in O(n).
equalTerms :: Eq1 f => ComparabilityRelation f fields -> Term f (Record fields) -> Term f (Record fields) -> Bool equalTerms :: Eq1 syntax => ComparabilityRelation syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Bool
equalTerms canCompare = go equalTerms canCompare = go
where go a b = canCompareTerms canCompare a b && liftEq go (termOut (unTerm a)) (termOut (unTerm b)) where go a b = canCompareTerms canCompare a b && liftEq go (termOut (unTerm a)) (termOut (unTerm b))
-- | How many nodes to consider for our constant-time approximation to tree edit distance.
defaultM :: Integer
defaultM = 10
-- | Return an edit distance as the sum of it's term sizes, given an cutoff and a syntax of terms 'f a'.
-- | Computes a constant-time approximation to the edit distance of a diff. This is done by comparing at most _m_ nodes, & assuming the rest are zero-cost.
editDistanceUpTo :: (GAlign syntax, Foldable syntax, Functor syntax) => Integer -> Edit syntax ann1 ann2 -> Int
editDistanceUpTo m = these termSize termSize (\ a b -> diffCost m (approximateDiff a b))
where diffCost = flip . cata $ \ diff m -> case diff of
_ | m <= 0 -> 0
Merge body -> sum (fmap ($ pred m) body)
body -> succ (sum (fmap ($ pred m) body))
approximateDiff a b = maybe (replacing a b) (merge (extract a, extract b)) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b))
-- Instances -- Instances
instance Hashable label => Hashable (Gram label) where instance Hashable label => Hashable (Gram label) where

11
src/Renderer.hs
View File

@ -24,9 +24,10 @@ import Data.Foldable (asum)
import Data.JSON.Fields import Data.JSON.Fields
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Output import Data.Output
import Data.Record
import Data.Syntax.Algebra (RAlgebra) import Data.Syntax.Algebra (RAlgebra)
import Data.Text (Text) import Data.Text (Text)
import Diff (SyntaxDiff) import Diff
import Info (DefaultFields) import Info (DefaultFields)
import Renderer.JSON as R import Renderer.JSON as R
import Renderer.Patch as R import Renderer.Patch as R
@ -45,8 +46,8 @@ data DiffRenderer output where
JSONDiffRenderer :: DiffRenderer (Map.Map Text Value) JSONDiffRenderer :: DiffRenderer (Map.Map Text Value)
-- | Render to a 'ByteString' formatted as nested s-expressions with patches indicated. -- | Render to a 'ByteString' formatted as nested s-expressions with patches indicated.
SExpressionDiffRenderer :: DiffRenderer ByteString SExpressionDiffRenderer :: DiffRenderer ByteString
-- | “Render” by returning the computed 'SyntaxDiff'. This renderer is not surfaced in the command-line interface, and is intended strictly for tests. Further, as it cannot render à la carte terms, it should be regarded as a (very) short-term hack until such time as we have a better idea for TOCSpec.hs. -- | “Render” by returning the computed 'Diff'. This renderer is not surfaced in the command-line interface, and is intended strictly for tests. Further, as it cannot render à la carte terms, it should be regarded as a (very) short-term hack until such time as we have a better idea for TOCSpec.hs.
IdentityDiffRenderer :: DiffRenderer (Maybe (SyntaxDiff (Maybe Declaration ': DefaultFields))) IdentityDiffRenderer :: DiffRenderer (Maybe (Diff Syntax (Record (Maybe Declaration ': DefaultFields)) (Record (Maybe Declaration ': DefaultFields))))
deriving instance Eq (DiffRenderer output) deriving instance Eq (DiffRenderer output)
deriving instance Show (DiffRenderer output) deriving instance Show (DiffRenderer output)
@ -59,8 +60,8 @@ data TermRenderer output where
JSONTermRenderer :: TermRenderer [Value] JSONTermRenderer :: TermRenderer [Value]
-- | Render to a 'ByteString' formatted as nested s-expressions. -- | Render to a 'ByteString' formatted as nested s-expressions.
SExpressionTermRenderer :: TermRenderer ByteString SExpressionTermRenderer :: TermRenderer ByteString
-- | “Render” by returning the computed 'SyntaxTerm'. This renderer is not surfaced in the command-line interface, and is intended strictly for tests. Further, as it cannot render à la carte terms, it should be regarded as a (very) short-term hack until such time as we have a better idea for SemanticSpec.hs. -- | “Render” by returning the computed 'Term'. This renderer is not surfaced in the command-line interface, and is intended strictly for tests. Further, as it cannot render à la carte terms, it should be regarded as a (very) short-term hack until such time as we have a better idea for SemanticSpec.hs.
IdentityTermRenderer :: TermRenderer (Maybe (SyntaxTerm DefaultFields)) IdentityTermRenderer :: TermRenderer (Maybe (Term Syntax (Record DefaultFields)))
deriving instance Eq (TermRenderer output) deriving instance Eq (TermRenderer output)
deriving instance Show (TermRenderer output) deriving instance Show (TermRenderer output)

8
src/Renderer/Patch.hs
View File

@ -23,7 +23,6 @@ import Data.Semigroup ((<>))
import Data.Source import Data.Source
import Data.These import Data.These
import Diff import Diff
import Patch
import Prelude hiding (fst, snd) import Prelude hiding (fst, snd)
import SplitDiff import SplitDiff
@ -32,7 +31,7 @@ truncatePatch :: Both Blob -> ByteString
truncatePatch blobs = header blobs <> "#timed_out\nTruncating diff: timeout reached.\n" truncatePatch blobs = header blobs <> "#timed_out\nTruncating diff: timeout reached.\n"
-- | Render a diff in the traditional patch format. -- | Render a diff in the traditional patch format.
renderPatch :: (HasField fields Range, Traversable f) => Both Blob -> Diff f (Record fields) -> File renderPatch :: (HasField fields Range, Traversable f) => Both Blob -> Diff f (Record fields) (Record fields) -> File
renderPatch blobs diff = File $ if not (ByteString.null text) && ByteString.last text /= '\n' renderPatch blobs diff = File $ if not (ByteString.null text) && ByteString.last text /= '\n'
then text <> "\n\\ No newline at end of file\n" then text <> "\n\\ No newline at end of file\n"
else text else text
@ -133,7 +132,7 @@ emptyHunk :: Hunk (SplitDiff a annotation)
emptyHunk = Hunk { offset = mempty, changes = [], trailingContext = [] } emptyHunk = Hunk { offset = mempty, changes = [], trailingContext = [] }
-- | Render a diff as a series of hunks. -- | Render a diff as a series of hunks.
hunks :: (Traversable f, HasField fields Range) => Diff f (Record fields) -> Both Blob -> [Hunk (SplitDiff [] (Record fields))] hunks :: (Traversable f, HasField fields Range) => Diff f (Record fields) (Record fields) -> Both Blob -> [Hunk (SplitDiff [] (Record fields))]
hunks _ blobs | sources <- blobSource <$> blobs hunks _ blobs | sources <- blobSource <$> blobs
, sourcesEqual <- runBothWith (==) sources , sourcesEqual <- runBothWith (==) sources
, sourcesNull <- runBothWith (&&) (nullSource <$> sources) , sourcesNull <- runBothWith (&&) (nullSource <$> sources)
@ -181,3 +180,6 @@ changeIncludingContext leadingContext rows = case changes of
-- | Whether a row has changes on either side. -- | Whether a row has changes on either side.
rowHasChanges :: (Foldable f, Functor f) => Join These (SplitDiff f annotation) -> Bool rowHasChanges :: (Foldable f, Functor f) => Join These (SplitDiff f annotation) -> Bool
rowHasChanges row = or (hasChanges <$> row) rowHasChanges row = or (hasChanges <$> row)
maybeSnd :: These a b -> Maybe b
maybeSnd = these (const Nothing) Just (\ _ a -> Just a)

8
src/Renderer/SExpression.hs
View File

@ -14,14 +14,14 @@ import Prelude hiding (replicate)
import Term import Term
-- | Returns a ByteString SExpression formatted diff. -- | Returns a ByteString SExpression formatted diff.
renderSExpressionDiff :: (ConstrainAll Show fields, Foldable f, Functor f) => Diff f (Record fields) -> ByteString renderSExpressionDiff :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => Diff syntax (Record fields) (Record fields) -> ByteString
renderSExpressionDiff diff = cata printDiffF diff 0 <> "\n" renderSExpressionDiff diff = cata printDiffF diff 0 <> "\n"
-- | Returns a ByteString SExpression formatted term. -- | Returns a ByteString SExpression formatted term.
renderSExpressionTerm :: (ConstrainAll Show fields, Foldable f, Functor f) => Term f (Record fields) -> ByteString renderSExpressionTerm :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => Term syntax (Record fields) -> ByteString
renderSExpressionTerm term = cata (\ term n -> nl n <> replicate (2 * n) ' ' <> printTermF term n) term 0 <> "\n" renderSExpressionTerm term = cata (\ term n -> nl n <> replicate (2 * n) ' ' <> printTermF term n) term 0 <> "\n"
printDiffF :: (ConstrainAll Show fields, Foldable f, Functor f) => DiffF f (Record fields) (Int -> ByteString) -> Int -> ByteString printDiffF :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => DiffF syntax (Record fields) (Record fields) (Int -> ByteString) -> Int -> ByteString
printDiffF diff n = case diff of printDiffF diff n = case diff of
Patch (Delete term) -> nl n <> pad (n - 1) <> "{-" <> printTermF term n <> "-}" Patch (Delete term) -> nl n <> pad (n - 1) <> "{-" <> printTermF term n <> "-}"
Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> printTermF term n <> "+}" Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> printTermF term n <> "+}"
@ -29,7 +29,7 @@ printDiffF diff n = case diff of
<> nl (n + 1) <> pad (n - 1) <> "->" <> printTermF term2 n <> " }" <> nl (n + 1) <> pad (n - 1) <> "->" <> printTermF term2 n <> " }"
Merge (In (_, ann) syntax) -> nl n <> pad n <> "(" <> showAnnotation ann <> foldMap (\ d -> d (n + 1)) syntax <> ")" Merge (In (_, ann) syntax) -> nl n <> pad n <> "(" <> showAnnotation ann <> foldMap (\ d -> d (n + 1)) syntax <> ")"
printTermF :: (ConstrainAll Show fields, Foldable f, Functor f) => TermF f (Record fields) (Int -> ByteString) -> Int -> ByteString printTermF :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => TermF syntax (Record fields) (Int -> ByteString) -> Int -> ByteString
printTermF (In annotation syntax) n = "(" <> showAnnotation annotation <> foldMap (\t -> t (n + 1)) syntax <> ")" printTermF (In annotation syntax) n = "(" <> showAnnotation annotation <> foldMap (\t -> t (n + 1)) syntax <> ")"
nl :: Int -> ByteString nl :: Int -> ByteString

20
src/Renderer/TOC.hs
View File

@ -18,7 +18,8 @@ module Renderer.TOC
) where ) where
import Data.Aeson import Data.Aeson
import Data.Align (crosswalk) import Data.Align (bicrosswalk)
import Data.Bifoldable (bifoldMap)
import Data.Bifunctor (bimap) import Data.Bifunctor (bimap)
import Data.Blob import Data.Blob
import Data.ByteString.Lazy (toStrict) import Data.ByteString.Lazy (toStrict)
@ -35,7 +36,6 @@ import Data.Semigroup ((<>), sconcat)
import Data.Source as Source import Data.Source as Source
import Data.Text (toLower) import Data.Text (toLower)
import qualified Data.Text as T import qualified Data.Text as T
import Data.These
import Data.Union import Data.Union
import Diff import Diff
import GHC.Generics import GHC.Generics
@ -99,7 +99,7 @@ declaration (In annotation _) = annotation <$ (getField annotation :: Maybe Decl
-- | Compute 'Declaration's for methods and functions in 'Syntax'. -- | Compute 'Declaration's for methods and functions in 'Syntax'.
syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (SyntaxTermF fields) (SyntaxTerm fields) (Maybe Declaration) syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (TermF S.Syntax (Record fields)) (Term S.Syntax (Record fields)) (Maybe Declaration)
syntaxDeclarationAlgebra Blob{..} (In a r) = case r of syntaxDeclarationAlgebra Blob{..} (In a r) = case r of
S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier) S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier)
S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier) S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier)
@ -165,17 +165,17 @@ data Entry a
-- | Compute a table of contents for a diff characterized by a function mapping relevant nodes onto values in Maybe. -- | Compute a table of contents for a diff characterized by a function mapping relevant nodes onto values in Maybe.
tableOfContentsBy :: (Foldable f, Functor f) tableOfContentsBy :: (Foldable f, Functor f)
=> (forall b. TermF f annotation b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe. => (forall b. TermF f ann b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe.
-> Diff f annotation -- ^ The diff to compute the table of contents for. -> Diff f ann ann -- ^ The diff to compute the table of contents for.
-> [Entry a] -- ^ A list of entries for relevant changed and unchanged nodes in the diff. -> [Entry a] -- ^ A list of entries for relevant changed and unchanged nodes in the diff.
tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of
Patch patch -> (pure . patchEntry <$> crosswalk selector patch) <> foldMap fold patch <> Just [] Patch patch -> (pure . patchEntry <$> bicrosswalk selector selector patch) <> bifoldMap fold fold patch <> Just []
Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of
(Just a, Nothing) -> Just [Unchanged a] (Just a, Nothing) -> Just [Unchanged a]
(Just a, Just []) -> Just [Changed a] (Just a, Just []) -> Just [Changed a]
(_ , entries) -> entries) (_ , entries) -> entries)
where patchEntry = these Deleted Inserted (const Replaced) . unPatch where patchEntry = patch Deleted Inserted (const Replaced)
termTableOfContentsBy :: (Foldable f, Functor f) termTableOfContentsBy :: (Foldable f, Functor f)
=> (forall b. TermF f annotation b -> Maybe a) => (forall b. TermF f annotation b -> Maybe a)
@ -214,7 +214,7 @@ recordSummary record = case getDeclaration record of
Just declaration -> Just . JSONSummary (toCategoryName declaration) (declarationIdentifier declaration) (sourceSpan record) Just declaration -> Just . JSONSummary (toCategoryName declaration) (declarationIdentifier declaration) (sourceSpan record)
Nothing -> const Nothing Nothing -> const Nothing
renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Both Blob -> Diff f (Record fields) -> Summaries renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Both Blob -> Diff f (Record fields) (Record fields) -> Summaries
renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC
where toMap [] = mempty where toMap [] = mempty
toMap as = Map.singleton summaryKey (toJSON <$> as) toMap as = Map.singleton summaryKey (toJSON <$> as)
@ -229,7 +229,7 @@ renderToCTerm Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition
where toMap [] = mempty where toMap [] = mempty
toMap as = Map.singleton (T.pack blobPath) (toJSON <$> as) toMap as = Map.singleton (T.pack blobPath) (toJSON <$> as)
diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Diff f (Record fields) -> [JSONSummary] diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Diff f (Record fields) (Record fields) -> [JSONSummary]
diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration
termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Term f (Record fields) -> [JSONSummary] termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Term f (Record fields) -> [JSONSummary]

72
src/SES.hs
View File

@ -1,10 +1,70 @@
{-# LANGUAGE Strict #-} {-# LANGUAGE BangPatterns, GADTs, ImplicitParams, MultiParamTypeClasses, ScopedTypeVariables #-}
module SES module SES
( Comparable ( EditScript
, Myers.ses , ses
) where ) where
import qualified SES.Myers as Myers import Data.Array ((!))
import qualified Data.Array as Array
import Data.Foldable (find, toList)
import Data.Ix
import Data.These
-- | Edit constructor for two terms, if comparable. Otherwise returns Nothing. -- | An edit script, i.e. a sequence of changes/copies of elements.
type Comparable term = term -> term -> Bool type EditScript a b = [These a b]
data Endpoint a b = Endpoint { x :: {-# UNPACK #-} !Int, _y :: {-# UNPACK #-} !Int, _script :: EditScript a b }
deriving (Eq, Show)
-- | Compute the shortest edit script using Myers’ algorithm.
ses :: (Foldable t, Foldable u) => (a -> b -> Bool) -> t a -> u b -> EditScript a b
ses eq as' bs'
| null bs = This <$> toList as
| null as = That <$> toList bs
| otherwise = reverse (searchUpToD 0 (Array.array (1, 1) [(1, Endpoint 0 (-1) [])]))
where (as, bs) = (Array.listArray (0, pred n) (toList as'), Array.listArray (0, pred m) (toList bs'))
(!n, !m) = (length as', length bs')
-- Search an edit graph for the shortest edit script up to a given proposed edit distance, building on the results of previous searches.
searchUpToD !d !v =
let !endpoints = slideFrom . searchAlongK <$> [ k | k <- [-d, -d + 2 .. d], inRange (-m, n) k ] in
case find isComplete endpoints of
Just (Endpoint _ _ script) -> script
_ -> searchUpToD (succ d) (Array.array (-d, d) ((\ e@(Endpoint x y _) -> (x - y, e)) <$> endpoints))
where isComplete (Endpoint x y _) = x >= n && y >= m
-- Search an edit graph for the shortest edit script along a specific diagonal, moving onto a given diagonal from one of its in-bounds adjacent diagonals (if any).
searchAlongK !k
| k == -d = moveDownFrom (v ! succ k)
| k == d = moveRightFrom (v ! pred k)
| k == -m = moveDownFrom (v ! succ k)
| k == n = moveRightFrom (v ! pred k)
| otherwise =
let left = v ! pred k
up = v ! succ k in
if x left < x up then
moveDownFrom up
else
moveRightFrom left
-- | Move downward from a given vertex, inserting the element for the corresponding row.
moveDownFrom (Endpoint x y script) = Endpoint x (succ y) $ maybe script ((: script) . That) (bs !? y)
{-# INLINE moveDownFrom #-}
-- | Move rightward from a given vertex, deleting the element for the corresponding column.
moveRightFrom (Endpoint x y script) = Endpoint (succ x) y $ maybe script ((: script) . This) (as !? x)
{-# INLINE moveRightFrom #-}
-- | Slide down any diagonal edges from a given vertex.
slideFrom (Endpoint x y script)
| Just a <- as !? x
, Just b <- bs !? y
, a `eq` b = slideFrom (Endpoint (succ x) (succ y) (These a b : script))
| otherwise = Endpoint x y script
(!?) :: Ix i => Array.Array i a -> i -> Maybe a
(!?) v i | inRange (Array.bounds v) i, !a <- v ! i = Just a
| otherwise = Nothing
{-# INLINE (!?) #-}

70
src/SES/Myers.hs
View File

@ -1,70 +0,0 @@
{-# LANGUAGE BangPatterns, GADTs, ImplicitParams, MultiParamTypeClasses, ScopedTypeVariables #-}
module SES.Myers
( EditScript
, ses
) where
import Data.Array ((!))
import qualified Data.Array as Array
import Data.Foldable (find, toList)
import Data.Ix
import Data.These
-- | An edit script, i.e. a sequence of changes/copies of elements.
type EditScript a b = [These a b]
data Endpoint a b = Endpoint { x :: {-# UNPACK #-} !Int, _y :: {-# UNPACK #-} !Int, _script :: EditScript a b }
deriving (Eq, Show)
-- | Compute the shortest edit script using Myers’ algorithm.
ses :: (Foldable t, Foldable u) => (a -> b -> Bool) -> t a -> u b -> EditScript a b
ses eq as' bs'
| null bs = This <$> toList as
| null as = That <$> toList bs
| otherwise = reverse (searchUpToD 0 (Array.array (1, 1) [(1, Endpoint 0 (-1) [])]))
where (as, bs) = (Array.listArray (0, pred n) (toList as'), Array.listArray (0, pred m) (toList bs'))
(!n, !m) = (length as', length bs')
-- Search an edit graph for the shortest edit script up to a given proposed edit distance, building on the results of previous searches.
searchUpToD !d !v =
let !endpoints = slideFrom . searchAlongK <$> [ k | k <- [-d, -d + 2 .. d], inRange (-m, n) k ] in
case find isComplete endpoints of
Just (Endpoint _ _ script) -> script
_ -> searchUpToD (succ d) (Array.array (-d, d) ((\ e@(Endpoint x y _) -> (x - y, e)) <$> endpoints))
where isComplete (Endpoint x y _) = x >= n && y >= m
-- Search an edit graph for the shortest edit script along a specific diagonal, moving onto a given diagonal from one of its in-bounds adjacent diagonals (if any).
searchAlongK !k
| k == -d = moveDownFrom (v ! succ k)
| k == d = moveRightFrom (v ! pred k)
| k == -m = moveDownFrom (v ! succ k)
| k == n = moveRightFrom (v ! pred k)
| otherwise =
let left = v ! pred k
up = v ! succ k in
if x left < x up then
moveDownFrom up
else
moveRightFrom left
-- | Move downward from a given vertex, inserting the element for the corresponding row.
moveDownFrom (Endpoint x y script) = Endpoint x (succ y) $ maybe script ((: script) . That) (bs !? y)
{-# INLINE moveDownFrom #-}
-- | Move rightward from a given vertex, deleting the element for the corresponding column.
moveRightFrom (Endpoint x y script) = Endpoint (succ x) y $ maybe script ((: script) . This) (as !? x)
{-# INLINE moveRightFrom #-}
-- | Slide down any diagonal edges from a given vertex.
slideFrom (Endpoint x y script)
| Just a <- as !? x
, Just b <- bs !? y
, a `eq` b = slideFrom (Endpoint (succ x) (succ y) (These a b : script))
| otherwise = Endpoint x y script
(!?) :: Ix i => Array.Array i a -> i -> Maybe a
(!?) v i | inRange (Array.bounds v) i, !a <- v ! i = Just a
| otherwise = Nothing
{-# INLINE (!?) #-}

29
src/Semantic.hs
View File

@ -11,6 +11,7 @@ import Algorithm hiding (diff)
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad ((<=<)) import Control.Monad ((<=<))
import Data.Align.Generic (GAlign) import Data.Align.Generic (GAlign)
import Data.Bifunctor
import Data.Blob import Data.Blob
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Functor.Both as Both import Data.Functor.Both as Both
@ -87,27 +88,27 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of
(PatchDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffRecursively (renderPatch blobs) (PatchDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffRecursively (renderPatch blobs)
(PatchDiffRenderer, Just Language.TypeScript) -> run (parse typescriptParser) diffRecursively (renderPatch blobs) (PatchDiffRenderer, Just Language.TypeScript) -> run (parse typescriptParser) diffRecursively (renderPatch blobs)
(PatchDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderPatch blobs) (PatchDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderPatch blobs)
(SExpressionDiffRenderer, Just Language.JSON) -> run (decorate constructorLabel <=< parse jsonParser) diffRecursively (renderSExpressionDiff . fmap keepConstructorLabel) (SExpressionDiffRenderer, Just Language.JSON) -> run (decorate constructorLabel <=< parse jsonParser) diffRecursively (renderSExpressionDiff . bimap keepConstructorLabel keepConstructorLabel)
(SExpressionDiffRenderer, Just Language.Markdown) -> run (decorate constructorLabel <=< parse markdownParser) diffRecursively (renderSExpressionDiff . fmap keepConstructorLabel) (SExpressionDiffRenderer, Just Language.Markdown) -> run (decorate constructorLabel <=< parse markdownParser) diffRecursively (renderSExpressionDiff . bimap keepConstructorLabel keepConstructorLabel)
(SExpressionDiffRenderer, Just Language.Python) -> run (decorate constructorLabel <=< parse pythonParser) diffRecursively (renderSExpressionDiff . fmap keepConstructorLabel) (SExpressionDiffRenderer, Just Language.Python) -> run (decorate constructorLabel <=< parse pythonParser) diffRecursively (renderSExpressionDiff . bimap keepConstructorLabel keepConstructorLabel)
(SExpressionDiffRenderer, Just Language.TypeScript) -> run (decorate constructorLabel <=< parse typescriptParser) diffRecursively (renderSExpressionDiff . fmap keepConstructorLabel) (SExpressionDiffRenderer, Just Language.TypeScript) -> run (decorate constructorLabel <=< parse typescriptParser) diffRecursively (renderSExpressionDiff . bimap keepConstructorLabel keepConstructorLabel)
(SExpressionDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderSExpressionDiff . fmap keepCategory) (SExpressionDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderSExpressionDiff . bimap keepCategory keepCategory)
(IdentityDiffRenderer, _) -> run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffTerms Just (IdentityDiffRenderer, _) -> run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffTerms Just
where effectiveLanguage = runBothWith (<|>) (blobLanguage <$> blobs) where effectiveLanguage = runBothWith (<|>) (blobLanguage <$> blobs)
syntaxParser = parserForLanguage effectiveLanguage syntaxParser = parserForLanguage effectiveLanguage
run :: Functor f => (Blob -> Task (Term f a)) -> (Both (Term f a) -> Diff f a) -> (Diff f a -> output) -> Task output run :: Functor syntax => (Blob -> Task (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (Diff syntax ann ann -> output) -> Task output
run parse diff renderer = distributeFor blobs parse >>= diffTermPair blobs diff >>= render renderer run parse diff renderer = distributeFor blobs parse >>= runBothWith (diffTermPair blobs diff) >>= render renderer
diffRecursively :: (Eq1 f, GAlign f, Show1 f, Traversable f, Diffable f) => Both (Term f (Record fields)) -> Diff f (Record fields) diffRecursively :: (Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax, Diffable syntax) => Term syntax (Record fields1) -> Term syntax (Record fields2) -> Diff syntax (Record fields1) (Record fields2)
diffRecursively = decoratingWith constructorNameAndConstantFields (diffTermsWith algorithmForTerms comparableByConstructor) diffRecursively = decoratingWith constructorNameAndConstantFields constructorNameAndConstantFields (diffTermsWith algorithmForTerms comparableByConstructor)
-- | A task to diff a pair of 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's. -- | A task to diff a pair of 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's.
diffTermPair :: Functor f => Both Blob -> Differ f a -> Both (Term f a) -> Task (Diff f a) diffTermPair :: Functor syntax => Both Blob -> Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2)
diffTermPair blobs differ terms = case runJoin (blobExists <$> blobs) of diffTermPair blobs differ t1 t2 = case runJoin (blobExists <$> blobs) of
(True, False) -> pure (deleting (Both.fst terms)) (True, False) -> pure (deleting t1)
(False, True) -> pure (inserting (Both.snd terms)) (False, True) -> pure (inserting t2)
_ -> time "diff" logInfo $ diff differ terms _ -> time "diff" logInfo $ diff differ t1 t2
where where
logInfo = let (a, b) = runJoin blobs in logInfo = let (a, b) = runJoin blobs in
[ ("before_path", blobPath a) [ ("before_path", blobPath a)

10
src/Semantic/Task.hs
View File

@ -67,7 +67,7 @@ data TaskF output where
Time :: String -> [(String, String)] -> Task output -> TaskF output Time :: String -> [(String, String)] -> Task output -> TaskF output
Parse :: Parser term -> Blob -> TaskF term Parse :: Parser term -> Blob -> TaskF term
Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> TaskF (Term f (Record (field ': fields))) Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> TaskF (Term f (Record (field ': fields)))
Diff :: Differ f a -> Both (Term f a) -> TaskF (Diff f a) Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> TaskF (Diff syntax ann1 ann2)
Render :: Renderer input output -> input -> TaskF output Render :: Renderer input output -> input -> TaskF output
Distribute :: Traversable t => t (Task output) -> TaskF (t output) Distribute :: Traversable t => t (Task output) -> TaskF (t output)
@ -82,7 +82,7 @@ data TaskF output where
type Task = Freer TaskF type Task = Freer TaskF
-- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types. -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types.
type Differ f a = Both (Term f a) -> Diff f a type Differ syntax ann1 ann2 = Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2
-- | A function to render terms or diffs. -- | A function to render terms or diffs.
type Renderer i o = i -> o type Renderer i o = i -> o
@ -117,8 +117,8 @@ decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fiel
decorate algebra term = Decorate algebra term `Then` return decorate algebra term = Decorate algebra term `Then` return
-- | A 'Task' which diffs a pair of terms using the supplied 'Differ' function. -- | A 'Task' which diffs a pair of terms using the supplied 'Differ' function.
diff :: Differ f a -> Both (Term f a) -> Task (Diff f a) diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2)
diff differ terms = Semantic.Task.Diff differ terms `Then` return diff differ term1 term2 = Semantic.Task.Diff differ term1 term2 `Then` return
-- | A 'Task' which renders some input using the supplied 'Renderer' function. -- | A 'Task' which renders some input using the supplied 'Renderer' function.
render :: Renderer input output -> input -> Task output render :: Renderer input output -> input -> Task output
@ -182,7 +182,7 @@ runTaskWithOptions options task = do
either (pure . Left) yield res either (pure . Left) yield res
Parse parser blob -> go (runParser options blob parser) >>= either (pure . Left) yield Parse parser blob -> go (runParser options blob parser) >>= either (pure . Left) yield
Decorate algebra term -> pure (decoratorWithAlgebra algebra term) >>= yield Decorate algebra term -> pure (decoratorWithAlgebra algebra term) >>= yield
Semantic.Task.Diff differ terms -> pure (differ terms) >>= yield Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2) >>= yield
Render renderer input -> pure (renderer input) >>= yield Render renderer input -> pure (renderer input) >>= yield
Distribute tasks -> Async.mapConcurrently go tasks >>= either (pure . Left) yield . sequenceA . withStrategy (parTraversable (parTraversable rseq)) Distribute tasks -> Async.mapConcurrently go tasks >>= either (pure . Left) yield . sequenceA . withStrategy (parTraversable (parTraversable rseq))
LiftIO action -> action >>= yield LiftIO action -> action >>= yield

8
src/Semantic/Util.hs
View File

@ -44,11 +44,11 @@ diffWithParser :: (HasField fields Data.Span.Span,
GAlign (Data.Union.Union fs)) => GAlign (Data.Union.Union fs)) =>
Parser (Term (Data.Union.Union fs) (Record fields)) Parser (Term (Data.Union.Union fs) (Record fields))
-> Both Blob -> Both Blob
-> Task (Diff (Union fs) (Record (Maybe Declaration ': fields))) -> Task (Diff (Union fs) (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
diffWithParser parser = run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) diffWithParser parser = run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob))
where where
run parse sourceBlobs = distributeFor sourceBlobs parse >>= diffTermPair sourceBlobs diffRecursively run parse sourceBlobs = distributeFor sourceBlobs parse >>= runBothWith (diffTermPair sourceBlobs diffRecursively)
diffRecursively :: (Eq1 f, GAlign f, Show1 f, Traversable f, Diffable f) => Both (Term f (Record fields)) -> Diff f (Record fields) diffRecursively :: (Eq1 f, GAlign f, Show1 f, Traversable f, Diffable f) => Term f (Record fields) -> Term f (Record fields) -> Diff f (Record fields) (Record fields)
diffRecursively = decoratingWith constructorNameAndConstantFields (diffTermsWith algorithmForTerms comparableByConstructor) diffRecursively = decoratingWith constructorNameAndConstantFields constructorNameAndConstantFields (diffTermsWith algorithmForTerms comparableByConstructor)

6
src/Term.hs
View File

@ -3,8 +3,6 @@ module Term
( Term(..) ( Term(..)
, termIn , termIn
, TermF(..) , TermF(..)
, SyntaxTerm
, SyntaxTermF
, termSize , termSize
, extract , extract
, unwrap , unwrap
@ -24,7 +22,6 @@ import Data.Functor.Foldable
import Data.JSON.Fields import Data.JSON.Fields
import Data.Record import Data.Record
import Data.Semigroup ((<>)) import Data.Semigroup ((<>))
import Syntax
import Text.Show import Text.Show
-- | A Term with an abstract syntax tree and an annotation. -- | A Term with an abstract syntax tree and an annotation.
@ -33,9 +30,6 @@ newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) }
data TermF syntax ann recur = In { termAnnotation :: ann, termOut :: syntax recur } data TermF syntax ann recur = In { termAnnotation :: ann, termOut :: syntax recur }
deriving (Eq, Foldable, Functor, Show, Traversable) deriving (Eq, Foldable, Functor, Show, Traversable)
-- | A Term with a Syntax leaf and a record of fields.
type SyntaxTerm fields = Term Syntax (Record fields)
type SyntaxTermF fields = TermF Syntax (Record fields)
-- | Return the node count of a term. -- | Return the node count of a term.
termSize :: (Foldable f, Functor f) => Term f annotation -> Int termSize :: (Foldable f, Functor f) => Term f annotation -> Int

14
src/TreeSitter.hs
View File

@ -34,7 +34,7 @@ import qualified TreeSitter.TypeScript as TS
import Info import Info
-- | Returns a TreeSitter parser for the given language and TreeSitter grammar. -- | Returns a TreeSitter parser for the given language and TreeSitter grammar.
treeSitterParser :: Ptr TS.Language -> Blob -> IO (SyntaxTerm DefaultFields) treeSitterParser :: Ptr TS.Language -> Blob -> IO (Term S.Syntax (Record DefaultFields))
treeSitterParser language blob = bracket TS.ts_document_new TS.ts_document_free $ \ document -> do treeSitterParser language blob = bracket TS.ts_document_new TS.ts_document_free $ \ document -> do
TS.ts_document_set_language document language TS.ts_document_set_language document language
unsafeUseAsCStringLen (sourceBytes (blobSource blob)) $ \ (sourceBytes, len) -> do unsafeUseAsCStringLen (sourceBytes (blobSource blob)) $ \ (sourceBytes, len) -> do
@ -70,13 +70,13 @@ anaM g = a where a = pure . embed <=< traverse a <=< g
-- | Return a parser for a tree sitter language & document. -- | Return a parser for a tree sitter language & document.
documentToTerm :: Ptr TS.Language -> Ptr TS.Document -> Blob -> IO (SyntaxTerm DefaultFields) documentToTerm :: Ptr TS.Language -> Ptr TS.Document -> Blob -> IO (Term S.Syntax (Record DefaultFields))
documentToTerm language document Blob{..} = do documentToTerm language document Blob{..} = do
root <- alloca (\ rootPtr -> do root <- alloca (\ rootPtr -> do
TS.ts_document_root_node_p document rootPtr TS.ts_document_root_node_p document rootPtr
peek rootPtr) peek rootPtr)
toTerm root toTerm root
where toTerm :: TS.Node -> IO (SyntaxTerm DefaultFields) where toTerm :: TS.Node -> IO (Term S.Syntax (Record DefaultFields))
toTerm node@TS.Node{..} = do toTerm node@TS.Node{..} = do
name <- peekCString nodeType name <- peekCString nodeType
@ -95,7 +95,7 @@ documentToTerm language document Blob{..} = do
copyNamed = TS.ts_node_copy_named_child_nodes document copyNamed = TS.ts_node_copy_named_child_nodes document
copyAll = TS.ts_node_copy_child_nodes document copyAll = TS.ts_node_copy_child_nodes document
isNonEmpty :: HasField fields Category => SyntaxTerm fields -> Bool isNonEmpty :: HasField fields Category => Term S.Syntax (Record fields) -> Bool
isNonEmpty = (/= Empty) . category . extract isNonEmpty = (/= Empty) . category . extract
nodeRange :: TS.Node -> Range nodeRange :: TS.Node -> Range
@ -105,18 +105,18 @@ nodeSpan :: TS.Node -> Span
nodeSpan TS.Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos nodeStartPoint) (pointPos nodeEndPoint) nodeSpan TS.Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos nodeStartPoint) (pointPos nodeEndPoint)
where pointPos TS.TSPoint{..} = pointRow `seq` pointColumn `seq` Pos (1 + fromIntegral pointRow) (1 + fromIntegral pointColumn) where pointPos TS.TSPoint{..} = pointRow `seq` pointColumn `seq` Pos (1 + fromIntegral pointRow) (1 + fromIntegral pointColumn)
assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields) assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ Term S.Syntax (Record DefaultFields) ] -> IO [ Term S.Syntax (Record DefaultFields) ] -> IO (Term S.Syntax (Record DefaultFields))
assignTerm language source annotation children allChildren = assignTerm language source annotation children allChildren =
case assignTermByLanguage source (category annotation) children of case assignTermByLanguage source (category annotation) children of
Just a -> pure (termIn annotation a) Just a -> pure (termIn annotation a)
_ -> defaultTermAssignment source annotation children allChildren _ -> defaultTermAssignment source annotation children allChildren
where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) where assignTermByLanguage :: Source -> Category -> [ Term S.Syntax (Record DefaultFields) ] -> Maybe (S.Syntax (Term S.Syntax (Record DefaultFields)))
assignTermByLanguage = case languageForTSLanguage language of assignTermByLanguage = case languageForTSLanguage language of
Just Language.Go -> Go.termAssignment Just Language.Go -> Go.termAssignment
Just Ruby -> Ruby.termAssignment Just Ruby -> Ruby.termAssignment
_ -> \ _ _ _ -> Nothing _ -> \ _ _ _ -> Nothing
defaultTermAssignment :: Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields) defaultTermAssignment :: Source -> Record DefaultFields -> [ Term S.Syntax (Record DefaultFields) ] -> IO [ Term S.Syntax (Record DefaultFields) ] -> IO (Term S.Syntax (Record DefaultFields))
defaultTermAssignment source annotation children allChildren defaultTermAssignment source annotation children allChildren
| category annotation `elem` operatorCategories = Term . In annotation . S.Operator <$> allChildren | category annotation `elem` operatorCategories = Term . In annotation . S.Operator <$> allChildren
| otherwise = case (category annotation, children) of | otherwise = case (category annotation, children) of

2
test/AlignmentSpec.hs
View File

@ -258,7 +258,7 @@ instance Listable BranchElement where
counts :: [Join These (Int, a)] -> Both Int counts :: [Join These (Int, a)] -> Both Int
counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap fst <$> numbered)) counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap fst <$> numbered))
align :: Both Source.Source -> Diff Syntax (Record '[Range]) -> PrettyDiff (SplitDiff [] (Record '[Range])) align :: Both Source.Source -> Diff Syntax (Record '[Range]) (Record '[Range]) -> PrettyDiff (SplitDiff [] (Record '[Range]))
align sources = PrettyDiff sources . fmap (fmap (getRange &&& id)) . alignDiff sources align sources = PrettyDiff sources . fmap (fmap (getRange &&& id)) . alignDiff sources
info :: Int -> Int -> Record '[Range] info :: Int -> Int -> Record '[Range]

38
test/Data/Functor/Listable.hs
View File

@ -70,6 +70,13 @@ tiers2 :: (Listable a, Listable b, Listable2 l) => [Tier (l a b)]
tiers2 = liftTiers2 tiers tiers tiers2 = liftTiers2 tiers tiers
class Listable3 l where
liftTiers3 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier (l a b c)]
tiers3 :: (Listable3 l, Listable a, Listable b, Listable c) => [Tier (l a b c)]
tiers3 = liftTiers3 tiers tiers tiers
-- | Lifts a unary constructor to a list of tiers, given a list of tiers for its argument. -- | Lifts a unary constructor to a list of tiers, given a list of tiers for its argument.
-- --
-- Commonly used in the definition of 'Listable1' and 'Listable2' instances. -- Commonly used in the definition of 'Listable1' and 'Listable2' instances.
@ -165,22 +172,19 @@ instance (Listable1 f, Listable a) => Listable (Term f a) where
tiers = tiers1 tiers = tiers1
instance Listable1 f => Listable2 (DiffF f) where instance (Listable1 syntax) => Listable3 (DiffF syntax) where
liftTiers2 annTiers recurTiers liftTiers3 ann1Tiers ann2Tiers recurTiers
= liftCons1 (liftTiers (liftTiers2 annTiers recurTiers)) Patch = liftCons1 (liftTiers2 (liftTiers2 ann1Tiers recurTiers) (liftTiers2 ann2Tiers recurTiers)) Patch
\/ liftCons1 (liftTiers2 (liftTiers2 annTiers annTiers) recurTiers) Merge \/ liftCons1 (liftTiers2 (liftTiers2 ann1Tiers ann2Tiers) recurTiers) Merge
instance (Listable1 f, Listable a) => Listable1 (DiffF f a) where instance (Listable1 syntax, Listable ann1, Listable ann2, Listable recur) => Listable (DiffF syntax ann1 ann2 recur) where
liftTiers = liftTiers2 tiers tiers = tiers3
instance (Listable1 f, Listable a, Listable b) => Listable (DiffF f a b) where instance Listable1 f => Listable2 (Diff f) where
tiers = tiers1 liftTiers2 annTiers1 annTiers2 = go where go = liftCons1 (liftTiers3 annTiers1 annTiers2 go) Diff
instance Listable1 f => Listable1 (Diff f) where instance (Listable1 syntax, Listable ann1, Listable ann2) => Listable (Diff syntax ann1 ann2) where
liftTiers annTiers = go where go = liftCons1 (liftTiers2 annTiers go) Diff tiers = tiers2
instance (Listable1 f, Listable a) => Listable (Diff f a) where
tiers = tiers1
instance (Listable head, Listable (Record tail)) => Listable (Record (head ': tail)) where instance (Listable head, Listable (Record tail)) => Listable (Record (head ': tail)) where
@ -211,11 +215,11 @@ instance Listable Category.Category where
\/ cons0 Category.SingletonMethod \/ cons0 Category.SingletonMethod
instance Listable1 Patch where instance Listable2 Patch where
liftTiers t = liftCons1 t Insert \/ liftCons1 t Delete \/ liftCons2 t t Replace liftTiers2 t1 t2 = liftCons1 t2 Insert \/ liftCons1 t1 Delete \/ liftCons2 t1 t2 Replace
instance Listable a => Listable (Patch a) where instance (Listable a, Listable b) => Listable (Patch a b) where
tiers = tiers1 tiers = tiers2
instance Listable1 Syntax where instance Listable1 Syntax where

18
test/Data/RandomWalkSimilarity/Spec.hs
View File

@ -20,32 +20,30 @@ spec = parallel $ do
let positively = succ . abs let positively = succ . abs
describe "pqGramDecorator" $ do describe "pqGramDecorator" $ do
prop "produces grams with stems of the specified length" $ prop "produces grams with stems of the specified length" $
\ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== positively p) . length . stem . rhead) \ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (term :: Term Syntax (Record '[Category])) `shouldSatisfy` all ((== positively p) . length . stem . rhead)
prop "produces grams with bases of the specified width" $ prop "produces grams with bases of the specified width" $
\ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== positively q) . length . base . rhead) \ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (term :: Term Syntax (Record '[Category])) `shouldSatisfy` all ((== positively q) . length . base . rhead)
describe "featureVectorDecorator" $ do describe "featureVectorDecorator" $ do
prop "produces a vector of the specified dimension" $ prop "produces a vector of the specified dimension" $
\ (term, p, q, d) -> featureVectorDecorator (rhead . termAnnotation) (positively p) (positively q) (positively d) (term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== (0, abs d)) . bounds . rhead) \ (term, p, q, d) -> featureVectorDecorator (rhead . termAnnotation) (positively p) (positively q) (positively d) (term :: Term Syntax (Record '[Category])) `shouldSatisfy` all ((== (0, abs d)) . bounds . unFV . rhead)
describe "rws" $ do describe "rws" $ do
prop "produces correct diffs" $ prop "produces correct diffs" $
\ (as, bs) -> let tas = decorate <$> (as :: [SyntaxTerm '[Category]]) \ (as, bs) -> let tas = decorate <$> (as :: [Term Syntax (Record '[Category])])
tbs = decorate <$> (bs :: [SyntaxTerm '[Category]]) tbs = decorate <$> (bs :: [Term Syntax (Record '[Category])])
root = termIn (Program :. Nil) . Indexed root = termIn (Program :. Nil) . Indexed
diff = merge ((Program :. Nil, Program :. Nil)) (Indexed (stripDiff . diffThese <$> rws editDistance canCompare tas tbs)) in diff = merge ((Program :. Nil, Program :. Nil)) (Indexed (stripDiff . diffThese <$> rws canCompare tas tbs)) in
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (root (stripTerm <$> tas)), Just (root (stripTerm <$> tbs))) (beforeTerm diff, afterTerm diff) `shouldBe` (Just (root (stripTerm <$> tas)), Just (root (stripTerm <$> tbs)))
it "produces unbiased insertions within branches" $ it "produces unbiased insertions within branches" $
let (a, b) = (decorate (Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf "a") ])), decorate (Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf "b") ]))) in let (a, b) = (decorate (Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf "a") ])), decorate (Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf "b") ]))) in
fmap (bimap stripTerm stripTerm) (rws editDistance canCompare [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ That a, These b b ] fmap (bimap stripTerm stripTerm) (rws canCompare [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ That a, These b b ]
where canCompare a b = termAnnotation a == termAnnotation b where canCompare a b = termAnnotation a == termAnnotation b
decorate :: SyntaxTerm '[Category] -> SyntaxTerm '[FeatureVector, Category] decorate :: Term Syntax (Record '[Category]) -> Term Syntax (Record '[FeatureVector, Category])
decorate = defaultFeatureVectorDecorator (category . termAnnotation) decorate = defaultFeatureVectorDecorator (category . termAnnotation)
diffThese = these deleting inserting replacing diffThese = these deleting inserting replacing
editDistance = these (const 1) (const 1) (const (const 0))

13
test/DiffSpec.hs
View File

@ -4,10 +4,12 @@ module DiffSpec where
import Category import Category
import Data.Functor.Both import Data.Functor.Both
import Data.Functor.Listable () import Data.Functor.Listable ()
import Data.Record
import RWS import RWS
import Diff import Diff
import Info import Info
import Interpreter import Interpreter
import Syntax
import Term import Term
import Test.Hspec import Test.Hspec
import Test.Hspec.LeanCheck import Test.Hspec.LeanCheck
@ -16,19 +18,18 @@ spec :: Spec
spec = parallel $ do spec = parallel $ do
let decorate = defaultFeatureVectorDecorator (category . termAnnotation) let decorate = defaultFeatureVectorDecorator (category . termAnnotation)
prop "equality is reflexive" $ prop "equality is reflexive" $
\ a -> let diff = a :: SyntaxDiff '[Category] in \ diff -> diff `shouldBe` (diff :: Diff Syntax (Record '[Category]) (Record '[Category]))
diff `shouldBe` diff
prop "equal terms produce identity diffs" $ prop "equal terms produce identity diffs" $
\ a -> let term = decorate (a :: SyntaxTerm '[Category]) in \ a -> let term = decorate (a :: Term Syntax (Record '[Category])) in
diffCost (diffTerms (pure term)) `shouldBe` 0 diffCost (diffTerms term term) `shouldBe` 0
describe "beforeTerm" $ do describe "beforeTerm" $ do
prop "recovers the before term" $ prop "recovers the before term" $
\ a b -> let diff = diffTerms (both a b :: Both (SyntaxTerm '[Category])) in \ a b -> let diff = diffTerms a b :: Diff Syntax (Record '[Category]) (Record '[Category]) in
beforeTerm diff `shouldBe` Just a beforeTerm diff `shouldBe` Just a
describe "afterTerm" $ do describe "afterTerm" $ do
prop "recovers the after term" $ prop "recovers the after term" $
\ a b -> let diff = diffTerms (both a b :: Both (SyntaxTerm '[Category])) in \ a b -> let diff = diffTerms a b :: Diff Syntax (Record '[Category]) (Record '[Category]) in
afterTerm diff `shouldBe` Just b afterTerm diff `shouldBe` Just b

13
test/InterpreterSpec.hs
View File

@ -20,18 +20,17 @@ spec = parallel $ do
it "returns a replacement when comparing two unicode equivalent terms" $ it "returns a replacement when comparing two unicode equivalent terms" $
let termA = Term $ (StringLiteral :. Nil) `In` Leaf "t\776" let termA = Term $ (StringLiteral :. Nil) `In` Leaf "t\776"
termB = Term $ (StringLiteral :. Nil) `In` Leaf "\7831" in termB = Term $ (StringLiteral :. Nil) `In` Leaf "\7831" in
diffTerms (both termA termB) `shouldBe` replacing termA termB diffTerms termA termB `shouldBe` replacing termA termB
prop "produces correct diffs" $ prop "produces correct diffs" $
\ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm '[Category])) in \ a b -> let diff = diffTerms a b :: Diff Syntax (Record '[Category]) (Record '[Category]) in
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (unListableF a), Just (unListableF b)) (beforeTerm diff, afterTerm diff) `shouldBe` (Just a, Just b)
prop "constructs zero-cost diffs of equal terms" $ prop "constructs zero-cost diffs of equal terms" $
\ a -> let term = (unListableF a :: SyntaxTerm '[Category]) \ a -> let diff = diffTerms a a :: Diff Syntax (Record '[Category]) (Record '[Category]) in
diff = diffTerms (pure term) in
diffCost diff `shouldBe` 0 diffCost diff `shouldBe` 0
it "produces unbiased insertions within branches" $ it "produces unbiased insertions within branches" $
let term s = Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf s) ]) :: SyntaxTerm '[Category] let term s = Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf s) ]) :: Term Syntax (Record '[Category])
root = termIn (Program :. Nil) . Indexed in root = termIn (Program :. Nil) . Indexed in
diffTerms (both (root [ term "b" ]) (root [ term "a", term "b" ])) `shouldBe` merge ((Program :. Nil, Program :. Nil)) (Indexed [ inserting (term "a"), cata (\ (In a r) -> merge (a, a) r) (term "b") ]) diffTerms (root [ term "b" ]) (root [ term "a", term "b" ]) `shouldBe` merge ((Program :. Nil, Program :. Nil)) (Indexed [ inserting (term "a"), cata (\ (In a r) -> merge (a, a) r) (term "b") ])

4
test/SES/Myers/Spec.hs → test/SES/Spec.hs
View File

@ -1,7 +1,7 @@
module SES.Myers.Spec where module SES.Spec where
import Data.These import Data.These
import SES.Myers import SES
import Test.Hspec import Test.Hspec
import Test.Hspec.LeanCheck import Test.Hspec.LeanCheck

4
test/SemanticSpec.hs
View File

@ -31,11 +31,11 @@ spec = parallel $ do
describe "diffTermPair" $ do describe "diffTermPair" $ do
it "produces an Insert when the first blob is missing" $ do it "produces an Insert when the first blob is missing" $ do
result <- runTask (diffTermPair (both (emptyBlob "/foo") (sourceBlob "/foo" Nothing "")) (runBothWith replacing) (pure (termIn () []))) result <- runTask (diffTermPair (both (emptyBlob "/foo") (sourceBlob "/foo" Nothing "")) replacing (termIn () []) (termIn () []))
result `shouldBe` Diff (Patch (Insert (In () []))) result `shouldBe` Diff (Patch (Insert (In () [])))
it "produces a Delete when the second blob is missing" $ do it "produces a Delete when the second blob is missing" $ do
result <- runTask (diffTermPair (both (sourceBlob "/foo" Nothing "") (emptyBlob "/foo")) (runBothWith replacing) (pure (termIn () []))) result <- runTask (diffTermPair (both (sourceBlob "/foo" Nothing "") (emptyBlob "/foo")) replacing (termIn () []) (termIn () []))
result `shouldBe` Diff (Patch (Delete (In () []))) result `shouldBe` Diff (Patch (Delete (In () [])))
where where

4
test/Spec.hs
View File

@ -8,7 +8,7 @@ import qualified Data.Syntax.Assignment.Spec
import qualified DiffSpec import qualified DiffSpec
import qualified InterpreterSpec import qualified InterpreterSpec
import qualified PatchOutputSpec import qualified PatchOutputSpec
import qualified SES.Myers.Spec import qualified SES.Spec
import qualified SourceSpec import qualified SourceSpec
import qualified TermSpec import qualified TermSpec
import qualified TOCSpec import qualified TOCSpec
@ -28,7 +28,7 @@ main = hspec $ do
describe "Diff" DiffSpec.spec describe "Diff" DiffSpec.spec
describe "Interpreter" InterpreterSpec.spec describe "Interpreter" InterpreterSpec.spec
describe "PatchOutput" PatchOutputSpec.spec describe "PatchOutput" PatchOutputSpec.spec
describe "SES.Myers" SES.Myers.Spec.spec describe "SES" SES.Spec.spec
describe "Source" SourceSpec.spec describe "Source" SourceSpec.spec
describe "Term" TermSpec.spec describe "Term" TermSpec.spec
describe "Semantic" SemanticSpec.spec describe "Semantic" SemanticSpec.spec

19
test/TOCSpec.hs
View File

@ -4,6 +4,7 @@ module TOCSpec where
import Category as C import Category as C
import Data.Aeson import Data.Aeson
import Data.Bifunctor
import Data.Blob import Data.Blob
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Functor.Both import Data.Functor.Both
@ -41,21 +42,23 @@ spec :: Spec
spec = parallel $ do spec = parallel $ do
describe "tableOfContentsBy" $ do describe "tableOfContentsBy" $ do
prop "drops all nodes with the constant Nothing function" $ prop "drops all nodes with the constant Nothing function" $
\ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (diff :: Diff Syntax ()) `shouldBe` [] \ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (diff :: Diff Syntax () ()) `shouldBe` []
let diffSize = max 1 . length . diffPatches let diffSize = max 1 . length . diffPatches
let lastValue a = fromMaybe (extract a) (getLast (foldMap (Last . Just) a)) let lastValue a = fromMaybe (extract a) (getLast (foldMap (Last . Just) a))
prop "includes all nodes with a constant Just function" $ prop "includes all nodes with a constant Just function" $
\ diff -> let diff' = (diff :: Diff Syntax ()) in entryPayload <$> tableOfContentsBy (const (Just ())) diff' `shouldBe` replicate (diffSize diff') () \ diff -> let diff' = (diff :: Diff Syntax () ()) in entryPayload <$> tableOfContentsBy (const (Just ())) diff' `shouldBe` replicate (diffSize diff') ()
prop "produces an unchanged entry for identity diffs" $ prop "produces an unchanged entry for identity diffs" $
\ term -> let term' = (term :: Term Syntax (Record '[Category])) in tableOfContentsBy (Just . termAnnotation) (diffTerms (pure term')) `shouldBe` [Unchanged (lastValue term')] \ term -> tableOfContentsBy (Just . termAnnotation) (diffTerms term term) `shouldBe` [Unchanged (lastValue (term :: Term Syntax (Record '[Category])))]
prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $ prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $
\ patch -> let patch' = (patch :: Patch (Term Syntax Int)) in tableOfContentsBy (Just . termAnnotation) (these deleting inserting replacing (unPatch patch')) `shouldBe` these (fmap Deleted) (fmap Inserted) (const (fmap Replaced)) (unPatch (foldMap pure <$> patch')) \ p -> tableOfContentsBy (Just . termAnnotation) (patch deleting inserting replacing p)
`shouldBe`
patch (fmap Deleted) (fmap Inserted) (const (fmap Replaced)) (bimap (foldMap pure) (foldMap pure) (p :: Patch (Term Syntax Int) (Term Syntax Int)))
prop "produces changed entries for relevant nodes containing irrelevant patches" $ prop "produces changed entries for relevant nodes containing irrelevant patches" $
\ diff -> let diff' = merge (0, 0) (Indexed [1 <$ (diff :: Diff Syntax Int)]) in \ diff -> let diff' = merge (0, 0) (Indexed [bimap (const 1) (const 1) (diff :: Diff Syntax Int Int)]) in
tableOfContentsBy (\ (n `In` _) -> if n == (0 :: Int) then Just n else Nothing) diff' `shouldBe` tableOfContentsBy (\ (n `In` _) -> if n == (0 :: Int) then Just n else Nothing) diff' `shouldBe`
if null (diffPatches diff') then [Unchanged 0] if null (diffPatches diff') then [Unchanged 0]
else replicate (length (diffPatches diff')) (Changed 0) else replicate (length (diffPatches diff')) (Changed 0)
@ -134,7 +137,7 @@ spec = parallel $ do
prop "equal terms produce identity diffs" $ prop "equal terms produce identity diffs" $
\a -> let term = defaultFeatureVectorDecorator (Info.category . termAnnotation) (a :: Term') in \a -> let term = defaultFeatureVectorDecorator (Info.category . termAnnotation) (a :: Term') in
diffTOC (diffTerms (pure term)) `shouldBe` [] diffTOC (diffTerms term term) `shouldBe` []
describe "JSONSummary" $ do describe "JSONSummary" $ do
it "encodes modified summaries to JSON" $ do it "encodes modified summaries to JSON" $ do
@ -162,8 +165,8 @@ spec = parallel $ do
toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/markdown/headings.A.md -> test/fixtures/toc/markdown/headings.B.md\":[{\"span\":{\"start\":[5,1],\"end\":[7,10]},\"category\":\"Heading 2\",\"term\":\"Two\",\"changeType\":\"added\"},{\"span\":{\"start\":[9,1],\"end\":[10,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString) toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/markdown/headings.A.md -> test/fixtures/toc/markdown/headings.B.md\":[{\"span\":{\"start\":[5,1],\"end\":[7,10]},\"category\":\"Heading 2\",\"term\":\"Two\",\"changeType\":\"added\"},{\"span\":{\"start\":[9,1],\"end\":[10,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
type Diff' = SyntaxDiff (Maybe Declaration ': DefaultFields) type Diff' = Diff Syntax (Record (Maybe Declaration ': DefaultFields)) (Record (Maybe Declaration ': DefaultFields))
type Term' = SyntaxTerm (Maybe Declaration ': DefaultFields) type Term' = Term Syntax (Record (Maybe Declaration ': DefaultFields))
numTocSummaries :: Diff' -> Int numTocSummaries :: Diff' -> Int
numTocSummaries diff = length $ filter isValidSummary (diffTOC diff) numTocSummaries diff = length $ filter isValidSummary (diffTOC diff)

4
test/TermSpec.hs
View File

@ -3,6 +3,8 @@ module TermSpec where
import Category import Category
import Data.Functor.Listable import Data.Functor.Listable
import Data.Record
import Syntax
import Term import Term
import Test.Hspec (Spec, describe, parallel) import Test.Hspec (Spec, describe, parallel)
import Test.Hspec.Expectations.Pretty import Test.Hspec.Expectations.Pretty
@ -12,4 +14,4 @@ spec :: Spec
spec = parallel $ do spec = parallel $ do
describe "Term" $ do describe "Term" $ do
prop "equality is reflexive" $ prop "equality is reflexive" $
\ a -> unListableF a `shouldBe` (unListableF a :: SyntaxTerm '[Category]) \ a -> unListableF a `shouldBe` (unListableF a :: Term Syntax (Record '[Category]))