import Yesod.Core.Widget into Yesod.Core.Class.Yesod

yesod-core/Yesod/Core.hs

@@ -21,11 +21,9 @@ module Yesod.Core
     , ErrorResponse (..)
       -- * Utitlities
     , maybeAuthorized
-    -- FIXME: API breakage
+    , widgetToPageContent
-    -- , widgetToPageContent
       -- * Defaults
-    -- FIXME: API breakage
+    , defaultErrorHandler
-    -- , defaultErrorHandler
     , defaultYesodMiddleware
     , authorizationCheck
       -- * Data types

yesod-core/Yesod/Core/Class/Handler.hs

@@ -10,8 +10,6 @@ module Yesod.Core.Class.Handler
     ) where
 
 import Yesod.Core.Types
-import Data.Monoid (mempty)
-import Control.Monad (liftM)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase)
 import Control.Monad.Trans.Class (lift)

yesod-core/Yesod/Core/Class/Yesod.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE CPP               #-}
 module Yesod.Core.Class.Yesod where
 
+import           Control.Monad                      (mplus)
 import           Control.Monad.Logger               (logErrorS)
 import           Yesod.Core.Content
 import           Yesod.Core.Handler
@@ -15,11 +16,12 @@ import           Blaze.ByteString.Builder           (Builder)
 import           Blaze.ByteString.Builder.Char.Utf8 (fromText)
 import           Control.Arrow                      ((***), second)
 import           Control.Exception                  (bracket)
-import           Control.Monad                      (forM, when, void)
+import           Control.Monad                      (when, void)
 import           Control.Monad.IO.Class             (MonadIO (liftIO))
 import           Control.Monad.Logger               (LogLevel (LevelInfo, LevelOther),
                                                      LogSource)
 import           Control.Monad.Trans.Resource       (InternalState, createInternalState, closeInternalState)
+import qualified Data.Aeson as J
 import qualified Data.ByteString.Char8              as S8
 import qualified Data.ByteString.Lazy               as L
 import Data.Aeson (object, (.=))
@@ -30,8 +32,6 @@ import           Data.Text                          (Text)
 import qualified Data.Text                          as T
 import qualified Data.Text.Encoding                 as TE
 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)
@@ -41,9 +41,6 @@ import           Network.Wai.Parse                  (lbsBackEnd,
                                                      tempFileBackEnd)
 import           Network.Wai.Logger                 (ZonedDate, clockDateCacher)
 import           System.Log.FastLogger
-import           Text.Blaze                         (customAttribute, textTag,
-                                                     toValue, (!))
-import           Text.Blaze                         (preEscapedToMarkup)
 import           Text.Blaze.Html                    (Html)
 import qualified Text.Blaze.Html5                   as TBH
 import qualified Web.ClientSession                  as CS
@@ -51,7 +48,10 @@ import           Web.Cookie                         (parseCookies)
 import           Web.Cookie                         (SetCookie (..))
 import           Yesod.Core.Types
 import           Yesod.Core.Internal.Session
-import Control.Monad.Trans.Class (lift)
+
+-- for jsLoader and defaultErrorHandler
+import           Yesod.Core.Widget (WidgetT, toWidget, setTitle, PageContent(..), ScriptLoadPosition(BottomOfBody), getMessage, widgetToPageContentUnbound)
+import qualified Data.Foldable
 
 
 -- | Define settings for a Yesod applications. All methods have intelligent
@@ -77,28 +77,11 @@ class RenderRoute site => Yesod site where
     --
     -- Default value: 'defaultErrorHandler'.
     errorHandler :: ErrorResponse -> HandlerT site IO TypedContent
-    -- errorHandler = defaultErrorHandler
+    errorHandler = defaultErrorHandler
 
     -- | Applies some form of layout to the contents of a page.
-    {- FIXME
     defaultLayout :: WidgetT site IO () -> HandlerT site IO Html
-    widgetToPageContent = widgetToPageContentUnbound addStaticContent jsLoader
+    defaultLayout = defaultDefaultLayout
-    defaultLayout w = do
-        p <- widgetToPageContent w
-        mmsg <- getMessage
-        withUrlRenderer [hamlet|
-            $newline never
-            $doctype 5
-            <html>
-                <head>
-                    <title>#{pageTitle p}
-                    ^{pageHead p}
-                <body>
-                    $maybe msg <- mmsg
-                        <p .message>#{msg}
-                    ^{pageBody p}
-            |]
-            -}
 
     -- | 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
