Merge branch 'master' into quis-lintiet-ipsos-lintes

bench/Main.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, FlexibleInstances, StandaloneDeriving #-}
+module Main where
+
+import Criterion.Main
+import Data.String
+import Prologue
+import Test.QuickCheck hiding (Fixed)
+
+main :: IO ()
+main = do
+  benchmarks <- sequenceA []
+  defaultMain benchmarks
+
+-- | Defines a named group of n benchmarks over inputs generated by an `Arbitrary` instance.
+-- |
+-- | The inputs’ sizes at each iteration are measured by a metric function, which gives the name of the benchmark. This makes it convenient to correlate a benchmark of some function over lists with e.g. input `length`.
+generativeBenchmark :: (Arbitrary a, Show m, Ord m) => String -> Int -> (a -> m) -> (a -> Benchmarkable) -> IO Benchmark
+generativeBenchmark name n metric benchmark = do
+  benchmarks <- traverse measure (replicate n defaultSize)
+  pure $! bgroup name (snd <$> (sortOn fst benchmarks))
+  where measure n = do
+          input <- generate (resize n arbitrary)
+          let measurement = metric input
+          pure $! (measurement, bench (show measurement) (benchmark input))
+        defaultSize = 100

semantic-diff.cabal

@@ -16,9 +16,12 @@ library
   exposed-modules:     Algorithm
                      , Alignment
                      , Category
+                     , Data.Bifunctor.Join.Arbitrary
                      , Data.Functor.Both
                      , Data.OrderedMap
+                     , Data.These.Arbitrary
                      , Diff
+                     , Diff.Arbitrary
                      , Diffing
                      , DiffOutput
                      , Info
@@ -27,6 +30,7 @@ library
                      , Operation
                      , Parser
                      , Patch
+                     , Patch.Arbitrary
                      , Range
                      , Renderer
                      , Renderer.JSON
@@ -38,6 +42,7 @@ library
                      , SplitDiff
                      , Syntax
                      , Term
+                     , Term.Arbitrary
                      , TreeSitter
                      , DiffSummary
                      , Prologue
@@ -52,6 +57,8 @@ library
                      , filepath
                      , mtl
                      , pointed
+                     , QuickCheck >= 2.8.1
+                     , quickcheck-text
                      , semigroups
                      , text >= 1.2.1.3
                      , text-icu
@@ -66,6 +73,22 @@ library
   default-extensions:  DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric, FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards
   ghc-options:        -Wall -fno-warn-name-shadowing -O2 -threaded -fprof-auto "-with-rtsopts=-N -p -s -h -i0.1" -j
 
+benchmark semantic-diff-bench
+  type:                exitcode-stdio-1.0
+  main-is:             Main.hs
+  hs-source-dirs:      bench
+  build-depends:       base
+                     , bifunctors
+                     , criterion
+                     , QuickCheck >= 2.8.1
+                     , quickcheck-text
+                     , recursion-schemes
+                     , semantic-diff
+                     , these
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -j -O2 -static
+  default-language:    Haskell2010
+  default-extensions:  OverloadedStrings, NoImplicitPrelude
+
 test-suite semantic-diff-test
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test

src/Data/Bifunctor/Join/Arbitrary.hs

@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Data.Bifunctor.Join.Arbitrary where
+
+import Data.Bifunctor.Join
+import Data.Functor.Both as Both
+import Data.These
+import Data.These.Arbitrary ()
+import Prologue
+import Test.QuickCheck
+
+instance Arbitrary a => Arbitrary (Join These a) where
+  arbitrary = Join <$> arbitrary
+  shrink (Join a) = Join <$> shrink a
+
+instance Arbitrary a => Arbitrary (Join (,) a) where
+  arbitrary = both <$> arbitrary <*> arbitrary
+  shrink b = both <$> shrink (Both.fst b) <*> shrink (Both.snd b)

src/Data/These/Arbitrary.hs

