diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/Inotify.hs | 32 |
1 files changed, 22 insertions, 10 deletions
diff --git a/Utility/Inotify.hs b/Utility/Inotify.hs index 2dcc1ed64..ff3de81b1 100644 --- a/Utility/Inotify.hs +++ b/Utility/Inotify.hs @@ -15,6 +15,7 @@ import qualified System.Posix.Files as Files import System.Posix.Terminal import Control.Concurrent.MVar import System.Posix.Signals +import Control.Exception as E type Hook = Maybe (FilePath -> IO ()) @@ -51,10 +52,13 @@ type Hook = Maybe (FilePath -> IO ()) watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> Hook -> Hook -> Hook -> Hook -> IO () watchDir i dir ignored add addsymlink del deldir | ignored dir = noop - | otherwise = void $ do - _ <- addWatch i watchevents dir go - mapM walk =<< filter (not . dirCruft) <$> - getDirectoryContents dir + | otherwise = do + mvar <- newEmptyMVar + void $ addWatch i watchevents dir $ \event -> + serialized mvar (void $ go event) + serialized mvar $ + mapM_ walk =<< filter (not . dirCruft) <$> + getDirectoryContents dir where recurse d = watchDir i d ignored add addsymlink del deldir @@ -117,14 +121,22 @@ watchDir i dir ignored add addsymlink del deldir filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f) +{- Uses an MVar to serialize an action, so that only one thread at a time + - runs it. -} +serialized :: MVar () -> IO () -> IO () +serialized mvar a = void $ do + putMVar mvar () -- blocks if action already running + _ <- E.try a :: IO (Either E.SomeException ()) + takeMVar mvar -- allow next action to run + {- Pauses the main thread, letting children run until program termination. -} waitForTermination :: IO () waitForTermination = do - mv <- newEmptyMVar - check softwareTermination mv + mvar <- newEmptyMVar + check softwareTermination mvar whenM (queryTerminal stdInput) $ - check keyboardSignal mv - takeMVar mv + check keyboardSignal mvar + takeMVar mvar where - check sig mv = void $ - installHandler sig (CatchOnce $ putMVar mv ()) Nothing + check sig mvar = void $ + installHandler sig (CatchOnce $ putMVar mvar ()) Nothing |