github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-29 18:06:14 +03:00
Code Issues Projects Releases Wiki Activity

Add (failing) tests of rws’ bias.

Browse Source
This commit is contained in:
Rob Rix 2016-08-11 11:53:51 -04:00
parent 6debe0a076
commit e4c55a8dbd
1 changed files with 12 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -36,3 +36,15 @@ spec = parallel $ do
tbs = toTerm' <$> (bs :: [ArbitraryTerm Text (Record '[Category])])
diff = free (Free (pure (pure 0 .: Program .: RNil) :< Indexed (rws compare tas tbs))) in
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (cofree ((pure 0 .: Program .: RNil) :< Indexed tas)), Just (cofree ((pure 0 .: Program .: RNil) :< Indexed tbs)))
let toTerm'' c (ArbitraryTerm r f) = toTerm' (ArbitraryTerm (setCategory r c) f)
let strip diff = free $ case runFree diff of
Free (h :< t) -> Free (fmap rtail h :< fmap strip t)
Pure a -> Pure (fmap (fmap rtail) a)
prop "produces unbiased deletions" $
\ a b c -> let (a', b') = (toTerm'' c a, toTerm'' c (b :: ArbitraryTerm Text (Record '[Category]))) in
fmap strip (rws compare [ a', b' ] [ a' ]) `shouldBe` fmap strip (reverse (rws compare [ b', a' ] [ a' ]))
prop "produces unbiased insertions" $
\ a b c -> let (a', b') = (toTerm'' c a, toTerm'' c (b :: ArbitraryTerm Text (Record '[Category]))) in
fmap strip (rws compare [ a' ] [ a', b' ]) `shouldBe` fmap strip (reverse (rws compare [ a' ] [ b', a' ]))