@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Data.These.Arbitrary where
+
+import Data.These
+import Prologue
+import Test.QuickCheck
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (These a b) where
+  arbitrary = oneof [ This <$> arbitrary
+                    , That <$> arbitrary
+                    , These <$> arbitrary <*> arbitrary ]
+  shrink = these (fmap This . shrink) (fmap That . shrink) (\ a b -> (This <$> shrink a) ++ (That <$> shrink b) ++ (These <$> shrink a <*> shrink b))

src/Diff.hs

@@ -9,6 +9,7 @@ import Syntax
 import Term
 
 -- | An annotated series of patches of terms.
+type DiffF leaf annotation = FreeF (CofreeF (Syntax leaf) (Both annotation)) (Patch (Term leaf annotation))
 type Diff a annotation = Free (CofreeF (Syntax a) (Both annotation)) (Patch (Term a annotation))
 
 type instance Base (Free f a) = FreeF f a

src/Diff/Arbitrary.hs

@@ -0,0 +1,69 @@
+module Diff.Arbitrary where
+
+import Diff
+import Data.Bifunctor.Join
+import Data.Bifunctor.Join.Arbitrary ()
+import Data.Functor.Foldable (unfold)
+import qualified Data.List as List
+import qualified Data.OrderedMap as Map
+import Patch
+import Patch.Arbitrary ()
+import Syntax
+import Prologue
+import Term.Arbitrary
+import Test.QuickCheck hiding (Fixed)
+
+newtype ArbitraryDiff leaf annotation = ArbitraryDiff { unArbitraryDiff :: FreeF (CofreeF (Syntax leaf) (Join (,) annotation)) (Patch (ArbitraryTerm leaf annotation)) (ArbitraryDiff leaf annotation) }
+  deriving (Show, Eq, Generic)
+
+toDiff :: ArbitraryDiff leaf annotation -> Diff leaf annotation
+toDiff = fmap (fmap toTerm) . unfold unArbitraryDiff
+
+diffOfSize :: (Arbitrary leaf, Arbitrary annotation) => Int -> Gen (ArbitraryDiff leaf annotation)
+diffOfSize n
+  | n <= 0 = (ArbitraryDiff .) . (Free .) . (:<) <$> arbitrary <*> syntaxOfSize n
+  | otherwise = oneof
+    [ (ArbitraryDiff .) . (Free .) . (:<) <$> arbitrary <*> syntaxOfSize n
+    , ArbitraryDiff . Pure <$> patchOfSize n ]
+  where syntaxOfSize n | n <= 1 = oneof $ (Leaf <$> arbitrary) : branchGeneratorsOfSize n
+                       | otherwise = oneof $ branchGeneratorsOfSize n
+        branchGeneratorsOfSize n =
+          [ Indexed <$> childrenOfSize (pred n)
+          , Fixed <$> childrenOfSize (pred n)
+          , (Keyed .) . (Map.fromList .) . zip <$> infiniteListOf arbitrary <*> childrenOfSize (pred n)
+          ]
+        childrenOfSize n | n <= 0 = pure []
+        childrenOfSize n = do
+          m <- choose (1, n)
+          first <- diffOfSize m
+          rest <- childrenOfSize (n - m)
+          pure $! first : rest
+        patchOfSize 1 = oneof [ Insert <$> termOfSize 1
+                              , Delete <$> termOfSize 1 ]
+        patchOfSize n = do
+          m <- choose (1, n - 1)
+          left <- termOfSize m
+          right <- termOfSize (n - m)
+          oneof [ Insert <$> termOfSize n
+                , Delete <$> termOfSize n
+                , pure (Replace left right) ]
+
+arbitraryDiffSize :: ArbitraryDiff leaf annotation -> Int
+arbitraryDiffSize = iter (succ . sum) . fmap (sum . fmap (arbitraryTermSize . unfold runCofree)) . toDiff
+
+
+-- Instances
+
+instance (Eq leaf, Eq annotation, Arbitrary leaf, Arbitrary annotation) => Arbitrary (ArbitraryDiff leaf annotation) where
+  arbitrary = sized $ \ n -> do
+    m <- choose (0, n)
+    diffOfSize m
+
+  shrink diff@(ArbitraryDiff annotated) = case annotated of
+    Free (annotation :< syntax) -> (subterms diff ++) $ filter (/= diff) $
+      (ArbitraryDiff .) . (Free .) . (:<) <$> shrink annotation <*> case syntax of
+        Leaf a -> Leaf <$> shrink a
+        Indexed i -> Indexed <$> (List.subsequences i >>= recursivelyShrink)
+        Fixed f -> Fixed <$> (List.subsequences f >>= recursivelyShrink)
+        Keyed k -> Keyed . Map.fromList <$> (List.subsequences (Map.toList k) >>= recursivelyShrink)
+    Pure patch -> ArbitraryDiff . Pure <$> shrink patch