@@ -236,9 +219,8 @@ class RenderRoute site => Yesod site where
     -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js
     --
     -- Or write your own async js loader.
-    -- FIXME: the type
+    jsLoader :: site -> ScriptLoadPosition site
-    -- jsLoader :: site -> ScriptLoadPosition site
+    jsLoader _ = BottomOfBody
-    -- jsLoader _ = BottomOfBody
 
     -- | Create a session backend. Returning 'Nothing' disables
     -- sessions. If you'd like to change the way that the session
@@ -375,7 +357,75 @@ authorizationCheck = do
                               void $ notAuthenticated
             Unauthorized s' -> permissionDenied s'
 
-{- FIXME
+
+-- templating types
+type Render url = url -> [(Text, Text)] -> Text
+type HtmlUrl url = Render url -> Html
+
+maybeH :: Monad m => Maybe a -> (a -> m ()) -> Maybe (m ()) -> m ()
+maybeH mv f mm = fromMaybe (return ()) $ fmap f mv `mplus` mm
+
+
+widgetToPageContent
+  :: (Yesod site, Eq (Route site))
+  => WidgetT site IO ()
+  -> HandlerT site IO (PageContent (Route site))
+widgetToPageContent = widgetToPageContentUnbound addStaticContent jsLoader
+
+
+-- | Provide both an HTML and JSON representation for a piece of
+-- data, using the default layout for the HTML output
+-- ('defaultLayout').
+--
+-- /Since: 0.3.0/
+defaultLayoutJson :: (Yesod site, J.ToJSON a)
+                  => WidgetT site IO ()  -- ^ HTML
+                  -> HandlerT site IO a  -- ^ JSON
+                  -> HandlerT site IO TypedContent
+defaultLayoutJson w json = selectRep $ do
+    provideRep $ defaultLayout w
+    provideRep $ fmap J.toJSON json
+
+
+defaultDefaultLayout :: Yesod site => WidgetT site IO () -> HandlerT site IO Html
+defaultDefaultLayout w = do
+    p <- widgetToPageContent w
+    mmsg <- getMessage
+    withUrlRenderer $ htmlTemplate p mmsg
+  where
+    asHtmlUrl :: HtmlUrl url -> HtmlUrl url
+    asHtmlUrl = id
+
+    -- equivalent to
+    -- [hamlet|
+    --    $newline never
+    --    $doctype 5
+    --    <html>
+    --        <head>
+    --            <title>#{pageTitle p}
+    --            ^{pageHead p}
+    --        <body>
+    --            $maybe msg <- mmsg
+    --                <p .message>#{msg}
+    --            ^{pageBody p}
+    --    |]
+    htmlTemplate p mmsg = \_render_afYl -> do
+        TBH.preEscapedText $ T.pack "<!DOCTYPE html>\n<html><head><title>"
+        TBH.toHtml (pageTitle p)
+        TBH.preEscapedText $ T.pack "</title>"
+        asHtmlUrl (pageHead p) _render_afYl
+        TBH.preEscapedText $ T.pack "</head><body>"
+        maybeH
+          mmsg
+          (\ msg_afYm
+             -> do { id ((TBH.preEscapedText . T.pack) "<p class=\"message\">");
+                     id (TBH.toHtml msg_afYm);
+                     id ((TBH.preEscapedText . T.pack) "</p>") })
+          Nothing
+        asHtmlUrl (pageBody p) _render_afYl
+        (TBH.preEscapedText . T.pack) "</body></html>"
+
+
 -- | The default error handler for 'errorHandler'.
 defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent
 defaultErrorHandler NotFound = selectRep $ do
@@ -383,11 +433,19 @@ defaultErrorHandler NotFound = selectRep $ do
         r <- waiRequest
         let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
         setTitle "Not Found"
-        toWidget [hamlet|
+        toWidget $ htmlTemplate path'
-            <h1>Not Found
-            <p>#{path'}
-        |]
     provideRep $ return $ object ["message" .= ("Not Found" :: Text)]
+  where
+    -- equivalent to
+    --
+    --    [hamlet|
+    --        <h1>Not Found
+    --        <p>#{path'}
+    --    |]
+     htmlTemplate path' = \_renderer -> do 
+       TBH.preEscapedText $ T.pack "<h1>Not Found</h1>\n<p>"
+       TBH.toHtml path'
+       TBH.preEscapedText $ T.pack "</p>"
 
 -- For API requests.
 -- For a user with a browser,
@@ -396,10 +454,7 @@ defaultErrorHandler NotFound = selectRep $ do
 defaultErrorHandler NotAuthenticated = selectRep $ do
     provideRep $ defaultLayout $ do
         setTitle "Not logged in"
-        toWidget [hamlet|
+        toWidget htmlTemplate
-            <h1>Not logged in
-            <p style="display:none;">Set the authRoute and the user will be redirected there.
-        |]
 
     provideRep $ do
         -- 401 *MUST* include a WWW-Authenticate header
@@ -417,48 +472,97 @@ defaultErrorHandler NotAuthenticated = selectRep $ do
           case authRoute site of
               Nothing -> []
               Just url -> ["authentication_url" .= rend url]
+  where
+    -- equivalent to
+    --   [hamlet|
+    --      <h1>Not logged in
+    --        <p style="display:none;">Set the authRoute and the user will be redirected there.
+    --   |]
+    htmlTemplate = \_renderer -> TBH.preEscapedText $ T.pack
+      "<h1>Not logged in</h1>\n<p style=\"display:none;\">Set the authRoute and the user will be redirected there.</p>"
+
 
 defaultErrorHandler (PermissionDenied msg) = selectRep $ do
     provideRep $ defaultLayout $ do
         setTitle "Permission Denied"
-        toWidget [hamlet|
+        toWidget htmlTemplate
-            <h1>Permission denied
-            <p>#{msg}
-        |]
     provideRep $
         return $ object $ [
           "message" .= ("Permission Denied. " <> msg)
           ]
+  where
+    -- equivalent to
+    --
+    --    [hamlet|
+    --        <h1>Permission denied
+    --        <p>#{msg}
+    --    |]
+    htmlTemplate = \_renderer -> do
+      TBH.preEscapedText $ T.pack "<h1>Permission denied</h1>\n<p>"
+      TBH.toHtml msg
+      TBH.preEscapedText $ T.pack "</p>"
+
 
 defaultErrorHandler (InvalidArgs ia) = selectRep $ do
     provideRep $ defaultLayout $ do
         setTitle "Invalid Arguments"
-        toWidget [hamlet|
+        toWidget htmlTemplate
-            <h1>Invalid Arguments
-            <ul>
-                $forall msg <- ia
-                    <li>#{msg}
-        |]
     provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]
