Merge pull request #651 from github/property-tests

Property tests

semantic-diff.cabal

@@ -75,6 +75,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

src/Category.hs

@@ -2,7 +2,9 @@ module Category where
 
 import Prologue
 import Data.Hashable
-import Test.QuickCheck
+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,23 +74,47 @@ 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
+  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
     ]
 

src/Data/Record.hs

@@ -4,6 +4,7 @@ module Data.Record where
 import GHC.Show
 import Prologue
 import Test.QuickCheck
+import GHC.Show (Show(..))
 
 -- | A type-safe, extensible record structure.
 -- |

src/DiffSummary.hs

@@ -1,26 +1,31 @@
 {-# LANGUAGE DataKinds, TypeFamilies, ScopedTypeVariables #-}
-module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..)) where
+
+module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..), annotatedSummaries) where
 
 import Prologue hiding (snd, intercalate)
 import Diff
-import Info (category)
 import Patch
 import Term
+import Info (category)
 import Syntax
 import Category
 import Data.Functor.Foldable as Foldable
 import Data.Functor.Both
-import Data.Record
 import Data.Text as Text (intercalate)
-import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string)
+import Test.QuickCheck hiding (Fixed)
+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
 
-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
-  Fixed children -> fromMaybe "EmptyFixedNode" $ (toCategoryName . category) . extract <$> head children
-  Indexed children -> fromMaybe "EmptyIndexedNode" $ (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)
@@ -98,20 +103,41 @@ 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)
+instance Arbitrary Branch where
+  arbitrary = oneof [ pure BIndexed, pure BFixed ]
+  shrink = genericShrink
+
 data DiffSummary a = DiffSummary {
   patch :: Patch a,
   parentAnnotations :: [Category]
-} deriving (Eq, Functor, Show)
+} deriving (Eq, Functor, Show, Generic)
 
-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
+instance (Eq a, Arbitrary a) => Arbitrary (DiffSummary a) where
+  arbitrary = DiffSummary <$> arbitrary <*> arbitrary
+  shrink = genericShrink
+
+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]
@@ -119,8 +145,8 @@ 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
@@ -138,26 +164,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 (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)) -> [ DiffSummary (Insert $ termToDiffInfo term) [] ]
+  (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) => Term leaf (Record fields) -> DiffInfo
 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) ]
+  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)
   -- 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
-  _ -> [ DiffInfo (toCategoryName term) (toTermName term) ]
+  Syntax.Operator _ -> LeafInfo (toCategoryName term) "x"
+  Commented cs leaf -> BranchInfo (termToDiffInfo <$> cs <> maybeToList leaf) (toCategoryName term) BCommented
+  _ ->  LeafInfo (toCategoryName term) (toTermName term)
 
 prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo
 prependSummary annotation summary = summary { parentAnnotations = annotation : parentAnnotations summary }

src/Diffing.hs

@@ -98,15 +98,18 @@ diffFiles parser renderer sourceBlobs = do
         (True, False) -> pure $ Insert (snd terms)
         (False, True) -> pure $ Delete (fst terms)
         (_, _) ->
-          runBothWith (diffTerms construct shouldCompareTerms diffCostWithCachedTermCosts) (replaceLeaves <*> terms)
+          runBothWith (diffTerms construct compareCategoryEq diffCostWithCachedTermCosts) (replaceLeaves <*> terms)
 
   pure $! renderer textDiff sourceBlobs
+
   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)))
-        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.
 diffCostWithCachedTermCosts :: HasField fields Cost => Diff leaf (Record fields) -> Integer

src/Renderer/Summary.hs

@@ -7,8 +7,8 @@ import Data.Aeson
 import Data.Record
 import Range
 import DiffSummary
-import Data.Text (pack)
 import Text.PrettyPrint.Leijen.Text (pretty)
 
 summary :: (HasField fields Category, HasField fields Range) => Renderer (Record fields)
-summary diff _ = toS . encode $ pack . show . pretty <$> diffSummary diff
+summary diff _ = toS . encode $ summaries >>= annotatedSummaries
+  where summaries = diffSummary diff

test/AlignmentSpec.hs

@@ -26,6 +26,7 @@ import Term
 import Test.Hspec
 import Test.Hspec.QuickCheck
 import Test.QuickCheck
+import GHC.Show (Show(..))
 
 spec :: Spec
 spec = parallel $ do

test/CorpusSpec.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE DataKinds, FlexibleContexts, GeneralizedNewtypeDeriving #-}
 module CorpusSpec where
 
-import System.IO
+import Data.String
 import Diffing
 import Renderer
 import qualified Renderer.JSON as J
@@ -23,6 +23,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
@@ -77,7 +78,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)

test/DiffSummarySpec.hs

@@ -7,12 +7,17 @@ import Test.Hspec
 import Test.Hspec.QuickCheck
 import Diff
 import Syntax
+import Term
 import Patch
 import Category
 import DiffSummary
-import Text.PrettyPrint.Leijen.Text
+import Text.PrettyPrint.Leijen.Text (pretty)
+import Test.Hspec.QuickCheck
+import Diff.Arbitrary
+import Data.List (partition)
 import Term.Arbitrary
 import Interpreter
+import Info
 
 arrayInfo :: Record '[Category]
 arrayInfo = ArrayLiteral .: RNil
@@ -24,23 +29,75 @@ testDiff :: Diff Text (Record '[Category])
 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 (LeafInfo "string" "a"), parentAnnotations = [] }
 
 replacementSummary :: DiffSummary DiffInfo
-replacementSummary = DiffSummary { patch = Replace (DiffInfo "string" "a") (DiffInfo "symbol" "b"), parentAnnotations = [ ArrayLiteral ] }
+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 ] } ]
+      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
         diffSummary (diffTerms wrap (==) diffCost term term) `shouldBe` []
 
-  describe "show" $ do
+  describe "annotatedSummaries" $ 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
+        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 -> children <> maybeToList leaf >>= extractDiffLeaves
+          _ -> [ term ]
+        in
+          case (partition isBranchNode diffInfoPatches, partition isIndexedOrFixed syntaxPatches) of
+            ((branchPatches, _), (diffPatches, _)) ->
+              let listOfLeaves = foldMap extractLeaves (join $ toList <$> branchPatches)
+                  listOfDiffLeaves = foldMap extractDiffLeaves (diffPatches >>= toList)
+               in
+                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' :: 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 = any isBranchInfo

vendor/text-icu

@@ -1 +1 @@
-Subproject commit a660194e2358ffcc86a9fe11a67fc3223c316007
+Subproject commit 6d07c2b2034f2bfdcd038de0d6a3ceca445f0221