% Copyright (C) 2005 Tomasz Zielonka
%
% This program is free software; you can redistribute it and/or modify
% it under the terms of the GNU General Public License as published by
% the Free Software Foundation; either version 2, or (at your option)
% any later version.
%
% This program is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
% GNU General Public License for more details.
%
% You should have received a copy of the GNU General Public License
% along with this program; see the file COPYING. If not, write to
% the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
% Boston, MA 02110-1301, USA.
This was originally Tomasz Zielonka's AtExit module, slightly generalised
to include global variables. Here, we attempt to cover broad, global
features, such as exit handlers. These features slightly break the Haskellian
purity of darcs, in favour of programming convenience.
\begin{code}
module Darcs.Global ( atexit, with_atexit,
sshControlMasterDisabled, setSshControlMasterDisabled,
verboseMode, setVerboseMode,
timingsMode, setTimingsMode,
whenDebugMode, withDebugMode, setDebugMode,
debugMessage, debugFail, putTiming,
darcsdir
) where
import Control.Monad ( when )
import Control.Concurrent.MVar
import Control.Exception (bracket_, catch, block, unblock)
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import System.IO.Unsafe (unsafePerformIO)
import System.IO (hPutStrLn, hPutStr, stderr)
import System.Time ( calendarTimeToString, toCalendarTime, getClockTime )
import Prelude hiding (catch)
{-# NOINLINE atexit_actions #-}
atexit_actions :: MVar (Maybe [IO ()])
atexit_actions = unsafePerformIO (newMVar (Just []))
atexit :: IO () -> IO ()
atexit action = do
modifyMVar_ atexit_actions $ \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
with_atexit :: IO a -> IO a
with_atexit prog = do
bracket_
(return ())
exit
prog
where
exit = block $ do
Just actions <- swapMVar atexit_actions Nothing
-- from now on atexit will not register new actions
mapM_ runAction actions
runAction action = do
catch (unblock action) $ \exn -> do
hPutStrLn stderr $ "Exception thrown by an atexit registered action:"
hPutStrLn stderr $ show exn
\end{code}
Write-once-read-many global variables make it easier to implement flags, such
as --no-ssh-cm. Using global variables reduces the number of parameters
that we have to pass around, but it is rather unsafe and should be used sparingly.
\begin{code}
{-# NOINLINE _debugMode #-}
_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++": ")
{-# NOINLINE _timingsMode #-}
_timingsMode :: IORef Bool
_timingsMode = unsafePerformIO $ newIORef False
setTimingsMode :: IO ()
setTimingsMode = writeIORef _timingsMode True
{-# NOINLINE timingsMode #-}
timingsMode :: Bool
timingsMode = unsafePerformIO $ readIORef _timingsMode
{-# NOINLINE _verboseMode #-}
_verboseMode :: IORef Bool
_verboseMode = unsafePerformIO $ newIORef False
setVerboseMode :: IO ()
setVerboseMode = writeIORef _verboseMode True
{-# NOINLINE verboseMode #-}
verboseMode :: Bool
verboseMode = unsafePerformIO $ readIORef _verboseMode
{-# NOINLINE _sshControlMasterDisabled #-}
_sshControlMasterDisabled :: IORef Bool
_sshControlMasterDisabled = unsafePerformIO $ newIORef False
setSshControlMasterDisabled :: IO ()
setSshControlMasterDisabled = writeIORef _sshControlMasterDisabled True
{-# NOINLINE sshControlMasterDisabled #-}
sshControlMasterDisabled :: Bool
sshControlMasterDisabled = unsafePerformIO $ readIORef _sshControlMasterDisabled
darcsdir :: String
darcsdir = "_darcs"
\end{code}