+  where
+    -- equivalent to
+    -- [hamlet|
+    --        <h1>Invalid Arguments
+    --        <ul>
+    --            $forall msg <- ia
+    --               <li>#{msg}
+    --    |]
+    htmlTemplate = \_renderer -> do
+      (TBH.preEscapedText . T.pack) "<h1>Invalid Arguments</h1>\n<ul>"
+      Data.Foldable.mapM_
+                (\ msg_afNn
+                   -> do { (TBH.preEscapedText . T.pack) "<li>";
+                           TBH.toHtml msg_afNn;
+                           (TBH.preEscapedText . T.pack) "</li>" })
+                ia;
+      (TBH.preEscapedText . T.pack) "</ul>"
+
+
 defaultErrorHandler (InternalError e) = do
     $logErrorS "yesod-core" e
     selectRep $ do
         provideRep $ defaultLayout $ do
             setTitle "Internal Server Error"
-            toWidget [hamlet|
+            toWidget htmlTemplate
-                <h1>Internal Server Error
-                <pre>#{e}
-            |]
         provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]
+  where
+    -- equivalent to
+    --        [hamlet|
+    --            <h1>Internal Server Error
+    --            <pre>#{e}
+    --        |]
+    htmlTemplate = \_renderer -> do
+      (TBH.preEscapedText . T.pack) "<h1>Internal Server Error</h1>\n<pre>"
+      TBH.toHtml e
+      (TBH.preEscapedText . T.pack) "</pre>"
+
 defaultErrorHandler (BadMethod m) = selectRep $ do
     provideRep $ defaultLayout $ do
         setTitle"Bad Method"
