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

Define runTask using foldFreer.

Browse Source
This commit is contained in:
Rob Rix 2017-07-21 12:09:06 -04:00
parent 4a067250c6
commit 007fdd0e5c
1 changed files with 10 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/Semantic/Task.hs
View File

@ -120,13 +120,13 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
-- | Execute a 'Task', yielding its result value in 'IO'.
runTask :: Task a -> IO a
runTask = iterFreerA $ \ task yield -> case task of
ReadBlobs source -> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source >>= yield
ReadBlobPairs source -> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source >>= yield
WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield
WriteLog message -> B.hPutStr stderr (formatMessage message) >>= yield
Parse parser blob -> runParser parser blob >>= yield
Decorate algebra term -> yield (decoratorWithAlgebra algebra term)
Diff differ terms -> yield (differ terms)
Render renderer input -> yield (renderer input)
Distribute tasks -> Async.mapConcurrently runTask tasks >>= yield . withStrategy (parTraversable rseq)
runTask = foldFreer $ \ task -> case task of
ReadBlobs source -> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source
ReadBlobPairs source -> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source
WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents
WriteLog message -> B.hPutStr stderr (formatMessage message)
Parse parser blob -> runParser parser blob
Decorate algebra term -> pure (decoratorWithAlgebra algebra term)
Diff differ terms -> pure (differ terms)
Render renderer input -> pure (renderer input)
Distribute tasks -> Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq)