--
-- needs -package posix
--
-- The use of TH will break profiling. What can we do about this?
--

module Logging where

import MkTemp

import Prelude hiding (catch)

import Data.Char
import Data.Maybe

import qualified Debug.Trace

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad.State

import System.IO
import System.Time
import System.CPUTime
import System.Exit
import System.Environment
import System.IO.Unsafe

logState :: MVar (LogLevel, Maybe Logfile)
logState = unsafePerformIO (newMVar (Warn, Nothing))
{-# NOINLINE logState #-}

data LogLevel = Debug | Info | Warn | Fatal | Ignore
              deriving (Eq, Ord)

instance Show LogLevel where
    showsPrec _ Debug = (++) "DEBUG" 
    showsPrec _ Info  = (++) "INFO "
    showsPrec _ Warn  = (++) "WARN "
    showsPrec _ Fatal = (++) "FATAL"
    showsPrec _ Ignore = (++) "IGNORE"

levelFromString :: [Char] -> Maybe LogLevel
levelFromString s =
    let s' = map toLower s
        in case s' of 
             _ | s' == "debug" -> return Debug
               | s' == "info"  -> return Info
               | s' == "warn"  -> return Warn
               | s' == "fatal" -> return Fatal
               | s' == "ignore" -> return Ignore
               | otherwise     -> Nothing

type LineNumber = Int
type SourceLocation = (FilePath, LineNumber)
unknownLocation = ("?", 0)

data Logfile = Filename String
             | UseStderr

initLogging :: LogLevel -> Logfile -> IO ()
initLogging l f = 
    do swapMVar logState (l, Just f)
       return ()

formatTime :: IO String
formatTime =
    do clockT <- getClockTime
       CalendarTime year mon day hour min sec sdec 
           _ _ _ _ _ <- toCalendarTime clockT
       let mon' = case show ((fromEnum mon) + 1) of
                    c:[] -> '0':c:[]
                    s    -> s
           maxSdecLen = 5
           sdec' = if length (show sdec) > maxSdecLen
                      then take maxSdecLen (show sdec)
                      else show sdec
       return $ (show year) ++ "-" ++
                (show day)  ++ " " ++
                (show hour) ++ ":" ++
                (show min)  ++ ":" ++
                (show sec)  ++ ":" ++
                sdec'

{-
defaultLogFileName :: IO [Char]
defaultLogFileName =
    do pid <- getProcessID      -- not portable
       return (pname ++ "_" ++ show pid ++ ".log")
-}

defaultLogFileName :: IO FilePath
defaultLogFileName = do
        pname <- getProgName
        mf    <- mkstemps (pname ++ "XXXXXX" ++ ".log") 4{-length ".log"-}
        case mf of
                Nothing    -> error "Unable to create log file"
                Just (f,h) -> hClose h >> return f

niceError_ :: SourceLocation -> String -> a
niceError_ (fname, lineno) s =
    let msg = fname ++ ":" ++ show lineno ++ ": " ++ s
        in error msg

dtrace_ :: SourceLocation -> String -> a -> a
dtrace_ (fname, lineno) s x =
    let msg = fname ++ ":" ++ show lineno ++ ": " ++ s
        in Debug.Trace.trace msg x

toStderr :: MonadIO m => String -> m ()
toStderr s = liftIO $ hPutStrLn stderr s

debug_ :: MonadIO m => SourceLocation -> String -> m ()
debug_ loc s = liftIO $ log_ loc Debug s
info_ :: MonadIO m => SourceLocation -> String -> m ()
info_ loc s = liftIO $ log_ loc Info s
warn_ :: MonadIO m => SourceLocation -> String -> m ()
warn_ loc s = liftIO $ log_ loc Warn s
fatal_ :: MonadIO m => SourceLocation -> String -> m a
fatal_ loc s = liftIO $
    do log_ loc Fatal s
       error ("FATAL ERROR: " ++ s)

log_ :: SourceLocation -> LogLevel -> String -> IO ()
log_ loc level s = 
    do withMVar logState
          (\ (thresh, logF) ->
           (if level >= thresh
               then doLogging logF loc level s
               else return ()) `catch` (\e -> return ()))

doLogging :: (Show b) =>
	     Maybe Logfile -> ([Char], b) -> LogLevel -> [Char] -> IO ()
doLogging logF loc level s =
    do tid <- myThreadId
       time <- formatTime
       let fname = fst loc
           lineno = snd loc

       let msg = "[" ++ show level ++
                  " " ++ fname ++
                  ":" ++ show lineno ++
                  ", "++ show tid    ++
                  ", "++ time   ++ 
                  "] "++ s

       handle <- 
           case logF of
             Just (Filename name) -> openLogfile name AppendMode
             Just UseStderr       -> return Nothing
             Nothing  -> do hPutStrLn stderr ("Logging not initialized")
                            return Nothing
       case handle of
         Just h  -> do hPutStrLn h msg
                       hFlush h
                       hClose h
                       if level >= Warn
                          then hPutStrLn stderr msg
                          else return ()
         Nothing -> do hPutStrLn stderr msg
                       hFlush stderr
       return ()
    where openLogfile name mode = 
              do h <- openFile name mode
                 return $ Just h
              `catch`
              (\e -> do hPutStrLn stderr $
                                "Error opening logfile "++ show name ++ 
                                " for writing: " ++ show e
                        return Nothing)

------------------------------------------------------------------------
-- Time a computation
--
time :: (MonadIO m) => LogLevel -> String -> m a -> m a
time level s a = do
        start <- liftIO $ getCPUTime
        v <- a
        end   <- liftIO $ getCPUTime
        let diff = (fromIntegral (end - start)) / (10^12)
        liftIO $ log_ unknownLocation level 
                   ("Computation time for " ++ s ++ ": " ++ (show diff) ++ 
                    " sec")
        return v

{-
time a = do
        start <- liftIO $ getClockTime
        a
        end   <- liftIO $ getClocktime
        let d = diffClockTimes end start
            s = timeDiffToString d
            s'= s ++ (tdPicosec d) ++ "ms"
-}