module Darcs.Global ( atexit, withAtexit,
sshControlMasterDisabled, setSshControlMasterDisabled,
timingsMode, setTimingsMode,
whenDebugMode, withDebugMode, setDebugMode,
debugMessage, debugFail, putTiming,
addCRCWarning, getCRCWarnings, resetCRCWarnings,
addBadSource, getBadSourcesList, isBadSource, darcsdir,
isReachableSource, addReachableSource
) where
import Control.Monad ( when )
import Control.Concurrent.MVar
import Control.Exception.Extensible (bracket_, catch, block, unblock, SomeException)
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import Data.IORef ( modifyIORef )
import System.IO.Unsafe (unsafePerformIO)
import System.IO (hPutStrLn, hPutStr, stderr)
import System.Time ( calendarTimeToString, toCalendarTime, getClockTime )
import Prelude hiding (catch)
atexitActions :: MVar (Maybe [IO ()])
atexitActions = unsafePerformIO (newMVar (Just []))
atexit :: IO () -> IO ()
atexit action = do
modifyMVar_ atexitActions $ \ml -> do
case ml of
Just l -> do
return (Just (action : l))
Nothing -> do
hPutStrLn stderr "It's too late to use atexit"
return Nothing
withAtexit :: IO a -> IO a
withAtexit prog = do
bracket_
(return ())
exit
prog
where
exit = block $ do
Just actions <- swapMVar atexitActions Nothing
mapM_ runAction actions
runAction action = do
catch (unblock action) $ \(exn :: SomeException) -> do
hPutStrLn stderr $ "Exception thrown by an atexit registered action:"
hPutStrLn stderr $ show exn
_debugMode :: IORef Bool
_debugMode = unsafePerformIO $ newIORef False
setDebugMode :: IO ()
setDebugMode = writeIORef _debugMode True
whenDebugMode :: IO () -> IO ()
whenDebugMode j = do b <- readIORef _debugMode
when b j
withDebugMode :: (Bool -> IO a) -> IO a
withDebugMode j = readIORef _debugMode >>= j
debugMessage :: String -> IO ()
debugMessage m = whenDebugMode $ do putTiming; hPutStrLn stderr m
debugFail :: String -> IO a
debugFail m = debugMessage m >> fail m
putTiming :: IO ()
putTiming = when timingsMode $ do t <- getClockTime >>= toCalendarTime
hPutStr stderr (calendarTimeToString t++": ")
_timingsMode :: IORef Bool
_timingsMode = unsafePerformIO $ newIORef False
setTimingsMode :: IO ()
setTimingsMode = writeIORef _timingsMode True
timingsMode :: Bool
timingsMode = unsafePerformIO $ readIORef _timingsMode
_sshControlMasterDisabled :: IORef Bool
_sshControlMasterDisabled = unsafePerformIO $ newIORef False
setSshControlMasterDisabled :: IO ()
setSshControlMasterDisabled = writeIORef _sshControlMasterDisabled True
sshControlMasterDisabled :: Bool
sshControlMasterDisabled = unsafePerformIO $ readIORef _sshControlMasterDisabled
type CRCWarningList = [FilePath]
_crcWarningList :: IORef CRCWarningList
_crcWarningList = unsafePerformIO $ newIORef []
addCRCWarning :: FilePath -> IO ()
addCRCWarning fp = modifyIORef _crcWarningList (fp:)
getCRCWarnings :: IO [FilePath]
getCRCWarnings = readIORef _crcWarningList
resetCRCWarnings :: IO ()
resetCRCWarnings = writeIORef _crcWarningList []
_badSourcesList :: IORef [String]
_badSourcesList = unsafePerformIO $ newIORef []
addBadSource :: String -> IO ()
addBadSource cache = modifyIORef _badSourcesList (cache:)
getBadSourcesList :: IO [String]
getBadSourcesList = readIORef _badSourcesList
isBadSource :: IO (String -> Bool)
isBadSource = do badSources <- getBadSourcesList
return (`elem` badSources)
_reachableSourcesList :: IORef [String]
_reachableSourcesList = unsafePerformIO $ newIORef []
addReachableSource :: String -> IO ()
addReachableSource src = modifyIORef _reachableSourcesList (src:)
getReachableSources :: IO [String]
getReachableSources = readIORef _reachableSourcesList
isReachableSource :: IO (String -> Bool)
isReachableSource = do reachableSources <- getReachableSources
return (`elem` reachableSources)
darcsdir :: String
darcsdir = "_darcs"