diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 3fe6b4f4..8307bf5e 100644 --- a/Yesod/Core.hs +++ b/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 diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs index 298f25d2..4d817605 100644 --- a/Yesod/Internal/Core.hs +++ b/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 = - formatLogMessage level src msg >>= + messageLogger _ loc level 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 - -> Text -- ^ source +instance Lift LogLevel where + 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 diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs index 45e3e178..32a60fc1 100644 --- a/Yesod/Internal/Dispatch.hs +++ b/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) [] ] diff --git a/helloworld.hs b/helloworld.hs index 9a2b70f1..7c974a30 100644 --- a/helloworld.hs +++ b/helloworld.hs @@ -1,11 +1,10 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} import Yesod.Core -import Yesod.Dispatch -import Yesod.Content -import Yesod.Handler -import Network.Wai.Handler.Warp (runEx) +import Network.Wai.Handler.Warp (run) +import Data.Text (unpack) 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" -main = toWaiApp (HelloWorld Subsite) >>= runEx print 3000 +getRootR = do + $(logOther "HAHAHA") "Here I am" + return $ RepPlain "Hello World" +main = toWaiApp (HelloWorld Subsite) >>= run 3000