src/Patch.hs

@@ -16,7 +16,7 @@ data Patch a =
   Replace a a
   | Insert a
   | Delete a
-  deriving (Foldable, Functor, Show, Eq)
+  deriving (Eq, Foldable, Functor, Show, Traversable)
 
 -- | Return the item from the after side of the patch.
 after :: Patch a -> Maybe a

src/Patch/Arbitrary.hs

@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Patch.Arbitrary where
+
+import Patch
+import Prologue
+import Test.QuickCheck
+
+patchOf :: Gen a -> Gen a -> Gen (Patch a)
+patchOf l r = oneof
+  [ Insert <$> r
+  , Delete <$> l
+  , Replace <$> l <*> r
+  ]
+
+instance Arbitrary a => Arbitrary (Patch a) where
+  arbitrary = patchOf arbitrary arbitrary
+
+  shrink patch = traverse shrink patch

src/Term/Arbitrary.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE TypeFamilies #-}
+module Term.Arbitrary where
+
+import Data.Functor.Foldable (Base, cata, unfold, Unfoldable(embed))
+import qualified Data.List as List
+import qualified Data.OrderedMap as Map
+import Data.Text.Arbitrary ()
+import Prologue
+import Syntax
+import Term
+import Test.QuickCheck hiding (Fixed)
+
+newtype ArbitraryTerm leaf annotation = ArbitraryTerm { unArbitraryTerm :: TermF leaf annotation (ArbitraryTerm leaf annotation) }
+  deriving (Show, Eq, Generic)
+
+toTerm :: ArbitraryTerm leaf annotation -> Term leaf annotation
+toTerm = unfold unArbitraryTerm
+
+termOfSize :: (Arbitrary leaf, Arbitrary annotation) => Int -> Gen (ArbitraryTerm leaf annotation)
+termOfSize n = (ArbitraryTerm .) . (:<) <$> arbitrary <*> syntaxOfSize n
+  where syntaxOfSize n | n <= 1 = oneof $ (Leaf <$> arbitrary) : branchGeneratorsOfSize n
+                       | otherwise = oneof $ branchGeneratorsOfSize n
+        branchGeneratorsOfSize n =
+          [ Indexed <$> childrenOfSize (pred n)
+          , Fixed <$> childrenOfSize (pred n)
+          , (Keyed .) . (Map.fromList .) . zip <$> infiniteListOf arbitrary <*> childrenOfSize (pred n)
+          ]
+        childrenOfSize n | n <= 0 = pure []
+        childrenOfSize n = do
+          m <- choose (1, n)
+          first <- termOfSize m
+          rest <- childrenOfSize (n - m)
+          pure $! first : rest
+
+arbitraryTermSize :: ArbitraryTerm leaf annotation -> Int
+arbitraryTermSize = cata (succ . sum) . toTerm
+
+-- Instances
+
+type instance Base (ArbitraryTerm leaf annotation) = CofreeF (Syntax leaf) annotation
+instance Unfoldable (ArbitraryTerm leaf annotation) where embed = ArbitraryTerm
+
+instance (Eq leaf, Eq annotation, Arbitrary leaf, Arbitrary annotation) => Arbitrary (ArbitraryTerm leaf annotation) where
+  arbitrary = sized $ \ n -> do
+    m <- choose (0, n)
+    termOfSize m
+
+  shrink term@(ArbitraryTerm (annotation :< syntax)) = (subterms term ++) $ filter (/= term) $
+    (ArbitraryTerm .) . (:<) <$> shrink annotation <*> case syntax of
+      Leaf a -> Leaf <$> shrink a
+      Indexed i -> Indexed <$> (List.subsequences i >>= recursivelyShrink)
+      Fixed f -> Fixed <$> (List.subsequences f >>= recursivelyShrink)
+      Keyed k -> Keyed . Map.fromList <$> (List.subsequences (Map.toList k) >>= recursivelyShrink)

