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

Extract the TaskF interpreter to the top level.

Browse Source
This commit is contained in:
Rob Rix 2018-04-04 10:35:21 -04:00
parent 744e5632ed
commit 9101bcd996
1 changed files with 14 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
src/Semantic/Task.hs
View File

@ -185,18 +185,7 @@ runTaskWithOptions options task = do
run options logger statter = run' run options logger statter = run'
where where
run' :: Task a -> IO (Either SomeException a) run' :: Task a -> IO (Either SomeException a)
run' = runM . runError . flip runReader statter . flip runReader logger . runTelemetry . flip runReader options . go . runDistribute run' = runM . runError . flip runReader statter . flip runReader logger . runTelemetry . flip runReader options . runTaskF . runDistribute
go :: Members '[Reader Options, Telemetry, Reader LogQueue, Reader StatQueue, Exc SomeException, IO] effs => Eff (TaskF ': effs) a -> Eff effs a
go = interpret (\ task -> case task of
ReadBlobs (Left handle) -> rethrowing (IO.readBlobsFromHandle handle)
ReadBlobs (Right paths@[(path, Nothing)]) -> rethrowing (IO.isDirectory path >>= bool (IO.readBlobsFromPaths paths) (IO.readBlobsFromDir path))
ReadBlobs (Right paths) -> rethrowing (IO.readBlobsFromPaths paths)
ReadBlobPairs source -> rethrowing (either IO.readBlobPairsFromHandle (traverse (runBothWith IO.readFilePair)) source)
WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents)
Parse parser blob -> runParser blob parser
Decorate algebra term -> pure (decoratorWithAlgebra algebra term)
Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2)
Render renderer input -> pure (renderer input))
runDistribute :: Members '[Exc SomeException, IO] effs => Eff (Distribute ': effs) a -> Eff effs a runDistribute :: Members '[Exc SomeException, IO] effs => Eff (Distribute ': effs) a -> Eff effs a
runDistribute = interpret (\ task -> case task of runDistribute = interpret (\ task -> case task of
@ -248,6 +237,19 @@ runParser blob@Blob{..} parser = case parser of
_ -> fold syntax _ -> fold syntax
runTaskF :: Members '[Reader Options, Telemetry, Reader LogQueue, Reader StatQueue, Exc SomeException, IO] effs => Eff (TaskF ': effs) a -> Eff effs a
runTaskF = interpret (\ task -> case task of
ReadBlobs (Left handle) -> rethrowing (IO.readBlobsFromHandle handle)
ReadBlobs (Right paths@[(path, Nothing)]) -> rethrowing (IO.isDirectory path >>= bool (IO.readBlobsFromPaths paths) (IO.readBlobsFromDir path))
ReadBlobs (Right paths) -> rethrowing (IO.readBlobsFromPaths paths)
ReadBlobPairs source -> rethrowing (either IO.readBlobPairsFromHandle (traverse (runBothWith IO.readFilePair)) source)
WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents)
Parse parser blob -> runParser blob parser
Decorate algebra term -> pure (decoratorWithAlgebra algebra term)
Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2)
Render renderer input -> pure (renderer input))
-- | Statting and logging effects. -- | Statting and logging effects.
data Telemetry output where data Telemetry output where
WriteStat :: Stat -> Telemetry () WriteStat :: Stat -> Telemetry ()