github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-22 22:31:36 +03:00
Code Issues Projects Releases Wiki Activity

Expect the incoming term to have a label at the head of the record already.

Browse Source
This commit is contained in:
Rob Rix 2016-08-04 15:35:47 -04:00
parent 9c3509f7d2
commit 3dc0a4f071
1 changed files with 2 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Data/RandomWalkSimilarity.hs
View File

@ -115,8 +115,8 @@ decorateTermWithLabel :: (Typeable label, Functor f) => (forall b. CofreeF f (Re
decorateTermWithLabel getLabel = cata $ \ c@(h :< t) ->
cofree ((getLabel c .: h) :< t)
decorateTermWithPQGram :: (Typeable label, Functor f) => (forall b. CofreeF f (Record fields) b -> label) -> Int -> Int -> Cofree f (Record fields) -> Cofree f (Record (Gram label ': fields))
decorateTermWithPQGram getLabel p q = futu coalgebra . (,) [] . decorateTermWithLabel getLabel
decorateTermWithPQGram :: (Typeable label, Functor f) => (forall b. CofreeF f (Record (label ': fields)) b -> label) -> Int -> Int -> Cofree f (Record (label ': fields)) -> Cofree f (Record (Gram label ': fields))
decorateTermWithPQGram getLabel p q = futu coalgebra . (,) []
where coalgebra :: Functor f => ([Maybe label], Cofree f (Record (label ': fields))) -> CofreeF f (Record (Gram label ': fields)) (Free.Free (CofreeF f (Record (Gram label ': fields))) ([Maybe label], Cofree f (Record (label ': fields))))
coalgebra (parentLabels, c) = case extract c of
RCons label rest -> (Gram (take p (parentLabels <> repeat Nothing)) (pure (Just label)) .: rest) :< fmap (pure . (,) (take p (Just label : parentLabels))) (unwrap c)