github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-02 20:41:38 +03:00
Code Issues Projects Releases Wiki Activity

Factor the language-specific parts of diffBlobPair out.

Browse Source
This commit is contained in:
Rob Rix 2018-05-14 14:15:28 -04:00
parent c22b9f6beb
commit b76812ec91
1 changed files with 18 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
src/Semantic/Diff.hs
View File

@ -1,9 +1,10 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GADTs, ScopedTypeVariables #-}
module Semantic.Diff where
import Analysis.ConstructorName (ConstructorName, constructorLabel)
import Analysis.IdentifierName (IdentifierName, identifierLabel)
import Analysis.Declaration (HasDeclaration, declarationAlgebra)
import Data.AST
import Data.Blob
import Data.Diff
import Data.JSON.Fields
@ -25,23 +26,21 @@ diffBlobPairs renderer = distributeFoldMap (WrapTask . diffBlobPair renderer)
-- | A task to parse a pair of 'Blob's, diff them, and render the 'Diff'.
diffBlobPair :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs => DiffRenderer output -> BlobPair -> Eff effs output
diffBlobPair renderer blobs
| Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable] <$> effectiveLanguage
= case renderer of
ToCDiffRenderer -> run parser (decorate . declarationAlgebra) >>= render (renderToCDiff blobs)
JSONDiffRenderer -> run parser (const (decorate constructorLabel >=> decorate identifierLabel)) >>= render (renderJSONDiff blobs)
SExpressionDiffRenderer -> run parser (const pure) >>= serialize (SExpression ByConstructorName)
DOTDiffRenderer -> run parser (const pure) >>= render renderTreeGraph >>= serialize (DOT (diffStyle (pathKeyForBlobPair blobs)))
| otherwise = noLanguageForBlob effectivePath
where effectivePath = pathForBlobPair blobs
effectiveLanguage = languageForBlobPair blobs
languageTag = languageTagForBlobPair blobs
| Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable] <$> (languageForBlobPair blobs)
= diffBlobPairWithParser renderer blobs parser
| otherwise = noLanguageForBlob (pathForBlobPair blobs)
run :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax, Members [Distribute WrappedTask, Task, Telemetry, IO] effs)
=> Parser (Term syntax (Record fields'))
-> (Blob -> Term syntax (Record fields') -> TaskEff (Term syntax (Record fields)))
diffBlobPairWithParser :: forall syntax effs output . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax, Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs) => DiffRenderer output -> BlobPair -> Parser (Term syntax (Record Location)) -> Eff effs output
diffBlobPairWithParser renderer blobs parser = case renderer of
ToCDiffRenderer -> parseBlobs (decorate . declarationAlgebra) >>= diffTerms >>= render (renderToCDiff blobs)
JSONDiffRenderer -> parseBlobs (const (decorate constructorLabel >=> decorate identifierLabel)) >>= diffTerms >>= render (renderJSONDiff blobs)
SExpressionDiffRenderer -> parseBlobs (const pure) >>= diffTerms >>= serialize (SExpression ByConstructorName)
DOTDiffRenderer -> parseBlobs (const pure) >>= diffTerms >>= render renderTreeGraph >>= serialize (DOT (diffStyle (pathKeyForBlobPair blobs)))
where languageTag = languageTagForBlobPair blobs
parseBlobs :: (Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields))) -> Eff effs (Join These (Term syntax (Record fields)))
parseBlobs decorate = distributeFor blobs (\ blob -> WrapTask (decorate blob =<< parse parser blob))
diffTerms :: Join These (Term syntax (Record fields))
-> Eff effs (Diff syntax (Record fields) (Record fields))
run parser decorate = do
terms <- distributeFor blobs (\ blob -> WrapTask (decorate blob =<< parse parser blob))
time "diff" languageTag $ do
diff <- diff (runJoin terms)
diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
diffTerms terms = time "diff" languageTag $ do
diff <- diff (runJoin terms)
diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)