mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-09 11:12:51 -06:00
(1) Refactor concurrency, (2) write to .gfo.tmp then rename to .gfo
(1) introduces the module GF.Infra.Concurreny with lifted concurrency
operators (to reduce uses of liftIO) and some additional concurrency
utilities, e.g. a function for sequential logging that is used in
both GF.CompileInParallel and GFServer.
(2) avoids leaving broken .gfo files behind if compilation is aborted.
This commit is contained in:
48
src/compiler/GF/Infra/Concurrency.hs
Normal file
48
src/compiler/GF/Infra/Concurrency.hs
Normal file
@@ -0,0 +1,48 @@
|
||||
-- | Lifted concurrency operators and a some useful concurrency abstractions
|
||||
module GF.Infra.Concurrency(
|
||||
module GF.Infra.Concurrency,
|
||||
C.forkIO,
|
||||
C.MVar,C.modifyMVar,C.modifyMVar_,
|
||||
C.Chan
|
||||
) where
|
||||
import qualified Control.Concurrent as C
|
||||
import System.IO.Unsafe(unsafeInterleaveIO)
|
||||
import Control.Monad((<=<))
|
||||
import Control.Monad.Trans(MonadIO(..))
|
||||
|
||||
-- * Futures
|
||||
|
||||
newtype Future a = Future {now::IO a}
|
||||
|
||||
spawn io = do v <- newEmptyMVar
|
||||
C.forkIO $ putMVar v =<< io
|
||||
return (Future (readMVar v))
|
||||
|
||||
parMapM f = mapM now <=< mapM (spawn . f)
|
||||
|
||||
-- * Single-threaded logging
|
||||
|
||||
newLog put =
|
||||
do logchan <- newChan
|
||||
liftIO $ C.forkIO (mapM_ put =<< getChanContents logchan)
|
||||
return (writeChan logchan)
|
||||
|
||||
-- * Lifted concurrency operators
|
||||
|
||||
newMVar x = liftIO $ C.newMVar x
|
||||
readMVar v = liftIO $ C.readMVar v
|
||||
putMVar v = liftIO . C.putMVar v
|
||||
|
||||
newEmptyMVar :: MonadIO io => io (C.MVar a)
|
||||
newEmptyMVar = liftIO C.newEmptyMVar
|
||||
|
||||
newChan :: MonadIO io => io (C.Chan a)
|
||||
newChan = liftIO C.newChan
|
||||
|
||||
getChanContents ch = liftIO $ C.getChanContents ch
|
||||
writeChan ch = liftIO . C.writeChan ch
|
||||
|
||||
|
||||
-- * Delayed IO
|
||||
|
||||
lazyIO = unsafeInterleaveIO
|
||||
Reference in New Issue
Block a user