From f1feea61dcba0b16afed5ce8dd5d2433fe505461 Mon Sep 17 00:00:00 2001 From: dummy Date: Thu, 16 Oct 2014 02:15:23 +0000 Subject: [PATCH] hack TH --- Yesod/Core.hs | 30 +++--- Yesod/Core/Class/Yesod.hs | 256 ++++++++++++++++++++++++++++++--------------- Yesod/Core/Dispatch.hs | 38 ++----- Yesod/Core/Handler.hs | 25 ++--- Yesod/Core/Internal/Run.hs | 6 +- Yesod/Core/Internal/TH.hs | 111 -------------------- Yesod/Core/Types.hs | 3 +- Yesod/Core/Widget.hs | 32 +----- 8 files changed, 213 insertions(+), 288 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 9b29317..7c0792d 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -31,16 +31,16 @@ module Yesod.Core , unauthorizedI -- * Logging , LogLevel (..) - , logDebug - , logInfo - , logWarn - , logError - , logOther - , logDebugS - , logInfoS - , logWarnS - , logErrorS - , logOtherS + --, logDebug + --, logInfo + --, logWarn + --, logError + --, logOther + --, logDebugS + --, logInfoS + --, logWarnS + --, logErrorS + --, logOtherS -- * Sessions , SessionBackend (..) , customizeSessionCookies @@ -87,17 +87,15 @@ module Yesod.Core , readIntegral -- * Shakespeare -- ** Hamlet - , hamlet - , shamlet - , xhamlet + --, hamlet + -- , shamlet + --, xhamlet , HtmlUrl -- ** Julius - , julius + --, julius , JavascriptUrl , renderJavascriptUrl -- ** Cassius/Lucius - , cassius - , lucius , CssUrl , renderCssUrl ) where diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs index 8631d27..c40eb10 100644 --- a/Yesod/Core/Class/Yesod.hs +++ b/Yesod/Core/Class/Yesod.hs @@ -5,18 +5,22 @@ {-# LANGUAGE CPP #-} module Yesod.Core.Class.Yesod where -import Control.Monad.Logger (logErrorS) +--import Control.Monad.Logger (logErrorS) import Yesod.Core.Content import Yesod.Core.Handler import Yesod.Routes.Class +import qualified Text.Blaze.Internal +import qualified Control.Monad.Logger +import qualified Text.Hamlet +import qualified Data.Foldable import Blaze.ByteString.Builder (Builder) import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Control.Arrow ((***), second) import Control.Monad (forM, when, void) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), +import Control.Monad.Logger (Loc, LogLevel (LevelInfo, LevelOther), LogSource) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L @@ -33,7 +37,6 @@ import qualified Data.Text.Encoding.Error as TEE import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Word (Word64) -import Language.Haskell.TH.Syntax (Loc (..)) import Network.HTTP.Types (encodePath) import qualified Network.Wai as W import Data.Default (def) @@ -94,18 +97,26 @@ class RenderRoute site => Yesod site where defaultLayout w = do p <- widgetToPageContent w mmsg <- getMessage - withUrlRenderer [hamlet| - $newline never - $doctype 5 - - - #{pageTitle p} - ^{pageHead p} - <body> - $maybe msg <- mmsg - <p .message>#{msg} - ^{pageBody p} - |] + withUrlRenderer $ \ _render_aHra + -> do { id + ((Text.Blaze.Internal.preEscapedText . T.pack) + "<!DOCTYPE html>\n<html><head><title>"); + id (TBH.toHtml (pageTitle p)); + id ((Text.Blaze.Internal.preEscapedText . T.pack) ""); + Text.Hamlet.asHtmlUrl (pageHead p) _render_aHra; + id ((Text.Blaze.Internal.preEscapedText . T.pack) ""); + Text.Hamlet.maybeH + mmsg + (\ msg_aHrb + -> do { id + ((Text.Blaze.Internal.preEscapedText . T.pack) + "

"); + id (TBH.toHtml msg_aHrb); + id ((Text.Blaze.Internal.preEscapedText . T.pack) "

") }) + Nothing; + Text.Hamlet.asHtmlUrl (pageBody p) _render_aHra; + id + ((Text.Blaze.Internal.preEscapedText . T.pack) "") } -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid @@ -374,45 +385,103 @@ widgetToPageContent w = do -- modernizr should be at the end of the http://www.modernizr.com/docs/#installing -- the asynchronous loader means your page doesn't have to wait for all the js to load let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc - regularScriptLoad = [hamlet| - $newline never - $forall s <- scripts - ^{mkScriptTag s} - $maybe j <- jscript - $maybe s <- jsLoc - ") }) + (Just + (do { id + ((Text.Blaze.Internal.preEscapedText . T.pack) "") }))) + Nothing } + + + headAll = \ _render_aHsW + -> do { Text.Hamlet.asHtmlUrl head' _render_aHsW; + Data.Foldable.mapM_ + (\ s_aHsX -> Text.Hamlet.asHtmlUrl (mkLinkTag s_aHsX) _render_aHsW) + stylesheets; + Data.Foldable.mapM_ + (\ s_aHsY + -> do { Text.Hamlet.maybeH + (right (snd s_aHsY)) + (\ t_aHsZ + -> Text.Hamlet.maybeH + (fst s_aHsY) + (\ media_aHt0 + -> do { id + ((Text.Blaze.Internal.preEscapedText . T.pack) + "") }) + (Just + (do { id + ((Text.Blaze.Internal.preEscapedText . T.pack) + "") }))) + Nothing; + Text.Hamlet.maybeH + (left (snd s_aHsY)) + (\ content_aHt1 + -> Text.Hamlet.maybeH + (fst s_aHsY) + (\ media_aHt2 + -> do { id + ((Text.Blaze.Internal.preEscapedText . T.pack) + "") }) + (Just + (do { id + ((Text.Blaze.Internal.preEscapedText . T.pack) + "") }))) + Nothing }) + css; + case jsLoader master of { + BottomOfBody -> return () + ; BottomOfHeadAsync asyncJsLoader_aHt3 + -> Text.Hamlet.asHtmlUrl + (asyncJsLoader_aHt3 asyncScripts mcomplete) _render_aHsW + ; BottomOfHeadBlocking + -> Text.Hamlet.asHtmlUrl regularScriptLoad _render_aHsW } } + + let bodyScript = \ _render_aHt8 -> do { Text.Hamlet.asHtmlUrl body _render_aHt8; + Text.Hamlet.asHtmlUrl regularScriptLoad _render_aHt8 } + return $ PageContent title headAll $ case jsLoader master of @@ -442,10 +511,13 @@ defaultErrorHandler NotFound = selectRep $ do r <- waiRequest let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r setTitle "Not Found" - toWidget [hamlet| -

Not Found -

#{path'} - |] + toWidget $ \ _render_aHte + -> do { id + ((Text.Blaze.Internal.preEscapedText . T.pack) + "

Not Found

\n

"); + id (TBH.toHtml path'); + id ((Text.Blaze.Internal.preEscapedText . T.pack) "

") } + provideRep $ return $ object ["message" .= ("Not Found" :: Text)] -- For API requests. @@ -455,10 +527,11 @@ defaultErrorHandler NotFound = selectRep $ do defaultErrorHandler NotAuthenticated = selectRep $ do provideRep $ defaultLayout $ do setTitle "Not logged in" - toWidget [hamlet| -

Not logged in -

Set the authRoute and the user will be redirected there. - |] + toWidget $ \ _render_aHti + -> id + ((Text.Blaze.Internal.preEscapedText . T.pack) + "

Not logged in

\n

Set the authRoute and the user will be redirected there.

") + provideRep $ do -- 401 *MUST* include a WWW-Authenticate header @@ -480,10 +553,13 @@ defaultErrorHandler NotAuthenticated = selectRep $ do defaultErrorHandler (PermissionDenied msg) = selectRep $ do provideRep $ defaultLayout $ do setTitle "Permission Denied" - toWidget [hamlet| -

Permission denied -

#{msg} - |] + toWidget $ \ _render_aHtq + -> do { id + ((Text.Blaze.Internal.preEscapedText . T.pack) + "

Permission denied

\n

"); + id (TBH.toHtml msg); + id ((Text.Blaze.Internal.preEscapedText . T.pack) "

") } + provideRep $ return $ object $ [ "message" .= ("Permission Denied. " <> msg) @@ -492,30 +568,42 @@ defaultErrorHandler (PermissionDenied msg) = selectRep $ do defaultErrorHandler (InvalidArgs ia) = selectRep $ do provideRep $ defaultLayout $ do setTitle "Invalid Arguments" - toWidget [hamlet| -

Invalid Arguments -