-        toWidget [hamlet|
+        toWidget $ htmlTemplate
-            <h1>Method Not Supported
-            <p>Method <code>#{S8.unpack m}</code> not supported
-        |]
     provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
-    -}
+  where
+    -- equivalent to
+    --
+    --    [hamlet|
+    --        <h1>Method Not Supported
+    --        <p>Method <code>#{S8.unpack m}</code> not supported
+    --    |]
+    htmlTemplate = \ _render -> do
+        TBH.preEscapedText $ T.pack
+             "<h1>Method Not Supported</h1>\n<p>Method <code>"
+        TBH.toHtml (S8.unpack m)
+        TBH.preEscapedText $ T.pack "</code> not supported</p>"
+
 
 formatLogMessage :: IO ZonedDate
                  -> Loc

yesod-core/Yesod/Core/Internal/TH.hs

@@ -22,6 +22,7 @@ import Yesod.Core.Types
 import Yesod.Core.Content
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
+import Yesod.Core.Widget (WidgetT)
 
 -- | Generates URL datatype and site function for the given 'Resource's. This
 -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
@@ -55,9 +56,8 @@ masterTypeSyns :: Type -> [Dec]
 masterTypeSyns site =
     [ TySynD (mkName "Handler") []
       $ ConT ''HandlerT `AppT` site `AppT` ConT ''IO
-    -- FIXME
+    , TySynD (mkName "Widget")  []
-    -- , TySynD (mkName "Widget")  []
+      $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
-    --  $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
     ]
 
 mkYesodGeneral :: String                   -- ^ foundation type

yesod-core/Yesod/Core/Widget.hs

@@ -47,6 +47,12 @@ module Yesod.Core.Widget
     , asWidgetT
     , tellWidget
 
+      -- * Formerly Yesod.Core.Class.Yesod
+    , jelper
+    , asyncHelper
+    , jsToHtml
+    , widgetToPageContentUnbound
+
       -- * Formerly Yesod.Core.Types
     , ScriptLoadPosition(..)
     , BottomOfHeadAsync
@@ -66,7 +72,6 @@ module Yesod.Core.Widget
     , hamletToRepHtml
 
       -- * Formerly Yesod.Core.Json
-    -- FIXME
     -- , defaultLayoutJson
 
       -- * Formerly Yesod.Core
@@ -74,7 +79,7 @@ module Yesod.Core.Widget
     ) where
 
 import           Control.Applicative                (Applicative(..))
-import           Control.Monad                      (liftM, ap)
+import           Control.Monad                      (liftM, ap, forM, mplus)
 import           Control.Monad.Base                 (MonadBase (liftBase))
 import           Control.Monad.Catch                (MonadCatch (..))
 import           Control.Monad.Catch                (MonadMask (..))
@@ -98,6 +103,7 @@ import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )
 import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )
 import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
 import Blaze.ByteString.Builder (Builder)
+import qualified Data.ByteString.Lazy               as L
 import           Data.Conduit                       (Flush (Chunk), Producer, ConduitM)
 import Data.Conduit.Internal (Pipe(..))
 import Data.Conduit.Lazy (MonadActive, monadActive)
@@ -110,6 +116,7 @@ import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
 import Yesod.Routes.Class
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Text (Text)
+import           Data.Maybe                         (fromMaybe)
 import qualified Data.Map as Map
 
 import           System.Log.FastLogger              (toLogStr)
@@ -117,9 +124,17 @@ import qualified Data.Text.Lazy as TL
 
 import Yesod.Core.Types
 import Yesod.Core.Class.Handler
-import Yesod.Core.Handler (setSession, lookupSession, deleteSession, withUrlRenderer, sendChunk)
+import Yesod.Core.Handler (setSession, lookupSession, deleteSession, withUrlRenderer, sendChunk, getUrlRenderParams, getYesod)
 import Yesod.Core.Content (ToContent(..), ToTypedContent(..), HasContentType(..), ToFlushBuilder(..), typeHtml)
