|
| 1 | +{-# LANGUAGE BangPatterns #-} |
| 2 | +{-# LANGUAGE FlexibleContexts #-} |
| 3 | +{-# OPTIONS_GHC -fno-warn-orphans #-} -- For MonadLogger IO instance |
1 | 4 | module Haskell.Ide.Engine.MonadFunctions |
2 | 5 | ( |
3 | 6 | -- * Logging functions |
4 | | - logm |
| 7 | + withStdoutLogging |
| 8 | + , withStderrLogging |
| 9 | + , withFileLogging |
| 10 | + , setLogLevel |
| 11 | + , setLogTimeFormat |
| 12 | + , logm |
5 | 13 | , debugm |
6 | 14 | ) where |
7 | 15 |
|
8 | | - |
9 | | -import Control.Logging |
10 | 16 | import Control.Monad.IO.Class |
| 17 | +import Control.Monad.Logger |
11 | 18 | import qualified Data.Text as T |
| 19 | +import Haskell.Ide.Engine.Monad() |
12 | 20 | import Prelude hiding (log) |
| 21 | +import Control.Exception.Lifted |
| 22 | +import Control.Monad |
| 23 | +import Control.Monad.Trans.Control |
| 24 | +import Data.IORef |
| 25 | +import Data.Monoid |
| 26 | +import Data.Text as T |
| 27 | +import Data.Time |
| 28 | +import Prelude hiding (log) |
| 29 | +import System.IO.Unsafe |
| 30 | +import System.Log.FastLogger |
13 | 31 |
|
14 | 32 | -- --------------------------------------------------------------------- |
15 | 33 |
|
16 | 34 | logm :: MonadIO m => String -> m () |
17 | | -logm s = liftIO $ log $ T.pack s |
| 35 | +logm s = do |
| 36 | + liftIO (logInfoN $ T.pack s) |
| 37 | + flushLog |
| 38 | + |
| 39 | +debugm :: MonadIO m => String -> m () |
| 40 | +debugm s = do |
| 41 | + liftIO $ logDebugN $ T.pack s |
| 42 | + flushLog |
| 43 | + |
| 44 | +-- --------------------------------------------------------------------- |
| 45 | + |
| 46 | +-- instance MonadLoggerIO IO where |
| 47 | +instance MonadLogger IO where |
| 48 | + monadLoggerLog loc src lvl msg = loggingLogger loc lvl src msg |
| 49 | + |
| 50 | +-- --------------------------------------------------------------------- |
| 51 | + |
| 52 | +{- |
| 53 | +From https://hackage.haskell.org/package/logging-3.0.2/docs/src/Control-Logging.html |
| 54 | +-} |
| 55 | + |
| 56 | + |
| 57 | +-- |Create a new global variable to hold the system-wide log level |
| 58 | +logLevel :: IORef LogLevel |
| 59 | +{-# NOINLINE logLevel #-} |
| 60 | +logLevel = unsafePerformIO $ newIORef LevelDebug |
| 61 | + |
| 62 | +-- | Set the global verbosity level. Messages at our higher than this level are |
| 63 | +-- displayed. It defaults to 'LevelDebug'. |
| 64 | +setLogLevel :: LogLevel -> IO () |
| 65 | +setLogLevel = atomicWriteIORef logLevel |
| 66 | + |
| 67 | +-- |Create a new global variable to hold the system-wide log output device |
| 68 | +logSet :: IORef LoggerSet |
| 69 | +{-# NOINLINE logSet #-} |
| 70 | +logSet = unsafePerformIO $ |
| 71 | + newIORef (error "Must call withStdoutLogging or withStderrLogging") |
| 72 | + |
| 73 | +-- |Create a new global variable to hold the system-wide log time format |
| 74 | +logTimeFormat :: IORef String |
| 75 | +{-# NOINLINE logTimeFormat #-} |
| 76 | +logTimeFormat = unsafePerformIO $ newIORef "%Y %b-%d %H:%M:%S%Q" |
| 77 | + |
| 78 | +-- | Set the global format used for log timestamps. |
| 79 | +setLogTimeFormat :: String -> IO () |
| 80 | +setLogTimeFormat = atomicWriteIORef logTimeFormat |
| 81 | + |
| 82 | +-- | This function, or 'withStderrLogging' or 'withFileLogging', must be wrapped |
| 83 | +-- around whatever region of your application will be alive for the duration |
| 84 | +-- that logging will be used. Typically it would be wrapped around the body of |
| 85 | +-- 'main'. |
| 86 | +withStdoutLogging :: (MonadBaseControl IO m, MonadIO m) => m a -> m a |
| 87 | +withStdoutLogging f = do |
| 88 | + liftIO $ do |
| 89 | + set <- newStdoutLoggerSet defaultBufSize |
| 90 | + atomicWriteIORef logSet set |
| 91 | + f `finally` flushLog |
| 92 | + |
| 93 | +withStderrLogging :: (MonadBaseControl IO m, MonadIO m) => m a -> m a |
| 94 | +withStderrLogging f = do |
| 95 | + liftIO $ do |
| 96 | + set <- newStderrLoggerSet defaultBufSize |
| 97 | + atomicWriteIORef logSet set |
| 98 | + f `finally` flushLog |
| 99 | + |
| 100 | +withFileLogging :: (MonadBaseControl IO m, MonadIO m) => FilePath -> m a -> m a |
| 101 | +withFileLogging path f = do |
| 102 | + liftIO $ do |
| 103 | + set <- newFileLoggerSet defaultBufSize path |
| 104 | + atomicWriteIORef logSet set |
| 105 | + f `finally` flushLog |
| 106 | + |
| 107 | +-- | Flush all collected logging messages. This is automatically called by |
| 108 | +-- 'withStdoutLogging', 'withStderrLogging' and 'withFileLogging' when those |
| 109 | +-- blocks are exited by whatever means. |
| 110 | +flushLog :: MonadIO m => m () |
| 111 | +flushLog = liftIO $ do |
| 112 | + set <- readIORef logSet |
| 113 | + flushLogStr set |
| 114 | + |
| 115 | +-- --------------------------------------------------------------------- |
| 116 | +-- Taken from Control.Monad.Logger source |
| 117 | + |
| 118 | + |
| 119 | +-- NOTE: general principle: a log line should not have more than one "\n" in it, |
| 120 | +-- else grepping the log becomes impossible. |
| 121 | +loggingLogger :: ToLogStr msg => Loc -> LogLevel -> LogSource -> msg -> IO () |
| 122 | +loggingLogger !loc !lvl !src str = do |
| 123 | + maxLvl <- readIORef logLevel |
| 124 | + when (lvl >= maxLvl) $ do |
| 125 | + let willLog = True |
| 126 | + when willLog $ do |
| 127 | + now <- getCurrentTime |
| 128 | + fmt <- readIORef logTimeFormat |
| 129 | + let stamp = formatTime defaultTimeLocale fmt now |
| 130 | + set <- readIORef logSet |
| 131 | + pushLogStr set |
| 132 | + $ toLogStr (stamp ++ " " ++ renderLevel lvl |
| 133 | + ++ " " ++ renderSource src) |
| 134 | + <> toLogStr str |
| 135 | + <> toLogStr locStr |
| 136 | + <> toLogStr (pack "\n") |
| 137 | + where |
| 138 | + renderSource :: Text -> String |
| 139 | + renderSource txt |
| 140 | + | T.null txt = "" |
| 141 | + | otherwise = unpack txt ++ ": " |
| 142 | + |
| 143 | + renderLevel LevelDebug = "[DEBUG]" |
| 144 | + renderLevel LevelInfo = "[INFO]" |
| 145 | + renderLevel LevelWarn = "[WARN]" |
| 146 | + renderLevel LevelError = "[ERROR]" |
| 147 | + renderLevel (LevelOther txt) = "[" ++ unpack txt ++ "]" |
| 148 | + |
| 149 | + locStr = |
| 150 | + if isDefaultLoc loc |
| 151 | + then "" |
| 152 | + else (" @(" ++ fileLocStr ++ ")" ) |
| 153 | + |
| 154 | + -- taken from file-location package |
| 155 | + -- turn the TH Loc loaction information into a human readable string |
| 156 | + -- leaving out the loc_end parameter |
| 157 | + fileLocStr = (loc_package loc) ++ ':' : (loc_module loc) ++ |
| 158 | + ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc) |
| 159 | + where |
| 160 | + line = show . fst . loc_start |
| 161 | + char = show . snd . loc_start |
18 | 162 |
|
19 | | -debugm :: MonadIO m =>String -> m () |
20 | | -debugm s = liftIO $ log $ T.pack s |
| 163 | +isDefaultLoc :: Loc -> Bool |
| 164 | +isDefaultLoc (Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0)) = True |
| 165 | +isDefaultLoc _ = False |
21 | 166 |
|
| 167 | +-- EOF |
0 commit comments