github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-02 20:41:38 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into more-go-terms

Browse Source
This commit is contained in:
joshvera 2017-01-18 11:14:03 -05:00
commit 8e88838495
27 changed files with 597 additions and 453 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
bench/Main.hs
View File

@ -1,50 +1,43 @@
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, FlexibleInstances, StandaloneDeriving #-}
{-# LANGUAGE DeriveAnyClass, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
import Arguments
import Criterion.Main
import Data.Function
import Data.List (genericLength)
import Data.String
import Patch
import Prologue
import SES
import Test.QuickCheck hiding (Fixed)
import Arguments
import SemanticDiff (fetchDiffs)
import qualified Renderer as R
import SemanticDiff (fetchDiffs)
import qualified SemanticDiffPar
import SES
import System.Directory (makeAbsolute)
main :: IO ()
main = do
benchmarks <- sequenceA [ generativeBenchmarkWith "ses" 10 arbitrarySESInputs (uncurry ((*) `on` length)) (nf (uncurry benchmarkSES)) ]
defaultMain (syncAsyncBenchmark : benchmarks)
where arbitrarySESInputs = (,) <$> sized (`vectorOf` arbitrary) <*> sized (`vectorOf` arbitrary)
main = defaultMain
[ bgroup "ses"
[ bench "0,0" (nf (uncurry benchmarkSES) ([], []))
, bench "1,1, =" (nf (uncurry benchmarkSES) ([lower], [lower]))
, bench "1,1, ≠" (nf (uncurry benchmarkSES) ([lower], [upper]))
, bench "10,10, =" (nf (uncurry benchmarkSES) (replicate 10 lower, replicate 10 lower))
, bench "10,10, ≠" (nf (uncurry benchmarkSES) (replicate 10 lower, replicate 10 upper))
, bench "100,100, =" (nf (uncurry benchmarkSES) (replicate 100 lower, replicate 100 lower))
, bench "100,100, ≠" (nf (uncurry benchmarkSES) (replicate 100 lower, replicate 100 upper))
]
, syncAsyncBenchmark
]
where lower = ['a'..'z']
upper = ['A'..'Z']
benchmarkSES :: [String] -> [String] -> [Either String (Patch String)]
benchmarkSES as bs = ses compare cost as bs
benchmarkSES = ses compare cost
where compare a b = if a == b then Just (Left a) else Nothing
cost = either (const 0) (sum . fmap genericLength)
instance NFData a => NFData (Patch a)
-- | 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 = generativeBenchmarkWith name n arbitrary metric benchmark
generativeBenchmarkWith :: (Show m, Ord m) => String -> Int -> Gen a -> (a -> m) -> (a -> Benchmarkable) -> IO Benchmark
generativeBenchmarkWith name n generator metric benchmark = do
benchmarks <- traverse measure (take n [0,(defaultSize `div` n)..defaultSize])
pure $! bgroup name (snd <$> (sortOn fst benchmarks))
where measure n = do
input <- generate (resize n generator)
let measurement = metric input
pure $! (measurement, bench (show measurement) (benchmark input))
defaultSize = 100
syncAsyncBenchmark :: Benchmark
syncAsyncBenchmark =
bgroup "async vs par" [

16
semantic-diff.cabal
View File

@ -18,14 +18,14 @@ library
, Arguments
, Category
, Data.Align.Generic
, Data.Bifunctor.Join.Arbitrary
, Data.Functor.Both
, Data.Functor.Listable
, Data.Mergeable
, Data.Mergeable.Generic
, Data.RandomWalkSimilarity
, Data.Record
, Data.Text.Listable
, Diff
, Diff.Arbitrary
, Diffing
, DiffSummary
, Info
@ -39,7 +39,6 @@ library
, Parse
, Parser
, Patch
, Patch.Arbitrary
, Paths_semantic_diff
, Prologue
, Range
@ -56,7 +55,6 @@ library
, SplitDiff
, Syntax
, Term
, Term.Arbitrary
, TreeSitter
, FDoc.Term
, FDoc.RecursionSchemes
@ -81,14 +79,13 @@ library
, gitrev
, hashable
, kdt
, leancheck
, MonadRandom
, mtl
, optparse-applicative
, pointed
, protolude
, QuickCheck >= 2.8.1
, quickcheck-instances
, quickcheck-text
, recursion-schemes
, regex-compat
, semigroups
@ -144,9 +141,9 @@ benchmark semantic-diff-bench
build-depends: base
, criterion
, directory
, leancheck
, monad-par
, mtl
, QuickCheck >= 2.8.1
, semantic-diff
, text >= 1.2.1.3
ghc-options: -threaded -rtsopts -with-rtsopts=-N -j -O2 -static -pgml=script/g++
@ -168,17 +165,18 @@ test-suite test
, RangeSpec
, Source.Spec
, TermSpec
, Test.Hspec.LeanCheck
build-depends: base
, bifunctors
, deepseq
, filepath
, Glob
, hspec >= 2.1.10
, hspec-core
, hspec-expectations-pretty-diff
, leancheck
, mtl
, protolude
, QuickCheck >= 2.8.1
, quickcheck-text
, recursion-schemes >= 4.1
, semantic-diff
, text >= 1.2.1.3

225
src/Category.hs
View File

@ -3,9 +3,9 @@
module Category where
import Prologue
import Test.QuickCheck hiding (Args)
import Data.Functor.Listable
import Data.Text (pack)
import Data.Text.Arbitrary()
import Data.Text.Listable
-- | A standardized category of AST node. Used to determine the semantics for
-- | semantic diffing and define comparability of nodes.
@ -227,108 +227,119 @@ instance Hashable Category
instance (StringConv Category Text) where
strConv _ = pack . show
instance Arbitrary Category where
arbitrary = oneof [
pure Program
, pure Error
, pure Boolean
, pure BooleanOperator
, pure MathOperator
, pure DictionaryLiteral
, pure Pair
, pure FunctionCall
, pure Function
, pure Identifier
, pure Params
, pure ExpressionStatements
, pure MethodCall
, pure Args
, pure StringLiteral
, pure IntegerLiteral
, pure NumberLiteral
, pure FloatLiteral
, pure Regex
, pure Return
, pure SymbolLiteral
, pure TemplateString
, pure ArrayLiteral
, pure Assignment
, pure MathAssignment
, pure MemberAccess
, pure SubscriptAccess
, pure VarAssignment
, pure VarDecl
, pure For
, pure DoWhile
, pure While
, pure Switch
, pure Ternary
, pure Case
, pure Operator
, pure Object
, pure Throw
, pure Constructor
, pure Try
, pure Catch
, pure Finally
, pure Class
, pure Method
, pure Module
, pure Import
, pure Export
, pure Interpolation
, pure Subshell
, pure OperatorAssignment
, pure Yield
, pure Until
, pure Unless
, pure Begin
, pure Else
, pure Elsif
, pure Ensure
, pure Rescue
, pure RescueModifier
, pure RescuedException
, pure RescueArgs
, pure When
, pure Negate
, pure Select
, pure Defer
, pure Go
, pure Slice
, pure TypeAssertion
, pure TypeConversion
, pure ArgumentPair
, pure KeywordParameter
, pure OptionalParameter
, pure SplatParameter
, pure HashSplatParameter
, pure BlockParameter
, pure ArrayTy
, pure DictionaryTy
, pure Break
, pure Continue
, pure Binary
, pure Unary
, pure Constant
, pure Superclass
, pure SingletonClass
, pure ParameterDecl
, pure Default
, pure TypeDecl
, pure PointerTy
, pure FieldDecl
, pure SliceTy
, pure Element
, pure IndexExpression
, pure FunctionTy
, pure IncrementStatement
, pure DecrementStatement
, pure QualifiedIdentifier
, pure FieldDeclarations
, pure RuneLiteral
, Other <$> arbitrary
]
shrink (Other s) = Other <$> shrink s
shrink _ = []
instance Listable Category where
tiers
= cons0 Program
\/ cons0 Error
\/ cons0 Boolean
\/ cons0 BooleanOperator
\/ cons0 MathOperator
\/ cons0 DictionaryLiteral
\/ cons0 Pair
\/ cons0 FunctionCall
\/ cons0 Function
\/ cons0 Identifier
\/ cons0 Params
\/ cons0 ExpressionStatements
\/ cons0 MethodCall
\/ cons0 Args
\/ cons0 StringLiteral
\/ cons0 IntegerLiteral
\/ cons0 NumberLiteral
\/ cons0 Regex
\/ cons0 Return
\/ cons0 SymbolLiteral
\/ cons0 TemplateString
\/ cons0 ArrayLiteral
\/ cons0 Assignment
\/ cons0 MathAssignment
\/ cons0 MemberAccess
\/ cons0 SubscriptAccess
\/ cons0 VarAssignment
\/ cons0 VarDecl
\/ cons0 For
\/ cons0 DoWhile
\/ cons0 While
\/ cons0 Switch
\/ cons0 If
\/ cons0 Ternary
\/ cons0 Case
\/ cons0 Operator
\/ cons0 CommaOperator
\/ cons0 Object
\/ cons0 Throw
\/ cons0 Constructor
\/ cons0 Try
\/ cons0 Catch
\/ cons0 Finally
\/ cons0 Class
\/ cons0 Method
\/ cons0 Comment
\/ cons0 RelationalOperator
\/ cons0 Empty
\/ cons0 Module
\/ cons0 Import
\/ cons0 Export
\/ cons0 AnonymousFunction
\/ cons0 Interpolation
\/ cons0 Subshell
\/ cons0 OperatorAssignment
\/ cons0 Yield
\/ cons0 Until
\/ cons0 Unless
\/ cons0 Begin
\/ cons0 Else
\/ cons0 Elsif
\/ cons0 Ensure
\/ cons0 Rescue
\/ cons0 RescueModifier
\/ cons0 RescuedException
\/ cons0 RescueArgs
\/ cons0 When
\/ cons0 Negate
\/ cons0 Select
\/ cons0 Defer
\/ cons0 Go
\/ cons0 Slice
\/ cons0 TypeAssertion
\/ cons0 TypeConversion
\/ cons0 ArgumentPair
\/ cons0 KeywordParameter
\/ cons0 OptionalParameter
\/ cons0 SplatParameter
\/ cons0 HashSplatParameter
\/ cons0 BlockParameter
\/ cons0 FloatLiteral
\/ cons0 ArrayTy
\/ cons0 DictionaryTy
\/ cons0 StructTy
\/ cons0 Struct
\/ cons0 Break
\/ cons0 Continue
\/ cons0 Binary
\/ cons0 Unary
\/ cons0 Constant
\/ cons0 Superclass
\/ cons0 SingletonClass
\/ cons0 RangeExpression
\/ cons0 ScopeOperator
\/ cons0 BeginBlock
\/ cons0 EndBlock
\/ cons0 ParameterDecl
\/ cons0 Default
\/ cons0 TypeDecl
\/ cons0 PointerTy
\/ cons0 FieldDecl
\/ cons0 SliceTy
\/ cons0 Element
\/ cons0 Literal
\/ cons0 ChannelTy
\/ cons0 Send
\/ cons0 IndexExpression
\/ cons0 FunctionTy
\/ cons0 IncrementStatement
\/ cons0 DecrementStatement
\/ cons0 QualifiedIdentifier
\/ cons0 FieldDeclarations
\/ cons0 RuneLiteral
\/ cons1 (Other . unListableText)

16
src/Data/Bifunctor/Join/Arbitrary.hs
View File

@ -1,16 +0,0 @@
{-# 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 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)

127
src/Data/Functor/Listable.hs Normal file
View File

@ -0,0 +1,127 @@
module Data.Functor.Listable
( Listable(..)
, mapT
, cons0
, cons1
, cons2
, cons3
, cons4
, cons5
, cons6
, (\/)
, Tier
, Listable1(..)
, tiers1
, Listable2(..)
, tiers2
, liftCons1
, liftCons2
, liftCons3
, liftCons4
, ListableF(..)
) where
import Data.Bifunctor.Join
import Data.These
import Prologue
import Test.LeanCheck
type Tier a = [a]
-- | Lifting of 'Listable' to @* -> *@.
class Listable1 l where
-- | The tiers for @l :: * -> *@, parameterized by the tiers for @a :: *@.
liftTiers :: [Tier a] -> [Tier (l a)]
-- | A suitable definition of 'tiers' for 'Listable1' type constructors parameterized by 'Listable' types.
tiers1 :: (Listable a, Listable1 l) => [Tier (l a)]
tiers1 = liftTiers tiers
-- | Lifting of 'Listable' to @* -> * -> *@.
class Listable2 l where
-- | The tiers for @l :: * -> * -> *@, parameterized by the tiers for @a :: *@ & @b :: *@.
liftTiers2 :: [Tier a] -> [Tier b] -> [Tier (l a b)]
-- | A suitable definition of 'tiers' for 'Listable2' type constructors parameterized by 'Listable' types.
tiers2 :: (Listable a, Listable b, Listable2 l) => [Tier (l a b)]
tiers2 = liftTiers2 tiers tiers
-- | Lifts a unary constructor to a list of tiers, given a list of tiers for its argument.
--
-- Commonly used in the definition of 'Listable1' and 'Listable2' instances.
liftCons1 :: [Tier a] -> (a -> b) -> [Tier b]
liftCons1 tiers f = mapT f tiers `addWeight` 1
-- | Lifts a binary constructor to a list of tiers, given lists of tiers for its arguments.
--
-- Commonly used in the definition of 'Listable1' and 'Listable2' instances.
liftCons2 :: [Tier a] -> [Tier b] -> (a -> b -> c) -> [Tier c]
liftCons2 tiers1 tiers2 f = mapT (uncurry f) (productWith (,) tiers1 tiers2) `addWeight` 1
-- | Lifts a ternary constructor to a list of tiers, given lists of tiers for its arguments.
--
-- Commonly used in the definition of 'Listable1' and 'Listable2' instances.
liftCons3 :: [Tier a] -> [Tier b] -> [Tier c] -> (a -> b -> c -> d) -> [Tier d]
liftCons3 tiers1 tiers2 tiers3 f = mapT (uncurry3 f) (productWith (\ x (y, z) -> (x, y, z)) tiers1 (liftCons2 tiers2 tiers3 (,)) ) `addWeight` 1
where uncurry3 f (a, b, c) = f a b c
-- | Lifts a quaternary constructor to a list of tiers, given lists of tiers for its arguments.
--
-- Commonly used in the definition of 'Listable1' and 'Listable2' instances.
liftCons4 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier d] -> (a -> b -> c -> d -> e) -> [Tier e]
liftCons4 tiers1 tiers2 tiers3 tiers4 f = mapT (uncurry4 f) (productWith (\ x (y, z, w) -> (x, y, z, w)) tiers1 (liftCons3 tiers2 tiers3 tiers4 (,,)) ) `addWeight` 1
where uncurry4 f (a, b, c, d) = f a b c d
-- | Convenient wrapper for 'Listable1' type constructors and 'Listable' types, where a 'Listable' instance would necessarily be orphaned.
newtype ListableF f a = ListableF { unListableF :: f a }
deriving Show
-- Instances
instance Listable1 Maybe where
liftTiers tiers = cons0 Nothing \/ liftCons1 tiers Just
instance Listable2 (,) where
liftTiers2 = productWith (,)
instance Listable2 Either where
liftTiers2 leftTiers rightTiers = liftCons1 leftTiers Left \/ liftCons1 rightTiers Right
instance Listable a => Listable1 ((,) a) where
liftTiers = liftTiers2 tiers
instance Listable1 [] where
liftTiers tiers = go
where go = cons0 [] \/ liftCons2 tiers go (:)
instance Listable2 p => Listable1 (Join p) where
liftTiers tiers = liftCons1 (liftTiers2 tiers tiers) Join
instance Listable2 These where
liftTiers2 this that = liftCons1 this This \/ liftCons1 that That \/ liftCons2 this that These
instance Listable1 f => Listable2 (CofreeF f) where
liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<)
instance (Listable1 f, Listable a) => Listable1 (CofreeF f a) where
liftTiers = liftTiers2 tiers
instance Listable1 f => Listable1 (Cofree f) where
liftTiers annotationTiers = go
where go = liftCons1 (liftTiers2 annotationTiers go) cofree
instance Listable1 f => Listable2 (FreeF f) where
liftTiers2 pureTiers recurTiers = liftCons1 pureTiers Pure \/ liftCons1 (liftTiers recurTiers) Free
instance (Listable1 f, Listable a) => Listable1 (FreeF f a) where
liftTiers = liftTiers2 tiers
instance Listable1 f => Listable1 (Free f) where
liftTiers pureTiers = go
where go = liftCons1 (liftTiers2 pureTiers go) free
instance (Listable1 f, Listable a) => Listable (ListableF f a) where
tiers = ListableF `mapT` tiers1

27
src/Data/RandomWalkSimilarity.hs
View File

@ -18,23 +18,23 @@ module Data.RandomWalkSimilarity
import Control.Applicative
import Control.Monad.Random
import Control.Monad.State
import Data.Align.Generic
import Data.Functor.Both hiding (fst, snd)
import Data.Functor.Listable
import Data.Hashable
import qualified Data.IntMap as IntMap
import qualified Data.KdTree.Static as KdTree
import Data.Semigroup (Min(..), Option(..))
import Data.Record
import Data.Semigroup (Min(..), Option(..))
import Data.These
import qualified Data.Vector as Vector
import Diff
import Info
import Patch
import Prologue as P
import Term (termSize, zipTerms, Term, TermF)
import Test.QuickCheck hiding (Fixed)
import Test.QuickCheck.Random
import qualified SES
import Info
import Data.Align.Generic
import Data.These
import Diff
import Term (termSize, zipTerms, Term, TermF)
import Test.QuickCheck.Random (mkQCGen)
type Label f fields label = forall b. TermF f (Record fields) b -> label
type DiffTerms f fields = Term f (Record fields) -> Term f (Record fields) -> Maybe (Diff f (Record fields))
@ -300,11 +300,8 @@ instance Hashable label => Hashable (Gram label) where
hashWithSalt _ = hash
hash gram = hash (stem gram <> base gram)
-- | Construct a generator for arbitrary `Gram`s of size `(p, q)`.
gramWithPQ :: Arbitrary label => Int -> Int -> Gen (Gram label)
gramWithPQ p q = Gram <$> vectorOf p arbitrary <*> vectorOf q arbitrary
instance Listable1 Gram where
liftTiers tiers = liftCons2 (liftTiers (liftTiers tiers)) (liftTiers (liftTiers tiers)) Gram
instance Arbitrary label => Arbitrary (Gram label) where
arbitrary = join $ gramWithPQ <$> arbitrary <*> arbitrary
shrink (Gram a b) = Gram <$> shrink a <*> shrink b
instance Listable a => Listable (Gram a) where
tiers = tiers1

36
src/Data/Record.hs
View File

@ -1,15 +1,14 @@
{-# LANGUAGE DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeOperators, ConstraintKinds #-}
module Data.Record where
import GHC.Show
import Prologue
import Test.QuickCheck
import Category
import Range
import SourceSpan
import Data.Aeson
import Data.Aeson.Types
import Data.Functor.Listable
import GHC.Show
import Prologue
import Range
import SourceSpan
-- | A type alias for HasField constraints commonly used throughout semantic-diff.
type DefaultFields fields = (HasField fields Category, HasField fields Range, HasField fields SourceSpan)
@ -63,12 +62,21 @@ instance (Show h, Show (Record t)) => Show (Record (h ': t)) where
instance Show (Record '[]) where
showsPrec n RNil = showParen (n > 0) ("RNil" <>)
instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (Record (a ': b ': c ': d ': '[])) where
toJSON (RCons a (RCons b (RCons c (RCons d RNil)))) = toJSONList [toJSON a, toJSON b, toJSON c, toJSON d]
instance (ToJSON h, ToJSONList (Record t)) => ToJSON (Record (h ': t)) where
toJSON r = toJSONList (toJSONValues r)
instance ToJSON (Record '[]) where
toJSON _ = emptyArray
class ToJSONList t where
toJSONValues :: t -> [Value]
instance (ToJSON h, ToJSONList (Record t)) => ToJSONList (Record (h ': t)) where
toJSONValues (RCons h t) = toJSON h : toJSONValues t
instance ToJSONList (Record '[]) where
toJSONValues _ = []
instance (Eq h, Eq (Record t)) => Eq (Record (h ': t)) where
RCons h1 t1 == RCons h2 t2 = h1 == h2 && t1 == t2
@ -85,12 +93,8 @@ instance Ord (Record '[]) where
_ `compare` _ = EQ
instance (Arbitrary field, Arbitrary (Record fields)) => Arbitrary (Record (field ': fields)) where
arbitrary = RCons <$> arbitrary <*> arbitrary
instance (Listable head, Listable (Record tail)) => Listable (Record (head ': tail)) where
tiers = cons2 RCons
shrink (RCons h t) = RCons <$> shrink h <*> shrink t
instance Arbitrary (Record '[]) where
arbitrary = pure RNil
shrink _ = []
instance Listable (Record '[]) where
tiers = cons0 RNil

10
src/Data/Text/Listable.hs Normal file
View File

@ -0,0 +1,10 @@
module Data.Text.Listable where
import Data.Functor.Listable
import Data.Text
import Prologue
newtype ListableText = ListableText { unListableText :: Text }
instance Listable ListableText where
tiers = cons1 (ListableText . pack)

55
src/Diff/Arbitrary.hs
View File

@ -1,55 +0,0 @@
module Diff.Arbitrary where
import Diff
import Term
import Data.Bifunctor.Join
import Data.Bifunctor.Join.Arbitrary ()
import Data.Functor.Both
import Data.Functor.Foldable (unfold)
import Patch
import Patch.Arbitrary ()
import Syntax
import Prologue
import Term.Arbitrary
import Test.QuickCheck hiding (Fixed)
data ArbitraryDiff leaf annotation
= ArbitraryFree (Join (,) annotation) (Syntax leaf (ArbitraryDiff leaf annotation))
| ArbitraryPure (Patch (ArbitraryTerm leaf annotation))
deriving (Show, Eq, Generic)
unArbitraryDiff :: ArbitraryDiff leaf annotation -> FreeF (TermF (Syntax leaf) (Both annotation)) (Patch (ArbitraryTerm leaf annotation)) (ArbitraryDiff leaf annotation)
unArbitraryDiff (ArbitraryFree a s) = Free (a :< s)
unArbitraryDiff (ArbitraryPure p) = Pure p
toDiff :: ArbitraryDiff leaf annotation -> Diff (Syntax leaf) annotation
toDiff = fmap (fmap toTerm) . unfold unArbitraryDiff
diffOfSize :: (Arbitrary leaf, Arbitrary annotation) => Int -> Gen (ArbitraryDiff leaf annotation)
diffOfSize n
| n <= 0 = ArbitraryFree <$> arbitrary <*> syntaxOfSize diffOfSize n
| otherwise = oneof
[ ArbitraryFree <$> arbitrary <*> syntaxOfSize diffOfSize n
, ArbitraryPure <$> patchOfSize n ]
where 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 = genericShrink

32
src/DiffSummary.hs
View File

@ -13,9 +13,9 @@ import Syntax as S
import Category as C
import Data.Functor.Both hiding (fst, snd)
import qualified Data.Functor.Both as Both
import Data.Functor.Listable
import qualified Data.Text as Text
import Test.QuickCheck hiding (Fixed)
import Patch.Arbitrary()
import Data.Text.Listable
import Data.Record
import Data.These
import Text.PrettyPrint.Leijen.Text ((<+>), squotes, space, string, Doc, punctuate, pretty, hsep)
@ -93,7 +93,7 @@ data DiffSummary a = DiffSummary {
} deriving (Eq, Functor, Show, Generic)
-- Returns a list of diff summary texts given two source blobs and a diff.
diffSummaries :: (HasCategory leaf, DefaultFields fields) => Both SourceBlob -> SyntaxDiff leaf fields -> [JSONSummary Text SourceSpans]
diffSummaries :: (StringConv leaf Text, DefaultFields fields) => Both SourceBlob -> SyntaxDiff leaf fields -> [JSONSummary Text SourceSpans]
diffSummaries blobs diff = summaryToTexts =<< diffToDiffSummaries (source <$> blobs) diff
-- Takes a 'DiffSummary DiffInfo' and returns a list of JSON Summaries whose text summaries represent the LeafInfo summaries of the 'DiffSummary'.
@ -103,7 +103,7 @@ summaryToTexts DiffSummary{..} = appendParentContexts <$> summaries patch
jsonSummary { summary = show $ summary jsonSummary <+> parentContexts parentAnnotation }
-- Returns a list of 'DiffSummary' given two source blobs and a diff.
diffToDiffSummaries :: (HasCategory leaf, DefaultFields fields) => Both (Source Char) -> SyntaxDiff leaf fields -> [DiffSummary DiffInfo]
diffToDiffSummaries :: (StringConv leaf Text, DefaultFields fields) => Both (Source Char) -> SyntaxDiff leaf fields -> [DiffSummary DiffInfo]
diffToDiffSummaries sources = para $ \diff ->
let
diff' = free (Prologue.fst <$> diff)
@ -183,7 +183,7 @@ toLeafInfos LeafInfo{..} = pure $ JSONSummary (summary leafCategory termName) so
vowels = Text.singleton <$> ("aeiouAEIOU" :: [Char])
-- Returns a text representing a specific term given a source and a term.
toTermName :: forall leaf fields. (HasCategory leaf, DefaultFields fields) => Source Char -> SyntaxTerm leaf fields -> Text
toTermName :: forall leaf fields. (StringConv leaf Text, DefaultFields fields) => Source Char -> SyntaxTerm leaf fields -> Text
toTermName source term = case unwrap term of
S.Send _ _ -> termNameFromSource term
S.Ty _ -> termNameFromSource term
@ -195,7 +195,7 @@ toTermName source term = case unwrap term of
S.AnonymousFunction params _ -> "anonymous" <> paramsToArgNames params
S.Fixed children -> termNameFromChildren term children
S.Indexed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children
Leaf leaf -> toCategoryName leaf
Leaf leaf -> toS leaf
S.Assignment identifier _ -> toTermName' identifier
S.Function identifier _ _ -> toTermName' identifier
S.ParameterDecl _ _ -> termNameFromSource term
@ -249,7 +249,7 @@ toTermName source term = case unwrap term of
S.Array ty _ -> maybe (termNameFromSource term) termNameFromSource ty
S.Class identifier _ _ -> toTermName' identifier
S.Method identifier args _ -> toTermName' identifier <> paramsToArgNames args
S.Comment a -> toCategoryName a
S.Comment a -> toS a
S.Commented _ _ -> termNameFromChildren term (toList $ unwrap term)
S.Module identifier _ -> toTermName' identifier
S.Import identifier [] -> termNameFromSource identifier
@ -319,7 +319,7 @@ parentContexts contexts = hsep $ either identifiableDoc annotatableDoc <$> conte
toDoc :: Text -> Doc
toDoc = string . toS
termToDiffInfo :: (HasCategory leaf, DefaultFields fields) => Source Char -> SyntaxTerm leaf fields -> DiffInfo
termToDiffInfo :: (StringConv leaf Text, DefaultFields fields) => Source Char -> SyntaxTerm leaf fields -> DiffInfo
termToDiffInfo blob term = case unwrap term of
S.Indexed children -> BranchInfo (termToDiffInfo' <$> children) (category $ extract term) BIndexed
S.Fixed children -> BranchInfo (termToDiffInfo' <$> children) (category $ extract term) BFixed
@ -336,7 +336,7 @@ termToDiffInfo blob term = case unwrap term of
-- | For a DiffSummary without a parentAnnotation, we append a parentAnnotation with the first identifiable term.
-- | For a DiffSummary with a parentAnnotation, we append the next annotatable term to the extant parentAnnotation.
-- | If a DiffSummary already has a parentAnnotation, and a (grand) parentAnnotation, then we return the summary without modification.
appendSummary :: (HasCategory leaf, DefaultFields fields) => Source Char -> SyntaxTerm leaf fields -> DiffSummary DiffInfo -> DiffSummary DiffInfo
appendSummary :: (StringConv leaf Text, DefaultFields fields) => Source Char -> SyntaxTerm leaf fields -> DiffSummary DiffInfo -> DiffSummary DiffInfo
appendSummary source term summary =
case (parentAnnotation summary, identifiable term, annotatable term) of
([], Identifiable _, _) -> appendParentAnnotation Left
@ -481,13 +481,15 @@ instance HasCategory Category where
instance HasField fields Category => HasCategory (SyntaxTerm leaf fields) where
toCategoryName = toCategoryName . category . extract
instance Arbitrary Branch where
arbitrary = oneof [ pure BIndexed, pure BFixed ]
shrink = genericShrink
instance Listable Branch where
tiers = cons0 BIndexed \/ cons0 BFixed \/ cons0 BCommented \/ cons0 BIf
instance Arbitrary a => Arbitrary (DiffSummary a) where
arbitrary = DiffSummary <$> arbitrary <*> arbitrary
shrink = genericShrink
instance Listable1 DiffSummary where
liftTiers termTiers = liftCons2 (liftTiers termTiers) (liftTiers (eitherTiers (liftTiers (mapT unListableText tiers)))) DiffSummary
where eitherTiers tiers = liftTiers2 tiers tiers
instance Listable a => Listable (DiffSummary a) where
tiers = tiers1
instance P.Pretty DiffInfo where
pretty LeafInfo{..} = squotes (string $ toSL termName) <+> string (toSL (toCategoryName leafCategory))

8
src/Info.hs
View File

@ -1,12 +1,12 @@
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-}
module Info (Range(..), characterRange, setCharacterRange, Category(..), category, setCategory, Cost(..), cost, setCost, SourceSpan(..), SourcePos(..), SourceSpans(..), SourceText(..), sourceText) where
import Data.Functor.Listable
import Data.Record
import Prologue
import Category
import Range
import SourceSpan
import Test.QuickCheck
import Data.Aeson
newtype Cost = Cost { unCost :: Int }
@ -39,7 +39,5 @@ setCost = setField
-- Instances
instance Arbitrary Cost where
arbitrary = Cost <$> arbitrary
shrink = fmap Cost . shrink . unCost
instance Listable Cost where
tiers = cons1 Cost

10
src/Patch.hs
View File

@ -13,6 +13,7 @@ module Patch
, mapPatch
) where
import Data.Functor.Listable
import Data.These
import Prologue
@ -69,3 +70,12 @@ maybeFst = these Just (const Nothing) ((Just .) . const)
-- | Return Just the value in That, or the second value in These, if any.
maybeSnd :: These a b -> Maybe b
maybeSnd = these (const Nothing) Just ((Just .) . flip const)
-- Instances
instance Listable1 Patch where
liftTiers t = liftCons1 t Insert \/ liftCons1 t Delete \/ liftCons2 t t Replace
instance Listable a => Listable (Patch a) where
tiers = tiers1

18
src/Patch/Arbitrary.hs
View File

@ -1,18 +0,0 @@
{-# 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

9
src/Range.hs
View File

@ -5,8 +5,7 @@ import Data.List (span)
import Data.Semigroup
import Data.String
import Prologue
import Test.QuickCheck
import Test.LeanCheck
-- | A half-open interval of integers, defined by start & end indices.
data Range = Range { start :: Int, end :: Int }
@ -82,7 +81,5 @@ instance Semigroup Range where
instance Ord Range where
a <= b = start a <= start b
instance Arbitrary Range where
arbitrary = Range <$> arbitrary <*> arbitrary
shrink s = Range <$> shrink (start s) <*> shrink (end s)
instance Listable Range where
tiers = cons2 Range

17
src/SourceSpan.hs
View File

@ -6,13 +6,12 @@
--
module SourceSpan where
import Prologue
import Data.Aeson ((.=), (.:))
import qualified Data.Aeson as A
import Test.QuickCheck
import Data.These
import Data.Text.Arbitrary()
import Data.Semigroup
import Data.These
import Prologue
import Test.LeanCheck
-- |
-- Source position information
@ -99,10 +98,8 @@ instance A.ToJSON SourceSpans where
(That span) -> A.pairs $ "insert" .= span
(These span1 span2) -> A.pairs $ "replace" .= (span1, span2)
instance Arbitrary SourcePos where
arbitrary = SourcePos <$> arbitrary <*> arbitrary
shrink = genericShrink
instance Listable SourcePos where
tiers = cons2 SourcePos
instance Arbitrary SourceSpan where
arbitrary = SourceSpan <$> arbitrary <*> arbitrary
shrink = genericShrink
instance Listable SourceSpan where
tiers = cons2 SourceSpan

80
src/Syntax.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE DeriveAnyClass #-}
module Syntax where
import Prologue
import Data.Aeson
import Data.Functor.Listable
import Data.Mergeable
import GHC.Generics
import Test.QuickCheck hiding (Fixed)
import Data.Aeson
import Prologue
-- | A node in an abstract syntax tree.
--
@ -109,21 +109,63 @@ data Syntax a f
-- Instances
instance (Arbitrary leaf, Arbitrary f) => Arbitrary (Syntax leaf f) where
arbitrary = sized (syntaxOfSize (`resize` arbitrary) )
instance Listable2 Syntax where
liftTiers2 leaf recur
= liftCons1 leaf Leaf
\/ liftCons1 (liftTiers recur) Indexed
\/ liftCons1 (liftTiers recur) Fixed
\/ liftCons2 recur (liftTiers recur) FunctionCall
\/ liftCons2 recur (liftTiers recur) Ternary
\/ liftCons2 (liftTiers recur) (liftTiers recur) AnonymousFunction
\/ liftCons3 recur (liftTiers recur) (liftTiers recur) Function
\/ liftCons2 recur recur Assignment
\/ liftCons2 recur recur OperatorAssignment
\/ liftCons2 recur recur MemberAccess
\/ liftCons3 recur recur (liftTiers recur) MethodCall
\/ liftCons1 (liftTiers recur) Operator
\/ liftCons2 recur (liftTiers recur) VarDecl
\/ liftCons2 recur recur VarAssignment
\/ liftCons2 recur recur SubscriptAccess
\/ liftCons2 (liftTiers recur) (liftTiers recur) Switch
\/ liftCons2 recur (liftTiers recur) Case
\/ liftCons1 (liftTiers recur) Select
\/ liftCons2 (liftTiers recur) (liftTiers recur) Syntax.Object
\/ liftCons2 recur recur Pair
\/ liftCons1 leaf Comment
\/ liftCons2 (liftTiers recur) (liftTiers recur) Commented
\/ liftCons1 (liftTiers recur) Syntax.Error
\/ liftCons2 (liftTiers recur) (liftTiers recur) For
\/ liftCons2 recur recur DoWhile
\/ liftCons2 recur (liftTiers recur) While
\/ liftCons1 (liftTiers recur) Return
\/ liftCons1 recur Throw
\/ liftCons1 recur Constructor
\/ liftCons4 (liftTiers recur) (liftTiers recur) (liftTiers recur) (liftTiers recur) Try
\/ liftCons2 (liftTiers recur) (liftTiers recur) Syntax.Array
\/ liftCons3 recur (liftTiers recur) (liftTiers recur) Class
\/ liftCons3 recur (liftTiers recur) (liftTiers recur) Method
\/ liftCons2 recur (liftTiers recur) If
\/ liftCons2 recur (liftTiers recur) Module
\/ liftCons2 recur (liftTiers recur) Import
\/ liftCons2 (liftTiers recur) (liftTiers recur) Export
\/ liftCons1 (liftTiers recur) Yield
\/ liftCons1 recur Negate
\/ liftCons2 (liftTiers recur) (liftTiers recur) Rescue
\/ liftCons1 recur Go
\/ liftCons1 recur Defer
\/ liftCons2 recur recur TypeAssertion
\/ liftCons2 recur recur TypeConversion
\/ liftCons1 (liftTiers recur) Break
\/ liftCons1 (liftTiers recur) Continue
\/ liftCons1 (liftTiers recur) BlockStatement
\/ liftCons2 (liftTiers recur) recur ParameterDecl
\/ liftCons2 recur recur TypeDecl
\/ liftCons3 recur (liftTiers recur) (liftTiers recur) FieldDecl
\/ liftCons1 recur Ty
\/ liftCons2 recur recur Send
shrink = genericShrink
instance Listable leaf => Listable1 (Syntax leaf) where
liftTiers = liftTiers2 tiers
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
where branchGeneratorsOfSize n =
[ Indexed <$> childrenOfSize (pred n)
, Fixed <$> childrenOfSize (pred n)
]
childrenOfSize n | n <= 0 = pure []
childrenOfSize n = do
m <- choose (1, n)
first <- recur m
rest <- childrenOfSize (n - m)
pure $! first : rest
instance (Listable leaf, Listable recur) => Listable (Syntax leaf recur) where
tiers = tiers1

2
src/Term.hs
View File

@ -11,7 +11,7 @@ import Data.These
import Syntax
-- | A Term with an abstract syntax tree and an annotation.
type Term f annotation = Cofree f annotation
type Term f = Cofree f
type TermF = CofreeF
-- | A Term with a Syntax leaf and a record of fields.

37
src/Term/Arbitrary.hs
View File

@ -1,37 +0,0 @@
{-# LANGUAGE TypeFamilies #-}
module Term.Arbitrary where
import Data.Functor.Foldable (Base, unfold, Corecursive(embed))
import Data.Text.Arbitrary ()
import Prologue
import Syntax
import Term
import Test.QuickCheck hiding (Fixed)
data ArbitraryTerm leaf annotation = ArbitraryTerm { annotation :: annotation, syntax :: Syntax leaf (ArbitraryTerm leaf annotation)}
deriving (Show, Eq, Generic)
unArbitraryTerm :: ArbitraryTerm leaf annotation -> TermF (Syntax leaf) annotation (ArbitraryTerm leaf annotation)
unArbitraryTerm (ArbitraryTerm a s) = a :< s
toTerm :: ArbitraryTerm leaf annotation -> Term (Syntax leaf) annotation
toTerm = unfold unArbitraryTerm
termOfSize :: (Arbitrary leaf, Arbitrary annotation) => Int -> Gen (ArbitraryTerm leaf annotation)
termOfSize n = ArbitraryTerm <$> arbitrary <*> syntaxOfSize termOfSize n
arbitraryTermSize :: ArbitraryTerm leaf annotation -> Int
arbitraryTermSize = cata (succ . sum) . toTerm
-- Instances
type instance Base (ArbitraryTerm leaf annotation) = TermF (Syntax leaf) annotation
instance Corecursive (ArbitraryTerm leaf annotation) where embed (a :< s) = ArbitraryTerm a s
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 = genericShrink

41
test/AlignmentSpec.hs
View File

@ -6,13 +6,12 @@ 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.Functor.Listable
import Data.List (nub)
import Data.Monoid hiding ((<>))
import Data.Record
import Data.String
import Data.Text.Arbitrary ()
import Data.These
import Patch
import Prologue hiding (fst, snd)
@ -24,8 +23,8 @@ import Syntax
import Term
import Test.Hspec (Spec, describe, it, parallel)
import Test.Hspec.Expectations.Pretty
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Test.Hspec.LeanCheck
import Test.LeanCheck
import GHC.Show (Show(..))
spec :: Spec
@ -48,7 +47,7 @@ spec = parallel $ do
prop "covers every input line" $
\ elements -> let (_, children, ranges) = toAlignBranchInputs elements in
join <$> (traverse (modifyJoin (fromThese [] []) . fmap (pure . Prologue.fst)) (alignBranch Prologue.snd children ranges)) `shouldBe` ranges
join <$> traverse (modifyJoin (fromThese [] []) . fmap (pure . Prologue.fst)) (alignBranch Prologue.snd children ranges) `shouldBe` ranges
prop "covers every input child" $
\ elements -> let (_, children, ranges) = toAlignBranchInputs elements in
@ -195,7 +194,7 @@ spec = parallel $ do
describe "numberedRows" $ do
prop "counts only non-empty values" $
\ xs -> counts (numberedRows (xs :: [Join These Char])) `shouldBe` length . catMaybes <$> Join (unalign (runJoin <$> xs))
\ xs -> counts (numberedRows (unListableF <$> xs :: [Join These Char])) `shouldBe` length . catMaybes <$> Join (unalign (runJoin . unListableF <$> xs))
data BranchElement
= Child String (Join These String)
@ -236,23 +235,23 @@ keysOfAlignedChildren lines = lines >>= these identity identity (<>) . runJoin .
joinCrosswalk :: Bicrosswalk p => Align f => (a -> f b) -> Join p a -> f (Join p b)
joinCrosswalk f = fmap Join . bicrosswalk f f . runJoin
instance Arbitrary BranchElement where
arbitrary = oneof [ key >>= \ key -> Child key <$> joinTheseOf (contents key)
, Margin <$> joinTheseOf margin ]
where key = listOf1 (elements (['a'..'z'] <> ['A'..'Z'] <> ['0'..'9']))
contents key = wrap key <$> listOf (padding '*')
instance Listable BranchElement where
tiers = oneof [ (\ key -> Child key `mapT` joinTheseOf (contents key)) `concatMapT` key
, Margin `mapT` joinTheseOf (pure `mapT` padding '-') ]
where key = pure `mapT` [['a'..'z'] <> ['A'..'Z'] <> ['0'..'9']]
contents key = (wrap key . pure) `mapT` padding '*'
wrap key contents = "(" <> key <> contents <> ")" :: String
margin = listOf (padding '-')
padding char = frequency [ (10, pure char)
, (1, pure '\n') ]
joinTheseOf g = oneof [ Join . This <$> g
, Join . That <$> g
, (Join .) . These <$> g <*> g ]
padding :: Char -> [Tier Char]
padding char = frequency [ (10, [[char]])
, (1, [['\n']]) ]
joinTheseOf g = oneof [ (Join . This) `mapT` g
, (Join . That) `mapT` g
, productWith ((Join .) . These) g g ]
frequency :: [(Int, [Tier a])] -> [Tier a]
frequency = concatT . foldr ((\/) . pure . uncurry replicate) []
oneof :: [[[a]]] -> [[a]]
oneof = frequency . fmap ((,) 1)
shrink (Child key contents) = Child key <$> joinCrosswalk shrinkContents contents
where shrinkContents string = (++ suffix) . (prefix ++) <$> shrinkList (const []) (drop (length prefix) (take (length string - length suffix) string))
(prefix, suffix) = ('(' : key, ")" :: String)
shrink (Margin contents) = Margin <$> joinCrosswalk (shrinkList (const [])) contents
counts :: [Join These (Int, a)] -> Both Int
counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap Prologue.fst <$> numbered))

60
test/Data/Mergeable/Spec.hs
View File

@ -2,52 +2,62 @@
module Data.Mergeable.Spec where
import Data.Functor.Identity
import Data.Functor.Listable
import Data.Mergeable
import Data.String (String)
import GHC.Show
import Prologue
import Syntax
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Test.Hspec.LeanCheck
import Test.LeanCheck
spec :: Spec
spec = parallel $ do
describe "[]" $ do
let gen = scale (`div` 25) arbitrary :: Gen [Char]
withAlternativeInstances sequenceAltLaws gen
withAlternativeInstances mergeLaws gen
withAlternativeInstances sequenceAltLaws (tiers :: [Tier String])
withAlternativeInstances mergeLaws (tiers :: [Tier String])
describe "Maybe" $ do
withAlternativeInstances sequenceAltLaws (arbitrary :: Gen (Maybe Char))
withAlternativeInstances mergeLaws (arbitrary :: Gen (Maybe Char))
withAlternativeInstances sequenceAltLaws (tiers :: [Tier (Maybe Char)])
withAlternativeInstances mergeLaws (tiers :: [Tier (Maybe Char)])
describe "Identity" $ do
withAlternativeInstances sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char))
withAlternativeInstances mergeLaws (Identity <$> arbitrary :: Gen (Identity Char))
withAlternativeInstances sequenceAltLaws (Identity `mapT` tiers :: [Tier (Identity Char)])
withAlternativeInstances mergeLaws (Identity `mapT` tiers :: [Tier (Identity Char)])
describe "Syntax" $ do
withAlternativeInstances sequenceAltLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char))
withAlternativeInstances mergeLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char))
withAlternativeInstances sequenceAltLaws (tiers :: [Tier (Syntax Char Char)])
withAlternativeInstances mergeLaws (tiers :: [Tier (Syntax Char Char)])
prop "subsumes catMaybes/Just" $ do
prop "subsumes catMaybes/Just" $
\ 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 :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => [Tier (f a)] -> [Tier (Blind (a -> g a))] -> Spec
mergeLaws value function = describe "merge" $ do
prop "identity" . forAll value $
\ a -> merge pure a `shouldNotBe` (empty :: g (f a))
let pair = (,) <$> value <*> function
prop "relationship with sequenceAlt" . forAll pair $
prop "relationship with sequenceAlt" . forAll (value >< function) $
\ (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
sequenceAltLaws value function = do
describe "sequenceAlt" $ do
prop "identity" . forAll value $
\ a -> sequenceAlt (pure <$> a) `shouldNotBe` (empty :: g (f a))
sequenceAltLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => [Tier (f a)] -> [Tier (Blind (a -> g a))] -> Spec
sequenceAltLaws value function = describe "sequenceAlt" $ do
prop "identity" . forAll value $
\ 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)
prop "relationship with merge" . forAll (productWith ((Blind .) . fmap . getBlind) function value :: [Tier (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
withAlternativeInstances :: forall f a. (Listable a, Eq (f a), Show (f a)) => (forall g. (Alternative g, Eq (g (f a)), Show (g (f a))) => [Tier (f a)] -> [Tier (Blind (a -> g a))] -> Spec) -> [Tier (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)))
describe "[]" $ laws gen (fmap const `mapT` tiers :: [Tier (Blind (a -> [a]))])
describe "Maybe" $ laws gen (fmap const `mapT` tiers :: [Tier (Blind (a -> Maybe a))])
newtype Blind a = Blind { getBlind :: a }
deriving Functor
instance Listable a => Listable (Blind a) where
tiers = Blind `mapT` tiers
instance Show (Blind a) where
showsPrec _ _ = showString "*"

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

@ -1,9 +1,12 @@
{-# LANGUAGE DataKinds #-}
module Data.RandomWalkSimilarity.Spec where
import Category
import Data.Functor.Both
import Data.Functor.Listable
import Data.RandomWalkSimilarity
import Data.Record
import Data.String
import qualified Data.Vector as Vector
import Diff
import Info
@ -12,30 +15,27 @@ import Prologue
import Syntax
import Term
import Diffing (getLabel)
import Term.Arbitrary
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Test.Hspec.LeanCheck
spec :: Spec
spec = parallel $ do
let positively = succ . abs
describe "pqGramDecorator" $ do
prop "produces grams with stems of the specified length" $
\ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (toTerm term :: Term (Syntax Text) (Record '[Text])) `shouldSatisfy` all ((== positively p) . length . stem . rhead)
\ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (unListableF term :: SyntaxTerm String '[Category]) `shouldSatisfy` all ((== positively p) . length . stem . rhead)
prop "produces grams with bases of the specified width" $
\ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (toTerm term :: Term (Syntax Text) (Record '[Text])) `shouldSatisfy` all ((== positively q) . length . base . rhead)
\ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (unListableF term :: SyntaxTerm String '[Category]) `shouldSatisfy` all ((== positively q) . length . base . rhead)
describe "featureVectorDecorator" $ do
prop "produces a vector of the specified dimension" $
\ (term, p, q, d) -> featureVectorDecorator (rhead . headF) (positively p) (positively q) (positively d) (toTerm term :: Term (Syntax Text) (Record '[Text])) `shouldSatisfy` all ((== positively d) . length . rhead)
\ (term, p, q, d) -> featureVectorDecorator (rhead . headF) (positively p) (positively q) (positively d) (unListableF term :: SyntaxTerm String '[Category]) `shouldSatisfy` all ((== positively d) . length . rhead)
describe "rws" $ do
let toTerm' = decorate . toTerm
prop "produces correct diffs" . forAll (scale (`div` 4) arbitrary) $
\ (as, bs) -> let tas = toTerm' <$> (as :: [ArbitraryTerm Text (Record '[Category])])
tbs = toTerm' <$> (bs :: [ArbitraryTerm Text (Record '[Category])])
prop "produces correct diffs" $
\ (as, bs) -> let tas = decorate <$> (unListableF <$> as :: [SyntaxTerm String '[Category]])
tbs = decorate <$> (unListableF <$> bs :: [SyntaxTerm String '[Category]])
root = cofree . ((Program .: RNil) :<) . Indexed
diff = wrap (pure (Program .: RNil) :< Indexed (stripDiff <$> rws compare getLabel tas tbs)) in
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (root (stripTerm <$> tas)), Just (root (stripTerm <$> tbs)))

32
test/Diff/Spec.hs
View File

@ -2,41 +2,37 @@
module Diff.Spec where
import Category
import Data.RandomWalkSimilarity
import Data.Record
import Data.Text.Arbitrary ()
import Data.Bifunctor.Join
import Data.Functor.Listable
import Data.String
import Diff
import Diff.Arbitrary
import Diffing (getLabel)
import Info
import Interpreter
import Patch
import Prologue
import Term.Arbitrary
import Term
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Test.Hspec.LeanCheck
spec :: Spec
spec = parallel $ do
let toTerm' = defaultFeatureVectorDecorator (category . headF) . toTerm
prop "equality is reflexive" $
\ a b -> let diff = diffTerms wrap (==) diffCost getLabel (toTerm' a) (toTerm' (b :: ArbitraryTerm Text (Record '[Category]))) in
\ a -> let diff = unListableDiff a :: SyntaxDiff String '[Category] in
diff `shouldBe` diff
prop "equal terms produce identity diffs" $
\ a -> let term = toTerm' (a :: ArbitraryTerm Text (Record '[Category])) in
\ a -> let term = unListableF a :: SyntaxTerm String '[Category] in
diffCost (diffTerms wrap (==) diffCost getLabel term term) `shouldBe` 0
describe "beforeTerm" $ do
prop "recovers the before term" $
\ a b -> let diff = diffTerms wrap (==) diffCost getLabel (toTerm' a) (toTerm' (b :: ArbitraryTerm Text (Record '[Category]))) in
beforeTerm diff `shouldBe` Just (toTerm' a)
\ a b -> let diff = diffTerms wrap (==) diffCost getLabel (unListableF a) (unListableF b :: SyntaxTerm String '[Category]) in
beforeTerm diff `shouldBe` Just (unListableF a)
describe "afterTerm" $ do
prop "recovers the after term" $
\ a b -> let diff = diffTerms wrap (==) diffCost getLabel (toTerm' a) (toTerm' (b :: ArbitraryTerm Text (Record '[Category]))) in
afterTerm diff `shouldBe` Just (toTerm' b)
\ a b -> let diff = diffTerms wrap (==) diffCost getLabel (unListableF a) (unListableF b :: SyntaxTerm String '[Category]) in
afterTerm diff `shouldBe` Just (unListableF b)
describe "ArbitraryDiff" $ do
prop "generates diffs of a specific size" . forAll ((arbitrary >>= \ n -> (,) n <$> diffOfSize n) `suchThat` ((> 0) . fst)) $
\ (n, diff) -> arbitraryDiffSize (diff :: ArbitraryDiff Text ()) `shouldBe` n
unListableDiff :: Functor f => ListableF (Free (TermF f (ListableF (Join (,)) annotation))) (Patch (ListableF (Term f) annotation)) -> Diff f annotation
unListableDiff diff = transFreeT (first unListableF) $ fmap unListableF <$> unListableF diff

17
test/DiffSummarySpec.hs
View File

@ -3,11 +3,12 @@ module DiffSummarySpec where
import Category
import Data.Functor.Both
import Data.Functor.Listable
import Data.List (partition)
import Data.RandomWalkSimilarity
import Data.Record
import Data.String
import Diff
import Diff.Arbitrary
import DiffSummary
import Info
import Interpreter
@ -16,10 +17,9 @@ import Prologue
import Source
import Syntax
import Term
import Term.Arbitrary
import Test.Hspec (Spec, describe, it, parallel)
import Test.Hspec.Expectations.Pretty
import Test.Hspec.QuickCheck
import Test.Hspec.LeanCheck
import Data.These
import Diffing (getLabel)
@ -51,13 +51,13 @@ spec = parallel $ do
diffSummaries blobs testDiff `shouldBe` [ JSONSummary "Added the \"a\" string" (SourceSpans . That $ sourceSpanBetween (1, 2) (1, 4)) ]
prop "equal terms produce identity diffs" $
\ a -> let term = defaultFeatureVectorDecorator (category . headF) (toTerm (a :: ArbitraryTerm Text (Record '[Category, Range, SourceSpan]))) in
\ a -> let term = defaultFeatureVectorDecorator (category . headF) (unListableF a :: SyntaxTerm String '[Category, Range, SourceSpan]) in
diffSummaries blobs (diffTerms wrap (==) diffCost getLabel term term) `shouldBe` []
describe "DiffInfo" $ do
prop "patches in summaries match the patches in diffs" $
\a -> let
diff = (toDiff (a :: ArbitraryDiff Text (Record '[Category, Cost, Range, SourceSpan])))
diff = unListableDiff a :: SyntaxDiff String '[Category, Cost, Range, SourceSpan]
summaries = diffToDiffSummaries (source <$> blobs) diff
patches = toList diff
in
@ -66,14 +66,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, Range, SourceSpan])))
diff = unListableDiff a :: SyntaxDiff String '[Category, Range, SourceSpan]
diffInfoPatches = patch <$> diffToDiffSummaries (source <$> blobs) diff
syntaxPatches = toList diff
extractLeaves :: DiffInfo -> [DiffInfo]
extractLeaves (BranchInfo children _ _) = join $ extractLeaves <$> children
extractLeaves leaf = [ leaf ]
extractDiffLeaves :: Term (Syntax Text) (Record '[Category, Range, SourceSpan]) -> [ Term (Syntax Text) (Record '[Category, Range, SourceSpan]) ]
extractDiffLeaves :: SyntaxTerm String '[Category, Range, SourceSpan] -> [ SyntaxTerm String '[Category, Range, SourceSpan] ]
extractDiffLeaves term = case unwrap term of
(Indexed children) -> join $ extractDiffLeaves <$> children
(Fixed children) -> join $ extractDiffLeaves <$> children
@ -98,3 +98,6 @@ isIndexedOrFixed' syntax = case syntax of
isBranchNode :: Patch DiffInfo -> Bool
isBranchNode = any isBranchInfo
unListableDiff :: Functor f => ListableF (Free (TermF f (ListableF (Join (,)) annotation))) (Patch (ListableF (Term f) annotation)) -> Diff f annotation
unListableDiff diff = transFreeT (first unListableF) $ fmap unListableF <$> unListableF diff

16
test/InterpreterSpec.hs
View File

@ -3,8 +3,10 @@ module InterpreterSpec where
import Category
import Data.Functor.Foldable
import Data.Functor.Listable
import Data.RandomWalkSimilarity
import Data.Record
import Data.String
import Diff
import Diffing
import Info
@ -12,27 +14,27 @@ import Interpreter
import Patch
import Prologue
import Syntax
import Term.Arbitrary
import Term
import Test.Hspec (Spec, describe, it, parallel)
import Test.Hspec.Expectations.Pretty
import Test.Hspec.QuickCheck
import Test.Hspec.LeanCheck
spec :: Spec
spec = parallel $ do
describe "interpret" $ do
let decorate = defaultFeatureVectorDecorator (category . headF)
let compare = ((==) `on` category . extract)
let compare = (==) `on` category . extract
it "returns a replacement when comparing two unicode equivalent terms" $
let termA = cofree $ (StringLiteral .: RNil) :< Leaf ("t\776" :: Text)
let termA = cofree $ (StringLiteral .: RNil) :< Leaf ("t\776" :: String)
termB = cofree $ (StringLiteral .: RNil) :< Leaf "\7831" in
stripDiff (diffTerms wrap compare diffCost getLabel (decorate termA) (decorate termB)) `shouldBe` replacing termA termB
prop "produces correct diffs" $
\ a b -> let diff = stripDiff $ diffTerms wrap compare diffCost getLabel (decorate (toTerm a)) (decorate (toTerm (b :: ArbitraryTerm Text (Record '[Category])))) in
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (toTerm a), Just (toTerm b))
\ a b -> let diff = stripDiff $ diffTerms wrap compare diffCost getLabel (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (unListableF a), Just (unListableF b))
prop "constructs zero-cost diffs of equal terms" $
\ a -> let term = decorate (toTerm (a :: ArbitraryTerm Text (Record '[Category])))
\ a -> let term = decorate (unListableF a :: SyntaxTerm String '[Category])
diff = diffTerms wrap compare diffCost getLabel term term in
diffCost diff `shouldBe` 0

16
test/TermSpec.hs
View File

@ -1,19 +1,17 @@
{-# LANGUAGE DataKinds #-}
module TermSpec where
import Data.Text.Arbitrary ()
import Category
import Data.Functor.Listable
import Data.String (String)
import Prologue
import Term.Arbitrary
import Term
import Test.Hspec (Spec, describe, parallel)
import Test.Hspec.Expectations.Pretty
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Test.Hspec.LeanCheck
spec :: Spec
spec = parallel $ do
describe "Term" $ do
prop "equality is reflexive" $
\ a -> toTerm a `shouldBe` toTerm (a :: ArbitraryTerm Text ())
describe "ArbitraryTerm" $ do
prop "generates terms of a specific size" . forAll ((arbitrary >>= \ n -> (,) n <$> termOfSize n) `suchThat` ((> 0) . fst)) $
\ (n, term) -> arbitraryTermSize (term :: ArbitraryTerm Text ()) `shouldBe` n
\ a -> unListableF a `shouldBe` (unListableF a :: SyntaxTerm String '[Category])

76
test/Test/Hspec/LeanCheck.hs Normal file
View File

@ -0,0 +1,76 @@
{-# LANGUAGE GADTs, TypeFamilies #-}
module Test.Hspec.LeanCheck
( prop
, forAll
) where
import Control.Exception
import Data.Bifunctor (first)
import Data.String (String)
import GHC.Show as Show (showsPrec)
import Prologue
import Test.Hspec
import Test.Hspec.Core.Spec
import Test.LeanCheck.Core
data Property where
Property :: IOTestable prop => prop -> Property
-- | Perform an enumerative test of a property using LeanCheck.
--
-- 'prop' will typically be a function of one or more 'Listable' arguments, returning either 'Bool' or 'IO ()' (in the latter case, typically via 'shouldBe' and friends). For example:
--
-- > describe "+" $ do
-- > prop "associativity" $
-- > \ a b c -> a + (b + c) `shouldBe` (a + b :: Int) + c
prop :: (HasCallStack, IOTestable prop) => String -> prop -> Spec
prop s = it s . Property
data ForAll a where
ForAll :: IOTestable prop => [[a]] -> (a -> prop) -> ForAll a
-- | Test a property given by an explicit list of tiers rather than a 'Listable' instance. This can be used to e.g. filter input values for which the property does not hold.
--
-- > describe "mean" $ do
-- > prop "≥ the minimum" . forAll (not . null `filterT` tiers) $
-- > \ list -> (mean list :: Int) `shouldSatisfy` (>= min list)
forAll :: IOTestable prop => [[a]] -> (a -> prop) -> ForAll a
forAll = ForAll
instance Example Property where
type Arg Property = ()
evaluateExample (Property prop) (Params _ bound) _ _ = do
result <- iocounterExample bound prop
case result of
Just messages -> pure $ Fail Nothing (concat messages)
Nothing -> pure Success
class IOTestable t where
-- 'resultiers', lifted into 'IO'.
ioResultTiers :: t -> [[IO ([String], Bool)]]
instance IOTestable (IO ()) where
ioResultTiers action = [[ (action >> pure ([], True)) `catch` (\ e -> pure ([ displayException (e :: SomeException) ], False)) ]]
instance (IOTestable b, Show a, Listable a) => IOTestable (a -> b) where
ioResultTiers p = ioconcatMapT resultiersFor tiers
where resultiersFor x = fmap (fmap (first (showsPrec 11 x "":))) <$> ioResultTiers (p x)
instance IOTestable Bool where
ioResultTiers p = [[ pure ([], p) ]]
instance IOTestable (ForAll a) where
ioResultTiers (ForAll tiers property) = concatMapT (ioResultTiers . property) tiers
-- | 'concatMapT', lifted into 'IO'.
ioconcatMapT :: (a -> [[IO b]]) -> [[a]] -> [[IO b]]
ioconcatMapT f = (>>= (>>= f))
-- | 'counterExamples', lifted into 'IO'.
iocounterExamples :: IOTestable a => Int -> a -> IO [[String]]
iocounterExamples n = fmap (fmap fst . filter (not . snd)) . sequenceA . take n . concat . ioResultTiers
-- | 'counterExample', lifted into 'IO'.
iocounterExample :: IOTestable a => Int -> a -> IO (Maybe [String])
iocounterExample n = fmap listToMaybe . iocounterExamples n

2
vendor/text-icu vendored

@ -1 +1 @@
Subproject commit 75e614795840d32440c0f06deeee775015a94bf4
Subproject commit b851ba283cd1bb02f57f9c939219b75bea69afeb