+import           Data.List                          (foldl', nub)
 import           Data.Map                           (Map, unionWith)
+import           Data.Text.Lazy.Builder (toLazyText)
+import qualified Data.Text.Lazy.Builder as TLB
+import           Data.Text.Lazy.Encoding (encodeUtf8)
+import qualified Data.Foldable
+import qualified Data.Text
+import qualified Text.Blaze.Html5                   as TBH
+import qualified Text.Blaze.Html5 as H
 
 -- templating types
 type Render url = url -> [(Text, Text)] -> Text
@@ -489,20 +504,242 @@ sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)
 sendChunkHtml = sendChunk
 
 
------------------------------
+maybeH :: Monad m => Maybe a -> (a -> m ()) -> Maybe (m ()) -> m ()
--- originally from Yesod.Core.Json
+maybeH mv f mm = fromMaybe (return ()) $ fmap f mv `mplus` mm
------------------------------
+
--- | Provide both an HTML and JSON representation for a piece of
+type AddStaticContent site m = Text -- ^ filename extension
--- data, using the default layout for the HTML output
+                            -> Text -- ^ mime-type
--- ('defaultLayout').
+                            -> L.ByteString -- ^ content
---
+                            -> HandlerT site m (Maybe (Either Text (Route site, [(Text, Text)])))
--- /Since: 0.3.0/
+
-{- FIXME
+-- | Convert a widget to a 'PageContent'.
-defaultLayoutJson :: (Yesod site, J.ToJSON a)
+-- not bound to the Yesod typeclass
-                  => WidgetT site IO ()  -- ^ HTML
+widgetToPageContentUnbound
-                  -> HandlerT site IO a  -- ^ JSON
+  :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, Eq (Route site))
-                  -> HandlerT site IO TypedContent
+  => AddStaticContent site m
-defaultLayoutJson w json = selectRep $ do
+  -> (site -> ScriptLoadPosition site)
-    provideRep $ defaultLayout w
+  -> WidgetT site m ()
-    provideRep $ fmap J.toJSON json
+  -> HandlerT site m (PageContent (Route site))
-    -}
+widgetToPageContentUnbound addStaticContent jsLoader w = do
+    master <- getYesod
+    hd <- HandlerT return
+    ((), 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 $ toLazyText $ s render
+                return $ renderLoc x
+
+    -- modernizr should be at the end of the <head> 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
+        scriptLoad = regularScriptLoad scripts jscript jsLoc
+        headAll = headContent head' stylesheets css master asyncScripts mcomplete scriptLoad
+
+    let bodyScript = bodyScriptLoad body scriptLoad
+
+    return $ PageContent title headAll $
+        case jsLoader master of
+            BottomOfBody -> bodyScript
+            _ -> body
+  where
+    renderLoc' render' (Local url) = render' url []
+    renderLoc' _ (Remote s) = s
+
+    addAttr x (y, z) = x H.! H.customAttribute (H.textTag y) (H.toValue z)
+    mkScriptTag (Script loc attrs) render' =
+        foldl' addAttr H.script (("src", renderLoc' render' loc) : attrs) $ return ()
+    mkLinkTag (Stylesheet loc attrs) render' =
+        foldl' addAttr H.link
+            ( ("rel", "stylesheet")
+            : ("href", renderLoc' render' loc)
+            : attrs
+            )
+
+    runUniqueList :: Eq x => UniqueList x -> [x]
+    runUniqueList (UniqueList x) = nub $ x []
+
+    -- equivalent to
+    --
+    --   [hamlet|
+    --        $newline never
+    --        ^{body}
+    --        ^{scriptLoad}
+    --    |]
+    bodyScriptLoad body scriptLoad = \renderer -> do
+        asHtmlUrl body renderer
+        asHtmlUrl scriptLoad renderer
+
+    -- equivalent to
+    --
+    --  [hamlet|
+    --    $newline never
+    --    $forall s <- scripts
+    --        ^{mkScriptTag s}
+    --    $maybe j <- jscript
+    --        $maybe s <- jsLoc
+    --            <script src="#{s}">
+    --        $nothing
+    --            <script>^{jelper j}
+    -- |]
+    regularScriptLoad scripts jscript jsLoc = \_render_ahpp -> do
+       { Data.Foldable.mapM_
+            (\ s_ahpq -> asHtmlUrl (mkScriptTag s_ahpq) _render_ahpp) scripts;
+         maybeH
+            jscript
+            (\ j_ahpr
+               -> maybeH
+                    jsLoc
+                    (\ s_ahps
+                       -> do { id ((H.preEscapedText . Data.Text.pack) "<script src=\"");
+                               id (TBH.toHtml s_ahps);
+                               id ((H.preEscapedText . Data.Text.pack) "\"></script>") })
+                    (Just
+                       (do { id ((H.preEscapedText . Data.Text.pack) "<script>");
+                             asHtmlUrl (jelper j_ahpr) _render_ahpp;
+                             id ((H.preEscapedText . Data.Text.pack) "</script>") })))
+            Nothing }
+
+    -- equivalent to
+    --
+    -- [hamlet|
+    --    $newline never
+    --    \^{head'}
+    --    $forall s <- stylesheets
+    --        ^{mkLinkTag s}
+    --    $forall s <- css
+    --        $maybe t <- right $ snd s
+    --            $maybe media <- fst s
+    --                <link rel=stylesheet media=#{media} href=#{t}>
+    --            $nothing
+    --                <link rel=stylesheet href=#{t}>
+    --        $maybe content <- left $ snd s
+    --            $maybe media <- fst s
+    --                <style media=#{media}>#{content}
+    --            $nothing
+    --                <style>#{content}
+    --    $case jsLoader master
+    --      $of BottomOfBody
+    --      $of BottomOfHeadAsync asyncJsLoader
+    --          ^{asyncJsLoader asyncScripts mcomplete}
+    --      $of BottomOfHeadBlocking
+    --          ^{scriptLoad}
+    -- |]
+    headContent head' stylesheets css master asyncScripts mcomplete scriptLoad = \_render_ahmq -> do
+      { asHtmlUrl head' _render_ahmq;
+        Data.Foldable.mapM_
+          (\ s_ahmr -> asHtmlUrl (mkLinkTag s_ahmr) _render_ahmq)
+          stylesheets;
+        Data.Foldable.mapM_
+          (\ s_ahms
+             -> do { maybeH
+                       (right (snd s_ahms))
+                       (\ t_ahmt
+                          -> maybeH
+                               (fst s_ahms)
+                               (\ media_ahmu
+                                  -> do { id
+                                            ((H.preEscapedText . Data.Text.pack)
+                                               "<link rel=\"stylesheet\" media=\"");
+                                          id (TBH.toHtml media_ahmu);
+                                          id
+                                            ((H.preEscapedText . Data.Text.pack)
+                                               "\" href=\"");
+                                          id (TBH.toHtml t_ahmt);
+                                          id ((H.preEscapedText . Data.Text.pack) "\">") })
+                               (Just
+                                  (do { id
+                                          ((H.preEscapedText . Data.Text.pack)
+                                             "<link rel=\"stylesheet\" href=\"");
+                                        id (TBH.toHtml t_ahmt);
+                                        id ((H.preEscapedText . Data.Text.pack) "\">") })))
+                       Nothing;
+                     maybeH
+                       (left (snd s_ahms))
+                       (\ content_ahmv
+                          -> maybeH
+                               (fst s_ahms)
+                               (\ media_ahmw
+                                  -> do { id
+                                            ((H.preEscapedText . Data.Text.pack)
+                                               "<style media=\"");
+                                          id (TBH.toHtml media_ahmw);
+                                          id ((H.preEscapedText . Data.Text.pack) "\">");
+                                          id (TBH.toHtml content_ahmv);
+                                          id
+                                            ((H.preEscapedText . Data.Text.pack)
+                                               "</style>") })
+                               (Just
+                                  (do { id ((H.preEscapedText . Data.Text.pack) "<style>");
+                                        id (TBH.toHtml content_ahmv);
+                                        id
+                                          ((H.preEscapedText . Data.Text.pack)
+                                             "</style>") })))
+                       Nothing })
+          css;
+        case jsLoader master of
+          BottomOfBody -> return ()
+          BottomOfHeadAsync asyncJsLoader_ahmx -> asHtmlUrl (asyncJsLoader_ahmx asyncScripts mcomplete) _render_ahmq
+          BottomOfHeadBlocking -> asHtmlUrl scriptLoad _render_ahmq
+      }
+
+
+asyncHelper :: (url -> [x] -> Text)
+         -> [Script (url)]
+         -> Maybe (BuilderUrl url)
+         -> Maybe Text
+         -> (Maybe (HtmlUrl url), [Text])
+asyncHelper render scripts jscript jsLoc =
+    (mcomplete, scripts'')
+  where
+    scripts' = map goScript scripts
+    scripts'' =
+        case jsLoc of
+            Just s -> scripts' ++ [s]
+            Nothing -> scripts'
+    goScript (Script (Local url) _) = render url []
+    goScript (Script (Remote s) _) = s
+    mcomplete =
+        case jsLoc of
+            Just{} -> Nothing
+            Nothing ->
+                case jscript of
+                    Nothing -> Nothing
+                    Just j -> Just $ jelper j
+
+jsToHtml :: TLB.Builder -> Html
+jsToHtml b = preEscapedToMarkup $ toLazyText b
+
+jelper :: (Render url -> TLB.Builder) -> HtmlUrl url
+jelper = fmap jsToHtml
+
+right :: Either a b -> Maybe b
+right (Right x) = Just x
+right _ = Nothing
+
+left :: Either a b -> Maybe a
+left (Left x) = Just x
+left _ = Nothing
+
+asHtmlUrl :: HtmlUrl url -> HtmlUrl url
+asHtmlUrl = id

yesod-core/Yesod/Shakespeare.hs

@@ -24,10 +24,6 @@ module Yesod.Shakespeare (
       -- * i18n
     , getMessageRender
 
-      -- * Formerly Yesod.Core.Class.Yesod
-    , jelper
-    , asyncHelper
-    , jsToHtml
       -- * Formerly Yesod.Core.Handler
       -- ** Redirecting
     , redirectToPost
@@ -51,8 +47,9 @@ module Yesod.Shakespeare (
     , module Text.Shakespeare.I18N
 ) where
 
+import           Control.Monad.IO.Class (MonadIO)
 import           Control.Monad                      (liftM, forM)
-import Control.Monad.Trans.Class (lift)
+import           Control.Monad.Trans.Class (lift)
 import Text.Shakespeare.I18N
 import qualified Data.ByteString.Lazy               as L
 import           Data.List                          (foldl', nub)
@@ -63,7 +60,6 @@ import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP)
 import Data.Text (Text)
 import qualified Data.Text.Lazy as TL
 import Data.Text.Lazy.Builder (fromLazyText, toLazyText)
-import           Data.Text.Lazy.Encoding            (encodeUtf8)
 import Data.Monoid (Last(..), mempty)
 import qualified Data.Map as Map
 
@@ -80,6 +76,11 @@ import Yesod.Core.Handler (getUrlRenderParams, toTextUrl, invalidArgs, permissio
 import Yesod.Core.Content (ToContent(..), ToTypedContent(..), HasContentType(..), typeJavascript, typeCss)
 import           Yesod.Routes.Class            (Route)
 
+-- for hamlet expansion
+import qualified Data.Foldable
+import qualified Data.Text
+import Text.Hamlet (asHtmlUrl)
+
 type Translate msg = msg -> Html
 type HtmlUrlI18n msg url = Translate msg -> Render url -> Html
 type Render url = url -> [(Text, Text)] -> Text
@@ -158,153 +159,6 @@ $doctype 5
             <input type="submit" value="Continue">
 |] >>= sendResponse
 
-------------------------------
--- from Yesod.Core.Class.Yesod
-------------------------------
-type AddStaticContent site = Text -- ^ filename extension
-                          -> Text -- ^ mime-type
-                          -> L.ByteString -- ^ content
-                          -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
-
--- | Convert a widget to a 'PageContent'.
--- not bound to the Yesod typeclass
-{- widgetToPageContentUnbound
-  :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, Eq (Route site))
-  => AddStaticContent site -> site -> ScriptLoadPosition site -> WidgetT site IO ()
-  -> HandlerT site m (PageContent (Route site))
-  -}
-widgetToPageContentUnbound addStaticContent jsLoader w = do
-    master <- getYesod
-    hd <- HandlerT return
-    ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style mJS' (Head head')) <- lift $ unWidgetT w hd
-    let jscript = fmap (\x -> Javascript . x) mJS'
-    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 <head> 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
-                    <script src="#{s}">
-                $nothing
-                    <script>^{jelper j}
-        |]
-
-        headAll = [hamlet|
-            $newline never
-            \^{head'}
-            $forall s <- stylesheets
-                ^{mkLinkTag s}
-            $forall s <- css
-                $maybe t <- right $ snd s
-                    $maybe media <- fst s
-                        <link rel=stylesheet media=#{media} href=#{t}>
-                    $nothing
-                        <link rel=stylesheet href=#{t}>
-                $maybe content <- left $ snd s
-                    $maybe media <- fst s
-                        <style media=#{media}>#{content}
-                    $nothing
-                        <style>#{content}
-            $case jsLoader master
-              $of BottomOfBody
-              $of BottomOfHeadAsync asyncJsLoader
-                  ^{asyncJsLoader asyncScripts mcomplete}
-              $of BottomOfHeadBlocking
-                  ^{regularScriptLoad}
-        |]
-    let bodyScript = [hamlet|
-            $newline never
-            ^{body}
-            ^{regularScriptLoad}
-        |]
-
-    return $ PageContent title headAll $
-        case jsLoader master of
-            BottomOfBody -> bodyScript
-            _ -> body
-  where
-    renderLoc' render' (Local url) = render' url []
-    renderLoc' _ (Remote s) = s
-
-    addAttr x (y, z) = x H.! H.customAttribute (H.textTag y) (H.toValue z)
-    mkScriptTag (Script loc attrs) render' =
-        foldl' addAttr H.script (("src", renderLoc' render' loc) : attrs) $ return ()
-    mkLinkTag (Stylesheet loc attrs) render' =
-        foldl' addAttr H.link
-            ( ("rel", "stylesheet")
-            : ("href", renderLoc' render' loc)
-            : attrs
-            )
-
-    runUniqueList :: Eq x => UniqueList x -> [x]
-    runUniqueList (UniqueList x) = nub $ x []
-
-asyncHelper :: (url -> [x] -> Text)
-         -> [Script (url)]
-         -> Maybe (JavascriptUrl (url))
-         -> Maybe Text
-         -> (Maybe (HtmlUrl url), [Text])
-asyncHelper render scripts jscript jsLoc =
-    (mcomplete, scripts'')
-  where
-    scripts' = map goScript scripts
-    scripts'' =
-        case jsLoc of
-            Just s -> scripts' ++ [s]
-            Nothing -> scripts'
-    goScript (Script (Local url) _) = render url []
-    goScript (Script (Remote s) _) = s
-    mcomplete =
-        case jsLoc of
-            Just{} -> Nothing
-            Nothing ->
-                case jscript of
-                    Nothing -> Nothing
-                    Just j -> Just $ jelper j
-
-jsToHtml :: Javascript -> Html
-jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b
-
-jelper :: JavascriptUrl url -> HtmlUrl url
-jelper = fmap jsToHtml
-
-right :: Either a b -> Maybe b
-right (Right x) = Just x
-right _ = Nothing
-
-left :: Either a b -> Maybe a
-left (Left x) = Just x
-left _ = Nothing
-
 ------------------------------------
 -- Formerly Yesod.Core.Content
 ------------------------------------

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -3,9 +3,9 @@
 {-# LANGUAGE ViewPatterns #-}
 module YesodCoreTest.ErrorHandling
     ( errorHandlingTest
-    , Widget
     ) where
 import Yesod.Core
+import Yesod.Shakespeare (whamlet)
 import Yesod.Core.Widget
 import Test.Hspec
 import Network.Wai

yesod-core/test/YesodCoreTest/JsLoader.hs

@@ -8,6 +8,7 @@ import YesodCoreTest.JsLoaderSites.Bottom (B(..))
 import Test.Hspec
 
 import Yesod.Core
+import Yesod.Core.Widget
 import Network.Wai.Test
 
 data H = H

yesod-core/yesod-core.cabal

@@ -104,7 +104,7 @@ library
                      Yesod.Routes.TH.ParseRoute
                      Yesod.Routes.TH.RouteAttrs
 
-    ghc-options:     -Wall
+    ghc-options:     -Wall -ddump-splices -ddump-to-file
     -- Following line added due to: https://github.com/yesodweb/yesod/issues/545
     -- This looks like a GHC bug
     extensions:      MultiParamTypeClasses