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