test/AlignmentSpec.hs

@@ -7,6 +7,7 @@ import Control.Monad.State
 import Data.Align hiding (align)
 import Data.Bifunctor
 import Data.Bifunctor.Join
+import Data.Bifunctor.Join.Arbitrary ()
 import Data.Functor.Both as Both
 import Data.List (nub)
 import Data.Monoid

test/ArbitraryTerm.hs

@@ -1,75 +1,16 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module ArbitraryTerm where
 
-import Category
-import Data.Bifunctor.Join
-import Data.Functor.Both
-import Data.Functor.Foldable
-import qualified Data.OrderedMap as Map
-import qualified Data.List as List
 import Data.Text.Arbitrary ()
-import Data.These
-import Info
-import Patch
+import Data.These.Arbitrary ()
 import Prologue hiding (fst, snd)
-import Range
 import Source hiding ((++))
-import Syntax
-import Term
 import Test.QuickCheck hiding (Fixed)
 
-newtype ArbitraryTerm a annotation = ArbitraryTerm (annotation, Syntax a (ArbitraryTerm a annotation))
-  deriving (Show, Eq, Generic)
-
-unTerm :: ArbitraryTerm a annotation -> Term a annotation
-unTerm = unfold unpack
-  where unpack (ArbitraryTerm (annotation, syntax)) = annotation :< syntax
-
-instance (Eq a, Eq annotation, Arbitrary a, Arbitrary annotation) => Arbitrary (ArbitraryTerm a annotation) where
-  arbitrary = scale (`div` 2) $ sized (\ x -> boundedTerm x x) -- first indicates the cube of the max length of lists, second indicates the cube of the max depth of the tree
-    where boundedTerm maxLength maxDepth = ArbitraryTerm <$> ((,) <$> arbitrary <*> boundedSyntax maxLength maxDepth)
-          boundedSyntax _ maxDepth | maxDepth <= 0 = Leaf <$> arbitrary
-          boundedSyntax maxLength maxDepth = frequency
-            [ (12, Leaf <$> arbitrary),
-              (1, Indexed . take maxLength <$> listOf (smallerTerm maxLength maxDepth)),
-              (1, Fixed . take maxLength <$> listOf (smallerTerm maxLength maxDepth)),
-              (1, Keyed . Map.fromList . take maxLength <$> listOf (arbitrary >>= (\x -> (,) x <$> smallerTerm maxLength maxDepth))) ]
-          smallerTerm maxLength maxDepth = boundedTerm (div maxLength 3) (div maxDepth 3)
-  shrink term@(ArbitraryTerm (annotation, syntax)) = (subterms term ++) $ filter (/= term) $
-    ArbitraryTerm <$> ((,) <$> shrink annotation <*> case syntax of
-      Leaf a -> Leaf <$> shrink a
-      Indexed i -> Indexed <$> (List.subsequences i >>= recursivelyShrink)
-      Fixed f -> Fixed <$> (List.subsequences f >>= recursivelyShrink)
-      Keyed k -> Keyed . Map.fromList <$> (List.subsequences (Map.toList k) >>= recursivelyShrink))
-
 data CategorySet = A | B | C | D deriving (Eq, Show)
 
 instance Arbitrary CategorySet where
   arbitrary = elements [ A, B, C, D ]
 
