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

First pass at parallel rendering!

Browse Source
This commit is contained in:
Timothy Clem 2017-04-21 16:24:14 -07:00
parent 980333f40d
commit bd019104a8
2 changed files with 21 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
src/Renderer.hs
View File

@ -27,6 +27,8 @@ import Source (SourceBlob)
import Syntax
import Term
import Control.Parallel.Strategies
import qualified Control.Concurrent.Async as Async
data DiffRenderer fields output where
SplitRenderer :: (HasField fields Category, HasField fields Range) => DiffRenderer fields File
@ -36,8 +38,8 @@ data DiffRenderer fields output where
SExpressionDiffRenderer :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> DiffRenderer fields ByteString
ToCRenderer :: HasDefaultFields fields => DiffRenderer fields Summaries
runDiffRenderer :: (Monoid output, StringConv output ByteString) => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> output
runDiffRenderer renderer = foldMap . uncurry $ case renderer of
runDiffRenderer :: (Monoid output, StringConv output ByteString) => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> IO output
runDiffRenderer renderer = renderAsync $ case renderer of
SplitRenderer -> (File .) . R.split
PatchRenderer -> (File .) . R.patch
JSONDiffRenderer -> R.json
@ -45,17 +47,30 @@ runDiffRenderer renderer = foldMap . uncurry $ case renderer of
SExpressionDiffRenderer format -> R.sExpression format
ToCRenderer -> R.toc
where
renderAsync :: (Monoid output, StringConv output ByteString) => (Both SourceBlob -> Diff (Syntax Text) (Record fields) -> output) -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> IO output
renderAsync f diffs = do
outputs <- Async.mapConcurrently (pure . uncurry f) diffs
pure $ mconcat (outputs `using` parTraversable rseq)
data ParseTreeRenderer fields output where
SExpressionParseTreeRenderer :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> ParseTreeRenderer fields ByteString
JSONParseTreeRenderer :: HasDefaultFields fields => ParseTreeRenderer fields Value
JSONIndexParseTreeRenderer :: HasDefaultFields fields => ParseTreeRenderer fields Value
runParseTreeRenderer :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer fields output -> [(SourceBlob, Term (Syntax Text) (Record fields))] -> output
runParseTreeRenderer renderer = foldMap . uncurry $ case renderer of
runParseTreeRenderer :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer fields output -> [(SourceBlob, Term (Syntax Text) (Record fields))] -> IO output
runParseTreeRenderer renderer = renderAsync $ case renderer of
SExpressionParseTreeRenderer format -> R.sExpressionParseTree format
JSONParseTreeRenderer -> R.jsonParseTree False
JSONIndexParseTreeRenderer -> R.jsonIndexParseTree False
where
renderAsync :: (Monoid output, StringConv output ByteString) => (SourceBlob -> Term (Syntax Text) (Record fields) -> output) -> [(SourceBlob, Term (Syntax Text) (Record fields))] -> IO output
renderAsync f terms = do
outputs <- Async.mapConcurrently (pure . uncurry f) terms
pure $ mconcat (outputs `using` parTraversable rseq)
newtype File = File { unFile :: Text }
deriving Show

4
src/Semantic.hs
View File

@ -56,7 +56,7 @@ diffBlobs renderer blobs = do
traceEventIO "diffing some blobs"
diffs <- Async.mapConcurrently go blobs
let diffs' = diffs >>= \ (blobs, diff) -> (,) blobs <$> toList diff
pure . toS $ runDiffRenderer renderer (diffs' `using` parTraversable (parTuple2 r0 rdeepseq))
toS <$> runDiffRenderer renderer (diffs' `using` parTraversable (parTuple2 r0 rdeepseq))
where
go blobPair = do
traceEventIO ("diffing: " <> show (path <$> blobPair))
@ -85,7 +85,7 @@ diffBlobs' blobs = do
parseBlobs :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer DefaultFields output -> [SourceBlob] -> IO ByteString
parseBlobs renderer blobs = do
terms <- traverse go blobs
pure . toS $ runParseTreeRenderer renderer (terms `using` parTraversable (parTuple2 r0 rdeepseq))
toS <$> runParseTreeRenderer renderer (terms `using` parTraversable (parTuple2 r0 rdeepseq))
where
go blob = do
term <- parseBlob blob