src/Darcs/Global.lhs

   1 %  Copyright (C) 2005 Tomasz Zielonka
   2 %
   3 %  This program is free software; you can redistribute it and/or modify
   4 %  it under the terms of the GNU General Public License as published by
   5 %  the Free Software Foundation; either version 2, or (at your option)
   6 %  any later version.
   7 %
   8 %  This program is distributed in the hope that it will be useful,
   9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 %  GNU General Public License for more details.
  12 %
  13 %  You should have received a copy of the GNU General Public License
  14 %  along with this program; see the file COPYING.  If not, write to
  15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16 %  Boston, MA 02110-1301, USA.
  17
  18
  19 This was originally Tomasz Zielonka's AtExit module, slightly generalised
  20 to include global variables.  Here, we attempt to cover broad, global
  21 features, such as exit handlers.  These features slightly break the Haskellian
  22 purity of darcs, in favour of programming convenience.
  23
  24 \begin{code}
  25 module Darcs.Global ( atexit, with_atexit,
  26                       sshControlMasterDisabled, setSshControlMasterDisabled,
  27                       verboseMode, setVerboseMode,
  28                       timingsMode, setTimingsMode,
  29                       whenDebugMode, withDebugMode, setDebugMode,
  30                       debugMessage, debugFail, putTiming,
  31                       darcsdir
  32     ) where
  33
  34 import Control.Monad ( when )
  35 import Control.Concurrent.MVar
  36 import Control.Exception (bracket_, catch, block, unblock)
  37 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
  38 import System.IO.Unsafe (unsafePerformIO)
  39 import System.IO (hPutStrLn, hPutStr, stderr)
  40 import System.Time ( calendarTimeToString, toCalendarTime, getClockTime )
  41 import Prelude hiding (catch)
  42
  43 {-# NOINLINE atexit_actions #-}
  44 atexit_actions :: MVar (Maybe [IO ()])
  45 atexit_actions = unsafePerformIO (newMVar (Just []))
  46
  47 atexit :: IO () -> IO ()
  48 atexit action = do
  49     modifyMVar_ atexit_actions $ \ml -> do
  50         case ml of
  51             Just l -> do
  52                 return (Just (action : l))
  53             Nothing -> do
  54                 hPutStrLn stderr "It's too late to use atexit"
  55                 return Nothing
  56
  57 with_atexit :: IO a -> IO a
  58 with_atexit prog = do
  59     bracket_
  60         (return ())
  61         exit
  62         prog
  63   where
  64     exit = block $ do
  65         Just actions <- swapMVar atexit_actions Nothing
  66         -- from now on atexit will not register new actions
  67         mapM_ runAction actions
  68     runAction action = do
  69         catch (unblock action) $ \exn -> do
  70             hPutStrLn stderr $ "Exception thrown by an atexit registered action:"
  71             hPutStrLn stderr $ show exn
  72
  73 \end{code}
  74
  75 Write-once-read-many global variables make it easier to implement flags, such
  76 as --no-ssh-cm.  Using global variables reduces the number of parameters
  77 that we have to pass around, but it is rather unsafe and should be used sparingly.
  78
  79 \begin{code}
  80 {-# NOINLINE _debugMode #-}
  81 _debugMode :: IORef Bool
  82 _debugMode = unsafePerformIO $ newIORef False
  83
  84 setDebugMode :: IO ()
  85 setDebugMode = writeIORef _debugMode True
  86
  87 whenDebugMode :: IO () -> IO ()
  88 whenDebugMode j = do b <- readIORef _debugMode
  89                      when b j
  90
  91 withDebugMode :: (Bool -> IO a) -> IO a
  92 withDebugMode j = readIORef _debugMode >>= j
  93
  94
  95 debugMessage :: String -> IO ()
  96 debugMessage m = whenDebugMode $ do putTiming; hPutStrLn stderr m
  97
  98 debugFail :: String -> IO a
  99 debugFail m = debugMessage m >> fail m
 100
 101 putTiming :: IO ()
 102 putTiming = when timingsMode $ do t <- getClockTime >>= toCalendarTime
 103                                   hPutStr stderr (calendarTimeToString t++": ")
 104
 105 {-# NOINLINE _timingsMode #-}
 106 _timingsMode :: IORef Bool
 107 _timingsMode = unsafePerformIO $ newIORef False
 108
 109 setTimingsMode :: IO ()
 110 setTimingsMode = writeIORef _timingsMode True
 111
 112 {-# NOINLINE timingsMode #-}
 113 timingsMode :: Bool
 114 timingsMode = unsafePerformIO $ readIORef _timingsMode
 115
 116 {-# NOINLINE _verboseMode #-}
 117 _verboseMode :: IORef Bool
 118 _verboseMode = unsafePerformIO $ newIORef False
 119
 120 setVerboseMode :: IO ()
 121 setVerboseMode = writeIORef _verboseMode True
 122
 123 {-# NOINLINE verboseMode #-}
 124 verboseMode :: Bool
 125 verboseMode = unsafePerformIO $ readIORef _verboseMode
 126
 127 {-# NOINLINE _sshControlMasterDisabled #-}
 128 _sshControlMasterDisabled :: IORef Bool
 129 _sshControlMasterDisabled = unsafePerformIO $ newIORef False
 130
 131 setSshControlMasterDisabled :: IO ()
 132 setSshControlMasterDisabled = writeIORef _sshControlMasterDisabled True
 133
 134 {-# NOINLINE sshControlMasterDisabled #-}
 135 sshControlMasterDisabled :: Bool
 136 sshControlMasterDisabled = unsafePerformIO $ readIORef _sshControlMasterDisabled
 137
 138 darcsdir :: String
 139 darcsdir = "_darcs"
 140 \end{code}