-instance Arbitrary a => Arbitrary (Join (,) a) where
-  arbitrary = both <$> arbitrary <*> arbitrary
-  shrink b = both <$> shrink (fst b) <*> shrink (snd b)
-
-instance (Arbitrary a, Arbitrary b) => Arbitrary (These a b) where
-  arbitrary = oneof [ This <$> arbitrary
-                    , That <$> arbitrary
-                    , These <$> arbitrary <*> arbitrary ]
-  shrink = these (fmap This . shrink) (fmap That . shrink) (\ a b -> (This <$> shrink a) ++ (That <$> shrink b) ++ (These <$> shrink a <*> shrink b))
-
-instance Arbitrary a => Arbitrary (Join These a) where
-  arbitrary = Join <$> arbitrary
-  shrink (Join a) = Join <$> shrink a
-
-instance Arbitrary a => Arbitrary (Patch a) where
-  arbitrary = oneof [
-    Insert <$> arbitrary,
-    Delete <$> arbitrary,
-    Replace <$> arbitrary <*> arbitrary ]
-
 instance Arbitrary a => Arbitrary (Source a) where
   arbitrary = Source.fromList <$> arbitrary
-
-arbitraryLeaf :: Gen (Source Char, Info, Syntax (Source Char) f)
-arbitraryLeaf = toTuple <$> arbitrary
-  where toTuple string = (string, Info (Range 0 $ length string) StringLiteral 1 0, Leaf string)

test/TermSpec.hs

@@ -1,26 +1,36 @@
 module TermSpec where
 
+import ArbitraryTerm
+import Data.String
+import Data.Text.Arbitrary ()
+import Diff
+import Diff.Arbitrary
+import Interpreter
+import Prologue
+import Term.Arbitrary
 import Test.Hspec
 import Test.Hspec.QuickCheck
-import Data.Text.Arbitrary ()
-
-import Prologue
-import Data.String
-import Interpreter
-import Diff
-import ArbitraryTerm
+import Test.QuickCheck
 
 spec :: Spec
 spec = parallel $ do
   describe "Term" $ do
     prop "equality is reflexive" $
-      \ a -> unTerm a == unTerm (a :: ArbitraryTerm String ())
+      \ a -> toTerm a == toTerm (a :: ArbitraryTerm String ())
+
+  describe "ArbitraryTerm" $
+    prop "generates terms of a specific size" $ forAll ((arbitrary >>= \ n -> (,) n <$> termOfSize n) `suchThat` ((> 0) . fst)) $
+      \ (n, term) -> arbitraryTermSize (term :: ArbitraryTerm String ()) `shouldBe` n
+
+  describe "ArbitraryDiff" $
+    prop "generates diffs of a specific size" $ forAll ((arbitrary >>= \ n -> (,) n <$> diffOfSize n) `suchThat` ((> 0) . fst)) $
+      \ (n, diff) -> arbitraryDiffSize (diff :: ArbitraryDiff String ()) `shouldBe` n
 
   describe "Diff" $ do
     prop "equality is reflexive" $
-      \ a b -> let diff = diffTerms (free . Free) ((==) `on` extract) diffCost (unTerm a) (unTerm (b :: ArbitraryTerm String CategorySet)) in
+      \ a b -> let diff = diffTerms (free . Free) (==) diffCost (toTerm a) (toTerm (b :: ArbitraryTerm String CategorySet)) in
         diff == diff
 
     prop "equal terms produce identity diffs" $
-      \ a -> let term = unTerm (a :: ArbitraryTerm String CategorySet) in
-        diffCost (diffTerms (free . Free) ((==) `on` extract) diffCost term term) == 0
+      \ a -> let term = toTerm (a :: ArbitraryTerm String CategorySet) in
+        diffCost (diffTerms (free . Free) (==) diffCost term term) == 0