github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-29 02:44:36 +03:00
Code Issues Projects Releases Wiki Activity

Generalize pqGrams over a getLabel accessor again.

Browse Source
This commit is contained in:
Rob Rix 2016-06-23 10:18:39 -04:00
parent c85c87ad65
commit a657295ae6
2 changed files with 5 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Data/RandomWalkSimilarity.hs
View File

@ -5,7 +5,6 @@ import qualified Data.DList as DList
import Data.Functor.Foldable as Foldable
import Data.Hashable
import qualified Data.OrderedMap as Map
import Data.Record
import qualified Data.Vector as Vector
import Diff
import Patch
@ -29,9 +28,9 @@ data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] }
serialize :: Gram label -> [Maybe label]
serialize gram = stem gram <> base gram
pqGrams :: HasField fields label => Int -> Int -> Cofree (Syntax leaf) (Record fields) -> Bag (Gram label)
pqGrams p q = cata merge . setRootBase . setRootStem . hylo go project
where go (record :< functor) = cofree (Gram [] [ Just (getField record) ] :< (assignParent (Just (getField record)) p <$> functor))
pqGrams :: Int -> Int -> (annotation -> label) -> Cofree (Syntax leaf) annotation -> Bag (Gram label)
pqGrams p q getLabel = cata merge . setRootBase . setRootStem . hylo go project
where go (annotation :< functor) = cofree (Gram [] [ Just (getLabel annotation) ] :< (assignParent (Just (getLabel annotation)) p <$> functor))
merge (head :< tail) = DList.singleton head <> Prologue.fold tail
assignParent parentLabel n tree
| n > 0 = let gram :< functor = runCofree tree in cofree $ prependParent parentLabel gram :< assignSiblings (assignParent parentLabel (pred n) <$> functor)

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

@ -18,10 +18,10 @@ spec :: Spec
spec = parallel $ do
describe "pqGrams" $ do
prop "produces grams with stems of the specified length" . forAll (arbitrary `suchThat` (\ (_, p, q) -> p > 0 && q > 0)) $
\ (term, p, q) -> (pqGrams p q (toTerm term :: Term String (Record '[String])) :: Bag (Gram String)) `shouldSatisfy` all ((== p) . length . stem)
\ (term, p, q) -> (pqGrams p q getField (toTerm term :: Term String (Record '[String])) :: Bag (Gram String)) `shouldSatisfy` all ((== p) . length . stem)
prop "produces grams with bases of the specified length" . forAll (arbitrary `suchThat` (\ (_, p, q) -> p > 0 && q > 0)) $
\ (term, p, q) -> (pqGrams p q (toTerm term :: Term String (Record '[String])) :: Bag (Gram String)) `shouldSatisfy` all ((== q) . length . base)
\ (term, p, q) -> (pqGrams p q getField (toTerm term :: Term String (Record '[String])) :: Bag (Gram String)) `shouldSatisfy` all ((== q) . length . base)
describe "featureVector" $ do
prop "produces a vector of the specified dimension" . forAll (arbitrary `suchThat` ((> 0) . snd)) $