1
1
mirror of https://github.com/github/semantic.git synced 2024-12-22 14:21:31 +03:00

🔥 concurrently

This commit is contained in:
Timothy Clem 2017-04-25 09:05:48 -07:00
parent 12948181c5
commit 6be9b9c3cd

View File

@ -5,21 +5,18 @@ module Command
, readFile
, readFilesAtSHA
, readFilesAtSHAs
, concurrently
-- Evaluation
, runCommand
) where
import qualified Command.Files as Files
import qualified Command.Git as Git
import qualified Control.Concurrent.Async.Pool as Async
import Control.Monad.Free.Freer
import Control.Monad.IO.Class
import Data.Functor.Both
import Data.Functor.Classes
import Data.String
import GHC.Conc (numCapabilities)
import Prologue hiding (concurrently, Concurrently, readFile)
import Prologue hiding (readFile)
import Source
import Text.Show
@ -50,10 +47,6 @@ readFilesAtSHAs :: FilePath -- ^ GIT_DIR
-> Command [Both SourceBlob] -- ^ A command producing a list of pairs of blobs for the specified files (or all files if none were specified).
readFilesAtSHAs gitDir alternates paths shas = ReadFilesAtSHAs gitDir alternates paths shas `Then` return
-- | Run a function over each element of a Traversable concurrently.
concurrently :: Traversable t => t a -> (a -> Command b) -> Command (t b)
concurrently ts f = Concurrently ts f `Then` return
-- Evaluation
@ -63,9 +56,6 @@ runCommand = iterFreerA $ \ command yield -> case command of
ReadFile path -> Files.readFile path >>= yield
ReadFilesAtSHA gitDir alternates paths sha -> Git.readFilesAtSHA gitDir alternates paths sha >>= yield
ReadFilesAtSHAs gitDir alternates paths shas -> Git.readFilesAtSHAs gitDir alternates paths shas >>= yield
Concurrently ts f -> do
results <- Async.withTaskGroup numCapabilities $ \ group -> Async.runTask group $ traverse (Async.task . runCommand . f) ts
yield results
LiftIO io -> io >>= yield
@ -75,18 +65,16 @@ data CommandF f where
ReadFile :: FilePath -> CommandF SourceBlob
ReadFilesAtSHA :: FilePath -> [FilePath] -> [FilePath] -> String -> CommandF [SourceBlob]
ReadFilesAtSHAs :: FilePath -> [FilePath] -> [FilePath] -> Both String -> CommandF [Both SourceBlob]
Concurrently :: Traversable t => t a -> (a -> Command b) -> CommandF (t b)
LiftIO :: IO a -> CommandF a
instance MonadIO Command where
liftIO io = LiftIO io `Then` return
instance Show1 CommandF where
liftShowsPrec sp sl d command = case command of
liftShowsPrec _ _ d command = case command of
ReadFile path -> showsUnaryWith showsPrec "ReadFile" d path
ReadFilesAtSHA gitDir alternates paths sha -> showsQuaternaryWith showsPrec showsPrec showsPrec showsPrec "ReadFilesAtSHA" d gitDir alternates paths sha
ReadFilesAtSHAs gitDir alternates paths shas -> showsQuaternaryWith showsPrec showsPrec showsPrec showsPrec "ReadFilesAtSHAs" d gitDir alternates paths shas
Concurrently commands f -> showsBinaryWith (liftShowsPrec sp sl) (const showChar) "Concurrently" d (traverse f commands) '_'
LiftIO _ -> showsUnaryWith (const showChar) "LiftIO" d '_'
where
showsQuaternaryWith sp1 sp2 sp3 sp4 name d x y z w = showParen (d > 10) $