1{-# LANGUAGE CPP #-} 2{-# LANGUAGE GeneralizedNewtypeDeriving #-} 3{-# LANGUAGE DefaultSignatures #-} 4{-# LANGUAGE StandaloneDeriving #-} 5#if WITH_CALLSTACK 6{-# LANGUAGE ImplicitParams #-} 7#endif 8#if WITH_TEMPLATE_HASKELL 9{-# LANGUAGE TemplateHaskell #-} 10#endif 11{-# LANGUAGE TypeFamilies #-} 12{-# LANGUAGE FlexibleContexts #-} 13{-# LANGUAGE FlexibleInstances #-} 14{-# LANGUAGE MultiParamTypeClasses #-} 15{-# LANGUAGE OverloadedStrings #-} 16{-# LANGUAGE UndecidableInstances #-} 17{-# LANGUAGE Trustworthy #-} 18{-# LANGUAGE TupleSections #-} 19-- | This module provides the facilities needed for a decoupled logging system. 20-- 21-- The 'MonadLogger' class is implemented by monads that give access to a 22-- logging facility. If you're defining a custom monad, then you may define an 23-- instance of 'MonadLogger' that routes the log messages to the appropriate 24-- place (e.g., that's what @yesod-core@'s @HandlerT@ does). Otherwise, you 25-- may use the 'LoggingT' monad included in this module (see 26-- 'runStderrLoggingT'). To simply discard log message, use 'NoLoggingT'. 27-- 28-- As a user of the logging facility, we provide you some convenient Template 29-- Haskell splices that use the 'MonadLogger' class. They will record their 30-- source file and position, which is very helpful when debugging. See 31-- 'logDebug' for more information. 32module Control.Monad.Logger 33 ( -- * MonadLogger 34 MonadLogger(..) 35 , MonadLoggerIO (..) 36 , LogLevel(..) 37 , LogSource 38 -- * Re-export from fast-logger 39 , LogStr 40 , ToLogStr(..) 41 , fromLogStr 42 -- * Helper transformers 43 , LoggingT (..) 44 , runStderrLoggingT 45 , runStdoutLoggingT 46 , runChanLoggingT 47 , runFileLoggingT 48 , unChanLoggingT 49 , withChannelLogger 50 , filterLogger 51 , NoLoggingT (..) 52 , mapNoLoggingT 53 , WriterLoggingT (..) 54 , execWriterLoggingT 55 , runWriterLoggingT 56 , mapLoggingT 57#if WITH_TEMPLATE_HASKELL 58 -- * TH logging 59 , logDebug 60 , logInfo 61 , logWarn 62 , logError 63 , logOther 64 -- * TH logging of showable values 65 , logDebugSH 66 , logInfoSH 67 , logWarnSH 68 , logErrorSH 69 , logOtherSH 70 -- * TH logging with source 71 , logDebugS 72 , logInfoS 73 , logWarnS 74 , logErrorS 75 , logOtherS 76 -- * TH util 77 , liftLoc 78#endif 79 -- * Non-TH logging 80 , logDebugN 81 , logInfoN 82 , logWarnN 83 , logErrorN 84 , logOtherN 85 -- * Non-TH logging with source 86 , logWithoutLoc 87 , logDebugNS 88 , logInfoNS 89 , logWarnNS 90 , logErrorNS 91 , logOtherNS 92#if WITH_CALLSTACK 93 -- * Callstack logging 94 , logDebugCS 95 , logInfoCS 96 , logWarnCS 97 , logErrorCS 98 , logOtherCS 99#endif 100 -- * utilities for defining your own loggers 101 , defaultLogStr 102 , Loc (..) 103 , defaultLoc 104 ) where 105 106#if WITH_TEMPLATE_HASKELL 107import Language.Haskell.TH.Syntax (Lift (lift), Q, Exp, Loc (..), qLocation) 108#endif 109 110import Data.Functor ((<$>)) 111import Data.Monoid (Monoid) 112 113import Control.Applicative (Applicative (..), WrappedMonad(..)) 114import Control.Concurrent.Chan (Chan(),writeChan,readChan) 115import Control.Concurrent.STM 116import Control.Concurrent.STM.TBChan 117import Control.Exception.Lifted (onException, bracket) 118import Control.Monad (liftM, when, void, forever) 119import Control.Monad.Base (MonadBase (liftBase), liftBaseDefault) 120#if MIN_VERSION_base(4, 9, 0) 121import qualified Control.Monad.Fail as Fail 122#endif 123import Control.Monad.IO.Unlift 124import Control.Monad.Loops (untilM) 125import Control.Monad.Trans.Control (MonadBaseControl (..), MonadTransControl (..), ComposeSt, defaultLiftBaseWith, defaultRestoreM) 126import qualified Control.Monad.Trans.Class as Trans 127 128import Control.Monad.IO.Class (MonadIO (liftIO)) 129import Control.Monad.Trans.Resource (MonadResource (liftResourceT)) 130import Control.Monad.Catch (MonadThrow (..), MonadCatch (..), MonadMask (..) 131#if MIN_VERSION_exceptions(0, 10, 0) 132 , ExitCase (..) 133#endif 134 ) 135 136import Control.Monad.Trans.Identity ( IdentityT) 137import Control.Monad.Trans.List ( ListT ) 138import Control.Monad.Trans.Maybe ( MaybeT ) 139import Control.Monad.Trans.Error ( ErrorT, Error) 140import Control.Monad.Trans.Except ( ExceptT ) 141 142import Control.Monad.Trans.Reader ( ReaderT ) 143import Control.Monad.Trans.Cont ( ContT ) 144import Control.Monad.Trans.State ( StateT ) 145import Control.Monad.Trans.Writer ( WriterT ) 146import Control.Monad.Trans.RWS ( RWST ) 147import Control.Monad.Trans.Resource ( ResourceT) 148import Data.Conduit.Internal ( Pipe, ConduitM ) 149 150import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) 151import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) 152import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) 153 154import Data.Text (Text, pack, unpack) 155import qualified Data.Text as T 156import qualified Data.ByteString.Char8 as S8 157 158import Data.Monoid (mappend, mempty) 159import System.Log.FastLogger 160import System.IO (Handle, IOMode(AppendMode), BufferMode(LineBuffering), openFile, hClose, hSetBuffering, stdout, stderr) 161 162import Control.Monad.Cont.Class ( MonadCont (..) ) 163import Control.Monad.Error.Class ( MonadError (..) ) 164import Control.Monad.RWS.Class ( MonadRWS ) 165import Control.Monad.Reader.Class ( MonadReader (..) ) 166import Control.Monad.State.Class ( MonadState (..) ) 167import Control.Monad.Writer.Class ( MonadWriter (..) ) 168 169#if WITH_CALLSTACK 170import GHC.Stack as GHC 171#endif 172 173import Data.Conduit.Lazy (MonadActive, monadActive) 174 175data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text 176 deriving (Eq, Prelude.Show, Prelude.Read, Ord) 177 178type LogSource = Text 179 180#if WITH_TEMPLATE_HASKELL 181 182instance Lift LogLevel where 183 lift LevelDebug = [|LevelDebug|] 184 lift LevelInfo = [|LevelInfo|] 185 lift LevelWarn = [|LevelWarn|] 186 lift LevelError = [|LevelError|] 187 lift (LevelOther x) = [|LevelOther $ pack $(lift $ unpack x)|] 188 189#else 190 191data Loc 192 = Loc { loc_filename :: String 193 , loc_package :: String 194 , loc_module :: String 195 , loc_start :: CharPos 196 , loc_end :: CharPos } 197type CharPos = (Int, Int) 198 199#endif 200 201-- | A @Monad@ which has the ability to log messages in some manner. 202class Monad m => MonadLogger m where 203 monadLoggerLog :: ToLogStr msg => Loc -> LogSource -> LogLevel -> msg -> m () 204 default monadLoggerLog :: (MonadLogger m', Trans.MonadTrans t, MonadLogger (t m'), ToLogStr msg, m ~ t m') 205 => Loc -> LogSource -> LogLevel -> msg -> m () 206 monadLoggerLog loc src lvl msg = Trans.lift $ monadLoggerLog loc src lvl msg 207 208-- | An extension of @MonadLogger@ for the common case where the logging action 209-- is a simple @IO@ action. The advantage of using this typeclass is that the 210-- logging function itself can be extracted as a first-class value, which can 211-- make it easier to manipulate monad transformer stacks, as an example. 212-- 213-- @since 0.3.10 214class (MonadLogger m, MonadIO m) => MonadLoggerIO m where 215 -- | Request the logging function itself. 216 -- 217 -- @since 0.3.10 218 askLoggerIO :: m (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) 219 default askLoggerIO :: (Trans.MonadTrans t, MonadLoggerIO n, m ~ t n) 220 => m (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) 221 askLoggerIO = Trans.lift askLoggerIO 222 223 224{- 225instance MonadLogger IO where monadLoggerLog _ _ _ = return () 226instance MonadLogger Identity where monadLoggerLog _ _ _ = return () 227instance MonadLogger (ST s) where monadLoggerLog _ _ _ = return () 228instance MonadLogger (Lazy.ST s) where monadLoggerLog _ _ _ = return () 229-} 230 231#define DEF monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d 232instance MonadLogger m => MonadLogger (IdentityT m) where DEF 233instance MonadLogger m => MonadLogger (ListT m) where DEF 234instance MonadLogger m => MonadLogger (MaybeT m) where DEF 235instance (MonadLogger m, Error e) => MonadLogger (ErrorT e m) where DEF 236instance MonadLogger m => MonadLogger (ExceptT e m) where DEF 237instance MonadLogger m => MonadLogger (ReaderT r m) where DEF 238instance MonadLogger m => MonadLogger (ContT r m) where DEF 239instance MonadLogger m => MonadLogger (StateT s m) where DEF 240instance (MonadLogger m, Monoid w) => MonadLogger (WriterT w m) where DEF 241instance (MonadLogger m, Monoid w) => MonadLogger (RWST r w s m) where DEF 242instance MonadLogger m => MonadLogger (ResourceT m) where DEF 243instance MonadLogger m => MonadLogger (Pipe l i o u m) where DEF 244instance MonadLogger m => MonadLogger (ConduitM i o m) where DEF 245instance MonadLogger m => MonadLogger (Strict.StateT s m) where DEF 246instance (MonadLogger m, Monoid w) => MonadLogger (Strict.WriterT w m) where DEF 247instance (MonadLogger m, Monoid w) => MonadLogger (Strict.RWST r w s m) where DEF 248#undef DEF 249 250instance MonadLoggerIO m => MonadLoggerIO (IdentityT m) 251instance MonadLoggerIO m => MonadLoggerIO (ListT m) 252instance MonadLoggerIO m => MonadLoggerIO (MaybeT m) 253instance (MonadLoggerIO m, Error e) => MonadLoggerIO (ErrorT e m) 254instance MonadLoggerIO m => MonadLoggerIO (ExceptT e m) 255instance MonadLoggerIO m => MonadLoggerIO (ReaderT r m) 256instance MonadLoggerIO m => MonadLoggerIO (ContT r m) 257instance MonadLoggerIO m => MonadLoggerIO (StateT s m) 258instance (MonadLoggerIO m, Monoid w) => MonadLoggerIO (WriterT w m) 259instance (MonadLoggerIO m, Monoid w) => MonadLoggerIO (RWST r w s m) 260instance MonadLoggerIO m => MonadLoggerIO (ResourceT m) 261instance MonadLoggerIO m => MonadLoggerIO (Pipe l i o u m) 262instance MonadLoggerIO m => MonadLoggerIO (ConduitM i o m) 263instance MonadLoggerIO m => MonadLoggerIO (Strict.StateT s m) 264instance (MonadLoggerIO m, Monoid w) => MonadLoggerIO (Strict.WriterT w m) 265instance (MonadLoggerIO m, Monoid w) => MonadLoggerIO (Strict.RWST r w s m) 266 267#if WITH_TEMPLATE_HASKELL 268logTH :: LogLevel -> Q Exp 269logTH level = 270 [|monadLoggerLog $(qLocation >>= liftLoc) (pack "") $(lift level) 271 . (id :: Text -> Text)|] 272 273-- | Generates a function that takes a 'LogLevel' and a 'Show a => a'. 274-- 275-- @since 0.3.18 276logTHShow :: LogLevel -> Q Exp 277logTHShow level = 278 [|monadLoggerLog $(qLocation >>= liftLoc) (pack "") $(lift level) 279 . ((pack . show) :: Show a => a -> Text)|] 280 281-- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage: 282-- 283-- > $(logDebug) "This is a debug log message" 284logDebug :: Q Exp 285logDebug = logTH LevelDebug 286 287-- | See 'logDebug' 288logInfo :: Q Exp 289logInfo = logTH LevelInfo 290-- | See 'logDebug' 291logWarn :: Q Exp 292logWarn = logTH LevelWarn 293-- | See 'logDebug' 294logError :: Q Exp 295logError = logTH LevelError 296 297-- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage: 298-- 299-- > $(logOther "My new level") "This is a log message" 300logOther :: Text -> Q Exp 301logOther = logTH . LevelOther 302 303 304-- | Generates a function that takes a 'Show a => a' and logs a 'LevelDebug' message. Usage: 305-- 306-- > $(logDebugSH) (Just "This is a debug log message") 307-- 308-- @since 0.3.18 309logDebugSH :: Q Exp 310logDebugSH = logTHShow LevelDebug 311 312-- | See 'logDebugSH' 313logInfoSH :: Q Exp 314logInfoSH = logTHShow LevelInfo 315-- | See 'logDebugSH' 316logWarnSH :: Q Exp 317logWarnSH = logTHShow LevelWarn 318-- | See 'logDebugSH' 319logErrorSH :: Q Exp 320logErrorSH = logTHShow LevelError 321 322-- | Generates a function that takes a 'Show a => a' and logs a 'LevelOther' message. Usage: 323-- 324-- > $(logOtherSH "My new level") "This is a log message" 325logOtherSH :: Text -> Q Exp 326logOtherSH = logTHShow . LevelOther 327 328-- | Lift a location into an Exp. 329-- 330-- @since 0.3.1 331liftLoc :: Loc -> Q Exp 332liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc 333 $(lift a) 334 $(lift b) 335 $(lift c) 336 ($(lift d1), $(lift d2)) 337 ($(lift e1), $(lift e2)) 338 |] 339 340-- | Generates a function that takes a 'LogSource' and 'Text' and logs a 'LevelDebug' message. Usage: 341-- 342-- > $logDebugS "SomeSource" "This is a debug log message" 343logDebugS :: Q Exp 344logDebugS = [|\a b -> monadLoggerLog $(qLocation >>= liftLoc) a LevelDebug (b :: Text)|] 345 346-- | See 'logDebugS' 347logInfoS :: Q Exp 348logInfoS = [|\a b -> monadLoggerLog $(qLocation >>= liftLoc) a LevelInfo (b :: Text)|] 349-- | See 'logDebugS' 350logWarnS :: Q Exp 351logWarnS = [|\a b -> monadLoggerLog $(qLocation >>= liftLoc) a LevelWarn (b :: Text)|] 352-- | See 'logDebugS' 353logErrorS :: Q Exp 354logErrorS = [|\a b -> monadLoggerLog $(qLocation >>= liftLoc) a LevelError (b :: Text)|] 355 356-- | Generates a function that takes a 'LogSource', a level name and a 'Text' and logs a 'LevelOther' message. Usage: 357-- 358-- > $logOtherS "SomeSource" "My new level" "This is a log message" 359logOtherS :: Q Exp 360logOtherS = [|\src level msg -> monadLoggerLog $(qLocation >>= liftLoc) src (LevelOther level) (msg :: Text)|] 361#endif 362 363-- | Monad transformer that disables logging. 364-- 365-- @since 0.2.4 366newtype NoLoggingT m a = NoLoggingT { runNoLoggingT :: m a } 367 deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadActive, MonadBase b) 368 369-- For some reason GND is a fool on GHC 7.10 and older, we have to help it by providing the context explicitly. 370deriving instance MonadResource m => MonadResource (NoLoggingT m) 371 372instance MonadActive m => MonadActive (LoggingT m) where 373 monadActive = Trans.lift monadActive 374 375instance Trans.MonadTrans NoLoggingT where 376 lift = NoLoggingT 377 378instance MonadTransControl NoLoggingT where 379 type StT NoLoggingT a = a 380 liftWith f = NoLoggingT $ f runNoLoggingT 381 restoreT = NoLoggingT 382 {-# INLINE liftWith #-} 383 {-# INLINE restoreT #-} 384 385#if MIN_VERSION_base(4, 9, 0) 386-- | @since 0.3.30 387instance (Fail.MonadFail m) => Fail.MonadFail (NoLoggingT m) where 388 fail = Trans.lift . Fail.fail 389#endif 390 391instance MonadBaseControl b m => MonadBaseControl b (NoLoggingT m) where 392 type StM (NoLoggingT m) a = StM m a 393 liftBaseWith f = NoLoggingT $ 394 liftBaseWith $ \runInBase -> 395 f $ runInBase . runNoLoggingT 396 restoreM = NoLoggingT . restoreM 397 398instance Monad m => MonadLogger (NoLoggingT m) where 399 monadLoggerLog _ _ _ _ = return () 400instance MonadIO m => MonadLoggerIO (NoLoggingT m) where 401 askLoggerIO = return $ \_ _ _ _ -> return () 402 403-- | @since 0.3.26 404instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where 405 {-# INLINE withRunInIO #-} 406 withRunInIO inner = 407 NoLoggingT $ 408 withRunInIO $ \run -> 409 inner (run . runNoLoggingT) 410 411-- | @since 0.3.28 412type LogLine = (Loc, LogSource, LogLevel, LogStr) 413 414-- | @since 0.3.28 415newtype WriterLoggingT m a = WriterLoggingT { unWriterLoggingT :: m (a, DList LogLine) } 416 417-- | Simple implementation of a difference list to support WriterLoggingT 418newtype DList a = DList { unDList :: [a] -> [a] } 419 420emptyDList :: DList a 421emptyDList = DList id 422 423singleton :: a -> DList a 424singleton = DList . (:) 425 426dListToList :: DList a -> [a] 427dListToList (DList dl) = dl [] 428 429appendDList :: DList a -> DList a -> DList a 430appendDList dl1 dl2 = DList (unDList dl1 . unDList dl2) 431 432-- | Run a block using a @MonadLogger@ instance. Return a value and logs in a list 433-- | @since 0.3.28 434runWriterLoggingT :: Functor m => WriterLoggingT m a -> m (a, [LogLine]) 435runWriterLoggingT (WriterLoggingT ma) = fmap dListToList <$> ma 436 437-- | Run a block using a @MonadLogger@ instance. Return logs in a list 438-- | @since 0.3.28 439execWriterLoggingT :: Functor m => WriterLoggingT m a -> m [LogLine] 440execWriterLoggingT ma = snd <$> runWriterLoggingT ma 441 442instance Monad m => Monad (WriterLoggingT m) where 443 return = unwrapMonad . pure 444 (WriterLoggingT ma) >>= f = WriterLoggingT $ do 445 (a, msgs) <- ma 446 (a', msgs') <- unWriterLoggingT $ f a 447 return (a', appendDList msgs msgs') 448 449instance Applicative m => Applicative (WriterLoggingT m) where 450 pure a = WriterLoggingT . pure $ (a, emptyDList) 451 WriterLoggingT mf <*> WriterLoggingT ma = WriterLoggingT $ 452 fmap (\((f, msgs), (a, msgs')) -> (f a, appendDList msgs msgs')) ((,) <$> mf <*> ma) 453 454instance Functor m => Functor (WriterLoggingT m) where 455 fmap f (WriterLoggingT ma) = WriterLoggingT $ 456 fmap (\(a, msgs) -> (f a, msgs)) ma 457 458instance Monad m => MonadLogger (WriterLoggingT m) where 459 monadLoggerLog loc source level msg = WriterLoggingT . return $ ((), singleton (loc, source, level, toLogStr msg)) 460 461 462instance Trans.MonadTrans WriterLoggingT where 463 lift ma = WriterLoggingT $ (, emptyDList) `liftM` ma 464 465instance MonadIO m => MonadIO (WriterLoggingT m) where 466 liftIO ioa = WriterLoggingT $ (, emptyDList) `liftM` liftIO ioa 467 468instance MonadBase b m => MonadBase b (WriterLoggingT m) where 469 liftBase = liftBaseDefault 470 471instance MonadTransControl WriterLoggingT where 472 type StT WriterLoggingT a = (a, DList LogLine) 473 liftWith f = WriterLoggingT $ liftM (\x -> (x, emptyDList)) 474 (f $ unWriterLoggingT) 475 restoreT = WriterLoggingT 476 477instance MonadBaseControl b m => MonadBaseControl b (WriterLoggingT m) where 478 type StM (WriterLoggingT m) a = ComposeSt WriterLoggingT m a 479 liftBaseWith = defaultLiftBaseWith 480 restoreM = defaultRestoreM 481 482instance MonadThrow m => MonadThrow (WriterLoggingT m) where 483 throwM = Trans.lift . throwM 484 485instance MonadCatch m => MonadCatch (WriterLoggingT m) where 486 catch (WriterLoggingT m) c = 487 WriterLoggingT $ m `catch` \e -> unWriterLoggingT (c e) 488 489instance MonadMask m => MonadMask (WriterLoggingT m) where 490 mask a = WriterLoggingT $ (mask $ \ u -> unWriterLoggingT (a $ q u)) 491 where q u b = WriterLoggingT $ u (unWriterLoggingT b) 492 493 uninterruptibleMask a = WriterLoggingT $ uninterruptibleMask $ \u -> unWriterLoggingT (a $ q u) 494 where q u b = WriterLoggingT $ u (unWriterLoggingT b) 495 496#if MIN_VERSION_exceptions(0, 10, 0) 497 generalBracket acquire release use = WriterLoggingT $ do 498 ((b, _w12), (c, w123)) <- generalBracket 499 (unWriterLoggingT acquire) 500 (\(resource, w1) exitCase -> case exitCase of 501 ExitCaseSuccess (b, w12) -> do 502 (c, w3) <- unWriterLoggingT (release resource (ExitCaseSuccess b)) 503 return (c, appendDList w12 w3) 504 -- In the two other cases, the base monad overrides @use@'s state 505 -- changes and the state reverts to @w1@. 506 ExitCaseException e -> do 507 (c, w3) <- unWriterLoggingT (release resource (ExitCaseException e)) 508 return (c, appendDList w1 w3) 509 ExitCaseAbort -> do 510 (c, w3) <- unWriterLoggingT (release resource ExitCaseAbort) 511 return (c, appendDList w1 w3)) 512 (\(resource, w1) -> do 513 (a, w2) <- unWriterLoggingT (use resource) 514 return (a, appendDList w1 w2)) 515 return ((b, c), w123) 516#elif MIN_VERSION_exceptions(0, 9, 0) 517 generalBracket acquire release releaseEx use = 518 WriterLoggingT $ generalBracket 519 (unWriterLoggingT acquire) 520 (\(x, w1) -> do 521 (y, w2) <- unWriterLoggingT (release x) 522 return (y, appendDList w1 w2)) 523 (\(x, w1) ex -> do 524 (y, w2) <- unWriterLoggingT (releaseEx x ex) 525 return (y, appendDList w1 w2)) 526 (\(x, w1) -> do 527 (y, w2) <- unWriterLoggingT (use x) 528 return (y, appendDList w1 w2)) 529#endif 530 531-- | Monad transformer that adds a new logging function. 532-- 533-- @since 0.2.2 534newtype LoggingT m a = LoggingT { runLoggingT :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a } 535 536#if __GLASGOW_HASKELL__ < 710 537instance Monad m => Functor (LoggingT m) where 538 fmap = liftM 539 540instance Monad m => Applicative (LoggingT m) where 541 pure = return 542 (<*>) = ap 543#else 544instance Functor m => Functor (LoggingT m) where 545 fmap f logger = LoggingT $ \loggerFn -> fmap f $ (runLoggingT logger) loggerFn 546 {-# INLINE fmap #-} 547 548instance Applicative m => Applicative (LoggingT m) where 549 pure = LoggingT . const . pure 550 {-# INLINE pure #-} 551 loggerF <*> loggerA = LoggingT $ \loggerFn -> 552 (runLoggingT loggerF) loggerFn 553 <*> (runLoggingT loggerA) loggerFn 554 {-# INLINE (<*>) #-} 555#endif 556 557#if MIN_VERSION_base(4, 9, 0) 558-- | @since 0.3.30 559instance (Fail.MonadFail m) => Fail.MonadFail (LoggingT m) where 560 fail = Trans.lift . Fail.fail 561#endif 562 563instance Monad m => Monad (LoggingT m) where 564 return = LoggingT . const . return 565 LoggingT ma >>= f = LoggingT $ \r -> do 566 a <- ma r 567 let LoggingT f' = f a 568 f' r 569 570instance MonadIO m => MonadIO (LoggingT m) where 571 liftIO = Trans.lift . liftIO 572 573instance MonadThrow m => MonadThrow (LoggingT m) where 574 throwM = Trans.lift . throwM 575instance MonadCatch m => MonadCatch (LoggingT m) where 576 catch (LoggingT m) c = 577 LoggingT $ \r -> m r `catch` \e -> runLoggingT (c e) r 578instance MonadMask m => MonadMask (LoggingT m) where 579 mask a = LoggingT $ \e -> mask $ \u -> runLoggingT (a $ q u) e 580 where q u (LoggingT b) = LoggingT (u . b) 581 uninterruptibleMask a = 582 LoggingT $ \e -> uninterruptibleMask $ \u -> runLoggingT (a $ q u) e 583 where q u (LoggingT b) = LoggingT (u . b) 584#if MIN_VERSION_exceptions(0, 10, 0) 585 generalBracket acquire release use = 586 LoggingT $ \e -> generalBracket 587 (runLoggingT acquire e) 588 (\x ec -> runLoggingT (release x ec) e) 589 (\x -> runLoggingT (use x) e) 590#elif MIN_VERSION_exceptions(0, 9, 0) 591 generalBracket acquire release releaseEx use = 592 LoggingT $ \e -> generalBracket 593 (runLoggingT acquire e) 594 (\x -> runLoggingT (release x) e) 595 (\x y -> runLoggingT (releaseEx x y) e) 596 (\x -> runLoggingT (use x) e) 597#endif 598 599instance MonadResource m => MonadResource (LoggingT m) where 600 liftResourceT = Trans.lift . liftResourceT 601 602instance MonadBase b m => MonadBase b (LoggingT m) where 603 liftBase = Trans.lift . liftBase 604 605instance Trans.MonadTrans LoggingT where 606 lift = LoggingT . const 607 608instance MonadTransControl LoggingT where 609 type StT LoggingT a = a 610 liftWith f = LoggingT $ \r -> f $ \(LoggingT t) -> t r 611 restoreT = LoggingT . const 612 {-# INLINE liftWith #-} 613 {-# INLINE restoreT #-} 614 615instance MonadBaseControl b m => MonadBaseControl b (LoggingT m) where 616 type StM (LoggingT m) a = StM m a 617 liftBaseWith f = LoggingT $ \reader' -> 618 liftBaseWith $ \runInBase -> 619 f $ runInBase . (\(LoggingT r) -> r reader') 620 restoreM = LoggingT . const . restoreM 621 622instance MonadIO m => MonadLogger (LoggingT m) where 623 monadLoggerLog a b c d = LoggingT $ \f -> liftIO $ f a b c (toLogStr d) 624instance MonadIO m => MonadLoggerIO (LoggingT m) where 625 askLoggerIO = LoggingT return 626 627-- | @since 0.3.26 628instance MonadUnliftIO m => MonadUnliftIO (LoggingT m) where 629 {-# INLINE withRunInIO #-} 630 withRunInIO inner = 631 LoggingT $ \r -> 632 withRunInIO $ \run -> 633 inner (run . flip runLoggingT r) 634 635defaultOutput :: Handle 636 -> Loc 637 -> LogSource 638 -> LogLevel 639 -> LogStr 640 -> IO () 641defaultOutput h loc src level msg = 642 S8.hPutStr h ls 643 where 644 ls = defaultLogStrBS loc src level msg 645defaultLogStrBS :: Loc 646 -> LogSource 647 -> LogLevel 648 -> LogStr 649 -> S8.ByteString 650defaultLogStrBS a b c d = 651 toBS $ defaultLogStr a b c d 652 where 653 toBS = fromLogStr 654 655defaultLogLevelStr :: LogLevel -> LogStr 656defaultLogLevelStr level = case level of 657 LevelOther t -> toLogStr t 658 _ -> toLogStr $ S8.pack $ drop 5 $ show level 659 660defaultLogStr :: Loc 661 -> LogSource 662 -> LogLevel 663 -> LogStr 664 -> LogStr 665defaultLogStr loc src level msg = 666 "[" `mappend` defaultLogLevelStr level `mappend` 667 (if T.null src 668 then mempty 669 else "#" `mappend` toLogStr src) `mappend` 670 "] " `mappend` 671 msg `mappend` 672 (if isDefaultLoc loc 673 then "\n" 674 else 675 " @(" `mappend` 676 toLogStr (S8.pack fileLocStr) `mappend` 677 ")\n") 678 where 679 -- taken from file-location package 680 -- turn the TH Loc loaction information into a human readable string 681 -- leaving out the loc_end parameter 682 fileLocStr = (loc_package loc) ++ ':' : (loc_module loc) ++ 683 ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc) 684 where 685 line = show . fst . loc_start 686 char = show . snd . loc_start 687{- 688defaultLogStrWithoutLoc :: 689 LogSource -> LogLevel -> LogStr -> LogStr 690defaultLogStrWithoutLoc loc src level msg = 691 "[" `mappend` defaultLogLevelStr level `mappend` 692 (if T.null src 693 then mempty 694 else "#" `mappend` toLogStr src) `mappend` 695 "] " `mappend` 696 msg `mappend` "\n" 697-} 698 699 700-- | Run a block using a @MonadLogger@ instance which appends to the specified file. 701-- 702-- @since 0.3.22 703runFileLoggingT :: MonadBaseControl IO m => FilePath -> LoggingT m a -> m a 704runFileLoggingT fp logt = bracket 705 (liftBase $ openFile fp AppendMode) 706 (liftBase . hClose) 707 $ \h -> liftBase (hSetBuffering h LineBuffering) >> (runLoggingT logt) (defaultOutput h) 708 709-- | Run a block using a @MonadLogger@ instance which prints to stderr. 710-- 711-- @since 0.2.2 712runStderrLoggingT :: MonadIO m => LoggingT m a -> m a 713runStderrLoggingT = (`runLoggingT` defaultOutput stderr) 714 715-- | Run a block using a @MonadLogger@ instance which prints to stdout. 716-- 717-- @since 0.2.2 718runStdoutLoggingT :: MonadIO m => LoggingT m a -> m a 719runStdoutLoggingT = (`runLoggingT` defaultOutput stdout) 720 721-- | Run a block using a @MonadLogger@ instance which writes tuples to an 722-- unbounded channel. 723-- 724-- The tuples can be extracted (ie. in another thread) with `unChanLoggingT` 725-- or a custom extraction funtion, and written to a destination. 726-- 727-- @since 0.3.17 728runChanLoggingT :: MonadIO m => Chan LogLine -> LoggingT m a -> m a 729runChanLoggingT chan = (`runLoggingT` sink chan) 730 where 731 sink chan' loc src lvl msg = writeChan chan' (loc,src,lvl,msg) 732 733-- | Read logging tuples from an unbounded channel and log them into a 734-- `MonadLoggerIO` monad, forever. 735-- 736-- For use in a dedicated thread with a channel fed by `runChanLoggingT`. 737-- 738-- @since 0.3.17 739unChanLoggingT :: (MonadLogger m, MonadIO m) => Chan LogLine -> m void 740unChanLoggingT chan = forever $ do 741 (loc,src,lvl,msg) <- liftIO $ readChan chan 742 monadLoggerLog loc src lvl msg 743 744-- | Within the 'LoggingT' monad, capture all log messages to a bounded 745-- channel of the indicated size, and only actually log them if there is an 746-- exception. 747-- 748-- @since 0.3.2 749withChannelLogger :: (MonadBaseControl IO m, MonadIO m) 750 => Int -- ^ Number of messages to keep 751 -> LoggingT m a 752 -> LoggingT m a 753withChannelLogger size action = LoggingT $ \logger -> do 754 chan <- liftIO $ newTBChanIO size 755 runLoggingT action (channelLogger chan logger) `onException` dumpLogs chan 756 where 757 channelLogger chan logger loc src lvl str = atomically $ do 758 full <- isFullTBChan chan 759 when full $ void $ readTBChan chan 760 writeTBChan chan $ logger loc src lvl str 761 762 dumpLogs chan = liftIO $ 763 sequence_ =<< atomically (untilM (readTBChan chan) (isEmptyTBChan chan)) 764 765-- | Only log messages passing the given predicate function. 766-- 767-- This can be a convenient way, for example, to ignore debug level messages. 768-- 769-- @since 0.3.13 770filterLogger :: (LogSource -> LogLevel -> Bool) 771 -> LoggingT m a 772 -> LoggingT m a 773filterLogger p (LoggingT f) = LoggingT $ \logger -> 774 f $ \loc src level msg -> 775 when (p src level) $ logger loc src level msg 776 777instance MonadCont m => MonadCont (LoggingT m) where 778 callCC f = LoggingT $ \i -> callCC $ \c -> runLoggingT (f (LoggingT . const . c)) i 779 780instance MonadError e m => MonadError e (LoggingT m) where 781 throwError = Trans.lift . throwError 782 catchError r h = LoggingT $ \i -> runLoggingT r i `catchError` \e -> runLoggingT (h e) i 783 784instance MonadError e m => MonadError e (NoLoggingT m) where 785 throwError = Trans.lift . throwError 786 catchError r h = NoLoggingT $ runNoLoggingT r `catchError` \e -> runNoLoggingT (h e) 787 788instance MonadRWS r w s m => MonadRWS r w s (LoggingT m) 789 790instance MonadReader r m => MonadReader r (LoggingT m) where 791 ask = Trans.lift ask 792 local = mapLoggingT . local 793 794-- | @since 0.3.24 795instance MonadReader r m => MonadReader r (NoLoggingT m) where 796 ask = Trans.lift ask 797 local = mapNoLoggingT . local 798 799-- | Map the unwrapped computation using the given function. 800-- 801-- @since 0.3.29 802mapLoggingT :: (m a -> n b) -> LoggingT m a -> LoggingT n b 803mapLoggingT f = LoggingT . (f .) . runLoggingT 804 805instance MonadState s m => MonadState s (LoggingT m) where 806 get = Trans.lift get 807 put = Trans.lift . put 808 809instance MonadWriter w m => MonadWriter w (LoggingT m) where 810 tell = Trans.lift . tell 811 listen = mapLoggingT listen 812 pass = mapLoggingT pass 813 814-- | Map the unwrapped computation using the given function. 815-- 816-- @since 0.3.29 817mapNoLoggingT :: (m a -> n b) -> NoLoggingT m a -> NoLoggingT n b 818mapNoLoggingT f = NoLoggingT . f . runNoLoggingT 819 820instance MonadState s m => MonadState s (NoLoggingT m) where 821 get = Trans.lift get 822 put = Trans.lift . put 823 824instance MonadWriter w m => MonadWriter w (NoLoggingT m) where 825 tell = Trans.lift . tell 826 listen = mapNoLoggingT listen 827 pass = mapNoLoggingT pass 828 829-- | dummy location, used with 'logWithoutLoc' 830-- 831-- @since 0.3.23 832defaultLoc :: Loc 833defaultLoc = Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0) 834 835isDefaultLoc :: Loc -> Bool 836isDefaultLoc (Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0)) = True 837isDefaultLoc _ = False 838 839-- | 840-- 841-- @since 0.3.23 842logWithoutLoc :: (MonadLogger m, ToLogStr msg) => LogSource -> LogLevel -> msg -> m () 843logWithoutLoc = monadLoggerLog defaultLoc 844 845logDebugN :: MonadLogger m => Text -> m () 846logDebugN = logWithoutLoc "" LevelDebug 847 848logInfoN :: MonadLogger m => Text -> m () 849logInfoN = logWithoutLoc "" LevelInfo 850 851logWarnN :: MonadLogger m => Text -> m () 852logWarnN = logWithoutLoc "" LevelWarn 853 854logErrorN :: MonadLogger m => Text -> m () 855logErrorN = logWithoutLoc "" LevelError 856 857logOtherN :: MonadLogger m => LogLevel -> Text -> m () 858logOtherN = logWithoutLoc "" 859 860logDebugNS :: MonadLogger m => Text -> Text -> m () 861logDebugNS src = logWithoutLoc src LevelDebug 862 863logInfoNS :: MonadLogger m => Text -> Text -> m () 864logInfoNS src = logWithoutLoc src LevelInfo 865 866logWarnNS :: MonadLogger m => Text -> Text -> m () 867logWarnNS src = logWithoutLoc src LevelWarn 868 869logErrorNS :: MonadLogger m => Text -> Text -> m () 870logErrorNS src = logWithoutLoc src LevelError 871 872logOtherNS :: MonadLogger m => Text -> LogLevel -> Text -> m () 873logOtherNS = logWithoutLoc 874 875#if WITH_CALLSTACK 876-- Callstack based logging 877 878mkLoggerLoc :: GHC.SrcLoc -> Loc 879mkLoggerLoc loc = 880 Loc { loc_filename = GHC.srcLocFile loc 881 , loc_package = GHC.srcLocPackage loc 882 , loc_module = GHC.srcLocModule loc 883 , loc_start = ( GHC.srcLocStartLine loc 884 , GHC.srcLocStartCol loc) 885 , loc_end = ( GHC.srcLocEndLine loc 886 , GHC.srcLocEndCol loc) 887 } 888 889locFromCS :: GHC.CallStack -> Loc 890locFromCS cs = case getCallStack cs of 891 ((_, loc):_) -> mkLoggerLoc loc 892 _ -> defaultLoc 893 894logCS :: (MonadLogger m, ToLogStr msg) 895 => GHC.CallStack 896 -> LogSource 897 -> LogLevel 898 -> msg 899 -> m () 900logCS cs src lvl msg = 901 monadLoggerLog (locFromCS cs) src lvl msg 902 903-- | Logs a message with location given by 'CallStack'. 904-- See 'Control.Monad.Logger.CallStack' for more convenient 905-- functions for 'CallStack' based logging. 906-- 907-- @since 0.3.19 908logDebugCS :: MonadLogger m => GHC.CallStack -> Text -> m () 909logDebugCS cs msg = logCS cs "" LevelDebug msg 910 911-- | See 'logDebugCS' 912-- 913-- @since 0.3.19 914logInfoCS :: MonadLogger m => GHC.CallStack -> Text -> m () 915logInfoCS cs msg = logCS cs "" LevelInfo msg 916 917-- | See 'logDebugCS' 918-- 919-- @since 0.3.19 920logWarnCS :: MonadLogger m => GHC.CallStack -> Text -> m () 921logWarnCS cs msg = logCS cs "" LevelWarn msg 922 923-- | See 'logDebugCS' 924-- 925-- @since 0.3.19 926logErrorCS :: MonadLogger m => GHC.CallStack -> Text -> m () 927logErrorCS cs msg = logCS cs "" LevelError msg 928 929-- | See 'logDebugCS' 930-- 931-- @since 0.3.19 932logOtherCS :: MonadLogger m => GHC.CallStack -> LogLevel -> Text -> m () 933logOtherCS cs lvl msg = logCS cs "" lvl msg 934 935#endif 936