Logging TH functions and a minor bugfix

Yesod/Core.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
 module Yesod.Core
     ( -- * Type classes
       Yesod (..)
@@ -16,6 +17,11 @@ module Yesod.Core
       -- * Logging
     , LogLevel (..)
     , formatLogMessage
+    , logDebug
+    , logInfo
+    , logWarn
+    , logError
+    , logOther
       -- * Misc
     , yesodVersion
     , yesodRender
@@ -33,3 +39,35 @@ import Yesod.Dispatch
 import Yesod.Handler
 import Yesod.Request
 import Yesod.Widget
+
+import Language.Haskell.TH.Syntax
+import Data.Text (Text)
+
+logTH :: LogLevel -> Q Exp
+logTH level =
+    [|messageLoggerHandler $(qLocation >>= liftLoc) $(lift level)|]
+  where
+    liftLoc :: Loc -> Q Exp
+    liftLoc (Loc a b c d e) = [|Loc $(lift a) $(lift b) $(lift c) $(lift d) $(lift e)|]
+
+-- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:
+--
+-- > $(logDebug) "This is a debug log message"
+logDebug :: Q Exp
+logDebug = logTH LevelDebug
+
+-- | See 'logDebug'
+logInfo :: Q Exp
+logInfo = logTH LevelInfo
+-- | See 'logDebug'
+logWarn :: Q Exp
+logWarn = logTH LevelWarn
+-- | See 'logDebug'
+logError :: Q Exp
+logError = logTH LevelError
+
+-- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage:
+--
+-- > $(logOther "My new level") "This is a log message"
+logOther :: Text -> Q Exp
+logOther = logTH . LevelOther

Yesod/Internal/Core.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
 -- | The basic typeclass for a Yesod application.
 module Yesod.Internal.Core
     ( -- * Type classes
@@ -22,6 +23,7 @@ module Yesod.Internal.Core
       -- * Logging
     , LogLevel (..)
     , formatLogMessage
+    , messageLoggerHandler
       -- * Misc
     , yesodVersion
     , yesodRender
@@ -53,7 +55,7 @@ import qualified Text.Blaze.Html5 as TBH
 import Data.Text.Lazy.Builder (toLazyText)
 import Data.Text.Lazy.Encoding (encodeUtf8)
 import Data.Maybe (fromMaybe)
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.IO.Class (MonadIO (liftIO))
 import Web.Cookie (parseCookies)
 import qualified Data.Map as Map
 import Data.Time
@@ -70,6 +72,7 @@ import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.IO
 import qualified System.IO
 import qualified Data.Text.Lazy.Builder as TB
+import Language.Haskell.TH.Syntax (Loc (..), Lift (..))
 
 #if GHC7
 #define HAMLET hamlet
@@ -245,29 +248,44 @@ class RenderRoute (Route a) => Yesod a where
 
     -- | Send a message to the log. By default, prints to stderr.
     messageLogger :: a
+                  -> Loc -- ^ position in source code
                   -> LogLevel
-                  -> Text -- ^ source
                   -> Text -- ^ message
                   -> IO ()
-    messageLogger _ level src msg =
+    messageLogger _ loc level msg =
-        formatLogMessage level src msg >>=
+        formatLogMessage loc level msg >>=
         Data.Text.Lazy.IO.hPutStrLn System.IO.stderr
 
+messageLoggerHandler :: (Yesod m, MonadIO mo)
+                     => Loc -> LogLevel -> Text -> GGHandler s m mo ()
+messageLoggerHandler loc level msg = do
+    y <- getYesod
+    liftIO $ messageLogger y loc level msg
+
 data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
     deriving (Eq, Show, Read, Ord)
 
-formatLogMessage :: LogLevel
+instance Lift LogLevel where
-                 -> Text -- ^ source
+    lift LevelDebug = [|LevelDebug|]
+    lift LevelInfo = [|LevelInfo|]
+    lift LevelWarn = [|LevelWarn|]
+    lift LevelError = [|LevelError|]
+    lift (LevelOther x) = [|LevelOther $ TS.pack $(lift $ TS.unpack x)|]
+
+formatLogMessage :: Loc
+                 -> LogLevel
                  -> Text -- ^ message
                  -> IO TL.Text
-formatLogMessage level src msg = do
+formatLogMessage loc level msg = do
     now <- getCurrentTime
     return $ TB.toLazyText $
         TB.fromText (TS.pack $ show now)
         `mappend` TB.fromText ": "
         `mappend` TB.fromText (TS.pack $ show level)
         `mappend` TB.fromText "@("
-        `mappend` TB.fromText src
+        `mappend` TB.fromText (TS.pack $ loc_filename loc)
+        `mappend` TB.fromText ":"
+        `mappend` TB.fromText (TS.pack $ show $ fst $ loc_start loc)
         `mappend` TB.fromText ") "
         `mappend` TB.fromText msg
 

Yesod/Internal/Dispatch.hs

@@ -279,11 +279,11 @@ mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do
     fsp <- [|fromSinglePiece|]
     let exp' = CaseE (fsp `AppE` VarE next)
                 [ Match
-                    (ConP (mkName "Left") [WildP])
+                    (ConP (mkName "Nothing") [])
                     (NormalB nothing)
                     []
                 , Match
-                    (ConP (mkName "Right") [VarP next'])
+                    (ConP (mkName "Just") [VarP next'])
                     (NormalB innerExp)
                     []
                 ]

helloworld.hs

@@ -1,11 +1,10 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell #-}
 import Yesod.Core
-import Yesod.Dispatch
+import Network.Wai.Handler.Warp (run)
-import Yesod.Content
+import Data.Text (unpack)
-import Yesod.Handler
-import Network.Wai.Handler.Warp (runEx)
 
 data Subsite = Subsite String
 
@@ -14,16 +13,18 @@ mkYesodSub "Subsite" [] [$parseRoutes|
 /multi/*Strings SubMultiR
 |]
 
-getSubRootR :: GHandler Subsite m RepPlain
+getSubRootR :: Yesod m => GHandler Subsite m RepPlain
 getSubRootR = do
     Subsite s <- getYesodSub
     tm <- getRouteToMaster
     render <- getUrlRender
-    return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ render (tm SubRootR)
+    $(logDebug) "I'm in SubRootR"
+    return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render (tm SubRootR))
 
-handleSubMultiR :: Strings -> GHandler Subsite m RepPlain
+handleSubMultiR :: Yesod m => Strings -> GHandler Subsite m RepPlain
 handleSubMultiR x = do
     Subsite y <- getYesodSub
+    $(logInfo) "In SubMultiR"
     return . RepPlain . toContent . show $ (x, y)
 
 data HelloWorld = HelloWorld { getSubsite :: String -> Subsite }
@@ -33,5 +34,7 @@ mkYesod "HelloWorld" [$parseRoutes|
 |]
 instance Yesod HelloWorld where approot _ = ""
 -- getRootR :: GHandler HelloWorld HelloWorld RepPlain -- FIXME remove type sig
-getRootR = return $ RepPlain "Hello World"
+getRootR = do
-main = toWaiApp (HelloWorld Subsite) >>= runEx print 3000
+    $(logOther "HAHAHA") "Here I am"
+    return $ RepPlain "Hello World"
+main = toWaiApp (HelloWorld Subsite) >>= run 3000