Skip to content
Browse files

Add Location data type

  • Loading branch information...
1 parent 4c2b693 commit 6139f4da0d0e816ab2abec5ec1f6db4e365c27b5 @sol committed Jan 2, 2012
Showing with 44 additions and 17 deletions.
  1. +1 −1 LICENSE
  2. +1 −1 logging.cabal
  3. +42 −15 src/Logging.hs
View
2 LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2011 Simon Hengel <sol@typeful.net>
+Copyright (c) 2011, 2012 Simon Hengel <sol@typeful.net>
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
View
2 logging.cabal
@@ -2,7 +2,7 @@ name: logging
version: 0.0.0
license: MIT
license-file: LICENSE
-copyright: (c) 2011 Simon Hengel
+copyright: (c) 2011, 2012 Simon Hengel
author: Simon Hengel
maintainer: Simon Hengel <sol@typeful.net>
build-type: Simple
View
57 src/Logging.hs
@@ -22,15 +22,28 @@ import qualified Prelude
import System.IO (hPutStrLn, stderr)
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax
+import Language.Haskell.TH hiding (location)
+import Language.Haskell.TH.Syntax hiding (location)
+import qualified Language.Haskell.TH.Syntax as TH
import Data.IORef
import Foreign (unsafePerformIO)
import Text.Format (formatS)
import Util (stripVersion)
+-- | Compatibility function for old LogRecord format
+logLocationInfo :: LogRecord -> String
+logLocationInfo m = filename ++ ":" ++ show line
+ where
+ loc = logLocation m
+ filename = locationFilename loc
+ line = locationLine loc
+
+-- | Compatibility function for old LogRecord format
+logChannel m = let loc = logLocation m in
+ (stripVersion $ locationPackage loc) ++ "." ++ locationModule loc
+
data LogLevel = TRACE | DEBUG | INFO | WARN | ERROR
deriving (Eq, Show)
@@ -42,12 +55,28 @@ instance Lift LogLevel where
lift ERROR = [|ERROR|]
data LogRecord = LogRecord {
- logChannel :: String
-, logLevel :: LogLevel
-, logMessage :: ShowS
-, logLocationInfo :: String
+ logLevel :: LogLevel
+, logMessage :: ShowS
+, logLocation :: Location
+}
+
+data Location = Location {
+ locationFilename :: String
+, locationPackage :: String
+, locationModule :: String
+, locationLine :: Int
+, locationColumn :: Int
}
+location :: Q Exp
+location = do
+ loc <- TH.location
+ let filename = loc_filename loc
+ let package = loc_package loc
+ let mod = loc_module loc
+ let (line, column) = loc_start loc
+ [|Location filename package mod line column|]
+
-- We use the unsafePerformIO hack to share one sink across a process.
logSink :: IORef (LogRecord -> IO ())
{-# NOINLINE logSink #-}
@@ -63,17 +92,15 @@ consumeLogRecord m = do
-- | Write log messages to stderr.
defaultLogSink :: LogRecord -> IO ()
-defaultLogSink (LogRecord _ level message linfo) =
- hPutStrLn stderr $ show level ++ " " ++ linfo ++ ": " ++ message []
+defaultLogSink m =
+ hPutStrLn stderr $ show level ++ " " ++ linfo ++ ": " ++ message ""
+ where
+ level = logLevel m
+ message = logMessage m
+ linfo = logLocationInfo m
createLogRecord :: LogLevel -> String -> Q Exp
-createLogRecord level message = do
- loc <- location
- let channel = (stripVersion $ loc_package loc) ++ "." ++ loc_module loc
- let filename = loc_filename loc
- let (line, _) = loc_start loc
- let linfo = filename ++ ":" ++ show line
- [| LogRecord channel level $(formatS message) linfo |]
+createLogRecord level message = [|LogRecord level $(formatS message) $(location)|]
logTrace, logDebug, logInfo, logWarn, logError :: String -> ExpQ
logTrace message = [| consumeLogRecord $(createLogRecord TRACE message) |]

0 comments on commit 6139f4d

Please sign in to comment.
Something went wrong with that request. Please try again.