defaultLayoutT

yesod-core/Yesod/Core.hs

@@ -1,4 +1,8 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module Yesod.Core
     ( -- * Type classes
@@ -43,6 +47,9 @@ module Yesod.Core
     -- * JS loaders
     , ScriptLoadPosition (..)
     , BottomOfHeadAsync
+      -- * Subsites
+    , defaultLayoutT
+    , MonadHandlerBase (..)
       -- * Misc
     , yesodVersion
     , yesodRender
@@ -61,6 +68,10 @@ module Yesod.Core
 import Yesod.Core.Content
 import Yesod.Core.Dispatch
 import Yesod.Core.Handler
+import Yesod.Core.Class.Handler
+import Data.IORef (readIORef, newIORef)
+import Control.Monad.IO.Class (liftIO)
+import Data.Text (Text)
 import Yesod.Core.Widget
 import Yesod.Core.Json
 import Yesod.Core.Types
@@ -69,6 +80,8 @@ import Text.Shakespeare.I18N
 import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)
 
 import Control.Monad.Logger
+import Control.Monad.Trans.Resource (MonadResource, liftResourceT)
+import Control.Monad.Trans.Class (MonadTrans)
 import Yesod.Core.Internal.Session
 import Yesod.Core.Class.Yesod
 import Yesod.Core.Class.Dispatch
@@ -98,3 +111,58 @@ maybeAuthorized :: Yesod a
 maybeAuthorized r isWrite = do
     x <- isAuthorized r isWrite
     return $ if x == Authorized then Just r else Nothing
+
+class (MonadResource m, HandlerState m, Yesod (HandlerBase m)) => MonadHandlerBase m where
+    type HandlerBase m
+    type HandlerSite m
+    liftHandler :: GHandler (HandlerBase m) (HandlerBase m) a -> m a
+    askHandlerData :: m (HandlerData (HandlerSite m) (HandlerSite m))
+instance Yesod master => MonadHandlerBase (GHandler master master) where
+    type HandlerBase (GHandler master master) = master
+    type HandlerSite (GHandler master master) = master
+    liftHandler = id
+    askHandlerData = GHandler return
+instance MonadHandlerBase m => MonadHandlerBase (HandlerT sub m) where
+    type HandlerBase (HandlerT sub m) = HandlerBase m
+    type HandlerSite (HandlerT sub m) = sub
+    liftHandler = lift . liftHandler
+    askHandlerData = HandlerT return
+
+defaultLayoutT :: ( HandlerState m
+                  , HandlerSite m ~ sub
+                  , Yesod (HandlerBase m)
+                  , MonadHandlerBase m
+                  , MonadResource m
+                  )
+               => GWidget sub sub ()
+               -> m RepHtml
+defaultLayoutT (GWidget (GHandler f)) = do
+    hd <- askHandlerData
+    ((), gwdata) <- liftResourceT $ f hd
+    liftHandler $ defaultLayout $ GWidget $ return ((), renderGWData (rheRender $ handlerEnv hd) gwdata)
+
+renderGWData :: (x -> [(Text, Text)] -> Text) -> GWData x -> GWData y
+renderGWData render gwd = GWData
+    { gwdBody = fixBody $ gwdBody gwd
+    , gwdTitle = gwdTitle gwd
+    , gwdScripts = fixUnique fixScript $ gwdScripts gwd
+    , gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd
+    , gwdCss = fmap fixCss $ gwdCss gwd
+    , gwdJavascript = fmap fixJS $ gwdJavascript gwd
+    , gwdHead = fixHead $ gwdHead gwd
+    }
+  where
+    fixBody (Body h) = Body $ const $ h render
+    fixHead (Head h) = Head $ const $ h render
+
+    fixUnique go (UniqueList f) = UniqueList (map go (f []) ++)
+
+    fixScript (Script loc attrs) = Script (fixLoc loc) attrs
+    fixStyle (Stylesheet loc attrs) = Stylesheet (fixLoc loc) attrs
+
+    fixLoc (Local url) = Remote $ render url []
+    fixLoc (Remote t) = Remote t
+
+    fixCss f = const $ f render
+
+    fixJS f = const $ f render

