Some cleanup

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

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
+    yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m
-        :: (m TypedContent
+                     -> W.Application
-                -> YesodRunnerEnv (HandlerSite m)
-                -> Maybe (Route (HandlerSite m))
-                -> W.Application)
-        -> (HandlerSite m -> sub)
-        -> (Route sub -> Route (HandlerSite m))
-        -> YesodRunnerEnv (HandlerSite 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
+subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained.
-          => (HandlerT parent m TypedContent
+          => HandlerT child (HandlerT parent m) TypedContent
-                -> YesodRunnerEnv parent
+          -> YesodSubRunnerEnv child parent (HandlerT parent m)
-                -> Maybe (Route parent)
-                -> W.Application)
-          -> (parent -> child)
-          -> (Route child -> Route parent)
-          -> HandlerT child (HandlerT parent m) TypedContent
-          -> YesodRunnerEnv parent
           -> Maybe (Route child)
           -> W.Application
-subHelper parentRunner getSub toMaster handlert env route =
+subHelper handlert YesodSubRunnerEnv {..} route =
-    parentRunner base env (fmap toMaster route)
+    ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)
   where
-    base = stripHandlerT (fmap toTypedContent handlert) getSub toMaster route
+    base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route

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

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, (.=))

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
+            clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res
-                { mdsRunHandler = [|yesodRunner|]
-                , mdsSubDispatcher = [|yesodSubDispatch|]
-                , mdsGetPathInfo = [|W.pathInfo|]
-                , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
-                , mdsMethod = [|W.requestMethod|]
-                , mds404 = [|notFound >> return ()|]
-                , mds405 = [|badMethod >> return ()|]
-                } res
             return $ FunD 'yesodDispatch [clause']
    in sequence [instanceD context yDispatch [thisDispatch]]
 
 
 mkYesodSubDispatch :: [ResourceTree String] -> Q Exp
 mkYesodSubDispatch res = do
-    parentRunner <- newName "parentRunner"
+    clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
-    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
     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)
 

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)

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.Resource (runResourceT, withInternalState, runInternalState)
-import           Control.Monad.Trans.Control  (MonadBaseControl)
 import qualified Data.ByteString              as S
 import qualified Data.ByteString.Char8        as S8
 import qualified Data.IORef                   as I

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)
 

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

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

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)

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
+getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite)
-
-instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where
-    yesodSubDispatch = $(mkYesodSubDispatch resourcesSubsite)
 
 getBarR :: Monad m => m T.Text
 getBarR = return $ T.pack "BarR"

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 Yesod.Core.Types
-import Data.Monoid (mempty)
-import qualified Data.Text as T
-import qualified Data.ByteString.Lazy.Char8 as L8
 
-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

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