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

Implement genFeaturizedTermsAndDiffs as an effect

Browse Source
This commit is contained in:
joshvera 2017-04-07 15:42:32 -04:00
parent 999cfbc57c
commit 752d494795
1 changed files with 47 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
src/RWS.hs
View File

@ -20,23 +20,68 @@ import Data.Functor.Classes.Eq.Generic
-- -> [Term f (Record fields)] -- ^ The list of new terms.
-- -> [These (Term f (Record fields)) (Term f (Record fields))] -- ^ The resulting list of similarity-matched diffs.
-- rws editDistance canCompare as bs = undefined
-- | A term which has not yet been mapped by `rws`, along with its feature vector summary & index.
data UnmappedTerm f fields = UnmappedTerm {
termIndex :: Int -- ^ The index of the term within its root term.
, feature :: FeatureVector -- ^ Feature vector
, term :: Term f (Record fields) -- ^ The unmapped term
}
-- | Either a `term`, an index of a matched term, or nil.
data TermOrIndexOrNone term = Term term | Index Int | None
data RWS f (fields :: [*]) result where
-- RWS :: RWS a b (EditScript a b)
SES :: RWS f fields (RWSEditScript f fields)
-- FindNearestNeighbourToDiff :: TermOrIndexOrNone (UnmappedTerm f fields) ->
GenFeaturizedTermsAndDiffs :: HasField fields (Maybe FeatureVector) => RWSEditScript f fields -> RWS f fields ([UnmappedTerm f fields], [UnmappedTerm f fields], [(These Int Int, These (Term f (Record fields)) (Term f (Record fields)))], [TermOrIndexOrNone (UnmappedTerm f fields)])
-- EraseFeatureVector :: forall a b f fields. RwsF a b (EditScript (Term f (Record fields)) (Term f (Record fields)))
type FeatureVector = Array Int Double
type RWSEditScript f fields = [These (Term f (Record fields)) (Term f (Record fields))]
run :: (Eq1 f, Functor f, HasField fields Category, Foldable t) => t (Term f (Record fields)) -> t (Term f (Record fields)) -> Eff '[RWS f fields] (RWSEditScript f fields) -> RWSEditScript f fields
run :: (Eq1 f, Functor f, HasField fields Category, HasField fields FeatureVector, Foldable t) => t (Term f (Record fields)) -> t (Term f (Record fields)) -> Eff '[RWS f fields] (RWSEditScript f fields) -> RWSEditScript f fields
run _ _ (Val x) = x
run as bs (E u q) = case decompose u of
Right SES ->
let sesDiffs = ses (gliftEq (==) `on` fmap category) as bs in
RWS.run as bs (apply q sesDiffs)
Right (GenFeaturizedTermsAndDiffs sesDiffs) -> RWS.run as bs . apply q $ evalState (genFeaturizedTermsAndDiffs sesDiffs) (0, 0)
genFeaturizedTermsAndDiffs :: (Functor f, HasField fields (Maybe FeatureVector)) => RWSEditScript f fields -> State (Int, Int) ([UnmappedTerm f fields], [UnmappedTerm f fields], [(These Int Int, These (Term f (Record fields)) (Term f (Record fields)))], [TermOrIndexOrNone (UnmappedTerm f fields)])
genFeaturizedTermsAndDiffs sesDiffs = case sesDiffs of
[] -> pure ([], [], [], [])
(diff : diffs) -> do
(counterA, counterB) <- get
case diff of
This term -> do
put (succ counterA, counterB)
(as, bs, mappedDiffs, allDiffs) <- genFeaturizedTermsAndDiffs diffs
pure (as <> pure (featurize counterA term), bs, mappedDiffs, allDiffs <> pure None)
That term -> do
put (counterA, succ counterB)
(as, bs, mappedDiffs, allDiffs) <- genFeaturizedTermsAndDiffs diffs
pure (as, bs <> pure (featurize counterB term), mappedDiffs, allDiffs <> pure (Term (featurize counterB term)))
These a b -> do
put (succ counterA, succ counterB)
(as, bs, mappedDiffs, allDiffs) <- genFeaturizedTermsAndDiffs diffs
pure (as, bs, mappedDiffs <> pure (These counterA counterB, These a b), allDiffs <> pure (Index counterA))
featurize :: (HasField fields (Maybe FeatureVector), Functor f) => Int -> Term f (Record fields) -> UnmappedTerm f fields
featurize index term = UnmappedTerm index (let Just v = getField (extract term) in v) (eraseFeatureVector term)
eraseFeatureVector :: (Functor f, HasField fields (Maybe FeatureVector)) => Term f (Record fields) -> Term f (Record fields)
eraseFeatureVector term = let record :< functor = runCofree term in
cofree (setFeatureVector record Nothing :< functor)
setFeatureVector :: HasField fields (Maybe FeatureVector) => Record fields -> Maybe FeatureVector -> Record fields
setFeatureVector = setField
data EditGraph a b = EditGraph { as :: !(Array Int a), bs :: !(Array Int b) }
deriving (Eq, Show)