yesod-core/Yesod/Core/Types.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Yesod.Core.Types where
 
 import qualified Blaze.ByteString.Builder           as BBuilder
@@ -12,7 +13,7 @@ import           Control.Applicative                ((<$>))
 import           Control.Arrow                      (first)
 import           Control.Exception                  (Exception, throwIO)
 import           Control.Failure                    (Failure (..))
-import           Control.Monad                      (liftM)
+import           Control.Monad                      (liftM, ap)
 import           Control.Monad.Trans.Class          (MonadTrans)
 import qualified Control.Monad.Trans.Class          as Trans
 import           Control.Monad.Base                 (MonadBase (liftBase))
@@ -208,6 +209,9 @@ instance Monad m => Monad (HandlerT sub m) where
     HandlerT f >>= g = HandlerT $ \hd -> f hd >>= \x -> unHandlerT (g x) hd
 instance Monad m => Functor (HandlerT sub m) where
     fmap = liftM
+instance Monad m => Applicative (HandlerT sub m) where
+    pure = return
+    (<*>) = ap
 
 data GHState = GHState
     { ghsSession :: SessionMap

yesod-core/Yesod/Core/Types/Orphan.hs

@@ -1,7 +1,26 @@
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Yesod.Core.Types.Orphan where
 
 import Yesod.Core.Types
 import Control.Monad.Trans.Class
+import           Control.Monad.IO.Class             (MonadIO (liftIO))
+import           Control.Monad.Base                 (MonadBase (liftBase))
+import           Control.Monad.Trans.Control        (MonadBaseControl (..))
+import           Control.Monad.Trans.Resource       (MonadResource (..))
+import           Data.Conduit                       (MonadThrow (..))
 
 instance MonadTrans (HandlerT sub) where
     lift = HandlerT . const
+instance MonadBase b m => MonadBase b (HandlerT sub m) where
+    liftBase = lift . liftBase
+instance MonadBaseControl b m => MonadBaseControl b (HandlerT sub m)
+instance MonadResource m => MonadResource (HandlerT sub m) where
+    liftResourceT = lift . liftResourceT
+instance MonadIO m => MonadIO (HandlerT sub m)
+instance MonadThrow m => MonadThrow (HandlerT sub m) where
+    monadThrow = lift . monadThrow

yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs

@@ -24,6 +24,13 @@ getBarR = return $ T.pack "BarR"
 getBazR :: Yesod master => HandlerT Subsite (GHandler master master) RepHtml
 getBazR = lift $ defaultLayout [whamlet|Used Default Layout|]
 
+getBinR :: MonadHandlerBase m => HandlerT Subsite m RepHtml
+getBinR = defaultLayoutT
+    [whamlet|
+        <p>Used defaultLayoutT
+        <a href=@{BazR}>Baz
+    |]
+
 data Y = Y
 mkYesod "Y" [parseRoutes|
 / RootR GET
@@ -63,8 +70,17 @@ case_deflayout = runner $ do
     assertBodyContains (L8.pack "Used Default Layout") res
     assertStatus 200 res
 
+case_deflayoutT :: IO ()
+case_deflayoutT = runner $ do
+    res <- request defaultRequest
+        { pathInfo = map T.pack ["subsite", "bin"]
+        }
+    assertBodyContains (L8.pack "Used defaultLayoutT") res
+    assertStatus 200 res
+
 noOverloadedTest :: Spec
 noOverloadedTest = describe "Test.NoOverloadedStrings" $ do
       it "sanity" case_sanity
       it "subsite" case_subsite
       it "deflayout" case_deflayout
+      it "deflayoutT" case_deflayoutT

yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs

@@ -14,4 +14,5 @@ data Subsite = Subsite
 mkYesodSubData "Subsite" [parseRoutes|
 /bar BarR GET
 /baz BazR GET
+/bin BinR GET
 |]