diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 3075f9a7..4c777853 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -70,9 +70,6 @@ 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 @@ -80,8 +77,6 @@ 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 diff --git a/yesod-core/Yesod/Core/Class/Dispatch.hs b/yesod-core/Yesod/Core/Class/Dispatch.hs index c3f8abb9..fe014ac2 100644 --- a/yesod-core/Yesod/Core/Class/Dispatch.hs +++ b/yesod-core/Yesod/Core/Class/Dispatch.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} @@ -12,9 +13,7 @@ import Yesod.Core.Types import Yesod.Core.Content import Yesod.Core.Class.Yesod import Yesod.Core.Class.Handler -import Yesod.Core.Internal.Request (textQueryString) import Yesod.Core.Internal.Run -import Control.Monad.Trans.Control (MonadBaseControl) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -22,36 +21,23 @@ class Yesod site => YesodDispatch site where yesodDispatch :: YesodRunnerEnv site -> W.Application class YesodSubDispatch sub m where - yesodSubDispatch - :: (m TypedContent - -> YesodRunnerEnv (HandlerSite m) - -> Maybe (Route (HandlerSite m)) - -> W.Application) - -> (HandlerSite m -> sub) - -> (Route sub -> Route (HandlerSite m)) - -> YesodRunnerEnv (HandlerSite m) - -> W.Application + yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m + -> W.Application instance YesodSubDispatch WaiSubsite master where - yesodSubDispatch _ toSub _ YesodRunnerEnv { yreSite = site } req = + yesodSubDispatch YesodSubRunnerEnv {..} req = app req where - WaiSubsite app = toSub site + WaiSubsite app = ysreGetSub $ yreSite $ ysreParentEnv -- | A helper function for creating YesodSubDispatch instances, used by the -- internal generated code. -subHelper :: Monad m - => (HandlerT parent m TypedContent - -> YesodRunnerEnv parent - -> Maybe (Route parent) - -> W.Application) - -> (parent -> child) - -> (Route child -> Route parent) - -> HandlerT child (HandlerT parent m) TypedContent - -> YesodRunnerEnv parent +subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained. + => HandlerT child (HandlerT parent m) TypedContent + -> YesodSubRunnerEnv child parent (HandlerT parent m) -> Maybe (Route child) -> W.Application -subHelper parentRunner getSub toMaster handlert env route = - parentRunner base env (fmap toMaster route) +subHelper handlert YesodSubRunnerEnv {..} route = + ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) where - base = stripHandlerT (fmap toTypedContent handlert) getSub toMaster route + base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs index 326d2dba..4885fc21 100644 --- a/yesod-core/Yesod/Core/Class/Handler.hs +++ b/yesod-core/Yesod/Core/Class/Handler.hs @@ -6,9 +6,6 @@ module Yesod.Core.Class.Handler where import Yesod.Core.Types -import Control.Monad.Trans.Class (MonadTrans) -import Control.Monad.Trans.Resource -import Control.Monad.Trans.Control import Data.IORef.Lifted (atomicModifyIORef) import Control.Exception.Lifted (throwIO) import Control.Monad.Base diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs index d58cb435..efe31a9e 100644 --- a/yesod-core/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/Yesod/Core/Class/Yesod.hs @@ -7,7 +7,6 @@ module Yesod.Core.Class.Yesod where import Control.Monad.Logger (logErrorS) import Yesod.Core.Content import Yesod.Core.Handler -import Yesod.Core.Class.Handler import Yesod.Routes.Class @@ -18,8 +17,6 @@ import Control.Monad (forM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource) -import Control.Monad.Trans.Resource -import Control.Monad.Trans.Control import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Aeson (object, (.=)) diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index 020e496b..c71ffe8c 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -128,6 +128,25 @@ mkYesodGeneral name args clazzes isSub resS = do subCons = conT $ mkName name subArgs = map (varT. mkName) args +mkMDS :: Q Exp -> MkDispatchSettings +mkMDS rh = MkDispatchSettings + { mdsRunHandler = rh + , mdsSubDispatcher = + [|\parentRunner getSub toParent env -> yesodSubDispatch + YesodSubRunnerEnv + { ysreParentRunner = parentRunner + , ysreGetSub = getSub + , ysreToParentRoute = toParent + , ysreParentEnv = env + } + |] + , mdsGetPathInfo = [|W.pathInfo|] + , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] + , mdsMethod = [|W.requestMethod|] + , mds404 = [|notFound >> return ()|] + , mds405 = [|badMethod >> return ()|] + } + -- | If the generation of @'YesodDispatch'@ instance require finer -- control of the types, contexts etc. using this combinator. You will -- hardly need this generality. However, in certain situations, like @@ -141,57 +160,22 @@ mkDispatchInstance :: CxtQ -- ^ The context mkDispatchInstance context _sub master res = do let yDispatch = conT ''YesodDispatch `appT` master thisDispatch = do - clause' <- mkDispatchClause MkDispatchSettings - { mdsRunHandler = [|yesodRunner|] - , mdsSubDispatcher = [|yesodSubDispatch|] - , mdsGetPathInfo = [|W.pathInfo|] - , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] - , mdsMethod = [|W.requestMethod|] - , mds404 = [|notFound >> return ()|] - , mds405 = [|badMethod >> return ()|] - } res + clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res return $ FunD 'yesodDispatch [clause'] in sequence [instanceD context yDispatch [thisDispatch]] mkYesodSubDispatch :: [ResourceTree String] -> Q Exp mkYesodSubDispatch res = do - parentRunner <- newName "parentRunner" - getSub <- newName "getSub" - toMaster <- newName "toMaster" - runner <- newName "runner" - clause' <- mkDispatchClause MkDispatchSettings - { mdsRunHandler = [|subHelper - $(return $ VarE parentRunner) - $(return $ VarE getSub) - $(return $ VarE toMaster) - . fmap toTypedContent - |] - , mdsSubDispatcher = [|yesodSubDispatch|] - , mdsGetPathInfo = [|W.pathInfo|] - , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] - , mdsMethod = [|W.requestMethod|] - , mds404 = [|notFound >> return ()|] - , mds405 = [|badMethod >> return ()|] - } res + clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res inner <- newName "inner" let innerFun = FunD inner [clause'] - runnerFun = FunD runner - [ Clause - [] - (NormalB $ VarE 'subHelper - `AppE` VarE parentRunner - `AppE` VarE getSub - `AppE` VarE toMaster - ) - [] - ] helper <- newName "helper" let fun = FunD helper [ Clause - [VarP parentRunner, VarP getSub, VarP toMaster] + [] (NormalB $ VarE inner) - [innerFun, runnerFun] + [innerFun] ] return $ LetE [fun] (VarE helper) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 47cbbce5..c48a2cec 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -163,7 +163,7 @@ import Yesod.Core.Content (ToTypedContent (..), simpleConte import Yesod.Core.Internal.Util (formatRFC1123) import Text.Blaze.Html (preEscapedToMarkup, toHtml) -import Control.Monad.Trans.Resource (ResourceT, runResourceT) +import Control.Monad.Trans.Resource (ResourceT) import Data.Dynamic (fromDynamic, toDyn) import qualified Data.IORef as I import Data.Maybe (listToMaybe) diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index 1643eefa..36a12b16 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -7,18 +7,15 @@ module Yesod.Core.Internal.Run where import Yesod.Core.Internal.Response -import Yesod.Core.Class.Handler import Blaze.ByteString.Builder (toByteString) import Control.Applicative ((<$>)) import Control.Exception (fromException) import Control.Exception.Lifted (catch) -import Control.Monad (join) import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (LogLevel (LevelError), LogSource, liftLoc) -import Control.Monad.Trans.Resource (runResourceT, transResourceT, ResourceT, joinResourceT, withInternalState, runInternalState) -import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.IORef as I diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index 20952c21..df7043be 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -25,7 +25,6 @@ import Yesod.Core.Class.Yesod (defaultLayout, Yesod) import Yesod.Core.Class.Handler import Yesod.Core.Widget (WidgetT) import Yesod.Routes.Class -import Control.Applicative ((<$>)) import Control.Monad (join) import qualified Data.Aeson as J import qualified Data.Aeson.Parser as JP @@ -38,7 +37,6 @@ import Network.Wai (requestBody, requestHeaders) import Network.Wai.Parse (parseHttpAccept) import qualified Data.ByteString.Char8 as B8 import Data.Maybe (listToMaybe) -import Control.Monad.Trans.Class (lift) import Control.Monad (liftM) import Control.Monad.Trans.Resource (liftResourceT) diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 9f98f702..cd6113ae 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -12,17 +12,15 @@ import qualified Blaze.ByteString.Builder.Char.Utf8 import Control.Applicative (Applicative (..)) import Control.Applicative ((<$>)) import Control.Arrow (first) -import Control.Exception (Exception, throwIO) +import Control.Exception (Exception) import Control.Failure (Failure (..)) 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)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel, LogSource, MonadLogger (..)) import Control.Monad.Trans.Control (MonadBaseControl (..)) -import Control.Monad.Trans.Resource +import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L import Data.Conduit (Flush, MonadThrow (..), @@ -55,7 +53,7 @@ import Text.Hamlet (HtmlUrl) import Text.Julius (JavascriptUrl) import Web.Cookie (SetCookie) import Yesod.Core.Internal.Util (getTime, putTime) -import Control.Monad.Trans.Class +import Control.Monad.Trans.Class (MonadTrans (..)) import Yesod.Routes.Class (RenderRoute (..)) -- Sessions @@ -193,6 +191,19 @@ data YesodRunnerEnv site = YesodRunnerEnv , yreSessionBackend :: !(Maybe SessionBackend) } +data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv + { ysreParentRunner :: !(ParentRunner parent parentMonad) + , ysreGetSub :: !(parent -> sub) + , ysreToParentRoute :: !(Route sub -> Route parent) + , ysreParentEnv :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner? + } + +type ParentRunner parent m + = m TypedContent + -> YesodRunnerEnv parent + -> Maybe (Route parent) + -> W.Application + -- | A generic handler monad, which can have a different subsite and master -- site. We define a newtype for better error message. newtype HandlerT site m a = HandlerT diff --git a/yesod-core/Yesod/Core/Widget.hs b/yesod-core/Yesod/Core/Widget.hs index 627531f1..3b36f4df 100644 --- a/yesod-core/Yesod/Core/Widget.hs +++ b/yesod-core/Yesod/Core/Widget.hs @@ -55,7 +55,6 @@ import Text.Cassius import Text.Julius import Yesod.Routes.Class import Yesod.Core.Handler (getMessageRender, getUrlRenderParams) -import Control.Monad.Trans.Resource (transResourceT) import Control.Monad.IO.Class (MonadIO, liftIO) import Text.Shakespeare.I18N (RenderMessage) import Control.Monad (liftM) @@ -71,7 +70,6 @@ import qualified Data.Text.Lazy as TL import Yesod.Core.Types import Yesod.Core.Class.Handler -import Control.Monad.Trans.Class preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup diff --git a/yesod-core/test/YesodCoreTest/CleanPath.hs b/yesod-core/test/YesodCoreTest/CleanPath.hs index d344f24f..f4eae3e4 100644 --- a/yesod-core/test/YesodCoreTest/CleanPath.hs +++ b/yesod-core/test/YesodCoreTest/CleanPath.hs @@ -30,7 +30,7 @@ instance RenderRoute Subsite where renderRoute (SubsiteRoute x) = (x, []) instance YesodSubDispatch Subsite master where - yesodSubDispatch _ _ _ _ req = return $ responseLBS + yesodSubDispatch _ req = return $ responseLBS status200 [ ("Content-Type", "SUBSITE") ] $ L8.pack $ show (pathInfo req) diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs index e7325166..0abb919e 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs @@ -14,10 +14,7 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import Control.Monad.Trans.Class getSubsite :: a -> Subsite -getSubsite = const Subsite - -instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where - yesodSubDispatch = $(mkYesodSubDispatch resourcesSubsite) +getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite) getBarR :: Monad m => m T.Text getBarR = return $ T.pack "BarR" diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs index 48886c7a..3888a893 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs +++ b/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs @@ -1,18 +1,22 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} module YesodCoreTest.NoOverloadedStringsSub where import Yesod.Core import Network.Wai -import Network.Wai.Test -import Data.Monoid (mempty) -import qualified Data.Text as T -import qualified Data.ByteString.Lazy.Char8 as L8 +import Yesod.Core.Types -data Subsite = Subsite +data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerT master IO) -> Application) mkYesodSubData "Subsite" [parseRoutes| /bar BarR GET /baz BazR GET /bin BinR GET |] + +instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where + yesodSubDispatch ysre = + f ysre + where + Subsite f = ysreGetSub ysre $ yreSite $ ysreParentEnv ysre diff --git a/yesod-core/test/YesodCoreTest/RequestBodySize.hs b/yesod-core/test/YesodCoreTest/RequestBodySize.hs index 98ee3cb5..c5b33d80 100644 --- a/yesod-core/test/YesodCoreTest/RequestBodySize.hs +++ b/yesod-core/test/YesodCoreTest/RequestBodySize.hs @@ -18,8 +18,6 @@ import qualified Data.Text as T import Data.Conduit import Data.Conduit.List (consume) import Data.Conduit.Binary (isolate) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Resource data Y = Y