From fc6551c6500dd93b8d2d726c88c42debe7239cc9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 13 Mar 2013 10:15:47 +0200 Subject: [PATCH] defaultLayoutT --- yesod-core/Yesod/Core.hs | 68 +++++++++++++++++++ yesod-core/Yesod/Core/Types.hs | 6 +- yesod-core/Yesod/Core/Types/Orphan.hs | 19 ++++++ .../test/YesodCoreTest/NoOverloadedStrings.hs | 16 +++++ .../YesodCoreTest/NoOverloadedStringsSub.hs | 1 + 5 files changed, 109 insertions(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index c70bd0ff..8f81d438 100644 --- a/yesod-core/Yesod/Core.hs +++ b/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 diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index f7c29094..ce22b666 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/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 diff --git a/yesod-core/Yesod/Core/Types/Orphan.hs b/yesod-core/Yesod/Core/Types/Orphan.hs index 25f8fc03..e9c361fc 100644 --- a/yesod-core/Yesod/Core/Types/Orphan.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs index 798aa09b..b0e58953 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/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| +

Used defaultLayoutT + 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 diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs index 9eb1ef24..48886c7a 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs +++ b/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 |]