From 7169a512651720c75518c555e0fae9943e64d247 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 13 Jul 2016 11:58:43 -0400 Subject: [PATCH 001/320] Use wl-pprint-text to pretty print diff summaries --- semantic-diff.cabal | 2 ++ src/DiffSummary.hs | 27 ++++++++++++++------------- src/Renderer/Summary.hs | 3 ++- test/DiffSummarySpec.hs | 5 +++-- 4 files changed, 21 insertions(+), 16 deletions(-) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index a1c619429..a01e2bc36 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -76,6 +76,7 @@ library , free , comonad , protolude + , wl-pprint-text default-language: Haskell2010 default-extensions: DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards, LambdaCase ghc-options: -Wall -fno-warn-name-shadowing -O2 -threaded -fprof-auto "-with-rtsopts=-N -p -s -h -i0.1" -j @@ -126,6 +127,7 @@ test-suite semantic-diff-test , these , free , recursion-schemes >= 4.1 + , wl-pprint-text if os(darwin) ghc-options: -threaded -rtsopts -with-rtsopts=-N -j else diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 2efbe689f..eae4c3188 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -12,7 +12,9 @@ import Category import Data.Functor.Foldable as Foldable import Data.Functor.Both import Data.OrderedMap -import Data.Text as Text (intercalate, unpack) +import Data.Text as Text (intercalate) +import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string) +import qualified Text.PrettyPrint.Leijen.Text as P data DiffInfo = DiffInfo { categoryName :: Text, termName :: Text } deriving (Eq, Show) @@ -104,19 +106,18 @@ instance HasCategory leaf => HasCategory (Term leaf Info) where data DiffSummary a = DiffSummary { patch :: Patch a, parentAnnotations :: [Category] -} deriving (Eq, Functor) +} deriving (Eq, Functor, Show) -instance Show (DiffSummary DiffInfo) where - showsPrec _ DiffSummary{..} s = (++s) . unpack $ case patch of - (Insert diffInfo) -> "Added the " <> "'" <> termName diffInfo <> "' " <> categoryName diffInfo <> maybeParentContext parentAnnotations - (Delete diffInfo) -> "Deleted the " <> "'" <> termName diffInfo <> "' " <> categoryName diffInfo <> maybeParentContext parentAnnotations - (Replace t1 t2) -> - "Replaced the " <> "'" <> termName t1 <> "' " <> categoryName t1 - <> " with the " <> "'" <> termName t2 <> "' " <> categoryName t2 - <> maybeParentContext parentAnnotations - where maybeParentContext parentAnnotations = if null parentAnnotations - then "" - else " in the " <> intercalate "/" (toCategoryName <$> parentAnnotations) <> " context" +instance P.Pretty (DiffSummary DiffInfo) where + pretty DiffSummary{..} = case patch of + Insert diffInfo -> "Added the" <+> squotes (toDoc $ termName diffInfo) <+> (toDoc $ categoryName diffInfo) P.<> maybeParentContext parentAnnotations + Delete diffInfo -> "Deleted the" <+> squotes (toDoc $ termName diffInfo) <+> (toDoc $ categoryName diffInfo) P.<> maybeParentContext parentAnnotations + Replace t1 t2 -> "Replaced the" <+> squotes (toDoc $ termName t1) <+> (toDoc $ categoryName t1) <+> "with the" <+> P.squotes (toDoc $ termName t2) <+> (toDoc $ categoryName t2) P.<> maybeParentContext parentAnnotations + where + maybeParentContext annotations = if null annotations + then "" + else space <> "in the" <+> (toDoc . intercalate "/" $ toCategoryName <$> annotations) <+> "context" + toDoc = string . toS diffSummary :: HasCategory leaf => Diff leaf Info -> [DiffSummary DiffInfo] diffSummary = cata $ \case diff --git a/src/Renderer/Summary.hs b/src/Renderer/Summary.hs index feeb4fe39..4536e9d2c 100644 --- a/src/Renderer/Summary.hs +++ b/src/Renderer/Summary.hs @@ -5,6 +5,7 @@ import Renderer import DiffSummary import Data.Aeson import Data.Text (pack) +import Text.PrettyPrint.Leijen.Text (pretty) summary :: Renderer -summary diff _ = toS . encode $ pack . show <$> diffSummary diff +summary diff _ = toS . encode $ pack . show . pretty <$> diffSummary diff diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index f7db5b1eb..ef4b7f3a2 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -10,6 +10,7 @@ import Patch import Range import Category import DiffSummary +import Text.PrettyPrint.Leijen.Text arrayInfo :: Info arrayInfo = rangeAt 0 .: ArrayLiteral .: 2 .: 0 .: RNil @@ -33,6 +34,6 @@ spec = parallel $ do diffSummary testDiff `shouldBe` [ DiffSummary { patch = Insert (DiffInfo "string" "a"), parentAnnotations = [ ArrayLiteral ] } ] describe "show" $ do it "should print adds" $ - show testSummary `shouldBe` ("Added the 'a' string" :: Text) + show (pretty testSummary) `shouldBe` ("Added the 'a' string" :: Text) it "prints a replacement" $ do - show replacementSummary `shouldBe` ("Replaced the 'a' string with the 'b' symbol in the array context" :: Text) + show (pretty replacementSummary) `shouldBe` ("Replaced the 'a' string with the 'b' symbol in the array context" :: Text) From 59426b86f6ab1896242a54ff021de37e1716b618 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 13 Jul 2016 14:32:53 -0400 Subject: [PATCH 002/320] Add megaparsec to pretty print summaries --- semantic-diff.cabal | 1 + src/Category.hs | 26 +++++++++++++++++++++++--- src/Data/Record.hs | 1 + src/DiffSummary.hs | 8 +++++++- test/AlignmentSpec.hs | 1 + test/CorpusSpec.hs | 4 ++-- test/DiffSummarySpec.hs | 27 ++++++++++++++++++++++++++- 7 files changed, 61 insertions(+), 7 deletions(-) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index a01e2bc36..0fdaded56 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -128,6 +128,7 @@ test-suite semantic-diff-test , free , recursion-schemes >= 4.1 , wl-pprint-text + , megaparsec if os(darwin) ghc-options: -threaded -rtsopts -with-rtsopts=-N -j else diff --git a/src/Category.hs b/src/Category.hs index e904efb92..9e9bad4eb 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -2,7 +2,7 @@ module Category where import Prologue import Data.Hashable -import Test.QuickCheck +import Test.QuickCheck (oneof, Arbitrary, arbitrary, shrink) import Data.Text.Arbitrary() -- | A standardized category of AST node. Used to determine the semantics for @@ -78,17 +78,37 @@ data Category instance Hashable Category instance Arbitrary Category where - arbitrary = oneof - [ pure Program + arbitrary = oneof [ + pure Program , pure Error + , pure Boolean , pure BinaryOperator , pure DictionaryLiteral , pure Pair , pure FunctionCall + , pure Function + , pure Identifier + , pure Params + , pure ExpressionStatements + , pure MethodCall + , pure Args , pure StringLiteral , pure IntegerLiteral + , pure Regex , pure SymbolLiteral + , pure TemplateString , pure ArrayLiteral + , pure Assignment + , pure MathAssignment + , pure MemberAccess + , pure SubscriptAccess + , pure VarAssignment + , pure VarDecl + , pure Switch + , pure Ternary + , pure Case + , pure Operator + , pure Object , Other <$> arbitrary ] diff --git a/src/Data/Record.hs b/src/Data/Record.hs index 5d6043771..8cb72136e 100644 --- a/src/Data/Record.hs +++ b/src/Data/Record.hs @@ -3,6 +3,7 @@ module Data.Record where import Prologue import Test.QuickCheck +import GHC.Show (Show(..)) -- | A type-safe, extensible record structure. -- | diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index eae4c3188..84b1f72ee 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -13,6 +13,8 @@ import Data.Functor.Foldable as Foldable import Data.Functor.Both import Data.OrderedMap import Data.Text as Text (intercalate) +import Test.QuickCheck hiding (Fixed) +import Patch.Arbitrary() import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string) import qualified Text.PrettyPrint.Leijen.Text as P @@ -106,7 +108,11 @@ instance HasCategory leaf => HasCategory (Term leaf Info) where data DiffSummary a = DiffSummary { patch :: Patch a, parentAnnotations :: [Category] -} deriving (Eq, Functor, Show) +} deriving (Eq, Functor, Show, Generic) + +instance (Eq a, Arbitrary a) => Arbitrary (DiffSummary a) where + arbitrary = DiffSummary <$> arbitrary <*> arbitrary + shrink = genericShrink instance P.Pretty (DiffSummary DiffInfo) where pretty DiffSummary{..} = case patch of diff --git a/test/AlignmentSpec.hs b/test/AlignmentSpec.hs index 13730d8a2..e06474553 100644 --- a/test/AlignmentSpec.hs +++ b/test/AlignmentSpec.hs @@ -27,6 +27,7 @@ import Term import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck +import GHC.Show (Show(..)) spec :: Spec spec = parallel $ do diff --git a/test/CorpusSpec.hs b/test/CorpusSpec.hs index 57459ac38..84425de6f 100644 --- a/test/CorpusSpec.hs +++ b/test/CorpusSpec.hs @@ -1,7 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module CorpusSpec where -import System.IO import Data.String import Diffing import Renderer @@ -20,6 +19,7 @@ import qualified Source as S import System.FilePath import System.FilePath.Glob import Test.Hspec +import GHC.Show (Show(..)) spec :: Spec spec = parallel $ do @@ -76,7 +76,7 @@ testDiff renderer paths diff matcher = do case diff of Nothing -> matcher actual actual Just file -> do - expected <- Verbatim . T.pack <$> readFile file + expected <- Verbatim <$> readFile file matcher actual expected where parser = parserForFilepath (fst paths) sourceBlobs sources = pure S.SourceBlob <*> sources <*> pure mempty <*> paths <*> pure (Just S.defaultPlainBlob) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index ef4b7f3a2..977652641 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} module DiffSummarySpec where import Prologue @@ -10,7 +11,12 @@ import Patch import Range import Category import DiffSummary -import Text.PrettyPrint.Leijen.Text +import Text.PrettyPrint.Leijen.Text (pretty) +import Test.Hspec.QuickCheck +import Interpreter +import Term.Arbitrary +import Text.Megaparsec.Text +import Text.Megaparsec arrayInfo :: Info arrayInfo = rangeAt 0 .: ArrayLiteral .: 2 .: 0 .: RNil @@ -37,3 +43,22 @@ spec = parallel $ do show (pretty testSummary) `shouldBe` ("Added the 'a' string" :: Text) it "prints a replacement" $ do show (pretty replacementSummary) `shouldBe` ("Replaced the 'a' string with the 'b' symbol in the array context" :: Text) + prop "diff summaries of arbitrary diffs are identical" $ + \a b -> let + diff = diffTerms wrap (==) diffCost (toTerm a) (toTerm (b :: ArbitraryTerm Text Info)) + prettyDiff = show . pretty $ diffSummary diff in + parsePrettyDiff prettyDiff `shouldBe` Just (diffSummary diff) + +parsePrettyDiff :: Text -> Maybe [DiffSummary DiffInfo] +parsePrettyDiff string = parseMaybe diffParser string + +parsePatch :: Parsec Text (Patch Text) +parsePatch = (\x y z -> case x of + "Added" -> Insert (toS z) + "Deleted" -> Delete (toS z)) <$> (string "Added" <|> string "Deleted") <*> (space *> string "the" <* space) <*> between (char '\'') (char '\'') (many printChar) + +diffParser :: Parsec Text (DiffSummary DiffInfo) +diffParser = do + patch <- parsePatch + annotations <- _ + pure $ DiffSummary patch annotations \ No newline at end of file From 2ebbe72a76900e06ec1043dfd8977ccd5264db6f Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 14 Jul 2016 11:52:03 -0400 Subject: [PATCH 003/320] Add Categorizable newtype for HasCategory (Record fields) --- src/DiffSummary.hs | 32 +++++++++++++++++--------------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 84b1f72ee..30e60476e 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -4,9 +4,9 @@ module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..)) where import Prologue hiding (snd, intercalate) import Diff -import Info (Info, category) import Patch import Term +import Info (category) import Syntax import Category import Data.Functor.Foldable as Foldable @@ -15,12 +15,13 @@ import Data.OrderedMap import Data.Text as Text (intercalate) import Test.QuickCheck hiding (Fixed) import Patch.Arbitrary() +import Data.Record import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string) import qualified Text.PrettyPrint.Leijen.Text as P data DiffInfo = DiffInfo { categoryName :: Text, termName :: Text } deriving (Eq, Show) -toTermName :: HasCategory leaf => Term leaf Info -> Text +toTermName :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> Text toTermName term = case unwrap term of Fixed children -> fromMaybe "EmptyFixedNode" $ (toCategoryName . category) . extract <$> head children Indexed children -> fromMaybe "EmptyIndexedNode" $ (toCategoryName . category) . extract <$> head children @@ -65,8 +66,9 @@ class HasCategory a where instance HasCategory Text where toCategoryName = identity -instance HasCategory Info where - toCategoryName = toCategoryName . category +newtype Categorizable a = Categorizable a +instance (HasField fields Category) => HasCategory (Categorizable (Record fields)) where + toCategoryName (Categorizable a)= toCategoryName $ category a instance HasCategory Category where toCategoryName = \case @@ -102,7 +104,7 @@ instance HasCategory Category where TemplateString -> "template string" Category.Object -> "object" -instance HasCategory leaf => HasCategory (Term leaf Info) where +instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract data DiffSummary a = DiffSummary { @@ -125,7 +127,7 @@ instance P.Pretty (DiffSummary DiffInfo) where else space <> "in the" <+> (toDoc . intercalate "/" $ toCategoryName <$> annotations) <+> "context" toDoc = string . toS -diffSummary :: HasCategory leaf => Diff leaf Info -> [DiffSummary DiffInfo] +diffSummary :: (HasCategory leaf, HasField fields Category) => Diff leaf (Record fields) -> [DiffSummary DiffInfo] diffSummary = cata $ \case -- Skip comments and leaves since they don't have any changes (Free (_ :< Leaf _)) -> [] @@ -154,23 +156,23 @@ diffSummary = cata $ \case (Pure (Delete term)) -> (\info -> DiffSummary (Delete info) []) <$> termToDiffInfo term (Pure (Replace t1 t2)) -> (\(info1, info2) -> DiffSummary (Replace info1 info2) []) <$> zip (termToDiffInfo t1) (termToDiffInfo t2) -termToDiffInfo :: HasCategory leaf => Term leaf Info -> [DiffInfo] +termToDiffInfo :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> [DiffInfo] termToDiffInfo term = case runCofree term of (_ :< Leaf _) -> [ DiffInfo (toCategoryName term) (toTermName term) ] (_ :< Indexed children) -> join $ termToDiffInfo <$> children (_ :< Fixed children) -> join $ termToDiffInfo <$> children (_ :< Keyed children) -> join $ termToDiffInfo <$> Prologue.toList children - (info :< Syntax.FunctionCall identifier _) -> [ DiffInfo (toCategoryName info) (toTermName identifier) ] - (info :< Syntax.Ternary ternaryCondition _) -> [ DiffInfo (toCategoryName info) (toTermName ternaryCondition) ] - (info :< Syntax.Function identifier _ _) -> [ DiffInfo (toCategoryName info) (maybe "anonymous" toTermName identifier) ] - (info :< Syntax.Assignment identifier _) -> [ DiffInfo (toCategoryName info) (toTermName identifier) ] - (info :< Syntax.MathAssignment identifier _) -> [ DiffInfo (toCategoryName info) (toTermName identifier) ] + (info :< Syntax.FunctionCall identifier _) -> [ DiffInfo (toCategoryName (Categorizable info)) (toTermName identifier) ] + (info :< Syntax.Ternary ternaryCondition _) -> [ DiffInfo (toCategoryName (Categorizable info)) (toTermName ternaryCondition) ] + (info :< Syntax.Function identifier _ _) -> [ DiffInfo (toCategoryName $ Categorizable info) (maybe "anonymous" toTermName identifier) ] + (info :< Syntax.Assignment identifier _) -> [ DiffInfo (toCategoryName $ Categorizable info) (toTermName identifier) ] + (info :< Syntax.MathAssignment identifier _) -> [ DiffInfo (toCategoryName $ Categorizable info) (toTermName identifier) ] -- Currently we cannot express the operator for an operator production from TreeSitter. Eventually we should be able to -- use the term name of the operator identifier when we have that production value. Until then, I'm using a placeholder value -- to indicate where that value should be when constructing DiffInfos. - (info :< Syntax.Operator _) -> [DiffInfo (toCategoryName info) "x"] - (info :< Commented cs leaf) -> join (termToDiffInfo <$> cs) <> maybe [] (\leaf -> [ DiffInfo (toCategoryName info) (toTermName leaf) ]) leaf - (info :< _) -> [ DiffInfo (toCategoryName info) (toTermName term) ] + (info :< Syntax.Operator _) -> [DiffInfo (toCategoryName $ Categorizable info) "x"] + (info :< Commented cs leaf) -> join (termToDiffInfo <$> cs) <> maybe [] (\leaf -> [ DiffInfo (toCategoryName $ Categorizable info) (toTermName leaf) ]) leaf + (info :< _) -> [ DiffInfo (toCategoryName $ Categorizable info) (toTermName term) ] prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo prependSummary annotation summary = summary { parentAnnotations = annotation : parentAnnotations summary } From 922e845c786aa7054e97686663c13f2c01103f17 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 14 Jul 2016 11:52:40 -0400 Subject: [PATCH 004/320] Add property test to test diff summary constructors --- test/DiffSummarySpec.hs | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 977652641..107a69b58 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -14,7 +14,7 @@ import DiffSummary import Text.PrettyPrint.Leijen.Text (pretty) import Test.Hspec.QuickCheck import Interpreter -import Term.Arbitrary +import Diff.Arbitrary import Text.Megaparsec.Text import Text.Megaparsec @@ -44,21 +44,18 @@ spec = parallel $ do it "prints a replacement" $ do show (pretty replacementSummary) `shouldBe` ("Replaced the 'a' string with the 'b' symbol in the array context" :: Text) prop "diff summaries of arbitrary diffs are identical" $ - \a b -> let - diff = diffTerms wrap (==) diffCost (toTerm a) (toTerm (b :: ArbitraryTerm Text Info)) - prettyDiff = show . pretty $ diffSummary diff in - parsePrettyDiff prettyDiff `shouldBe` Just (diffSummary diff) + \a -> let + diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category]))) + summaries = diffSummary diff in + ((() <$) . patch <$> summaries) `shouldBe` ((() <$) <$> toList diff) parsePrettyDiff :: Text -> Maybe [DiffSummary DiffInfo] parsePrettyDiff string = parseMaybe diffParser string -parsePatch :: Parsec Text (Patch Text) -parsePatch = (\x y z -> case x of - "Added" -> Insert (toS z) - "Deleted" -> Delete (toS z)) <$> (string "Added" <|> string "Deleted") <*> (space *> string "the" <* space) <*> between (char '\'') (char '\'') (many printChar) +parsePatch :: Parsec Text (Patch DiffInfo) +parsePatch = (\x y z a -> case x of + "Added" -> Insert (DiffInfo (toS z) (toS a)) + "Deleted" -> Delete (DiffInfo(toS z) (toS a))) <$> (string "Added" <|> string "Deleted") <*> (space *> string "the" <* space) <*> between (char '\'') (char '\'') (many printChar) <*> (space *> many printChar) -diffParser :: Parsec Text (DiffSummary DiffInfo) -diffParser = do - patch <- parsePatch - annotations <- _ - pure $ DiffSummary patch annotations \ No newline at end of file +diffParser :: Parsec Text [(DiffSummary DiffInfo)] +diffParser = (DiffSummary <$> parsePatch <*> pure []) `sepBy` newline From a9adce26104f717e6addd66b4d492efc27f152f7 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 14 Jul 2016 13:01:16 -0400 Subject: [PATCH 005/320] other patches should be the same as summary patches --- test/DiffSummarySpec.hs | 26 ++++++++++++++++++++++++-- 1 file changed, 24 insertions(+), 2 deletions(-) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 107a69b58..6ef7fb313 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -7,6 +7,7 @@ import Test.Hspec import Diff import Info import Syntax +import Term import Patch import Range import Category @@ -17,6 +18,7 @@ import Interpreter import Diff.Arbitrary import Text.Megaparsec.Text import Text.Megaparsec +import Data.List (partition) arrayInfo :: Info arrayInfo = rangeAt 0 .: ArrayLiteral .: 2 .: 0 .: RNil @@ -46,8 +48,28 @@ spec = parallel $ do prop "diff summaries of arbitrary diffs are identical" $ \a -> let diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category]))) - summaries = diffSummary diff in - ((() <$) . patch <$> summaries) `shouldBe` ((() <$) <$> toList diff) + summaries = diffSummary diff + patches = toList diff + isIndexedOrFixed :: Patch (Term a annotation) -> Bool + isIndexedOrFixed patch = case unwrap <$> patch of + (Insert syntax) -> isIndexedOrFixed' syntax + (Delete syntax) -> isIndexedOrFixed' syntax + (Replace s1 s2) -> isIndexedOrFixed' s1 || isIndexedOrFixed' s2 + isIndexedOrFixed' = \case + (Indexed _) -> True + (Fixed _) -> True + _ -> False + isBranchCategory = \case + (Insert info) -> categoryName info `elem` ["Indexed", "Fixed"] + (Delete info) -> categoryName info `elem` ["Indexed", "Fixed"] + (Replace i1 i2) -> categoryName i1 `elem` ["Indexed", "Fixed"] || categoryName i2 `elem` ["Indexed", "Fixed"] + in + case (partition isIndexedOrFixed patches, partition isBranchCategory (patch <$> summaries)) of + ((branchPatches, otherPatches), (branchSummaries, otherSummaries)) -> + (() <$ branchPatches, () <$ otherPatches) `shouldBe` (() <$ branchSummaries, () <$ otherSummaries) + + -- ((() <$) . patch <$> summaries) `shouldBe` ((() <$) <$> otherPatches) + parsePrettyDiff :: Text -> Maybe [DiffSummary DiffInfo] parsePrettyDiff string = parseMaybe diffParser string From 1c65d03618b9a9b7c61c79f03f3050887256c17c Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 14 Jul 2016 13:01:33 -0400 Subject: [PATCH 006/320] Output a diff summary for empty branch syntax nodes --- src/DiffSummary.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 30e60476e..5b0c429cc 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -159,8 +159,8 @@ diffSummary = cata $ \case termToDiffInfo :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> [DiffInfo] termToDiffInfo term = case runCofree term of (_ :< Leaf _) -> [ DiffInfo (toCategoryName term) (toTermName term) ] - (_ :< Indexed children) -> join $ termToDiffInfo <$> children - (_ :< Fixed children) -> join $ termToDiffInfo <$> children + (info :< Indexed children) -> if null children then [ DiffInfo (toCategoryName (Categorizable info)) (toTermName term) ] else join $ termToDiffInfo <$> children + (info :< Fixed children) -> if null children then [ DiffInfo (toCategoryName (Categorizable info)) (toTermName term) ] else join $ termToDiffInfo <$> children (_ :< Keyed children) -> join $ termToDiffInfo <$> Prologue.toList children (info :< Syntax.FunctionCall identifier _) -> [ DiffInfo (toCategoryName (Categorizable info)) (toTermName identifier) ] (info :< Syntax.Ternary ternaryCondition _) -> [ DiffInfo (toCategoryName (Categorizable info)) (toTermName ternaryCondition) ] From 13671e5d14d2e87afc9c942a1eb564b36e5f7982 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 14 Jul 2016 19:35:23 -0400 Subject: [PATCH 007/320] Add patchAnnotations to DiffInfo to track discarded branch nodes --- src/DiffSummary.hs | 64 ++++++++++++++++++++++++++++++++--------- src/Diffing.hs | 16 +++++++---- test/DiffSummarySpec.hs | 41 +++++++++++++------------- 3 files changed, 82 insertions(+), 39 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index c41d88841..9e97bce0f 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -6,9 +6,13 @@ import Prologue hiding (snd, intercalate) import Diff import Patch import Term -import Info (category) +import Info (category, Cost) import Syntax import Category +import Interpreter (diffTerms) +import Diffing +import Data.Align +import Data.These import Data.Functor.Foldable as Foldable import Data.Functor.Both import Data.Text as Text (intercalate) @@ -17,13 +21,14 @@ import Patch.Arbitrary() import Data.Record import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string) import qualified Text.PrettyPrint.Leijen.Text as P +import Data.Hashable data DiffInfo = DiffInfo { categoryName :: Text, termName :: Text } deriving (Eq, Show) toTermName :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> Text toTermName term = case unwrap term of - Fixed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children - Indexed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children + Syntax.Fixed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children + Syntax.Indexed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children Leaf leaf -> toCategoryName leaf Syntax.Assignment identifier value -> toTermName identifier <> toTermName value Syntax.Function identifier _ _ -> (maybe "anonymous" toTermName identifier) @@ -105,13 +110,19 @@ instance HasCategory Category where instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract +data Branch = Indexed | Fixed deriving (Show, Eq, Generic) +instance Arbitrary Branch where + arbitrary = oneof [ pure DiffSummary.Indexed, pure DiffSummary.Fixed ] + shrink = genericShrink + data DiffSummary a = DiffSummary { patch :: Patch a, - parentAnnotations :: [Category] + parentAnnotations :: [Category], + patchAnnotations :: [Patch Branch] } deriving (Eq, Functor, Show, Generic) instance (Eq a, Arbitrary a) => Arbitrary (DiffSummary a) where - arbitrary = DiffSummary <$> arbitrary <*> arbitrary + arbitrary = DiffSummary <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink instance P.Pretty (DiffSummary DiffInfo) where @@ -125,13 +136,13 @@ instance P.Pretty (DiffSummary DiffInfo) where else space <> "in the" <+> (toDoc . intercalate "/" $ toCategoryName <$> annotations) <+> "context" toDoc = string . toS -diffSummary :: (HasCategory leaf, HasField fields Category) => Diff leaf (Record fields) -> [DiffSummary DiffInfo] +diffSummary :: (HasCategory leaf, HasField fields Category, Hashable leaf, Show (Record fields), Show leaf, Ord (Record fields), Eq leaf, HasField fields Cost) => Diff leaf (Record fields) -> [DiffSummary DiffInfo] diffSummary = cata $ \case -- Skip comments and leaves since they don't have any changes (Free (_ :< Leaf _)) -> [] Free (_ :< (Syntax.Comment _)) -> [] - (Free (infos :< Indexed children)) -> prependSummary (category $ snd infos) <$> join children - (Free (infos :< Fixed children)) -> prependSummary (category $ snd infos) <$> join children + (Free (infos :< Syntax.Indexed children)) -> prependSummary (category $ snd infos) <$> join children + (Free (infos :< Syntax.Fixed children)) -> prependSummary (category $ snd infos) <$> join children (Free (infos :< Syntax.FunctionCall identifier children)) -> prependSummary (category $ snd infos) <$> join (Prologue.toList (identifier : children)) (Free (infos :< Syntax.Function id ps body)) -> prependSummary (category $ snd infos) <$> (fromMaybe [] id) <> (fromMaybe [] ps) <> body (Free (infos :< Syntax.Assignment id value)) -> prependSummary (category $ snd infos) <$> id <> value @@ -149,15 +160,42 @@ diffSummary = cata $ \case Free (infos :< (Syntax.Object kvs)) -> prependSummary (category $ snd infos) <$> join kvs Free (infos :< (Syntax.Pair a b)) -> prependSummary (category $ snd infos) <$> a <> b Free (infos :< (Syntax.Commented cs leaf)) -> prependSummary (category $ snd infos) <$> join cs <> fromMaybe [] leaf - (Pure (Insert term)) -> (\info -> DiffSummary (Insert info) []) <$> termToDiffInfo term - (Pure (Delete term)) -> (\info -> DiffSummary (Delete info) []) <$> termToDiffInfo term - (Pure (Replace t1 t2)) -> (\(info1, info2) -> DiffSummary (Replace info1 info2) []) <$> zip (termToDiffInfo t1) (termToDiffInfo t2) + (Pure (Insert term)) -> (\info -> DiffSummary (Insert info) [] []) <$> termToDiffInfo term + (Pure (Insert term)) -> case unwrap term of + (Syntax.Indexed terms) -> + (\info -> DiffSummary (Insert info) [] [Delete DiffSummary.Indexed]) <$> (join $ termToDiffInfo <$> terms) + (Syntax.Fixed terms) -> + (\info -> DiffSummary (Insert info) [] [Delete DiffSummary.Fixed]) <$> (join $ termToDiffInfo <$> terms) + (Pure (Delete term)) -> case unwrap term of + (Syntax.Indexed terms) -> + (\info -> DiffSummary (Delete info) [] [Delete DiffSummary.Indexed]) <$> termToDiffInfo term + (Syntax.Fixed terms) -> + (\info -> DiffSummary (Delete info) [] [Delete DiffSummary.Fixed]) <$> termToDiffInfo term + (Pure (Replace t1 t2)) -> case (unwrap t1, unwrap t2) of + (Syntax.Indexed t1', Syntax.Indexed t2') -> + (\patch -> DiffSummary patch [] [Replace DiffSummary.Indexed DiffSummary.Indexed]) <$> join (alignWith summarizeThese t1' t2') + (Syntax.Indexed t1', Syntax.Fixed t2') -> + (\patch -> DiffSummary patch [] [Replace DiffSummary.Indexed DiffSummary.Fixed]) <$> join (alignWith summarizeThese t1' t2') + (Syntax.Fixed t1', Syntax.Indexed t2') -> + (\patch -> DiffSummary patch [] [Replace DiffSummary.Fixed DiffSummary.Indexed]) <$> join (alignWith summarizeThese t1' t2') + (Syntax.Fixed t1', Syntax.Fixed t2') -> + (\patch -> DiffSummary patch [] [Replace DiffSummary.Fixed DiffSummary.Fixed]) <$> join (alignWith summarizeThese t1' t2') + (_, _) -> + (\(info1, info2) -> DiffSummary (Replace info1 info2) [] []) <$> zip (termToDiffInfo t1) (termToDiffInfo t2) + +summarizeThese :: (HasCategory leaf, HasField fields Category, Hashable leaf, Show (Record fields), Show leaf, Ord (Record fields), Eq leaf, HasField fields Cost) => These (Term leaf (Record fields)) (Term leaf (Record fields)) -> [Patch DiffInfo] +summarizeThese = these (sequence . Delete <$> termToDiffInfo) (sequence . Insert <$> termToDiffInfo) (\t1 t2 -> patch <$> summaries t1 t2) + where + summaries :: (HasCategory leaf, HasField fields Category, Hashable leaf, Show (Record fields), Show leaf, Ord (Record fields), Eq leaf, HasField fields Cost) => Term leaf (Record fields) -> Term leaf (Record fields) -> [DiffSummary DiffInfo] + summaries t1 t2 = diffSummary $ diffTerms construct compareCategoryEq diffCostWithCachedTermSizes t1 t2 termToDiffInfo :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> [DiffInfo] termToDiffInfo term = case runCofree term of (_ :< Leaf _) -> [ DiffInfo (toCategoryName term) (toTermName term) ] - (info :< Indexed children) -> if null children then [ DiffInfo (toCategoryName (Categorizable info)) (toTermName term) ] else join $ termToDiffInfo <$> children - (info :< Fixed children) -> if null children then [ DiffInfo (toCategoryName (Categorizable info)) (toTermName term) ] else join $ termToDiffInfo <$> children + (info :< Syntax.Indexed children) -> if null children + then [ DiffInfo (toCategoryName (Categorizable info)) (toTermName term) ] + else join $ termToDiffInfo <$> children + (info :< Syntax.Fixed children) -> if null children then [ DiffInfo (toCategoryName (Categorizable info)) (toTermName term) ] else join $ termToDiffInfo <$> children (info :< Syntax.FunctionCall identifier _) -> [ DiffInfo (toCategoryName (Categorizable info)) (toTermName identifier) ] (info :< Syntax.Ternary ternaryCondition _) -> [ DiffInfo (toCategoryName (Categorizable info)) (toTermName ternaryCondition) ] (info :< Syntax.Function identifier _ _) -> [ DiffInfo (toCategoryName $ Categorizable info) (maybe "anonymous" toTermName identifier) ] diff --git a/src/Diffing.hs b/src/Diffing.hs index cc813c00f..8d047b40e 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -92,19 +92,23 @@ diffFiles parser renderer sourceBlobs = do (True, False) -> pure $ Insert (snd terms) (False, True) -> pure $ Delete (fst terms) (_, _) -> - runBothWith (diffTerms construct shouldCompareTerms diffCostWithCachedTermSizes) $ replaceLeaves <*> terms + runBothWith (diffTerms construct compareCategoryEq diffCostWithCachedTermSizes) $ replaceLeaves <*> terms pure $! renderer textDiff sourceBlobs - where construct :: CofreeF (Syntax Text) (Both Info) (Diff Text Info) -> Diff Text Info - construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax)) - sumCost = fmap getSum . foldMap (fmap Sum . getCost) + + +construct :: HasField fields Cost => CofreeF (Syntax leaf) (Both (Record fields)) (Diff leaf (Record fields)) -> Diff leaf (Record fields) +construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax)) + where sumCost = fmap getSum . foldMap (fmap Sum . getCost) getCost diff = case runFree diff of Free (info :< _) -> cost <$> info Pure patch -> uncurry both (fromThese 0 0 (unPatch (cost . extract <$> patch))) - shouldCompareTerms = (==) `on` category . extract + +compareCategoryEq :: HasField fields Category => Term leaf (Record fields) -> Term leaf (Record fields) -> Bool +compareCategoryEq = (==) `on` category . extract -- | The sum of the node count of the diff’s patches. -diffCostWithCachedTermSizes :: Diff a Info -> Integer +diffCostWithCachedTermSizes :: HasField fields Cost => Diff a (Record fields) -> Integer diffCostWithCachedTermSizes diff = unCost $ case runFree diff of Free (info :< _) -> sum (cost <$> info) Pure patch -> sum (cost . extract <$> patch) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 1b0d4ff23..01b776db4 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -30,24 +30,24 @@ testDiff :: Diff Text Info testDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "a")) ]) testSummary :: DiffSummary DiffInfo -testSummary = DiffSummary { patch = Insert (DiffInfo "string" "a"), parentAnnotations = [] } +testSummary = DiffSummary { patch = Insert (DiffInfo "string" "a"), parentAnnotations = [], patchAnnotations = [] } replacementSummary :: DiffSummary DiffInfo -replacementSummary = DiffSummary { patch = Replace (DiffInfo "string" "a") (DiffInfo "symbol" "b"), parentAnnotations = [ ArrayLiteral ] } +replacementSummary = DiffSummary { patch = Replace (DiffInfo "string" "a") (DiffInfo "symbol" "b"), parentAnnotations = [ ArrayLiteral ], patchAnnotations = [] } spec :: Spec spec = parallel $ do describe "diffSummary" $ do it "outputs a diff summary" $ do - diffSummary testDiff `shouldBe` [ DiffSummary { patch = Insert (DiffInfo "string" "a"), parentAnnotations = [ ArrayLiteral ] } ] + diffSummary testDiff `shouldBe` [ DiffSummary { patch = Insert (DiffInfo "string" "a"), parentAnnotations = [ ArrayLiteral ], patchAnnotations = [] } ] describe "show" $ do it "should print adds" $ show (pretty testSummary) `shouldBe` ("Added the 'a' string" :: Text) it "prints a replacement" $ do show (pretty replacementSummary) `shouldBe` ("Replaced the 'a' string with the 'b' symbol in the array context" :: Text) - prop "diff summaries of arbitrary diffs are identical" $ + prop "patches in summaries match the patches in diffs" $ \a -> let - diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category]))) + diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Cost]))) summaries = diffSummary diff patches = toList diff isIndexedOrFixed :: Patch (Term a annotation) -> Bool @@ -59,22 +59,23 @@ spec = parallel $ do (Indexed _) -> True (Fixed _) -> True _ -> False - isBranchCategory syntax = case syntax of; (Insert info) -> termName info == "branch" || categoryName info `elem` ["Indexed", "Fixed"]; (Delete info) -> termName info == "branch" || categoryName info `elem` ["Indexed", "Fixed"]; (Replace i1 i2) -> termName i1 == "branch" || categoryName i1 `elem` ["Indexed", "Fixed"] || categoryName i1 `elem` ["Indexed", "Fixed"] || termName i2 == "branch"; + isBranchNode :: DiffSummary DiffInfo -> Bool + isBranchNode summary = (not . null $ patchAnnotations summary) || (case patch summary of + (Insert diffInfo) -> termName diffInfo == "branch" + (Delete diffInfo) -> termName diffInfo == "branch" + (Replace i1 i2) -> termName i1 == "branch" || termName i2 == "branch") in - case (partition isBranchCategory (patch <$> summaries), partition isIndexedOrFixed patches) of + case (partition isBranchNode summaries, partition isIndexedOrFixed patches) of ((branchSummaries, otherSummaries), (branchPatches, otherPatches)) -> - (() <$ branchSummaries, () <$ otherSummaries) `shouldBe` (() <$ branchPatches, () <$ otherPatches) + ((() <$) . patch <$> branchSummaries, (() <$) . patch <$> otherSummaries) `shouldBe` ((() <$) <$> branchPatches, (() <$) <$> otherPatches) + -- ((() <$) <$> (patch <$> summaries)) `shouldBe` ((() <$) <$> patches) + -- [Insert (), Insert ()] == [ Insert () ] + -- explodePatch :: Patch (Syntax a) -> [Patch (Syntax a)] + -- explodePatch Indexed = explodePatch <$> children + + -- Patches of branch nodes with children should have a summary for each child that is not a branch node + -- Patches of branch nodes with children that are branch nodes shoudl have a summary for each of those children or one summary per branch if the branches are empty +-- let xs = ArbitraryPure (Insert (ArbitraryTerm {annotation = Category.Operator .: RNil, syntax = Indexed [ArbitraryTerm {annotation = Program .: RNil, syntax = Leaf ""}]})) +-- let xs = ArbitraryPure (Delete (ArbitraryTerm {annotation = Category.Case .: RNil, syntax = Fixed [ArbitraryTerm {annotation = Category.FunctionCall .: RNil, syntax = Leaf ""}]})) :: ArbitraryDiff Text (Record '[Category]) -- ((() <$) . patch <$> summaries) `shouldBe` ((() <$) <$> otherPatches) - - -parsePrettyDiff :: Text -> Maybe [DiffSummary DiffInfo] -parsePrettyDiff string = parseMaybe diffParser string - -parsePatch :: Parsec Text (Patch DiffInfo) -parsePatch = (\x y z a -> case x of - "Added" -> Insert (DiffInfo (toS z) (toS a)) - "Deleted" -> Delete (DiffInfo(toS z) (toS a))) <$> (string "Added" <|> string "Deleted") <*> (space *> string "the" <* space) <*> between (char '\'') (char '\'') (many printChar) <*> (space *> many printChar) - -diffParser :: Parsec Text [(DiffSummary DiffInfo)] -diffParser = (DiffSummary <$> parsePatch <*> pure []) `sepBy` newline From e57f30f20bc80d255acac91bf5266ff83b18ef33 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 15 Jul 2016 13:18:45 -0400 Subject: [PATCH 008/320] DiffInfo are now either LeafInfos or BranchInfos --- src/DiffSummary.hs | 74 ++++++++++++----------------------------- test/DiffSummarySpec.hs | 31 ++++++----------- 2 files changed, 32 insertions(+), 73 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 9e97bce0f..97e39ee47 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -9,10 +9,6 @@ import Term import Info (category, Cost) import Syntax import Category -import Interpreter (diffTerms) -import Diffing -import Data.Align -import Data.These import Data.Functor.Foldable as Foldable import Data.Functor.Both import Data.Text as Text (intercalate) @@ -23,7 +19,9 @@ import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string) import qualified Text.PrettyPrint.Leijen.Text as P import Data.Hashable -data DiffInfo = DiffInfo { categoryName :: Text, termName :: Text } deriving (Eq, Show) +data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text } + | BranchInfo { branches :: [ DiffInfo ], categoryName :: Text, branchType :: Branch } + deriving (Eq, Show) toTermName :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> Text toTermName term = case unwrap term of @@ -110,19 +108,18 @@ instance HasCategory Category where instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract -data Branch = Indexed | Fixed deriving (Show, Eq, Generic) +data Branch = BIndexed | BFixed | BCommented deriving (Show, Eq, Generic) instance Arbitrary Branch where - arbitrary = oneof [ pure DiffSummary.Indexed, pure DiffSummary.Fixed ] + arbitrary = oneof [ pure BIndexed, pure BFixed ] shrink = genericShrink data DiffSummary a = DiffSummary { patch :: Patch a, - parentAnnotations :: [Category], - patchAnnotations :: [Patch Branch] + parentAnnotations :: [Category] } deriving (Eq, Functor, Show, Generic) instance (Eq a, Arbitrary a) => Arbitrary (DiffSummary a) where - arbitrary = DiffSummary <$> arbitrary <*> arbitrary <*> arbitrary + arbitrary = DiffSummary <$> arbitrary <*> arbitrary shrink = genericShrink instance P.Pretty (DiffSummary DiffInfo) where @@ -160,53 +157,26 @@ diffSummary = cata $ \case Free (infos :< (Syntax.Object kvs)) -> prependSummary (category $ snd infos) <$> join kvs Free (infos :< (Syntax.Pair a b)) -> prependSummary (category $ snd infos) <$> a <> b Free (infos :< (Syntax.Commented cs leaf)) -> prependSummary (category $ snd infos) <$> join cs <> fromMaybe [] leaf - (Pure (Insert term)) -> (\info -> DiffSummary (Insert info) [] []) <$> termToDiffInfo term - (Pure (Insert term)) -> case unwrap term of - (Syntax.Indexed terms) -> - (\info -> DiffSummary (Insert info) [] [Delete DiffSummary.Indexed]) <$> (join $ termToDiffInfo <$> terms) - (Syntax.Fixed terms) -> - (\info -> DiffSummary (Insert info) [] [Delete DiffSummary.Fixed]) <$> (join $ termToDiffInfo <$> terms) - (Pure (Delete term)) -> case unwrap term of - (Syntax.Indexed terms) -> - (\info -> DiffSummary (Delete info) [] [Delete DiffSummary.Indexed]) <$> termToDiffInfo term - (Syntax.Fixed terms) -> - (\info -> DiffSummary (Delete info) [] [Delete DiffSummary.Fixed]) <$> termToDiffInfo term - (Pure (Replace t1 t2)) -> case (unwrap t1, unwrap t2) of - (Syntax.Indexed t1', Syntax.Indexed t2') -> - (\patch -> DiffSummary patch [] [Replace DiffSummary.Indexed DiffSummary.Indexed]) <$> join (alignWith summarizeThese t1' t2') - (Syntax.Indexed t1', Syntax.Fixed t2') -> - (\patch -> DiffSummary patch [] [Replace DiffSummary.Indexed DiffSummary.Fixed]) <$> join (alignWith summarizeThese t1' t2') - (Syntax.Fixed t1', Syntax.Indexed t2') -> - (\patch -> DiffSummary patch [] [Replace DiffSummary.Fixed DiffSummary.Indexed]) <$> join (alignWith summarizeThese t1' t2') - (Syntax.Fixed t1', Syntax.Fixed t2') -> - (\patch -> DiffSummary patch [] [Replace DiffSummary.Fixed DiffSummary.Fixed]) <$> join (alignWith summarizeThese t1' t2') - (_, _) -> - (\(info1, info2) -> DiffSummary (Replace info1 info2) [] []) <$> zip (termToDiffInfo t1) (termToDiffInfo t2) + (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo term) [] ] + (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo term) [] ] + (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo t1) (termToDiffInfo t2)) [] ] -summarizeThese :: (HasCategory leaf, HasField fields Category, Hashable leaf, Show (Record fields), Show leaf, Ord (Record fields), Eq leaf, HasField fields Cost) => These (Term leaf (Record fields)) (Term leaf (Record fields)) -> [Patch DiffInfo] -summarizeThese = these (sequence . Delete <$> termToDiffInfo) (sequence . Insert <$> termToDiffInfo) (\t1 t2 -> patch <$> summaries t1 t2) - where - summaries :: (HasCategory leaf, HasField fields Category, Hashable leaf, Show (Record fields), Show leaf, Ord (Record fields), Eq leaf, HasField fields Cost) => Term leaf (Record fields) -> Term leaf (Record fields) -> [DiffSummary DiffInfo] - summaries t1 t2 = diffSummary $ diffTerms construct compareCategoryEq diffCostWithCachedTermSizes t1 t2 - -termToDiffInfo :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> [DiffInfo] +termToDiffInfo :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> DiffInfo termToDiffInfo term = case runCofree term of - (_ :< Leaf _) -> [ DiffInfo (toCategoryName term) (toTermName term) ] - (info :< Syntax.Indexed children) -> if null children - then [ DiffInfo (toCategoryName (Categorizable info)) (toTermName term) ] - else join $ termToDiffInfo <$> children - (info :< Syntax.Fixed children) -> if null children then [ DiffInfo (toCategoryName (Categorizable info)) (toTermName term) ] else join $ termToDiffInfo <$> children - (info :< Syntax.FunctionCall identifier _) -> [ DiffInfo (toCategoryName (Categorizable info)) (toTermName identifier) ] - (info :< Syntax.Ternary ternaryCondition _) -> [ DiffInfo (toCategoryName (Categorizable info)) (toTermName ternaryCondition) ] - (info :< Syntax.Function identifier _ _) -> [ DiffInfo (toCategoryName $ Categorizable info) (maybe "anonymous" toTermName identifier) ] - (info :< Syntax.Assignment identifier _) -> [ DiffInfo (toCategoryName $ Categorizable info) (toTermName identifier) ] - (info :< Syntax.MathAssignment identifier _) -> [ DiffInfo (toCategoryName $ Categorizable info) (toTermName identifier) ] + (_ :< Leaf _) -> LeafInfo (toCategoryName term) (toTermName term) + (info :< Syntax.Indexed children) -> BranchInfo (termToDiffInfo <$> children) (toCategoryName (Categorizable info)) BIndexed + (info :< Syntax.Fixed children) -> BranchInfo (termToDiffInfo <$> children) (toCategoryName (Categorizable info)) BFixed + (info :< Syntax.FunctionCall identifier _) -> LeafInfo (toCategoryName (Categorizable info)) (toTermName identifier) + (info :< Syntax.Ternary ternaryCondition _) -> LeafInfo (toCategoryName (Categorizable info)) (toTermName ternaryCondition) + (info :< Syntax.Function identifier _ _) -> LeafInfo (toCategoryName $ Categorizable info) (maybe "anonymous" toTermName identifier) + (info :< Syntax.Assignment identifier _) -> LeafInfo (toCategoryName $ Categorizable info) (toTermName identifier) + (info :< Syntax.MathAssignment identifier _) -> LeafInfo (toCategoryName $ Categorizable info) (toTermName identifier) -- Currently we cannot express the operator for an operator production from TreeSitter. Eventually we should be able to -- use the term name of the operator identifier when we have that production value. Until then, I'm using a placeholder value -- to indicate where that value should be when constructing DiffInfos. - (info :< Syntax.Operator _) -> [DiffInfo (toCategoryName $ Categorizable info) "x"] - (info :< Commented cs leaf) -> join (termToDiffInfo <$> cs) <> maybe [] (\leaf -> [ DiffInfo (toCategoryName $ Categorizable info) (toTermName leaf) ]) leaf - (info :< _) -> [ DiffInfo (toCategoryName $ Categorizable info) (toTermName term) ] + (info :< Syntax.Operator _) -> LeafInfo (toCategoryName $ Categorizable info) "x" + (info :< Commented cs leaf) -> BranchInfo (termToDiffInfo <$> cs <> maybeToList leaf) (toCategoryName $ Categorizable info) BCommented + (info :< _) -> LeafInfo (toCategoryName $ Categorizable info) (toTermName term) prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo prependSummary annotation summary = summary { parentAnnotations = annotation : parentAnnotations summary } diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 01b776db4..402c50a98 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -14,10 +14,7 @@ import Category import DiffSummary import Text.PrettyPrint.Leijen.Text (pretty) import Test.Hspec.QuickCheck -import Interpreter import Diff.Arbitrary -import Text.Megaparsec.Text -import Text.Megaparsec import Data.List (partition) arrayInfo :: Info @@ -30,16 +27,16 @@ testDiff :: Diff Text Info testDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "a")) ]) testSummary :: DiffSummary DiffInfo -testSummary = DiffSummary { patch = Insert (DiffInfo "string" "a"), parentAnnotations = [], patchAnnotations = [] } +testSummary = DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnotations = [] } replacementSummary :: DiffSummary DiffInfo -replacementSummary = DiffSummary { patch = Replace (DiffInfo "string" "a") (DiffInfo "symbol" "b"), parentAnnotations = [ ArrayLiteral ], patchAnnotations = [] } +replacementSummary = DiffSummary { patch = Replace (LeafInfo "string" "a") (LeafInfo "symbol" "b"), parentAnnotations = [ ArrayLiteral ] } spec :: Spec spec = parallel $ do describe "diffSummary" $ do it "outputs a diff summary" $ do - diffSummary testDiff `shouldBe` [ DiffSummary { patch = Insert (DiffInfo "string" "a"), parentAnnotations = [ ArrayLiteral ], patchAnnotations = [] } ] + diffSummary testDiff `shouldBe` [ DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnotations = [ ArrayLiteral ] } ] describe "show" $ do it "should print adds" $ show (pretty testSummary) `shouldBe` ("Added the 'a' string" :: Text) @@ -59,23 +56,15 @@ spec = parallel $ do (Indexed _) -> True (Fixed _) -> True _ -> False + isBranchInfo info = case info of + (BranchInfo _ _ _) -> True + (LeafInfo _ _) -> False isBranchNode :: DiffSummary DiffInfo -> Bool - isBranchNode summary = (not . null $ patchAnnotations summary) || (case patch summary of - (Insert diffInfo) -> termName diffInfo == "branch" - (Delete diffInfo) -> termName diffInfo == "branch" - (Replace i1 i2) -> termName i1 == "branch" || termName i2 == "branch") + isBranchNode summary = (case patch summary of + (Insert diffInfo) -> isBranchInfo diffInfo + (Delete diffInfo) -> isBranchInfo diffInfo + (Replace i1 i2) -> isBranchInfo i1 || isBranchInfo i2) in case (partition isBranchNode summaries, partition isIndexedOrFixed patches) of ((branchSummaries, otherSummaries), (branchPatches, otherPatches)) -> ((() <$) . patch <$> branchSummaries, (() <$) . patch <$> otherSummaries) `shouldBe` ((() <$) <$> branchPatches, (() <$) <$> otherPatches) - - -- ((() <$) <$> (patch <$> summaries)) `shouldBe` ((() <$) <$> patches) - -- [Insert (), Insert ()] == [ Insert () ] - -- explodePatch :: Patch (Syntax a) -> [Patch (Syntax a)] - -- explodePatch Indexed = explodePatch <$> children - - -- Patches of branch nodes with children should have a summary for each child that is not a branch node - -- Patches of branch nodes with children that are branch nodes shoudl have a summary for each of those children or one summary per branch if the branches are empty --- let xs = ArbitraryPure (Insert (ArbitraryTerm {annotation = Category.Operator .: RNil, syntax = Indexed [ArbitraryTerm {annotation = Program .: RNil, syntax = Leaf ""}]})) --- let xs = ArbitraryPure (Delete (ArbitraryTerm {annotation = Category.Case .: RNil, syntax = Fixed [ArbitraryTerm {annotation = Category.FunctionCall .: RNil, syntax = Leaf ""}]})) :: ArbitraryDiff Text (Record '[Category]) - -- ((() <$) . patch <$> summaries) `shouldBe` ((() <$) <$> otherPatches) From ea814432a699499fee0125820b9ae3ee48f89f8e Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 15 Jul 2016 14:10:31 -0400 Subject: [PATCH 009/320] Add a property test to check number of LeafInfos in diff summaries match leaves in diff patches --- src/DiffSummary.hs | 2 +- test/DiffSummarySpec.hs | 82 ++++++++++++++++++++++++++++------------- 2 files changed, 57 insertions(+), 27 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 97e39ee47..81042ca37 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -133,7 +133,7 @@ instance P.Pretty (DiffSummary DiffInfo) where else space <> "in the" <+> (toDoc . intercalate "/" $ toCategoryName <$> annotations) <+> "context" toDoc = string . toS -diffSummary :: (HasCategory leaf, HasField fields Category, Hashable leaf, Show (Record fields), Show leaf, Ord (Record fields), Eq leaf, HasField fields Cost) => Diff leaf (Record fields) -> [DiffSummary DiffInfo] +diffSummary :: (HasCategory leaf, HasField fields Category) => Diff leaf (Record fields) -> [DiffSummary DiffInfo] diffSummary = cata $ \case -- Skip comments and leaves since they don't have any changes (Free (_ :< Leaf _)) -> [] diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 402c50a98..add67b280 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -42,29 +42,59 @@ spec = parallel $ do show (pretty testSummary) `shouldBe` ("Added the 'a' string" :: Text) it "prints a replacement" $ do show (pretty replacementSummary) `shouldBe` ("Replaced the 'a' string with the 'b' symbol in the array context" :: Text) - prop "patches in summaries match the patches in diffs" $ - \a -> let - diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Cost]))) - summaries = diffSummary diff - patches = toList diff - isIndexedOrFixed :: Patch (Term a annotation) -> Bool - isIndexedOrFixed patch = case unwrap <$> patch of - (Insert syntax) -> isIndexedOrFixed' syntax - (Delete syntax) -> isIndexedOrFixed' syntax - (Replace s1 s2) -> isIndexedOrFixed' s1 || isIndexedOrFixed' s2 - isIndexedOrFixed' syntax = case syntax of - (Indexed _) -> True - (Fixed _) -> True - _ -> False - isBranchInfo info = case info of - (BranchInfo _ _ _) -> True - (LeafInfo _ _) -> False - isBranchNode :: DiffSummary DiffInfo -> Bool - isBranchNode summary = (case patch summary of - (Insert diffInfo) -> isBranchInfo diffInfo - (Delete diffInfo) -> isBranchInfo diffInfo - (Replace i1 i2) -> isBranchInfo i1 || isBranchInfo i2) - in - case (partition isBranchNode summaries, partition isIndexedOrFixed patches) of - ((branchSummaries, otherSummaries), (branchPatches, otherPatches)) -> - ((() <$) . patch <$> branchSummaries, (() <$) . patch <$> otherSummaries) `shouldBe` ((() <$) <$> branchPatches, (() <$) <$> otherPatches) + describe "DiffInfo" $ do + prop "patches in summaries match the patches in diffs" $ + \a -> let + diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Cost]))) + summaries = diffSummary diff + patches = toList diff + in + case (partition isBranchNode (patch <$> summaries), partition isIndexedOrFixed patches) of + ((branchPatches, otherPatches), (branchDiffPatches, otherDiffPatches)) -> + (() <$ branchPatches, () <$ otherPatches) `shouldBe` (() <$ branchDiffPatches, () <$ otherDiffPatches) + prop "generates one LeafInfo for each child in an arbitrary branch patch" $ + \a -> let + diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category]))) + diffInfoPatches = patch <$> diffSummary diff + syntaxPatches = toList diff + extractLeaves :: DiffInfo -> [DiffInfo] + extractLeaves (BranchInfo children _ _) = join $ extractLeaves <$> children + extractLeaves leaf = [ leaf ] + + extractDiffLeaves :: Term Text (Record '[Category]) -> [ Term Text (Record '[Category]) ] + extractDiffLeaves term = case unwrap term of + (Indexed children) -> join $ extractDiffLeaves <$> children + (Fixed children) -> join $ extractDiffLeaves <$> children + Commented children leaf -> join $ extractDiffLeaves <$> children <> maybeToList leaf + _ -> [ term ] + in + case (partition isBranchNode diffInfoPatches, partition isIndexedOrFixed syntaxPatches) of + ((branchPatches, _), (diffPatches, _)) -> + let listOfLeaves = foldMap extractLeaves (join $ toList <$> branchPatches) + listOfDiffLeaves = foldMap extractDiffLeaves (join $ toList <$> diffPatches) + in + length listOfLeaves `shouldBe` length listOfDiffLeaves + + -- partitions arbitrary diff infos ([BranchInfo], [LeafInfo]) + -- partitions arbitrary patches ([Fixed/Indexed], [Other]) + -- Map [BranchInfo] -> [LeafInfo] + -- Map [Fixed/Indexed] -> [Children != Fixed/Indexed] + -- length [Children != Fixed/Indexed] == length [LeafInfo] + +isIndexedOrFixed :: Patch (Term a annotation) -> Bool +isIndexedOrFixed patch = case unwrap <$> patch of + (Insert syntax) -> isIndexedOrFixed' syntax + (Delete syntax) -> isIndexedOrFixed' syntax + (Replace s1 s2) -> isIndexedOrFixed' s1 || isIndexedOrFixed' s2 +isIndexedOrFixed' syntax = case syntax of + (Indexed _) -> True + (Fixed _) -> True + _ -> False +isBranchInfo info = case info of + (BranchInfo _ _ _) -> True + (LeafInfo _ _) -> False +isBranchNode :: Patch DiffInfo -> Bool +isBranchNode patch = case patch of + (Insert diffInfo) -> isBranchInfo diffInfo + (Delete diffInfo) -> isBranchInfo diffInfo + (Replace i1 i2) -> isBranchInfo i1 || isBranchInfo i2 \ No newline at end of file From 22eccb20e7b844dab6f1088285090492407b82f1 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 15 Jul 2016 14:11:16 -0400 Subject: [PATCH 010/320] unpin text-icu --- vendor/text-icu | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/text-icu b/vendor/text-icu index 29f115a1d..6d07c2b20 160000 --- a/vendor/text-icu +++ b/vendor/text-icu @@ -1 +1 @@ -Subproject commit 29f115a1d0cb39b4c2f615d30579955eaa5bb855 +Subproject commit 6d07c2b2034f2bfdcd038de0d6a3ceca445f0221 From ed2f8bd57d03d1e9e178846fa7452409844b8abe Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 15 Jul 2016 15:24:40 -0400 Subject: [PATCH 011/320] Delete comments --- test/DiffSummarySpec.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index add67b280..347f7aedd 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -75,12 +75,6 @@ spec = parallel $ do in length listOfLeaves `shouldBe` length listOfDiffLeaves - -- partitions arbitrary diff infos ([BranchInfo], [LeafInfo]) - -- partitions arbitrary patches ([Fixed/Indexed], [Other]) - -- Map [BranchInfo] -> [LeafInfo] - -- Map [Fixed/Indexed] -> [Children != Fixed/Indexed] - -- length [Children != Fixed/Indexed] == length [LeafInfo] - isIndexedOrFixed :: Patch (Term a annotation) -> Bool isIndexedOrFixed patch = case unwrap <$> patch of (Insert syntax) -> isIndexedOrFixed' syntax From ac36cf5bccba0302a61af41100c925a5078fb80b Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 15 Jul 2016 17:06:41 -0400 Subject: [PATCH 012/320] Pretty print diff summaries as lists of LeafInfo Docs --- src/DiffSummary.hs | 36 ++++++++++++++++++++++++------------ src/Renderer/Summary.hs | 7 ++++--- 2 files changed, 28 insertions(+), 15 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 81042ca37..8ff19c2d4 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds, TypeFamilies, ScopedTypeVariables #-} -module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..)) where +module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..), annotatedSummaries) where import Prologue hiding (snd, intercalate) import Diff @@ -15,7 +15,7 @@ import Data.Text as Text (intercalate) import Test.QuickCheck hiding (Fixed) import Patch.Arbitrary() import Data.Record -import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string) +import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string, Doc, punctuate, pretty) import qualified Text.PrettyPrint.Leijen.Text as P import Data.Hashable @@ -122,16 +122,28 @@ instance (Eq a, Arbitrary a) => Arbitrary (DiffSummary a) where arbitrary = DiffSummary <$> arbitrary <*> arbitrary shrink = genericShrink -instance P.Pretty (DiffSummary DiffInfo) where - pretty DiffSummary{..} = case patch of - Insert diffInfo -> "Added the" <+> squotes (toDoc $ termName diffInfo) <+> (toDoc $ categoryName diffInfo) P.<> maybeParentContext parentAnnotations - Delete diffInfo -> "Deleted the" <+> squotes (toDoc $ termName diffInfo) <+> (toDoc $ categoryName diffInfo) P.<> maybeParentContext parentAnnotations - Replace t1 t2 -> "Replaced the" <+> squotes (toDoc $ termName t1) <+> (toDoc $ categoryName t1) <+> "with the" <+> P.squotes (toDoc $ termName t2) <+> (toDoc $ categoryName t2) P.<> maybeParentContext parentAnnotations - where - maybeParentContext annotations = if null annotations - then "" - else space <> "in the" <+> (toDoc . intercalate "/" $ toCategoryName <$> annotations) <+> "context" - toDoc = string . toS +instance P.Pretty DiffInfo where + pretty LeafInfo{..} = squotes (string $ toSL termName) <+> (string $ toSL categoryName) + pretty BranchInfo{..} = mconcat $ punctuate (string "," <> space) (pretty <$> branches) + +annotatedSummaries :: DiffSummary DiffInfo -> [Text] +annotatedSummaries DiffSummary{..} = show . (P.<> maybeParentContext parentAnnotations) <$> summaries patch + +summaries :: Patch DiffInfo -> [P.Doc] +summaries (Insert info) = (("Added" <+> "the") <+>) <$> toLeafInfos info +summaries (Delete info) = (("Deleted" <+> "the") <+>) <$> toLeafInfos info +summaries (Replace i1 i2) = zipWith (\a b -> "Replaced" <+> "the" <+> a <+> "with the" <+> b) (toLeafInfos i1) (toLeafInfos i2) + +toLeafInfos :: DiffInfo -> [Doc] +toLeafInfos LeafInfo{..} = [ squotes (toDoc termName) <+> (toDoc categoryName) ] +toLeafInfos BranchInfo{..} = pretty <$> branches + +maybeParentContext :: [Category] -> Doc +maybeParentContext annotations = if null annotations + then "" + else space <> "in the" <+> (toDoc . intercalate "/" $ toCategoryName <$> annotations) <+> "context" +toDoc :: Text -> Doc +toDoc = string . toS diffSummary :: (HasCategory leaf, HasField fields Category) => Diff leaf (Record fields) -> [DiffSummary DiffInfo] diffSummary = cata $ \case diff --git a/src/Renderer/Summary.hs b/src/Renderer/Summary.hs index 4536e9d2c..c48bee36e 100644 --- a/src/Renderer/Summary.hs +++ b/src/Renderer/Summary.hs @@ -4,8 +4,9 @@ import Prologue import Renderer import DiffSummary import Data.Aeson -import Data.Text (pack) -import Text.PrettyPrint.Leijen.Text (pretty) summary :: Renderer -summary diff _ = toS . encode $ pack . show . pretty <$> diffSummary diff +summary diff _ = toS . encode $ annotatedTexts + where summaries = diffSummary diff + annotatedTexts :: [Text] + annotatedTexts = join $ annotatedSummaries <$> summaries From 78bb7779a4f14b92785944b15ae112ae4a37fcef Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 15 Jul 2016 17:11:45 -0400 Subject: [PATCH 013/320] Test annotatedSummaries --- test/DiffSummarySpec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 347f7aedd..045953e9b 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -39,9 +39,9 @@ spec = parallel $ do diffSummary testDiff `shouldBe` [ DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnotations = [ ArrayLiteral ] } ] describe "show" $ do it "should print adds" $ - show (pretty testSummary) `shouldBe` ("Added the 'a' string" :: Text) + annotatedSummaries testSummary `shouldBe` ["Added the 'a' string"] it "prints a replacement" $ do - show (pretty replacementSummary) `shouldBe` ("Replaced the 'a' string with the 'b' symbol in the array context" :: Text) + annotatedSummaries replacementSummary `shouldBe` ["Replaced the 'a' string with the 'b' symbol in the array context"] describe "DiffInfo" $ do prop "patches in summaries match the patches in diffs" $ \a -> let From a4851ba06367537f82592ec91d7328f1970a9442 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 15 Jul 2016 20:32:48 -0400 Subject: [PATCH 014/320] type signatures --- test/DiffSummarySpec.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 045953e9b..725292bf5 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -80,13 +80,18 @@ isIndexedOrFixed patch = case unwrap <$> patch of (Insert syntax) -> isIndexedOrFixed' syntax (Delete syntax) -> isIndexedOrFixed' syntax (Replace s1 s2) -> isIndexedOrFixed' s1 || isIndexedOrFixed' s2 + +isIndexedOrFixed' :: Syntax a f -> Bool isIndexedOrFixed' syntax = case syntax of (Indexed _) -> True (Fixed _) -> True _ -> False + +isBranchInfo :: DiffInfo -> Bool isBranchInfo info = case info of (BranchInfo _ _ _) -> True (LeafInfo _ _) -> False + isBranchNode :: Patch DiffInfo -> Bool isBranchNode patch = case patch of (Insert diffInfo) -> isBranchInfo diffInfo From ad4d36f7fd385036540b96e6f2a0e8c4ca0efc28 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sun, 17 Jul 2016 11:18:31 -0400 Subject: [PATCH 015/320] Add a CoArbitrary instance to Category --- semantic-diff.cabal | 1 + src/Category.hs | 10 ++++++++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index f762da7e6..84123584d 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -76,6 +76,7 @@ library , comonad , protolude , wl-pprint-text + , quickcheck-instances default-language: Haskell2010 default-extensions: DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards, LambdaCase ghc-options: -Wall -fno-warn-name-shadowing -O2 -threaded -fprof-auto "-with-rtsopts=-N -p -s -h -i0.1" -j diff --git a/src/Category.hs b/src/Category.hs index 9e9bad4eb..8d500f2dc 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -3,6 +3,8 @@ module Category where import Prologue import Data.Hashable import Test.QuickCheck (oneof, Arbitrary, arbitrary, shrink) +import Test.QuickCheck.Arbitrary +import Data.Text (unpack) import Data.Text.Arbitrary() -- | A standardized category of AST node. Used to determine the semantics for @@ -72,14 +74,18 @@ data Category | Other Text deriving (Eq, Generic, Ord, Show) - -- Instances instance Hashable Category +instance CoArbitrary Text where + coarbitrary = coarbitrary . unpack +instance CoArbitrary Category where + coarbitrary = genericCoarbitrary + instance Arbitrary Category where arbitrary = oneof [ - pure Program + pure Program , pure Error , pure Boolean , pure BinaryOperator From bd985202ee176d9d23840610c14405d68a3e5708 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sun, 17 Jul 2016 11:18:45 -0400 Subject: [PATCH 016/320] Add an error case to Objects --- src/Parser.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Parser.hs b/src/Parser.hs index f2402a253..1d72e4131 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -81,7 +81,9 @@ termConstructor source info = cofree . construct toTuple child | S.Indexed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)] toTuple child | S.Fixed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)] toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)] + toTuple _ = [cofree (extract child :< S.Error S.Comment c)] construct children | isFixed (category info) = withDefaultInfo $ S.Fixed children + construct children | isError (category info) = withDefualtInfo $ S.Error children construct children = withDefaultInfo $ S.Indexed children From 5fe5da65b0b3d80dfc8a63e062fbfbb1fbcfb684 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 22 Jul 2016 14:20:03 -0400 Subject: [PATCH 017/320] Use unwrap --- src/DiffSummary.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 6f15bc75b..332831270 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -144,20 +144,20 @@ diffSummary = cata $ \case (Pure (Replace t1 t2)) -> (\(info1, info2) -> DiffSummary (Replace info1 info2) []) <$> zip (termToDiffInfo t1) (termToDiffInfo t2) termToDiffInfo :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> [DiffInfo] -termToDiffInfo term = case runCofree term of - (_ :< Leaf _) -> [ DiffInfo (toCategoryName term) (toTermName term) ] - (_ :< Indexed children) -> join $ termToDiffInfo <$> children - (_ :< Fixed children) -> join $ termToDiffInfo <$> children - (_ :< Syntax.FunctionCall identifier _) -> [ DiffInfo (toCategoryName term) (toTermName identifier) ] - (_ :< Syntax.Ternary ternaryCondition _) -> [ DiffInfo (toCategoryName term) (toTermName ternaryCondition) ] - (_ :< Syntax.Function identifier _ _) -> [ DiffInfo (toCategoryName term) (maybe "anonymous" toTermName identifier) ] - (_ :< Syntax.Assignment identifier _) -> [ DiffInfo (toCategoryName term) (toTermName identifier) ] - (_ :< Syntax.MathAssignment identifier _) -> [ DiffInfo (toCategoryName term) (toTermName identifier) ] +termToDiffInfo term = case unwrap term of + Leaf _ -> [ DiffInfo (toCategoryName term) (toTermName term) ] + Indexed children -> join $ termToDiffInfo <$> children + Fixed children -> join $ termToDiffInfo <$> children + Syntax.FunctionCall identifier _ -> [ DiffInfo (toCategoryName term) (toTermName identifier) ] + Syntax.Ternary ternaryCondition _ -> [ DiffInfo (toCategoryName term) (toTermName ternaryCondition) ] + Syntax.Function identifier _ _ -> [ DiffInfo (toCategoryName term) (maybe "anonymous" toTermName identifier) ] + Syntax.Assignment identifier _ -> [ DiffInfo (toCategoryName term) (toTermName identifier) ] + Syntax.MathAssignment identifier _ -> [ DiffInfo (toCategoryName term) (toTermName identifier) ] -- Currently we cannot express the operator for an operator production from TreeSitter. Eventually we should be able to -- use the term name of the operator identifier when we have that production value. Until then, I'm using a placeholder value -- to indicate where that value should be when constructing DiffInfos. - (_ :< Syntax.Operator _) -> [DiffInfo (toCategoryName term) "x"] - (_ :< Commented cs leaf) -> join (termToDiffInfo <$> cs) <> maybe [] (\leaf -> [ DiffInfo (toCategoryName term) (toTermName leaf) ]) leaf + Syntax.Operator _ -> [DiffInfo (toCategoryName term) "x"] + Commented cs leaf -> join (termToDiffInfo <$> cs) <> maybe [] (\leaf -> [ DiffInfo (toCategoryName term) (toTermName leaf) ]) leaf _ -> [ DiffInfo (toCategoryName term) (toTermName term) ] prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo From b5119dab1e2556d0296e51335a4fc1245426c83b Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 22 Jul 2016 14:51:08 -0400 Subject: [PATCH 018/320] Include Info --- test/DiffSummarySpec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index cf989d683..297944eae 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -17,6 +17,7 @@ import Diff.Arbitrary import Data.List (partition) import Term.Arbitrary import Interpreter +import Info arrayInfo :: Record '[Category] arrayInfo = ArrayLiteral .: RNil From f53cf8f05ea4cc8232d9c27f97a0499bda5bf2f5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 15:28:47 -0400 Subject: [PATCH 019/320] Stub in a Sequenceable typeclass. --- semantic-diff.cabal | 1 + src/Data/Sequenceable.hs | 6 ++++++ 2 files changed, 7 insertions(+) create mode 100644 src/Data/Sequenceable.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index e82e75a91..07c86e88a 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -21,6 +21,7 @@ library , Data.Functor.Both , Data.RandomWalkSimilarity , Data.Record + , Data.Sequenceable , Data.These.Arbitrary , Diff , Diff.Arbitrary diff --git a/src/Data/Sequenceable.hs b/src/Data/Sequenceable.hs new file mode 100644 index 000000000..cdfa82540 --- /dev/null +++ b/src/Data/Sequenceable.hs @@ -0,0 +1,6 @@ +module Data.Sequenceable where + +import Prologue + +class Sequenceable t where + sequenceAlt :: Alternative f => t (f a) -> f (t a) From a9829e67cd3b7b2a46cba861809c4c146e171cef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 15:29:12 -0400 Subject: [PATCH 020/320] Add a Sequenceable instance over []. --- src/Data/Sequenceable.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Data/Sequenceable.hs b/src/Data/Sequenceable.hs index cdfa82540..2c420578c 100644 --- a/src/Data/Sequenceable.hs +++ b/src/Data/Sequenceable.hs @@ -2,5 +2,14 @@ module Data.Sequenceable where import Prologue +-- Classes + class Sequenceable t where sequenceAlt :: Alternative f => t (f a) -> f (t a) + + +-- Instances + +instance Sequenceable [] where + sequenceAlt (x:xs) = ((:) <$> x <|> pure identity) <*> sequenceAlt xs + sequenceAlt [] = pure [] From 9b322da2be39359f75729620dda4ba5e6454fe9f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 15:30:35 -0400 Subject: [PATCH 021/320] Add a Sequenceable instance over Syntax. --- src/Syntax.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index 1980c7f79..cde872846 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -1,7 +1,8 @@ module Syntax where -import Prologue +import Data.Sequenceable import GHC.Generics +import Prologue import Test.QuickCheck hiding (Fixed) -- | A node in an abstract syntax tree. @@ -38,3 +39,9 @@ instance (Arbitrary leaf, Arbitrary f) => Arbitrary (Syntax leaf f) where arbitrary = sized (syntaxOfSize (`resize` arbitrary) ) shrink = genericShrink + +instance Sequenceable (Syntax leaf) where + sequenceAlt syntax = case syntax of + Leaf a -> pure (Leaf a) + Indexed i -> Indexed <$> sequenceAlt i + Fixed i -> Fixed <$> sequenceAlt i From 22476895c6b5ee195225cf86f541313cb7c9157d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 14:17:45 -0400 Subject: [PATCH 022/320] =?UTF-8?q?Define=20mergeMaybe=E2=80=99s=20algebra?= =?UTF-8?q?=20by=20iteration.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is a restricted class of catamorphism which happens to line up exactly with what we’re doing here. --- src/Diff.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Diff.hs b/src/Diff.hs index 6332e0a73..a023d5da0 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -26,10 +26,9 @@ diffCost = diffSum $ patchSum termSize -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch. mergeMaybe :: (Patch (Term leaf annotation) -> Maybe (Term leaf annotation)) -> Diff leaf annotation -> Maybe (Term leaf annotation) -mergeMaybe transform = cata algebra . fmap transform - where algebra :: FreeF (CofreeF (Syntax leaf) (Both annotation)) (Maybe (Term leaf annotation)) (Maybe (Term leaf annotation)) -> Maybe (Term leaf annotation) - algebra (Pure p) = p - algebra (Free (annotations :< syntax)) = Just . cofree $ Both.fst annotations :< case syntax of +mergeMaybe transform = iter algebra . fmap transform + where algebra :: CofreeF (Syntax leaf) (Both annotation) (Maybe (Term leaf annotation)) -> Maybe (Term leaf annotation) + algebra (annotations :< syntax) = Just . cofree $ Both.fst annotations :< case syntax of Leaf s -> Leaf s Indexed i -> Indexed (catMaybes i) Fixed i -> Fixed (catMaybes i) From dd0e4d890ff7b69d12ba32d1f6a5d56e7d405c1e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 15:32:11 -0400 Subject: [PATCH 023/320] =?UTF-8?q?Define=20mergeMaybe=E2=80=99s=20algebra?= =?UTF-8?q?=20using=20sequenceAlt.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Diff.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Diff.hs b/src/Diff.hs index a023d5da0..7587f08da 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -5,6 +5,7 @@ module Diff where import Prologue import Data.Functor.Foldable as Foldable import Data.Functor.Both as Both +import Data.Sequenceable import Patch import Syntax import Term @@ -28,10 +29,7 @@ diffCost = diffSum $ patchSum termSize mergeMaybe :: (Patch (Term leaf annotation) -> Maybe (Term leaf annotation)) -> Diff leaf annotation -> Maybe (Term leaf annotation) mergeMaybe transform = iter algebra . fmap transform where algebra :: CofreeF (Syntax leaf) (Both annotation) (Maybe (Term leaf annotation)) -> Maybe (Term leaf annotation) - algebra (annotations :< syntax) = Just . cofree $ Both.fst annotations :< case syntax of - Leaf s -> Leaf s - Indexed i -> Indexed (catMaybes i) - Fixed i -> Fixed (catMaybes i) + algebra (annotations :< syntax) = cofree . (Both.fst annotations :<) <$> sequenceAlt syntax -- | Recover the before state of a diff. beforeTerm :: Diff leaf annotation -> Maybe (Term leaf annotation) From 808f15d40ecd2504e1be080d85943e9d078475fc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 15:33:01 -0400 Subject: [PATCH 024/320] Stub in a generic Sequenceable module. --- semantic-diff.cabal | 1 + src/Data/Sequenceable/Generic.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Data/Sequenceable/Generic.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 07c86e88a..e69d7ca41 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -22,6 +22,7 @@ library , Data.RandomWalkSimilarity , Data.Record , Data.Sequenceable + , Data.Sequenceable.Generic , Data.These.Arbitrary , Diff , Diff.Arbitrary diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs new file mode 100644 index 000000000..3aea40877 --- /dev/null +++ b/src/Data/Sequenceable/Generic.hs @@ -0,0 +1 @@ +module Data.Sequenceable.Generic where From e93a826f522fe8a9d96e765c40c646a7ad2adab3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 15:34:28 -0400 Subject: [PATCH 025/320] Stub in a GSequenceable typeclass. --- src/Data/Sequenceable/Generic.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index 3aea40877..433c0b7e7 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -1 +1,6 @@ module Data.Sequenceable.Generic where + +import Prologue + +class GSequenceable t where + gsequenceAlt :: Alternative f => t (f a) -> f (t a) From 7203942df202f170c2100dbb6c58aae82e16396a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 15:36:17 -0400 Subject: [PATCH 026/320] Implement GSequenceable over unit constructors. --- src/Data/Sequenceable/Generic.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index 433c0b7e7..8fa3a7830 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -1,6 +1,15 @@ module Data.Sequenceable.Generic where +import GHC.Generics import Prologue +-- Classes + class GSequenceable t where gsequenceAlt :: Alternative f => t (f a) -> f (t a) + + +-- Instances + +instance GSequenceable U1 where + gsequenceAlt _ = pure U1 From 5b36bf150785abe0da464ee00367892470419379 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 15:40:01 -0400 Subject: [PATCH 027/320] Define GSequenceable over Par1. --- src/Data/Sequenceable/Generic.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index 8fa3a7830..777830013 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -13,3 +13,6 @@ class GSequenceable t where instance GSequenceable U1 where gsequenceAlt _ = pure U1 + +instance GSequenceable Par1 where + gsequenceAlt (Par1 a) = Par1 <$> a From ff869ec51737f36aea4f8fffd9d82b92d6f7f1c7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 15:40:05 -0400 Subject: [PATCH 028/320] Define GSequenceable over K1. --- src/Data/Sequenceable/Generic.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index 777830013..7c01b6fd5 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -16,3 +16,6 @@ instance GSequenceable U1 where instance GSequenceable Par1 where gsequenceAlt (Par1 a) = Par1 <$> a + +instance GSequenceable (K1 i c) where + gsequenceAlt (K1 a) = pure (K1 a) From bc5f05494d2b93556910f38b3d2893f912f4a702 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 15:42:31 -0400 Subject: [PATCH 029/320] Define a default implementation of gsequenceAlt. --- src/Data/Sequenceable/Generic.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index 7c01b6fd5..20122614a 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DefaultSignatures #-} module Data.Sequenceable.Generic where import GHC.Generics @@ -7,6 +8,8 @@ import Prologue class GSequenceable t where gsequenceAlt :: Alternative f => t (f a) -> f (t a) + default gsequenceAlt :: (Generic1 t, GSequenceable (Rep1 t), Alternative f) => t (f a) -> f (t a) + gsequenceAlt = fmap to1 . gsequenceAlt . from1 -- Instances From 9a94dddd2b8acdbab7ac38e1cb1b29fd1bff8fce Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 15:57:47 -0400 Subject: [PATCH 030/320] Define GSequenceable over Rec1. --- src/Data/Sequenceable/Generic.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index 20122614a..cc986c3c9 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -22,3 +22,6 @@ instance GSequenceable Par1 where instance GSequenceable (K1 i c) where gsequenceAlt (K1 a) = pure (K1 a) + +instance GSequenceable f => GSequenceable (Rec1 f) where + gsequenceAlt (Rec1 a) = Rec1 <$> gsequenceAlt a From 3913e078f48ff8f4b12fe680260f83eb73b2e052 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 15:58:36 -0400 Subject: [PATCH 031/320] Define GSequenceable over M1. --- src/Data/Sequenceable/Generic.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index cc986c3c9..902671d0e 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -25,3 +25,6 @@ instance GSequenceable (K1 i c) where instance GSequenceable f => GSequenceable (Rec1 f) where gsequenceAlt (Rec1 a) = Rec1 <$> gsequenceAlt a + +instance GSequenceable f => GSequenceable (M1 i c f) where + gsequenceAlt (M1 a) = M1 <$> gsequenceAlt a From 21370a49a00f948810347efe42c279f521ab2682 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:00:01 -0400 Subject: [PATCH 032/320] Define GSequenceable over sums. --- src/Data/Sequenceable/Generic.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index 902671d0e..1f61b09e4 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DefaultSignatures, TypeOperators #-} module Data.Sequenceable.Generic where import GHC.Generics @@ -28,3 +28,7 @@ instance GSequenceable f => GSequenceable (Rec1 f) where instance GSequenceable f => GSequenceable (M1 i c f) where gsequenceAlt (M1 a) = M1 <$> gsequenceAlt a + +instance (GSequenceable f, GSequenceable g) => GSequenceable (f :+: g) where + gsequenceAlt (L1 a) = L1 <$> gsequenceAlt a + gsequenceAlt (R1 b) = R1 <$> gsequenceAlt b From 735f8128cf18d678842d6f84f47bf35c47d43c47 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:01:07 -0400 Subject: [PATCH 033/320] Define GSequenceable over products. --- src/Data/Sequenceable/Generic.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index 1f61b09e4..33b326965 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -32,3 +32,6 @@ instance GSequenceable f => GSequenceable (M1 i c f) where instance (GSequenceable f, GSequenceable g) => GSequenceable (f :+: g) where gsequenceAlt (L1 a) = L1 <$> gsequenceAlt a gsequenceAlt (R1 b) = R1 <$> gsequenceAlt b + +instance (GSequenceable f, GSequenceable g) => GSequenceable (f :*: g) where + gsequenceAlt (a :*: b) = (:*:) <$> gsequenceAlt a <*> gsequenceAlt b From ac6c451ab8a2d89615743b93d62653466c0ad13d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:05:50 -0400 Subject: [PATCH 034/320] Sequenceable implies Functor. --- src/Data/Sequenceable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Sequenceable.hs b/src/Data/Sequenceable.hs index 2c420578c..4527fa5b5 100644 --- a/src/Data/Sequenceable.hs +++ b/src/Data/Sequenceable.hs @@ -4,7 +4,7 @@ import Prologue -- Classes -class Sequenceable t where +class Functor t => Sequenceable t where sequenceAlt :: Alternative f => t (f a) -> f (t a) From ba90fdac88f83a890700278d299fd5cc0f332bf9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:06:29 -0400 Subject: [PATCH 035/320] Define a GSequenceable instance over []. --- src/Data/Sequenceable/Generic.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index 33b326965..2b80e1070 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DefaultSignatures, TypeOperators #-} module Data.Sequenceable.Generic where +import Data.Sequenceable import GHC.Generics import Prologue @@ -35,3 +36,5 @@ instance (GSequenceable f, GSequenceable g) => GSequenceable (f :+: g) where instance (GSequenceable f, GSequenceable g) => GSequenceable (f :*: g) where gsequenceAlt (a :*: b) = (:*:) <$> gsequenceAlt a <*> gsequenceAlt b + +instance GSequenceable [] where gsequenceAlt = sequenceAlt From e780689400801351d5576961d16a09ca44519d0e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:06:52 -0400 Subject: [PATCH 036/320] Syntax is GSequenceable. --- src/Syntax.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Syntax.hs b/src/Syntax.hs index cde872846..ea30d3e38 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -1,6 +1,7 @@ module Syntax where import Data.Sequenceable +import Data.Sequenceable.Generic import GHC.Generics import Prologue import Test.QuickCheck hiding (Fixed) @@ -45,3 +46,5 @@ instance Sequenceable (Syntax leaf) where Leaf a -> pure (Leaf a) Indexed i -> Indexed <$> sequenceAlt i Fixed i -> Fixed <$> sequenceAlt i + +instance GSequenceable (Syntax leaf) From 1ede2d2a231d434db4906a3c3ea06183b7c34470 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:07:07 -0400 Subject: [PATCH 037/320] Syntax uses the generically derived GSequenceable implementation. --- src/Syntax.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index ea30d3e38..fd9bb8d06 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -42,9 +42,6 @@ instance (Arbitrary leaf, Arbitrary f) => Arbitrary (Syntax leaf f) where shrink = genericShrink instance Sequenceable (Syntax leaf) where - sequenceAlt syntax = case syntax of - Leaf a -> pure (Leaf a) - Indexed i -> Indexed <$> sequenceAlt i - Fixed i -> Fixed <$> sequenceAlt i + sequenceAlt = gsequenceAlt instance GSequenceable (Syntax leaf) From 2b81c34d8dcb4df5033976f848e296b65fbe4394 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:08:13 -0400 Subject: [PATCH 038/320] Define a genericSequenceAlt function suitable for Sequenceable definitions. --- src/Data/Sequenceable/Generic.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index 2b80e1070..b7d1a5c9c 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -12,6 +12,9 @@ class GSequenceable t where default gsequenceAlt :: (Generic1 t, GSequenceable (Rep1 t), Alternative f) => t (f a) -> f (t a) gsequenceAlt = fmap to1 . gsequenceAlt . from1 +genericSequenceAlt :: (Generic1 t, GSequenceable (Rep1 t), Alternative f) => t (f a) -> f (t a) +genericSequenceAlt = fmap to1 . gsequenceAlt . from1 + -- Instances From d32652d5eb7f0c20661ea432a7c51603d433c0c4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:09:28 -0400 Subject: [PATCH 039/320] Syntax is Sequenceable via genericSequenceAlt. --- src/Syntax.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index fd9bb8d06..380b04876 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -42,6 +42,4 @@ instance (Arbitrary leaf, Arbitrary f) => Arbitrary (Syntax leaf f) where shrink = genericShrink instance Sequenceable (Syntax leaf) where - sequenceAlt = gsequenceAlt - -instance GSequenceable (Syntax leaf) + sequenceAlt = genericSequenceAlt From 609a90fb9013ec291d480bc85edcab75340c7fc7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:10:31 -0400 Subject: [PATCH 040/320] :fire: the default signature for gsequenceAlt. --- src/Data/Sequenceable/Generic.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index b7d1a5c9c..074e12402 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DefaultSignatures, TypeOperators #-} +{-# LANGUAGE TypeOperators #-} module Data.Sequenceable.Generic where import Data.Sequenceable @@ -9,8 +9,6 @@ import Prologue class GSequenceable t where gsequenceAlt :: Alternative f => t (f a) -> f (t a) - default gsequenceAlt :: (Generic1 t, GSequenceable (Rep1 t), Alternative f) => t (f a) -> f (t a) - gsequenceAlt = fmap to1 . gsequenceAlt . from1 genericSequenceAlt :: (Generic1 t, GSequenceable (Rep1 t), Alternative f) => t (f a) -> f (t a) genericSequenceAlt = fmap to1 . gsequenceAlt . from1 From dabffff7d08fae9637c76142cbdcaa6b781a879d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:13:54 -0400 Subject: [PATCH 041/320] Implement GSequenceable over [] directly. --- src/Data/Sequenceable/Generic.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Sequenceable/Generic.hs index 074e12402..028bf1424 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Sequenceable/Generic.hs @@ -1,7 +1,6 @@ {-# LANGUAGE TypeOperators #-} module Data.Sequenceable.Generic where -import Data.Sequenceable import GHC.Generics import Prologue @@ -38,4 +37,6 @@ instance (GSequenceable f, GSequenceable g) => GSequenceable (f :+: g) where instance (GSequenceable f, GSequenceable g) => GSequenceable (f :*: g) where gsequenceAlt (a :*: b) = (:*:) <$> gsequenceAlt a <*> gsequenceAlt b -instance GSequenceable [] where gsequenceAlt = sequenceAlt +instance GSequenceable [] where + gsequenceAlt (x:xs) = ((:) <$> x <|> pure identity) <*> gsequenceAlt xs + gsequenceAlt [] = pure [] From f959917ae3896a4baa57d3fc0b99e7b143d1bed6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:14:27 -0400 Subject: [PATCH 042/320] Define Sequenceable over [] in terms of GSequenceable over []. --- src/Data/Sequenceable.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Data/Sequenceable.hs b/src/Data/Sequenceable.hs index 4527fa5b5..b20f88901 100644 --- a/src/Data/Sequenceable.hs +++ b/src/Data/Sequenceable.hs @@ -1,5 +1,6 @@ module Data.Sequenceable where +import Data.Sequenceable.Generic import Prologue -- Classes @@ -10,6 +11,4 @@ class Functor t => Sequenceable t where -- Instances -instance Sequenceable [] where - sequenceAlt (x:xs) = ((:) <$> x <|> pure identity) <*> sequenceAlt xs - sequenceAlt [] = pure [] +instance Sequenceable [] where sequenceAlt = gsequenceAlt From f3f8aee39cc03f95d86b3a2cfb1ad38cf8ff40d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:14:44 -0400 Subject: [PATCH 043/320] Add a default signature for Sequenceable. --- src/Data/Sequenceable.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Sequenceable.hs b/src/Data/Sequenceable.hs index b20f88901..b9b24ff68 100644 --- a/src/Data/Sequenceable.hs +++ b/src/Data/Sequenceable.hs @@ -1,12 +1,16 @@ +{-# LANGUAGE DefaultSignatures #-} module Data.Sequenceable where import Data.Sequenceable.Generic +import GHC.Generics import Prologue -- Classes class Functor t => Sequenceable t where sequenceAlt :: Alternative f => t (f a) -> f (t a) + default sequenceAlt :: (Generic1 t, GSequenceable (Rep1 t), Alternative f) => t (f a) -> f (t a) + sequenceAlt = genericSequenceAlt -- Instances From 0b85a1826d1d515a0c61696ee7b1225f0a2e84c8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 16:15:04 -0400 Subject: [PATCH 044/320] Derive the Sequenceable instance over Syntax. --- src/Syntax.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index 380b04876..820e8b5c4 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE DeriveAnyClass #-} module Syntax where import Data.Sequenceable -import Data.Sequenceable.Generic import GHC.Generics import Prologue import Test.QuickCheck hiding (Fixed) @@ -17,7 +17,7 @@ data Syntax | Indexed [f] -- | An ordered branch of child nodes, expected to be of fixed length in the grammar, e.g. a binary operator & its operands. | Fixed [f] - deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable) + deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Sequenceable, Show, Traversable) -- Instances @@ -40,6 +40,3 @@ instance (Arbitrary leaf, Arbitrary f) => Arbitrary (Syntax leaf f) where arbitrary = sized (syntaxOfSize (`resize` arbitrary) ) shrink = genericShrink - -instance Sequenceable (Syntax leaf) where - sequenceAlt = genericSequenceAlt From 9ae7f52e8fa77edd6844470d2be7629a5fd98b91 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 17:38:10 -0400 Subject: [PATCH 045/320] Rename Sequenceable to Mergeable. --- semantic-diff.cabal | 4 ++-- src/Data/Mergeable.hs | 18 +++++++++++++++ .../{Sequenceable => Mergeable}/Generic.hs | 22 +++++++++---------- src/Data/Sequenceable.hs | 18 --------------- src/Diff.hs | 2 +- src/Syntax.hs | 4 ++-- 6 files changed, 34 insertions(+), 34 deletions(-) create mode 100644 src/Data/Mergeable.hs rename src/Data/{Sequenceable => Mergeable}/Generic.hs (54%) delete mode 100644 src/Data/Sequenceable.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index e69d7ca41..f7b43cf5e 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -21,8 +21,8 @@ library , Data.Functor.Both , Data.RandomWalkSimilarity , Data.Record - , Data.Sequenceable - , Data.Sequenceable.Generic + , Data.Mergeable + , Data.Mergeable.Generic , Data.These.Arbitrary , Diff , Diff.Arbitrary diff --git a/src/Data/Mergeable.hs b/src/Data/Mergeable.hs new file mode 100644 index 000000000..283cd2609 --- /dev/null +++ b/src/Data/Mergeable.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DefaultSignatures #-} +module Data.Mergeable where + +import Data.Mergeable.Generic +import GHC.Generics +import Prologue + +-- Classes + +class Functor t => Mergeable t where + sequenceAlt :: Alternative f => t (f a) -> f (t a) + default sequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a) + sequenceAlt = genericSequenceAlt + + +-- Instances + +instance Mergeable [] where sequenceAlt = gsequenceAlt diff --git a/src/Data/Sequenceable/Generic.hs b/src/Data/Mergeable/Generic.hs similarity index 54% rename from src/Data/Sequenceable/Generic.hs rename to src/Data/Mergeable/Generic.hs index 028bf1424..2d4b6e504 100644 --- a/src/Data/Sequenceable/Generic.hs +++ b/src/Data/Mergeable/Generic.hs @@ -1,42 +1,42 @@ {-# LANGUAGE TypeOperators #-} -module Data.Sequenceable.Generic where +module Data.Mergeable.Generic where import GHC.Generics import Prologue -- Classes -class GSequenceable t where +class GMergeable t where gsequenceAlt :: Alternative f => t (f a) -> f (t a) -genericSequenceAlt :: (Generic1 t, GSequenceable (Rep1 t), Alternative f) => t (f a) -> f (t a) +genericSequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a) genericSequenceAlt = fmap to1 . gsequenceAlt . from1 -- Instances -instance GSequenceable U1 where +instance GMergeable U1 where gsequenceAlt _ = pure U1 -instance GSequenceable Par1 where +instance GMergeable Par1 where gsequenceAlt (Par1 a) = Par1 <$> a -instance GSequenceable (K1 i c) where +instance GMergeable (K1 i c) where gsequenceAlt (K1 a) = pure (K1 a) -instance GSequenceable f => GSequenceable (Rec1 f) where +instance GMergeable f => GMergeable (Rec1 f) where gsequenceAlt (Rec1 a) = Rec1 <$> gsequenceAlt a -instance GSequenceable f => GSequenceable (M1 i c f) where +instance GMergeable f => GMergeable (M1 i c f) where gsequenceAlt (M1 a) = M1 <$> gsequenceAlt a -instance (GSequenceable f, GSequenceable g) => GSequenceable (f :+: g) where +instance (GMergeable f, GMergeable g) => GMergeable (f :+: g) where gsequenceAlt (L1 a) = L1 <$> gsequenceAlt a gsequenceAlt (R1 b) = R1 <$> gsequenceAlt b -instance (GSequenceable f, GSequenceable g) => GSequenceable (f :*: g) where +instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where gsequenceAlt (a :*: b) = (:*:) <$> gsequenceAlt a <*> gsequenceAlt b -instance GSequenceable [] where +instance GMergeable [] where gsequenceAlt (x:xs) = ((:) <$> x <|> pure identity) <*> gsequenceAlt xs gsequenceAlt [] = pure [] diff --git a/src/Data/Sequenceable.hs b/src/Data/Sequenceable.hs deleted file mode 100644 index b9b24ff68..000000000 --- a/src/Data/Sequenceable.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -module Data.Sequenceable where - -import Data.Sequenceable.Generic -import GHC.Generics -import Prologue - --- Classes - -class Functor t => Sequenceable t where - sequenceAlt :: Alternative f => t (f a) -> f (t a) - default sequenceAlt :: (Generic1 t, GSequenceable (Rep1 t), Alternative f) => t (f a) -> f (t a) - sequenceAlt = genericSequenceAlt - - --- Instances - -instance Sequenceable [] where sequenceAlt = gsequenceAlt diff --git a/src/Diff.hs b/src/Diff.hs index 7587f08da..ae917010f 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -5,7 +5,7 @@ module Diff where import Prologue import Data.Functor.Foldable as Foldable import Data.Functor.Both as Both -import Data.Sequenceable +import Data.Mergeable import Patch import Syntax import Term diff --git a/src/Syntax.hs b/src/Syntax.hs index 820e8b5c4..d2e1fb45e 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} module Syntax where -import Data.Sequenceable +import Data.Mergeable import GHC.Generics import Prologue import Test.QuickCheck hiding (Fixed) @@ -17,7 +17,7 @@ data Syntax | Indexed [f] -- | An ordered branch of child nodes, expected to be of fixed length in the grammar, e.g. a binary operator & its operands. | Fixed [f] - deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Sequenceable, Show, Traversable) + deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Mergeable, Show, Traversable) -- Instances From 1d7645cafe955972c3a3d54a9b5cdeff029373a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 17:49:07 -0400 Subject: [PATCH 046/320] GMergeable has a gmerge method generalizing gsequenceAlt. --- src/Data/Mergeable.hs | 2 +- src/Data/Mergeable/Generic.hs | 24 ++++++++++++------------ 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Data/Mergeable.hs b/src/Data/Mergeable.hs index 283cd2609..5c48c888c 100644 --- a/src/Data/Mergeable.hs +++ b/src/Data/Mergeable.hs @@ -15,4 +15,4 @@ class Functor t => Mergeable t where -- Instances -instance Mergeable [] where sequenceAlt = gsequenceAlt +instance Mergeable [] where sequenceAlt = gmerge identity diff --git a/src/Data/Mergeable/Generic.hs b/src/Data/Mergeable/Generic.hs index 2d4b6e504..25637d2ef 100644 --- a/src/Data/Mergeable/Generic.hs +++ b/src/Data/Mergeable/Generic.hs @@ -7,36 +7,36 @@ import Prologue -- Classes class GMergeable t where - gsequenceAlt :: Alternative f => t (f a) -> f (t a) + gmerge :: Alternative f => (a -> f b) -> t a -> f (t b) genericSequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a) -genericSequenceAlt = fmap to1 . gsequenceAlt . from1 +genericSequenceAlt = fmap to1 . gmerge identity . from1 -- Instances instance GMergeable U1 where - gsequenceAlt _ = pure U1 + gmerge _ _ = pure U1 instance GMergeable Par1 where - gsequenceAlt (Par1 a) = Par1 <$> a + gmerge f (Par1 a) = Par1 <$> f a instance GMergeable (K1 i c) where - gsequenceAlt (K1 a) = pure (K1 a) + gmerge _ (K1 a) = pure (K1 a) instance GMergeable f => GMergeable (Rec1 f) where - gsequenceAlt (Rec1 a) = Rec1 <$> gsequenceAlt a + gmerge f (Rec1 a) = Rec1 <$> gmerge f a instance GMergeable f => GMergeable (M1 i c f) where - gsequenceAlt (M1 a) = M1 <$> gsequenceAlt a + gmerge f (M1 a) = M1 <$> gmerge f a instance (GMergeable f, GMergeable g) => GMergeable (f :+: g) where - gsequenceAlt (L1 a) = L1 <$> gsequenceAlt a - gsequenceAlt (R1 b) = R1 <$> gsequenceAlt b + gmerge f (L1 a) = L1 <$> gmerge f a + gmerge f (R1 b) = R1 <$> gmerge f b instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where - gsequenceAlt (a :*: b) = (:*:) <$> gsequenceAlt a <*> gsequenceAlt b + gmerge f (a :*: b) = (:*:) <$> gmerge f a <*> gmerge f b instance GMergeable [] where - gsequenceAlt (x:xs) = ((:) <$> x <|> pure identity) <*> gsequenceAlt xs - gsequenceAlt [] = pure [] + gmerge f (x:xs) = ((:) <$> f x <|> pure identity) <*> gmerge f xs + gmerge _ [] = pure [] From 8f8bf5dad9a551ffc64f1ea7b91ef9adaad7a756 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 17:50:08 -0400 Subject: [PATCH 047/320] Define a genericMerge helper. --- src/Data/Mergeable/Generic.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Mergeable/Generic.hs b/src/Data/Mergeable/Generic.hs index 25637d2ef..ab1dcb5e1 100644 --- a/src/Data/Mergeable/Generic.hs +++ b/src/Data/Mergeable/Generic.hs @@ -9,6 +9,9 @@ import Prologue class GMergeable t where gmerge :: Alternative f => (a -> f b) -> t a -> f (t b) +genericMerge :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => (a -> f b) -> t a -> f (t b) +genericMerge f = fmap to1 . gmerge f . from1 + genericSequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a) genericSequenceAlt = fmap to1 . gmerge identity . from1 From afd67dbbd9030e5fedd50f587da7018f1701ba3d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 17:51:57 -0400 Subject: [PATCH 048/320] Define a merge method in Mergeable which generalizes sequenceAlt. --- src/Data/Mergeable.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Mergeable.hs b/src/Data/Mergeable.hs index 5c48c888c..ed3cd7627 100644 --- a/src/Data/Mergeable.hs +++ b/src/Data/Mergeable.hs @@ -8,6 +8,10 @@ import Prologue -- Classes class Functor t => Mergeable t where + merge :: Alternative f => (a -> f b) -> t a -> f (t b) + default merge :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => (a -> f b) -> t a -> f (t b) + merge = genericMerge + sequenceAlt :: Alternative f => t (f a) -> f (t a) default sequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a) sequenceAlt = genericSequenceAlt From 5c25157593d5bb4b28d46b682d4f5ff24edd3417 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 17:52:30 -0400 Subject: [PATCH 049/320] sequenceAlt defaults to merge identity. --- src/Data/Mergeable.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Mergeable.hs b/src/Data/Mergeable.hs index ed3cd7627..59a7aed4e 100644 --- a/src/Data/Mergeable.hs +++ b/src/Data/Mergeable.hs @@ -13,8 +13,7 @@ class Functor t => Mergeable t where merge = genericMerge sequenceAlt :: Alternative f => t (f a) -> f (t a) - default sequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a) - sequenceAlt = genericSequenceAlt + sequenceAlt = merge identity -- Instances From 698e829e03711a4f164a96f6b8833555a62c1ee4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 17:53:24 -0400 Subject: [PATCH 050/320] Define the Mergeable instance over [] in terms of merge/gmerge. --- src/Data/Mergeable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Mergeable.hs b/src/Data/Mergeable.hs index 59a7aed4e..02fbe7353 100644 --- a/src/Data/Mergeable.hs +++ b/src/Data/Mergeable.hs @@ -18,4 +18,4 @@ class Functor t => Mergeable t where -- Instances -instance Mergeable [] where sequenceAlt = gmerge identity +instance Mergeable [] where merge = gmerge From 054413b47e4b2ec7d3cc1f7706d6c8646f33dd5c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 17:53:59 -0400 Subject: [PATCH 051/320] :fire: genericSequenceAlt. --- src/Data/Mergeable/Generic.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Data/Mergeable/Generic.hs b/src/Data/Mergeable/Generic.hs index ab1dcb5e1..2940c3e23 100644 --- a/src/Data/Mergeable/Generic.hs +++ b/src/Data/Mergeable/Generic.hs @@ -12,9 +12,6 @@ class GMergeable t where genericMerge :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => (a -> f b) -> t a -> f (t b) genericMerge f = fmap to1 . gmerge f . from1 -genericSequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a) -genericSequenceAlt = fmap to1 . gmerge identity . from1 - -- Instances From 49ac4fea8ce32fe17dfdd44d740a42cf5e451fd4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 18:00:56 -0400 Subject: [PATCH 052/320] Add a rewrite rule for merge identity. --- src/Data/Mergeable.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Mergeable.hs b/src/Data/Mergeable.hs index 02fbe7353..8a9070067 100644 --- a/src/Data/Mergeable.hs +++ b/src/Data/Mergeable.hs @@ -15,6 +15,10 @@ class Functor t => Mergeable t where sequenceAlt :: Alternative f => t (f a) -> f (t a) sequenceAlt = merge identity +{-# RULES +"merge identity" merge identity = sequenceAlt + #-} + -- Instances From a495f143aa704b0a33cef64c95ac58ac5354fe32 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 18:42:31 -0400 Subject: [PATCH 053/320] Align leaves and comments through alignBranch. --- src/Alignment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Alignment.hs b/src/Alignment.hs index 6745ee8cf..868ba0250 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -62,8 +62,8 @@ alignPatch sources patch = case patch of -- | The Applicative instance f is either Identity or Both. Identity is for Terms in Patches, Both is for Diffs in unchanged portions of the diff. alignSyntax :: (Applicative f, HasField fields Range) => (forall a. f a -> Join These a) -> (CofreeF (Syntax leaf) (Record fields) term -> term) -> (term -> Range) -> f (Source Char) -> CofreeF (Syntax leaf) (f (Record fields)) [Join These term] -> [Join These term] alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = case syntax of - Leaf s -> catMaybes $ wrapInBranch (const (Leaf s)) . fmap (flip (,) []) <$> (Join <$> bisequenceL (runJoin lineRanges)) - Comment a -> catMaybes $ wrapInBranch (const (Comment a)) . fmap (flip (,) []) <$> (Join <$> bisequenceL (runJoin lineRanges)) + Leaf s -> catMaybes $ wrapInBranch (const (Leaf s)) <$> alignBranch getRange [] bothRanges + Comment a -> catMaybes $ wrapInBranch (const (Comment a)) <$> alignBranch getRange [] bothRanges Indexed children -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges Syntax.Function id params body -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (fromMaybe [] id <> fromMaybe [] params <> body) bothRanges From b95cadd9a8478de489a9a93f915be00c07d8fb6b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Jul 2016 18:43:16 -0400 Subject: [PATCH 054/320] Factor catMaybes out of the alignment cases. --- src/Alignment.hs | 44 ++++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/src/Alignment.hs b/src/Alignment.hs index 868ba0250..a71310da0 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -61,40 +61,40 @@ alignPatch sources patch = case patch of -- | The Applicative instance f is either Identity or Both. Identity is for Terms in Patches, Both is for Diffs in unchanged portions of the diff. alignSyntax :: (Applicative f, HasField fields Range) => (forall a. f a -> Join These a) -> (CofreeF (Syntax leaf) (Record fields) term -> term) -> (term -> Range) -> f (Source Char) -> CofreeF (Syntax leaf) (f (Record fields)) [Join These term] -> [Join These term] -alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = case syntax of - Leaf s -> catMaybes $ wrapInBranch (const (Leaf s)) <$> alignBranch getRange [] bothRanges - Comment a -> catMaybes $ wrapInBranch (const (Comment a)) <$> alignBranch getRange [] bothRanges +alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = catMaybes $ case syntax of + Leaf s -> wrapInBranch (const (Leaf s)) <$> alignBranch getRange [] bothRanges + Comment a -> wrapInBranch (const (Comment a)) <$> alignBranch getRange [] bothRanges Indexed children -> - catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges - Syntax.Function id params body -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (fromMaybe [] id <> fromMaybe [] params <> body) bothRanges + wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges + Syntax.Function id params body -> wrapInBranch Indexed <$> alignBranch getRange (fromMaybe [] id <> fromMaybe [] params <> body) bothRanges -- Align FunctionCalls like Indexed nodes by appending identifier to its children. Syntax.FunctionCall identifier children -> - catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join (identifier : children)) bothRanges + wrapInBranch Indexed <$> alignBranch getRange (join (identifier : children)) bothRanges Syntax.Assignment assignmentId value -> - catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (assignmentId <> value) bothRanges + wrapInBranch Indexed <$> alignBranch getRange (assignmentId <> value) bothRanges Syntax.MemberAccess memberId property -> - catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (memberId <> property) bothRanges + wrapInBranch Indexed <$> alignBranch getRange (memberId <> property) bothRanges Syntax.MethodCall targetId methodId args -> - catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (targetId <> methodId <> args) bothRanges + wrapInBranch Indexed <$> alignBranch getRange (targetId <> methodId <> args) bothRanges Syntax.Args children -> - catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges + wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges Syntax.VarDecl decl -> - catMaybes $ wrapInBranch Indexed <$> alignBranch getRange decl bothRanges + wrapInBranch Indexed <$> alignBranch getRange decl bothRanges Syntax.VarAssignment id value -> - catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (id <> value) bothRanges + wrapInBranch Indexed <$> alignBranch getRange (id <> value) bothRanges Switch expr cases -> - catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (expr <> join cases) bothRanges + wrapInBranch Indexed <$> alignBranch getRange (expr <> join cases) bothRanges Case expr body -> - catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (expr <> body) bothRanges + wrapInBranch Indexed <$> alignBranch getRange (expr <> body) bothRanges Fixed children -> - catMaybes $ wrapInBranch Fixed <$> alignBranch getRange (join children) bothRanges - Pair a b -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (a <> b) bothRanges - Object children -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges - Commented cs expr -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join cs <> join (maybeToList expr)) bothRanges - Ternary expr cases -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (expr <> join cases) bothRanges - Operator cases -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join cases) bothRanges - MathAssignment key value -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (key <> value) bothRanges - SubscriptAccess key value -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (key <> value) bothRanges + wrapInBranch Fixed <$> alignBranch getRange (join children) bothRanges + Pair a b -> wrapInBranch Indexed <$> alignBranch getRange (a <> b) bothRanges + Object children -> wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges + Commented cs expr -> wrapInBranch Indexed <$> alignBranch getRange (join cs <> join (maybeToList expr)) bothRanges + Ternary expr cases -> wrapInBranch Indexed <$> alignBranch getRange (expr <> join cases) bothRanges + Operator cases -> wrapInBranch Indexed <$> alignBranch getRange (join cases) bothRanges + MathAssignment key value -> wrapInBranch Indexed <$> alignBranch getRange (key <> value) bothRanges + SubscriptAccess key value -> wrapInBranch Indexed <$> alignBranch getRange (key <> value) bothRanges where bothRanges = modifyJoin (fromThese [] []) lineRanges lineRanges = toJoinThese $ actualLineRanges <$> (characterRange <$> infos) <*> sources wrapInBranch constructor = applyThese $ toJoinThese ((\ info (range, children) -> toNode (setCharacterRange info range :< constructor children)) <$> infos) From c7bdc8cd5b06b5848377c3353c8df58b343b2931 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 12:31:22 -0400 Subject: [PATCH 055/320] let it breathe --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index f43bc8f91..1e0e2a6a7 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds, TypeFamilies, ScopedTypeVariables #-} + module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..), annotatedSummaries) where import Prologue hiding (snd, intercalate) From abacae0cc039a3a3690414c6799f5cf08230c448 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 12:35:22 -0400 Subject: [PATCH 056/320] redundant imports --- src/DiffSummary.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 1e0e2a6a7..1e3d9133b 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -7,7 +7,7 @@ import Prologue hiding (snd, intercalate) import Diff import Patch import Term -import Info (category, Cost) +import Info (category) import Syntax import Category import Data.Functor.Foldable as Foldable @@ -18,7 +18,6 @@ import Patch.Arbitrary() import Data.Record import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string, Doc, punctuate, pretty) import qualified Text.PrettyPrint.Leijen.Text as P -import Data.Hashable data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text } | BranchInfo { branches :: [ DiffInfo ], categoryName :: Text, branchType :: Branch } From 1197d46d314bd6916bc13951eec381086ee7af0e Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 13:34:38 -0400 Subject: [PATCH 057/320] Remove megaparsec --- semantic-diff.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 6827745b4..7f0d8dce1 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -126,7 +126,6 @@ test-suite semantic-diff-test , free , recursion-schemes >= 4.1 , wl-pprint-text - , megaparsec if os(darwin) ghc-options: -threaded -rtsopts -with-rtsopts=-N -j else From 88b0cc327a326186dbfcf605951160b2bc1badc8 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 13:35:52 -0400 Subject: [PATCH 058/320] Remove Categorizable newtype and HasFiel instance --- src/DiffSummary.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 1e3d9133b..2ed418747 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -67,10 +67,6 @@ class HasCategory a where instance HasCategory Text where toCategoryName = identity -newtype Categorizable a = Categorizable a -instance (HasField fields Category) => HasCategory (Categorizable (Record fields)) where - toCategoryName (Categorizable a)= toCategoryName $ category a - instance HasCategory Category where toCategoryName = \case ArrayLiteral -> "array" From a6ea8f44d8ceead40e9e40a52b3f66c2e2c53fd7 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 14:55:30 -0400 Subject: [PATCH 059/320] Add Error syntax cases to DiffSummary --- src/DiffSummary.hs | 145 +++++++++++++++++++++++---------------------- 1 file changed, 73 insertions(+), 72 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 1e3d9133b..9bce68607 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -8,8 +8,8 @@ import Diff import Patch import Term import Info (category) -import Syntax -import Category +import Syntax as S +import Category as C import Data.Functor.Foldable as Foldable import Data.Functor.Both import Data.Text as Text (intercalate) @@ -25,40 +25,40 @@ data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text } toTermName :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> Text toTermName term = case unwrap term of - Syntax.Fixed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children - Syntax.Indexed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children + S.Fixed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children + S.Indexed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children Leaf leaf -> toCategoryName leaf - Syntax.Assignment identifier value -> toTermName identifier <> toTermName value - Syntax.Function identifier _ _ -> (maybe "anonymous" toTermName identifier) - Syntax.FunctionCall i _ -> toTermName i - Syntax.MemberAccess base property -> case (unwrap base, unwrap property) of - (Syntax.FunctionCall{}, Syntax.FunctionCall{}) -> toTermName base <> "()." <> toTermName property <> "()" - (Syntax.FunctionCall{}, _) -> toTermName base <> "()." <> toTermName property - (_, Syntax.FunctionCall{}) -> toTermName base <> "." <> toTermName property <> "()" + S.Assignment identifier value -> toTermName identifier <> toTermName value + S.Function identifier _ _ -> (maybe "anonymous" toTermName identifier) + S.FunctionCall i _ -> toTermName i + S.MemberAccess base property -> case (unwrap base, unwrap property) of + (S.FunctionCall{}, S.FunctionCall{}) -> toTermName base <> "()." <> toTermName property <> "()" + (S.FunctionCall{}, _) -> toTermName base <> "()." <> toTermName property + (_, S.FunctionCall{}) -> toTermName base <> "." <> toTermName property <> "()" (_, _) -> toTermName base <> "." <> toTermName property - Syntax.MethodCall targetId methodId _ -> toTermName targetId <> sep <> toTermName methodId <> "()" + S.MethodCall targetId methodId _ -> toTermName targetId <> sep <> toTermName methodId <> "()" where sep = case unwrap targetId of - Syntax.FunctionCall{} -> "()." + S.FunctionCall{} -> "()." _ -> "." - Syntax.SubscriptAccess base element -> case (unwrap base, unwrap element) of - (Syntax.FunctionCall{}, Syntax.FunctionCall{}) -> toTermName base <> "()." <> toTermName element <> "()" - (Syntax.FunctionCall{}, _) -> toTermName base <> "()." <> toTermName element - (_, Syntax.FunctionCall{}) -> toTermName base <> "[" <> toTermName element <> "()" <> "]" + S.SubscriptAccess base element -> case (unwrap base, unwrap element) of + (S.FunctionCall{}, S.FunctionCall{}) -> toTermName base <> "()." <> toTermName element <> "()" + (S.FunctionCall{}, _) -> toTermName base <> "()." <> toTermName element + (_, S.FunctionCall{}) -> toTermName base <> "[" <> toTermName element <> "()" <> "]" (_, _) -> toTermName base <> "[" <> toTermName element <> "]" - Syntax.VarAssignment varId _ -> toTermName varId - Syntax.VarDecl decl -> toTermName decl + S.VarAssignment varId _ -> toTermName varId + S.VarDecl decl -> toTermName decl -- TODO: We should remove Args from Syntax since I don't think we should ever -- evaluate Args as a single toTermName Text - joshvera - Syntax.Args args -> mconcat $ toTermName <$> args + S.Args args -> mconcat $ toTermName <$> args -- TODO: We should remove Case from Syntax since I don't think we should ever -- evaluate Case as a single toTermName Text - joshvera - Syntax.Case expr _ -> toTermName expr - Syntax.Switch expr _ -> toTermName expr - Syntax.Ternary expr _ -> toTermName expr - Syntax.MathAssignment id _ -> toTermName id - Syntax.Operator syntaxes -> mconcat $ toTermName <$> syntaxes - Syntax.Object kvs -> "{" <> intercalate ", " (toTermName <$> kvs) <> "}" - Syntax.Pair a b -> toTermName a <> ": " <> toTermName b + S.Case expr _ -> toTermName expr + S.Switch expr _ -> toTermName expr + S.Ternary expr _ -> toTermName expr + S.MathAssignment id _ -> toTermName id + S.Operator syntaxes -> mconcat $ toTermName <$> syntaxes + S.Object kvs -> "{" <> intercalate ", " (toTermName <$> kvs) <> "}" + S.Pair a b -> toTermName a <> ": " <> toTermName b Comment a -> toCategoryName a class HasCategory a where @@ -77,33 +77,33 @@ instance HasCategory Category where BinaryOperator -> "binary operator" Boolean -> "boolean" DictionaryLiteral -> "dictionary" - Error -> "error" + C.Error -> "error" ExpressionStatements -> "expression statements" - Category.Assignment -> "assignment" - Category.Function -> "function" - Category.FunctionCall -> "function call" - Category.MemberAccess -> "member access" - Category.MethodCall -> "method call" - Category.Args -> "arguments" - Category.VarAssignment -> "var assignment" - Category.VarDecl -> "variable" - Category.Switch -> "switch statement" - Category.Case -> "case statement" - Category.SubscriptAccess -> "subscript access" - Category.MathAssignment -> "math assignment" - Category.Ternary -> "ternary" - Category.Operator -> "operator" + C.Assignment -> "assignment" + C.Function -> "function" + C.FunctionCall -> "function call" + C.MemberAccess -> "member access" + C.MethodCall -> "method call" + C.Args -> "arguments" + C.VarAssignment -> "var assignment" + C.VarDecl -> "variable" + C.Switch -> "switch statement" + C.Case -> "case statement" + C.SubscriptAccess -> "subscript access" + C.MathAssignment -> "math assignment" + C.Ternary -> "ternary" + C.Operator -> "operator" Identifier -> "identifier" IntegerLiteral -> "integer" Other s -> s - Category.Pair -> "pair" + C.Pair -> "pair" Params -> "params" Program -> "top level" Regex -> "regex" StringLiteral -> "string" SymbolLiteral -> "symbol" TemplateString -> "template string" - Category.Object -> "object" + C.Object -> "object" instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract @@ -149,26 +149,27 @@ diffSummary :: (HasCategory leaf, HasField fields Category) => Diff leaf (Record diffSummary = cata $ \case -- Skip comments and leaves since they don't have any changes (Free (_ :< Leaf _)) -> [] - Free (_ :< (Syntax.Comment _)) -> [] - (Free (infos :< Syntax.Indexed children)) -> prependSummary (category $ snd infos) <$> join children - (Free (infos :< Syntax.Fixed children)) -> prependSummary (category $ snd infos) <$> join children - (Free (infos :< Syntax.FunctionCall identifier children)) -> prependSummary (category $ snd infos) <$> join (Prologue.toList (identifier : children)) - (Free (infos :< Syntax.Function id ps body)) -> prependSummary (category $ snd infos) <$> (fromMaybe [] id) <> (fromMaybe [] ps) <> body - (Free (infos :< Syntax.Assignment id value)) -> prependSummary (category $ snd infos) <$> id <> value - (Free (infos :< Syntax.MemberAccess base property)) -> prependSummary (category $ snd infos) <$> base <> property - (Free (infos :< Syntax.SubscriptAccess base property)) -> prependSummary (category $ snd infos) <$> base <> property - (Free (infos :< Syntax.MethodCall targetId methodId ps)) -> prependSummary (category $ snd infos) <$> targetId <> methodId <> ps - (Free (infos :< Syntax.VarAssignment varId value)) -> prependSummary (category $ snd infos) <$> varId <> value - (Free (infos :< Syntax.VarDecl decl)) -> prependSummary (category $ snd infos) <$> decl - (Free (infos :< Syntax.Args args)) -> prependSummary (category $ snd infos) <$> join args - (Free (infos :< Syntax.Switch expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases - (Free (infos :< Syntax.Case expr body)) -> prependSummary (category $ snd infos) <$> expr <> body - Free (infos :< (Syntax.Ternary expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases - Free (infos :< (Syntax.MathAssignment id value)) -> prependSummary (category $ snd infos) <$> id <> value - Free (infos :< (Syntax.Operator syntaxes)) -> prependSummary (category $ snd infos) <$> join syntaxes - Free (infos :< (Syntax.Object kvs)) -> prependSummary (category $ snd infos) <$> join kvs - Free (infos :< (Syntax.Pair a b)) -> prependSummary (category $ snd infos) <$> a <> b - Free (infos :< (Syntax.Commented cs leaf)) -> prependSummary (category $ snd infos) <$> join cs <> fromMaybe [] leaf + Free (_ :< (S.Comment _)) -> [] + (Free (infos :< S.Indexed children)) -> prependSummary (category $ snd infos) <$> join children + (Free (infos :< S.Fixed children)) -> prependSummary (category $ snd infos) <$> join children + (Free (infos :< S.FunctionCall identifier children)) -> prependSummary (category $ snd infos) <$> join (Prologue.toList (identifier : children)) + (Free (infos :< S.Function id ps body)) -> prependSummary (category $ snd infos) <$> (fromMaybe [] id) <> (fromMaybe [] ps) <> body + (Free (infos :< S.Assignment id value)) -> prependSummary (category $ snd infos) <$> id <> value + (Free (infos :< S.MemberAccess base property)) -> prependSummary (category $ snd infos) <$> base <> property + (Free (infos :< S.SubscriptAccess base property)) -> prependSummary (category $ snd infos) <$> base <> property + (Free (infos :< S.MethodCall targetId methodId ps)) -> prependSummary (category $ snd infos) <$> targetId <> methodId <> ps + (Free (infos :< S.VarAssignment varId value)) -> prependSummary (category $ snd infos) <$> varId <> value + (Free (infos :< S.VarDecl decl)) -> prependSummary (category $ snd infos) <$> decl + (Free (infos :< S.Args args)) -> prependSummary (category $ snd infos) <$> join args + (Free (infos :< S.Switch expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases + (Free (infos :< S.Case expr body)) -> prependSummary (category $ snd infos) <$> expr <> body + Free (infos :< (S.Ternary expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases + Free (infos :< (S.MathAssignment id value)) -> prependSummary (category $ snd infos) <$> id <> value + Free (infos :< (S.Operator syntaxes)) -> prependSummary (category $ snd infos) <$> join syntaxes + Free (infos :< (S.Object kvs)) -> prependSummary (category $ snd infos) <$> join kvs + Free (infos :< (S.Pair a b)) -> prependSummary (category $ snd infos) <$> a <> b + Free (infos :< (S.Commented cs leaf)) -> prependSummary (category $ snd infos) <$> join cs <> fromMaybe [] leaf + Free (infos :< (S.Error children)) -> prependSummary (category $ snd infos) <$> join children (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo term) [] ] (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo t1) (termToDiffInfo t2)) [] ] @@ -176,17 +177,17 @@ diffSummary = cata $ \case termToDiffInfo :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> DiffInfo termToDiffInfo term = case unwrap term of Leaf _ -> LeafInfo (toCategoryName term) (toTermName term) - Syntax.Indexed children -> BranchInfo (termToDiffInfo <$> children) (toCategoryName term) BIndexed - Syntax.Fixed children -> BranchInfo (termToDiffInfo <$> children) (toCategoryName term) BFixed - Syntax.FunctionCall identifier _ -> LeafInfo (toCategoryName term) (toTermName identifier) - Syntax.Ternary ternaryCondition _ -> LeafInfo (toCategoryName term) (toTermName ternaryCondition) - Syntax.Function identifier _ _ -> LeafInfo (toCategoryName term) (maybe "anonymous" toTermName identifier) - Syntax.Assignment identifier _ -> LeafInfo (toCategoryName term) (toTermName identifier) - Syntax.MathAssignment identifier _ -> LeafInfo (toCategoryName term) (toTermName identifier) + S.Indexed children -> BranchInfo (termToDiffInfo <$> children) (toCategoryName term) BIndexed + S.Fixed children -> BranchInfo (termToDiffInfo <$> children) (toCategoryName term) BFixed + S.FunctionCall identifier _ -> LeafInfo (toCategoryName term) (toTermName identifier) + S.Ternary ternaryCondition _ -> LeafInfo (toCategoryName term) (toTermName ternaryCondition) + S.Function identifier _ _ -> LeafInfo (toCategoryName term) (maybe "anonymous" toTermName identifier) + S.Assignment identifier _ -> LeafInfo (toCategoryName term) (toTermName identifier) + S.MathAssignment identifier _ -> LeafInfo (toCategoryName term) (toTermName identifier) -- Currently we cannot express the operator for an operator production from TreeSitter. Eventually we should be able to -- use the term name of the operator identifier when we have that production value. Until then, I'm using a placeholder value -- to indicate where that value should be when constructing DiffInfos. - Syntax.Operator _ -> LeafInfo (toCategoryName term) "x" + S.Operator _ -> LeafInfo (toCategoryName term) "x" Commented cs leaf -> BranchInfo (termToDiffInfo <$> cs <> maybeToList leaf) (toCategoryName term) BCommented _ -> LeafInfo (toCategoryName term) (toTermName term) From da6a5c50cada5b4339805238f3d0f15b96450895 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 14:56:23 -0400 Subject: [PATCH 060/320] Add error case to MemberAccess construct case --- src/Parser.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index d8082ee3e..0300391d2 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE ScopedTypeVariables #-} module Parser where import Prologue hiding (Constructor) import Data.Record import Data.Text (pack) -import Category +import Category as C import Info import Range import qualified Syntax as S @@ -26,10 +27,12 @@ isFixed = flip Set.member fixedCategories -- | Given a function that maps production names to sets of categories, produce -- | a Constructor. -termConstructor :: (Show (Record fields), HasField fields Category, HasField fields Range) => Source Char -> (Record fields) -> [Term Text (Record fields)] -> Term Text (Record fields) +termConstructor :: forall fields. (Show (Record fields), HasField fields Category, HasField fields Range) => Source Char -> (Record fields) -> [Term Text (Record fields)] -> Term Text (Record fields) termConstructor source info = cofree . construct where withDefaultInfo syntax = (info :< syntax) + withErrorInfo syntax = (setCategory info C.Error :< syntax) + construct :: (Show (Record fields), HasField fields Category, HasField fields Range) => [Term Text (Record fields)] -> CofreeF (S.Syntax Text) (Record fields) (Term Text (Record fields)) construct [] = withDefaultInfo . S.Leaf . pack . toString $ slice (characterRange info) source construct children | Assignment == category info = case children of (identifier:value:[]) -> withDefaultInfo $ S.Assignment identifier value @@ -37,6 +40,7 @@ termConstructor source info = cofree . construct (identifier:value:[]) -> withDefaultInfo $ S.MathAssignment identifier value construct children | MemberAccess == category info = case children of (base:property:[]) -> withDefaultInfo $ S.MemberAccess base property + children -> withErrorInfo $ S.Error children construct children | SubscriptAccess == category info = case children of (base:element:[]) -> withDefaultInfo $ S.SubscriptAccess base element construct children | Operator == category info = withDefaultInfo $ S.Operator children From 771f37df0b264875754cf522ee115730b65b35ec Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 14:56:33 -0400 Subject: [PATCH 061/320] Add styleName mapping to Category.Error --- src/Renderer/Split.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index fe67726fa..0a7022fcc 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -33,7 +33,7 @@ classifyMarkup category element = (element !) . A.class_ . textValue $ styleName styleName :: Category -> Text styleName category = "category-" <> case category of Program -> "program" - Error -> "error" + C.Error -> "error" BinaryOperator -> "binary-operator" Boolean -> "boolean" DictionaryLiteral -> "dictionary" From de1088f4903a4959422c6a6297e8c8f6681cf6ad Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 14:56:43 -0400 Subject: [PATCH 062/320] Remove redundant import --- src/Renderer/Summary.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Renderer/Summary.hs b/src/Renderer/Summary.hs index 17983625a..81a2909e3 100644 --- a/src/Renderer/Summary.hs +++ b/src/Renderer/Summary.hs @@ -7,7 +7,6 @@ import Data.Aeson import Data.Record import Range import DiffSummary -import Text.PrettyPrint.Leijen.Text (pretty) summary :: (HasField fields Category, HasField fields Range) => Renderer (Record fields) summary diff _ = toS . encode $ annotatedTexts From 3b3d3282cbaf442769c1df39bdd2b6f525f80e4e Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 14:56:51 -0400 Subject: [PATCH 063/320] Add Error case to Syntax --- src/Syntax.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Syntax.hs b/src/Syntax.hs index 7bfad9204..b969ccac9 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -49,6 +49,7 @@ data Syntax | Pair f f | Comment a | Commented [f] (Maybe f) + | Error [f] deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable) From 30d4645dbb0c7e1d8d0b52e7a36abca9144824a9 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 14:57:14 -0400 Subject: [PATCH 064/320] Add bool_op and expression_statement mapping to categoriesForLanguage --- src/TreeSitter.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index a567817fc..fc54f9b51 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -31,6 +31,8 @@ categoriesForLanguage :: Language -> Text -> Category categoriesForLanguage language name = case (language, name) of (JavaScript, "object") -> Object (JavaScript, "rel_op") -> BinaryOperator -- relational operator, e.g. >, <, <=, >=, ==, != + (JavaScript, "bool_op") -> BinaryOperator + (JavaScript, "expression_statement") -> ExpressionStatements (JavaScript, "this_expression") -> Identifier (JavaScript, "null") -> Identifier (JavaScript, "undefined") -> Identifier From 882c7c224249585f38885919b3ecf4a5f660f469 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 18:39:22 -0400 Subject: [PATCH 065/320] Add the Error type as a Branch --- src/DiffSummary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 9bce68607..0c40a26fd 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -108,7 +108,7 @@ instance HasCategory Category where instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract -data Branch = BIndexed | BFixed | BCommented deriving (Show, Eq, Generic) +data Branch = BIndexed | BFixed | BCommented | BError deriving (Show, Eq, Generic) instance Arbitrary Branch where arbitrary = oneof [ pure BIndexed, pure BFixed ] shrink = genericShrink From 58ffd297379461688ebd1db789975b44d5282140 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 18:41:22 -0400 Subject: [PATCH 066/320] Add an error case --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 0c40a26fd..30b98ca88 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -189,6 +189,7 @@ termToDiffInfo term = case unwrap term of -- to indicate where that value should be when constructing DiffInfos. S.Operator _ -> LeafInfo (toCategoryName term) "x" Commented cs leaf -> BranchInfo (termToDiffInfo <$> cs <> maybeToList leaf) (toCategoryName term) BCommented + S.Error children -> BranchInfo (termToDiffInfo <$> children) (toCategoryName term) BError _ -> LeafInfo (toCategoryName term) (toTermName term) prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo From 338b7c2a1be9fba208f66bce356de71ee81768c6 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 25 Jul 2016 20:32:14 -0400 Subject: [PATCH 067/320] indent --- src/DiffSummary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 30b98ca88..75e75894f 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -190,7 +190,7 @@ termToDiffInfo term = case unwrap term of S.Operator _ -> LeafInfo (toCategoryName term) "x" Commented cs leaf -> BranchInfo (termToDiffInfo <$> cs <> maybeToList leaf) (toCategoryName term) BCommented S.Error children -> BranchInfo (termToDiffInfo <$> children) (toCategoryName term) BError - _ -> LeafInfo (toCategoryName term) (toTermName term) + _ -> LeafInfo (toCategoryName term) (toTermName term) prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo prependSummary annotation summary = summary { parentAnnotations = annotation : parentAnnotations summary } From 7435e9069cd34a10bd7f182cf163f7a99ff2ca5f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 03:50:13 -0400 Subject: [PATCH 068/320] Wrap all the branch cases but Fixed in Indexed. --- src/Alignment.hs | 33 ++------------------------------- 1 file changed, 2 insertions(+), 31 deletions(-) diff --git a/src/Alignment.hs b/src/Alignment.hs index a71310da0..00866ea3a 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -64,37 +64,8 @@ alignSyntax :: (Applicative f, HasField fields Range) => (forall a. f a -> Join alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = catMaybes $ case syntax of Leaf s -> wrapInBranch (const (Leaf s)) <$> alignBranch getRange [] bothRanges Comment a -> wrapInBranch (const (Comment a)) <$> alignBranch getRange [] bothRanges - Indexed children -> - wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges - Syntax.Function id params body -> wrapInBranch Indexed <$> alignBranch getRange (fromMaybe [] id <> fromMaybe [] params <> body) bothRanges - -- Align FunctionCalls like Indexed nodes by appending identifier to its children. - Syntax.FunctionCall identifier children -> - wrapInBranch Indexed <$> alignBranch getRange (join (identifier : children)) bothRanges - Syntax.Assignment assignmentId value -> - wrapInBranch Indexed <$> alignBranch getRange (assignmentId <> value) bothRanges - Syntax.MemberAccess memberId property -> - wrapInBranch Indexed <$> alignBranch getRange (memberId <> property) bothRanges - Syntax.MethodCall targetId methodId args -> - wrapInBranch Indexed <$> alignBranch getRange (targetId <> methodId <> args) bothRanges - Syntax.Args children -> - wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges - Syntax.VarDecl decl -> - wrapInBranch Indexed <$> alignBranch getRange decl bothRanges - Syntax.VarAssignment id value -> - wrapInBranch Indexed <$> alignBranch getRange (id <> value) bothRanges - Switch expr cases -> - wrapInBranch Indexed <$> alignBranch getRange (expr <> join cases) bothRanges - Case expr body -> - wrapInBranch Indexed <$> alignBranch getRange (expr <> body) bothRanges - Fixed children -> - wrapInBranch Fixed <$> alignBranch getRange (join children) bothRanges - Pair a b -> wrapInBranch Indexed <$> alignBranch getRange (a <> b) bothRanges - Object children -> wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges - Commented cs expr -> wrapInBranch Indexed <$> alignBranch getRange (join cs <> join (maybeToList expr)) bothRanges - Ternary expr cases -> wrapInBranch Indexed <$> alignBranch getRange (expr <> join cases) bothRanges - Operator cases -> wrapInBranch Indexed <$> alignBranch getRange (join cases) bothRanges - MathAssignment key value -> wrapInBranch Indexed <$> alignBranch getRange (key <> value) bothRanges - SubscriptAccess key value -> wrapInBranch Indexed <$> alignBranch getRange (key <> value) bothRanges + Fixed children -> wrapInBranch Fixed <$> alignBranch getRange (join children) bothRanges + _ -> wrapInBranch Indexed <$> alignBranch getRange (join (toList syntax)) bothRanges where bothRanges = modifyJoin (fromThese [] []) lineRanges lineRanges = toJoinThese $ actualLineRanges <$> (characterRange <$> infos) <*> sources wrapInBranch constructor = applyThese $ toJoinThese ((\ info (range, children) -> toNode (setCharacterRange info range :< constructor children)) <$> infos) From 4863611ecc96504693d86299b267343ffc96cd85 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 03:54:41 -0400 Subject: [PATCH 069/320] :fire: the RULES pragma on Mergeable. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit I don’t understand what they do well enough for this to be anything but a maintenance burden. --- src/Data/Mergeable.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Data/Mergeable.hs b/src/Data/Mergeable.hs index b111b2c4b..3cc4591d6 100644 --- a/src/Data/Mergeable.hs +++ b/src/Data/Mergeable.hs @@ -15,10 +15,6 @@ class Functor t => Mergeable t where sequenceAlt :: Alternative f => t (f a) -> f (t a) sequenceAlt = merge identity -{-# RULES -"merge identity" merge identity = sequenceAlt - #-} - -- Instances From a64e6736a3485cbc2d730f39edea467a55c9e0fb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 03:56:10 -0400 Subject: [PATCH 070/320] Define a Mergeable instance over Identity. --- src/Data/Mergeable.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Mergeable.hs b/src/Data/Mergeable.hs index 3cc4591d6..2ce8bc030 100644 --- a/src/Data/Mergeable.hs +++ b/src/Data/Mergeable.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DefaultSignatures #-} module Data.Mergeable where +import Data.Functor.Identity import Data.Mergeable.Generic import GHC.Generics import Prologue @@ -21,3 +22,5 @@ class Functor t => Mergeable t where instance Mergeable [] where merge = gmerge instance Mergeable Maybe + +instance Mergeable Identity where merge f = fmap Identity . f . runIdentity From 8f15a592821e56cb42d1ce30702d2a275fa694b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 03:56:52 -0400 Subject: [PATCH 071/320] Stub in a spec for the Mergeable stuff. --- semantic-diff.cabal | 1 + test/Data/Mergeable/Spec.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 test/Data/Mergeable/Spec.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 25e42c709..dd378750e 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -103,6 +103,7 @@ test-suite semantic-diff-test main-is: Spec.hs other-modules: AlignmentSpec , CorpusSpec + , Data.Mergeable.Spec , Data.RandomWalkSimilarity.Spec , Diff.Spec , DiffSummarySpec diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs new file mode 100644 index 000000000..38b284357 --- /dev/null +++ b/test/Data/Mergeable/Spec.hs @@ -0,0 +1 @@ +module Data.Mergeable.Spec where From b03f1d3b913d14ce2d1fb94b5c91eb37a422c48f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 03:58:14 -0400 Subject: [PATCH 072/320] Stub in a spec function. --- test/Data/Mergeable/Spec.hs | 6 ++++++ test/Spec.hs | 2 ++ 2 files changed, 8 insertions(+) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 38b284357..87dea4c28 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -1 +1,7 @@ module Data.Mergeable.Spec where + +import Prologue +import Test.Hspec + +spec :: Spec +spec = pure () diff --git a/test/Spec.hs b/test/Spec.hs index 50fa6e398..56001e7dc 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,6 +3,7 @@ module Main where import Prologue import qualified AlignmentSpec import qualified CorpusSpec +import qualified Data.Mergeable.Spec import qualified Data.RandomWalkSimilarity.Spec import qualified Diff.Spec import qualified DiffSummarySpec @@ -15,6 +16,7 @@ main :: IO () main = hspec . parallel $ do describe "Alignment" AlignmentSpec.spec describe "Corpus" CorpusSpec.spec + describe "Data.Mergeable" Data.Mergeable.Spec.spec describe "Data.RandomWalkSimilarity" Data.RandomWalkSimilarity.Spec.spec describe "Diff.Spec" Diff.Spec.spec describe "DiffSummary" DiffSummarySpec.spec From 93c53ed90ab1fa78beda34867225d01e80decba5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 04:02:52 -0400 Subject: [PATCH 073/320] Stub in a property test for the proposed identity law. --- test/Data/Mergeable/Spec.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 87dea4c28..31b3162bb 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -1,7 +1,13 @@ module Data.Mergeable.Spec where +import Data.Functor.Identity +import Data.Mergeable import Prologue import Test.Hspec +import Test.Hspec.QuickCheck spec :: Spec -spec = pure () +spec = do + describe "sequenceAlt" $ do + prop "identity" $ + \ a -> sequenceAlt (fmap Just a) `shouldBe` Just (a :: [Char]) From fa3b7d126ecfb30de4c4188d8fbb830051d4ddf9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 04:04:24 -0400 Subject: [PATCH 074/320] Factor the sequenceAlt law properties into a separate function. --- test/Data/Mergeable/Spec.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 31b3162bb..7971660c1 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -8,6 +8,10 @@ import Test.Hspec.QuickCheck spec :: Spec spec = do + sequenceAltLaws + +sequenceAltLaws :: Spec +sequenceAltLaws = do describe "sequenceAlt" $ do prop "identity" $ \ a -> sequenceAlt (fmap Just a) `shouldBe` Just (a :: [Char]) From 734254194c894cec2e77004d6a5cee2d1567919c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 04:06:51 -0400 Subject: [PATCH 075/320] Define sequenceAltLaws to take a generator of Mergeable values. --- test/Data/Mergeable/Spec.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 7971660c1..05a808003 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -5,13 +5,14 @@ import Data.Mergeable import Prologue import Test.Hspec import Test.Hspec.QuickCheck +import Test.QuickCheck spec :: Spec spec = do - sequenceAltLaws + sequenceAltLaws (arbitrary :: Gen [Char]) -sequenceAltLaws :: Spec -sequenceAltLaws = do +sequenceAltLaws :: (Mergeable f, Eq (f a), Show (f a)) => Gen (f a) -> Spec +sequenceAltLaws gen = do describe "sequenceAlt" $ do - prop "identity" $ - \ a -> sequenceAlt (fmap Just a) `shouldBe` Just (a :: [Char]) + prop "identity" . forAll gen $ + \ a -> sequenceAlt (fmap Just a) `shouldBe` Just a From 88bb767ff7d6645465bcf5c437b34486a73c13c3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 04:07:46 -0400 Subject: [PATCH 076/320] Group the law invocations by functor. --- test/Data/Mergeable/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 05a808003..b9a5b471d 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -9,7 +9,7 @@ import Test.QuickCheck spec :: Spec spec = do - sequenceAltLaws (arbitrary :: Gen [Char]) + describe "[]" $ sequenceAltLaws (arbitrary :: Gen [Char]) sequenceAltLaws :: (Mergeable f, Eq (f a), Show (f a)) => Gen (f a) -> Spec sequenceAltLaws gen = do From d1bbe1c029f899678bbf4ba6008a2a1dae160f39 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 04:08:19 -0400 Subject: [PATCH 077/320] Validate the sequenceAltLaws against Maybe. --- test/Data/Mergeable/Spec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index b9a5b471d..2d0cd5799 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -10,6 +10,7 @@ import Test.QuickCheck spec :: Spec spec = do describe "[]" $ sequenceAltLaws (arbitrary :: Gen [Char]) + describe "Maybe" $ sequenceAltLaws (arbitrary :: Gen (Maybe Char)) sequenceAltLaws :: (Mergeable f, Eq (f a), Show (f a)) => Gen (f a) -> Spec sequenceAltLaws gen = do From a0cf6ce70298d1a7ab03ebf42b4e1b33177c76df Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 04:15:56 -0400 Subject: [PATCH 078/320] Validate the relationship between sequenceAlt and merge. --- test/Data/Mergeable/Spec.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 2d0cd5799..a213fdb86 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module Data.Mergeable.Spec where import Data.Functor.Identity @@ -12,8 +13,11 @@ spec = do describe "[]" $ sequenceAltLaws (arbitrary :: Gen [Char]) describe "Maybe" $ sequenceAltLaws (arbitrary :: Gen (Maybe Char)) -sequenceAltLaws :: (Mergeable f, Eq (f a), Show (f a)) => Gen (f a) -> Spec +sequenceAltLaws :: forall f a. (Arbitrary a, CoArbitrary a, Mergeable f, Eq (f a), Show (f a)) => Gen (f a) -> Spec sequenceAltLaws gen = do describe "sequenceAlt" $ do prop "identity" . forAll gen $ \ a -> sequenceAlt (fmap Just a) `shouldBe` Just a + + prop "relationship with merge" . forAll ((,) <$> gen <*> (arbitrary :: Gen (Blind (a -> Maybe a)))) $ + \ (a, f) -> sequenceAlt (getBlind f <$> a) `shouldBe` merge (getBlind f) a From f76b334b8c1addb01a3d0afd2ebd2c9de3b15ed6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 04:16:40 -0400 Subject: [PATCH 079/320] Validate the sequenceAltLaws against the Identity instance. --- test/Data/Mergeable/Spec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index a213fdb86..df894b6a4 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -12,6 +12,7 @@ spec :: Spec spec = do describe "[]" $ sequenceAltLaws (arbitrary :: Gen [Char]) describe "Maybe" $ sequenceAltLaws (arbitrary :: Gen (Maybe Char)) + describe "Identity" $ sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char)) sequenceAltLaws :: forall f a. (Arbitrary a, CoArbitrary a, Mergeable f, Eq (f a), Show (f a)) => Gen (f a) -> Spec sequenceAltLaws gen = do From 680643894933b0c8f0503fe540fd71e5fe2d2dcd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 04:23:03 -0400 Subject: [PATCH 080/320] Generalize the sequenceAlt laws over the inner alternative functor. --- test/Data/Mergeable/Spec.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index df894b6a4..1cbbec28d 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -16,9 +16,13 @@ spec = do sequenceAltLaws :: forall f a. (Arbitrary a, CoArbitrary a, Mergeable f, Eq (f a), Show (f a)) => Gen (f a) -> Spec sequenceAltLaws gen = do + describe "Maybe" $ sequenceAltLaws' gen (arbitrary :: Gen (Blind (a -> Maybe a))) + +sequenceAltLaws' :: forall f g a. (Arbitrary a, CoArbitrary a, Mergeable f, Alternative g, Eq (f a), Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec +sequenceAltLaws' value function = do describe "sequenceAlt" $ do - prop "identity" . forAll gen $ + prop "identity" . forAll value $ \ a -> sequenceAlt (fmap Just a) `shouldBe` Just a - prop "relationship with merge" . forAll ((,) <$> gen <*> (arbitrary :: Gen (Blind (a -> Maybe a)))) $ + prop "relationship with merge" . forAll ((,) <$> value <*> function) $ \ (a, f) -> sequenceAlt (getBlind f <$> a) `shouldBe` merge (getBlind f) a From 7af29fcf103b2bafe8c24e3a667e60a665f0dbbc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 04:25:45 -0400 Subject: [PATCH 081/320] Define the identity law over `pure`. --- test/Data/Mergeable/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 1cbbec28d..5c4a7fee8 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -22,7 +22,7 @@ sequenceAltLaws' :: forall f g a. (Arbitrary a, CoArbitrary a, Mergeable f, Alte sequenceAltLaws' value function = do describe "sequenceAlt" $ do prop "identity" . forAll value $ - \ a -> sequenceAlt (fmap Just a) `shouldBe` Just a + \ a -> sequenceAlt (pure <$> a) `shouldBe` (pure a :: g (f a)) prop "relationship with merge" . forAll ((,) <$> value <*> function) $ \ (a, f) -> sequenceAlt (getBlind f <$> a) `shouldBe` merge (getBlind f) a From 5d6b1cd0479670fb9fb121c303ebf651df96d560 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 05:39:02 -0400 Subject: [PATCH 082/320] Test the sequenceAlt laws over Syntax. --- test/Data/Mergeable/Spec.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 5c4a7fee8..71b1f9e43 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -4,6 +4,7 @@ module Data.Mergeable.Spec where import Data.Functor.Identity import Data.Mergeable import Prologue +import Syntax import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck @@ -13,6 +14,7 @@ spec = do describe "[]" $ sequenceAltLaws (arbitrary :: Gen [Char]) describe "Maybe" $ sequenceAltLaws (arbitrary :: Gen (Maybe Char)) describe "Identity" $ sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char)) + describe "Syntax" $ sequenceAltLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char)) sequenceAltLaws :: forall f a. (Arbitrary a, CoArbitrary a, Mergeable f, Eq (f a), Show (f a)) => Gen (f a) -> Spec sequenceAltLaws gen = do From 475c97190c54f275e2dd2603f2ffdf9d084f34db Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 12:47:38 -0400 Subject: [PATCH 083/320] Parallelize the Mergeable spec. --- test/Data/Mergeable/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 71b1f9e43..945f5c75c 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -10,7 +10,7 @@ import Test.Hspec.QuickCheck import Test.QuickCheck spec :: Spec -spec = do +spec = parallel $ do describe "[]" $ sequenceAltLaws (arbitrary :: Gen [Char]) describe "Maybe" $ sequenceAltLaws (arbitrary :: Gen (Maybe Char)) describe "Identity" $ sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char)) From df4621622a2a17ae123d70be17e53b3c808726b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 13:03:13 -0400 Subject: [PATCH 084/320] Formulate a merge law. --- test/Data/Mergeable/Spec.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 945f5c75c..16e3ef33f 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -16,6 +16,11 @@ spec = parallel $ do describe "Identity" $ sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char)) describe "Syntax" $ sequenceAltLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char)) +mergeLaws :: (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec +mergeLaws value function = describe "merge" $ do + prop "relationship with sequenceAlt" . forAll ((,) <$> value <*> function) $ + \ (a, f) -> merge (getBlind f) a `shouldBe` sequenceAlt (fmap (getBlind f) a) + sequenceAltLaws :: forall f a. (Arbitrary a, CoArbitrary a, Mergeable f, Eq (f a), Show (f a)) => Gen (f a) -> Spec sequenceAltLaws gen = do describe "Maybe" $ sequenceAltLaws' gen (arbitrary :: Gen (Blind (a -> Maybe a))) From 5430f45850911193cb3cfd2bf53648958b65a8c4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 13:06:18 -0400 Subject: [PATCH 085/320] Verify the merge laws over []/Maybe. --- test/Data/Mergeable/Spec.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 16e3ef33f..c63065190 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -11,7 +11,9 @@ import Test.QuickCheck spec :: Spec spec = parallel $ do - describe "[]" $ sequenceAltLaws (arbitrary :: Gen [Char]) + describe "[]" $ do + sequenceAltLaws (arbitrary :: Gen [Char]) + mergeLaws (arbitrary :: Gen [Char]) (arbitrary :: Gen (Blind (Char -> Maybe Char))) describe "Maybe" $ sequenceAltLaws (arbitrary :: Gen (Maybe Char)) describe "Identity" $ sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char)) describe "Syntax" $ sequenceAltLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char)) From be973b5baeb6228b9e7cc720eeeccd9593f89848 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 13:11:52 -0400 Subject: [PATCH 086/320] Generalize out a helper function to validate laws against alternative instances. --- test/Data/Mergeable/Spec.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index c63065190..31ff50a01 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} module Data.Mergeable.Spec where import Data.Functor.Identity @@ -12,23 +12,23 @@ import Test.QuickCheck spec :: Spec spec = parallel $ do describe "[]" $ do - sequenceAltLaws (arbitrary :: Gen [Char]) - mergeLaws (arbitrary :: Gen [Char]) (arbitrary :: Gen (Blind (Char -> Maybe Char))) - describe "Maybe" $ sequenceAltLaws (arbitrary :: Gen (Maybe Char)) - describe "Identity" $ sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char)) - describe "Syntax" $ sequenceAltLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char)) + withAlternativeInstances sequenceAltLaws (arbitrary :: Gen [Char]) + withAlternativeInstances mergeLaws (arbitrary :: Gen [Char]) + describe "Maybe" $ withAlternativeInstances sequenceAltLaws (arbitrary :: Gen (Maybe Char)) + describe "Identity" $ withAlternativeInstances sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char)) + describe "Syntax" $ withAlternativeInstances sequenceAltLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char)) -mergeLaws :: (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec +mergeLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec mergeLaws value function = describe "merge" $ do prop "relationship with sequenceAlt" . forAll ((,) <$> value <*> function) $ \ (a, f) -> merge (getBlind f) a `shouldBe` sequenceAlt (fmap (getBlind f) a) -sequenceAltLaws :: forall f a. (Arbitrary a, CoArbitrary a, Mergeable f, Eq (f a), Show (f a)) => Gen (f a) -> Spec -sequenceAltLaws gen = do - describe "Maybe" $ sequenceAltLaws' gen (arbitrary :: Gen (Blind (a -> Maybe a))) +withAlternativeInstances :: forall f a. (Arbitrary a, CoArbitrary a, Mergeable f, Eq (f a), Show (f a)) => (forall g. (Alternative g, Eq (g (f a)), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec) -> Gen (f a) -> Spec +withAlternativeInstances laws gen = do + describe "Maybe" $ laws gen (arbitrary :: Gen (Blind (a -> Maybe a))) -sequenceAltLaws' :: forall f g a. (Arbitrary a, CoArbitrary a, Mergeable f, Alternative g, Eq (f a), Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec -sequenceAltLaws' value function = do +sequenceAltLaws :: forall f g a. (Arbitrary a, CoArbitrary a, Mergeable f, Alternative g, Eq (f a), Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec +sequenceAltLaws value function = do describe "sequenceAlt" $ do prop "identity" . forAll value $ \ a -> sequenceAlt (pure <$> a) `shouldBe` (pure a :: g (f a)) From a967e800bbd84f39c174a64cf30653ffff4d8757 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 13:12:09 -0400 Subject: [PATCH 087/320] Move the alternative instances helper down. --- test/Data/Mergeable/Spec.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 31ff50a01..14cf3323f 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -23,10 +23,6 @@ mergeLaws value function = describe "merge" $ do prop "relationship with sequenceAlt" . forAll ((,) <$> value <*> function) $ \ (a, f) -> merge (getBlind f) a `shouldBe` sequenceAlt (fmap (getBlind f) a) -withAlternativeInstances :: forall f a. (Arbitrary a, CoArbitrary a, Mergeable f, Eq (f a), Show (f a)) => (forall g. (Alternative g, Eq (g (f a)), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec) -> Gen (f a) -> Spec -withAlternativeInstances laws gen = do - describe "Maybe" $ laws gen (arbitrary :: Gen (Blind (a -> Maybe a))) - sequenceAltLaws :: forall f g a. (Arbitrary a, CoArbitrary a, Mergeable f, Alternative g, Eq (f a), Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec sequenceAltLaws value function = do describe "sequenceAlt" $ do @@ -35,3 +31,8 @@ sequenceAltLaws value function = do prop "relationship with merge" . forAll ((,) <$> value <*> function) $ \ (a, f) -> sequenceAlt (getBlind f <$> a) `shouldBe` merge (getBlind f) a + + +withAlternativeInstances :: forall f a. (Arbitrary a, CoArbitrary a, Mergeable f, Eq (f a), Show (f a)) => (forall g. (Alternative g, Eq (g (f a)), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec) -> Gen (f a) -> Spec +withAlternativeInstances laws gen = do + describe "Maybe" $ laws gen (arbitrary :: Gen (Blind (a -> Maybe a))) From f64164d872bbd2291830d7d2d166ffc6a97237d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 13:12:32 -0400 Subject: [PATCH 088/320] Generalize a constraint away. --- test/Data/Mergeable/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 14cf3323f..666d3937b 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -33,6 +33,6 @@ sequenceAltLaws value function = do \ (a, f) -> sequenceAlt (getBlind f <$> a) `shouldBe` merge (getBlind f) a -withAlternativeInstances :: forall f a. (Arbitrary a, CoArbitrary a, Mergeable f, Eq (f a), Show (f a)) => (forall g. (Alternative g, Eq (g (f a)), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec) -> Gen (f a) -> Spec +withAlternativeInstances :: forall f a. (Arbitrary a, CoArbitrary a, Eq (f a), Show (f a)) => (forall g. (Alternative g, Eq (g (f a)), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec) -> Gen (f a) -> Spec withAlternativeInstances laws gen = do describe "Maybe" $ laws gen (arbitrary :: Gen (Blind (a -> Maybe a))) From 8f25cbd47306c5de0dd3731703da816aa995ffef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 13:13:45 -0400 Subject: [PATCH 089/320] :fire: some redundant constraints. --- test/Data/Mergeable/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 666d3937b..83028eac3 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -23,7 +23,7 @@ mergeLaws value function = describe "merge" $ do prop "relationship with sequenceAlt" . forAll ((,) <$> value <*> function) $ \ (a, f) -> merge (getBlind f) a `shouldBe` sequenceAlt (fmap (getBlind f) a) -sequenceAltLaws :: forall f g a. (Arbitrary a, CoArbitrary a, Mergeable f, Alternative g, Eq (f a), Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec +sequenceAltLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec sequenceAltLaws value function = do describe "sequenceAlt" $ do prop "identity" . forAll value $ From 7d4d14c99b2e33c1430f327c718fa348b53e635d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 13:16:46 -0400 Subject: [PATCH 090/320] Run the merge laws over Maybe. --- test/Data/Mergeable/Spec.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 83028eac3..ccd1e0941 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -14,7 +14,9 @@ spec = parallel $ do describe "[]" $ do withAlternativeInstances sequenceAltLaws (arbitrary :: Gen [Char]) withAlternativeInstances mergeLaws (arbitrary :: Gen [Char]) - describe "Maybe" $ withAlternativeInstances sequenceAltLaws (arbitrary :: Gen (Maybe Char)) + describe "Maybe" $ do + withAlternativeInstances sequenceAltLaws (arbitrary :: Gen (Maybe Char)) + withAlternativeInstances mergeLaws (arbitrary :: Gen (Maybe Char)) describe "Identity" $ withAlternativeInstances sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char)) describe "Syntax" $ withAlternativeInstances sequenceAltLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char)) From e98844e9372910ee23fa4ccbe84420a111c16e65 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 13:17:13 -0400 Subject: [PATCH 091/320] Run the merge laws over Identity. --- test/Data/Mergeable/Spec.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index ccd1e0941..bc176c34a 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -17,7 +17,9 @@ spec = parallel $ do describe "Maybe" $ do withAlternativeInstances sequenceAltLaws (arbitrary :: Gen (Maybe Char)) withAlternativeInstances mergeLaws (arbitrary :: Gen (Maybe Char)) - describe "Identity" $ withAlternativeInstances sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char)) + describe "Identity" $ do + withAlternativeInstances sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char)) + withAlternativeInstances mergeLaws (Identity <$> arbitrary :: Gen (Identity Char)) describe "Syntax" $ withAlternativeInstances sequenceAltLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char)) mergeLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec From 7ff92d968e00dc8b36aec2d14437e4bfb29ca70f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 13:17:33 -0400 Subject: [PATCH 092/320] Run the merge laws over Syntax. --- test/Data/Mergeable/Spec.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index bc176c34a..b249bb665 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -20,7 +20,9 @@ spec = parallel $ do describe "Identity" $ do withAlternativeInstances sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char)) withAlternativeInstances mergeLaws (Identity <$> arbitrary :: Gen (Identity Char)) - describe "Syntax" $ withAlternativeInstances sequenceAltLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char)) + describe "Syntax" $ do + withAlternativeInstances sequenceAltLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char)) + withAlternativeInstances mergeLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char)) mergeLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec mergeLaws value function = describe "merge" $ do From b987a403772163d9f7ea4efc8df3142581ac13a2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 13:23:14 -0400 Subject: [PATCH 093/320] =?UTF-8?q?sequenceAlt=E2=80=99s=20relationship=20?= =?UTF-8?q?with=20merge=20is=20the=20inverse=20of=20merge=E2=80=99s=20rela?= =?UTF-8?q?tionship=20with=20sequenceAlt.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- test/Data/Mergeable/Spec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index b249bb665..4cece0236 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -35,8 +35,8 @@ sequenceAltLaws value function = do prop "identity" . forAll value $ \ a -> sequenceAlt (pure <$> a) `shouldBe` (pure a :: g (f a)) - prop "relationship with merge" . forAll ((,) <$> value <*> function) $ - \ (a, f) -> sequenceAlt (getBlind f <$> a) `shouldBe` merge (getBlind f) a + prop "relationship with merge" . forAll (((\ (v, f) -> Blind (fmap (getBlind f) v)) <$> ((,) <$> value <*> function)) :: Gen (Blind (f (g a)))) $ + \ a -> sequenceAlt (getBlind a) `shouldBe` merge identity (getBlind a) withAlternativeInstances :: forall f a. (Arbitrary a, CoArbitrary a, Eq (f a), Show (f a)) => (forall g. (Alternative g, Eq (g (f a)), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec) -> Gen (f a) -> Spec From 794fffbf47c3f3159b5ccde192060c3c9a8192e0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 13:25:16 -0400 Subject: [PATCH 094/320] Clean up the generator. --- test/Data/Mergeable/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 4cece0236..46b79838e 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -35,7 +35,7 @@ sequenceAltLaws value function = do prop "identity" . forAll value $ \ a -> sequenceAlt (pure <$> a) `shouldBe` (pure a :: g (f a)) - prop "relationship with merge" . forAll (((\ (v, f) -> Blind (fmap (getBlind f) v)) <$> ((,) <$> value <*> function)) :: Gen (Blind (f (g a)))) $ + prop "relationship with merge" . forAll (Blind <$> (fmap . getBlind <$> function <*> value) :: Gen (Blind (f (g a)))) $ \ a -> sequenceAlt (getBlind a) `shouldBe` merge identity (getBlind a) From 2ee68cc4b2745e3c05790657a0ab348182afbf3f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 13:30:09 -0400 Subject: [PATCH 095/320] Add an identity law over merge. --- test/Data/Mergeable/Spec.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 46b79838e..d9b38ff33 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -26,7 +26,11 @@ spec = parallel $ do mergeLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec mergeLaws value function = describe "merge" $ do - prop "relationship with sequenceAlt" . forAll ((,) <$> value <*> function) $ + prop "identity" . forAll value $ + \ a -> merge pure a `shouldBe` (pure a :: g (f a)) + + let pair = (,) <$> value <*> function + prop "relationship with sequenceAlt" . forAll pair $ \ (a, f) -> merge (getBlind f) a `shouldBe` sequenceAlt (fmap (getBlind f) a) sequenceAltLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec From 4809ad0f2f80704c5f45261e69f41e89afe4f3e1 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 13:44:12 -0400 Subject: [PATCH 096/320] Use bind --- src/Renderer/Summary.hs | 4 +--- test/DiffSummarySpec.hs | 2 +- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Renderer/Summary.hs b/src/Renderer/Summary.hs index 17983625a..f4d2fe31b 100644 --- a/src/Renderer/Summary.hs +++ b/src/Renderer/Summary.hs @@ -10,7 +10,5 @@ import DiffSummary import Text.PrettyPrint.Leijen.Text (pretty) summary :: (HasField fields Category, HasField fields Range) => Renderer (Record fields) -summary diff _ = toS . encode $ annotatedTexts +summary diff _ = toS . encode $ summaries >>= annotatedSummaries where summaries = diffSummary diff - annotatedTexts :: [Text] - annotatedTexts = join $ annotatedSummaries <$> summaries diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 297944eae..bfe620510 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -78,7 +78,7 @@ spec = parallel $ do case (partition isBranchNode diffInfoPatches, partition isIndexedOrFixed syntaxPatches) of ((branchPatches, _), (diffPatches, _)) -> let listOfLeaves = foldMap extractLeaves (join $ toList <$> branchPatches) - listOfDiffLeaves = foldMap extractDiffLeaves (join $ toList <$> diffPatches) + listOfDiffLeaves = foldMap extractDiffLeaves (diffPatches >>= toList) in length listOfLeaves `shouldBe` length listOfDiffLeaves From 84edc4b8cefab86357639b9c72c9a706e3da6cba Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 13:45:50 -0400 Subject: [PATCH 097/320] use bind --- test/DiffSummarySpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index bfe620510..e798ab3eb 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -72,7 +72,7 @@ spec = parallel $ do extractDiffLeaves term = case unwrap term of (Indexed children) -> join $ extractDiffLeaves <$> children (Fixed children) -> join $ extractDiffLeaves <$> children - Commented children leaf -> join $ extractDiffLeaves <$> children <> maybeToList leaf + Commented children leaf -> children <> maybeToList leaf >>= extractDiffLeaves _ -> [ term ] in case (partition isBranchNode diffInfoPatches, partition isIndexedOrFixed syntaxPatches) of From de925c533d1df2ea74e416d614b8b9f6ffcacfa8 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 13:55:05 -0400 Subject: [PATCH 098/320] use Foldable.any --- test/DiffSummarySpec.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index e798ab3eb..88e675763 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -100,7 +100,4 @@ isBranchInfo info = case info of (LeafInfo _ _) -> False isBranchNode :: Patch DiffInfo -> Bool -isBranchNode patch = case patch of - (Insert diffInfo) -> isBranchInfo diffInfo - (Delete diffInfo) -> isBranchInfo diffInfo - (Replace i1 i2) -> isBranchInfo i1 || isBranchInfo i2 \ No newline at end of file +isBranchNode patch = any isBranchInfo From 799643147b748ddacc9e2d364429af74b8b51473 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 14:04:15 -0400 Subject: [PATCH 099/320] partially apply isBranchNode --- src/DiffSummary.hs | 1 - test/DiffSummarySpec.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 281769433..9fed469b0 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds, TypeFamilies, ScopedTypeVariables #-} - module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..), annotatedSummaries) where import Prologue hiding (snd, intercalate) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 88e675763..ab12b5546 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -100,4 +100,4 @@ isBranchInfo info = case info of (LeafInfo _ _) -> False isBranchNode :: Patch DiffInfo -> Bool -isBranchNode patch = any isBranchInfo +isBranchNode = any isBranchInfo From e7000b7de30c6f004147497ead649617fe1bd591 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 14:26:31 -0400 Subject: [PATCH 100/320] s/expression_statement/expression_statements --- test/diffs/asymmetrical-context.split.js | 8 ++++---- test/diffs/dictionary.json.js | 2 +- test/diffs/dictionary.split.js | 16 ++++++++-------- test/diffs/insert.split.js | 6 +++--- test/diffs/multiline-insert.split.js | 10 +++++----- test/diffs/nested-insert.split.js | 6 +++--- test/diffs/newline-at-eof.json.js | 2 +- test/diffs/newline-at-eof.split.js | 6 +++--- test/diffs/no-newline-at-eof.json.js | 2 +- test/diffs/no-newline-at-eof.split.js | 6 +++--- test/diffs/reformat.split.js | 8 ++++---- 11 files changed, 36 insertions(+), 36 deletions(-) diff --git a/test/diffs/asymmetrical-context.split.js b/test/diffs/asymmetrical-context.split.js index 57447bda9..31bc72255 100644 --- a/test/diffs/asymmetrical-context.split.js +++ b/test/diffs/asymmetrical-context.split.js @@ -1,7 +1,7 @@ -
1
      • console
      • .
      • log
      • (
          • '
          • hello
          • '
      • )
    • ;
  • + - @@ -20,9 +20,9 @@ - - diff --git a/test/diffs/dictionary.json.js b/test/diffs/dictionary.json.js index dc1db13ae..b7f2f522c 100644 --- a/test/diffs/dictionary.json.js +++ b/test/diffs/dictionary.json.js @@ -1 +1 @@ -{"rows":[[{"number":1,"terms":[{"range":[0,2],"category":"Program","children":[{"range":[0,2],"category":"expression_statement","children":[{"range":[0,2],"category":"Object","children":[]}]}]}],"range":[0,2],"hasChanges":false},{"number":1,"terms":[{"range":[0,2],"category":"Program","children":[{"range":[0,2],"category":"expression_statement","children":[{"range":[0,2],"category":"Object","children":[]}]}]}],"range":[0,2],"hasChanges":false}],[{"number":2,"terms":[{"range":[2,12],"category":"Program","children":[{"range":[2,12],"category":"expression_statement","children":[{"range":[2,12],"category":"Object","children":[{"range":[4,10],"category":"Pair","children":[{"range":[4,7],"category":"StringLiteral","children":[{"range":[4,5],"category":"StringLiteral"},{"range":[5,6],"category":"StringLiteral"},{"range":[6,7],"category":"StringLiteral"}]},{"patch":"replace","range":[9,10],"category":"number"}]}]}]}]}],"range":[2,12],"hasChanges":true},{"number":2,"terms":[{"range":[2,12],"category":"Program","children":[{"range":[2,12],"category":"expression_statement","children":[{"range":[2,12],"category":"Object","children":[{"range":[4,10],"category":"Pair","children":[{"range":[4,7],"category":"StringLiteral","children":[{"range":[4,5],"category":"StringLiteral"},{"range":[5,6],"category":"StringLiteral"},{"range":[6,7],"category":"StringLiteral"}]},{"patch":"replace","range":[9,10],"category":"number"}]}]}]}]}],"range":[2,12],"hasChanges":true}],[{"number":3,"terms":[{"range":[12,21],"category":"Program","children":[{"range":[12,21],"category":"expression_statement","children":[{"range":[12,21],"category":"Object","children":[{"range":[14,20],"category":"Pair","children":[{"range":[14,17],"category":"StringLiteral","children":[{"range":[14,15],"category":"StringLiteral"},{"range":[15,16],"category":"StringLiteral"},{"range":[16,17],"category":"StringLiteral"}]},{"range":[19,20],"category":"number"}]}]}]}]}],"range":[12,21],"hasChanges":false},{"number":3,"terms":[{"range":[12,21],"category":"Program","children":[{"range":[12,21],"category":"expression_statement","children":[{"range":[12,21],"category":"Object","children":[{"range":[14,20],"category":"Pair","children":[{"range":[14,17],"category":"StringLiteral","children":[{"range":[14,15],"category":"StringLiteral"},{"range":[15,16],"category":"StringLiteral"},{"range":[16,17],"category":"StringLiteral"}]},{"range":[19,20],"category":"number"}]}]}]}]}],"range":[12,21],"hasChanges":false}],[{"number":4,"terms":[{"range":[21,23],"category":"Program","children":[{"range":[21,23],"category":"expression_statement","children":[{"range":[21,22],"category":"Object","children":[]}]}]}],"range":[21,23],"hasChanges":false},{"number":4,"terms":[{"range":[21,23],"category":"Program","children":[{"range":[21,23],"category":"expression_statement","children":[{"range":[21,22],"category":"Object","children":[]}]}]}],"range":[21,23],"hasChanges":false}],[{"number":5,"terms":[{"range":[23,23],"category":"Program","children":[]}],"range":[23,23],"hasChanges":false},{"number":5,"terms":[{"range":[23,23],"category":"Program","children":[]}],"range":[23,23],"hasChanges":false}]],"oids":["",""],"paths":["test/diffs/dictionary.A.js","test/diffs/dictionary.B.js"]} \ No newline at end of file +{"rows":[[{"number":1,"terms":[{"range":[0,2],"category":"Program","children":[{"range":[0,2],"category":"ExpressionStatements","children":[{"range":[0,2],"category":"Object","children":[]}]}]}],"range":[0,2],"hasChanges":false},{"number":1,"terms":[{"range":[0,2],"category":"Program","children":[{"range":[0,2],"category":"ExpressionStatements","children":[{"range":[0,2],"category":"Object","children":[]}]}]}],"range":[0,2],"hasChanges":false}],[{"number":2,"terms":[{"range":[2,12],"category":"Program","children":[{"range":[2,12],"category":"ExpressionStatements","children":[{"range":[2,12],"category":"Object","children":[{"range":[4,10],"category":"Pair","children":[{"range":[4,7],"category":"StringLiteral","children":[{"range":[4,5],"category":"StringLiteral"},{"range":[5,6],"category":"StringLiteral"},{"range":[6,7],"category":"StringLiteral"}]},{"patch":"replace","range":[9,10],"category":"number"}]}]}]}]}],"range":[2,12],"hasChanges":true},{"number":2,"terms":[{"range":[2,12],"category":"Program","children":[{"range":[2,12],"category":"ExpressionStatements","children":[{"range":[2,12],"category":"Object","children":[{"range":[4,10],"category":"Pair","children":[{"range":[4,7],"category":"StringLiteral","children":[{"range":[4,5],"category":"StringLiteral"},{"range":[5,6],"category":"StringLiteral"},{"range":[6,7],"category":"StringLiteral"}]},{"patch":"replace","range":[9,10],"category":"number"}]}]}]}]}],"range":[2,12],"hasChanges":true}],[{"number":3,"terms":[{"range":[12,21],"category":"Program","children":[{"range":[12,21],"category":"ExpressionStatements","children":[{"range":[12,21],"category":"Object","children":[{"range":[14,20],"category":"Pair","children":[{"range":[14,17],"category":"StringLiteral","children":[{"range":[14,15],"category":"StringLiteral"},{"range":[15,16],"category":"StringLiteral"},{"range":[16,17],"category":"StringLiteral"}]},{"range":[19,20],"category":"number"}]}]}]}]}],"range":[12,21],"hasChanges":false},{"number":3,"terms":[{"range":[12,21],"category":"Program","children":[{"range":[12,21],"category":"ExpressionStatements","children":[{"range":[12,21],"category":"Object","children":[{"range":[14,20],"category":"Pair","children":[{"range":[14,17],"category":"StringLiteral","children":[{"range":[14,15],"category":"StringLiteral"},{"range":[15,16],"category":"StringLiteral"},{"range":[16,17],"category":"StringLiteral"}]},{"range":[19,20],"category":"number"}]}]}]}]}],"range":[12,21],"hasChanges":false}],[{"number":4,"terms":[{"range":[21,23],"category":"Program","children":[{"range":[21,23],"category":"ExpressionStatements","children":[{"range":[21,22],"category":"Object","children":[]}]}]}],"range":[21,23],"hasChanges":false},{"number":4,"terms":[{"range":[21,23],"category":"Program","children":[{"range":[21,23],"category":"ExpressionStatements","children":[{"range":[21,22],"category":"Object","children":[]}]}]}],"range":[21,23],"hasChanges":false}],[{"number":5,"terms":[{"range":[23,23],"category":"Program","children":[]}],"range":[23,23],"hasChanges":false},{"number":5,"terms":[{"range":[23,23],"category":"Program","children":[]}],"range":[23,23],"hasChanges":false}]],"oids":["",""],"paths":["test/diffs/dictionary.A.js","test/diffs/dictionary.B.js"]} \ No newline at end of file diff --git a/test/diffs/dictionary.split.js b/test/diffs/dictionary.split.js index f4d729479..74480d548 100644 --- a/test/diffs/dictionary.split.js +++ b/test/diffs/dictionary.split.js @@ -1,22 +1,22 @@ -
    1
        • console
        • .
        • log
        • (
            • '
            • hello
            • '
        • )
      • ;
    1
        • console
        • .
        • log
        • (
            • '
            • hello
            • '
        • )
      • ;
    • +
    1
        • console
        • .
        • log
        • (
            • '
            • hello
            • '
        • )
      • ;
    5
    2
        • console
        • .
        • log
        • (
            • '
            • world
            • '
        • )
      • ;
    • +
    2
        • console
        • .
        • log
        • (
            • '
            • world
            • '
        • )
      • ;
    6
        • console
        • .
        • log
        • (
            • '
            • world
            • '
        • )
      • ;
    • +
    6
        • console
        • .
        • log
        • (
            • '
            • world
            • '
        • )
      • ;
    3
      1
          • { + - - - - - - - diff --git a/test/diffs/insert.split.js b/test/diffs/insert.split.js index 32ebc47e6..04fe95e10 100644 --- a/test/diffs/insert.split.js +++ b/test/diffs/insert.split.js @@ -1,11 +1,11 @@ -
            1
                • {
            1
                • { +
            1
                • {
            2
                    • "
                    • b
                    • "
                  • :
                  • 4
                • , +
            2
                    • "
                    • b
                    • "
                  • :
                  • 4
                • ,
            2
                    • "
                    • b
                    • "
                  • :
                  • 5
                • , +
            2
                    • "
                    • b
                    • "
                  • :
                  • 5
                • ,
            3
                    • "
                    • a
                    • "
                  • :
                  • 5
                • +
            3
                    • "
                    • a
                    • "
                  • :
                  • 5
            3
                    • "
                    • a
                    • "
                  • :
                  • 5
                • +
            3
                    • "
                    • a
                    • "
                  • :
                  • 5
            4
                • }
              • +
            4
                • }
            4
                • }
              • +
            4
                • }
            5
              1
                  • console
                  • .
                  • log
                  • (
                      • '
                      • hello
                      • '
                  • )
                • ;
              • + - - diff --git a/test/diffs/multiline-insert.split.js b/test/diffs/multiline-insert.split.js index 46622452f..6d4caafc2 100644 --- a/test/diffs/multiline-insert.split.js +++ b/test/diffs/multiline-insert.split.js @@ -1,7 +1,7 @@ -
                1
                    • console
                    • .
                    • log
                    • (
                        • '
                        • hello
                        • '
                    • )
                  • ;
                1
                    • console
                    • .
                    • log
                    • (
                        • '
                        • hello
                        • '
                    • )
                  • ;
                • +
                1
                    • console
                    • .
                    • log
                    • (
                        • '
                        • hello
                        • '
                    • )
                  • ;
                2
                    • console
                    • .
                    • log
                    • (
                        • '
                        • world
                        • '
                    • )
                  • ;
                • +
                2
                    • console
                    • .
                    • log
                    • (
                        • '
                        • world
                        • '
                    • )
                  • ;
                2
                  1
                      • console
                      • .
                      • log
                      • (
                          • '
                          • hello
                          • '
                      • )
                    • ;
                  • + - @@ -9,16 +9,16 @@ - - - diff --git a/test/diffs/nested-insert.split.js b/test/diffs/nested-insert.split.js index 818b295f1..f43d38f8c 100644 --- a/test/diffs/nested-insert.split.js +++ b/test/diffs/nested-insert.split.js @@ -4,13 +4,13 @@ - - -
                    1
                        • console
                        • .
                        • log
                        • (
                            • '
                            • hello
                            • '
                        • )
                      • ;
                    1
                        • console
                        • .
                        • log
                        • (
                            • '
                            • hello
                            • '
                        • )
                      • ;
                    • +
                    1
                        • console
                        • .
                        • log
                        • (
                            • '
                            • hello
                            • '
                        • )
                      • ;
                    3
                            • console
                            • .
                            • log
                            • (
                                • '
                                • cruel
                                • '
                            • )
                          • ;
                        • +
                    3
                            • console
                            • .
                            • log
                            • (
                                • '
                                • cruel
                                • '
                            • )
                          • ;
                    4
                        • }
                    2
                        • console
                        • .
                        • log
                        • (
                            • '
                            • world
                            • '
                        • )
                      • ;
                    • +
                    2
                        • console
                        • .
                        • log
                        • (
                            • '
                            • world
                            • '
                        • )
                      • ;
                    5
                        • console
                        • .
                        • log
                        • (
                            • '
                            • world
                            • '
                        • )
                      • ;
                    • +
                    5
                        • console
                        • .
                        • log
                        • (
                            • '
                            • world
                            • '
                        • )
                      • ;
                    3
                      1
                        • if (
                        • true
                        • )
                          • {
                      2
                              • console
                              • .
                              • log
                              • (
                                  • '
                                  • hello
                                  • '
                              • )
                            • ;
                          • +
                      2
                              • console
                              • .
                              • log
                              • (
                                  • '
                                  • hello
                                  • '
                              • )
                            • ;
                      2
                              • console
                              • .
                              • log
                              • (
                                  • '
                                  • hello
                                  • '
                              • )
                            • ;
                          • +
                      2
                              • console
                              • .
                              • log
                              • (
                                  • '
                                  • hello
                                  • '
                              • )
                            • ;
                      3
                              • console
                              • .
                              • log
                              • (
                                  • '
                                  • world
                                  • '
                              • )
                            • ;
                          • +
                      3
                              • console
                              • .
                              • log
                              • (
                                  • '
                                  • world
                                  • '
                              • )
                            • ;
                      3
                          • }
                      • diff --git a/test/diffs/newline-at-eof.json.js b/test/diffs/newline-at-eof.json.js index 36e43787a..a97d2ed91 100644 --- a/test/diffs/newline-at-eof.json.js +++ b/test/diffs/newline-at-eof.json.js @@ -1 +1 @@ -{"rows":[[{"number":1,"terms":[{"range":[0,29],"category":"Program","children":[{"range":[0,28],"category":"expression_statement","children":[{"range":[0,27],"category":"MethodCall","children":[{"range":[0,7],"category":"Identifier"},{"range":[8,11],"category":"Identifier"},{"range":[12,26],"category":"Args","children":[{"range":[12,26],"category":"StringLiteral","children":[{"range":[12,13],"category":"StringLiteral"},{"range":[13,18],"category":"StringLiteral"},{"range":[18,19],"category":"StringLiteral"},{"range":[20,25],"category":"StringLiteral"},{"range":[25,26],"category":"StringLiteral"}]}]}]}]}]}],"range":[0,29],"hasChanges":false},{"number":1,"terms":[{"range":[0,29],"category":"Program","children":[{"range":[0,28],"category":"expression_statement","children":[{"range":[0,27],"category":"MethodCall","children":[{"range":[0,7],"category":"Identifier"},{"range":[8,11],"category":"Identifier"},{"range":[12,26],"category":"Args","children":[{"range":[12,26],"category":"StringLiteral","children":[{"range":[12,13],"category":"StringLiteral"},{"range":[13,18],"category":"StringLiteral"},{"range":[18,19],"category":"StringLiteral"},{"range":[20,25],"category":"StringLiteral"},{"range":[25,26],"category":"StringLiteral"}]}]}]}]}]}],"range":[0,29],"hasChanges":false}],[{"number":2,"terms":[{"range":[29,29],"category":"Program","children":[]}],"range":[29,29],"hasChanges":false},{"number":2,"terms":[{"range":[29,30],"category":"Program","children":[]}],"range":[29,30],"hasChanges":false}],[{"number":3,"terms":[{"range":[30,56],"category":"Program","children":[{"patch":"insert","range":[30,55],"category":"expression_statement","children":[{"range":[30,54],"category":"MethodCall","children":[{"range":[30,37],"category":"Identifier"},{"range":[38,41],"category":"Identifier"},{"range":[42,53],"category":"Args","children":[{"range":[42,53],"category":"StringLiteral","children":[{"range":[42,43],"category":"StringLiteral"},{"range":[43,52],"category":"StringLiteral"},{"range":[52,53],"category":"StringLiteral"}]}]}]}]}]}],"range":[30,56],"hasChanges":true}],[{"number":4,"terms":[{"range":[56,56],"category":"Program","children":[]}],"range":[56,56],"hasChanges":false}]],"oids":["",""],"paths":["test/diffs/newline-at-eof.A.js","test/diffs/newline-at-eof.B.js"]} \ No newline at end of file +{"rows":[[{"number":1,"terms":[{"range":[0,29],"category":"Program","children":[{"range":[0,28],"category":"ExpressionStatements","children":[{"range":[0,27],"category":"MethodCall","children":[{"range":[0,7],"category":"Identifier"},{"range":[8,11],"category":"Identifier"},{"range":[12,26],"category":"Args","children":[{"range":[12,26],"category":"StringLiteral","children":[{"range":[12,13],"category":"StringLiteral"},{"range":[13,18],"category":"StringLiteral"},{"range":[18,19],"category":"StringLiteral"},{"range":[20,25],"category":"StringLiteral"},{"range":[25,26],"category":"StringLiteral"}]}]}]}]}]}],"range":[0,29],"hasChanges":false},{"number":1,"terms":[{"range":[0,29],"category":"Program","children":[{"range":[0,28],"category":"ExpressionStatements","children":[{"range":[0,27],"category":"MethodCall","children":[{"range":[0,7],"category":"Identifier"},{"range":[8,11],"category":"Identifier"},{"range":[12,26],"category":"Args","children":[{"range":[12,26],"category":"StringLiteral","children":[{"range":[12,13],"category":"StringLiteral"},{"range":[13,18],"category":"StringLiteral"},{"range":[18,19],"category":"StringLiteral"},{"range":[20,25],"category":"StringLiteral"},{"range":[25,26],"category":"StringLiteral"}]}]}]}]}]}],"range":[0,29],"hasChanges":false}],[{"number":2,"terms":[{"range":[29,29],"category":"Program","children":[]}],"range":[29,29],"hasChanges":false},{"number":2,"terms":[{"range":[29,30],"category":"Program","children":[]}],"range":[29,30],"hasChanges":false}],[{"number":3,"terms":[{"range":[30,56],"category":"Program","children":[{"patch":"insert","range":[30,55],"category":"ExpressionStatements","children":[{"range":[30,54],"category":"MethodCall","children":[{"range":[30,37],"category":"Identifier"},{"range":[38,41],"category":"Identifier"},{"range":[42,53],"category":"Args","children":[{"range":[42,53],"category":"StringLiteral","children":[{"range":[42,43],"category":"StringLiteral"},{"range":[43,52],"category":"StringLiteral"},{"range":[52,53],"category":"StringLiteral"}]}]}]}]}]}],"range":[30,56],"hasChanges":true}],[{"number":4,"terms":[{"range":[56,56],"category":"Program","children":[]}],"range":[56,56],"hasChanges":false}]],"oids":["",""],"paths":["test/diffs/newline-at-eof.A.js","test/diffs/newline-at-eof.B.js"]} \ No newline at end of file diff --git a/test/diffs/newline-at-eof.split.js b/test/diffs/newline-at-eof.split.js index a648bae01..220e3f673 100644 --- a/test/diffs/newline-at-eof.split.js +++ b/test/diffs/newline-at-eof.split.js @@ -1,7 +1,7 @@ -
                        1
                            • console
                            • .
                            • log
                            • (
                                • "
                                • hello
                                • ,
                                • world
                                • "
                            • )
                          • ;
                        • + - @@ -9,7 +9,7 @@ - diff --git a/test/diffs/no-newline-at-eof.json.js b/test/diffs/no-newline-at-eof.json.js index bd108ca0a..dc8992a2d 100644 --- a/test/diffs/no-newline-at-eof.json.js +++ b/test/diffs/no-newline-at-eof.json.js @@ -1 +1 @@ -{"rows":[[{"number":1,"terms":[{"range":[0,28],"category":"Program","children":[{"range":[0,28],"category":"expression_statement","children":[{"range":[0,27],"category":"MethodCall","children":[{"range":[0,7],"category":"Identifier"},{"range":[8,11],"category":"Identifier"},{"range":[12,26],"category":"Args","children":[{"range":[12,26],"category":"StringLiteral","children":[{"range":[12,13],"category":"StringLiteral"},{"range":[13,18],"category":"StringLiteral"},{"range":[18,19],"category":"StringLiteral"},{"range":[20,25],"category":"StringLiteral"},{"range":[25,26],"category":"StringLiteral"}]}]}]}]}]}],"range":[0,28],"hasChanges":false},{"number":1,"terms":[{"range":[0,29],"category":"Program","children":[{"range":[0,28],"category":"expression_statement","children":[{"range":[0,27],"category":"MethodCall","children":[{"range":[0,7],"category":"Identifier"},{"range":[8,11],"category":"Identifier"},{"range":[12,26],"category":"Args","children":[{"range":[12,26],"category":"StringLiteral","children":[{"range":[12,13],"category":"StringLiteral"},{"range":[13,18],"category":"StringLiteral"},{"range":[18,19],"category":"StringLiteral"},{"range":[20,25],"category":"StringLiteral"},{"range":[25,26],"category":"StringLiteral"}]}]}]}]}]}],"range":[0,29],"hasChanges":false}],[{"number":2,"terms":[{"range":[29,30],"category":"Program","children":[]}],"range":[29,30],"hasChanges":false}],[{"number":3,"terms":[{"range":[30,55],"category":"Program","children":[{"patch":"insert","range":[30,55],"category":"expression_statement","children":[{"range":[30,54],"category":"MethodCall","children":[{"range":[30,37],"category":"Identifier"},{"range":[38,41],"category":"Identifier"},{"range":[42,53],"category":"Args","children":[{"range":[42,53],"category":"StringLiteral","children":[{"range":[42,43],"category":"StringLiteral"},{"range":[43,52],"category":"StringLiteral"},{"range":[52,53],"category":"StringLiteral"}]}]}]}]}]}],"range":[30,55],"hasChanges":true}]],"oids":["",""],"paths":["test/diffs/no-newline-at-eof.A.js","test/diffs/no-newline-at-eof.B.js"]} \ No newline at end of file +{"rows":[[{"number":1,"terms":[{"range":[0,28],"category":"Program","children":[{"range":[0,28],"category":"ExpressionStatements","children":[{"range":[0,27],"category":"MethodCall","children":[{"range":[0,7],"category":"Identifier"},{"range":[8,11],"category":"Identifier"},{"range":[12,26],"category":"Args","children":[{"range":[12,26],"category":"StringLiteral","children":[{"range":[12,13],"category":"StringLiteral"},{"range":[13,18],"category":"StringLiteral"},{"range":[18,19],"category":"StringLiteral"},{"range":[20,25],"category":"StringLiteral"},{"range":[25,26],"category":"StringLiteral"}]}]}]}]}]}],"range":[0,28],"hasChanges":false},{"number":1,"terms":[{"range":[0,29],"category":"Program","children":[{"range":[0,28],"category":"ExpressionStatements","children":[{"range":[0,27],"category":"MethodCall","children":[{"range":[0,7],"category":"Identifier"},{"range":[8,11],"category":"Identifier"},{"range":[12,26],"category":"Args","children":[{"range":[12,26],"category":"StringLiteral","children":[{"range":[12,13],"category":"StringLiteral"},{"range":[13,18],"category":"StringLiteral"},{"range":[18,19],"category":"StringLiteral"},{"range":[20,25],"category":"StringLiteral"},{"range":[25,26],"category":"StringLiteral"}]}]}]}]}]}],"range":[0,29],"hasChanges":false}],[{"number":2,"terms":[{"range":[29,30],"category":"Program","children":[]}],"range":[29,30],"hasChanges":false}],[{"number":3,"terms":[{"range":[30,55],"category":"Program","children":[{"patch":"insert","range":[30,55],"category":"ExpressionStatements","children":[{"range":[30,54],"category":"MethodCall","children":[{"range":[30,37],"category":"Identifier"},{"range":[38,41],"category":"Identifier"},{"range":[42,53],"category":"Args","children":[{"range":[42,53],"category":"StringLiteral","children":[{"range":[42,43],"category":"StringLiteral"},{"range":[43,52],"category":"StringLiteral"},{"range":[52,53],"category":"StringLiteral"}]}]}]}]}]}],"range":[30,55],"hasChanges":true}]],"oids":["",""],"paths":["test/diffs/no-newline-at-eof.A.js","test/diffs/no-newline-at-eof.B.js"]} \ No newline at end of file diff --git a/test/diffs/no-newline-at-eof.split.js b/test/diffs/no-newline-at-eof.split.js index 135895541..9643db481 100644 --- a/test/diffs/no-newline-at-eof.split.js +++ b/test/diffs/no-newline-at-eof.split.js @@ -1,6 +1,6 @@ -
                          1
                              • console
                              • .
                              • log
                              • (
                                  • "
                                  • hello
                                  • ,
                                  • world
                                  • "
                              • )
                            • ;
                          1
                              • console
                              • .
                              • log
                              • (
                                  • "
                                  • hello
                                  • ,
                                  • world
                                  • "
                              • )
                            • ;
                          • +
                          1
                              • console
                              • .
                              • log
                              • (
                                  • "
                                  • hello
                                  • ,
                                  • world
                                  • "
                              • )
                            • ;
                          2
                            3
                                • console
                                • .
                                • log
                                • (
                                    • "
                                    • insertion
                                    • "
                                • )
                              • ;
                            • +
                            3
                                • console
                                • .
                                • log
                                • (
                                    • "
                                    • insertion
                                    • "
                                • )
                              • ;
                            -
                            1
                                • console
                                • .
                                • log
                                • (
                                    • "
                                    • hello
                                    • ,
                                    • world
                                    • "
                                • )
                              • ;
                            1
                                • console
                                • .
                                • log
                                • (
                                    • "
                                    • hello
                                    • ,
                                    • world
                                    • "
                                • )
                              • ;
                            • + + @@ -8,6 +8,6 @@ - +
                              1
                                  • console
                                  • .
                                  • log
                                  • (
                                      • "
                                      • hello
                                      • ,
                                      • world
                                      • "
                                  • )
                                • ;
                              1
                                  • console
                                  • .
                                  • log
                                  • (
                                      • "
                                      • hello
                                      • ,
                                      • world
                                      • "
                                  • )
                                • ;
                              3
                                  • console
                                  • .
                                  • log
                                  • (
                                      • "
                                      • insertion
                                      • "
                                  • )
                                • ;
                              3
                                  • console
                                  • .
                                  • log
                                  • (
                                      • "
                                      • insertion
                                      • "
                                  • )
                                • ;
                              \ No newline at end of file diff --git a/test/diffs/reformat.split.js b/test/diffs/reformat.split.js index 95f6033f6..2b799ebb2 100644 --- a/test/diffs/reformat.split.js +++ b/test/diffs/reformat.split.js @@ -1,13 +1,13 @@ - - - + - +
                              1
                                  • [ +
                              1
                                  • [
                              1
                                  • [
                                  • bar
                                  • ]
                                • ;
                              2
                                  • bar
                                  • +
                              1
                                  • [
                                  • bar
                                  • ]
                                • ;
                              2
                                  • bar
                              3
                                  • ]
                                • ;
                              3
                                  • ]
                                • ;
                              \ No newline at end of file From 044aa782c107421afee5fc86317a7a41a1f6153c Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 14:04:15 -0400 Subject: [PATCH 101/320] partially apply isBranchNode --- src/DiffSummary.hs | 1 - test/DiffSummarySpec.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 2ed418747..0b66527d4 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds, TypeFamilies, ScopedTypeVariables #-} - module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..), annotatedSummaries) where import Prologue hiding (snd, intercalate) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 88e675763..ab12b5546 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -100,4 +100,4 @@ isBranchInfo info = case info of (LeafInfo _ _) -> False isBranchNode :: Patch DiffInfo -> Bool -isBranchNode patch = any isBranchInfo +isBranchNode = any isBranchInfo From cfb7361b9c424088ef589362df2b65ddb3772d72 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 14:44:25 -0400 Subject: [PATCH 102/320] Scale the list generator. --- test/Data/Mergeable/Spec.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index d9b38ff33..9f51c3994 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -12,8 +12,9 @@ import Test.QuickCheck spec :: Spec spec = parallel $ do describe "[]" $ do - withAlternativeInstances sequenceAltLaws (arbitrary :: Gen [Char]) - withAlternativeInstances mergeLaws (arbitrary :: Gen [Char]) + let gen = scale (`div` 25) arbitrary :: Gen [Char] + withAlternativeInstances sequenceAltLaws gen + withAlternativeInstances mergeLaws gen describe "Maybe" $ do withAlternativeInstances sequenceAltLaws (arbitrary :: Gen (Maybe Char)) withAlternativeInstances mergeLaws (arbitrary :: Gen (Maybe Char)) From be82432aa028243c3b9e01d3cb94faef6b1e5690 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 14:49:14 -0400 Subject: [PATCH 103/320] Add an error JSON case --- src/Renderer/JSON.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index a2ad3cb81..515e7b245 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -85,6 +85,7 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.Pair a b -> childrenFields [a, b] S.Comment _ -> [] S.Commented comments child -> childrenFields (comments <> maybeToList child) + S.Error c -> childrenFields c where childrenFields c = [ "children" .= c ] patchFields :: (KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (Term leaf (Record fields)) -> [kv] From 20899ce9acd6c54d027bed8d3ebc12c371e2be3a Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 14:51:15 -0400 Subject: [PATCH 104/320] Add an Error case to Alignment --- src/Alignment.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Alignment.hs b/src/Alignment.hs index 6745ee8cf..1d5e26476 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -66,6 +66,8 @@ alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = case syntax Comment a -> catMaybes $ wrapInBranch (const (Comment a)) . fmap (flip (,) []) <$> (Join <$> bisequenceL (runJoin lineRanges)) Indexed children -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges + Syntax.Error children -> + catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges Syntax.Function id params body -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (fromMaybe [] id <> fromMaybe [] params <> body) bothRanges -- Align FunctionCalls like Indexed nodes by appending identifier to its children. Syntax.FunctionCall identifier children -> From dd0b0322fc261b85180988b41f17aed9115c0a15 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 14:56:02 -0400 Subject: [PATCH 105/320] Add a property demonstrating the relationship between `sequenceAlt` over `[Maybe a]` & `pure . catMaybes`. --- test/Data/Mergeable/Spec.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index 9f51c3994..cd0013246 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -25,6 +25,9 @@ spec = parallel $ do withAlternativeInstances sequenceAltLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char)) withAlternativeInstances mergeLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char)) + prop "subsumes catMaybes/Just" $ do + \ a -> sequenceAlt a `shouldBe` pure (catMaybes (a :: [Maybe Char])) + mergeLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec mergeLaws value function = describe "merge" $ do prop "identity" . forAll value $ From b2006ef63778cfca89d349b015774d7006229f19 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 15:08:41 -0400 Subject: [PATCH 106/320] Make termConstructor total --- src/Parser.hs | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index 0300391d2..ffdba5de4 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -31,38 +31,41 @@ termConstructor :: forall fields. (Show (Record fields), HasField fields Categor termConstructor source info = cofree . construct where withDefaultInfo syntax = (info :< syntax) - withErrorInfo syntax = (setCategory info C.Error :< syntax) construct :: (Show (Record fields), HasField fields Category, HasField fields Range) => [Term Text (Record fields)] -> CofreeF (S.Syntax Text) (Record fields) (Term Text (Record fields)) construct [] = withDefaultInfo . S.Leaf . pack . toString $ slice (characterRange info) source construct children | Assignment == category info = case children of (identifier:value:[]) -> withDefaultInfo $ S.Assignment identifier value + children -> withDefaultInfo $ S.Error children construct children | MathAssignment == category info = case children of (identifier:value:[]) -> withDefaultInfo $ S.MathAssignment identifier value + children -> withDefaultInfo $ S.Error children construct children | MemberAccess == category info = case children of (base:property:[]) -> withDefaultInfo $ S.MemberAccess base property - children -> withErrorInfo $ S.Error children + children -> withDefaultInfo $ S.Error children construct children | SubscriptAccess == category info = case children of (base:element:[]) -> withDefaultInfo $ S.SubscriptAccess base element + _ -> withDefaultInfo $ S.Error children construct children | Operator == category info = withDefaultInfo $ S.Operator children - construct children | Function == category info = withDefaultInfo $ case children of - (body:[]) -> S.Function Nothing Nothing body + construct children | Function == category info = case children of + (body:[]) -> withDefaultInfo $ S.Function Nothing Nothing body (params:body:[]) | (info :< _) <- runCofree params, Params == category info -> - S.Function Nothing (Just params) body + withDefaultInfo $ S.Function Nothing (Just params) body (id:body:[]) | (info :< _) <- runCofree id, Identifier == category info -> - S.Function (Just id) Nothing body + withDefaultInfo $ S.Function (Just id) Nothing body (id:params:body:[]) | (info :< _) <- runCofree id, Identifier == category info -> - S.Function (Just id) (Just params) body - x -> error $ "Expected a function declaration but got: " <> show x + withDefaultInfo $ S.Function (Just id) (Just params) body + _ -> withDefaultInfo $ S.Error children construct children | FunctionCall == category info = case runCofree <$> children of [ (_ :< S.MemberAccess{..}), params@(_ :< S.Args{}) ] -> setCategory info MethodCall :< S.MethodCall memberId property (cofree params) (x:xs) -> withDefaultInfo $ S.FunctionCall (cofree x) (cofree <$> xs) + _ -> withDefaultInfo $ S.Error children construct children | Ternary == category info = case children of (condition:cases) -> withDefaultInfo $ S.Ternary condition cases - + _ -> withDefaultInfo $ S.Error children construct children | Args == category info = withDefaultInfo $ S.Args children construct children | VarAssignment == category info , [x, y] <- children = withDefaultInfo $ S.VarAssignment x y @@ -83,6 +86,7 @@ termConstructor source info = cofree . construct toTuple child | S.Indexed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)] toTuple child | S.Fixed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)] toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)] + toTuple child = pure child construct children | isFixed (category info) = withDefaultInfo $ S.Fixed children construct children = From 475ec475b6483fc848898807496cfe60bd81e059 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 15:27:16 -0400 Subject: [PATCH 107/320] Weaken the identity laws to be non-empty. --- test/Data/Mergeable/Spec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index cd0013246..ab0f5ae4a 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -31,7 +31,7 @@ spec = parallel $ do mergeLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec mergeLaws value function = describe "merge" $ do prop "identity" . forAll value $ - \ a -> merge pure a `shouldBe` (pure a :: g (f a)) + \ a -> merge pure a `shouldNotBe` (empty :: g (f a)) let pair = (,) <$> value <*> function prop "relationship with sequenceAlt" . forAll pair $ @@ -41,7 +41,7 @@ sequenceAltLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show sequenceAltLaws value function = do describe "sequenceAlt" $ do prop "identity" . forAll value $ - \ a -> sequenceAlt (pure <$> a) `shouldBe` (pure a :: g (f a)) + \ a -> sequenceAlt (pure <$> a) `shouldNotBe` (empty :: g (f a)) prop "relationship with merge" . forAll (Blind <$> (fmap . getBlind <$> function <*> value) :: Gen (Blind (f (g a)))) $ \ a -> sequenceAlt (getBlind a) `shouldBe` merge identity (getBlind a) From e5f9d1ed2847dd673e7bac806cc297f1d0acd12a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 15:27:32 -0400 Subject: [PATCH 108/320] Test the Mergeable laws over lists. --- test/Data/Mergeable/Spec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/Data/Mergeable/Spec.hs b/test/Data/Mergeable/Spec.hs index ab0f5ae4a..f03092baa 100644 --- a/test/Data/Mergeable/Spec.hs +++ b/test/Data/Mergeable/Spec.hs @@ -49,4 +49,5 @@ sequenceAltLaws value function = do withAlternativeInstances :: forall f a. (Arbitrary a, CoArbitrary a, Eq (f a), Show (f a)) => (forall g. (Alternative g, Eq (g (f a)), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec) -> Gen (f a) -> Spec withAlternativeInstances laws gen = do + describe "[]" $ laws gen (scale (`div` 25) (arbitrary :: Gen (Blind (a -> [a])))) describe "Maybe" $ laws gen (arbitrary :: Gen (Blind (a -> Maybe a))) From fd6b44e1a8ac9186637dc217f2812617e2491e4a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 15:32:30 -0400 Subject: [PATCH 109/320] This should probably be non-empty. --- src/Data/Mergeable/Generic.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Mergeable/Generic.hs b/src/Data/Mergeable/Generic.hs index 3d7bd0649..a9bb83d89 100644 --- a/src/Data/Mergeable/Generic.hs +++ b/src/Data/Mergeable/Generic.hs @@ -43,4 +43,4 @@ instance GMergeable [] where instance GMergeable Maybe where gmerge f (Just a) = Just <$> f a - gmerge _ Nothing = empty + gmerge _ Nothing = pure empty From 0656543b3843b59b2b2108a18b38bbea0c8a1014 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 15:35:28 -0400 Subject: [PATCH 110/320] :memo: Mergeable. --- src/Data/Mergeable.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Data/Mergeable.hs b/src/Data/Mergeable.hs index 2ce8bc030..dc50657fe 100644 --- a/src/Data/Mergeable.hs +++ b/src/Data/Mergeable.hs @@ -8,11 +8,16 @@ import Prologue -- Classes +-- | A 'Mergeable' functor is one which supports pushing itself through an 'Alternative' functor. Note the similarities with 'Traversable' & 'Crosswalk'. +-- +-- This is a kind of distributive law which produces (at least) the union of the two functors’ shapes; i.e. unlike 'Traversable', an 'empty' value in the inner functor does not produce an 'empty' result, and unlike 'Crosswalk', an 'empty' value in the outer functor does not produce an 'empty' result. class Functor t => Mergeable t where + -- | Merge a functor by mapping its elements into an 'Alternative' functor, combining them, and pushing the 'Mergeable' functor inside. merge :: Alternative f => (a -> f b) -> t a -> f (t b) default merge :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => (a -> f b) -> t a -> f (t b) merge = genericMerge + -- | Sequnce a 'Mergeable' functor by 'merge'ing the 'Alternative' values. sequenceAlt :: Alternative f => t (f a) -> f (t a) sequenceAlt = merge identity From 5eece699947995c2733661fb9b58831c921ce4f3 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 16:29:46 -0400 Subject: [PATCH 111/320] Use any --- test/DiffSummarySpec.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index ab12b5546..be46cceb7 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -83,10 +83,7 @@ spec = parallel $ do length listOfLeaves `shouldBe` length listOfDiffLeaves isIndexedOrFixed :: Patch (Term a annotation) -> Bool -isIndexedOrFixed patch = case unwrap <$> patch of - (Insert syntax) -> isIndexedOrFixed' syntax - (Delete syntax) -> isIndexedOrFixed' syntax - (Replace s1 s2) -> isIndexedOrFixed' s1 || isIndexedOrFixed' s2 +isIndexedOrFixed = any isIndexedOrFixed' isIndexedOrFixed' :: Syntax a f -> Bool isIndexedOrFixed' syntax = case syntax of From b703c5aa6e5dfebb6acb09c368c14a4bc9f4c085 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 16:29:59 -0400 Subject: [PATCH 112/320] Construct Error nodes as well --- src/Parser.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Parser.hs b/src/Parser.hs index ffdba5de4..3862316a2 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -89,5 +89,7 @@ termConstructor source info = cofree . construct toTuple child = pure child construct children | isFixed (category info) = withDefaultInfo $ S.Fixed children + construct children | C.Error == category info = + withDefaultInfo $ S.Error children construct children = withDefaultInfo $ S.Indexed children From 804a8457a555257d3f313665b1b5f63177a15674 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 16:30:12 -0400 Subject: [PATCH 113/320] ++js-test for errors.js --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 8747ef248..b08d03e94 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 8747ef2483104c72b468cbb2eede87956014c70e +Subproject commit b08d03e94379cf23613e54715f1ab3b79f6f52cb From 4bd4a93a0c04cdc8576ead22bfd4a68501842311 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 16:34:28 -0400 Subject: [PATCH 114/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index b08d03e94..6cd5009c5 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit b08d03e94379cf23613e54715f1ab3b79f6f52cb +Subproject commit 6cd5009c55addfb95f823c2c2b9be805e8dc68f8 From b5b33917865cbe9f8f9ee7ebf1f579405159ff50 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 26 Jul 2016 16:44:33 -0400 Subject: [PATCH 115/320] add missing unwrap --- test/DiffSummarySpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index be46cceb7..de561d4be 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -83,7 +83,7 @@ spec = parallel $ do length listOfLeaves `shouldBe` length listOfDiffLeaves isIndexedOrFixed :: Patch (Term a annotation) -> Bool -isIndexedOrFixed = any isIndexedOrFixed' +isIndexedOrFixed = any (isIndexedOrFixed' . unwrap) isIndexedOrFixed' :: Syntax a f -> Bool isIndexedOrFixed' syntax = case syntax of From 7f4c97a9a0fdd07e74f8a57f6b8844dfb71ba58e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 23:32:48 -0400 Subject: [PATCH 116/320] Add an example to the docs for `Mergeable`. --- src/Data/Mergeable.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Data/Mergeable.hs b/src/Data/Mergeable.hs index dc50657fe..647e2065d 100644 --- a/src/Data/Mergeable.hs +++ b/src/Data/Mergeable.hs @@ -11,6 +11,12 @@ import Prologue -- | A 'Mergeable' functor is one which supports pushing itself through an 'Alternative' functor. Note the similarities with 'Traversable' & 'Crosswalk'. -- -- This is a kind of distributive law which produces (at least) the union of the two functors’ shapes; i.e. unlike 'Traversable', an 'empty' value in the inner functor does not produce an 'empty' result, and unlike 'Crosswalk', an 'empty' value in the outer functor does not produce an 'empty' result. +-- +-- For example, we can use 'merge' to select one side or the other of a diff node in 'Syntax', while correctly handling the fact that some patches don’t have any content for that side: +-- +-- @ +-- let before = iter (\ (a :< s) -> sequenceAlt (cofree . (fst a :<)) syntax) . fmap (maybeFst . unPatch) +-- @ class Functor t => Mergeable t where -- | Merge a functor by mapping its elements into an 'Alternative' functor, combining them, and pushing the 'Mergeable' functor inside. merge :: Alternative f => (a -> f b) -> t a -> f (t b) From 1a4314bd387d16c6e2af12ca816be0ef0676358a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Jul 2016 23:35:12 -0400 Subject: [PATCH 117/320] Correct the doc example. --- src/Data/Mergeable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Mergeable.hs b/src/Data/Mergeable.hs index 647e2065d..8cf9ae965 100644 --- a/src/Data/Mergeable.hs +++ b/src/Data/Mergeable.hs @@ -15,7 +15,7 @@ import Prologue -- For example, we can use 'merge' to select one side or the other of a diff node in 'Syntax', while correctly handling the fact that some patches don’t have any content for that side: -- -- @ --- let before = iter (\ (a :< s) -> sequenceAlt (cofree . (fst a :<)) syntax) . fmap (maybeFst . unPatch) +-- let before = iter (\ (a :< s) -> cofree . (fst a :<) <$> sequenceAlt syntax) . fmap (maybeFst . unPatch) -- @ class Functor t => Mergeable t where -- | Merge a functor by mapping its elements into an 'Alternative' functor, combining them, and pushing the 'Mergeable' functor inside. From b912b89b9639063e1b89024de871bb00bd37d0e8 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 27 Jul 2016 12:28:37 -0400 Subject: [PATCH 118/320] Return ErrorInfos from termToDiffInfo --- src/DiffSummary.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 9fed469b0..5013da9de 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -20,6 +20,7 @@ import qualified Text.PrettyPrint.Leijen.Text as P data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text } | BranchInfo { branches :: [ DiffInfo ], categoryName :: Text, branchType :: Branch } + | ErrorInfo { branches :: [ DiffInfo ], categoryName :: Text } deriving (Eq, Show) toTermName :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> Text @@ -103,7 +104,7 @@ instance HasCategory Category where instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract -data Branch = BIndexed | BFixed | BCommented | BError deriving (Show, Eq, Generic) +data Branch = BIndexed | BFixed | BCommented deriving (Show, Eq, Generic) instance Arbitrary Branch where arbitrary = oneof [ pure BIndexed, pure BFixed ] shrink = genericShrink @@ -120,6 +121,7 @@ instance (Eq a, Arbitrary a) => Arbitrary (DiffSummary a) where instance P.Pretty DiffInfo where pretty LeafInfo{..} = squotes (string $ toSL termName) <+> (string $ toSL categoryName) pretty BranchInfo{..} = mconcat $ punctuate (string "," <> space) (pretty <$> branches) + pretty ErrorInfo{..} = (mconcat $ punctuate (string "," <> space) (pretty <$> branches)) <+> (string $ toSL categoryName) <+> "syntax error" annotatedSummaries :: DiffSummary DiffInfo -> [Text] annotatedSummaries DiffSummary{..} = show . (P.<> maybeParentContext parentAnnotations) <$> summaries patch @@ -130,8 +132,9 @@ summaries (Delete info) = (("Deleted" <+> "the") <+>) <$> toLeafInfos info summaries (Replace i1 i2) = zipWith (\a b -> "Replaced" <+> "the" <+> a <+> "with the" <+> b) (toLeafInfos i1) (toLeafInfos i2) toLeafInfos :: DiffInfo -> [Doc] -toLeafInfos LeafInfo{..} = [ squotes (toDoc termName) <+> (toDoc categoryName) ] +toLeafInfos LeafInfo{..} = pure $ squotes (toDoc termName) <+> (toDoc categoryName) toLeafInfos BranchInfo{..} = pretty <$> branches +toLeafInfos err@ErrorInfo{} = pure $ pretty err maybeParentContext :: [Category] -> Doc maybeParentContext annotations = if null annotations @@ -184,7 +187,7 @@ termToDiffInfo term = case unwrap term of -- to indicate where that value should be when constructing DiffInfos. S.Operator _ -> LeafInfo (toCategoryName term) "x" Commented cs leaf -> BranchInfo (termToDiffInfo <$> cs <> maybeToList leaf) (toCategoryName term) BCommented - S.Error children -> BranchInfo (termToDiffInfo <$> children) (toCategoryName term) BError + S.Error children -> ErrorInfo (termToDiffInfo <$> children) (toCategoryName term) _ -> LeafInfo (toCategoryName term) (toTermName term) prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo From ae4142ad7c777d0917582b7e6e9456605bf89a27 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 27 Jul 2016 17:15:09 -0400 Subject: [PATCH 119/320] Add SourceSpan module --- semantic-diff.cabal | 1 + src/Info.hs | 7 +++++ src/SourceSpan.hs | 71 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 79 insertions(+) create mode 100644 src/SourceSpan.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 7f0d8dce1..cd8817ed0 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -40,6 +40,7 @@ library , Renderer.Summary , SES , Source + , SourceSpan , SplitDiff , Syntax , Term diff --git a/src/Info.hs b/src/Info.hs index 5c7b8223d..a4b5d7896 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -5,11 +5,18 @@ import Data.Record import Prologue import Category import Range +import SourceSpan import Test.QuickCheck newtype Cost = Cost { unCost :: Integer } deriving (Eq, Num, Ord, Show) +sourceSpan :: HasField fields SourceSpan => Record fields -> SourceSpan +sourceSpan = getField + +setSourceSpan :: HasField fields SourceSpan => Record fields -> SourceSpan -> Record fields +setSourceSpan = setField + characterRange :: HasField fields Range => Record fields -> Range characterRange = getField diff --git a/src/SourceSpan.hs b/src/SourceSpan.hs new file mode 100644 index 000000000..ba68d0b22 --- /dev/null +++ b/src/SourceSpan.hs @@ -0,0 +1,71 @@ +-- | +-- Source position and span information +-- +module SourceSpan where + +import Prologue +import Data.Aeson ((.=), (.:)) +import qualified Data.Aeson as A + +-- | +-- Source position information +-- +data SourcePos = SourcePos + { -- | + -- Line number + -- + line :: !Int + -- | + -- Column number + -- + , column :: !Int + } deriving (Show, Read, Eq, Ord) + +displaySourcePos :: SourcePos -> Text +displaySourcePos sp = + "line " <> show (line sp) <> ", column " <> show (column sp) + +instance A.ToJSON SourcePos where + toJSON SourcePos{..} = + A.toJSON [line, column] + +instance A.FromJSON SourcePos where + parseJSON arr = do + [line, col] <- A.parseJSON arr + pure $ SourcePos line col + +data SourceSpan = SourceSpan + { -- | + -- Source name + -- + spanName :: !Text + -- | + -- Start of the span + -- + , spanStart :: !SourcePos + -- End of the span + -- + , spanEnd :: !SourcePos + } deriving (Show, Read, Eq, Ord) + +displayStartEndPos :: SourceSpan -> Text +displayStartEndPos sp = + displaySourcePos (spanStart sp) <> " - " <> displaySourcePos (spanEnd sp) + +displaySourceSpan :: SourceSpan -> Text +displaySourceSpan sp = + spanName sp <> " " <> displayStartEndPos sp + +instance A.ToJSON SourceSpan where + toJSON SourceSpan{..} = + A.object [ "name" .= spanName + , "start" .= spanStart + , "end" .= spanEnd + ] + +instance A.FromJSON SourceSpan where + parseJSON = A.withObject "SourceSpan" $ \o -> + SourceSpan <$> + o .: "name" <*> + o .: "start" <*> + o .: "end" From 2bd4e0993a1912ed62d449859260030b7ba061d2 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 27 Jul 2016 17:42:55 -0400 Subject: [PATCH 120/320] ++tree-sitter-parsers --- vendor/tree-sitter-parsers | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/tree-sitter-parsers b/vendor/tree-sitter-parsers index 36a5a0fc1..0fdcbafdb 160000 --- a/vendor/tree-sitter-parsers +++ b/vendor/tree-sitter-parsers @@ -1 +1 @@ -Subproject commit 36a5a0fc1ff4990f34842a27bc9c6cb0d181a50e +Subproject commit 0fdcbafdb69853a03db28e789bb00a2f733c6990 From c7d7ee51aac7a35b06d9725223e0f9b3fbb962f2 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 27 Jul 2016 18:11:55 -0400 Subject: [PATCH 121/320] Keep track of source spans --- src/Diffing.hs | 17 ++++++++++------- src/Info.hs | 2 +- src/Parser.hs | 2 +- src/TreeSitter.hs | 18 ++++++++++-------- 4 files changed, 22 insertions(+), 17 deletions(-) diff --git a/src/Diffing.hs b/src/Diffing.hs index e42017c7a..02f13238f 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -32,9 +32,10 @@ import Term import TreeSitter import Text.Parser.TreeSitter.Language import qualified Data.Text as T +import SourceSpan -- | Return a parser based on the file extension (including the "."). -parserForType :: Text -> Parser '[Range, Category, Cost] +parserForType :: Text -> Parser '[Range, Category, Cost, SourceSpan] parserForType mediaType = case languageForType mediaType of Just C -> treeSitterParser C ts_language_c Just JavaScript -> treeSitterParser JavaScript ts_language_javascript @@ -42,20 +43,22 @@ parserForType mediaType = case languageForType mediaType of _ -> lineByLineParser -- | A fallback parser that treats a file simply as rows of strings. -lineByLineParser :: Parser '[Range, Category, Cost] -lineByLineParser input = pure . cofree . root $ case foldl' annotateLeaves ([], 0) lines of +lineByLineParser :: Parser '[Range, Category, Cost, SourceSpan] +lineByLineParser blob = pure . cofree . root $ case foldl' annotateLeaves ([], 0) lines of (leaves, _) -> cofree <$> leaves where + input = source blob lines = actualLines input + rootSpan = SourceSpan (toS $ path blob) (SourcePos 0 0) (SourcePos (length lines) (maybe 0 length $ lastMay lines)) root children = let cost = 1 + fromIntegral (length children) in - ((Range 0 $ length input) .: Other "program" .: cost .: RNil) :< Indexed children - leaf charIndex line = ((Range charIndex $ charIndex + T.length line) .: Other "program" .: 1 .: RNil) :< Leaf line + ((Range 0 $ length input) .: Other "program" .: cost .: rootSpan.: RNil) :< Indexed children + leaf charIndex line = ((Range charIndex $ charIndex + T.length line) .: Other "program" .: 1 .: rootSpan .: RNil) :< Leaf line annotateLeaves (accum, charIndex) line = (accum <> [ leaf charIndex (toText line) ] , charIndex + length line) toText = T.pack . Source.toString -- | Return the parser that should be used for a given path. -parserForFilepath :: FilePath -> Parser '[Range, Category, Cost] +parserForFilepath :: FilePath -> Parser '[Range, Category, Cost, SourceSpan] parserForFilepath = parserForType . toS . takeExtension -- | Replace every string leaf with leaves of the words in the string. @@ -90,7 +93,7 @@ readAndTranscodeFile path = do diffFiles :: (HasField fields Category, HasField fields Cost, HasField fields Range, Eq (Record fields)) => Parser fields -> Renderer (Record fields) -> Both SourceBlob -> IO Text diffFiles parser renderer sourceBlobs = do let sources = source <$> sourceBlobs - terms <- sequence $ parser <$> sources + terms <- sequence $ parser <$> sourceBlobs let replaceLeaves = breakDownLeavesByWord <$> sources let areNullOids = runBothWith (\a b -> (oid a == nullOid || null (source a), oid b == nullOid || null (source b))) sourceBlobs diff --git a/src/Info.hs b/src/Info.hs index a4b5d7896..fad3e44af 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-} -module Info where +module Info (SourceSpan, sourceSpan, setSourceSpan, characterRange, setCharacterRange, category, setCategory, Cost(..), cost, setCost) where import Data.Record import Prologue diff --git a/src/Parser.hs b/src/Parser.hs index 3862316a2..96a12b7f7 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -15,7 +15,7 @@ import Source -- | A function that takes a source file and returns an annotated AST. -- | The return is in the IO monad because some of the parsers are written in C -- | and aren't pure. -type Parser fields = Source Char -> IO (Term Text (Record fields)) +type Parser fields = SourceBlob -> IO (Term Text (Record fields)) -- | Categories that are treated as fixed nodes. fixedCategories :: Set.Set Category diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index fc54f9b51..a44ce1939 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -13,16 +13,17 @@ import Foreign import Foreign.C.String import Text.Parser.TreeSitter hiding (Language(..)) import qualified Text.Parser.TreeSitter as TS +import SourceSpan -- | Returns a TreeSitter parser for the given language and TreeSitter grammar. -treeSitterParser :: Language -> Ptr TS.Language -> Parser '[Range, Category, Cost] -treeSitterParser language grammar contents = do +treeSitterParser :: Language -> Ptr TS.Language -> Parser '[Range, Category, Cost, SourceSpan] +treeSitterParser language grammar blob = do document <- ts_document_make ts_document_set_language document grammar - withCString (toString contents) (\source -> do + withCString (toString $ source blob) (\source -> do ts_document_set_input_string document source ts_document_parse document - term <- documentToTerm language document contents + term <- documentToTerm language document blob ts_document_free document pure term) @@ -78,8 +79,8 @@ defaultCategoryForNodeName name = case name of _ -> Other name -- | Return a parser for a tree sitter language & document. -documentToTerm :: Language -> Ptr Document -> Parser '[Range, Category, Cost] -documentToTerm language document contents = alloca $ \ root -> do +documentToTerm :: Language -> Ptr Document -> Parser '[Range, Category, Cost, SourceSpan] +documentToTerm language document blob = alloca $ \ root -> do ts_document_root_node_p document root toTerm root where toTerm node = do @@ -89,10 +90,11 @@ documentToTerm language document contents = alloca $ \ root -> do children <- traverse (alloca . getChild node) $ take (fromIntegral count) [0..] -- Note: The strict application here is semantically important. Without it, we may not evaluate the range until after we’ve exited the scope that `node` was allocated within, meaning `alloca` will free it & other stack data may overwrite it. range <- pure $! Range { start = fromIntegral $ ts_node_p_start_char node, end = fromIntegral $ ts_node_p_end_char node } + lineRange <- pure $! SourceSpan { spanName = toS $ path blob, spanStart = SourcePos (fromIntegral $ ts_node_p_start_point_row node) (fromIntegral $ ts_node_p_start_point_column node), spanEnd = SourcePos (fromIntegral $ ts_node_p_end_point_row node) (fromIntegral $ ts_node_p_end_point_column node) } let cost' = 1 + sum (cost . extract <$> children) - let info = range .: (categoriesForLanguage language (toS name)) .: cost' .: RNil - pure $! termConstructor contents info children + let info = range .: (categoriesForLanguage language (toS name)) .: cost' .: lineRange .: RNil + pure $! termConstructor (source blob) info children getChild node n out = do _ <- ts_node_p_named_child node n out toTerm out From bf9e385448a718daa6704088d4147d4e22ca4c33 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 27 Jul 2016 18:18:55 -0400 Subject: [PATCH 122/320] Print the source span when printing error node diff summaries --- src/DiffSummary.hs | 13 +++++++------ src/Diffing.hs | 4 ++-- src/Renderer/Summary.hs | 3 ++- 3 files changed, 11 insertions(+), 9 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 5013da9de..7b3fc830d 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -6,7 +6,7 @@ import Prologue hiding (snd, intercalate) import Diff import Patch import Term -import Info (category) +import Info (category, sourceSpan) import Syntax as S import Category as C import Data.Functor.Foldable as Foldable @@ -17,10 +17,11 @@ import Patch.Arbitrary() import Data.Record import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string, Doc, punctuate, pretty) import qualified Text.PrettyPrint.Leijen.Text as P +import SourceSpan data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text } | BranchInfo { branches :: [ DiffInfo ], categoryName :: Text, branchType :: Branch } - | ErrorInfo { branches :: [ DiffInfo ], categoryName :: Text } + | ErrorInfo { errorSpan :: SourceSpan, categoryName :: Text } deriving (Eq, Show) toTermName :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> Text @@ -121,7 +122,7 @@ instance (Eq a, Arbitrary a) => Arbitrary (DiffSummary a) where instance P.Pretty DiffInfo where pretty LeafInfo{..} = squotes (string $ toSL termName) <+> (string $ toSL categoryName) pretty BranchInfo{..} = mconcat $ punctuate (string "," <> space) (pretty <$> branches) - pretty ErrorInfo{..} = (mconcat $ punctuate (string "," <> space) (pretty <$> branches)) <+> (string $ toSL categoryName) <+> "syntax error" + pretty ErrorInfo{..} = "Syntax error at" <+> (string . toSL $ displaySourceSpan errorSpan) annotatedSummaries :: DiffSummary DiffInfo -> [Text] annotatedSummaries DiffSummary{..} = show . (P.<> maybeParentContext parentAnnotations) <$> summaries patch @@ -143,7 +144,7 @@ maybeParentContext annotations = if null annotations toDoc :: Text -> Doc toDoc = string . toS -diffSummary :: (HasCategory leaf, HasField fields Category) => Diff leaf (Record fields) -> [DiffSummary DiffInfo] +diffSummary :: (HasCategory leaf, HasField fields Category, HasField fields SourceSpan) => Diff leaf (Record fields) -> [DiffSummary DiffInfo] diffSummary = cata $ \case -- Skip comments and leaves since they don't have any changes (Free (_ :< Leaf _)) -> [] @@ -172,7 +173,7 @@ diffSummary = cata $ \case (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo t1) (termToDiffInfo t2)) [] ] -termToDiffInfo :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> DiffInfo +termToDiffInfo :: (HasCategory leaf, HasField fields Category, HasField fields SourceSpan) => Term leaf (Record fields) -> DiffInfo termToDiffInfo term = case unwrap term of Leaf _ -> LeafInfo (toCategoryName term) (toTermName term) S.Indexed children -> BranchInfo (termToDiffInfo <$> children) (toCategoryName term) BIndexed @@ -187,7 +188,7 @@ termToDiffInfo term = case unwrap term of -- to indicate where that value should be when constructing DiffInfos. S.Operator _ -> LeafInfo (toCategoryName term) "x" Commented cs leaf -> BranchInfo (termToDiffInfo <$> cs <> maybeToList leaf) (toCategoryName term) BCommented - S.Error children -> ErrorInfo (termToDiffInfo <$> children) (toCategoryName term) + S.Error children -> ErrorInfo (sourceSpan (extract term)) (toCategoryName term) _ -> LeafInfo (toCategoryName term) (toTermName term) prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo diff --git a/src/Diffing.hs b/src/Diffing.hs index 02f13238f..926f6e89b 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -122,7 +122,7 @@ diffCostWithCachedTermCosts diff = unCost $ case runFree diff of -- | Returns a rendered diff given a parser, diff arguments and two source blobs. -textDiff :: (Eq (Record fields), HasField fields Category, HasField fields Cost, HasField fields Range) => Parser fields -> DiffArguments -> Both SourceBlob -> IO Text +textDiff :: (Eq (Record fields), HasField fields Category, HasField fields Cost, HasField fields Range, HasField fields SourceSpan) => Parser fields -> DiffArguments -> Both SourceBlob -> IO Text textDiff parser arguments sources = case format arguments of Split -> diffFiles parser split sources Patch -> diffFiles parser patch sources @@ -138,7 +138,7 @@ truncatedDiff arguments sources = case format arguments of Summary -> pure "" -- | Prints a rendered diff to stdio or a filepath given a parser, diff arguments and two source blobs. -printDiff :: (Eq (Record fields), HasField fields Category, HasField fields Cost, HasField fields Range) => Parser fields -> DiffArguments -> Both SourceBlob -> IO () +printDiff :: (Eq (Record fields), HasField fields Category, HasField fields Cost, HasField fields Range, HasField fields SourceSpan) => Parser fields -> DiffArguments -> Both SourceBlob -> IO () printDiff parser arguments sources = do rendered <- textDiff parser arguments sources case (output arguments) of diff --git a/src/Renderer/Summary.hs b/src/Renderer/Summary.hs index 87a36f6b7..32cf2ad94 100644 --- a/src/Renderer/Summary.hs +++ b/src/Renderer/Summary.hs @@ -6,8 +6,9 @@ import Renderer import Data.Aeson import Data.Record import Range +import SourceSpan import DiffSummary -summary :: (HasField fields Category, HasField fields Range) => Renderer (Record fields) +summary :: (HasField fields Category, HasField fields Range, HasField fields SourceSpan) => Renderer (Record fields) summary diff _ = toS . encode $ summaries >>= annotatedSummaries where summaries = diffSummary diff From e3ccbca5aefb8f3471b0109887bf1c1b2d065a1a Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 27 Jul 2016 18:23:52 -0400 Subject: [PATCH 123/320] print filename at the end --- src/DiffSummary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 7b3fc830d..d0e00b89f 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -122,7 +122,7 @@ instance (Eq a, Arbitrary a) => Arbitrary (DiffSummary a) where instance P.Pretty DiffInfo where pretty LeafInfo{..} = squotes (string $ toSL termName) <+> (string $ toSL categoryName) pretty BranchInfo{..} = mconcat $ punctuate (string "," <> space) (pretty <$> branches) - pretty ErrorInfo{..} = "Syntax error at" <+> (string . toSL $ displaySourceSpan errorSpan) + pretty ErrorInfo{..} = "syntax error at" <+> (string . toSL $ displayStartEndPos errorSpan) <+> "in" <+> (string . toSL $ spanName errorSpan) annotatedSummaries :: DiffSummary DiffInfo -> [Text] annotatedSummaries DiffSummary{..} = show . (P.<> maybeParentContext parentAnnotations) <$> summaries patch From ba7d599aa31bf4798bc7f6421169d170750f7c28 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 27 Jul 2016 18:49:21 -0400 Subject: [PATCH 124/320] Add SourceSpan to tests --- src/DiffSummary.hs | 2 +- src/SourceSpan.hs | 14 ++++++++++++-- test/CorpusSpec.hs | 2 +- test/DiffSummarySpec.hs | 19 ++++++++++--------- 4 files changed, 24 insertions(+), 13 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index d0e00b89f..1ee02322d 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -188,7 +188,7 @@ termToDiffInfo term = case unwrap term of -- to indicate where that value should be when constructing DiffInfos. S.Operator _ -> LeafInfo (toCategoryName term) "x" Commented cs leaf -> BranchInfo (termToDiffInfo <$> cs <> maybeToList leaf) (toCategoryName term) BCommented - S.Error children -> ErrorInfo (sourceSpan (extract term)) (toCategoryName term) + S.Error _ -> ErrorInfo (sourceSpan (extract term)) (toCategoryName term) _ -> LeafInfo (toCategoryName term) (toTermName term) prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo diff --git a/src/SourceSpan.hs b/src/SourceSpan.hs index ba68d0b22..a81c63a21 100644 --- a/src/SourceSpan.hs +++ b/src/SourceSpan.hs @@ -6,6 +6,8 @@ module SourceSpan where import Prologue import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A +import Test.QuickCheck +import Data.Text.Arbitrary() -- | -- Source position information @@ -19,7 +21,7 @@ data SourcePos = SourcePos -- Column number -- , column :: !Int - } deriving (Show, Read, Eq, Ord) + } deriving (Show, Read, Eq, Ord, Generic) displaySourcePos :: SourcePos -> Text displaySourcePos sp = @@ -46,7 +48,7 @@ data SourceSpan = SourceSpan -- End of the span -- , spanEnd :: !SourcePos - } deriving (Show, Read, Eq, Ord) + } deriving (Show, Read, Eq, Ord, Generic) displayStartEndPos :: SourceSpan -> Text displayStartEndPos sp = @@ -69,3 +71,11 @@ instance A.FromJSON SourceSpan where o .: "name" <*> o .: "start" <*> o .: "end" + +instance Arbitrary SourcePos where + arbitrary = SourcePos <$> arbitrary <*> arbitrary + shrink = genericShrink + +instance Arbitrary SourceSpan where + arbitrary = SourceSpan <$> arbitrary <*> arbitrary <*> arbitrary + shrink = genericShrink \ No newline at end of file diff --git a/test/CorpusSpec.hs b/test/CorpusSpec.hs index 67aaabd7e..02a76ebec 100644 --- a/test/CorpusSpec.hs +++ b/test/CorpusSpec.hs @@ -71,7 +71,7 @@ normalizeName path = addExtension (dropExtension $ dropExtension path) (takeExte -- | Given file paths for A, B, and, optionally, a diff, return whether diffing -- | the files will produce the diff. If no diff is provided, then the result -- | is true, but the diff will still be calculated. -testDiff :: Renderer (Record '[Range, Category, Cost]) -> Both FilePath -> Maybe FilePath -> (Verbatim -> Verbatim -> Expectation) -> Expectation +testDiff :: Renderer (Record '[Range, Category, Cost, SourceSpan]) -> Both FilePath -> Maybe FilePath -> (Verbatim -> Verbatim -> Expectation) -> Expectation testDiff renderer paths diff matcher = do sources <- sequence $ readAndTranscodeFile <$> paths actual <- Verbatim <$> diffFiles parser renderer (sourceBlobs sources) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index de561d4be..f796e4143 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -18,14 +18,15 @@ import Data.List (partition) import Term.Arbitrary import Interpreter import Info +import SourceSpan -arrayInfo :: Record '[Category] -arrayInfo = ArrayLiteral .: RNil +arrayInfo :: Record '[Category, SourceSpan] +arrayInfo = ArrayLiteral .: SourceSpan "test.js" (SourcePos 0 0) (SourcePos 0 3) .: RNil -literalInfo :: Record '[Category] -literalInfo = StringLiteral .: RNil +literalInfo :: Record '[Category, SourceSpan] +literalInfo = StringLiteral .: SourceSpan "test.js" (SourcePos 0 0) (SourcePos 0 1) .: RNil -testDiff :: Diff Text (Record '[Category]) +testDiff :: Diff Text (Record '[Category, SourceSpan]) testDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "a")) ]) testSummary :: DiffSummary DiffInfo @@ -41,7 +42,7 @@ spec = parallel $ do diffSummary testDiff `shouldBe` [ DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnotations = [ ArrayLiteral ] } ] prop "equal terms produce identity diffs" $ - \ a -> let term = toTerm (a :: ArbitraryTerm Text (Record '[Category])) in + \ a -> let term = toTerm (a :: ArbitraryTerm Text (Record '[Category, SourceSpan])) in diffSummary (diffTerms wrap (==) diffCost term term) `shouldBe` [] describe "annotatedSummaries" $ do @@ -52,7 +53,7 @@ spec = parallel $ do describe "DiffInfo" $ do prop "patches in summaries match the patches in diffs" $ \a -> let - diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Cost]))) + diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Cost, SourceSpan]))) summaries = diffSummary diff patches = toList diff in @@ -61,14 +62,14 @@ spec = parallel $ do (() <$ branchPatches, () <$ otherPatches) `shouldBe` (() <$ branchDiffPatches, () <$ otherDiffPatches) prop "generates one LeafInfo for each child in an arbitrary branch patch" $ \a -> let - diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category]))) + diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, SourceSpan]))) diffInfoPatches = patch <$> diffSummary diff syntaxPatches = toList diff extractLeaves :: DiffInfo -> [DiffInfo] extractLeaves (BranchInfo children _ _) = join $ extractLeaves <$> children extractLeaves leaf = [ leaf ] - extractDiffLeaves :: Term Text (Record '[Category]) -> [ Term Text (Record '[Category]) ] + extractDiffLeaves :: Term Text (Record '[Category, SourceSpan]) -> [ Term Text (Record '[Category, SourceSpan]) ] extractDiffLeaves term = case unwrap term of (Indexed children) -> join $ extractDiffLeaves <$> children (Fixed children) -> join $ extractDiffLeaves <$> children From c8e284b1d9917998e97c0495697662995daded0a Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 27 Jul 2016 18:56:20 -0400 Subject: [PATCH 125/320] attribute SourceSpan credit to purescript --- src/SourceSpan.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/SourceSpan.hs b/src/SourceSpan.hs index a81c63a21..e486b31ca 100644 --- a/src/SourceSpan.hs +++ b/src/SourceSpan.hs @@ -1,5 +1,6 @@ -- | -- Source position and span information +-- Mostly taken from purescript's SourcePos definition. -- module SourceSpan where From c11d955f579944454c0595fbc6c6f904ec00d6f9 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 11:24:19 -0400 Subject: [PATCH 126/320] Add comments --- src/Syntax.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Syntax.hs b/src/Syntax.hs index 4cc9d2df3..02cb62b10 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -48,8 +48,11 @@ data Syntax | Switch { switchExpr :: f, cases :: [f] } | Case { caseExpr :: f, caseStatements :: f } | Object { keyValues :: [f] } + -- | A pair in an Object. e.g. foo: bar or foo => bar | Pair f f + -- | A comment. | Comment a + -- | A term preceded or followed by any number of comments. | Commented [f] (Maybe f) deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From 534de558f07c5ac90c80e7e4a8fd432c177367cd Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 13:48:44 -0400 Subject: [PATCH 127/320] Add a For category --- src/Category.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Category.hs b/src/Category.hs index 8d500f2dc..108488366 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -2,8 +2,7 @@ module Category where import Prologue import Data.Hashable -import Test.QuickCheck (oneof, Arbitrary, arbitrary, shrink) -import Test.QuickCheck.Arbitrary +import Test.QuickCheck hiding (Args) import Data.Text (unpack) import Data.Text.Arbitrary() @@ -62,6 +61,8 @@ data Category | VarDecl -- | A switch expression. | Switch + -- | A for expression. + | For -- | A ternary expression. | Ternary -- | A case expression. From b7f1d033c5d86c51598943c814e359d7cc9ed495 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 13:49:21 -0400 Subject: [PATCH 128/320] Add a For case to toTermName --- src/DiffSummary.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 0b66527d4..611e0c400 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -53,6 +53,7 @@ toTermName term = case unwrap term of -- evaluate Case as a single toTermName Text - joshvera Syntax.Case expr _ -> toTermName expr Syntax.Switch expr _ -> toTermName expr + Syntax.For expr value _ -> toTermName expr <> " in " <> toTermName value Syntax.Ternary expr _ -> toTermName expr Syntax.MathAssignment id _ -> toTermName id Syntax.Operator syntaxes -> mconcat $ toTermName <$> syntaxes @@ -98,6 +99,7 @@ instance HasCategory Category where StringLiteral -> "string" SymbolLiteral -> "symbol" TemplateString -> "template string" + Category.For -> "for statement" Category.Object -> "object" instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where From bda9e4528cb7685808d2cf138bfbcbc244e48873 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 13:49:38 -0400 Subject: [PATCH 129/320] Add a For case to diffSummary --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 611e0c400..dd2856980 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -158,6 +158,7 @@ diffSummary = cata $ \case (Free (infos :< Syntax.VarAssignment varId value)) -> prependSummary (category $ snd infos) <$> varId <> value (Free (infos :< Syntax.VarDecl decl)) -> prependSummary (category $ snd infos) <$> decl (Free (infos :< Syntax.Args args)) -> prependSummary (category $ snd infos) <$> join args + (Free (infos :< Syntax.For expr value body)) -> prependSummary (category $ snd infos) <$> expr <> value <> body (Free (infos :< Syntax.Switch expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases (Free (infos :< Syntax.Case expr body)) -> prependSummary (category $ snd infos) <$> expr <> body Free (infos :< (Syntax.Ternary expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases From bb373e8e42fd88b8cbd35f96c8c3c4a4743c4806 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 13:49:48 -0400 Subject: [PATCH 130/320] Add a For case to termConstructor --- src/Parser.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Parser.hs b/src/Parser.hs index d8082ee3e..d73faa1c0 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -81,5 +81,7 @@ termConstructor source info = cofree . construct toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)] construct children | isFixed (category info) = withDefaultInfo $ S.Fixed children + construct children | For == (category info), [clause, value, body] <- children = + withDefaultInfo $ S.For clause value body construct children = withDefaultInfo $ S.Indexed children From 8c52bf91b5f37ad0586ced0e213f30fb7ee4e2f2 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 13:50:08 -0400 Subject: [PATCH 131/320] Add a For case to styleName --- src/Renderer/JSON.hs | 1 + src/Renderer/Split.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index a2ad3cb81..81023f066 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -73,6 +73,7 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.Args c -> childrenFields c S.Assignment assignmentId property -> [ "assignmentIdentifier" .= assignmentId ] <> [ "property" .= property ] S.MemberAccess memberId value -> [ "memberIdentifier" .= memberId ] <> [ "value" .= value ] + S.For expr value body -> [ "forClause" .= expr ] <> [ "forValue" .= value ] <> [ "forBody" .= body ] S.Switch expr cases -> [ "switchExpression" .= expr ] <> [ "cases" .= cases ] S.Case expr body -> [ "caseExpression" .= expr ] <> [ "caseStatement" .= body ] S.VarDecl decl -> [ "variableDeclaration" .= decl ] diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index fe67726fa..b523beb3a 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -62,6 +62,7 @@ styleName category = "category-" <> case category of C.Ternary -> "ternary" C.Operator -> "operator" C.Object -> "object" + C.For -> "for" Other string -> string -- | Pick the class name for a split patch. From 4678805bb1b7fe63c6958e913cd1224f8061b1eb Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 13:50:20 -0400 Subject: [PATCH 132/320] Add a For case to Syntax --- src/Syntax.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Syntax.hs b/src/Syntax.hs index 02cb62b10..eb0249683 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -54,6 +54,7 @@ data Syntax | Comment a -- | A term preceded or followed by any number of comments. | Commented [f] (Maybe f) + | For { forClause :: f, forValue :: f, forBody :: f } deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From 951617ff5e1a1b85cbadb0fe68b3ae73f932878e Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 13:50:43 -0400 Subject: [PATCH 133/320] Add For cases to categoriesForLanguage and defaultCategoryForNodeName --- src/TreeSitter.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index a567817fc..dc55a672e 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -39,6 +39,8 @@ categoriesForLanguage language name = case (language, name) of (JavaScript, "delete_op") -> Operator (JavaScript, "type_op") -> Operator (JavaScript, "void_op") -> Operator + (JavaScript, "for_in_statement") -> For + (JavaScript, "for_of_statement") -> For (Ruby, "hash") -> Object _ -> defaultCategoryForNodeName name @@ -73,6 +75,7 @@ defaultCategoryForNodeName name = case name of "true" -> Boolean "false" -> Boolean "ternary" -> Ternary + "for_statement" -> For _ -> Other name -- | Return a parser for a tree sitter language & document. From 7eac1300899dfd6a9f47db86bea75a129183d610 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 14:00:28 -0400 Subject: [PATCH 134/320] Add DoWhile and While cases --- src/Category.hs | 7 +++++++ src/DiffSummary.hs | 6 ++++++ src/Parser.hs | 4 ++++ src/Renderer/JSON.hs | 4 +++- src/Renderer/Split.hs | 2 ++ src/Syntax.hs | 4 +++- src/TreeSitter.hs | 2 ++ 7 files changed, 27 insertions(+), 2 deletions(-) diff --git a/src/Category.hs b/src/Category.hs index 108488366..8e3441bdf 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -63,6 +63,10 @@ data Category | Switch -- | A for expression. | For + -- | A while expression. + | While + -- | A do/while expression. + | DoWhile -- | A ternary expression. | Ternary -- | A case expression. @@ -111,6 +115,9 @@ instance Arbitrary Category where , pure SubscriptAccess , pure VarAssignment , pure VarDecl + , pure For + , pure DoWhile + , pure While , pure Switch , pure Ternary , pure Case diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index dd2856980..1884bbcf1 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -54,6 +54,8 @@ toTermName term = case unwrap term of Syntax.Case expr _ -> toTermName expr Syntax.Switch expr _ -> toTermName expr Syntax.For expr value _ -> toTermName expr <> " in " <> toTermName value + Syntax.While expr _ -> toTermName expr + Syntax.DoWhile expr _ -> toTermName expr Syntax.Ternary expr _ -> toTermName expr Syntax.MathAssignment id _ -> toTermName id Syntax.Operator syntaxes -> mconcat $ toTermName <$> syntaxes @@ -100,6 +102,8 @@ instance HasCategory Category where SymbolLiteral -> "symbol" TemplateString -> "template string" Category.For -> "for statement" + Category.While -> "while statement" + Category.DoWhile -> "do/while statement" Category.Object -> "object" instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where @@ -159,6 +163,8 @@ diffSummary = cata $ \case (Free (infos :< Syntax.VarDecl decl)) -> prependSummary (category $ snd infos) <$> decl (Free (infos :< Syntax.Args args)) -> prependSummary (category $ snd infos) <$> join args (Free (infos :< Syntax.For expr value body)) -> prependSummary (category $ snd infos) <$> expr <> value <> body + (Free (infos :< Syntax.While expr body)) -> prependSummary (category $ snd infos) <$> expr <> body + (Free (infos :< Syntax.DoWhile expr body)) -> prependSummary (category $ snd infos) <$> expr <> body (Free (infos :< Syntax.Switch expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases (Free (infos :< Syntax.Case expr body)) -> prependSummary (category $ snd infos) <$> expr <> body Free (infos :< (Syntax.Ternary expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases diff --git a/src/Parser.hs b/src/Parser.hs index d73faa1c0..ae4f93ef6 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -83,5 +83,9 @@ termConstructor source info = cofree . construct construct children | isFixed (category info) = withDefaultInfo $ S.Fixed children construct children | For == (category info), [clause, value, body] <- children = withDefaultInfo $ S.For clause value body + construct children | While == (category info), [expr, body] <- children = + withDefaultInfo $ S.While expr body + construct children | DoWhile == (category info), [expr, body] <- children = + withDefaultInfo $ S.DoWhile expr body construct children = withDefaultInfo $ S.Indexed children diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 81023f066..d75ed8bae 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -73,7 +73,9 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.Args c -> childrenFields c S.Assignment assignmentId property -> [ "assignmentIdentifier" .= assignmentId ] <> [ "property" .= property ] S.MemberAccess memberId value -> [ "memberIdentifier" .= memberId ] <> [ "value" .= value ] - S.For expr value body -> [ "forClause" .= expr ] <> [ "forValue" .= value ] <> [ "forBody" .= body ] + S.For expr value body -> [ "forDeclaration" .= expr ] <> [ "forValue" .= value ] <> [ "forBody" .= body ] + S.While expr body -> [ "whileExpr" .= expr ] <> [ "whileBody" .= body ] + S.DoWhile expr body -> [ "doWhileExpr" .= expr ] <> [ "doWhileBody" .= body ] S.Switch expr cases -> [ "switchExpression" .= expr ] <> [ "cases" .= cases ] S.Case expr body -> [ "caseExpression" .= expr ] <> [ "caseStatement" .= body ] S.VarDecl decl -> [ "variableDeclaration" .= decl ] diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index b523beb3a..fb1feafdf 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -63,6 +63,8 @@ styleName category = "category-" <> case category of C.Operator -> "operator" C.Object -> "object" C.For -> "for" + C.While -> "while" + C.DoWhile -> "do_while" Other string -> string -- | Pick the class name for a split patch. diff --git a/src/Syntax.hs b/src/Syntax.hs index eb0249683..f76b2a951 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -54,7 +54,9 @@ data Syntax | Comment a -- | A term preceded or followed by any number of comments. | Commented [f] (Maybe f) - | For { forClause :: f, forValue :: f, forBody :: f } + | For { forDecl :: f, forValue :: f, forBody :: f } + | DoWhile { doWhileExpr :: f, doWhileBody :: f } + | While { whileExpr :: f, whileBody :: f } deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index dc55a672e..df65bba1b 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -76,6 +76,8 @@ defaultCategoryForNodeName name = case name of "false" -> Boolean "ternary" -> Ternary "for_statement" -> For + "while_statement" -> While + "do_statement" -> DoWhile _ -> Other name -- | Return a parser for a tree sitter language & document. From 5780015278aeb60831bb34597a81fdad26402926 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 14:26:02 -0400 Subject: [PATCH 135/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 8747ef248..867192034 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 8747ef2483104c72b468cbb2eede87956014c70e +Subproject commit 867192034f25bdde24b810775c41eb758451099e From 776444d64a35ad23c450618bfa056dc95ac7ef4a Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 14:26:17 -0400 Subject: [PATCH 136/320] Print the right expression in a DoWhile --- src/DiffSummary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 1884bbcf1..d7f483872 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -55,7 +55,7 @@ toTermName term = case unwrap term of Syntax.Switch expr _ -> toTermName expr Syntax.For expr value _ -> toTermName expr <> " in " <> toTermName value Syntax.While expr _ -> toTermName expr - Syntax.DoWhile expr _ -> toTermName expr + Syntax.DoWhile _ expr -> toTermName expr Syntax.Ternary expr _ -> toTermName expr Syntax.MathAssignment id _ -> toTermName id Syntax.Operator syntaxes -> mconcat $ toTermName <$> syntaxes From 8b4de1e63a14e284f4db720b0f5df292ce71d691 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 14:26:42 -0400 Subject: [PATCH 137/320] Label the DoWhile terms correctly --- src/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index f76b2a951..aeeecd4ef 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -55,7 +55,7 @@ data Syntax -- | A term preceded or followed by any number of comments. | Commented [f] (Maybe f) | For { forDecl :: f, forValue :: f, forBody :: f } - | DoWhile { doWhileExpr :: f, doWhileBody :: f } + | DoWhile { doWhileBody :: f, doWhileExpr :: f } | While { whileExpr :: f, whileBody :: f } deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From 5caa439bec975e56f3ee6247a42cd9b0857c9351 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 14:28:46 -0400 Subject: [PATCH 138/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 8747ef248..0989485a6 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 8747ef2483104c72b468cbb2eede87956014c70e +Subproject commit 0989485a6fad0ac82c12410c6ae6c9d5453662a2 From d057e156cd14731f92612b673b78d6e3092849be Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 14:34:53 -0400 Subject: [PATCH 139/320] Add Return case to Syntax --- src/Category.hs | 2 ++ src/DiffSummary.hs | 3 +++ src/Parser.hs | 2 ++ src/Renderer/JSON.hs | 1 + src/Renderer/Split.hs | 1 + src/Syntax.hs | 1 + src/TreeSitter.hs | 1 + 7 files changed, 11 insertions(+) diff --git a/src/Category.hs b/src/Category.hs index 8d500f2dc..d2923e66e 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -70,6 +70,8 @@ data Category | Operator -- | An object/dictionary/hash literal. | Object + -- | A return statement. + | Return -- | A non-standard category, which can be used for comparability. | Other Text deriving (Eq, Generic, Ord, Show) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 0b66527d4..668cab6f7 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -58,6 +58,7 @@ toTermName term = case unwrap term of Syntax.Operator syntaxes -> mconcat $ toTermName <$> syntaxes Syntax.Object kvs -> "{" <> intercalate ", " (toTermName <$> kvs) <> "}" Syntax.Pair a b -> toTermName a <> ": " <> toTermName b + Syntax.Return expr -> maybe "empty" toTermName expr Comment a -> toCategoryName a class HasCategory a where @@ -99,6 +100,7 @@ instance HasCategory Category where SymbolLiteral -> "symbol" TemplateString -> "template string" Category.Object -> "object" + Category.Return -> "return statement" instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract @@ -163,6 +165,7 @@ diffSummary = cata $ \case Free (infos :< (Syntax.Operator syntaxes)) -> prependSummary (category $ snd infos) <$> join syntaxes Free (infos :< (Syntax.Object kvs)) -> prependSummary (category $ snd infos) <$> join kvs Free (infos :< (Syntax.Pair a b)) -> prependSummary (category $ snd infos) <$> a <> b + Free (infos :< (Syntax.Return expr)) -> prependSummary (category $ snd infos) <$> fromMaybe [] expr Free (infos :< (Syntax.Commented cs leaf)) -> prependSummary (category $ snd infos) <$> join cs <> fromMaybe [] leaf (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo term) [] ] (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo term) [] ] diff --git a/src/Parser.hs b/src/Parser.hs index d8082ee3e..ada4b06f9 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -81,5 +81,7 @@ termConstructor source info = cofree . construct toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)] construct children | isFixed (category info) = withDefaultInfo $ S.Fixed children + construct children | Return == category info = + withDefaultInfo $ S.Return (listToMaybe children) construct children = withDefaultInfo $ S.Indexed children diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index a2ad3cb81..c11ab1e84 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -83,6 +83,7 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.SubscriptAccess id property -> [ "subscriptId" .= id ] <> [ "property" .= property ] S.Object pairs -> childrenFields pairs S.Pair a b -> childrenFields [a, b] + S.Return expr -> [ "returnExpr" .= expr ] S.Comment _ -> [] S.Commented comments child -> childrenFields (comments <> maybeToList child) where childrenFields c = [ "children" .= c ] diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index fe67726fa..720f14db3 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -62,6 +62,7 @@ styleName category = "category-" <> case category of C.Ternary -> "ternary" C.Operator -> "operator" C.Object -> "object" + C.Return -> "return_statement" Other string -> string -- | Pick the class name for a split patch. diff --git a/src/Syntax.hs b/src/Syntax.hs index 4cc9d2df3..e88ad016a 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -51,6 +51,7 @@ data Syntax | Pair f f | Comment a | Commented [f] (Maybe f) + | Return (Maybe f) deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index a567817fc..fbb015f02 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -73,6 +73,7 @@ defaultCategoryForNodeName name = case name of "true" -> Boolean "false" -> Boolean "ternary" -> Ternary + "return_statement" -> Return _ -> Other name -- | Return a parser for a tree sitter language & document. From 4710cf94eac7008ba10103b3ee9c0f40be76eb5e Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 14:49:07 -0400 Subject: [PATCH 140/320] Map leaves with Return categories to Return Nothing --- src/Parser.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index ada4b06f9..018efccf7 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -30,7 +30,11 @@ termConstructor :: (Show (Record fields), HasField fields Category, HasField fie termConstructor source info = cofree . construct where withDefaultInfo syntax = (info :< syntax) - construct [] = withDefaultInfo . S.Leaf . pack . toString $ slice (characterRange info) source + construct [] = case category info of + Return -> withDefaultInfo $ S.Return Nothing -- Map empty return statements to Return Nothing + _ -> withDefaultInfo . S.Leaf . pack . toString $ slice (characterRange info) source + construct children | Return == category info = + withDefaultInfo $ S.Return (listToMaybe children) construct children | Assignment == category info = case children of (identifier:value:[]) -> withDefaultInfo $ S.Assignment identifier value construct children | MathAssignment == category info = case children of @@ -81,7 +85,5 @@ termConstructor source info = cofree . construct toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)] construct children | isFixed (category info) = withDefaultInfo $ S.Fixed children - construct children | Return == category info = - withDefaultInfo $ S.Return (listToMaybe children) construct children = withDefaultInfo $ S.Indexed children From bb5b54d8472f99af509f38ef2d4c89060eb8db0a Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 14:49:29 -0400 Subject: [PATCH 141/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 867192034..0989485a6 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 867192034f25bdde24b810775c41eb758451099e +Subproject commit 0989485a6fad0ac82c12410c6ae6c9d5453662a2 From da0f21a07fae5284fb115d3b1beb015edf7bba21 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 16:18:30 -0400 Subject: [PATCH 142/320] Relax For constraint to take a list of clauses --- src/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index aeeecd4ef..0043e9ed3 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -54,7 +54,7 @@ data Syntax | Comment a -- | A term preceded or followed by any number of comments. | Commented [f] (Maybe f) - | For { forDecl :: f, forValue :: f, forBody :: f } + | For [f] f | DoWhile { doWhileBody :: f, doWhileExpr :: f } | While { whileExpr :: f, whileBody :: f } deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From 69c02ce76e780439f12c392bb5401ace912d686c Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 16:33:37 -0400 Subject: [PATCH 143/320] mconcat For exprs for now --- src/DiffSummary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index d7f483872..2b2a33af6 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -53,7 +53,7 @@ toTermName term = case unwrap term of -- evaluate Case as a single toTermName Text - joshvera Syntax.Case expr _ -> toTermName expr Syntax.Switch expr _ -> toTermName expr - Syntax.For expr value _ -> toTermName expr <> " in " <> toTermName value + Syntax.For exprs _ -> mconcat $ toTermName <$> exprs Syntax.While expr _ -> toTermName expr Syntax.DoWhile _ expr -> toTermName expr Syntax.Ternary expr _ -> toTermName expr From c45f251b3d383323e1ad24b1591dde5d636eae9b Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 28 Jul 2016 16:34:07 -0400 Subject: [PATCH 144/320] parse For exprs --- src/DiffSummary.hs | 2 +- src/Parser.hs | 4 ++-- src/Renderer/JSON.hs | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 2b2a33af6..c7a0ddb82 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -162,7 +162,7 @@ diffSummary = cata $ \case (Free (infos :< Syntax.VarAssignment varId value)) -> prependSummary (category $ snd infos) <$> varId <> value (Free (infos :< Syntax.VarDecl decl)) -> prependSummary (category $ snd infos) <$> decl (Free (infos :< Syntax.Args args)) -> prependSummary (category $ snd infos) <$> join args - (Free (infos :< Syntax.For expr value body)) -> prependSummary (category $ snd infos) <$> expr <> value <> body + (Free (infos :< Syntax.For exprs body)) -> prependSummary (category $ snd infos) <$> join exprs <> body (Free (infos :< Syntax.While expr body)) -> prependSummary (category $ snd infos) <$> expr <> body (Free (infos :< Syntax.DoWhile expr body)) -> prependSummary (category $ snd infos) <$> expr <> body (Free (infos :< Syntax.Switch expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases diff --git a/src/Parser.hs b/src/Parser.hs index ae4f93ef6..4d259861e 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -81,8 +81,8 @@ termConstructor source info = cofree . construct toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)] construct children | isFixed (category info) = withDefaultInfo $ S.Fixed children - construct children | For == (category info), [clause, value, body] <- children = - withDefaultInfo $ S.For clause value body + construct children | For == (category info), Just (exprs, body) <- unsnoc children = + withDefaultInfo $ S.For exprs body construct children | While == (category info), [expr, body] <- children = withDefaultInfo $ S.While expr body construct children | DoWhile == (category info), [expr, body] <- children = diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index d75ed8bae..217e19ab3 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -73,7 +73,7 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.Args c -> childrenFields c S.Assignment assignmentId property -> [ "assignmentIdentifier" .= assignmentId ] <> [ "property" .= property ] S.MemberAccess memberId value -> [ "memberIdentifier" .= memberId ] <> [ "value" .= value ] - S.For expr value body -> [ "forDeclaration" .= expr ] <> [ "forValue" .= value ] <> [ "forBody" .= body ] + S.For exprs body -> [ "forExpressions" .= exprs ] <> [ "forBody" .= body ] S.While expr body -> [ "whileExpr" .= expr ] <> [ "whileBody" .= body ] S.DoWhile expr body -> [ "doWhileExpr" .= expr ] <> [ "doWhileBody" .= body ] S.Switch expr cases -> [ "switchExpression" .= expr ] <> [ "cases" .= cases ] From 5f7555b624c7d4e6764f426f79bd89b57bda6fec Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 11:48:31 -0400 Subject: [PATCH 145/320] Finish merging DiffSummary --- src/DiffSummary.hs | 31 ++----------------------------- 1 file changed, 2 insertions(+), 29 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 16cd6203d..0c3001fbf 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -101,12 +101,8 @@ instance HasCategory Category where StringLiteral -> "string" SymbolLiteral -> "symbol" TemplateString -> "template string" -<<<<<<< HEAD C.Object -> "object" -======= - Category.Object -> "object" - Category.Return -> "return statement" ->>>>>>> origin/master + C.Return -> "return statement" instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract @@ -154,7 +150,6 @@ diffSummary :: (HasCategory leaf, HasField fields Category, HasField fields Sour diffSummary = cata $ \case -- Skip comments and leaves since they don't have any changes (Free (_ :< Leaf _)) -> [] -<<<<<<< HEAD Free (_ :< (S.Comment _)) -> [] (Free (infos :< S.Indexed children)) -> prependSummary (category $ snd infos) <$> join children (Free (infos :< S.Fixed children)) -> prependSummary (category $ snd infos) <$> join children @@ -173,32 +168,10 @@ diffSummary = cata $ \case Free (infos :< (S.MathAssignment id value)) -> prependSummary (category $ snd infos) <$> id <> value Free (infos :< (S.Operator syntaxes)) -> prependSummary (category $ snd infos) <$> join syntaxes Free (infos :< (S.Object kvs)) -> prependSummary (category $ snd infos) <$> join kvs + Free (infos :< (S.Return expr)) -> prependSummary (category $ snd infos) <$> fromMaybe [] expr Free (infos :< (S.Pair a b)) -> prependSummary (category $ snd infos) <$> a <> b Free (infos :< (S.Commented cs leaf)) -> prependSummary (category $ snd infos) <$> join cs <> fromMaybe [] leaf Free (infos :< (S.Error children)) -> prependSummary (category $ snd infos) <$> join children -======= - Free (_ :< (Syntax.Comment _)) -> [] - (Free (infos :< Syntax.Indexed children)) -> prependSummary (category $ snd infos) <$> join children - (Free (infos :< Syntax.Fixed children)) -> prependSummary (category $ snd infos) <$> join children - (Free (infos :< Syntax.FunctionCall identifier children)) -> prependSummary (category $ snd infos) <$> join (Prologue.toList (identifier : children)) - (Free (infos :< Syntax.Function id ps body)) -> prependSummary (category $ snd infos) <$> (fromMaybe [] id) <> (fromMaybe [] ps) <> body - (Free (infos :< Syntax.Assignment id value)) -> prependSummary (category $ snd infos) <$> id <> value - (Free (infos :< Syntax.MemberAccess base property)) -> prependSummary (category $ snd infos) <$> base <> property - (Free (infos :< Syntax.SubscriptAccess base property)) -> prependSummary (category $ snd infos) <$> base <> property - (Free (infos :< Syntax.MethodCall targetId methodId ps)) -> prependSummary (category $ snd infos) <$> targetId <> methodId <> ps - (Free (infos :< Syntax.VarAssignment varId value)) -> prependSummary (category $ snd infos) <$> varId <> value - (Free (infos :< Syntax.VarDecl decl)) -> prependSummary (category $ snd infos) <$> decl - (Free (infos :< Syntax.Args args)) -> prependSummary (category $ snd infos) <$> join args - (Free (infos :< Syntax.Switch expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases - (Free (infos :< Syntax.Case expr body)) -> prependSummary (category $ snd infos) <$> expr <> body - Free (infos :< (Syntax.Ternary expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases - Free (infos :< (Syntax.MathAssignment id value)) -> prependSummary (category $ snd infos) <$> id <> value - Free (infos :< (Syntax.Operator syntaxes)) -> prependSummary (category $ snd infos) <$> join syntaxes - Free (infos :< (Syntax.Object kvs)) -> prependSummary (category $ snd infos) <$> join kvs - Free (infos :< (Syntax.Pair a b)) -> prependSummary (category $ snd infos) <$> a <> b - Free (infos :< (Syntax.Return expr)) -> prependSummary (category $ snd infos) <$> fromMaybe [] expr - Free (infos :< (Syntax.Commented cs leaf)) -> prependSummary (category $ snd infos) <$> join cs <> fromMaybe [] leaf ->>>>>>> origin/master (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo term) [] ] (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo t1) (termToDiffInfo t2)) [] ] From 87c4c20b4d0a4a049e30b00affc59bb97a3f3cda Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 12:24:12 -0400 Subject: [PATCH 146/320] s/files/blobs --- src/Renderer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Renderer.hs b/src/Renderer.hs index 7696016b2..921ebc960 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -5,7 +5,7 @@ import Data.Functor.Both import Diff import Source --- | A function that will render a diff, given the two source files. +-- | A function that will render a diff, given the two source blobs. type Renderer annotation = Diff Text annotation -> Both SourceBlob -> Text data DiffArguments = DiffArguments { format :: Format, output :: Maybe FilePath, outputPath :: FilePath } From ce3857320f8ea56c4496e41d1456f7d1b0c3a3d4 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 12:59:07 -0400 Subject: [PATCH 147/320] Pass SourceBlobs to diffSummary --- src/DiffSummary.hs | 5 +++-- src/Diffing.hs | 2 +- src/Renderer.hs | 2 +- src/Renderer/JSON.hs | 2 +- src/Renderer/Patch.hs | 2 +- src/Renderer/Split.hs | 2 +- src/Renderer/Summary.hs | 4 ++-- 7 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index b45e8f091..8c85e2074 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -18,6 +18,7 @@ import Data.Record import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string, Doc, punctuate, pretty) import qualified Text.PrettyPrint.Leijen.Text as P import SourceSpan +import Source data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text } | BranchInfo { branches :: [ DiffInfo ], categoryName :: Text, branchType :: Branch } @@ -152,8 +153,8 @@ maybeParentContext annotations = if null annotations toDoc :: Text -> Doc toDoc = string . toS -diffSummary :: (HasCategory leaf, HasField fields Category, HasField fields SourceSpan) => Diff leaf (Record fields) -> [DiffSummary DiffInfo] -diffSummary = cata $ \case +diffSummary :: (HasCategory leaf, HasField fields Category, HasField fields SourceSpan) => Both SourceBlob -> Diff leaf (Record fields) -> [DiffSummary DiffInfo] +diffSummary blobs = cata $ \case -- Skip comments and leaves since they don't have any changes (Free (_ :< Leaf _)) -> [] Free (_ :< (S.Comment _)) -> [] diff --git a/src/Diffing.hs b/src/Diffing.hs index 926f6e89b..370c73130 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -103,7 +103,7 @@ diffFiles parser renderer sourceBlobs = do (_, _) -> runBothWith (diffTerms construct compareCategoryEq diffCostWithCachedTermCosts) (replaceLeaves <*> terms) - pure $! renderer textDiff sourceBlobs + pure $! renderer sourceBlobs textDiff where construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax)) sumCost = fmap getSum . foldMap (fmap Sum . getCost) diff --git a/src/Renderer.hs b/src/Renderer.hs index 921ebc960..794b9af0f 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -6,7 +6,7 @@ import Diff import Source -- | A function that will render a diff, given the two source blobs. -type Renderer annotation = Diff Text annotation -> Both SourceBlob -> Text +type Renderer annotation = Both SourceBlob -> Diff Text annotation -> Text data DiffArguments = DiffArguments { format :: Format, output :: Maybe FilePath, outputPath :: FilePath } deriving (Show) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 43dfa0543..5de0f9974 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -24,7 +24,7 @@ import Term -- | Render a diff to a string representing its JSON. json :: (HasField fields Category, HasField fields Range) => Renderer (Record fields) -json diff sources = toS . toLazyByteString . fromEncoding . pairs $ "rows" .= annotateRows (alignDiff (source <$> sources) diff) <> "oids" .= (oid <$> sources) <> "paths" .= (path <$> sources) +json blobs diff = toS . toLazyByteString . fromEncoding . pairs $ "rows" .= annotateRows (alignDiff (source <$> blobs) diff) <> "oids" .= (oid <$> blobs) <> "paths" .= (path <$> blobs) where annotateRows = fmap (fmap NumberedLine) . numberedRows newtype NumberedLine a = NumberedLine (Int, a) diff --git a/src/Renderer/Patch.hs b/src/Renderer/Patch.hs index 0246f4013..34b6f5631 100644 --- a/src/Renderer/Patch.hs +++ b/src/Renderer/Patch.hs @@ -27,7 +27,7 @@ truncatePatch _ blobs = pack $ header blobs <> "#timed_out\nTruncating diff: tim -- | Render a diff in the traditional patch format. patch :: HasField fields Range => Renderer (Record fields) -patch diff blobs = pack $ case getLast (foldMap (Last . Just) string) of +patch blobs diff = pack $ case getLast (foldMap (Last . Just) string) of Just c | c /= '\n' -> string <> "\n\\ No newline at end of file\n" _ -> string where string = header blobs <> mconcat (showHunk blobs <$> hunks diff blobs) diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index e3f18f45d..ab27270fe 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -77,7 +77,7 @@ splitPatchToClassName patch = stringValue $ "patch " <> case patch of -- | Render a diff as an HTML split diff. split :: (HasField fields Category, HasField fields Cost, HasField fields Range) => Renderer (Record fields) -split diff blobs = TL.toStrict . renderHtml +split blobs diff = TL.toStrict . renderHtml . docTypeHtml . ((head $ link ! A.rel "stylesheet" ! A.href "style.css") <>) . body diff --git a/src/Renderer/Summary.hs b/src/Renderer/Summary.hs index 32cf2ad94..636070464 100644 --- a/src/Renderer/Summary.hs +++ b/src/Renderer/Summary.hs @@ -10,5 +10,5 @@ import SourceSpan import DiffSummary summary :: (HasField fields Category, HasField fields Range, HasField fields SourceSpan) => Renderer (Record fields) -summary diff _ = toS . encode $ summaries >>= annotatedSummaries - where summaries = diffSummary diff +summary blobs diff = toS . encode $ summaries >>= annotatedSummaries + where summaries = diffSummary blobs diff \ No newline at end of file From 8fffee031ab85578aa009ab8f5091ae6c50024d1 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 13:03:11 -0400 Subject: [PATCH 148/320] Move Source declarations to the top --- src/Source.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Source.hs b/src/Source.hs index 628cf9e25..efa4e80f7 100644 --- a/src/Source.hs +++ b/src/Source.hs @@ -8,6 +8,15 @@ import qualified Data.Vector as Vector import Numeric import Range +-- | The source, oid, path, and Maybe SourceKind of a blob in a Git repo. +data SourceBlob = SourceBlob { source :: Source Char, oid :: String, path :: FilePath, blobKind :: Maybe SourceKind } + deriving (Show, Eq) + +-- | The contents of a source file, backed by a vector for efficient slicing. +newtype Source a = Source { getVector :: Vector.Vector a } + deriving (Eq, Show, Foldable, Functor, Traversable) + +-- | The kind of a blob, along with it's file mode. data SourceKind = PlainBlob Word32 | ExecutableBlob Word32 | SymlinkBlob Word32 deriving (Show, Eq) @@ -16,17 +25,11 @@ modeToDigits (PlainBlob mode) = showOct mode "" modeToDigits (ExecutableBlob mode) = showOct mode "" modeToDigits (SymlinkBlob mode) = showOct mode "" -data SourceBlob = SourceBlob { source :: Source Char, oid :: String, path :: FilePath, blobKind :: Maybe SourceKind } - deriving (Show, Eq) -- | The default plain blob mode defaultPlainBlob :: SourceKind defaultPlainBlob = PlainBlob 0o100644 --- | The contents of a source file, backed by a vector for efficient slicing. -newtype Source a = Source { getVector :: Vector.Vector a } - deriving (Eq, Show, Foldable, Functor, Traversable) - -- | Map blobs with Nothing blobKind to empty blobs. idOrEmptySourceBlob :: SourceBlob -> SourceBlob From 5b22f1c9ad05f177271b86ffb0831eced21b8659 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 13:12:36 -0400 Subject: [PATCH 149/320] add toTermName' to close over Source --- src/DiffSummary.hs | 57 +++++++++++++++++++++++----------------------- 1 file changed, 29 insertions(+), 28 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 8c85e2074..946e2bf13 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -25,47 +25,48 @@ data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text } | ErrorInfo { errorSpan :: SourceSpan, categoryName :: Text } deriving (Eq, Show) -toTermName :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> Text -toTermName term = case unwrap term of +toTermName :: (HasCategory leaf, HasField fields Category) => Source Char -> Term leaf (Record fields) -> Text +toTermName source term = case unwrap term of S.Fixed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children S.Indexed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children Leaf leaf -> toCategoryName leaf - S.Assignment identifier value -> toTermName identifier <> toTermName value - S.Function identifier _ _ -> (maybe "anonymous" toTermName identifier) - S.FunctionCall i _ -> toTermName i + S.Assignment identifier value -> toTermName' identifier <> toTermName' value + S.Function identifier _ _ -> (maybe "anonymous" toTermName' identifier) + S.FunctionCall i _ -> toTermName' i S.MemberAccess base property -> case (unwrap base, unwrap property) of - (S.FunctionCall{}, S.FunctionCall{}) -> toTermName base <> "()." <> toTermName property <> "()" - (S.FunctionCall{}, _) -> toTermName base <> "()." <> toTermName property - (_, S.FunctionCall{}) -> toTermName base <> "." <> toTermName property <> "()" - (_, _) -> toTermName base <> "." <> toTermName property - S.MethodCall targetId methodId _ -> toTermName targetId <> sep <> toTermName methodId <> "()" + (S.FunctionCall{}, S.FunctionCall{}) -> toTermName' base <> "()." <> toTermName' property <> "()" + (S.FunctionCall{}, _) -> toTermName' base <> "()." <> toTermName' property + (_, S.FunctionCall{}) -> toTermName' base <> "." <> toTermName' property <> "()" + (_, _) -> toTermName' base <> "." <> toTermName' property + S.MethodCall targetId methodId _ -> toTermName' targetId <> sep <> toTermName' methodId <> "()" where sep = case unwrap targetId of S.FunctionCall{} -> "()." _ -> "." S.SubscriptAccess base element -> case (unwrap base, unwrap element) of - (S.FunctionCall{}, S.FunctionCall{}) -> toTermName base <> "()." <> toTermName element <> "()" - (S.FunctionCall{}, _) -> toTermName base <> "()." <> toTermName element - (_, S.FunctionCall{}) -> toTermName base <> "[" <> toTermName element <> "()" <> "]" - (_, _) -> toTermName base <> "[" <> toTermName element <> "]" - S.VarAssignment varId _ -> toTermName varId - S.VarDecl decl -> toTermName decl + (S.FunctionCall{}, S.FunctionCall{}) -> toTermName' base <> "()." <> toTermName' element <> "()" + (S.FunctionCall{}, _) -> toTermName' base <> "()." <> toTermName element + (_, S.FunctionCall{}) -> toTermName' base <> "[" <> toTermName' element <> "()" <> "]" + (_, _) -> toTermName' base <> "[" <> toTermName' element <> "]" + S.VarAssignment varId _ -> toTermName' varId + S.VarDecl decl -> toTermName' decl -- TODO: We should remove Args from Syntax since I don't think we should ever -- evaluate Args as a single toTermName Text - joshvera - S.Args args -> mconcat $ toTermName <$> args + S.Args args -> mconcat $ toTermName' <$> args -- TODO: We should remove Case from Syntax since I don't think we should ever -- evaluate Case as a single toTermName Text - joshvera - S.Case expr _ -> toTermName expr - S.Switch expr _ -> toTermName expr - S.Ternary expr _ -> toTermName expr - S.MathAssignment id _ -> toTermName id - S.Operator syntaxes -> mconcat $ toTermName <$> syntaxes - S.Object kvs -> "{" <> intercalate ", " (toTermName <$> kvs) <> "}" - S.Pair a b -> toTermName a <> ": " <> toTermName b - S.Return expr -> maybe "empty" toTermName expr - S.For exprs _ -> mconcat $ toTermName <$> exprs - S.While expr _ -> toTermName expr - S.DoWhile _ expr -> toTermName expr + S.Case expr _ -> toTermName' expr + S.Switch expr _ -> toTermName' expr + S.Ternary expr _ -> toTermName' expr + S.MathAssignment id _ -> toTermName' id + S.Operator syntaxes -> mconcat $ toTermName' <$> syntaxes + S.Object kvs -> "{" <> intercalate ", " (toTermName' <$> kvs) <> "}" + S.Pair a b -> toTermName' a <> ": " <> toTermName' b + S.Return expr -> maybe "empty" toTermName' expr + S.For exprs _ -> mconcat $ toTermName' <$> exprs + S.While expr _ -> toTermName' expr + S.DoWhile _ expr -> toTermName' expr Comment a -> toCategoryName a + where toTermName' = toTermName source class HasCategory a where toCategoryName :: a -> Text From 3bb2bfeb97e4c942cb5ce3d8ef223e08700cf55f Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 13:49:07 -0400 Subject: [PATCH 150/320] Cleanup prependSummary --- src/DiffSummary.hs | 86 +++++++++++++++++++++++++--------------------- 1 file changed, 46 insertions(+), 40 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 946e2bf13..6ba276e9c 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -44,7 +44,7 @@ toTermName source term = case unwrap term of _ -> "." S.SubscriptAccess base element -> case (unwrap base, unwrap element) of (S.FunctionCall{}, S.FunctionCall{}) -> toTermName' base <> "()." <> toTermName' element <> "()" - (S.FunctionCall{}, _) -> toTermName' base <> "()." <> toTermName element + (S.FunctionCall{}, _) -> toTermName' base <> "()." <> toTermName' element (_, S.FunctionCall{}) -> toTermName' base <> "[" <> toTermName' element <> "()" <> "]" (_, _) -> toTermName' base <> "[" <> toTermName' element <> "]" S.VarAssignment varId _ -> toTermName' varId @@ -159,51 +159,57 @@ diffSummary blobs = cata $ \case -- Skip comments and leaves since they don't have any changes (Free (_ :< Leaf _)) -> [] Free (_ :< (S.Comment _)) -> [] - (Free (infos :< S.Indexed children)) -> prependSummary (category $ snd infos) <$> join children - (Free (infos :< S.Fixed children)) -> prependSummary (category $ snd infos) <$> join children - (Free (infos :< S.FunctionCall identifier children)) -> prependSummary (category $ snd infos) <$> join (Prologue.toList (identifier : children)) - (Free (infos :< S.Function id ps body)) -> prependSummary (category $ snd infos) <$> (fromMaybe [] id) <> (fromMaybe [] ps) <> body - (Free (infos :< S.Assignment id value)) -> prependSummary (category $ snd infos) <$> id <> value - (Free (infos :< S.MemberAccess base property)) -> prependSummary (category $ snd infos) <$> base <> property - (Free (infos :< S.SubscriptAccess base property)) -> prependSummary (category $ snd infos) <$> base <> property - (Free (infos :< S.MethodCall targetId methodId ps)) -> prependSummary (category $ snd infos) <$> targetId <> methodId <> ps - (Free (infos :< S.VarAssignment varId value)) -> prependSummary (category $ snd infos) <$> varId <> value - (Free (infos :< S.VarDecl decl)) -> prependSummary (category $ snd infos) <$> decl - (Free (infos :< S.Args args)) -> prependSummary (category $ snd infos) <$> join args - (Free (infos :< S.Switch expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases - (Free (infos :< S.Case expr body)) -> prependSummary (category $ snd infos) <$> expr <> body - Free (infos :< (S.Ternary expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases - Free (infos :< (S.MathAssignment id value)) -> prependSummary (category $ snd infos) <$> id <> value - Free (infos :< (S.Operator syntaxes)) -> prependSummary (category $ snd infos) <$> join syntaxes - Free (infos :< (S.Object kvs)) -> prependSummary (category $ snd infos) <$> join kvs - Free (infos :< (S.Return expr)) -> prependSummary (category $ snd infos) <$> fromMaybe [] expr - Free (infos :< (S.Pair a b)) -> prependSummary (category $ snd infos) <$> a <> b - Free (infos :< (S.Commented cs leaf)) -> prependSummary (category $ snd infos) <$> join cs <> fromMaybe [] leaf - Free (infos :< (S.Error children)) -> prependSummary (category $ snd infos) <$> join children - (Free (infos :< S.For exprs body)) -> prependSummary (category $ snd infos) <$> join exprs <> body - (Free (infos :< S.While expr body)) -> prependSummary (category $ snd infos) <$> expr <> body - (Free (infos :< S.DoWhile expr body)) -> prependSummary (category $ snd infos) <$> expr <> body - (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo term) [] ] - (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo term) [] ] - (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo t1) (termToDiffInfo t2)) [] ] + (Free (infos :< S.Indexed children)) -> annotateWithCategory infos <$> join children + (Free (infos :< S.Fixed children)) -> annotateWithCategory infos <$> join children + (Free (infos :< S.FunctionCall identifier children)) -> annotateWithCategory infos <$> join (Prologue.toList (identifier : children)) + (Free (infos :< S.Function id ps body)) -> annotateWithCategory infos <$> (fromMaybe [] id) <> (fromMaybe [] ps) <> body + (Free (infos :< S.Assignment id value)) -> annotateWithCategory infos <$> id <> value + (Free (infos :< S.MemberAccess base property)) -> annotateWithCategory infos <$> base <> property + (Free (infos :< S.SubscriptAccess base property)) -> annotateWithCategory infos <$> base <> property + (Free (infos :< S.MethodCall targetId methodId ps)) -> annotateWithCategory infos <$> targetId <> methodId <> ps + (Free (infos :< S.VarAssignment varId value)) -> annotateWithCategory infos <$> varId <> value + (Free (infos :< S.VarDecl decl)) -> annotateWithCategory infos <$> decl + (Free (infos :< S.Args args)) -> annotateWithCategory infos <$> join args + (Free (infos :< S.Switch expr cases)) -> annotateWithCategory infos <$> expr <> join cases + (Free (infos :< S.Case expr body)) -> annotateWithCategory infos <$> expr <> body + Free (infos :< (S.Ternary expr cases)) -> annotateWithCategory infos <$> expr <> join cases + Free (infos :< (S.MathAssignment id value)) -> annotateWithCategory infos <$> id <> value + Free (infos :< (S.Operator syntaxes)) -> annotateWithCategory infos <$> join syntaxes + Free (infos :< (S.Object kvs)) -> annotateWithCategory infos <$> join kvs + Free (infos :< (S.Return expr)) -> annotateWithCategory infos <$> fromMaybe [] expr + Free (infos :< (S.Pair a b)) -> annotateWithCategory infos <$> a <> b + Free (infos :< (S.Commented cs leaf)) -> annotateWithCategory infos <$> join cs <> fromMaybe [] leaf + Free (infos :< (S.Error children)) -> annotateWithCategory infos <$> join children + (Free (infos :< S.For exprs body)) -> annotateWithCategory infos <$> join exprs <> body + (Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body + (Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body + (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ] + (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ] + (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ] + where + (beforeSource, afterSource) = runJoin $ source <$> blobs + annotateWithCategory infos = prependSummary (category $ snd infos) -termToDiffInfo :: (HasCategory leaf, HasField fields Category, HasField fields SourceSpan) => Term leaf (Record fields) -> DiffInfo -termToDiffInfo term = case unwrap term of - Leaf _ -> LeafInfo (toCategoryName term) (toTermName term) - S.Indexed children -> BranchInfo (termToDiffInfo <$> children) (toCategoryName term) BIndexed - S.Fixed children -> BranchInfo (termToDiffInfo <$> children) (toCategoryName term) BFixed - S.FunctionCall identifier _ -> LeafInfo (toCategoryName term) (toTermName identifier) - S.Ternary ternaryCondition _ -> LeafInfo (toCategoryName term) (toTermName ternaryCondition) - S.Function identifier _ _ -> LeafInfo (toCategoryName term) (maybe "anonymous" toTermName identifier) - S.Assignment identifier _ -> LeafInfo (toCategoryName term) (toTermName identifier) - S.MathAssignment identifier _ -> LeafInfo (toCategoryName term) (toTermName identifier) + +termToDiffInfo :: (HasCategory leaf, HasField fields Category, HasField fields SourceSpan) => Source Char -> Term leaf (Record fields) -> DiffInfo +termToDiffInfo blob term = case unwrap term of + Leaf _ -> LeafInfo (toCategoryName term) (toTermName' term) + S.Indexed children -> BranchInfo (termToDiffInfo' <$> children) (toCategoryName term) BIndexed + S.Fixed children -> BranchInfo (termToDiffInfo' <$> children) (toCategoryName term) BFixed + S.FunctionCall identifier _ -> LeafInfo (toCategoryName term) (toTermName' identifier) + S.Ternary ternaryCondition _ -> LeafInfo (toCategoryName term) (toTermName' ternaryCondition) + S.Function identifier _ _ -> LeafInfo (toCategoryName term) (maybe "anonymous" toTermName' identifier) + S.Assignment identifier _ -> LeafInfo (toCategoryName term) (toTermName' identifier) + S.MathAssignment identifier _ -> LeafInfo (toCategoryName term) (toTermName' identifier) -- Currently we cannot express the operator for an operator production from TreeSitter. Eventually we should be able to -- use the term name of the operator identifier when we have that production value. Until then, I'm using a placeholder value -- to indicate where that value should be when constructing DiffInfos. S.Operator _ -> LeafInfo (toCategoryName term) "x" - Commented cs leaf -> BranchInfo (termToDiffInfo <$> cs <> maybeToList leaf) (toCategoryName term) BCommented + Commented cs leaf -> BranchInfo (termToDiffInfo' <$> cs <> maybeToList leaf) (toCategoryName term) BCommented S.Error _ -> ErrorInfo (sourceSpan (extract term)) (toCategoryName term) - _ -> LeafInfo (toCategoryName term) (toTermName term) + _ -> LeafInfo (toCategoryName term) (toTermName' term) + where toTermName' = toTermName blob + termToDiffInfo' = termToDiffInfo blob prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo prependSummary annotation summary = summary { parentAnnotations = annotation : parentAnnotations summary } From 20a70dae283540e9a0f5142777cae4c66d483953 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 13:58:15 -0400 Subject: [PATCH 151/320] extract for statement text from the source --- src/DiffSummary.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 6ba276e9c..12186aa37 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -6,7 +6,8 @@ import Prologue hiding (snd, intercalate) import Diff import Patch import Term -import Info (category, sourceSpan) +import Info (category, sourceSpan, characterRange) +import Range import Syntax as S import Category as C import Data.Functor.Foldable as Foldable @@ -25,7 +26,7 @@ data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text } | ErrorInfo { errorSpan :: SourceSpan, categoryName :: Text } deriving (Eq, Show) -toTermName :: (HasCategory leaf, HasField fields Category) => Source Char -> Term leaf (Record fields) -> Text +toTermName :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Source Char -> Term leaf (Record fields) -> Text toTermName source term = case unwrap term of S.Fixed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children S.Indexed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children @@ -62,7 +63,9 @@ toTermName source term = case unwrap term of S.Object kvs -> "{" <> intercalate ", " (toTermName' <$> kvs) <> "}" S.Pair a b -> toTermName' a <> ": " <> toTermName' b S.Return expr -> maybe "empty" toTermName' expr - S.For exprs _ -> mconcat $ toTermName' <$> exprs + S.For exprs _ -> toText $ Source.slice (unionRangesFrom forRange forClauseRanges) source + where forRange = characterRange $ extract term + forClauseRanges = characterRange . extract <$> exprs S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr Comment a -> toCategoryName a @@ -154,7 +157,7 @@ maybeParentContext annotations = if null annotations toDoc :: Text -> Doc toDoc = string . toS -diffSummary :: (HasCategory leaf, HasField fields Category, HasField fields SourceSpan) => Both SourceBlob -> Diff leaf (Record fields) -> [DiffSummary DiffInfo] +diffSummary :: (HasCategory leaf, HasField fields Category, HasField fields SourceSpan, HasField fields Range) => Both SourceBlob -> Diff leaf (Record fields) -> [DiffSummary DiffInfo] diffSummary blobs = cata $ \case -- Skip comments and leaves since they don't have any changes (Free (_ :< Leaf _)) -> [] @@ -191,7 +194,7 @@ diffSummary blobs = cata $ \case annotateWithCategory infos = prependSummary (category $ snd infos) -termToDiffInfo :: (HasCategory leaf, HasField fields Category, HasField fields SourceSpan) => Source Char -> Term leaf (Record fields) -> DiffInfo +termToDiffInfo :: (HasCategory leaf, HasField fields Category, HasField fields SourceSpan, HasField fields Range) => Source Char -> Term leaf (Record fields) -> DiffInfo termToDiffInfo blob term = case unwrap term of Leaf _ -> LeafInfo (toCategoryName term) (toTermName' term) S.Indexed children -> BranchInfo (termToDiffInfo' <$> children) (toCategoryName term) BIndexed From e38ce8b8838bb7de14abba9ed3eef525bb5fbcb9 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 13:59:30 -0400 Subject: [PATCH 152/320] Add SourceSpan to Error syntax --- src/Syntax.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index ea1f7c641..d06897412 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -5,6 +5,7 @@ import Data.Mergeable import GHC.Generics import Prologue import Test.QuickCheck hiding (Fixed) +import SourceSpan -- | A node in an abstract syntax tree. data Syntax @@ -54,7 +55,7 @@ data Syntax | Comment a -- | A term preceded or followed by any number of comments. | Commented [f] (Maybe f) - | Error [f] + | Error SourceSpan [f] | For [f] f | DoWhile { doWhileBody :: f, doWhileExpr :: f } | While { whileExpr :: f, whileBody :: f } From f7286f927cb0e9a0f75868d9b3b7d190f041235a Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 14:05:11 -0400 Subject: [PATCH 153/320] Construct errors with a SourceSpan --- src/DiffSummary.hs | 6 +++--- src/Parser.hs | 20 ++++++++++---------- src/Renderer/JSON.hs | 2 +- src/TreeSitter.hs | 9 ++++++--- 4 files changed, 20 insertions(+), 17 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 12186aa37..db145ff63 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -6,7 +6,7 @@ import Prologue hiding (snd, intercalate) import Diff import Patch import Term -import Info (category, sourceSpan, characterRange) +import Info (category, characterRange) import Range import Syntax as S import Category as C @@ -182,7 +182,7 @@ diffSummary blobs = cata $ \case Free (infos :< (S.Return expr)) -> annotateWithCategory infos <$> fromMaybe [] expr Free (infos :< (S.Pair a b)) -> annotateWithCategory infos <$> a <> b Free (infos :< (S.Commented cs leaf)) -> annotateWithCategory infos <$> join cs <> fromMaybe [] leaf - Free (infos :< (S.Error children)) -> annotateWithCategory infos <$> join children + Free (infos :< (S.Error _ children)) -> annotateWithCategory infos <$> join children (Free (infos :< S.For exprs body)) -> annotateWithCategory infos <$> join exprs <> body (Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body @@ -209,7 +209,7 @@ termToDiffInfo blob term = case unwrap term of -- to indicate where that value should be when constructing DiffInfos. S.Operator _ -> LeafInfo (toCategoryName term) "x" Commented cs leaf -> BranchInfo (termToDiffInfo' <$> cs <> maybeToList leaf) (toCategoryName term) BCommented - S.Error _ -> ErrorInfo (sourceSpan (extract term)) (toCategoryName term) + S.Error sourceSpan _ -> ErrorInfo sourceSpan (toCategoryName term) _ -> LeafInfo (toCategoryName term) (toTermName' term) where toTermName' = toTermName blob termToDiffInfo' = termToDiffInfo blob diff --git a/src/Parser.hs b/src/Parser.hs index cdefe2275..9368242d3 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -27,8 +27,8 @@ isFixed = flip Set.member fixedCategories -- | Given a function that maps production names to sets of categories, produce -- | a Constructor. -termConstructor :: forall fields. (Show (Record fields), HasField fields Category, HasField fields Range) => Source Char -> (Record fields) -> [Term Text (Record fields)] -> Term Text (Record fields) -termConstructor source info = cofree . construct +termConstructor :: forall fields. (Show (Record fields), HasField fields Category, HasField fields Range) => Source Char -> SourceSpan -> (Record fields) -> [Term Text (Record fields)] -> Term Text (Record fields) +termConstructor source sourceSpan info = cofree . construct where withDefaultInfo syntax = (info :< syntax) construct :: (Show (Record fields), HasField fields Category, HasField fields Range) => [Term Text (Record fields)] -> CofreeF (S.Syntax Text) (Record fields) (Term Text (Record fields)) @@ -39,16 +39,16 @@ termConstructor source info = cofree . construct withDefaultInfo $ S.Return (listToMaybe children) construct children | Assignment == category info = case children of (identifier:value:[]) -> withDefaultInfo $ S.Assignment identifier value - children -> withDefaultInfo $ S.Error children + children -> withDefaultInfo $ S.Error sourceSpan children construct children | MathAssignment == category info = case children of (identifier:value:[]) -> withDefaultInfo $ S.MathAssignment identifier value - children -> withDefaultInfo $ S.Error children + children -> withDefaultInfo $ S.Error sourceSpan children construct children | MemberAccess == category info = case children of (base:property:[]) -> withDefaultInfo $ S.MemberAccess base property - children -> withDefaultInfo $ S.Error children + children -> withDefaultInfo $ S.Error sourceSpan children construct children | SubscriptAccess == category info = case children of (base:element:[]) -> withDefaultInfo $ S.SubscriptAccess base element - _ -> withDefaultInfo $ S.Error children + _ -> withDefaultInfo $ S.Error sourceSpan children construct children | Operator == category info = withDefaultInfo $ S.Operator children construct children | Function == category info = case children of (body:[]) -> withDefaultInfo $ S.Function Nothing Nothing body @@ -58,18 +58,18 @@ termConstructor source info = cofree . construct withDefaultInfo $ S.Function (Just id) Nothing body (id:params:body:[]) | (info :< _) <- runCofree id, Identifier == category info -> withDefaultInfo $ S.Function (Just id) (Just params) body - _ -> withDefaultInfo $ S.Error children + _ -> withDefaultInfo $ S.Error sourceSpan children construct children | FunctionCall == category info = case runCofree <$> children of [ (_ :< S.MemberAccess{..}), params@(_ :< S.Args{}) ] -> setCategory info MethodCall :< S.MethodCall memberId property (cofree params) (x:xs) -> withDefaultInfo $ S.FunctionCall (cofree x) (cofree <$> xs) - _ -> withDefaultInfo $ S.Error children + _ -> withDefaultInfo $ S.Error sourceSpan children construct children | Ternary == category info = case children of (condition:cases) -> withDefaultInfo $ S.Ternary condition cases - _ -> withDefaultInfo $ S.Error children + _ -> withDefaultInfo $ S.Error sourceSpan children construct children | Args == category info = withDefaultInfo $ S.Args children construct children | VarAssignment == category info , [x, y] <- children = withDefaultInfo $ S.VarAssignment x y @@ -94,7 +94,7 @@ termConstructor source info = cofree . construct construct children | isFixed (category info) = withDefaultInfo $ S.Fixed children construct children | C.Error == category info = - withDefaultInfo $ S.Error children + withDefaultInfo $ S.Error sourceSpan children construct children | For == (category info), Just (exprs, body) <- unsnoc children = withDefaultInfo $ S.For exprs body construct children | While == (category info), [expr, body] <- children = diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 5de0f9974..2c6d726da 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -89,7 +89,7 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.Return expr -> [ "returnExpr" .= expr ] S.Comment _ -> [] S.Commented comments child -> childrenFields (comments <> maybeToList child) - S.Error c -> childrenFields c + S.Error sourceSpan c -> [ "sourceSpan" .= sourceSpan ] <> childrenFields c where childrenFields c = [ "children" .= c ] patchFields :: (KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (Term leaf (Record fields)) -> [kv] diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 8172ea9da..1bcb563ee 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -96,11 +96,14 @@ documentToTerm language document blob = alloca $ \ root -> do children <- traverse (alloca . getChild node) $ take (fromIntegral count) [0..] -- Note: The strict application here is semantically important. Without it, we may not evaluate the range until after we’ve exited the scope that `node` was allocated within, meaning `alloca` will free it & other stack data may overwrite it. range <- pure $! Range { start = fromIntegral $ ts_node_p_start_char node, end = fromIntegral $ ts_node_p_end_char node } - lineRange <- pure $! SourceSpan { spanName = toS $ path blob, spanStart = SourcePos (fromIntegral $ ts_node_p_start_point_row node) (fromIntegral $ ts_node_p_start_point_column node), spanEnd = SourcePos (fromIntegral $ ts_node_p_end_point_row node) (fromIntegral $ ts_node_p_end_point_column node) } + + sourceSpan <- pure $! SourceSpan { spanName = toS (path blob) + , spanStart = SourcePos (fromIntegral $ ts_node_p_start_point_row node) (fromIntegral $ ts_node_p_start_point_column node) + , spanEnd = SourcePos (fromIntegral $ ts_node_p_end_point_row node) (fromIntegral $ ts_node_p_end_point_column node) } let cost' = 1 + sum (cost . extract <$> children) - let info = range .: (categoriesForLanguage language (toS name)) .: cost' .: lineRange .: RNil - pure $! termConstructor (source blob) info children + let info = range .: (categoriesForLanguage language (toS name)) .: cost' .: sourceSpan .: RNil + pure $! termConstructor (source blob) sourceSpan info children getChild node n out = do _ <- ts_node_p_named_child node n out toTerm out From aa99744db71ab1b1a9a7db2a6cde613f7b431533 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 14:12:44 -0400 Subject: [PATCH 154/320] Remove SourceSpan from Record --- src/DiffSummary.hs | 4 ++-- src/Diffing.hs | 16 +++++++--------- src/Info.hs | 9 +-------- src/Parser.hs | 1 + src/Renderer/Summary.hs | 3 +-- src/TreeSitter.hs | 6 +++--- test/CorpusSpec.hs | 2 +- test/DiffSummarySpec.hs | 19 +++++++++---------- 8 files changed, 25 insertions(+), 35 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index db145ff63..14cd75a0d 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -157,7 +157,7 @@ maybeParentContext annotations = if null annotations toDoc :: Text -> Doc toDoc = string . toS -diffSummary :: (HasCategory leaf, HasField fields Category, HasField fields SourceSpan, HasField fields Range) => Both SourceBlob -> Diff leaf (Record fields) -> [DiffSummary DiffInfo] +diffSummary :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both SourceBlob -> Diff leaf (Record fields) -> [DiffSummary DiffInfo] diffSummary blobs = cata $ \case -- Skip comments and leaves since they don't have any changes (Free (_ :< Leaf _)) -> [] @@ -194,7 +194,7 @@ diffSummary blobs = cata $ \case annotateWithCategory infos = prependSummary (category $ snd infos) -termToDiffInfo :: (HasCategory leaf, HasField fields Category, HasField fields SourceSpan, HasField fields Range) => Source Char -> Term leaf (Record fields) -> DiffInfo +termToDiffInfo :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Source Char -> Term leaf (Record fields) -> DiffInfo termToDiffInfo blob term = case unwrap term of Leaf _ -> LeafInfo (toCategoryName term) (toTermName' term) S.Indexed children -> BranchInfo (termToDiffInfo' <$> children) (toCategoryName term) BIndexed diff --git a/src/Diffing.hs b/src/Diffing.hs index 370c73130..4856725b1 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -32,10 +32,9 @@ import Term import TreeSitter import Text.Parser.TreeSitter.Language import qualified Data.Text as T -import SourceSpan -- | Return a parser based on the file extension (including the "."). -parserForType :: Text -> Parser '[Range, Category, Cost, SourceSpan] +parserForType :: Text -> Parser '[Range, Category, Cost] parserForType mediaType = case languageForType mediaType of Just C -> treeSitterParser C ts_language_c Just JavaScript -> treeSitterParser JavaScript ts_language_javascript @@ -43,22 +42,21 @@ parserForType mediaType = case languageForType mediaType of _ -> lineByLineParser -- | A fallback parser that treats a file simply as rows of strings. -lineByLineParser :: Parser '[Range, Category, Cost, SourceSpan] +lineByLineParser :: Parser '[Range, Category, Cost] lineByLineParser blob = pure . cofree . root $ case foldl' annotateLeaves ([], 0) lines of (leaves, _) -> cofree <$> leaves where input = source blob lines = actualLines input - rootSpan = SourceSpan (toS $ path blob) (SourcePos 0 0) (SourcePos (length lines) (maybe 0 length $ lastMay lines)) root children = let cost = 1 + fromIntegral (length children) in - ((Range 0 $ length input) .: Other "program" .: cost .: rootSpan.: RNil) :< Indexed children - leaf charIndex line = ((Range charIndex $ charIndex + T.length line) .: Other "program" .: 1 .: rootSpan .: RNil) :< Leaf line + ((Range 0 $ length input) .: Other "program" .: cost .: RNil) :< Indexed children + leaf charIndex line = ((Range charIndex $ charIndex + T.length line) .: Other "program" .: 1 .: RNil) :< Leaf line annotateLeaves (accum, charIndex) line = (accum <> [ leaf charIndex (toText line) ] , charIndex + length line) toText = T.pack . Source.toString -- | Return the parser that should be used for a given path. -parserForFilepath :: FilePath -> Parser '[Range, Category, Cost, SourceSpan] +parserForFilepath :: FilePath -> Parser '[Range, Category, Cost] parserForFilepath = parserForType . toS . takeExtension -- | Replace every string leaf with leaves of the words in the string. @@ -122,7 +120,7 @@ diffCostWithCachedTermCosts diff = unCost $ case runFree diff of -- | Returns a rendered diff given a parser, diff arguments and two source blobs. -textDiff :: (Eq (Record fields), HasField fields Category, HasField fields Cost, HasField fields Range, HasField fields SourceSpan) => Parser fields -> DiffArguments -> Both SourceBlob -> IO Text +textDiff :: (Eq (Record fields), HasField fields Category, HasField fields Cost, HasField fields Range) => Parser fields -> DiffArguments -> Both SourceBlob -> IO Text textDiff parser arguments sources = case format arguments of Split -> diffFiles parser split sources Patch -> diffFiles parser patch sources @@ -138,7 +136,7 @@ truncatedDiff arguments sources = case format arguments of Summary -> pure "" -- | Prints a rendered diff to stdio or a filepath given a parser, diff arguments and two source blobs. -printDiff :: (Eq (Record fields), HasField fields Category, HasField fields Cost, HasField fields Range, HasField fields SourceSpan) => Parser fields -> DiffArguments -> Both SourceBlob -> IO () +printDiff :: (Eq (Record fields), HasField fields Category, HasField fields Cost, HasField fields Range) => Parser fields -> DiffArguments -> Both SourceBlob -> IO () printDiff parser arguments sources = do rendered <- textDiff parser arguments sources case (output arguments) of diff --git a/src/Info.hs b/src/Info.hs index fad3e44af..9e9a204c7 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -1,22 +1,15 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-} -module Info (SourceSpan, sourceSpan, setSourceSpan, characterRange, setCharacterRange, category, setCategory, Cost(..), cost, setCost) where +module Info (characterRange, setCharacterRange, category, setCategory, Cost(..), cost, setCost) where import Data.Record import Prologue import Category import Range -import SourceSpan import Test.QuickCheck newtype Cost = Cost { unCost :: Integer } deriving (Eq, Num, Ord, Show) -sourceSpan :: HasField fields SourceSpan => Record fields -> SourceSpan -sourceSpan = getField - -setSourceSpan :: HasField fields SourceSpan => Record fields -> SourceSpan -> Record fields -setSourceSpan = setField - characterRange :: HasField fields Range => Record fields -> Range characterRange = getField diff --git a/src/Parser.hs b/src/Parser.hs index 9368242d3..ed48382fe 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -11,6 +11,7 @@ import qualified Syntax as S import Term import qualified Data.Set as Set import Source +import SourceSpan -- | A function that takes a source file and returns an annotated AST. -- | The return is in the IO monad because some of the parsers are written in C diff --git a/src/Renderer/Summary.hs b/src/Renderer/Summary.hs index 636070464..a1aad2564 100644 --- a/src/Renderer/Summary.hs +++ b/src/Renderer/Summary.hs @@ -6,9 +6,8 @@ import Renderer import Data.Aeson import Data.Record import Range -import SourceSpan import DiffSummary -summary :: (HasField fields Category, HasField fields Range, HasField fields SourceSpan) => Renderer (Record fields) +summary :: (HasField fields Category, HasField fields Range) => Renderer (Record fields) summary blobs diff = toS . encode $ summaries >>= annotatedSummaries where summaries = diffSummary blobs diff \ No newline at end of file diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 1bcb563ee..9727c0f4b 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -16,7 +16,7 @@ import qualified Text.Parser.TreeSitter as TS import SourceSpan -- | Returns a TreeSitter parser for the given language and TreeSitter grammar. -treeSitterParser :: Language -> Ptr TS.Language -> Parser '[Range, Category, Cost, SourceSpan] +treeSitterParser :: Language -> Ptr TS.Language -> Parser '[Range, Category, Cost] treeSitterParser language grammar blob = do document <- ts_document_make ts_document_set_language document grammar @@ -85,7 +85,7 @@ defaultCategoryForNodeName name = case name of _ -> Other name -- | Return a parser for a tree sitter language & document. -documentToTerm :: Language -> Ptr Document -> Parser '[Range, Category, Cost, SourceSpan] +documentToTerm :: Language -> Ptr Document -> Parser '[Range, Category, Cost] documentToTerm language document blob = alloca $ \ root -> do ts_document_root_node_p document root toTerm root @@ -102,7 +102,7 @@ documentToTerm language document blob = alloca $ \ root -> do , spanEnd = SourcePos (fromIntegral $ ts_node_p_end_point_row node) (fromIntegral $ ts_node_p_end_point_column node) } let cost' = 1 + sum (cost . extract <$> children) - let info = range .: (categoriesForLanguage language (toS name)) .: cost' .: sourceSpan .: RNil + let info = range .: (categoriesForLanguage language (toS name)) .: cost' .: RNil pure $! termConstructor (source blob) sourceSpan info children getChild node n out = do _ <- ts_node_p_named_child node n out diff --git a/test/CorpusSpec.hs b/test/CorpusSpec.hs index 02a76ebec..67aaabd7e 100644 --- a/test/CorpusSpec.hs +++ b/test/CorpusSpec.hs @@ -71,7 +71,7 @@ normalizeName path = addExtension (dropExtension $ dropExtension path) (takeExte -- | Given file paths for A, B, and, optionally, a diff, return whether diffing -- | the files will produce the diff. If no diff is provided, then the result -- | is true, but the diff will still be calculated. -testDiff :: Renderer (Record '[Range, Category, Cost, SourceSpan]) -> Both FilePath -> Maybe FilePath -> (Verbatim -> Verbatim -> Expectation) -> Expectation +testDiff :: Renderer (Record '[Range, Category, Cost]) -> Both FilePath -> Maybe FilePath -> (Verbatim -> Verbatim -> Expectation) -> Expectation testDiff renderer paths diff matcher = do sources <- sequence $ readAndTranscodeFile <$> paths actual <- Verbatim <$> diffFiles parser renderer (sourceBlobs sources) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index f796e4143..de561d4be 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -18,15 +18,14 @@ import Data.List (partition) import Term.Arbitrary import Interpreter import Info -import SourceSpan -arrayInfo :: Record '[Category, SourceSpan] -arrayInfo = ArrayLiteral .: SourceSpan "test.js" (SourcePos 0 0) (SourcePos 0 3) .: RNil +arrayInfo :: Record '[Category] +arrayInfo = ArrayLiteral .: RNil -literalInfo :: Record '[Category, SourceSpan] -literalInfo = StringLiteral .: SourceSpan "test.js" (SourcePos 0 0) (SourcePos 0 1) .: RNil +literalInfo :: Record '[Category] +literalInfo = StringLiteral .: RNil -testDiff :: Diff Text (Record '[Category, SourceSpan]) +testDiff :: Diff Text (Record '[Category]) testDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "a")) ]) testSummary :: DiffSummary DiffInfo @@ -42,7 +41,7 @@ spec = parallel $ do diffSummary testDiff `shouldBe` [ DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnotations = [ ArrayLiteral ] } ] prop "equal terms produce identity diffs" $ - \ a -> let term = toTerm (a :: ArbitraryTerm Text (Record '[Category, SourceSpan])) in + \ a -> let term = toTerm (a :: ArbitraryTerm Text (Record '[Category])) in diffSummary (diffTerms wrap (==) diffCost term term) `shouldBe` [] describe "annotatedSummaries" $ do @@ -53,7 +52,7 @@ spec = parallel $ do describe "DiffInfo" $ do prop "patches in summaries match the patches in diffs" $ \a -> let - diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Cost, SourceSpan]))) + diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Cost]))) summaries = diffSummary diff patches = toList diff in @@ -62,14 +61,14 @@ spec = parallel $ do (() <$ branchPatches, () <$ otherPatches) `shouldBe` (() <$ branchDiffPatches, () <$ otherDiffPatches) prop "generates one LeafInfo for each child in an arbitrary branch patch" $ \a -> let - diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, SourceSpan]))) + diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category]))) diffInfoPatches = patch <$> diffSummary diff syntaxPatches = toList diff extractLeaves :: DiffInfo -> [DiffInfo] extractLeaves (BranchInfo children _ _) = join $ extractLeaves <$> children extractLeaves leaf = [ leaf ] - extractDiffLeaves :: Term Text (Record '[Category, SourceSpan]) -> [ Term Text (Record '[Category, SourceSpan]) ] + extractDiffLeaves :: Term Text (Record '[Category]) -> [ Term Text (Record '[Category]) ] extractDiffLeaves term = case unwrap term of (Indexed children) -> join $ extractDiffLeaves <$> children (Fixed children) -> join $ extractDiffLeaves <$> children From 05b425771193c490a57d4b4cf680d1fa7c8e92cc Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 14:20:35 -0400 Subject: [PATCH 155/320] Take sources instead of blobs to simplify diffSummary interface --- src/DiffSummary.hs | 6 ++--- src/Diffing.hs | 52 ++++++++++++++++++++--------------------- src/Renderer/Summary.hs | 3 ++- 3 files changed, 31 insertions(+), 30 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 14cd75a0d..dc4da3aa8 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -157,8 +157,8 @@ maybeParentContext annotations = if null annotations toDoc :: Text -> Doc toDoc = string . toS -diffSummary :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both SourceBlob -> Diff leaf (Record fields) -> [DiffSummary DiffInfo] -diffSummary blobs = cata $ \case +diffSummary :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both (Source Char) -> Diff leaf (Record fields) -> [DiffSummary DiffInfo] +diffSummary sources = cata $ \case -- Skip comments and leaves since they don't have any changes (Free (_ :< Leaf _)) -> [] Free (_ :< (S.Comment _)) -> [] @@ -190,7 +190,7 @@ diffSummary blobs = cata $ \case (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ] where - (beforeSource, afterSource) = runJoin $ source <$> blobs + (beforeSource, afterSource) = runJoin sources annotateWithCategory infos = prependSummary (category $ snd infos) diff --git a/src/Diffing.hs b/src/Diffing.hs index 4856725b1..955f74d36 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -33,6 +33,32 @@ import TreeSitter import Text.Parser.TreeSitter.Language import qualified Data.Text as T +-- | Given a parser and renderer, diff two sources and return the rendered +-- | result. +-- | Returns the rendered result strictly, so it's always fully evaluated +-- | with respect to other IO actions. +diffFiles :: (HasField fields Category, HasField fields Cost, HasField fields Range, Eq (Record fields)) => Parser fields -> Renderer (Record fields) -> Both SourceBlob -> IO Text +diffFiles parser renderer sourceBlobs = do + let sources = source <$> sourceBlobs + terms <- sequence $ parser <$> sourceBlobs + + let replaceLeaves = breakDownLeavesByWord <$> sources + let areNullOids = runBothWith (\a b -> (oid a == nullOid || null (source a), oid b == nullOid || null (source b))) sourceBlobs + let textDiff = case areNullOids of + (True, False) -> pure $ Insert (snd terms) + (False, True) -> pure $ Delete (fst terms) + (_, _) -> + runBothWith (diffTerms construct compareCategoryEq diffCostWithCachedTermCosts) (replaceLeaves <*> terms) + + pure $! renderer sourceBlobs textDiff + + where construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax)) + sumCost = fmap getSum . foldMap (fmap Sum . getCost) + getCost diff = case runFree diff of + Free (info :< _) -> cost <$> info + Pure patch -> uncurry both (fromThese 0 0 (unPatch (cost . extract <$> patch))) + + -- | Return a parser based on the file extension (including the "."). parserForType :: Text -> Parser '[Range, Category, Cost] parserForType mediaType = case languageForType mediaType of @@ -84,31 +110,6 @@ readAndTranscodeFile path = do text <- B1.readFile path transcode text --- | Given a parser and renderer, diff two sources and return the rendered --- | result. --- | Returns the rendered result strictly, so it's always fully evaluated --- | with respect to other IO actions. -diffFiles :: (HasField fields Category, HasField fields Cost, HasField fields Range, Eq (Record fields)) => Parser fields -> Renderer (Record fields) -> Both SourceBlob -> IO Text -diffFiles parser renderer sourceBlobs = do - let sources = source <$> sourceBlobs - terms <- sequence $ parser <$> sourceBlobs - - let replaceLeaves = breakDownLeavesByWord <$> sources - let areNullOids = runBothWith (\a b -> (oid a == nullOid || null (source a), oid b == nullOid || null (source b))) sourceBlobs - let textDiff = case areNullOids of - (True, False) -> pure $ Insert (snd terms) - (False, True) -> pure $ Delete (fst terms) - (_, _) -> - runBothWith (diffTerms construct compareCategoryEq diffCostWithCachedTermCosts) (replaceLeaves <*> terms) - - pure $! renderer sourceBlobs textDiff - - where construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax)) - sumCost = fmap getSum . foldMap (fmap Sum . getCost) - getCost diff = case runFree diff of - Free (info :< _) -> cost <$> info - Pure patch -> uncurry both (fromThese 0 0 (unPatch (cost . extract <$> patch))) - compareCategoryEq :: HasField fields Category => Term leaf (Record fields) -> Term leaf (Record fields) -> Bool compareCategoryEq = (==) `on` category . extract @@ -118,7 +119,6 @@ diffCostWithCachedTermCosts diff = unCost $ case runFree diff of Free (info :< _) -> sum (cost <$> info) Pure patch -> sum (cost . extract <$> patch) - -- | Returns a rendered diff given a parser, diff arguments and two source blobs. textDiff :: (Eq (Record fields), HasField fields Category, HasField fields Cost, HasField fields Range) => Parser fields -> DiffArguments -> Both SourceBlob -> IO Text textDiff parser arguments sources = case format arguments of diff --git a/src/Renderer/Summary.hs b/src/Renderer/Summary.hs index a1aad2564..1969da4af 100644 --- a/src/Renderer/Summary.hs +++ b/src/Renderer/Summary.hs @@ -7,7 +7,8 @@ import Data.Aeson import Data.Record import Range import DiffSummary +import Source summary :: (HasField fields Category, HasField fields Range) => Renderer (Record fields) summary blobs diff = toS . encode $ summaries >>= annotatedSummaries - where summaries = diffSummary blobs diff \ No newline at end of file + where summaries = diffSummary (source <$> blobs) diff \ No newline at end of file From 1ba42a9d0f9ea836ff799f66b67f8e4f0ab2b4b6 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 14:31:02 -0400 Subject: [PATCH 156/320] Add Ranges to DiffSummarySpec --- test/DiffSummarySpec.hs | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index de561d4be..152b95e28 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -18,14 +18,16 @@ import Data.List (partition) import Term.Arbitrary import Interpreter import Info +import Source +import Data.Functor.Both -arrayInfo :: Record '[Category] -arrayInfo = ArrayLiteral .: RNil +arrayInfo :: Record '[Category, Range] +arrayInfo = ArrayLiteral .: Range 0 3 .: RNil -literalInfo :: Record '[Category] -literalInfo = StringLiteral .: RNil +literalInfo :: Record '[Category, Range] +literalInfo = StringLiteral .: Range 1 2 .: RNil -testDiff :: Diff Text (Record '[Category]) +testDiff :: Diff Text (Record '[Category, Range]) testDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "a")) ]) testSummary :: DiffSummary DiffInfo @@ -34,15 +36,17 @@ testSummary = DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnota replacementSummary :: DiffSummary DiffInfo replacementSummary = DiffSummary { patch = Replace (LeafInfo "string" "a") (LeafInfo "symbol" "b"), parentAnnotations = [ ArrayLiteral ] } +sources = both (fromText "[]") (fromText "[a]") + spec :: Spec spec = parallel $ do describe "diffSummary" $ do it "outputs a diff summary" $ do - diffSummary testDiff `shouldBe` [ DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnotations = [ ArrayLiteral ] } ] + diffSummary sources testDiff `shouldBe` [ DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnotations = [ ArrayLiteral ] } ] prop "equal terms produce identity diffs" $ - \ a -> let term = toTerm (a :: ArbitraryTerm Text (Record '[Category])) in - diffSummary (diffTerms wrap (==) diffCost term term) `shouldBe` [] + \ a -> let term = toTerm (a :: ArbitraryTerm Text (Record '[Category, Range])) in + diffSummary sources (diffTerms wrap (==) diffCost term term) `shouldBe` [] describe "annotatedSummaries" $ do it "should print adds" $ @@ -52,8 +56,8 @@ spec = parallel $ do describe "DiffInfo" $ do prop "patches in summaries match the patches in diffs" $ \a -> let - diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Cost]))) - summaries = diffSummary diff + diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Cost, Range]))) + summaries = diffSummary sources diff patches = toList diff in case (partition isBranchNode (patch <$> summaries), partition isIndexedOrFixed patches) of @@ -61,14 +65,14 @@ spec = parallel $ do (() <$ branchPatches, () <$ otherPatches) `shouldBe` (() <$ branchDiffPatches, () <$ otherDiffPatches) prop "generates one LeafInfo for each child in an arbitrary branch patch" $ \a -> let - diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category]))) - diffInfoPatches = patch <$> diffSummary diff + diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Range]))) + diffInfoPatches = patch <$> diffSummary sources diff syntaxPatches = toList diff extractLeaves :: DiffInfo -> [DiffInfo] extractLeaves (BranchInfo children _ _) = join $ extractLeaves <$> children extractLeaves leaf = [ leaf ] - extractDiffLeaves :: Term Text (Record '[Category]) -> [ Term Text (Record '[Category]) ] + extractDiffLeaves :: Term Text (Record '[Category, Range]) -> [ Term Text (Record '[Category, Range]) ] extractDiffLeaves term = case unwrap term of (Indexed children) -> join $ extractDiffLeaves <$> children (Fixed children) -> join $ extractDiffLeaves <$> children From 5e877cc3e9922594f4fa853a05f1dbd57940e4ff Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 14:31:15 -0400 Subject: [PATCH 157/320] Remove some redundant imports --- src/Diffing.hs | 1 - src/Info.hs | 2 +- src/Parser.hs | 1 - src/Renderer/Split.hs | 1 - src/SplitDiff.hs | 1 - 5 files changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Diffing.hs b/src/Diffing.hs index 955f74d36..89369cd09 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -12,7 +12,6 @@ import qualified Data.Text.ICU.Convert as Convert import Data.These import Diff import Info -import Category import Interpreter import Language import Parser diff --git a/src/Info.hs b/src/Info.hs index 9e9a204c7..44ba5c7e9 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-} -module Info (characterRange, setCharacterRange, category, setCategory, Cost(..), cost, setCost) where +module Info (Range(..), characterRange, setCharacterRange, Category(..), category, setCategory, Cost(..), cost, setCost) where import Data.Record import Prologue diff --git a/src/Parser.hs b/src/Parser.hs index ed48382fe..4f408596e 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -6,7 +6,6 @@ import Data.Record import Data.Text (pack) import Category as C import Info -import Range import qualified Syntax as S import Term import qualified Data.Set as Set diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index ab27270fe..0d1f117c3 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -12,7 +12,6 @@ import Data.These import Info import Prologue hiding (div, head, fst, snd, link) import qualified Prologue -import Range import Renderer import Source import SplitDiff diff --git a/src/SplitDiff.hs b/src/SplitDiff.hs index 9dc6459f7..be23cc521 100644 --- a/src/SplitDiff.hs +++ b/src/SplitDiff.hs @@ -2,7 +2,6 @@ module SplitDiff where import Data.Record import Info -import Range import Prologue import Syntax import Term (Term) From 380e980250b38fde42e1d69265ac0ed8089ef682 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 14:34:28 -0400 Subject: [PATCH 158/320] annotate sources --- test/DiffSummarySpec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 152b95e28..dfc01e535 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -36,6 +36,7 @@ testSummary = DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnota replacementSummary :: DiffSummary DiffInfo replacementSummary = DiffSummary { patch = Replace (LeafInfo "string" "a") (LeafInfo "symbol" "b"), parentAnnotations = [ ArrayLiteral ] } +sources :: Both (Source Char) sources = both (fromText "[]") (fromText "[a]") spec :: Spec From ebda2e69002e4fb941c18eafeabfbd4dff652bdc Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:31:04 -0400 Subject: [PATCH 159/320] Remove redundant import --- src/TreeSitter.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 9727c0f4b..811db5dda 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -7,7 +7,6 @@ import Category import Info import Language import Parser -import Range import Source import Foreign import Foreign.C.String From 2dbe0eca0ab99ca3415cc00f1a374d479e3d8920 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:31:11 -0400 Subject: [PATCH 160/320] Add Throw to Syntax --- src/Syntax.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Syntax.hs b/src/Syntax.hs index d06897412..e0a76d99f 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -60,6 +60,7 @@ data Syntax | DoWhile { doWhileBody :: f, doWhileExpr :: f } | While { whileExpr :: f, whileBody :: f } | Return (Maybe f) + | Throw f deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From 36aee3a87b00e76e12047206374f0e7aad19a694 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:32:54 -0400 Subject: [PATCH 161/320] Add Throw category --- src/Category.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Category.hs b/src/Category.hs index 24f31d4c2..e6de322a8 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -77,6 +77,8 @@ data Category | Object -- | A return statement. | Return + -- | A throw statement. + | Throw -- | A non-standard category, which can be used for comparability. | Other Text deriving (Eq, Generic, Ord, Show) From e9a02c219d71c9ea0ce3389c01e04f11c786fe5b Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:33:02 -0400 Subject: [PATCH 162/320] Add Throw to termConstructor --- src/Parser.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index 4f408596e..54a4a7e4f 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -95,11 +95,13 @@ termConstructor source sourceSpan info = cofree . construct construct children | isFixed (category info) = withDefaultInfo $ S.Fixed children construct children | C.Error == category info = withDefaultInfo $ S.Error sourceSpan children - construct children | For == (category info), Just (exprs, body) <- unsnoc children = + construct children | For == category info, Just (exprs, body) <- unsnoc children = withDefaultInfo $ S.For exprs body - construct children | While == (category info), [expr, body] <- children = + construct children | While == category info, [expr, body] <- children = withDefaultInfo $ S.While expr body - construct children | DoWhile == (category info), [expr, body] <- children = + construct children | DoWhile == category info, [expr, body] <- children = withDefaultInfo $ S.DoWhile expr body + construct children | Throw == category info, [expr] <- children = + withDefaultInfo $ S.Throw expr construct children = withDefaultInfo $ S.Indexed children From b97da37c79d2b09a26ac7b9159ac1efb284bf7db Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:33:15 -0400 Subject: [PATCH 163/320] Add Throw to defaultCategoryForNodeName --- src/TreeSitter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 811db5dda..7d14d539a 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -81,6 +81,7 @@ defaultCategoryForNodeName name = case name of "while_statement" -> While "do_statement" -> DoWhile "return_statement" -> Return + "throw_statement" -> Throw _ -> Other name -- | Return a parser for a tree sitter language & document. From 14c9f3f7a6ab9f8086d63e7fe1ac1d3457064f9c Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:33:51 -0400 Subject: [PATCH 164/320] Add Throw to JSON --- src/Renderer/JSON.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 2c6d726da..5ba639749 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -90,6 +90,7 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.Comment _ -> [] S.Commented comments child -> childrenFields (comments <> maybeToList child) S.Error sourceSpan c -> [ "sourceSpan" .= sourceSpan ] <> childrenFields c + S.Throw c -> [ "throwExpression" .= c ] where childrenFields c = [ "children" .= c ] patchFields :: (KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (Term leaf (Record fields)) -> [kv] From c70273b899b4035a8ff379fb8482745ebb48d1d6 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:34:15 -0400 Subject: [PATCH 165/320] Add Throw to Split --- src/Renderer/Split.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index 0d1f117c3..8c88719c9 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -65,6 +65,7 @@ styleName category = "category-" <> case category of C.While -> "while" C.DoWhile -> "do_while" C.Return -> "return_statement" + C.Throw -> "throw_statement" Other string -> string -- | Pick the class name for a split patch. From ef3c89dc4858aac5244f31aab28fcceae4b2a126 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:35:28 -0400 Subject: [PATCH 166/320] Add Throw to DiffSummary --- src/DiffSummary.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index dc4da3aa8..a3b807790 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -68,6 +68,7 @@ toTermName source term = case unwrap term of forClauseRanges = characterRange . extract <$> exprs S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr + S.Throw expr -> toTermName' expr Comment a -> toCategoryName a where toTermName' = toTermName source @@ -114,6 +115,7 @@ instance HasCategory Category where C.DoWhile -> "do/while statement" C.Object -> "object" C.Return -> "return statement" + C.Throw -> "throw statement" instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract @@ -186,6 +188,7 @@ diffSummary sources = cata $ \case (Free (infos :< S.For exprs body)) -> annotateWithCategory infos <$> join exprs <> body (Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body + (Free (infos :< S.Throw expr)) -> annotateWithCategory infos <$> expr (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ] (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ] From a3d9a69f65cad5bd0a8337b43bdb78b92618d6fa Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:37:05 -0400 Subject: [PATCH 167/320] Remove redundant Range --- src/Renderer/JSON.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 5ba639749..84039592a 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -15,7 +15,6 @@ import qualified Data.Text as T import Data.These import Data.Vector hiding (toList) import Info -import Range import Renderer import Source hiding (fromList) import SplitDiff From c6754c9cdc0820a839ccfa6bc30fcc1c002721d9 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:40:23 -0400 Subject: [PATCH 168/320] Extract child text for Throw diff summaries --- src/DiffSummary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index a3b807790..e34433814 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -68,7 +68,7 @@ toTermName source term = case unwrap term of forClauseRanges = characterRange . extract <$> exprs S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr - S.Throw expr -> toTermName' expr + S.Throw expr -> toText $ Source.slice (characterRange $ extract expr) source Comment a -> toCategoryName a where toTermName' = toTermName source From e577ff3b28d36708bff46b84e368c50176dae364 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:40:30 -0400 Subject: [PATCH 169/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 0989485a6..bcb07d990 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 0989485a6fad0ac82c12410c6ae6c9d5453662a2 +Subproject commit bcb07d9909ab948bb5c9b3e3853a2d46f3cec531 From 32130e68c3b6f83d7f1ff6af726bda85cf9bf97d Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:41:54 -0400 Subject: [PATCH 170/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 0989485a6..bcb07d990 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 0989485a6fad0ac82c12410c6ae6c9d5453662a2 +Subproject commit bcb07d9909ab948bb5c9b3e3853a2d46f3cec531 From fd1b648a9e0319814b674c33526c289155a4a9ae Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:42:27 -0400 Subject: [PATCH 171/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index bcb07d990..4a6e3d1a2 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit bcb07d9909ab948bb5c9b3e3853a2d46f3cec531 +Subproject commit 4a6e3d1a2b50d2ea285ef6f8681216bdb3442e94 From 2490d92c377bc8b5f0db3c5f6e80fc2b34c298db Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:45:25 -0400 Subject: [PATCH 172/320] Add Try statement --- src/Syntax.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Syntax.hs b/src/Syntax.hs index d06897412..477bdd06a 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -60,6 +60,7 @@ data Syntax | DoWhile { doWhileBody :: f, doWhileExpr :: f } | While { whileExpr :: f, whileBody :: f } | Return (Maybe f) + | Try f (Maybe f) (Maybe f) deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From ad9c63ef4230099ac78934f34fadb0c83c8a8990 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:58:49 -0400 Subject: [PATCH 173/320] Add Try/Catch/Finally categories --- src/Category.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Category.hs b/src/Category.hs index 24f31d4c2..fe111559b 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -77,6 +77,12 @@ data Category | Object -- | A return statement. | Return + -- | A try statement. + | Try + -- | A catch statement. + | Catch + -- | A finally statement. + | Finally -- | A non-standard category, which can be used for comparability. | Other Text deriving (Eq, Generic, Ord, Show) From f767ad20dbc2e551618ccbd1152c05e0db42626e Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:58:55 -0400 Subject: [PATCH 174/320] Construct Try terms --- src/Parser.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Parser.hs b/src/Parser.hs index 4f408596e..70e839609 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -101,5 +101,13 @@ termConstructor source sourceSpan info = cofree . construct withDefaultInfo $ S.While expr body construct children | DoWhile == (category info), [expr, body] <- children = withDefaultInfo $ S.DoWhile expr body + construct children | Try == category info = case children of + [body] -> withDefaultInfo $ S.Try body Nothing Nothing + [body, catch] | Catch <- category (extract catch) -> withDefaultInfo $ S.Try body (Just catch) Nothing + [body, finally] | Finally <- category (extract finally) -> withDefaultInfo $ S.Try body Nothing (Just finally) + [body, catch, finally] | Catch <- category (extract catch), + Finally <- category (extract finally) -> + withDefaultInfo $ S.Try body (Just catch) (Just finally) + _ -> S.Error sourceSpan children construct children = withDefaultInfo $ S.Indexed children From 0c8f13f396e843a90b9dcd96e2647acde3804f03 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:59:05 -0400 Subject: [PATCH 175/320] Add Try case to JSON --- src/Renderer/JSON.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 2c6d726da..9da214689 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -90,6 +90,7 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.Comment _ -> [] S.Commented comments child -> childrenFields (comments <> maybeToList child) S.Error sourceSpan c -> [ "sourceSpan" .= sourceSpan ] <> childrenFields c + S.Try body catch finally -> [ "tryBody" .= body ] <> [ "tryCatch" .= catch ] <> [ "tryFinally" .= finally ] where childrenFields c = [ "children" .= c ] patchFields :: (KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (Term leaf (Record fields)) -> [kv] From 2de0afbe959e00db904502a68f12f7ec0568a685 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:59:14 -0400 Subject: [PATCH 176/320] Add Try/Catch/Finally to Split --- src/Renderer/Split.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index 0d1f117c3..7e244f872 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -65,6 +65,9 @@ styleName category = "category-" <> case category of C.While -> "while" C.DoWhile -> "do_while" C.Return -> "return_statement" + C.Try -> "try_statement" + C.Catch -> "catch_statement" + C.Finally -> "finally_statement" Other string -> string -- | Pick the class name for a split patch. From ddcb6f6a1d5e695563df9cedc0ce6d9e9e35a92e Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 15:59:51 -0400 Subject: [PATCH 177/320] Add Try/Catch/Finally cases to defaultCategoryForNodeName --- src/TreeSitter.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 9727c0f4b..5bb0b0c2b 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -82,6 +82,9 @@ defaultCategoryForNodeName name = case name of "while_statement" -> While "do_statement" -> DoWhile "return_statement" -> Return + "try_statement" -> Try + "catch" -> Catch + "finally" -> Finally _ -> Other name -- | Return a parser for a tree sitter language & document. From 0bfa2fef2bc282a492a48f0766b07d96ea8a379e Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:02:25 -0400 Subject: [PATCH 178/320] Add Try to toTermName --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index dc4da3aa8..502058a54 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -68,6 +68,7 @@ toTermName source term = case unwrap term of forClauseRanges = characterRange . extract <$> exprs S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr + S.Try expr _ _ -> toText $ Source.slice (characterRange $ extract expr) source Comment a -> toCategoryName a where toTermName' = toTermName source From d20c1658801b9c0d118b4bf6501655975e2caddf Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:02:39 -0400 Subject: [PATCH 179/320] Add Try/Catch/Finally to HasCategory instance --- src/DiffSummary.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 502058a54..b09a43f0b 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -115,6 +115,9 @@ instance HasCategory Category where C.DoWhile -> "do/while statement" C.Object -> "object" C.Return -> "return statement" + C.Catch -> "catch statement" + C.Try -> "try statement" + C.Finally -> "finally statement" instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract From 3ab1501b4e8f4e236f75c4018e01a9975ffc5f7c Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:03:06 -0400 Subject: [PATCH 180/320] Add Try case to diffSummary --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index b09a43f0b..34075706e 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -190,6 +190,7 @@ diffSummary sources = cata $ \case (Free (infos :< S.For exprs body)) -> annotateWithCategory infos <$> join exprs <> body (Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body + (Free (infos :< S.Try expr catch finally)) -> annotateWithCategory infos <$> expr <> fromMaybe [] catch <> fromMaybe [] finally (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ] (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ] From 0bbc9293e9705905c67fad16b27b18c1a5c168ef Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:06:22 -0400 Subject: [PATCH 181/320] Return a CofreeF instead of Syntax --- src/Parser.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Parser.hs b/src/Parser.hs index 70e839609..efb70bc78 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -108,6 +108,6 @@ termConstructor source sourceSpan info = cofree . construct [body, catch, finally] | Catch <- category (extract catch), Finally <- category (extract finally) -> withDefaultInfo $ S.Try body (Just catch) (Just finally) - _ -> S.Error sourceSpan children + _ -> withDefaultInfo $ S.Error sourceSpan children construct children = withDefaultInfo $ S.Indexed children From b07a02d102f017ec80db4fcd6a67951b7fe690ff Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:14:38 -0400 Subject: [PATCH 182/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index bcb07d990..4a6e3d1a2 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit bcb07d9909ab948bb5c9b3e3853a2d46f3cec531 +Subproject commit 4a6e3d1a2b50d2ea285ef6f8681216bdb3442e94 From 04a976969e43ba2644f574dd54f19f1f4fdbff15 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:16:58 -0400 Subject: [PATCH 183/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 0989485a6..4a6e3d1a2 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 0989485a6fad0ac82c12410c6ae6c9d5453662a2 +Subproject commit 4a6e3d1a2b50d2ea285ef6f8681216bdb3442e94 From edaab80540982cc4a6fe7b5a91be08ca3e930130 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:22:41 -0400 Subject: [PATCH 184/320] Add Class to Syntax --- src/Syntax.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Syntax.hs b/src/Syntax.hs index d06897412..48d1c965f 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -60,6 +60,7 @@ data Syntax | DoWhile { doWhileBody :: f, doWhileExpr :: f } | While { whileExpr :: f, whileBody :: f } | Return (Maybe f) + | Class f (Maybe f) [f] deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From ef78210447f649eb674fd2db874219d7838adac9 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:28:27 -0400 Subject: [PATCH 185/320] Add a Class category --- src/Category.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Category.hs b/src/Category.hs index 24f31d4c2..f52d9de1c 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -77,6 +77,8 @@ data Category | Object -- | A return statement. | Return + -- | A class declaration. + | Class -- | A non-standard category, which can be used for comparability. | Other Text deriving (Eq, Generic, Ord, Show) From 82de031db88bc2fc09e7dac2e1e1af3057c9ee72 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:28:34 -0400 Subject: [PATCH 186/320] Construct Class nodes --- src/Parser.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Parser.hs b/src/Parser.hs index 4f408596e..1b86f3486 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -101,5 +101,12 @@ termConstructor source sourceSpan info = cofree . construct withDefaultInfo $ S.While expr body construct children | DoWhile == (category info), [expr, body] <- children = withDefaultInfo $ S.DoWhile expr body + construct children | Class == category info = case children of + [identifier, superclass, classBody] | S.Indexed definitions <- unwrap classBody -> + withDefaultInfo $ S.Class identifier (Just superclass) definitions + [identifier, classBody] | S.Indexed definitions <- unwrap classBody -> + withDefaultInfo $ S.Class identifier Nothing definitions + _ -> + withDefaultInfo $ S.Error sourceSpan children construct children = withDefaultInfo $ S.Indexed children From 1dc3fb272746953fc216ae4961118477f6efd263 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:28:51 -0400 Subject: [PATCH 187/320] Add a Class JS mapping in categoriesForLanguage --- src/TreeSitter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 9727c0f4b..06779dd43 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -44,6 +44,7 @@ categoriesForLanguage language name = case (language, name) of (JavaScript, "void_op") -> Operator (JavaScript, "for_in_statement") -> For (JavaScript, "for_of_statement") -> For + (JavaScript, "class") -> Class (Ruby, "hash") -> Object _ -> defaultCategoryForNodeName name From 1fb7ff4016a06e737c6dacced27d586e6984e0b5 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:31:00 -0400 Subject: [PATCH 188/320] Add Class to JSON --- src/Renderer/JSON.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 2c6d726da..a8cd2381c 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -90,6 +90,7 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.Comment _ -> [] S.Commented comments child -> childrenFields (comments <> maybeToList child) S.Error sourceSpan c -> [ "sourceSpan" .= sourceSpan ] <> childrenFields c + S.Class identifier superclass definitions -> [ "classIdentifier" .= identifier ] <> [ "superclass" .= superclass ] <> [ "classDefinitions" .= definitions ] where childrenFields c = [ "children" .= c ] patchFields :: (KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (Term leaf (Record fields)) -> [kv] From ce0c19e2796ee14e9f7cfb086015d51143b9bdba Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:31:19 -0400 Subject: [PATCH 189/320] Add class to styleName --- src/Renderer/Split.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index 0d1f117c3..c973d9f82 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -65,6 +65,7 @@ styleName category = "category-" <> case category of C.While -> "while" C.DoWhile -> "do_while" C.Return -> "return_statement" + C.Class -> "class_statement" Other string -> string -- | Pick the class name for a split patch. From b74a2a6f795145b79a9629043c4fb8ca215d4053 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:32:52 -0400 Subject: [PATCH 190/320] Add Class to toTermName --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index dc4da3aa8..c49f71872 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -68,6 +68,7 @@ toTermName source term = case unwrap term of forClauseRanges = characterRange . extract <$> exprs S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr + S.Class identifier _ _ -> toTermName' identifier Comment a -> toCategoryName a where toTermName' = toTermName source From ca563deafde05d056825dd040ab8130dbe7d1910 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:33:05 -0400 Subject: [PATCH 191/320] Add Class to HasCategory Category instance --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index c49f71872..b0071fc44 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -115,6 +115,7 @@ instance HasCategory Category where C.DoWhile -> "do/while statement" C.Object -> "object" C.Return -> "return statement" + C.Class -> "class" instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract From cb5df9b593a2eb7959216f543208a912222cc393 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:33:12 -0400 Subject: [PATCH 192/320] Add Class to diffSummary --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index b0071fc44..dd3dcb6e1 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -188,6 +188,7 @@ diffSummary sources = cata $ \case (Free (infos :< S.For exprs body)) -> annotateWithCategory infos <$> join exprs <> body (Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body + (Free (infos :< S.Class identifier superclass definitions)) -> annotateWithCategory infos <$> identifier <> superclass <> join definitions (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ] (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ] From b242555021182e0b9309f11a8d17f111f8558a38 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:34:09 -0400 Subject: [PATCH 193/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 4a6e3d1a2..44c2dcac3 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 4a6e3d1a2b50d2ea285ef6f8681216bdb3442e94 +Subproject commit 44c2dcac37823fc6493c9226bfa15c7da1357d2c From 770c144a308a8ac8f08c9cb8384be5395d6c83a7 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:35:52 -0400 Subject: [PATCH 194/320] use fromMaybe since superclass is a Maybe --- src/DiffSummary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index dd3dcb6e1..903da38e4 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -188,7 +188,7 @@ diffSummary sources = cata $ \case (Free (infos :< S.For exprs body)) -> annotateWithCategory infos <$> join exprs <> body (Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body - (Free (infos :< S.Class identifier superclass definitions)) -> annotateWithCategory infos <$> identifier <> superclass <> join definitions + (Free (infos :< S.Class identifier superclass definitions)) -> annotateWithCategory infos <$> identifier <> fromMaybe [] superclass <> join definitions (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ] (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ] From 12e8d15002488fb5239230528b15be90912e19aa Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:40:41 -0400 Subject: [PATCH 195/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 0989485a6..1c6b3eede 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 0989485a6fad0ac82c12410c6ae6c9d5453662a2 +Subproject commit 1c6b3eedec733198c32d097860fca556174e9a3d From 19b29e6beb2e5aea2a5e673d8bb1c6f3438f4a25 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:42:38 -0400 Subject: [PATCH 196/320] Add Array to Syntax --- src/Syntax.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Syntax.hs b/src/Syntax.hs index d06897412..2e4a19ce9 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -60,6 +60,7 @@ data Syntax | DoWhile { doWhileBody :: f, doWhileExpr :: f } | While { whileExpr :: f, whileBody :: f } | Return (Maybe f) + | Array [f] deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From bd0ac540c64f90f32819b22782f7d36425b023f9 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:43:59 -0400 Subject: [PATCH 197/320] Construct Array syntax --- src/Parser.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Parser.hs b/src/Parser.hs index 4f408596e..8751736f0 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -101,5 +101,7 @@ termConstructor source sourceSpan info = cofree . construct withDefaultInfo $ S.While expr body construct children | DoWhile == (category info), [expr, body] <- children = withDefaultInfo $ S.DoWhile expr body + construct children | ArrayLiteral == category info = + withDefaultInfo $ S.Array children construct children = withDefaultInfo $ S.Indexed children From 65c9d53c6b7b341ac68b0600346edaf2f9891547 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:45:07 -0400 Subject: [PATCH 198/320] Add ArrayLiteral to Split.styleName --- src/Renderer/JSON.hs | 1 + src/Renderer/Split.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 2c6d726da..2cb3d64e0 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -90,6 +90,7 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.Comment _ -> [] S.Commented comments child -> childrenFields (comments <> maybeToList child) S.Error sourceSpan c -> [ "sourceSpan" .= sourceSpan ] <> childrenFields c + S.Array c -> childrenFields c where childrenFields c = [ "children" .= c ] patchFields :: (KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (Term leaf (Record fields)) -> [kv] diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index 0d1f117c3..9d31a21fe 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -40,7 +40,6 @@ styleName category = "category-" <> case category of StringLiteral -> "string" SymbolLiteral -> "symbol" IntegerLiteral -> "integer" - ArrayLiteral -> "array" C.FunctionCall -> "function_call" C.Function -> "function" C.MethodCall -> "method_call" @@ -65,6 +64,7 @@ styleName category = "category-" <> case category of C.While -> "while" C.DoWhile -> "do_while" C.Return -> "return_statement" + C.ArrayLiteral -> "array" Other string -> string -- | Pick the class name for a split patch. From 9453f8949d627f922385b2432ed86e22276d15d2 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:46:04 -0400 Subject: [PATCH 199/320] Add Array to toTermName --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index dc4da3aa8..112a85865 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -68,6 +68,7 @@ toTermName source term = case unwrap term of forClauseRanges = characterRange . extract <$> exprs S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr + S.Array _ -> toText $ Source.slice (characterRange $ extract term) source Comment a -> toCategoryName a where toTermName' = toTermName source From 5bef01097045b3ea4326d7a8003deaa6c93de9f9 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:46:16 -0400 Subject: [PATCH 200/320] Don't need to scope ArrayLiteral in styleName --- src/Renderer/Split.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index 9d31a21fe..d083c0445 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -64,7 +64,7 @@ styleName category = "category-" <> case category of C.While -> "while" C.DoWhile -> "do_while" C.Return -> "return_statement" - C.ArrayLiteral -> "array" + ArrayLiteral -> "array" Other string -> string -- | Pick the class name for a split patch. From 2a021201312d72cf2d167ca17fb49ee83848b8cb Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:47:08 -0400 Subject: [PATCH 201/320] Add Array to diffSummary --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 112a85865..bed1b84ff 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -187,6 +187,7 @@ diffSummary sources = cata $ \case (Free (infos :< S.For exprs body)) -> annotateWithCategory infos <$> join exprs <> body (Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body + (Free (infos :< S.Array children)) -> annotateWithCategory infos <$> join children (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ] (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ] From a18305da09555e97ed3ba96dca3660b9f94f184c Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:50:10 -0400 Subject: [PATCH 202/320] qualify Aeson.Array as A.Array --- src/Renderer/JSON.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 2cb3d64e0..4e2becb68 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -7,7 +7,7 @@ module Renderer.JSON ( import Prologue hiding (toList) import Alignment import Category -import Data.Aeson hiding (json) +import Data.Aeson as A hiding (json) import Data.Bifunctor.Join import Data.ByteString.Builder import Data.Record @@ -36,13 +36,13 @@ instance ToJSON Category where toJSON (Other s) = String s toJSON s = String . T.pack $ show s instance ToJSON Range where - toJSON (Range start end) = Array . fromList $ toJSON <$> [ start, end ] + toJSON (Range start end) = A.Array . fromList $ toJSON <$> [ start, end ] toEncoding (Range start end) = foldable [ start, end ] instance ToJSON a => ToJSON (Join These a) where - toJSON (Join vs) = Array . fromList $ toJSON <$> these pure pure (\ a b -> [ a, b ]) vs + toJSON (Join vs) = A.Array . fromList $ toJSON <$> these pure pure (\ a b -> [ a, b ]) vs toEncoding = foldable instance ToJSON a => ToJSON (Join (,) a) where - toJSON (Join (a, b)) = Array . fromList $ toJSON <$> [ a, b ] + toJSON (Join (a, b)) = A.Array . fromList $ toJSON <$> [ a, b ] toEncoding = foldable instance (HasField fields Category, HasField fields Range) => ToJSON (SplitDiff leaf (Record fields)) where toJSON splitDiff = case runFree splitDiff of From b354ed61d9f94fe376f37ad18c02fa6a11bfe054 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 16:57:30 -0400 Subject: [PATCH 203/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 44c2dcac3..7a46849e3 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 44c2dcac37823fc6493c9226bfa15c7da1357d2c +Subproject commit 7a46849e3dca65bcb8baf099fb2c59ca151571b0 From 5b32cd254efcf39b57a3c40a35ee69401071e5c3 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 17:37:21 -0400 Subject: [PATCH 204/320] ++tree-sitter-parsers --- vendor/tree-sitter-parsers | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/tree-sitter-parsers b/vendor/tree-sitter-parsers index 0fdcbafdb..1229ed83d 160000 --- a/vendor/tree-sitter-parsers +++ b/vendor/tree-sitter-parsers @@ -1 +1 @@ -Subproject commit 0fdcbafdb69853a03db28e789bb00a2f733c6990 +Subproject commit 1229ed83d0501dc3dbca9d4ceab70702763c76bb From 2985bbd25680b84aa5136f03659b31d396ed3ce0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 17:37:51 -0400 Subject: [PATCH 205/320] Add MethodDefinition to Syntax --- src/Syntax.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Syntax.hs b/src/Syntax.hs index 48d1c965f..c82b8974d 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -61,6 +61,7 @@ data Syntax | While { whileExpr :: f, whileBody :: f } | Return (Maybe f) | Class f (Maybe f) [f] + | MethodDefinition f (Maybe f) f deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From 828a2163bf8ece676e933a2d7b6ac29de57cff9a Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 18:31:39 -0400 Subject: [PATCH 206/320] Add MethodDefinition --- src/Syntax.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index c82b8974d..3c327bb7f 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -60,8 +60,10 @@ data Syntax | DoWhile { doWhileBody :: f, doWhileExpr :: f } | While { whileExpr :: f, whileBody :: f } | Return (Maybe f) + -- | A class with an identifier, superclass, and a list of definitions. | Class f (Maybe f) [f] - | MethodDefinition f (Maybe f) f + -- | A method definition with an identifier, params, and a body. + | MethodDefinition f [f] [f] deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From f931031515a9a578010e164daa86cc40d32cbe34 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 18:33:01 -0400 Subject: [PATCH 207/320] s/body/list of expressions --- src/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index 3c327bb7f..d83e9dbb8 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -62,7 +62,7 @@ data Syntax | Return (Maybe f) -- | A class with an identifier, superclass, and a list of definitions. | Class f (Maybe f) [f] - -- | A method definition with an identifier, params, and a body. + -- | A method definition with an identifier, params, and a list of expressions. | MethodDefinition f [f] [f] deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From bb630ebbb0d20be02f5fb51c983a06abc21d365b Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 18:33:09 -0400 Subject: [PATCH 208/320] Move Syntax instance up --- src/Syntax.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index d83e9dbb8..56da146b7 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -69,6 +69,11 @@ data Syntax -- Instances +instance (Arbitrary leaf, Arbitrary f) => Arbitrary (Syntax leaf f) where + arbitrary = sized (syntaxOfSize (`resize` arbitrary) ) + + shrink = genericShrink + syntaxOfSize :: Arbitrary leaf => (Int -> Gen f) -> Int -> Gen (Syntax leaf f) syntaxOfSize recur n | n <= 1 = oneof $ (Leaf <$> arbitrary) : branchGeneratorsOfSize n | otherwise = oneof $ branchGeneratorsOfSize n @@ -82,8 +87,3 @@ syntaxOfSize recur n | n <= 1 = oneof $ (Leaf <$> arbitrary) : branchGeneratorsO first <- recur m rest <- childrenOfSize (n - m) pure $! first : rest - -instance (Arbitrary leaf, Arbitrary f) => Arbitrary (Syntax leaf f) where - arbitrary = sized (syntaxOfSize (`resize` arbitrary) ) - - shrink = genericShrink From 1c5f94631c3e858b269cfc10df6a7e65d4a27588 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 18:37:41 -0400 Subject: [PATCH 209/320] s/diffSummary/diffSummaries --- src/DiffSummary.hs | 6 +++--- src/Renderer/Summary.hs | 2 +- test/DiffSummarySpec.hs | 10 +++++----- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 903da38e4..5854a9143 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds, TypeFamilies, ScopedTypeVariables #-} -module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..), annotatedSummaries) where +module DiffSummary (DiffSummary(..), diffSummaries, DiffInfo(..), annotatedSummaries) where import Prologue hiding (snd, intercalate) import Diff @@ -159,8 +159,8 @@ maybeParentContext annotations = if null annotations toDoc :: Text -> Doc toDoc = string . toS -diffSummary :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both (Source Char) -> Diff leaf (Record fields) -> [DiffSummary DiffInfo] -diffSummary sources = cata $ \case +diffSummaries :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both (Source Char) -> Diff leaf (Record fields) -> [DiffSummary DiffInfo] +diffSummaries sources = cata $ \case -- Skip comments and leaves since they don't have any changes (Free (_ :< Leaf _)) -> [] Free (_ :< (S.Comment _)) -> [] diff --git a/src/Renderer/Summary.hs b/src/Renderer/Summary.hs index 1969da4af..68bed1987 100644 --- a/src/Renderer/Summary.hs +++ b/src/Renderer/Summary.hs @@ -11,4 +11,4 @@ import Source summary :: (HasField fields Category, HasField fields Range) => Renderer (Record fields) summary blobs diff = toS . encode $ summaries >>= annotatedSummaries - where summaries = diffSummary (source <$> blobs) diff \ No newline at end of file + where summaries = diffSummaries (source <$> blobs) diff \ No newline at end of file diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index dfc01e535..dc648c4bf 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -41,13 +41,13 @@ sources = both (fromText "[]") (fromText "[a]") spec :: Spec spec = parallel $ do - describe "diffSummary" $ do + describe "diffSummaries" $ do it "outputs a diff summary" $ do - diffSummary sources testDiff `shouldBe` [ DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnotations = [ ArrayLiteral ] } ] + diffSummaries sources testDiff `shouldBe` [ DiffSummary { patch = Insert (LeafInfo "string" "a"), parentAnnotations = [ ArrayLiteral ] } ] prop "equal terms produce identity diffs" $ \ a -> let term = toTerm (a :: ArbitraryTerm Text (Record '[Category, Range])) in - diffSummary sources (diffTerms wrap (==) diffCost term term) `shouldBe` [] + diffSummaries sources (diffTerms wrap (==) diffCost term term) `shouldBe` [] describe "annotatedSummaries" $ do it "should print adds" $ @@ -58,7 +58,7 @@ spec = parallel $ do prop "patches in summaries match the patches in diffs" $ \a -> let diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Cost, Range]))) - summaries = diffSummary sources diff + summaries = diffSummaries sources diff patches = toList diff in case (partition isBranchNode (patch <$> summaries), partition isIndexedOrFixed patches) of @@ -67,7 +67,7 @@ spec = parallel $ do prop "generates one LeafInfo for each child in an arbitrary branch patch" $ \a -> let diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Range]))) - diffInfoPatches = patch <$> diffSummary sources diff + diffInfoPatches = patch <$> diffSummaries sources diff syntaxPatches = toList diff extractLeaves :: DiffInfo -> [DiffInfo] extractLeaves (BranchInfo children _ _) = join $ extractLeaves <$> children From eb3df7db6a16a1268283ad575b7cf27ef2e5c65d Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 18:39:08 -0400 Subject: [PATCH 210/320] MethodDefinition --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 5854a9143..005c0781b 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -189,6 +189,7 @@ diffSummaries sources = cata $ \case (Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.Class identifier superclass definitions)) -> annotateWithCategory infos <$> identifier <> fromMaybe [] superclass <> join definitions + (Free (infos :< S.MethodDefinition identifier params definitions)) -> annotateWithCategory infos <$> identifier <> join params <> join definitions (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ] (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ] From d3df14cafde3ef6b9de84280512bd3938738b36d Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 29 Jul 2016 23:41:21 -0400 Subject: [PATCH 211/320] Add method definitions --- src/Category.hs | 2 ++ src/Parser.hs | 2 ++ src/Syntax.hs | 2 +- 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Category.hs b/src/Category.hs index f52d9de1c..68b089d89 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -79,6 +79,8 @@ data Category | Return -- | A class declaration. | Class + -- | A class method declaration. + | Method -- | A non-standard category, which can be used for comparability. | Other Text deriving (Eq, Generic, Ord, Show) diff --git a/src/Parser.hs b/src/Parser.hs index 1b86f3486..e890d16ce 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -101,6 +101,8 @@ termConstructor source sourceSpan info = cofree . construct withDefaultInfo $ S.While expr body construct children | DoWhile == (category info), [expr, body] <- children = withDefaultInfo $ S.DoWhile expr body + construct children | Method == category info, [identifier, params, definitions] <- children = + withDefaultInfo $ S.Method identifier params definitions construct children | Class == category info = case children of [identifier, superclass, classBody] | S.Indexed definitions <- unwrap classBody -> withDefaultInfo $ S.Class identifier (Just superclass) definitions diff --git a/src/Syntax.hs b/src/Syntax.hs index 56da146b7..0ab0a7cfc 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -63,7 +63,7 @@ data Syntax -- | A class with an identifier, superclass, and a list of definitions. | Class f (Maybe f) [f] -- | A method definition with an identifier, params, and a list of expressions. - | MethodDefinition f [f] [f] + | Method f [f] [f] deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From 69e2c99634d7976101d29148f0bd0ef3d634ba8c Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 13:26:21 -0400 Subject: [PATCH 212/320] update Method JSON --- src/Renderer/JSON.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index a8cd2381c..85f298859 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -15,7 +15,6 @@ import qualified Data.Text as T import Data.These import Data.Vector hiding (toList) import Info -import Range import Renderer import Source hiding (fromList) import SplitDiff @@ -90,7 +89,8 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.Comment _ -> [] S.Commented comments child -> childrenFields (comments <> maybeToList child) S.Error sourceSpan c -> [ "sourceSpan" .= sourceSpan ] <> childrenFields c - S.Class identifier superclass definitions -> [ "classIdentifier" .= identifier ] <> [ "superclass" .= superclass ] <> [ "classDefinitions" .= definitions ] + S.Class identifier superclass definitions -> [ "classIdentifier" .= identifier ] <> [ "superclass" .= superclass ] <> [ "definitions" .= definitions ] + S.Method identifier params definitions -> [ "methodIdentifier" .= identifier ] <> [ "params" .= params ] <> [ "definitions" .= definitions ] where childrenFields c = [ "children" .= c ] patchFields :: (KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (Term leaf (Record fields)) -> [kv] From b3f523d9ef860be04c267fb9c5c895a8d944d40b Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 13:47:30 -0400 Subject: [PATCH 213/320] s/MethodDefinition/Method --- src/DiffSummary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 005c0781b..4f8db8da8 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -189,7 +189,7 @@ diffSummaries sources = cata $ \case (Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.Class identifier superclass definitions)) -> annotateWithCategory infos <$> identifier <> fromMaybe [] superclass <> join definitions - (Free (infos :< S.MethodDefinition identifier params definitions)) -> annotateWithCategory infos <$> identifier <> join params <> join definitions + (Free (infos :< S.Method identifier params definitions)) -> annotateWithCategory infos <$> identifier <> join params <> join definitions (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ] (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ] From c8b5fb8c08b2ace5426dca333c0805b8894076e7 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:00:47 -0400 Subject: [PATCH 214/320] Add Method to toTermName --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 4f8db8da8..e9b3d3a12 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -69,6 +69,7 @@ toTermName source term = case unwrap term of S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr S.Class identifier _ _ -> toTermName' identifier + S.Method identifier _ _ -> toTermName' identifier Comment a -> toCategoryName a where toTermName' = toTermName source From 1afa6d7b0f0bcc8fdd79c68cae563daca9677eff Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:00:58 -0400 Subject: [PATCH 215/320] Add Method to HasCategory Category instance --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index e9b3d3a12..887949fb3 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -117,6 +117,7 @@ instance HasCategory Category where C.Object -> "object" C.Return -> "return statement" C.Class -> "class" + C.Method -> "method" instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract From 792440ff56bc13e1e56846386dcaa8fe911c73c0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:01:15 -0400 Subject: [PATCH 216/320] Parse method definitions and method expressions better --- src/Parser.hs | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index e890d16ce..01cf22bfb 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -101,14 +101,34 @@ termConstructor source sourceSpan info = cofree . construct withDefaultInfo $ S.While expr body construct children | DoWhile == (category info), [expr, body] <- children = withDefaultInfo $ S.DoWhile expr body - construct children | Method == category info, [identifier, params, definitions] <- children = - withDefaultInfo $ S.Method identifier params definitions + construct children | Method == category info = case children of + [identifier, params, exprs] | + Params == category (extract params), + S.Indexed params' <- unwrap params, + exprs' <- expressionStatements exprs -> + withDefaultInfo $ S.Method identifier params' exprs' + [identifier, exprs] | exprs' <- expressionStatements exprs -> + withDefaultInfo $ S.Method identifier mempty exprs' + _ -> + withDefaultInfo $ S.Error sourceSpan children construct children | Class == category info = case children of - [identifier, superclass, classBody] | S.Indexed definitions <- unwrap classBody -> - withDefaultInfo $ S.Class identifier (Just superclass) definitions - [identifier, classBody] | S.Indexed definitions <- unwrap classBody -> - withDefaultInfo $ S.Class identifier Nothing definitions + [identifier, superclass, definitions] | definitions' <- methodDefinitions definitions -> + withDefaultInfo $ S.Class identifier (Just superclass) definitions' + [identifier, definitions] | definitions' <- methodDefinitions definitions -> + withDefaultInfo $ S.Class identifier Nothing definitions' _ -> withDefaultInfo $ S.Error sourceSpan children construct children = withDefaultInfo $ S.Indexed children + +expressionStatements :: HasField fields Category => Term Text (Record fields) -> [Term Text (Record fields)] +expressionStatements exprs | + Other "statement_block" == category (extract exprs), + S.Indexed exprs' <- unwrap exprs = exprs' +expressionStatements _ = mempty + +methodDefinitions :: HasField fields Category => Term Text (Record fields) -> [Term Text (Record fields)] +methodDefinitions definitions | + Other "class_body" == category (extract definitions), + S.Indexed definitions' <- unwrap definitions = definitions' +methodDefinitions _ = mempty \ No newline at end of file From 00613a034b348a54cb837c2ee7a7becc149c87df Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:01:20 -0400 Subject: [PATCH 217/320] Remove redundant import --- src/TreeSitter.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 06779dd43..6a1ef0eba 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -7,7 +7,6 @@ import Category import Info import Language import Parser -import Range import Source import Foreign import Foreign.C.String From 0e5255b7deaacdbaf104a3da93fb392d23e100e2 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:08:46 -0400 Subject: [PATCH 218/320] Map method_definition to Method categories --- src/TreeSitter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 6a1ef0eba..13b14a8f9 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -82,6 +82,7 @@ defaultCategoryForNodeName name = case name of "while_statement" -> While "do_statement" -> DoWhile "return_statement" -> Return + "method_definition" -> Method _ -> Other name -- | Return a parser for a tree sitter language & document. From 64dbee5cb2d98a4e39ab3a56952c7d3fdab6bb25 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:13:36 -0400 Subject: [PATCH 219/320] ++tree-sitter-parsers ++js-test --- test/repos/js-test | 2 +- vendor/tree-sitter-parsers | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/test/repos/js-test b/test/repos/js-test index 0989485a6..7a46849e3 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 0989485a6fad0ac82c12410c6ae6c9d5453662a2 +Subproject commit 7a46849e3dca65bcb8baf099fb2c59ca151571b0 diff --git a/vendor/tree-sitter-parsers b/vendor/tree-sitter-parsers index 0fdcbafdb..1229ed83d 160000 --- a/vendor/tree-sitter-parsers +++ b/vendor/tree-sitter-parsers @@ -1 +1 @@ -Subproject commit 0fdcbafdb69853a03db28e789bb00a2f733c6990 +Subproject commit 1229ed83d0501dc3dbca9d4ceab70702763c76bb From 347f0309dd83e932866a652fd1698de920a79a6e Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:25:52 -0400 Subject: [PATCH 220/320] Add Constructor Category --- src/Category.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Category.hs b/src/Category.hs index 24f31d4c2..13303c65e 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -77,6 +77,8 @@ data Category | Object -- | A return statement. | Return + -- | A constructor statement, e.g. new Foo; + | Constructor -- | A non-standard category, which can be used for comparability. | Other Text deriving (Eq, Generic, Ord, Show) From 27941fd2ce533555ea5b4e9b70cd840170ce716f Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:26:01 -0400 Subject: [PATCH 221/320] Add Constructor to toTermName --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index dc4da3aa8..bc420cbe9 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -68,6 +68,7 @@ toTermName source term = case unwrap term of forClauseRanges = characterRange . extract <$> exprs S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr + S.Constructor expr -> toTermName' expr Comment a -> toCategoryName a where toTermName' = toTermName source From 001407df2b1cff73e827a80528bf822ee2037834 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:26:13 -0400 Subject: [PATCH 222/320] Add Constructor to HasCategory Category instance --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index bc420cbe9..c79704e83 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -115,6 +115,7 @@ instance HasCategory Category where C.DoWhile -> "do/while statement" C.Object -> "object" C.Return -> "return statement" + C.Constructor -> "constructor" instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where toCategoryName = toCategoryName . category . extract From a625302391705b9ae25c18da27f4768a29a468c7 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:26:21 -0400 Subject: [PATCH 223/320] Add Constructor to diffSummary --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index c79704e83..ce9f405aa 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -188,6 +188,7 @@ diffSummary sources = cata $ \case (Free (infos :< S.For exprs body)) -> annotateWithCategory infos <$> join exprs <> body (Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body + (Free (infos :< S.Constructor expr)) -> annotateWithCategory infos <$> expr (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ] (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ] From a456a4f64ed3598b3aeb1e67566ba660b47050d0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:26:32 -0400 Subject: [PATCH 224/320] Parse Constructor syntax --- src/Parser.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Parser.hs b/src/Parser.hs index 4f408596e..6cc355f0e 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -101,5 +101,7 @@ termConstructor source sourceSpan info = cofree . construct withDefaultInfo $ S.While expr body construct children | DoWhile == (category info), [expr, body] <- children = withDefaultInfo $ S.DoWhile expr body + construct children | Constructor == category info, [expr] <- children = + withDefaultInfo $ S.Constructor expr construct children = withDefaultInfo $ S.Indexed children From b68a2d8bffd8cd60ecad011207c76bd95325a243 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:26:48 -0400 Subject: [PATCH 225/320] Add constructor to JSON --- src/Renderer/JSON.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 2c6d726da..2e27c604c 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -86,7 +86,8 @@ termFields info syntax = "range" .= characterRange info : "category" .= category S.SubscriptAccess id property -> [ "subscriptId" .= id ] <> [ "property" .= property ] S.Object pairs -> childrenFields pairs S.Pair a b -> childrenFields [a, b] - S.Return expr -> [ "returnExpr" .= expr ] + S.Return expr -> [ "returnExpression" .= expr ] + S.Constructor expr -> [ "constructorExpression" .= expr ] S.Comment _ -> [] S.Commented comments child -> childrenFields (comments <> maybeToList child) S.Error sourceSpan c -> [ "sourceSpan" .= sourceSpan ] <> childrenFields c From b2c66eb5cec7ff7380ec80b81391e2e5fe04cf04 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:26:59 -0400 Subject: [PATCH 226/320] Add Constructor to Split.styleName --- src/Renderer/Split.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index 0d1f117c3..729646340 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -65,6 +65,7 @@ styleName category = "category-" <> case category of C.While -> "while" C.DoWhile -> "do_while" C.Return -> "return_statement" + C.Constructor -> "constructor" Other string -> string -- | Pick the class name for a split patch. From f228ed0b6d5602006d38458f342266aa156dc1d0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:27:11 -0400 Subject: [PATCH 227/320] Add Constructor to Syntax --- src/Syntax.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Syntax.hs b/src/Syntax.hs index d06897412..a7eeaaece 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -60,6 +60,7 @@ data Syntax | DoWhile { doWhileBody :: f, doWhileExpr :: f } | While { whileExpr :: f, whileBody :: f } | Return (Maybe f) + | Constructor f deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable) From e2d0b01ced2ae9161d709de0908ceb5c9a73087d Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:27:34 -0400 Subject: [PATCH 228/320] Map JS new_expression to Constructor --- src/TreeSitter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 9727c0f4b..5d5c088ad 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -44,6 +44,7 @@ categoriesForLanguage language name = case (language, name) of (JavaScript, "void_op") -> Operator (JavaScript, "for_in_statement") -> For (JavaScript, "for_of_statement") -> For + (JavaScript, "new_expression") -> Constructor (Ruby, "hash") -> Object _ -> defaultCategoryForNodeName name From 262de7f07e080987fdff03a4549fe5d36cc34f2f Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 14:27:41 -0400 Subject: [PATCH 229/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 7a46849e3..0e185203c 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 7a46849e3dca65bcb8baf099fb2c59ca151571b0 +Subproject commit 0e185203ca83e51f7fc2dbbb3b251f77b876a270 From 2b55638fc86d172153123cded32a89fd83a4d62b Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 22:41:02 -0400 Subject: [PATCH 230/320] ++tree-sitter-parsers --- test/repos/js-test | 2 +- vendor/tree-sitter-parsers | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/test/repos/js-test b/test/repos/js-test index 0989485a6..0e185203c 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 0989485a6fad0ac82c12410c6ae6c9d5453662a2 +Subproject commit 0e185203ca83e51f7fc2dbbb3b251f77b876a270 diff --git a/vendor/tree-sitter-parsers b/vendor/tree-sitter-parsers index 0fdcbafdb..b32d12c13 160000 --- a/vendor/tree-sitter-parsers +++ b/vendor/tree-sitter-parsers @@ -1 +1 @@ -Subproject commit 0fdcbafdb69853a03db28e789bb00a2f733c6990 +Subproject commit b32d12c13da744d1b0edc2901988f5e29eae2e49 From 215310fc002b8622c60fb9ac2e00953517f2407b Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 11:46:12 -0400 Subject: [PATCH 231/320] Extract the Operator text using its children's ranges, or with the term's range --- src/DiffSummary.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index dc4da3aa8..9c78a0b38 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -59,17 +59,17 @@ toTermName source term = case unwrap term of S.Switch expr _ -> toTermName' expr S.Ternary expr _ -> toTermName' expr S.MathAssignment id _ -> toTermName' id - S.Operator syntaxes -> mconcat $ toTermName' <$> syntaxes + S.Operator exprs -> termNameFromChildren term exprs S.Object kvs -> "{" <> intercalate ", " (toTermName' <$> kvs) <> "}" S.Pair a b -> toTermName' a <> ": " <> toTermName' b S.Return expr -> maybe "empty" toTermName' expr - S.For exprs _ -> toText $ Source.slice (unionRangesFrom forRange forClauseRanges) source - where forRange = characterRange $ extract term - forClauseRanges = characterRange . extract <$> exprs + S.For exprs _ -> termNameFromChildren term exprs S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr Comment a -> toCategoryName a where toTermName' = toTermName source + termNameFromChildren term cs = toText $ Source.slice (unionRangesFrom (range term) (range <$> cs)) source + range term = (characterRange $ extract term) class HasCategory a where toCategoryName :: a -> Text From 8cb62b67894be74e513c1a89323457f6cb32c80b Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 11:51:45 -0400 Subject: [PATCH 232/320] ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 0e185203c..3af143b53 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 0e185203ca83e51f7fc2dbbb3b251f77b876a270 +Subproject commit 3af143b53c8f9a2a6761d8e9ea91d47982cc3bc0 From 2d0d01f3c4af429ad0373daa29516405d50399f6 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 11:57:37 -0400 Subject: [PATCH 233/320] Don't create dummy LeafInfos for Operators --- src/DiffSummary.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 9c78a0b38..3886def90 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -207,7 +207,6 @@ termToDiffInfo blob term = case unwrap term of -- Currently we cannot express the operator for an operator production from TreeSitter. Eventually we should be able to -- use the term name of the operator identifier when we have that production value. Until then, I'm using a placeholder value -- to indicate where that value should be when constructing DiffInfos. - S.Operator _ -> LeafInfo (toCategoryName term) "x" Commented cs leaf -> BranchInfo (termToDiffInfo' <$> cs <> maybeToList leaf) (toCategoryName term) BCommented S.Error sourceSpan _ -> ErrorInfo sourceSpan (toCategoryName term) _ -> LeafInfo (toCategoryName term) (toTermName' term) From 005b384fad5c725b6bfc10f43c2b65cd6a8131f8 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 12:06:51 -0400 Subject: [PATCH 234/320] Extract the term name of an Operator syntax from source --- src/DiffSummary.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 3886def90..8cef888ed 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -59,7 +59,7 @@ toTermName source term = case unwrap term of S.Switch expr _ -> toTermName' expr S.Ternary expr _ -> toTermName' expr S.MathAssignment id _ -> toTermName' id - S.Operator exprs -> termNameFromChildren term exprs + S.Operator _ -> termNameFromSource term S.Object kvs -> "{" <> intercalate ", " (toTermName' <$> kvs) <> "}" S.Pair a b -> toTermName' a <> ": " <> toTermName' b S.Return expr -> maybe "empty" toTermName' expr @@ -68,8 +68,10 @@ toTermName source term = case unwrap term of S.DoWhile _ expr -> toTermName' expr Comment a -> toCategoryName a where toTermName' = toTermName source - termNameFromChildren term cs = toText $ Source.slice (unionRangesFrom (range term) (range <$> cs)) source - range term = (characterRange $ extract term) + termNameFromChildren term cs = termNameFromRange (unionRangesFrom (range term) (range <$> cs)) + termNameFromSource term = termNameFromRange (range term) + termNameFromRange range = toText $ Source.slice range source + range = characterRange . extract class HasCategory a where toCategoryName :: a -> Text From dca3628afde2f4ccd18e54e63624729b0f1ef103 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 12:07:04 -0400 Subject: [PATCH 235/320] Add comma_op mapping to Operator category in categoriesForLanguage --- src/TreeSitter.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 9727c0f4b..caa74c765 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -31,17 +31,18 @@ treeSitterParser language grammar blob = do categoriesForLanguage :: Language -> Text -> Category categoriesForLanguage language name = case (language, name) of (JavaScript, "object") -> Object - (JavaScript, "rel_op") -> BinaryOperator -- relational operator, e.g. >, <, <=, >=, ==, != - (JavaScript, "bool_op") -> BinaryOperator (JavaScript, "expression_statement") -> ExpressionStatements (JavaScript, "this_expression") -> Identifier (JavaScript, "null") -> Identifier (JavaScript, "undefined") -> Identifier (JavaScript, "arrow_function") -> Function (JavaScript, "generator_function") -> Function + (JavaScript, "rel_op") -> BinaryOperator -- relational operator, e.g. >, <, <=, >=, ==, != + (JavaScript, "bool_op") -> BinaryOperator (JavaScript, "delete_op") -> Operator (JavaScript, "type_op") -> Operator (JavaScript, "void_op") -> Operator + (JavaScript, "comma_op") -> Operator (JavaScript, "for_in_statement") -> For (JavaScript, "for_of_statement") -> For From d216481ca758e215ddac64b86093f809a63e95a0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 12:12:35 -0400 Subject: [PATCH 236/320] Map BinaryOperator nodes to Operator syntax --- src/Parser.hs | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index 4f408596e..97082e82d 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -17,13 +17,9 @@ import SourceSpan -- | and aren't pure. type Parser fields = SourceBlob -> IO (Term Text (Record fields)) --- | Categories that are treated as fixed nodes. -fixedCategories :: Set.Set Category -fixedCategories = Set.fromList [ BinaryOperator, Pair ] - --- | Should these categories be treated as fixed nodes? -isFixed :: Category -> Bool -isFixed = flip Set.member fixedCategories +-- | Whether a category is an Operator Category +isOperator :: Category -> Bool +isOperator = flip Set.member (Set.fromList [ Operator, BinaryOperator ]) -- | Given a function that maps production names to sets of categories, produce -- | a Constructor. @@ -49,7 +45,7 @@ termConstructor source sourceSpan info = cofree . construct construct children | SubscriptAccess == category info = case children of (base:element:[]) -> withDefaultInfo $ S.SubscriptAccess base element _ -> withDefaultInfo $ S.Error sourceSpan children - construct children | Operator == category info = withDefaultInfo $ S.Operator children + construct children | isOperator (category info) = withDefaultInfo $ S.Operator children construct children | Function == category info = case children of (body:[]) -> withDefaultInfo $ S.Function Nothing Nothing body (params:body:[]) | (info :< _) <- runCofree params, Params == category info -> @@ -92,7 +88,7 @@ termConstructor source sourceSpan info = cofree . construct toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)] toTuple child = pure child - construct children | isFixed (category info) = withDefaultInfo $ S.Fixed children + construct children | Pair == (category info) = withDefaultInfo $ S.Fixed children construct children | C.Error == category info = withDefaultInfo $ S.Error sourceSpan children construct children | For == (category info), Just (exprs, body) <- unsnoc children = From 7c1e6677a84eaac52a9921eba6078644a41cafe9 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 12:19:05 -0400 Subject: [PATCH 237/320] Add math_op --- src/TreeSitter.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index caa74c765..70ec80ed8 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -37,12 +37,14 @@ categoriesForLanguage language name = case (language, name) of (JavaScript, "undefined") -> Identifier (JavaScript, "arrow_function") -> Function (JavaScript, "generator_function") -> Function - (JavaScript, "rel_op") -> BinaryOperator -- relational operator, e.g. >, <, <=, >=, ==, != - (JavaScript, "bool_op") -> BinaryOperator - (JavaScript, "delete_op") -> Operator - (JavaScript, "type_op") -> Operator - (JavaScript, "void_op") -> Operator - (JavaScript, "comma_op") -> Operator + (JavaScript, "math_op") -> BinaryOperator -- bitwise operator, e.g. +, -, *, /. + (JavaScript, "bool_op") -> BinaryOperator -- boolean operator, e.g. ||, &&. + (JavaScript, "bitwise_op") -> BinaryOperator -- bitwise operator, e.g. ^, &, etc. + (JavaScript, "rel_op") -> BinaryOperator -- relational operator, e.g. >, <, <=, >=, ==, !=. + (JavaScript, "comma_op") -> Operator -- comma operator, e.g. expr1, expr2. + (JavaScript, "delete_op") -> Operator -- delete operator, e.g. delete x[2]. + (JavaScript, "type_op") -> Operator -- type operator, e.g. typeof Object. + (JavaScript, "void_op") -> Operator -- void operator, e.g. void 2. (JavaScript, "for_in_statement") -> For (JavaScript, "for_of_statement") -> For From 6ecff059f9e33caf905317188f161a624d1d2c55 Mon Sep 17 00:00:00 2001 From: joshvera Date: Sat, 30 Jul 2016 22:41:02 -0400 Subject: [PATCH 238/320] ++tree-sitter-parsers --- test/repos/js-test | 2 +- vendor/tree-sitter-parsers | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/test/repos/js-test b/test/repos/js-test index 4a6e3d1a2..0e185203c 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 4a6e3d1a2b50d2ea285ef6f8681216bdb3442e94 +Subproject commit 0e185203ca83e51f7fc2dbbb3b251f77b876a270 diff --git a/vendor/tree-sitter-parsers b/vendor/tree-sitter-parsers index 0fdcbafdb..b32d12c13 160000 --- a/vendor/tree-sitter-parsers +++ b/vendor/tree-sitter-parsers @@ -1 +1 @@ -Subproject commit 0fdcbafdb69853a03db28e789bb00a2f733c6990 +Subproject commit b32d12c13da744d1b0edc2901988f5e29eae2e49 From 02573a483e6e11d83fcfbc8ab11cb72a20c94d9e Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 12:21:31 -0400 Subject: [PATCH 239/320] ++tree-sitter-parsers ++js-test --- test/repos/js-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/repos/js-test b/test/repos/js-test index 0e185203c..3af143b53 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 0e185203ca83e51f7fc2dbbb3b251f77b876a270 +Subproject commit 3af143b53c8f9a2a6761d8e9ea91d47982cc3bc0 From 58b2391ed829e533c16bbf36c9ddc75a486f2a93 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 12:22:16 -0400 Subject: [PATCH 240/320] ++js-test ++tree-sitter-parsers --- test/repos/js-test | 2 +- vendor/tree-sitter-parsers | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/test/repos/js-test b/test/repos/js-test index 4a6e3d1a2..3af143b53 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 4a6e3d1a2b50d2ea285ef6f8681216bdb3442e94 +Subproject commit 3af143b53c8f9a2a6761d8e9ea91d47982cc3bc0 diff --git a/vendor/tree-sitter-parsers b/vendor/tree-sitter-parsers index 0fdcbafdb..b32d12c13 160000 --- a/vendor/tree-sitter-parsers +++ b/vendor/tree-sitter-parsers @@ -1 +1 @@ -Subproject commit 0fdcbafdb69853a03db28e789bb00a2f733c6990 +Subproject commit b32d12c13da744d1b0edc2901988f5e29eae2e49 From 2ab3602532d7b38864416a61a493b7c8ac38f2fe Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 12:22:58 -0400 Subject: [PATCH 241/320] ++js-test ++tree-sitter-parsers --- test/repos/js-test | 2 +- vendor/tree-sitter-parsers | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/test/repos/js-test b/test/repos/js-test index 1c6b3eede..3af143b53 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 1c6b3eedec733198c32d097860fca556174e9a3d +Subproject commit 3af143b53c8f9a2a6761d8e9ea91d47982cc3bc0 diff --git a/vendor/tree-sitter-parsers b/vendor/tree-sitter-parsers index 0fdcbafdb..b32d12c13 160000 --- a/vendor/tree-sitter-parsers +++ b/vendor/tree-sitter-parsers @@ -1 +1 @@ -Subproject commit 0fdcbafdb69853a03db28e789bb00a2f733c6990 +Subproject commit b32d12c13da744d1b0edc2901988f5e29eae2e49 From ce149af0f683a26c24003528c8d7bc4760bd40d8 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 12:23:15 -0400 Subject: [PATCH 242/320] ++js-test ++tree-sitter-parsers --- test/repos/js-test | 2 +- vendor/tree-sitter-parsers | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/test/repos/js-test b/test/repos/js-test index 7a46849e3..3af143b53 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 7a46849e3dca65bcb8baf099fb2c59ca151571b0 +Subproject commit 3af143b53c8f9a2a6761d8e9ea91d47982cc3bc0 diff --git a/vendor/tree-sitter-parsers b/vendor/tree-sitter-parsers index 1229ed83d..b32d12c13 160000 --- a/vendor/tree-sitter-parsers +++ b/vendor/tree-sitter-parsers @@ -1 +1 @@ -Subproject commit 1229ed83d0501dc3dbca9d4ceab70702763c76bb +Subproject commit b32d12c13da744d1b0edc2901988f5e29eae2e49 From 446f01c5a2a2a21ed640ba5281771bffcb9b43e2 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 12:23:51 -0400 Subject: [PATCH 243/320] ++js-test ++tree-sitter-parsers --- test/repos/js-test | 2 +- vendor/tree-sitter-parsers | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/test/repos/js-test b/test/repos/js-test index 0e185203c..3af143b53 160000 --- a/test/repos/js-test +++ b/test/repos/js-test @@ -1 +1 @@ -Subproject commit 0e185203ca83e51f7fc2dbbb3b251f77b876a270 +Subproject commit 3af143b53c8f9a2a6761d8e9ea91d47982cc3bc0 diff --git a/vendor/tree-sitter-parsers b/vendor/tree-sitter-parsers index 1229ed83d..b32d12c13 160000 --- a/vendor/tree-sitter-parsers +++ b/vendor/tree-sitter-parsers @@ -1 +1 @@ -Subproject commit 1229ed83d0501dc3dbca9d4ceab70702763c76bb +Subproject commit b32d12c13da744d1b0edc2901988f5e29eae2e49 From 862b554e52b8cad9b54c63e194f8ec536f4c4995 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 1 Aug 2016 13:32:59 -0400 Subject: [PATCH 244/320] Missed a merge conflict --- src/DiffSummary.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 7ede08f97..efcb7a7c9 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -193,12 +193,9 @@ diffSummaries sources = cata $ \case (Free (infos :< S.For exprs body)) -> annotateWithCategory infos <$> join exprs <> body (Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body (Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body -<<<<<<< HEAD (Free (infos :< S.Array children)) -> annotateWithCategory infos <$> join children -======= (Free (infos :< S.Class identifier superclass definitions)) -> annotateWithCategory infos <$> identifier <> fromMaybe [] superclass <> join definitions (Free (infos :< S.Method identifier params definitions)) -> annotateWithCategory infos <$> identifier <> join params <> join definitions ->>>>>>> origin/master (Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ] (Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ] (Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ] From eb0119c528a787dc422b70af1dea7445c18ea5c7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 2 Aug 2016 10:53:29 -0400 Subject: [PATCH 245/320] July 26th, 2016 weekly. --- weekly/2016-07-26.md | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 weekly/2016-07-26.md diff --git a/weekly/2016-07-26.md b/weekly/2016-07-26.md new file mode 100644 index 000000000..ef27cf40a --- /dev/null +++ b/weekly/2016-07-26.md @@ -0,0 +1,30 @@ +# July 26, 2016 weekly + +Last week was Summit. + +## What went well? + +@rewinfrey - Pairing w/ @joshvera. Made significant progress on diff summary property tests. And the PR got merged! + +@joshvera - Pairing. Summit! + +@robrix - Summit! @joshvera & @rewinfrey really came together on the diff summary stuff, too ❤️ + + + +## What was challenging? + +@rewinfrey - How to add more test cases in a non-manual way. + +@joshvera - Figuring out how much the JS parser covers. If we improved our error handling to cover more cases that might get us partway to staff shipping. + +@robrix - **After the fact:** I don’t remember what I said, now, nor what was challenging that week. + + +## What did you learn? + +@rewinfrey - All the things at Summit! Learned a lot about property testing while pairing with @joshvera. + +@joshvera - Learned about property tests. Been reading about probabilities through this machine learning book. Onto continuous probability. + +@robrix - Some stuff about derivative parsers, probably? From 643337b9fab3abb7683d9c98c7dea4366bc2f53b Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 2 Aug 2016 11:58:09 -0400 Subject: [PATCH 246/320] Add 08/02/2016 notes --- weekly/2016-08-02.md | 45 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) create mode 100644 weekly/2016-08-02.md diff --git a/weekly/2016-08-02.md b/weekly/2016-08-02.md new file mode 100644 index 000000000..0db29970f --- /dev/null +++ b/weekly/2016-08-02.md @@ -0,0 +1,45 @@ +## What went well? + +@rewinfrey + +* Made a lot of progress on auto generation of test cases. + +@robrix + +* Mergeable PR went well. A pretty big step for maintenance costs. +Self-assessment forms are really streamlined compared to last time. + +@joshvera + +* Adding remaining cases to Syntax is going pretty well. + +## What went less well? + +@rewinfrey + +* Initial confusion for being on platform support was confusing. By the end of the week we knocked out a production bug that was affecting customers. + +@robrix + +* Though the self-assessment training was more streamlined, there was a lot of training involved. + +@joshvera + +* Realized mapping C into Syntax will be more trouble than anticipated. + +## What did you learn? + +@rewinfrey + +* Learned a lot about Haskell’s shell interactions. +* Specifically creating process and how Haskell abstracts from communicating with the shell. +* Learned about Yesod to do web programming in Haskell. + +@robrix + +* Reinforced knowledge of generic programing and property tests for laws governing new type classes. In the case of Mergeable, it’s difficult to describe the powerset behavior Mergeable has, and property tests helped with that. + +@joshvera + +* Learned about probability distributions and recalled the `suchThat` is kind of like filter for Arbitrary types in quickcheck. + From 8008be776e602ada681ed16c252bb5a68556bd52 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:12:31 -0400 Subject: [PATCH 247/320] Define Algorithm over AlgorithmF. --- src/Algorithm.hs | 20 +++++++++++++++++--- src/Interpreter.hs | 1 - 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 0fb8ae129..970b9c7d6 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -1,7 +1,21 @@ module Algorithm where -import Control.Monad.Trans.Free -import Operation +import Diff +import Prologue +import Term + +-- | A single step in a diffing algorithm. +data AlgorithmF + a -- ^ The type of leaves in the syntax tree, typically String, but possibly some datatype representing different leaves more precisely. + annotation -- ^ The type of annotations. + f -- ^ The type representing another level of the diffing algorithm. Often Algorithm. + -- | Recursively diff two terms and pass the result to the continuation. + = Recursive (Term a annotation) (Term a annotation) (Diff a annotation -> f) + -- | Diff two dictionaries and pass the result to the continuation. + -- | Diff two arrays and pass the result to the continuation. + | ByIndex [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) + | ByRandomWalkSimilarity [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) + deriving Functor -- | A lazily-produced AST for diffing. -type Algorithm a annotation = Free (Operation a annotation) +type Algorithm a annotation = Free (AlgorithmF a annotation) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 16f396538..f3b43ab52 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -11,7 +11,6 @@ import Data.Record import Data.These import Diff import Info -import Operation import Patch import Prologue hiding (lookup) import SES From 9a14248c084dbcc62d11b98c0c02a5ab29ef569c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:12:58 -0400 Subject: [PATCH 248/320] :fire: Operation. --- semantic-diff.cabal | 1 - src/Operation.hs | 18 ------------------ 2 files changed, 19 deletions(-) delete mode 100644 src/Operation.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 0ba91c38d..277247b9b 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -30,7 +30,6 @@ library , Info , Interpreter , Language - , Operation , Parser , Patch , Patch.Arbitrary diff --git a/src/Operation.hs b/src/Operation.hs deleted file mode 100644 index a718e14ae..000000000 --- a/src/Operation.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Operation where - -import Prologue -import Diff -import Term - --- | A single step in a diffing algorithm. -data Operation - a -- ^ The type of leaves in the syntax tree, typically String, but possibly some datatype representing different leaves more precisely. - annotation -- ^ The type of annotations. - f -- ^ The type representing another level of the diffing algorithm. Often Algorithm. - -- | Recursively diff two terms and pass the result to the continuation. - = Recursive (Term a annotation) (Term a annotation) (Diff a annotation -> f) - -- | Diff two dictionaries and pass the result to the continuation. - -- | Diff two arrays and pass the result to the continuation. - | ByIndex [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) - | ByRandomWalkSimilarity [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) - deriving Functor From f6c8cd81da3f0dd346535b3db420bf90f5d72a34 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:15:18 -0400 Subject: [PATCH 249/320] Add a smart constructor for Recursive operations. --- src/Algorithm.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 970b9c7d6..4a6f7dc7c 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -19,3 +19,6 @@ data AlgorithmF -- | A lazily-produced AST for diffing. type Algorithm a annotation = Free (AlgorithmF a annotation) + +recursively :: Term leaf annotation -> Term leaf annotation -> Algorithm leaf annotation (Diff leaf annotation) +recursively a b = wrap (Recursive a b pure) From d7ab1d017eb9f29545d5bc056d9408083189fc0f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:17:23 -0400 Subject: [PATCH 250/320] :fire: a redundant comment. --- src/Algorithm.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 4a6f7dc7c..3e4e5c329 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -11,7 +11,6 @@ data AlgorithmF f -- ^ The type representing another level of the diffing algorithm. Often Algorithm. -- | Recursively diff two terms and pass the result to the continuation. = Recursive (Term a annotation) (Term a annotation) (Diff a annotation -> f) - -- | Diff two dictionaries and pass the result to the continuation. -- | Diff two arrays and pass the result to the continuation. | ByIndex [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) | ByRandomWalkSimilarity [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) From 1835308f7e78b614688c41de59fe340d8ce4a579 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:38:35 -0400 Subject: [PATCH 251/320] Add a smart constructor for Indexed algorithms. --- src/Algorithm.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 3e4e5c329..500adb878 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -21,3 +21,6 @@ type Algorithm a annotation = Free (AlgorithmF a annotation) recursively :: Term leaf annotation -> Term leaf annotation -> Algorithm leaf annotation (Diff leaf annotation) recursively a b = wrap (Recursive a b pure) + +byIndex :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm leaf annotation [Diff leaf annotation] +byIndex a b = wrap (ByIndex a b pure) From f8ad7ecea10759d36cf1380a889127c54fb975b7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:38:49 -0400 Subject: [PATCH 252/320] Use the smart constructor to diff indexed terms. --- src/Interpreter.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index f3b43ab52..0b315c777 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -34,7 +34,9 @@ constructAndRun construct comparable cost t1 t2 | (category <$> t1) == (category <$> t2) = hylo construct runCofree <$> zipTerms t1 t2 | otherwise = run construct comparable cost $ algorithm a b where - algorithm (Indexed a') (Indexed b') = wrap $! ByIndex a' b' (annotate . Indexed) + algorithm (Indexed a') (Indexed b') = do + diffs <- byIndex a' b' + annotate (Indexed diffs) algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b' algorithm a' b' = wrap $! Recursive (cofree (annotation1 :< a')) (cofree (annotation2 :< b')) pure (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) From 14b38dff8bdafbe9e3b538ec716aff51fd715b36 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:39:33 -0400 Subject: [PATCH 253/320] Use the smart constructor to diff recursively. --- src/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 0b315c777..5611f43e4 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -38,7 +38,7 @@ constructAndRun construct comparable cost t1 t2 diffs <- byIndex a' b' annotate (Indexed diffs) algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b' - algorithm a' b' = wrap $! Recursive (cofree (annotation1 :< a')) (cofree (annotation2 :< b')) pure + algorithm _ _ = recursively t1 t2 (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) annotate = pure . construct . (both annotation1 annotation2 :<) From 6694b800823dc08700145a8b211a8a04f4803170 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:40:17 -0400 Subject: [PATCH 254/320] Add a smart constructor for RWS diffs. --- src/Algorithm.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 500adb878..cf2a29cb7 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -24,3 +24,6 @@ recursively a b = wrap (Recursive a b pure) byIndex :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm leaf annotation [Diff leaf annotation] byIndex a b = wrap (ByIndex a b pure) + +bySimilarity :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm leaf annotation [Diff leaf annotation] +bySimilarity a b = wrap (ByRandomWalkSimilarity a b pure) From fb8d95203f9b9332d0af162a61ffc486e56a664b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:43:36 -0400 Subject: [PATCH 255/320] Replace the type parameters to AlgorithmF. --- src/Algorithm.hs | 18 +++++++++--------- src/Interpreter.hs | 2 +- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index cf2a29cb7..be4072b20 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -6,24 +6,24 @@ import Term -- | A single step in a diffing algorithm. data AlgorithmF - a -- ^ The type of leaves in the syntax tree, typically String, but possibly some datatype representing different leaves more precisely. - annotation -- ^ The type of annotations. + term -- ^ The type of terms. + diff -- ^ The type of diffs. f -- ^ The type representing another level of the diffing algorithm. Often Algorithm. -- | Recursively diff two terms and pass the result to the continuation. - = Recursive (Term a annotation) (Term a annotation) (Diff a annotation -> f) + = Recursive term term (diff -> f) -- | Diff two arrays and pass the result to the continuation. - | ByIndex [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) - | ByRandomWalkSimilarity [Term a annotation] [Term a annotation] ([Diff a annotation] -> f) + | ByIndex [term] [term] ([diff] -> f) + | ByRandomWalkSimilarity [term] [term] ([diff] -> f) deriving Functor -- | A lazily-produced AST for diffing. -type Algorithm a annotation = Free (AlgorithmF a annotation) +type Algorithm term diff = Free (AlgorithmF term diff) -recursively :: Term leaf annotation -> Term leaf annotation -> Algorithm leaf annotation (Diff leaf annotation) +recursively :: Term leaf annotation -> Term leaf annotation -> Algorithm (Term leaf annotation) (Diff leaf annotation) (Diff leaf annotation) recursively a b = wrap (Recursive a b pure) -byIndex :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm leaf annotation [Diff leaf annotation] +byIndex :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm (Term leaf annotation) (Diff leaf annotation) [Diff leaf annotation] byIndex a b = wrap (ByIndex a b pure) -bySimilarity :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm leaf annotation [Diff leaf annotation] +bySimilarity :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm (Term leaf annotation) (Diff leaf annotation) [Diff leaf annotation] bySimilarity a b = wrap (ByRandomWalkSimilarity a b pure) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 5611f43e4..546ea1f4b 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -43,7 +43,7 @@ constructAndRun construct comparable cost t1 t2 annotate = pure . construct . (both annotation1 annotation2 :<) -- | Runs the diff algorithm -run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm leaf (Record fields) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) +run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) run construct comparable cost algorithm = case runFree algorithm of Pure diff -> Just diff Free (Recursive t1 t2 f) -> run construct comparable cost . f $ recur a b where From 9f6fb541a75aee9876e1db238069656ccc572287 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 18:58:37 -0400 Subject: [PATCH 256/320] Define run by iteration. --- src/Interpreter.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 546ea1f4b..c6e2d683f 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -44,9 +44,8 @@ constructAndRun construct comparable cost t1 t2 -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) -run construct comparable cost algorithm = case runFree algorithm of - Pure diff -> Just diff - Free (Recursive t1 t2 f) -> run construct comparable cost . f $ recur a b where +run construct comparable cost algorithm = (`iter` fmap Just algorithm) $ \case + Recursive t1 t2 f -> f $ recur a b where (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) annotate = construct . (both annotation1 annotation2 :<) @@ -54,9 +53,9 @@ run construct comparable cost algorithm = case runFree algorithm of diffThese = these (pure . Delete) (pure . Insert) (diffTerms construct comparable cost) - Free (ByIndex a b f) -> run construct comparable cost . f $ ses (constructAndRun construct comparable cost) cost a b + ByIndex a b f -> f $ ses (constructAndRun construct comparable cost) cost a b - Free (ByRandomWalkSimilarity a b f) -> run construct comparable cost . f $ rws (constructAndRun construct comparable cost) getLabel a b + ByRandomWalkSimilarity a b f -> f $ rws (constructAndRun construct comparable cost) getLabel a b where getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) From 840720d86e34cc8603fe6f709882bad777ac85ba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 19:48:51 -0400 Subject: [PATCH 257/320] Define a runAlgorithm function. --- src/Interpreter.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index c6e2d683f..2bc7fc49b 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} module Interpreter (Comparable, DiffConstructor, diffTerms) where import Algorithm @@ -59,3 +60,14 @@ run construct comparable cost algorithm = (`iter` fmap Just algorithm) $ \case where getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) + +runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Hashable label) => + (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -> + SES.Cost (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> + (forall b. CofreeF f annotation b -> label) -> + Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -> + a +runAlgorithm recur cost getLabel = iter $ \case + Recursive a b f -> f (maybe (pure (Replace a b)) (wrap . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (pure (Replace a b)) .) . recur))) (galign (unwrap a) (unwrap b))) + ByIndex as bs f -> f (ses recur cost as bs) + ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) From 10e38a8895d15d33e1b1176fd9bbaee42116583e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 19:50:16 -0400 Subject: [PATCH 258/320] Algorithm is defined in the Church encoded free monad. --- src/Algorithm.hs | 3 ++- src/Interpreter.hs | 5 +++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index be4072b20..96d21ce9c 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -1,5 +1,6 @@ module Algorithm where +import Control.Monad.Free.Church import Diff import Prologue import Term @@ -17,7 +18,7 @@ data AlgorithmF deriving Functor -- | A lazily-produced AST for diffing. -type Algorithm term diff = Free (AlgorithmF term diff) +type Algorithm term diff = F (AlgorithmF term diff) recursively :: Term leaf annotation -> Term leaf annotation -> Algorithm (Term leaf annotation) (Diff leaf annotation) (Diff leaf annotation) recursively a b = wrap (Recursive a b pure) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 2bc7fc49b..6221fed6b 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -11,6 +11,7 @@ import Data.RandomWalkSimilarity import Data.Record import Data.These import Diff +import qualified Control.Monad.Free.Church as F import Info import Patch import Prologue hiding (lookup) @@ -45,7 +46,7 @@ constructAndRun construct comparable cost t1 t2 -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) -run construct comparable cost algorithm = (`iter` fmap Just algorithm) $ \case +run construct comparable cost algorithm = (`F.iter` fmap Just algorithm) $ \case Recursive t1 t2 f -> f $ recur a b where (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) annotate = construct . (both annotation1 annotation2 :<) @@ -67,7 +68,7 @@ runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annot (forall b. CofreeF f annotation b -> label) -> Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -> a -runAlgorithm recur cost getLabel = iter $ \case +runAlgorithm recur cost getLabel = F.iter $ \case Recursive a b f -> f (maybe (pure (Replace a b)) (wrap . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (pure (Replace a b)) .) . recur))) (galign (unwrap a) (unwrap b))) ByIndex as bs f -> f (ses recur cost as bs) ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) From 78701ddd9002c63ef55aa067b41727d54fee9079 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 20:08:20 -0400 Subject: [PATCH 259/320] Defines a constructor of algorithms over terms. --- src/Interpreter.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 6221fed6b..a1627f139 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -44,6 +44,15 @@ constructAndRun construct comparable cost t1 t2 (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) annotate = pure . construct . (both annotation1 annotation2 :<) +algorithmWithTerms :: Eq leaf => Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) +algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of + (Indexed a, Indexed b) -> do + diffs <- byIndex a b + annotate (Indexed diffs) + (Leaf a, Leaf b) | a == b -> annotate (Leaf b) + _ -> recursively t1 t2 + where annotate = pure . wrap . (both (extract t1) (extract t2) :<) + -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) run construct comparable cost algorithm = (`F.iter` fmap Just algorithm) $ \case From f9969601e848980ba2b1621d660ff8a0cf23167e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 20:14:33 -0400 Subject: [PATCH 260/320] runAlgorithm receives a constructing function. --- src/Interpreter.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index a1627f139..743bd2769 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -72,12 +72,13 @@ run construct comparable cost algorithm = (`F.iter` fmap Just algorithm) $ \case _ -> Nothing) runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Hashable label) => + (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -> SES.Cost (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> (forall b. CofreeF f annotation b -> label) -> Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -> a -runAlgorithm recur cost getLabel = F.iter $ \case - Recursive a b f -> f (maybe (pure (Replace a b)) (wrap . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (pure (Replace a b)) .) . recur))) (galign (unwrap a) (unwrap b))) +runAlgorithm construct recur cost getLabel = F.iter $ \case + Recursive a b f -> f (maybe (pure (Replace a b)) (construct . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (pure (Replace a b)) .) . recur))) (galign (unwrap a) (unwrap b))) ByIndex as bs f -> f (ses recur cost as bs) ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) From b3d09f538e5fd98d77b76febda75088d814ace15 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 3 Aug 2016 20:14:41 -0400 Subject: [PATCH 261/320] Define run in terms of runAlgorithm. --- src/Interpreter.hs | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 743bd2769..82077ba13 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -55,21 +55,10 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) -run construct comparable cost algorithm = (`F.iter` fmap Just algorithm) $ \case - Recursive t1 t2 f -> f $ recur a b where - (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) - annotate = construct . (both annotation1 annotation2 :<) - - recur a b = maybe (pure (Replace t1 t2)) (annotate . fmap diffThese) (galign a b) - - diffThese = these (pure . Delete) (pure . Insert) (diffTerms construct comparable cost) - - ByIndex a b f -> f $ ses (constructAndRun construct comparable cost) cost a b - - ByRandomWalkSimilarity a b f -> f $ rws (constructAndRun construct comparable cost) getLabel a b - where getLabel (h :< t) = (category h, case t of - Leaf s -> Just s - _ -> Nothing) +run construct comparable cost = runAlgorithm construct (constructAndRun construct comparable cost) cost getLabel . fmap Just + where getLabel (h :< t) = (category h, case t of + Leaf s -> Just s + _ -> Nothing) runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Hashable label) => (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> From 190fa948e29a0e93ad791ffddf654129eaf1487f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 08:52:25 -0400 Subject: [PATCH 262/320] This is already getting exported via Protolude. --- src/Prologue.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Prologue.hs b/src/Prologue.hs index a37f4d92b..b73f2562a 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -2,12 +2,10 @@ module Prologue ( module X , lookup , traceShowId -, FilePath ) where import Protolude as X import Data.List (lookup) -import System.IO (FilePath) import Control.Comonad.Trans.Cofree as X import Control.Monad.Trans.Free as X From 53dfd9a3bd520250c9ff101afdb6350e34ef7f3b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 09:05:17 -0400 Subject: [PATCH 263/320] Extract a function to construct replacements. --- src/Interpreter.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 82077ba13..462362edd 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -68,6 +68,7 @@ runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annot Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -> a runAlgorithm construct recur cost getLabel = F.iter $ \case - Recursive a b f -> f (maybe (pure (Replace a b)) (construct . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (pure (Replace a b)) .) . recur))) (galign (unwrap a) (unwrap b))) + Recursive a b f -> f (maybe (replacing a b) (construct . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (replacing a b) .) . recur))) (galign (unwrap a) (unwrap b))) ByIndex as bs f -> f (ses recur cost as bs) ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) + where replacing = (pure .) . Replace From 663bb97a3ddfc02a4ac35ffba25b3354a06d90e6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 09:25:18 -0400 Subject: [PATCH 264/320] Define a DSL for constructing Patches. --- src/Patch.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/Patch.hs b/src/Patch.hs index c2b38dfaa..8ed640887 100644 --- a/src/Patch.hs +++ b/src/Patch.hs @@ -1,5 +1,8 @@ module Patch ( Patch(..) +, replacing +, inserting +, deleting , after , before , unPatch @@ -18,6 +21,19 @@ data Patch a | Delete a deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable) + +-- DSL + +replacing :: Applicative f => a -> a -> f (Patch a) +replacing = (pure .) . Replace + +inserting :: Applicative f => a -> f (Patch a) +inserting = pure . Insert + +deleting :: Applicative f => a -> f (Patch a) +deleting = pure . Delete + + -- | Return the item from the after side of the patch. after :: Patch a -> Maybe a after = maybeSnd . unPatch From 1ee3dcff66c18fc7f81df382289f174ddede8ee7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 09:25:33 -0400 Subject: [PATCH 265/320] Use the Patch DSL to construct replacements. --- src/Interpreter.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 462362edd..f8dc5c21f 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -71,4 +71,3 @@ runAlgorithm construct recur cost getLabel = F.iter $ \case Recursive a b f -> f (maybe (replacing a b) (construct . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (replacing a b) .) . recur))) (galign (unwrap a) (unwrap b))) ByIndex as bs f -> f (ses recur cost as bs) ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) - where replacing = (pure .) . Replace From b41ae038b9b2f75cfa8c38d1d1601126a3798fb3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 09:26:13 -0400 Subject: [PATCH 266/320] Traverse the recursive structure instead of embedding it. --- src/Interpreter.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index f8dc5c21f..cdff19875 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -60,7 +60,7 @@ run construct comparable cost = runAlgorithm construct (constructAndRun construc Leaf s -> Just s _ -> Nothing) -runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Hashable label) => +runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Traversable f, Hashable label) => (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -> SES.Cost (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> @@ -68,6 +68,8 @@ runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annot Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -> a runAlgorithm construct recur cost getLabel = F.iter $ \case - Recursive a b f -> f (maybe (replacing a b) (construct . (both (extract a) (extract b) :<) . fmap (these (pure . Delete) (pure . Insert) ((fromMaybe (replacing a b) .) . recur))) (galign (unwrap a) (unwrap b))) + Recursive a b f -> f (maybe (replacing a b) (construct . (both (extract a) (extract b) :<)) $ do + aligned <- galign (unwrap a) (unwrap b) + traverse (these (Just . deleting) (Just . inserting) recur) aligned) ByIndex as bs f -> f (ses recur cost as bs) ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) From 559011de3ac2e446c2f3ade86da44ffd97cf6ad4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 09:46:21 -0400 Subject: [PATCH 267/320] :fire: a redundant import. --- src/Data/Record.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Record.hs b/src/Data/Record.hs index 129ff43f3..70646facc 100644 --- a/src/Data/Record.hs +++ b/src/Data/Record.hs @@ -4,7 +4,6 @@ module Data.Record where import GHC.Show import Prologue import Test.QuickCheck -import GHC.Show (Show(..)) -- | A type-safe, extensible record structure. -- | From ff954d08c785ac5bfd109befdaba61a53940a361 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 09:55:47 -0400 Subject: [PATCH 268/320] :fire: the unused CoArbitrary instance over Category. This also allows us to :fire: the orphan instance over Text. --- src/Category.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Category.hs b/src/Category.hs index 491af79bb..425647973 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -3,7 +3,6 @@ module Category where import Prologue import Data.Hashable import Test.QuickCheck hiding (Args) -import Data.Text (unpack) import Data.Text.Arbitrary() -- | A standardized category of AST node. Used to determine the semantics for @@ -99,11 +98,6 @@ data Category instance Hashable Category -instance CoArbitrary Text where - coarbitrary = coarbitrary . unpack -instance CoArbitrary Category where - coarbitrary = genericCoarbitrary - instance Arbitrary Category where arbitrary = oneof [ pure Program From 70c6b42e690c7e90263fe09bd5332be4a88cba39 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 09:57:25 -0400 Subject: [PATCH 269/320] Add the missing pattern match over methods. --- src/Renderer/Split.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index 151655678..5357e7494 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -71,6 +71,7 @@ styleName category = "category-" <> case category of C.Finally -> "finally_statement" ArrayLiteral -> "array" C.Class -> "class_statement" + C.Method -> "method" Other string -> string -- | Pick the class name for a split patch. From 6c39b170e81496fd0fb4e9d633a0c6ff1ec3c763 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:00:37 -0400 Subject: [PATCH 270/320] Define toTermName over Commented nodes. --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index ccc0edff5..b5cf1ae91 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -73,6 +73,7 @@ toTermName source term = case unwrap term of S.Class identifier _ _ -> toTermName' identifier S.Method identifier _ _ -> toTermName' identifier Comment a -> toCategoryName a + S.Commented _ wrapped -> maybe "anonymous" toTermName' wrapped where toTermName' = toTermName source termNameFromChildren term cs = termNameFromRange (unionRangesFrom (range term) (range <$> cs)) termNameFromSource term = termNameFromRange (range term) From 2286b2b37bf4b49b7f74780f6bbd628b30410f49 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:02:39 -0400 Subject: [PATCH 271/320] Define toTermName over Error nodes. --- src/DiffSummary.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index b5cf1ae91..1ef51776d 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -63,6 +63,7 @@ toTermName source term = case unwrap term of S.Object kvs -> "{" <> intercalate ", " (toTermName' <$> kvs) <> "}" S.Pair a b -> toTermName' a <> ": " <> toTermName' b S.Return expr -> maybe "empty" toTermName' expr + S.Error span _ -> displayStartEndPos span S.For exprs _ -> termNameFromChildren term exprs S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr From e39ab20eee79f342b7ffe9c91e2608cb1da1994b Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 4 Aug 2016 10:13:56 -0400 Subject: [PATCH 272/320] Use termNameFromSource in toTermName --- src/DiffSummary.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 1ef51776d..3cd46f64d 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -67,10 +67,10 @@ toTermName source term = case unwrap term of S.For exprs _ -> termNameFromChildren term exprs S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr - S.Throw expr -> toText $ Source.slice (characterRange $ extract expr) source + S.Throw expr -> termNameFromSource expr S.Constructor expr -> toTermName' expr - S.Try expr _ _ -> toText $ Source.slice (characterRange $ extract expr) source - S.Array _ -> toText $ Source.slice (characterRange $ extract term) source + S.Try expr _ _ -> termNameFromSource expr + S.Array _ -> termNameFromSource term S.Class identifier _ _ -> toTermName' identifier S.Method identifier _ _ -> toTermName' identifier Comment a -> toCategoryName a From 5280b62a20911a649fbe1197b3a7c3cb4d5ae57f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:19:02 -0400 Subject: [PATCH 273/320] Commented terms are named from their children. --- src/DiffSummary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 3cd46f64d..75fd1c8fc 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -74,7 +74,7 @@ toTermName source term = case unwrap term of S.Class identifier _ _ -> toTermName' identifier S.Method identifier _ _ -> toTermName' identifier Comment a -> toCategoryName a - S.Commented _ wrapped -> maybe "anonymous" toTermName' wrapped + S.Commented comments wrapped -> termNameFromChildren term (comments <> maybeToList wrapped) where toTermName' = toTermName source termNameFromChildren term cs = termNameFromRange (unionRangesFrom (range term) (range <$> cs)) termNameFromSource term = termNameFromRange (range term) From f379deca3374abde6652b48573f8f5a6b4fa5f66 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:19:46 -0400 Subject: [PATCH 274/320] Use the Foldable instance to avoid a mappend. --- src/DiffSummary.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 75fd1c8fc..001cd79d3 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -64,7 +64,7 @@ toTermName source term = case unwrap term of S.Pair a b -> toTermName' a <> ": " <> toTermName' b S.Return expr -> maybe "empty" toTermName' expr S.Error span _ -> displayStartEndPos span - S.For exprs _ -> termNameFromChildren term exprs + S.For _ _ -> termNameFromChildren term S.While expr _ -> toTermName' expr S.DoWhile _ expr -> toTermName' expr S.Throw expr -> termNameFromSource expr @@ -74,9 +74,9 @@ toTermName source term = case unwrap term of S.Class identifier _ _ -> toTermName' identifier S.Method identifier _ _ -> toTermName' identifier Comment a -> toCategoryName a - S.Commented comments wrapped -> termNameFromChildren term (comments <> maybeToList wrapped) + S.Commented _ _ -> termNameFromChildren term where toTermName' = toTermName source - termNameFromChildren term cs = termNameFromRange (unionRangesFrom (range term) (range <$> cs)) + termNameFromChildren term = termNameFromRange (unionRangesFrom (range term) (range <$> toList (unwrap term))) termNameFromSource term = termNameFromRange (range term) termNameFromRange range = toText $ Source.slice range source range = characterRange . extract From 3808b89fe41e6be8c2c70c91f24e784e4d1dc225 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:32:05 -0400 Subject: [PATCH 275/320] Use replacing in diffTerms. --- src/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index cdff19875..77872b8fa 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -27,7 +27,7 @@ type DiffConstructor leaf annotation = CofreeF (Syntax leaf) (Both annotation) ( -- | Diff two terms, given a function that determines whether two terms can be compared and a cost function. diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Diff leaf (Record fields) -diffTerms construct comparable cost a b = fromMaybe (pure $ Replace a b) $ constructAndRun construct comparable cost a b +diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ constructAndRun construct comparable cost a b -- | Constructs an algorithm and runs it constructAndRun :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) From 5acf6ff0f23facfb46e3d89d3fcf3d10549137f3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:32:55 -0400 Subject: [PATCH 276/320] Check for comparability in `diffTerms`. --- src/Interpreter.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 77872b8fa..9080f56ea 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -27,7 +27,9 @@ type DiffConstructor leaf annotation = CofreeF (Syntax leaf) (Both annotation) ( -- | Diff two terms, given a function that determines whether two terms can be compared and a cost function. diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Diff leaf (Record fields) -diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ constructAndRun construct comparable cost a b +diffTerms construct comparable cost a b + | not (comparable a b) = replacing a b + | otherwise = fromMaybe (replacing a b) $ run construct comparable cost (algorithmWithTerms a b) -- | Constructs an algorithm and runs it constructAndRun :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) From d12dd5d56717c638a18febdb347449eda60c11dc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:33:37 -0400 Subject: [PATCH 277/320] Extract the recur function into the where clause. --- src/Interpreter.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 9080f56ea..2b2f773b1 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -57,8 +57,9 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) -run construct comparable cost = runAlgorithm construct (constructAndRun construct comparable cost) cost getLabel . fmap Just - where getLabel (h :< t) = (category h, case t of +run construct comparable cost = runAlgorithm construct recur cost getLabel . fmap Just + where recur = constructAndRun construct comparable cost + getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) From 05b9aee4eaaa00377486c6ec4c74de939801ab86 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:34:14 -0400 Subject: [PATCH 278/320] Guard `recur` on the comparability of its operands. --- src/Interpreter.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 2b2f773b1..2705bf29a 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -58,7 +58,9 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) run construct comparable cost = runAlgorithm construct recur cost getLabel . fmap Just - where recur = constructAndRun construct comparable cost + where recur a b = do + guard (comparable a b) + constructAndRun construct comparable cost a b getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) From c0d702c22d9fb2995a50cff4a845d50652a7630b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:46:48 -0400 Subject: [PATCH 279/320] Add a diffComparableTerms function. --- src/Interpreter.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 2705bf29a..01af0e716 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -31,6 +31,12 @@ diffTerms construct comparable cost a b | not (comparable a b) = replacing a b | otherwise = fromMaybe (replacing a b) $ run construct comparable cost (algorithmWithTerms a b) +diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) +diffComparableTerms construct comparable cost a b + | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b + | comparable a b = run construct comparable cost (algorithmWithTerms a b) + | otherwise = Nothing + -- | Constructs an algorithm and runs it constructAndRun :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) constructAndRun construct comparable cost t1 t2 From 99b076df800100cb65b99755cea9ef6d07786490 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:47:31 -0400 Subject: [PATCH 280/320] Define diffTerms in terms of diffComparableTerms. --- src/Interpreter.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 01af0e716..2d773f1f5 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -27,9 +27,7 @@ type DiffConstructor leaf annotation = CofreeF (Syntax leaf) (Both annotation) ( -- | Diff two terms, given a function that determines whether two terms can be compared and a cost function. diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Diff leaf (Record fields) -diffTerms construct comparable cost a b - | not (comparable a b) = replacing a b - | otherwise = fromMaybe (replacing a b) $ run construct comparable cost (algorithmWithTerms a b) +diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) diffComparableTerms construct comparable cost a b From 7809ae1756720dcfa86645de8c6831148ddfa39a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:54:36 -0400 Subject: [PATCH 281/320] Unpack the annotations &c inline. --- src/Interpreter.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 2d773f1f5..380e867fa 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -41,14 +41,13 @@ constructAndRun construct comparable cost t1 t2 | not $ comparable t1 t2 = Nothing | (category <$> t1) == (category <$> t2) = hylo construct runCofree <$> zipTerms t1 t2 | otherwise = - run construct comparable cost $ algorithm a b where + run construct comparable cost $ algorithm (unwrap t1) (unwrap t2) where algorithm (Indexed a') (Indexed b') = do diffs <- byIndex a' b' annotate (Indexed diffs) algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b' algorithm _ _ = recursively t1 t2 - (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2) - annotate = pure . construct . (both annotation1 annotation2 :<) + annotate = pure . construct . (both (extract t1) (extract t2) :<) algorithmWithTerms :: Eq leaf => Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of From 0953d430b944c1468086b76252f825d0fdfd4737 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:56:20 -0400 Subject: [PATCH 282/320] Rearrange the definition of constructAndRun a little. --- src/Interpreter.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 380e867fa..401515283 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -38,16 +38,15 @@ diffComparableTerms construct comparable cost a b -- | Constructs an algorithm and runs it constructAndRun :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) constructAndRun construct comparable cost t1 t2 - | not $ comparable t1 t2 = Nothing | (category <$> t1) == (category <$> t2) = hylo construct runCofree <$> zipTerms t1 t2 - | otherwise = - run construct comparable cost $ algorithm (unwrap t1) (unwrap t2) where - algorithm (Indexed a') (Indexed b') = do - diffs <- byIndex a' b' - annotate (Indexed diffs) - algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b' - algorithm _ _ = recursively t1 t2 - annotate = pure . construct . (both (extract t1) (extract t2) :<) + | comparable t1 t2 = run construct comparable cost $ algorithm (unwrap t1) (unwrap t2) + | otherwise = Nothing + where algorithm (Indexed a') (Indexed b') = do + diffs <- byIndex a' b' + annotate (Indexed diffs) + algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b' + algorithm _ _ = recursively t1 t2 + annotate = pure . construct . (both (extract t1) (extract t2) :<) algorithmWithTerms :: Eq leaf => Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of From 58fe4fdc898ba41ad93dbde91362d4c8e29f23aa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 10:58:29 -0400 Subject: [PATCH 283/320] Define constructAndRun.algorithm by case analysis. --- src/Interpreter.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 401515283..344347af9 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -41,11 +41,12 @@ constructAndRun construct comparable cost t1 t2 | (category <$> t1) == (category <$> t2) = hylo construct runCofree <$> zipTerms t1 t2 | comparable t1 t2 = run construct comparable cost $ algorithm (unwrap t1) (unwrap t2) | otherwise = Nothing - where algorithm (Indexed a') (Indexed b') = do - diffs <- byIndex a' b' - annotate (Indexed diffs) - algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b' - algorithm _ _ = recursively t1 t2 + where algorithm a b = case (a, b) of + (Indexed a', Indexed b') -> do + diffs <- byIndex a' b' + annotate (Indexed diffs) + (Leaf a', Leaf b') | a' == b' -> annotate $ Leaf b' + _ -> recursively t1 t2 annotate = pure . construct . (both (extract t1) (extract t2) :<) algorithmWithTerms :: Eq leaf => Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) From 47c2bdc60e7a2b92da7c221185e3dec59ee9cc70 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:00:29 -0400 Subject: [PATCH 284/320] Use the diff constructor within algorithmWithTerms to compute costs &c. --- src/Interpreter.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 344347af9..de297ec3e 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -32,7 +32,7 @@ diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffCompar diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) diffComparableTerms construct comparable cost a b | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b - | comparable a b = run construct comparable cost (algorithmWithTerms a b) + | comparable a b = run construct comparable cost (algorithmWithTerms construct a b) | otherwise = Nothing -- | Constructs an algorithm and runs it @@ -49,14 +49,14 @@ constructAndRun construct comparable cost t1 t2 _ -> recursively t1 t2 annotate = pure . construct . (both (extract t1) (extract t2) :<) -algorithmWithTerms :: Eq leaf => Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of +algorithmWithTerms :: Eq leaf => DiffConstructor leaf (Record fields) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) +algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> do diffs <- byIndex a b annotate (Indexed diffs) (Leaf a, Leaf b) | a == b -> annotate (Leaf b) _ -> recursively t1 t2 - where annotate = pure . wrap . (both (extract t1) (extract t2) :<) + where annotate = pure . construct . (both (extract t1) (extract t2) :<) -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) From 1df66429a68e1ff2d5e98035c56310392ddd81fe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:01:25 -0400 Subject: [PATCH 285/320] `run` recurs via `diffComparableTerms`. --- src/Interpreter.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index de297ec3e..1582f05a7 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -61,9 +61,7 @@ algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of -- | Runs the diff algorithm run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) run construct comparable cost = runAlgorithm construct recur cost getLabel . fmap Just - where recur a b = do - guard (comparable a b) - constructAndRun construct comparable cost a b + where recur a b = diffComparableTerms construct comparable cost a b getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) From 27786f33269f26e4e082b3a191623a26b91d9e2d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:01:29 -0400 Subject: [PATCH 286/320] :fire: constructAndRun. --- src/Interpreter.hs | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 1582f05a7..9f584abc7 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -35,20 +35,6 @@ diffComparableTerms construct comparable cost a b | comparable a b = run construct comparable cost (algorithmWithTerms construct a b) | otherwise = Nothing --- | Constructs an algorithm and runs it -constructAndRun :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) -constructAndRun construct comparable cost t1 t2 - | (category <$> t1) == (category <$> t2) = hylo construct runCofree <$> zipTerms t1 t2 - | comparable t1 t2 = run construct comparable cost $ algorithm (unwrap t1) (unwrap t2) - | otherwise = Nothing - where algorithm a b = case (a, b) of - (Indexed a', Indexed b') -> do - diffs <- byIndex a' b' - annotate (Indexed diffs) - (Leaf a', Leaf b') | a' == b' -> annotate $ Leaf b' - _ -> recursively t1 t2 - annotate = pure . construct . (both (extract t1) (extract t2) :<) - algorithmWithTerms :: Eq leaf => DiffConstructor leaf (Record fields) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> do From 0598e0727e32afaadda42a9a082be5fd8e2ba6c5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:03:13 -0400 Subject: [PATCH 287/320] algorithmWithTerms does not constrain the annotation type. --- src/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 9f584abc7..e16a05cac 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -35,7 +35,7 @@ diffComparableTerms construct comparable cost a b | comparable a b = run construct comparable cost (algorithmWithTerms construct a b) | otherwise = Nothing -algorithmWithTerms :: Eq leaf => DiffConstructor leaf (Record fields) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) +algorithmWithTerms :: Eq leaf => DiffConstructor leaf a -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) (Diff leaf a) (Diff leaf a) algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> do diffs <- byIndex a b From 7a2c4ed783c47f3d9c6392efc45a98a09fd9eaf3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:06:19 -0400 Subject: [PATCH 288/320] Generalize the Algorithm DSL over the term & diff types. --- src/Algorithm.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 96d21ce9c..592377d6c 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -1,9 +1,7 @@ module Algorithm where import Control.Monad.Free.Church -import Diff import Prologue -import Term -- | A single step in a diffing algorithm. data AlgorithmF @@ -20,11 +18,11 @@ data AlgorithmF -- | A lazily-produced AST for diffing. type Algorithm term diff = F (AlgorithmF term diff) -recursively :: Term leaf annotation -> Term leaf annotation -> Algorithm (Term leaf annotation) (Diff leaf annotation) (Diff leaf annotation) +recursively :: term -> term -> Algorithm term diff diff recursively a b = wrap (Recursive a b pure) -byIndex :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm (Term leaf annotation) (Diff leaf annotation) [Diff leaf annotation] +byIndex :: [term] -> [term] -> Algorithm term diff [diff] byIndex a b = wrap (ByIndex a b pure) -bySimilarity :: [Term leaf annotation] -> [Term leaf annotation] -> Algorithm (Term leaf annotation) (Diff leaf annotation) [Diff leaf annotation] +bySimilarity :: [term] -> [term] -> Algorithm term diff [diff] bySimilarity a b = wrap (ByRandomWalkSimilarity a b pure) From 401b78099c4002f291e93ecc2779ed6675b3b2ff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:08:08 -0400 Subject: [PATCH 289/320] Generalize `algorithmWithTerms` over the diff type. --- src/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index e16a05cac..92b716773 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -35,7 +35,7 @@ diffComparableTerms construct comparable cost a b | comparable a b = run construct comparable cost (algorithmWithTerms construct a b) | otherwise = Nothing -algorithmWithTerms :: Eq leaf => DiffConstructor leaf a -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) (Diff leaf a) (Diff leaf a) +algorithmWithTerms :: Eq leaf => (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> do diffs <- byIndex a b From 78a5e8cf32a14238a430dca5b0972bc5cf204c13 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:09:48 -0400 Subject: [PATCH 290/320] Pare `algorithmWithTerms` down to its essentials. --- src/Interpreter.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 92b716773..9207ee5a8 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -35,12 +35,11 @@ diffComparableTerms construct comparable cost a b | comparable a b = run construct comparable cost (algorithmWithTerms construct a b) | otherwise = Nothing -algorithmWithTerms :: Eq leaf => (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff +algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> do diffs <- byIndex a b annotate (Indexed diffs) - (Leaf a, Leaf b) | a == b -> annotate (Leaf b) _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) From 360863cc2181af6a27700cffc6e8fe411515b3d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:11:12 -0400 Subject: [PATCH 291/320] Define `diffComparableTerms` in terms of `runAlgorithm`. --- src/Interpreter.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 9207ee5a8..d356cdeee 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -32,8 +32,12 @@ diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffCompar diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) diffComparableTerms construct comparable cost a b | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b - | comparable a b = run construct comparable cost (algorithmWithTerms construct a b) + | comparable a b = runAlgorithm construct recur cost getLabel (Just <$> algorithmWithTerms construct a b) | otherwise = Nothing + where recur a b = diffComparableTerms construct comparable cost a b + getLabel (h :< t) = (category h, case t of + Leaf s -> Just s + _ -> Nothing) algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of From d9a1bd29f265ef04e5509835923d871181680600 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:11:22 -0400 Subject: [PATCH 292/320] :fire: `run`. --- src/Interpreter.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index d356cdeee..af5179c0d 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -47,14 +47,6 @@ algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) --- | Runs the diff algorithm -run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm (Term leaf (Record fields)) (Diff leaf (Record fields)) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields)) -run construct comparable cost = runAlgorithm construct recur cost getLabel . fmap Just - where recur a b = diffComparableTerms construct comparable cost a b - getLabel (h :< t) = (category h, case t of - Leaf s -> Just s - _ -> Nothing) - runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Traversable f, Hashable label) => (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -> From e41a0589d56703e371e10b7ede910a42ca4b2776 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:12:52 -0400 Subject: [PATCH 293/320] Define recur by closing over the higher-order functions. --- src/Interpreter.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index af5179c0d..67baa7dfd 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -30,11 +30,11 @@ diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Catego diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) -diffComparableTerms construct comparable cost a b - | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b - | comparable a b = runAlgorithm construct recur cost getLabel (Just <$> algorithmWithTerms construct a b) - | otherwise = Nothing - where recur a b = diffComparableTerms construct comparable cost a b +diffComparableTerms construct comparable cost = recur + where recur a b + | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b + | comparable a b = runAlgorithm construct recur cost getLabel (Just <$> algorithmWithTerms construct a b) + | otherwise = Nothing getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) From a138cf5ec22f5ac355ff8669dfd380c01e5da550 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:40:27 -0400 Subject: [PATCH 294/320] Split out the Indexed handling into a helper function. --- src/Interpreter.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 67baa7dfd..6ca2f27b1 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -41,11 +41,10 @@ diffComparableTerms construct comparable cost = recur algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of - (Indexed a, Indexed b) -> do - diffs <- byIndex a b - annotate (Indexed diffs) + (Indexed a, Indexed b) -> byIndex Indexed a b _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) + byIndex constructor a b = Algorithm.byIndex a b >>= annotate . constructor runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Traversable f, Hashable label) => (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> From bb40b363ba975cc2cfbe7a92513da34317f9bdd3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:40:35 -0400 Subject: [PATCH 295/320] Diff Array nodes byIndex. --- src/Interpreter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 6ca2f27b1..340430b1a 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -42,6 +42,7 @@ diffComparableTerms construct comparable cost = recur algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> byIndex Indexed a b + (Array a, Array b) -> byIndex Array a b _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) byIndex constructor a b = Algorithm.byIndex a b >>= annotate . constructor From 00e538fadb22ac9f177f3a9e3a1db0e8a4b8b5d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:46:02 -0400 Subject: [PATCH 296/320] =?UTF-8?q?Diff=20Commented=20nodes=E2=80=99=20com?= =?UTF-8?q?ments=20byIndex.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Interpreter.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 340430b1a..dae64adc6 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -42,6 +42,9 @@ diffComparableTerms construct comparable cost = recur algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> byIndex Indexed a b + (Commented commentsA a, Commented commentsB b) -> do + wrapped <- sequenceA (recursively <$> a <*> b) + byIndex (`Commented` wrapped) commentsA commentsB (Array a, Array b) -> byIndex Array a b _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) From 6f39c764fd5c316deb4b91577433b05163b177c4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:48:17 -0400 Subject: [PATCH 297/320] :fire: a redundant import. --- src/Interpreter.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index dae64adc6..092b80c54 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -2,7 +2,6 @@ module Interpreter (Comparable, DiffConstructor, diffTerms) where import Algorithm -import Category import Data.Align.Generic import Data.Functor.Foldable import Data.Functor.Both From 15460768bd1dea7d1ce4059758a0cae3f0d0c29d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:48:28 -0400 Subject: [PATCH 298/320] =?UTF-8?q?Diff=20switch=20statements=E2=80=99=20c?= =?UTF-8?q?ases=20byIndex.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Interpreter.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 092b80c54..16b0e043b 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -15,7 +15,7 @@ import Info import Patch import Prologue hiding (lookup) import SES -import Syntax +import Syntax as S import Term -- | Returns whether two terms are comparable @@ -41,6 +41,9 @@ diffComparableTerms construct comparable cost = recur algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> byIndex Indexed a b + (S.Switch exprA casesA, S.Switch exprB casesB) -> do + expr <- recursively exprA exprB + byIndex (S.Switch expr) casesA casesB (Commented commentsA a, Commented commentsB b) -> do wrapped <- sequenceA (recursively <$> a <*> b) byIndex (`Commented` wrapped) commentsA commentsB From 970ae647d2bdd02a1a5fbdf45d74a7a1a8444f5f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:51:44 -0400 Subject: [PATCH 299/320] Diff class definitions byIndex. --- src/Interpreter.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 16b0e043b..9cba6379e 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -48,6 +48,10 @@ algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of wrapped <- sequenceA (recursively <$> a <*> b) byIndex (`Commented` wrapped) commentsA commentsB (Array a, Array b) -> byIndex Array a b + (S.Class identifierA paramsA expressionsA, S.Class identifierB paramsB expressionsB) -> do + identifier <- recursively identifierA identifierB + params <- sequenceA (recursively <$> paramsA <*> paramsB) + byIndex (S.Class identifier params) expressionsA expressionsB _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) byIndex constructor a b = Algorithm.byIndex a b >>= annotate . constructor From efeb01e970c05159c2cf1f51269b752accb8fe88 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:53:08 -0400 Subject: [PATCH 300/320] Diff objects byIndex. --- src/Interpreter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 9cba6379e..d9741f598 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -44,6 +44,7 @@ algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (S.Switch exprA casesA, S.Switch exprB casesB) -> do expr <- recursively exprA exprB byIndex (S.Switch expr) casesA casesB + (S.Object a, S.Object b) -> byIndex S.Object a b (Commented commentsA a, Commented commentsB b) -> do wrapped <- sequenceA (recursively <$> a <*> b) byIndex (`Commented` wrapped) commentsA commentsB From ba1601f0891c500bd7531f362a906ff3075ef904 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 11:54:42 -0400 Subject: [PATCH 301/320] Diff function call arguments byIndex. --- src/Interpreter.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index d9741f598..28cb06a83 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -41,6 +41,9 @@ diffComparableTerms construct comparable cost = recur algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> byIndex Indexed a b + (S.FunctionCall identifierA argsA, S.FunctionCall identifierB argsB) -> do + identifier <- recursively identifierA identifierB + byIndex (S.FunctionCall identifier) argsA argsB (S.Switch exprA casesA, S.Switch exprB casesB) -> do expr <- recursively exprA exprB byIndex (S.Switch expr) casesA casesB From f533059ab2fe58dc7a891b8f8c6fa5064fc41aaa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:00:33 -0400 Subject: [PATCH 302/320] =?UTF-8?q?Diff=20methods=E2=80=99=20parameters=20?= =?UTF-8?q?&=20expressions=20byIndex.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Interpreter.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 28cb06a83..0c8f1a3e9 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -56,6 +56,11 @@ algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of identifier <- recursively identifierA identifierB params <- sequenceA (recursively <$> paramsA <*> paramsB) byIndex (S.Class identifier params) expressionsA expressionsB + (S.Method identifierA paramsA expressionsA, S.Method identifierB paramsB expressionsB) -> do + identifier <- recursively identifierA identifierB + params <- Algorithm.byIndex paramsA paramsB + expressions <- Algorithm.byIndex expressionsA expressionsB + annotate $! S.Method identifier params expressions _ -> recursively t1 t2 where annotate = pure . construct . (both (extract t1) (extract t2) :<) byIndex constructor a b = Algorithm.byIndex a b >>= annotate . constructor From 494274315dc44bf8c187b1479499ccbc8a76e376 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:06:15 -0400 Subject: [PATCH 303/320] Rename ByRandomWalkSimilarity to BySimilarity. --- src/Algorithm.hs | 4 ++-- src/Interpreter.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 592377d6c..a8e02ade8 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -12,7 +12,7 @@ data AlgorithmF = Recursive term term (diff -> f) -- | Diff two arrays and pass the result to the continuation. | ByIndex [term] [term] ([diff] -> f) - | ByRandomWalkSimilarity [term] [term] ([diff] -> f) + | BySimilarity [term] [term] ([diff] -> f) deriving Functor -- | A lazily-produced AST for diffing. @@ -25,4 +25,4 @@ byIndex :: [term] -> [term] -> Algorithm term diff [diff] byIndex a b = wrap (ByIndex a b pure) bySimilarity :: [term] -> [term] -> Algorithm term diff [diff] -bySimilarity a b = wrap (ByRandomWalkSimilarity a b pure) +bySimilarity a b = wrap (BySimilarity a b pure) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 0c8f1a3e9..d4264797c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -77,4 +77,4 @@ runAlgorithm construct recur cost getLabel = F.iter $ \case aligned <- galign (unwrap a) (unwrap b) traverse (these (Just . deleting) (Just . inserting) recur) aligned) ByIndex as bs f -> f (ses recur cost as bs) - ByRandomWalkSimilarity as bs f -> f (rws recur getLabel as bs) + BySimilarity as bs f -> f (rws recur getLabel as bs) From dfd807c945ef537bb02cc03b78427f989d760b44 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:07:19 -0400 Subject: [PATCH 304/320] Clarify the :memo: for ByIndex. --- src/Algorithm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index a8e02ade8..4324832e9 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -10,7 +10,7 @@ data AlgorithmF f -- ^ The type representing another level of the diffing algorithm. Often Algorithm. -- | Recursively diff two terms and pass the result to the continuation. = Recursive term term (diff -> f) - -- | Diff two arrays and pass the result to the continuation. + -- | Diff two lists by each element’s position, and pass the resulting list of diffs to the continuation. | ByIndex [term] [term] ([diff] -> f) | BySimilarity [term] [term] ([diff] -> f) deriving Functor From b4683ffc4fd1a5f056e5ea46a81c2688b581885b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:07:24 -0400 Subject: [PATCH 305/320] :memo: BySimilarity. --- src/Algorithm.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 4324832e9..94fe707c3 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -12,6 +12,7 @@ data AlgorithmF = Recursive term term (diff -> f) -- | Diff two lists by each element’s position, and pass the resulting list of diffs to the continuation. | ByIndex [term] [term] ([diff] -> f) + -- | Diff two lists by each element’s similarity and pass the resulting list of diffs to the continuation. | BySimilarity [term] [term] ([diff] -> f) deriving Functor From e1bb2297af232945c06043b84443b57cdf6bc4eb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:08:18 -0400 Subject: [PATCH 306/320] :memo: the Algorithm DSL. --- src/Algorithm.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 94fe707c3..77542eea6 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -19,11 +19,14 @@ data AlgorithmF -- | A lazily-produced AST for diffing. type Algorithm term diff = F (AlgorithmF term diff) +-- | Constructs a 'Recursive' diff of two terms. recursively :: term -> term -> Algorithm term diff diff recursively a b = wrap (Recursive a b pure) +-- | Constructs a 'ByIndex' diff of two lists of terms. byIndex :: [term] -> [term] -> Algorithm term diff [diff] byIndex a b = wrap (ByIndex a b pure) +-- | Constructs a 'BySimilarity' diff of two lists of terms. bySimilarity :: [term] -> [term] -> Algorithm term diff [diff] bySimilarity a b = wrap (BySimilarity a b pure) From e23b78f1bc5ef2b9a9c118b2b421b9e59f1cd4c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:08:34 -0400 Subject: [PATCH 307/320] Section header for the DSL. --- src/Algorithm.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 77542eea6..3692e9559 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -19,6 +19,9 @@ data AlgorithmF -- | A lazily-produced AST for diffing. type Algorithm term diff = F (AlgorithmF term diff) + +-- DSL + -- | Constructs a 'Recursive' diff of two terms. recursively :: term -> term -> Algorithm term diff diff recursively a b = wrap (Recursive a b pure) From 49d0fa798046d5205c376d0669550358f0c90db3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:10:19 -0400 Subject: [PATCH 308/320] Correct the :memo: of Algorithm. --- src/Algorithm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 3692e9559..c196f6d79 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -16,7 +16,7 @@ data AlgorithmF | BySimilarity [term] [term] ([diff] -> f) deriving Functor --- | A lazily-produced AST for diffing. +-- | The free monad for 'AlgorithmF'. This enables us to construct diff values using do-notation. We use the Church-encoded free monad 'F' for efficiency. type Algorithm term diff = F (AlgorithmF term diff) From 04a3d5200729a512856d3060dd6609b208a37b4d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:13:48 -0400 Subject: [PATCH 309/320] :memo: diffTerms. --- src/Interpreter.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index d4264797c..d8f1ddd18 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -24,8 +24,14 @@ type Comparable leaf annotation = Term leaf annotation -> Term leaf annotation - -- | Constructs a diff from the CofreeF containing its annotation and syntax. This function has the opportunity to, for example, cache properties in the annotation. type DiffConstructor leaf annotation = CofreeF (Syntax leaf) (Both annotation) (Diff leaf annotation) -> Diff leaf annotation --- | Diff two terms, given a function that determines whether two terms can be compared and a cost function. -diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Diff leaf (Record fields) +-- | Diff two terms recursively, given functions characterizing the diffing. +diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => + DiffConstructor leaf (Record fields) -> -- ^ A function to wrap up & possibly annotate every produced diff. + Comparable leaf (Record fields) -> -- ^ A function to determine whether or not two terms should even be compared. + SES.Cost (Diff leaf (Record fields)) -> -- ^ A function to compute the cost of a given diff node. + Term leaf (Record fields) -> -- ^ A term representing the old state. + Term leaf (Record fields) -> -- ^ A term representing the new state. + Diff leaf (Record fields) diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) From 7378668b2c116ca798ee188db95e52a698a435c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:25:56 -0400 Subject: [PATCH 310/320] Put the = before the first constructor. --- src/Syntax.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index b5b6e39ed..1357e2d8e 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -11,9 +11,8 @@ import SourceSpan data Syntax a -- ^ The type of leaves in the syntax tree, typically String, but possibly some datatype representing different leaves more precisely. f -- ^ The type representing another level of the tree, e.g. the children of branches. Often Cofree or Fix or similar. - = -- | A terminal syntax node, e.g. an identifier, or atomic literal. - Leaf a + = Leaf a -- | An ordered branch of child nodes, expected to be variadic in the grammar, e.g. a list of statements or uncurried function parameters. | Indexed [f] -- | An ordered branch of child nodes, expected to be of fixed length in the grammar, e.g. a binary operator & its operands. From af34a7bf1ccdcfbc99d204afa00ec615916d5a45 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:26:07 -0400 Subject: [PATCH 311/320] Haddock-friendly docs for Syntax. --- src/Syntax.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Syntax.hs b/src/Syntax.hs index 1357e2d8e..d7cc56f0c 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -8,9 +8,10 @@ import Test.QuickCheck hiding (Fixed) import SourceSpan -- | A node in an abstract syntax tree. -data Syntax - a -- ^ The type of leaves in the syntax tree, typically String, but possibly some datatype representing different leaves more precisely. - f -- ^ The type representing another level of the tree, e.g. the children of branches. Often Cofree or Fix or similar. +-- +-- 'a' is the type of leaves in the syntax tree, typically 'Text', but possibly some datatype representing different leaves more precisely. +-- 'f' is the type representing another level of the tree, e.g. the children of branches. Often 'Cofree', 'Free' or similar. +data Syntax a f -- | A terminal syntax node, e.g. an identifier, or atomic literal. = Leaf a -- | An ordered branch of child nodes, expected to be variadic in the grammar, e.g. a list of statements or uncurried function parameters. From d2cbccede25e79a1e49593c7e81a2b378cee13e5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:30:23 -0400 Subject: [PATCH 312/320] Haddock-friendly :memo: for rws. --- src/Data/RandomWalkSimilarity.hs | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/src/Data/RandomWalkSimilarity.hs b/src/Data/RandomWalkSimilarity.hs index 6f95a90bf..6c71c9cfd 100644 --- a/src/Data/RandomWalkSimilarity.hs +++ b/src/Data/RandomWalkSimilarity.hs @@ -18,16 +18,12 @@ import Test.QuickCheck hiding (Fixed) import Test.QuickCheck.Random -- | Given a function comparing two terms recursively, and a function to compute a Hashable label from an unpacked term, compute the diff of a pair of lists of terms using a random walk similarity metric, which completes in log-linear time. This implementation is based on the paper [_RWS-Diff—Flexible and Efficient Change Detection in Hierarchical Data_](https://github.com/github/semantic-diff/files/325837/RWS-Diff.Flexible.and.Efficient.Change.Detection.in.Hierarchical.Data.pdf). -rws :: (Hashable label, Eq annotation, Prologue.Foldable f, Functor f, Eq (f (Cofree f annotation))) => - -- | A function which comapres a pair of terms recursively, returning 'Just' their diffed value if appropriate, or 'Nothing' if they should not be compared. - (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -> - -- | A function to compute a label for an unpacked term. - (forall b. CofreeF f annotation b -> label) -> - -- | The old list of terms. - [Cofree f annotation] -> - -- | The new list of terms. - [Cofree f annotation] -> - [Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))] +rws :: (Hashable label, Eq annotation, Prologue.Foldable f, Functor f, Eq (f (Cofree f annotation))) + => (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -- ^ A function which comapres a pair of terms recursively, returning 'Just' their diffed value if appropriate, or 'Nothing' if they should not be compared. + -> (forall b. CofreeF f annotation b -> label) -- ^ A function to compute a label for an unpacked term. + -> [Cofree f annotation] -- ^ The list of old terms. + -> [Cofree f annotation] -- ^ The list of new terms. + -> [Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))] rws compare getLabel as bs | null as, null bs = [] | null as = insert <$> bs From e0da05538ee61898bbd016bdc77b2bb4154fae98 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:31:18 -0400 Subject: [PATCH 313/320] Haddock-friendly :memo: of AlgorithmF. --- src/Algorithm.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index c196f6d79..0f98ac5c7 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -4,10 +4,11 @@ import Control.Monad.Free.Church import Prologue -- | A single step in a diffing algorithm. -data AlgorithmF - term -- ^ The type of terms. - diff -- ^ The type of diffs. - f -- ^ The type representing another level of the diffing algorithm. Often Algorithm. +-- +-- 'term' is the type of terms. +-- 'diff' is the type of diffs. +-- 'f' represents the continuation after diffing. Often 'Algorithm'. +data AlgorithmF term diff f -- | Recursively diff two terms and pass the result to the continuation. = Recursive term term (diff -> f) -- | Diff two lists by each element’s position, and pass the resulting list of diffs to the continuation. From 11a3f324325839cc91f47d71a7bcc1d4fb6a1f66 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:33:09 -0400 Subject: [PATCH 314/320] Haddock-friendly :memo: of diffTerms. --- src/Interpreter.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index d8f1ddd18..3162c38a1 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -25,13 +25,13 @@ type Comparable leaf annotation = Term leaf annotation -> Term leaf annotation - type DiffConstructor leaf annotation = CofreeF (Syntax leaf) (Both annotation) (Diff leaf annotation) -> Diff leaf annotation -- | Diff two terms recursively, given functions characterizing the diffing. -diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => - DiffConstructor leaf (Record fields) -> -- ^ A function to wrap up & possibly annotate every produced diff. - Comparable leaf (Record fields) -> -- ^ A function to determine whether or not two terms should even be compared. - SES.Cost (Diff leaf (Record fields)) -> -- ^ A function to compute the cost of a given diff node. - Term leaf (Record fields) -> -- ^ A term representing the old state. - Term leaf (Record fields) -> -- ^ A term representing the new state. - Diff leaf (Record fields) +diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) + => DiffConstructor leaf (Record fields) -- ^ A function to wrap up & possibly annotate every produced diff. + -> Comparable leaf (Record fields) -- ^ A function to determine whether or not two terms should even be compared. + -> SES.Cost (Diff leaf (Record fields)) -- ^ A function to compute the cost of a given diff node. + -> Term leaf (Record fields) -- ^ A term representing the old state. + -> Term leaf (Record fields) -- ^ A term representing the new state. + -> Diff leaf (Record fields) diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) From 071e9568f0bc375a922443bddd7356c4c07b05b1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:42:26 -0400 Subject: [PATCH 315/320] :memo: runAlgorithm. --- src/Interpreter.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 3162c38a1..f7f97a968 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -71,13 +71,14 @@ algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of where annotate = pure . construct . (both (extract t1) (extract t2) :<) byIndex constructor a b = Algorithm.byIndex a b >>= annotate . constructor -runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Traversable f, Hashable label) => - (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> - (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -> - SES.Cost (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> - (forall b. CofreeF f annotation b -> label) -> - Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -> - a +-- | Run an algorithm, given functions characterizing the evaluation. +runAlgorithm :: (Functor f, GAlign f, Eq a, Eq annotation, Eq (f (Cofree f annotation)), Prologue.Foldable f, Traversable f, Hashable label) + => (CofreeF f (Both annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -> Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -- ^ A function to wrap up & possibly annotate every produced diff. + -> (Cofree f annotation -> Cofree f annotation -> Maybe (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation)))) -- ^ A function to diff two subterms recursively, if they are comparable, or else return 'Nothing'. + -> SES.Cost (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) -- ^ A function to compute the cost of a given diff node. + -> (forall b. CofreeF f annotation b -> label) -- ^ A function to compute a label for a given term. + -> Algorithm (Cofree f annotation) (Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))) a -- ^ The algorithm to run. + -> a runAlgorithm construct recur cost getLabel = F.iter $ \case Recursive a b f -> f (maybe (replacing a b) (construct . (both (extract a) (extract b) :<)) $ do aligned <- galign (unwrap a) (unwrap b) From 9374ed5a4a2cf97d8bd3ccbfc4ec155f7bedaa3c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:47:56 -0400 Subject: [PATCH 316/320] :memo: algorithmWithTerms. --- src/Interpreter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index f7f97a968..4ef568168 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -44,6 +44,7 @@ diffComparableTerms construct comparable cost = recur Leaf s -> Just s _ -> Nothing) +-- | Construct an algorithm to diff a pair of terms. algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> byIndex Indexed a b From 26b5f5b41bfcc3d8c17490b9b2bf1869d1058110 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:48:27 -0400 Subject: [PATCH 317/320] :memo: diffComparableTerms. --- src/Interpreter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 4ef568168..3c15317c3 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -34,6 +34,7 @@ diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Catego -> Diff leaf (Record fields) diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b +-- | Diff two terms recursively, given functions characterizing the diffing. If the terms are incomparable, returns 'Nothing'. diffComparableTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields)) diffComparableTerms construct comparable cost = recur where recur a b From 6b84266ac6669bde7cf28dbf15b1d1a1c22c3ef5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:51:05 -0400 Subject: [PATCH 318/320] :memo: the Patch DSL. --- src/Patch.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Patch.hs b/src/Patch.hs index 8ed640887..c4dcc8e69 100644 --- a/src/Patch.hs +++ b/src/Patch.hs @@ -24,12 +24,15 @@ data Patch a -- DSL +-- | Constructs the replacement of one value by another in an Applicative context. replacing :: Applicative f => a -> a -> f (Patch a) replacing = (pure .) . Replace +-- | Constructs the insertion of a value in an Applicative context. inserting :: Applicative f => a -> f (Patch a) inserting = pure . Insert +-- | Constructs the deletion of a value in an Applicative context. deleting :: Applicative f => a -> f (Patch a) deleting = pure . Delete From c308cd2b0149a90608b34ce892855f7ba48b1e63 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:51:36 -0400 Subject: [PATCH 319/320] Use the Patch DSL in SES. --- src/SES.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/SES.hs b/src/SES.hs index 5c59470f6..97ad55d1a 100644 --- a/src/SES.hs +++ b/src/SES.hs @@ -38,8 +38,8 @@ diffAt diffTerms cost (i, j) as bs | null bs = pure $ foldr delete [] as | otherwise = pure [] where - delete = consWithCost cost . pure . Delete - insert = consWithCost cost . pure . Insert + delete = consWithCost cost . deleting + insert = consWithCost cost . inserting costOf [] = 0 costOf ((_, c) : _) = c best = minimumBy (comparing costOf) From a6f8194b14e3e353bb8cfc94ee1734191792541d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 4 Aug 2016 12:51:41 -0400 Subject: [PATCH 320/320] Use the Patch DSL in RWS. --- src/Data/RandomWalkSimilarity.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Data/RandomWalkSimilarity.hs b/src/Data/RandomWalkSimilarity.hs index 6c71c9cfd..6b10ffe36 100644 --- a/src/Data/RandomWalkSimilarity.hs +++ b/src/Data/RandomWalkSimilarity.hs @@ -26,12 +26,10 @@ rws :: (Hashable label, Eq annotation, Prologue.Foldable f, Functor f, Eq (f (Co -> [Free (CofreeF f (Both annotation)) (Patch (Cofree f annotation))] rws compare getLabel as bs | null as, null bs = [] - | null as = insert <$> bs - | null bs = delete <$> as + | null as = inserting <$> bs + | null bs = deleting <$> as | otherwise = fmap snd . uncurry deleteRemaining . (`runState` (negate 1, fas)) $ traverse findNearestNeighbourTo fbs - where insert = pure . Insert - delete = pure . Delete - (p, q, d) = (2, 2, 15) + where (p, q, d) = (2, 2, 15) fas = zipWith featurize [0..] as fbs = zipWith featurize [0..] bs kdas = KdTree.build (Vector.toList . feature) fas @@ -39,14 +37,14 @@ rws compare getLabel as bs findNearestNeighbourTo kv@(UnmappedTerm _ _ v) = do (previous, unmapped) <- get let (UnmappedTerm i _ _) = KdTree.nearest kdas kv - fromMaybe (pure (negate 1, insert v)) $ do + fromMaybe (pure (negate 1, inserting v)) $ do found <- find ((== i) . termIndex) unmapped guard (i >= previous) compared <- compare (term found) v pure $! do put (i, List.delete found unmapped) pure (i, compared) - deleteRemaining diffs (_, unmapped) = foldl' (flip (List.insertBy (comparing fst))) diffs ((termIndex &&& delete . term) <$> unmapped) + deleteRemaining diffs (_, unmapped) = foldl' (flip (List.insertBy (comparing fst))) diffs ((termIndex &&& deleting . term) <$> unmapped) -- | A term which has not yet been mapped by `rws`, along with its feature vector summary & index. data UnmappedTerm a = UnmappedTerm { termIndex :: {-# UNPACK #-} !Int, feature :: !(Vector.Vector Double), term :: !a }