mirror of
https://github.com/github/semantic.git
synced 2024-12-22 14:21:31 +03:00
🔥 concurrently
This commit is contained in:
parent
12948181c5
commit
6be9b9c3cd
@ -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) $
|
||||
|
Loading…
Reference in New Issue
Block a user