-- TODO: Some licensing stuff (http://hackage.haskell.org/package/yesod-core-1.4.3/docs/src/Yesod-Core-Class-Yesod.html) {-# LANGUAGE FlexibleContexts, TemplateHaskell, QuasiQuotes, OverloadedStrings, TypeFamilies #-} module LMonad.Yesod where import Control.Monad (forM) import Data.List (foldl', nub) import qualified Data.Map as Map import Data.Monoid (Last(..), mempty) import Data.Text (Text) import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) import Language.Haskell.TH import Language.Haskell.TH.Quote import LMonad import Text.Blaze ( customAttribute, textTag, toValue, (!)) import qualified Text.Blaze.Html5 as TBH import Text.Julius import Yesod.Core import Yesod.Core.Types import qualified Yesod.Core.Widget as Yesod widgetToPageContent :: (Label l, LMonad (HandlerT site IO), LMonad (WidgetT site IO), Yesod site) => LMonadT l (WidgetT site IO) () -> LMonadT l (HandlerT site IO) (PageContent (Route site)) widgetToPageContent = swapBase $ \w -> do ( res, ((),new)) <- widgetToPageContent' w return (res, new) where widgetToPageContent' :: ((Eq (Route site)), (Yesod site)) => WidgetT site IO a -> HandlerT site IO (PageContent (Route site), a) widgetToPageContent' w = do master <- getYesod hd <- HandlerT return (res, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd let title = maybe mempty unTitle mTitle scripts = runUniqueList scripts' stylesheets = runUniqueList stylesheets' render <- getUrlRenderParams let renderLoc x = case x of Nothing -> Nothing Just (Left s) -> Just s Just (Right (u, p)) -> Just $ render u p css <- forM (Map.toList style) $ \(mmedia, content) -> do let rendered = toLazyText $ content render x <- addStaticContent "css" "text/css; charset=utf-8" $ encodeUtf8 rendered return (mmedia, case x of Nothing -> Left $ preEscapedToMarkup rendered Just y -> Right $ either id (uncurry render) y) jsLoc <- case jscript of Nothing -> return Nothing Just s -> do x <- addStaticContent "js" "text/javascript; charset=utf-8" $ encodeUtf8 $ renderJavascriptUrl render s return $ renderLoc x -- 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