github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-04 13:34:31 +03:00
Code Issues Projects Releases Wiki Activity

Define a MonadIO instance for Task.

Browse Source
This commit is contained in:
Rob Rix 2017-07-21 13:09:51 -04:00
parent d886ba21f0
commit 5e4f221585
1 changed files with 8 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/Semantic/Task.hs
View File

@ -19,6 +19,7 @@ module Semantic.Task
) where ) where
import Control.Concurrent.STM.TMQueue import Control.Concurrent.STM.TMQueue
import Control.Monad.IO.Class
import Control.Parallel.Strategies import Control.Parallel.Strategies
import qualified Control.Concurrent.Async as Async import qualified Control.Concurrent.Async as Async
import Control.Monad.Free.Freer import Control.Monad.Free.Freer
@ -44,6 +45,7 @@ data TaskF output where
Diff :: Differ f a -> Both (Term f a) -> TaskF (Diff f a) Diff :: Differ f a -> Both (Term f a) -> TaskF (Diff f a)
Render :: Renderer input output -> input -> TaskF output Render :: Renderer input output -> input -> TaskF output
Distribute :: Traversable t => t (Task output) -> TaskF (t output) Distribute :: Traversable t => t (Task output) -> TaskF (t output)
LiftIO :: IO a -> TaskF a
-- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap' -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
type Task = Freer TaskF type Task = Freer TaskF
@ -136,7 +138,8 @@ runTask task = do
Decorate algebra term -> writeLog (Info "Decorate") *> pure (pure (decoratorWithAlgebra algebra term)) Decorate algebra term -> writeLog (Info "Decorate") *> pure (pure (decoratorWithAlgebra algebra term))
Diff differ terms -> writeLog (Info "Diff") *> pure (pure (differ terms)) Diff differ terms -> writeLog (Info "Diff") *> pure (pure (differ terms))
Render renderer input -> writeLog (Info "Render") *> pure (pure (renderer input)) Render renderer input -> writeLog (Info "Render") *> pure (pure (renderer input))
Distribute tasks -> writeLog (Info "Distribute") *> pure (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq))) Distribute tasks -> writeLog (Info "Distribute") *> pure (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq))
LiftIO action -> pure action)
task task
atomically (closeTMQueue logQueue) atomically (closeTMQueue logQueue)
wait logging wait logging
@ -148,3 +151,7 @@ runTask task = do
B.hPutStr stderr (formatMessage message) B.hPutStr stderr (formatMessage message)
writeThread queue writeThread queue
_ -> pure () _ -> pure ()
instance MonadIO Task where
liftIO action = LiftIO action `Then` return