mirror of
https://github.com/github/semantic.git
synced 2024-12-25 16:02:43 +03:00
Migrate the RWS tests to à la carte syntax.
This commit is contained in:
parent
d54f8b34c2
commit
c9e4968d93
@ -1,49 +1,61 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
module Data.RandomWalkSimilarity.Spec where
|
||||
|
||||
import Category
|
||||
import Data.Array.IArray
|
||||
import Data.Bifunctor
|
||||
import Data.Functor.Listable ()
|
||||
import Data.Record
|
||||
import qualified Data.Syntax as Syntax
|
||||
import qualified Data.Syntax.Comment as Comment
|
||||
import qualified Data.Syntax.Declaration as Declaration
|
||||
import qualified Data.Syntax.Statement as Statement
|
||||
import Data.These
|
||||
import Data.Union
|
||||
import Decorators
|
||||
import Diff
|
||||
import Info
|
||||
import Interpreter
|
||||
import RWS
|
||||
import Syntax
|
||||
import Term
|
||||
import Test.Hspec
|
||||
import Test.Hspec.LeanCheck
|
||||
|
||||
type Syntax = Union
|
||||
'[ Comment.Comment
|
||||
, Declaration.Function
|
||||
, Declaration.Method
|
||||
, Statement.If
|
||||
, Syntax.Context
|
||||
, Syntax.Empty
|
||||
, Syntax.Identifier
|
||||
, []
|
||||
]
|
||||
|
||||
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 . termAnnotation) (positively p) (positively q) (term :: Term Syntax (Record '[Category])) `shouldSatisfy` all ((== positively p) . length . stem . rhead)
|
||||
\ (term, p, q) -> pqGramDecorator constructorNameAndConstantFields (positively p) (positively q) (term :: Term Syntax (Record '[])) `shouldSatisfy` all ((== positively p) . length . stem . rhead)
|
||||
|
||||
prop "produces grams with bases of the specified width" $
|
||||
\ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (term :: Term Syntax (Record '[Category])) `shouldSatisfy` all ((== positively q) . length . base . rhead)
|
||||
\ (term, p, q) -> pqGramDecorator constructorNameAndConstantFields (positively p) (positively q) (term :: Term Syntax (Record '[])) `shouldSatisfy` all ((== positively q) . length . base . rhead)
|
||||
|
||||
describe "featureVectorDecorator" $ do
|
||||
prop "produces a vector of the specified dimension" $
|
||||
\ (term, p, q, d) -> featureVectorDecorator (rhead . termAnnotation) (positively p) (positively q) (positively d) (term :: Term Syntax (Record '[Category])) `shouldSatisfy` all ((== (0, abs d)) . bounds . unFV . rhead)
|
||||
\ term p q d -> featureVectorDecorator constructorNameAndConstantFields (positively p) (positively q) (positively d) (term :: Term Syntax (Record '[])) `shouldSatisfy` all ((== (0, abs d)) . bounds . unFV . rhead)
|
||||
|
||||
describe "rws" $ do
|
||||
prop "produces correct diffs" $
|
||||
\ (as, bs) -> let tas = decorate <$> (as :: [Term Syntax (Record '[Category])])
|
||||
tbs = decorate <$> (bs :: [Term Syntax (Record '[Category])])
|
||||
root = termIn (Program :. Nil) . Indexed
|
||||
diff = merge ((Program :. Nil, Program :. Nil)) (Indexed (stripDiff . diffThese <$> rws canCompare (equalTerms canCompare) tas tbs)) in
|
||||
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (root (stripTerm <$> tas)), Just (root (stripTerm <$> tbs)))
|
||||
\ (as, bs) -> let tas = decorate <$> (as :: [Term Syntax (Record '[])])
|
||||
tbs = decorate <$> (bs :: [Term Syntax (Record '[])])
|
||||
wrap = termIn Nil . inj
|
||||
diff = merge (Nil, Nil) (inj (stripDiff . diffThese <$> rws comparableByConstructor (equalTerms comparableByConstructor) 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 (Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf "a") ])), decorate (Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf "b") ]))) in
|
||||
fmap (bimap stripTerm stripTerm) (rws canCompare (equalTerms canCompare) [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ That a, These b b ]
|
||||
let (a, b) = (decorate (termIn Nil (inj [ termIn Nil (inj (Syntax.Identifier "a")) ])), decorate (termIn Nil (inj [ termIn Nil (inj (Syntax.Identifier "b")) ]))) in
|
||||
fmap (bimap stripTerm stripTerm) (rws comparableByConstructor (equalTerms comparableByConstructor) [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ That a, These b b ]
|
||||
|
||||
where canCompare a b = termAnnotation a == termAnnotation b
|
||||
|
||||
decorate :: Term Syntax (Record '[Category]) -> Term Syntax (Record '[FeatureVector, Category])
|
||||
decorate = defaultFeatureVectorDecorator (category . termAnnotation)
|
||||
where decorate = defaultFeatureVectorDecorator constructorNameAndConstantFields
|
||||
|
||||
diffThese = these deleting inserting replacing
|
||||
|
Loading…
Reference in New Issue
Block a user