mirror of
https://github.com/gren-lang/compiler.git
synced 2024-10-26 18:00:47 +03:00
add BackgroundWriter to ensure that files are fully written
This commit is contained in:
parent
be9e78a134
commit
249090acaa
42
builder/src/BackgroundWriter.hs
Normal file
42
builder/src/BackgroundWriter.hs
Normal file
@ -0,0 +1,42 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module BackgroundWriter
|
||||
( Scope
|
||||
, withScope
|
||||
, writeBinary
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
|
||||
import qualified Data.Binary as Binary
|
||||
import Data.Foldable (traverse_)
|
||||
|
||||
import qualified File
|
||||
|
||||
|
||||
|
||||
-- BACKGROUND WRITER
|
||||
|
||||
|
||||
newtype Scope =
|
||||
Scope (MVar [MVar ()])
|
||||
|
||||
|
||||
withScope :: (Scope -> IO a) -> IO a
|
||||
withScope callback =
|
||||
do workList <- newMVar []
|
||||
result <- callback (Scope workList)
|
||||
mvars <- takeMVar workList
|
||||
traverse_ takeMVar mvars
|
||||
return result
|
||||
|
||||
|
||||
writeBinary :: (Binary.Binary a) => Scope -> FilePath -> a -> IO ()
|
||||
writeBinary (Scope workList) path value =
|
||||
do mvar <- newEmptyMVar
|
||||
_ <- forkIO (File.writeBinary path value >> putMVar mvar ())
|
||||
oldWork <- takeMVar workList
|
||||
let !newWork = mvar:oldWork
|
||||
putMVar workList newWork
|
||||
|
Loading…
Reference in New Issue
Block a user