-- 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.

-- |
-- Module      : Darcs.Util.Global
-- Copyright   : 2005 Tomasz Zielonka
-- License     : GPL
-- Maintainer  : darcs-devel@darcs.net
-- Stability   : experimental
-- Portability : portable
--
-- 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.

module Darcs.Util.Global
    ( setTimingsMode
    , whenDebugMode
    , withDebugMode
    , setDebugMode
    , debugMessage
    , addCRCWarning
    , getCRCWarnings
    , resetCRCWarnings
    , darcsdir
    , darcsLastMessage
    , darcsSendMessage
    , darcsSendMessageFinal
    , defaultRemoteDarcsCmd
    ) where


import Darcs.Prelude

import Control.Monad ( when )
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
import Data.Time.Clock.System ( getSystemTime, systemToTAITime )
import Data.Time.Clock.TAI ( AbsoluteTime, diffAbsoluteTime )
import Data.Time.Format ( defaultTimeLocale, formatTime )
import System.FilePath.Posix ( combine, (<.>) )
import System.IO ( hPutStr, hPutStrLn, stderr )
import System.IO.Unsafe ( unsafePerformIO )


-- 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.


_debugMode :: IORef Bool
_debugMode :: IORef Bool
_debugMode = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (IO (IORef Bool) -> IORef Bool) -> IO (IORef Bool) -> IORef Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
{-# NOINLINE _debugMode #-}


setDebugMode :: IO ()
setDebugMode :: IO ()
setDebugMode = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
_debugMode Bool
True


whenDebugMode :: IO () -> IO ()
whenDebugMode :: IO () -> IO ()
whenDebugMode IO ()
j = do Bool
b <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
_debugMode
                     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b IO ()
j


withDebugMode :: (Bool -> IO a) -> IO a
withDebugMode :: forall a. (Bool -> IO a) -> IO a
withDebugMode Bool -> IO a
j = IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
_debugMode IO Bool -> (Bool -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO a
j


debugMessage :: String -> IO ()
debugMessage :: String -> IO ()
debugMessage String
m = IO () -> IO ()
whenDebugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do IO ()
putTiming; Handle -> String -> IO ()
hPutStrLn Handle
stderr String
m


putTiming :: IO ()
putTiming :: IO ()
putTiming = do
  IORef (Maybe AbsoluteTime) -> IO (Maybe AbsoluteTime)
forall a. IORef a -> IO a
readIORef IORef (Maybe AbsoluteTime)
_timingsMode IO (Maybe AbsoluteTime) -> (Maybe AbsoluteTime -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe AbsoluteTime
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just AbsoluteTime
start -> do
      AbsoluteTime
now <- SystemTime -> AbsoluteTime
systemToTAITime (SystemTime -> AbsoluteTime) -> IO SystemTime -> IO AbsoluteTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SystemTime
getSystemTime
      Handle -> String -> IO ()
hPutStr Handle
stderr (DiffTime -> String
format (AbsoluteTime -> AbsoluteTime -> DiffTime
diffAbsoluteTime AbsoluteTime
now AbsoluteTime
start))
  where
    -- mm:ss.micros, similar to `ts -s "%m:%.S"`
    format :: DiffTime -> String
format = TimeLocale -> String -> DiffTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%02m:%06ES "

_timingsMode :: IORef (Maybe AbsoluteTime)
_timingsMode :: IORef (Maybe AbsoluteTime)
_timingsMode = IO (IORef (Maybe AbsoluteTime)) -> IORef (Maybe AbsoluteTime)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Maybe AbsoluteTime)) -> IORef (Maybe AbsoluteTime))
-> IO (IORef (Maybe AbsoluteTime)) -> IORef (Maybe AbsoluteTime)
forall a b. (a -> b) -> a -> b
$ Maybe AbsoluteTime -> IO (IORef (Maybe AbsoluteTime))
forall a. a -> IO (IORef a)
newIORef Maybe AbsoluteTime
forall a. Maybe a
Nothing
{-# NOINLINE _timingsMode #-}

setTimingsMode :: IO ()
setTimingsMode :: IO ()
setTimingsMode = do
  AbsoluteTime
start <- SystemTime -> AbsoluteTime
systemToTAITime (SystemTime -> AbsoluteTime) -> IO SystemTime -> IO AbsoluteTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SystemTime
getSystemTime
  IORef (Maybe AbsoluteTime) -> Maybe AbsoluteTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe AbsoluteTime)
_timingsMode (AbsoluteTime -> Maybe AbsoluteTime
forall a. a -> Maybe a
Just AbsoluteTime
start)

type CRCWarningList = [FilePath]
_crcWarningList :: IORef CRCWarningList
_crcWarningList :: IORef CRCWarningList
_crcWarningList = IO (IORef CRCWarningList) -> IORef CRCWarningList
forall a. IO a -> a
unsafePerformIO (IO (IORef CRCWarningList) -> IORef CRCWarningList)
-> IO (IORef CRCWarningList) -> IORef CRCWarningList
forall a b. (a -> b) -> a -> b
$ CRCWarningList -> IO (IORef CRCWarningList)
forall a. a -> IO (IORef a)
newIORef []
{-# NOINLINE _crcWarningList #-}


addCRCWarning :: FilePath -> IO ()
addCRCWarning :: String -> IO ()
addCRCWarning String
fp = IORef CRCWarningList -> (CRCWarningList -> CRCWarningList) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef CRCWarningList
_crcWarningList (String
fpString -> CRCWarningList -> CRCWarningList
forall a. a -> [a] -> [a]
:)


getCRCWarnings :: IO [FilePath]
getCRCWarnings :: IO CRCWarningList
getCRCWarnings = IORef CRCWarningList -> IO CRCWarningList
forall a. IORef a -> IO a
readIORef IORef CRCWarningList
_crcWarningList


resetCRCWarnings :: IO ()
resetCRCWarnings :: IO ()
resetCRCWarnings = IORef CRCWarningList -> CRCWarningList -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef CRCWarningList
_crcWarningList []


darcsdir :: String
darcsdir :: String
darcsdir = String
"_darcs"

defaultRemoteDarcsCmd :: String
defaultRemoteDarcsCmd :: String
defaultRemoteDarcsCmd = String
"darcs"

darcsLastMessage :: String
darcsLastMessage :: String
darcsLastMessage = String -> String -> String
combine String
darcsdir String
"patch_description.txt"

darcsSendMessage :: String 
darcsSendMessage :: String
darcsSendMessage = String -> String -> String
combine String
darcsdir String
"darcs-send"

darcsSendMessageFinal :: String
darcsSendMessageFinal :: String
darcsSendMessageFinal = String
darcsSendMessage String -> String -> String
<.> String
"final"