mirror of
https://github.com/github/semantic.git
synced 2024-12-27 00:44:57 +03:00
44 lines
2.0 KiB
Haskell
44 lines
2.0 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
module Diffing.Algorithm.RWS.Spec where
|
|
|
|
import Analysis.Decorator
|
|
import Data.Bifunctor
|
|
import Data.Diff
|
|
import Data.Functor.Listable (ListableSyntax)
|
|
import Data.Record
|
|
import Data.Sum
|
|
import qualified Data.Syntax as Syntax
|
|
import Data.Term
|
|
import Data.These
|
|
import Diffing.Algorithm
|
|
import Diffing.Algorithm.RWS
|
|
import Diffing.Interpreter.Spec (afterTerm, beforeTerm)
|
|
import Test.Hspec.LeanCheck
|
|
import SpecHelpers
|
|
|
|
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 (positively p) (positively q) (term :: Term ListableSyntax (Record '[])) `shouldSatisfy` all ((== positively p) . length . stem . rhead)
|
|
|
|
prop "produces grams with bases of the specified width" $
|
|
\ (term, p, q) -> pqGramDecorator (positively p) (positively q) (term :: Term ListableSyntax (Record '[])) `shouldSatisfy` all ((== positively q) . length . base . rhead)
|
|
|
|
describe "rws" $ do
|
|
prop "produces correct diffs" $
|
|
\ (as, bs) -> let tas = decorate <$> (as :: [Term ListableSyntax (Record '[])])
|
|
tbs = decorate <$> (bs :: [Term ListableSyntax (Record '[])])
|
|
wrap = termIn Nil . inject
|
|
diff = merge (Nil, Nil) (inject (stripDiff . diffThese <$> rws comparableTerms (equalTerms comparableTerms) tas tbs)) in
|
|
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (wrap (stripTerm <$> tas)), Just (wrap (stripTerm <$> tbs)))
|
|
|
|
it "produces unbiased insertions within branches" $
|
|
let (a, b) = (decorate (termIn Nil (inject [ termIn Nil (inject (Syntax.Identifier "a")) ])), decorate (termIn Nil (inject [ termIn Nil (inject (Syntax.Identifier "b")) ]))) in
|
|
fmap (bimap stripTerm stripTerm) (rws comparableTerms (equalTerms comparableTerms) [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ That a, These b b ]
|
|
|
|
where decorate = defaultFeatureVectorDecorator
|
|
|
|
diffThese = these deleting inserting replacing
|