More incomplete changes

yesod-core/Yesod/Core.hs

@@ -94,7 +94,7 @@ import Data.Version (showVersion)
 import Yesod.Routes.Class (RenderRoute (..))
 
 -- | Return an 'Unauthorized' value, with the given i18n message.
-unauthorizedI :: RenderMessage site msg => msg -> GHandler site AuthResult
+unauthorizedI :: (Monad m, RenderMessage site msg) => msg -> HandlerT site m AuthResult
 unauthorizedI msg = do
     mr <- getMessageRender
     return $ Unauthorized $ mr msg
@@ -109,44 +109,14 @@ yesodVersion = showVersion Paths_yesod_core.version
 maybeAuthorized :: Yesod site
                 => Route site
                 -> Bool -- ^ is this a write request?
-                -> GHandler site (Maybe (Route site))
+                -> HandlerT site IO (Maybe (Route site))
 maybeAuthorized r isWrite = do
     x <- isAuthorized r isWrite
     return $ if x == Authorized then Just r else Nothing
 
-defaultLayoutT :: ( HandlerSite m ~ sub
+defaultLayoutT :: Yesod parent
-                  , Yesod (HandlerMaster m)
+               => WidgetT child m ()
-                  , MonadHandler m
+               -> HandlerT parent m RepHtml
-                  )
+defaultLayoutT (WidgetT (HandlerT f)) = HandlerT $ \hd -> do
-               => GWidget sub ()
-               -> m RepHtml
-defaultLayoutT (GWidget (GHandler f)) = do
-    hd <- askHandlerData
     ((), gwdata) <- liftResourceT $ f hd
-    liftHandlerMaster $ defaultLayout $ GWidget $ return ((), renderGWData (rheRender $ handlerEnv hd) gwdata)
+    unHandlerT $ defaultLayout $ WidgetT $ 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/Class/Dispatch.hs

@@ -21,16 +21,16 @@ import           Control.Monad.Trans.Control  (MonadBaseControl)
 class Yesod site => YesodDispatch site where
     yesodDispatch :: YesodRunnerEnv site -> W.Application
 
-class YesodSubDispatch sub m where
+class YesodSubDispatch sub parent where
     yesodSubDispatch
-        :: (MonadHandler m, master ~ HandlerMaster m, Yesod master)
+        :: Monad m
-        => (m TypedContent
+        => (HandlerT parent m TypedContent
-                -> YesodRunnerEnv master
+                -> YesodRunnerEnv parent
-                -> Maybe (Route master)
+                -> Maybe (Route parent)
                 -> W.Application)
-        -> (master -> sub)
+        -> (parent -> sub)
-        -> (Route sub -> Route master)
+        -> (Route sub -> Route parent)
-        -> YesodRunnerEnv master
+        -> YesodRunnerEnv parent
         -> W.Application
 
 instance YesodSubDispatch WaiSubsite master where
@@ -39,16 +39,18 @@ instance YesodSubDispatch WaiSubsite master where
       where
         WaiSubsite app = toSub site
 
-subHelper :: (HandlerSite m ~ master, MonadHandler m)
+-- | A helper function for creating YesodSubDispatch instances, used by the
-          => (m TypedContent
+-- internal generated code.
-                -> YesodRunnerEnv master
+subHelper :: Monad m
-                -> Maybe (Route master)
+          => (HandlerT parent m TypedContent
+                -> YesodRunnerEnv parent
+                -> Maybe (Route parent)
                 -> W.Application)
-          -> (master -> sub)
+          -> (parent -> child)
-          -> (Route sub -> Route master)
+          -> (Route child -> Route parent)
-          -> HandlerT sub m TypedContent
+          -> HandlerT child (HandlerT parent m) TypedContent
-          -> YesodRunnerEnv master
+          -> YesodRunnerEnv parent
-          -> Maybe (Route sub)
+          -> Maybe (Route child)
           -> W.Application
 subHelper parentRunner getSub toMaster handlert env route =
     parentRunner base env (fmap toMaster route)

yesod-core/Yesod/Core/Dispatch.hs

@@ -122,8 +122,8 @@ mkYesodGeneral name args clazzes isSub resS = do
         context = if isSub then cxt $ yesod : map return clazzes
                            else return []
         yesod   = classP ''HandlerReader [master]
-        handler = tySynD (mkName "Handler") [] [t| GHandler $master    |]
+        handler = tySynD (mkName "Handler") [] [t| HandlerT $master IO    |]
-        widget  = tySynD (mkName "Widget")  [] [t| GWidget  $master () |]
+        widget  = tySynD (mkName "Widget")  [] [t| WidgetT  $master IO () |]
         res     = map (fmap parseType) resS
         subCons = conT $ mkName name
         subArgs = map (varT. mkName) args

yesod-core/Yesod/Core/Handler.hs

@@ -297,7 +297,8 @@ handlerToIO =
         newReq    = oldReq { reqWaiRequest = newWaiReq }
         clearedOldHandlerData =
           oldHandlerData { handlerRequest = err "handlerRequest never here"
-                         , handlerState   = err "handlerState never here" }
+                         , handlerState   = err "handlerState never here"
+                         , handlerToParent = const () }
             where
               err :: String -> a
               err = error . ("handlerToIO: clearedOldHandlerData/" ++)

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

@@ -12,11 +12,12 @@ 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)
+import           Control.Monad.Trans.Resource (runResourceT, transResourceT, ResourceT, joinResourceT)
 import           Control.Monad.Trans.Control  (MonadBaseControl)
 import qualified Data.ByteString              as S
 import qualified Data.ByteString.Char8        as S8
@@ -45,10 +46,10 @@ import           Yesod.Core.Internal.Request  (parseWaiRequest,
 import           Yesod.Routes.Class           (Route, renderRoute)
 
 -- | Function used internally by Yesod in the process of converting a
--- 'GHandler' into an 'Application'. Should not be needed by users.
+-- 'HandlerT' into an 'Application'. Should not be needed by users.
 runHandler :: ToTypedContent c
            => RunHandlerEnv site
-           -> GHandler site c
+           -> HandlerT site IO c
            -> YesodApp
 runHandler rhe@RunHandlerEnv {..} handler yreq = do
     let toErrorHandler e =
@@ -66,8 +67,9 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do
             { handlerRequest = yreq
             , handlerEnv     = rhe
             , handlerState   = istate
+            , handlerToParent = const ()
             }
-    contents' <- catch (fmap Right $ unGHandler handler hd)
+    contents' <- catch (fmap Right $ unHandlerT handler hd)
         (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
                       $ fromException e)
     state <- liftIO $ I.readIORef istate
@@ -128,31 +130,31 @@ safeEh log' er req = do
         (toContent ("Internal Server Error" :: S.ByteString))
         (reqSession req)
 
--- | Run a 'GHandler' completely outside of Yesod.  This
+-- | Run a 'HandlerT' completely outside of Yesod.  This
 -- function comes with many caveats and you shouldn't use it
 -- unless you fully understand what it's doing and how it works.
 --
 -- As of now, there's only one reason to use this function at
--- all: in order to run unit tests of functions inside 'GHandler'
+-- all: in order to run unit tests of functions inside 'HandlerT'
 -- but that aren't easily testable with a full HTTP request.
 -- Even so, it's better to use @wai-test@ or @yesod-test@ instead
 -- of using this function.
 --
 -- This function will create a fake HTTP request (both @wai@'s
 -- 'Request' and @yesod@'s 'Request') and feed it to the
--- @GHandler@.  The only useful information the @GHandler@ may
+-- @HandlerT@.  The only useful information the @HandlerT@ may
 -- get from the request is the session map, which you must supply
 -- as argument to @runFakeHandler@.  All other fields contain
 -- fake information, which means that they can be accessed but
 -- won't have any useful information.  The response of the
--- @GHandler@ is completely ignored, including changes to the
+-- @HandlerT@ is completely ignored, including changes to the
 -- session, cookies or headers.  We only return you the
--- @GHandler@'s return value.
+-- @HandlerT@'s return value.
 runFakeHandler :: (Yesod site, MonadIO m) =>
                   SessionMap
                -> (site -> Logger)
                -> site
-               -> GHandler site a
+               -> HandlerT site IO a
                -> m (Either ErrorResponse a)
 runFakeHandler fakeSessionMap logger site handler = liftIO $ do
   ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
@@ -208,7 +210,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
 {-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
 
 yesodRunner :: (ToTypedContent res, Yesod site)
-            => GHandler site res
+            => HandlerT site IO res
             -> YesodRunnerEnv site
             -> Maybe (Route site)
             -> Application
@@ -269,20 +271,18 @@ resolveApproot master req =
         ApprootMaster f -> f master
         ApprootRequest f -> f master req
 
-stripHandlerT :: (MonadHandler m, MonadBaseControl IO m)
+stripHandlerT :: HandlerT child (HandlerT parent m) a
-              => HandlerT sub m a
+              -> (parent -> child)
-              -> (HandlerSite m -> sub)
+              -> (Route child -> Route parent)
-              -> (Route sub -> Route (HandlerSite m))
+              -> Maybe (Route child)
-              -> Maybe (Route sub)
+              -> HandlerT parent m a
-              -> m a
+stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do
-stripHandlerT (HandlerT f) getSub toMaster newRoute = do
-    hd <- askHandlerData
-
     let env = handlerEnv hd
-    f hd
+    joinResourceT $ transResourceT (($ hd) . unHandlerT) $ f hd
         { handlerEnv = env
             { rheSite = getSub $ rheSite env
             , rheRoute = newRoute
             , rheRender = \url params -> rheRender env (toMaster url) params
             }
+        , handlerToParent = toMaster
         }

yesod-core/Yesod/Core/Json.hs

@@ -48,9 +48,9 @@ import Control.Monad.Trans.Resource (liftResourceT)
 --
 -- /Since: 0.3.0/
 defaultLayoutJson :: (Yesod site, J.ToJSON a)
-                  => WidgetT site m ()  -- ^ HTML
+                  => WidgetT site IO ()  -- ^ HTML
-                  -> HandlerT site m a  -- ^ JSON
+                  -> HandlerT site IO a  -- ^ JSON
-                  -> HandlerT site m TypedContent
+                  -> HandlerT site IO TypedContent
 defaultLayoutJson w json = selectRep $ do
     provideRep $ defaultLayout w
     provideRep $ fmap J.toJSON json
@@ -59,7 +59,7 @@ defaultLayoutJson w json = selectRep $ do
 -- support conversion to JSON via 'J.ToJSON'.
 --
 -- /Since: 0.3.0/
-jsonToRepJson :: J.ToJSON a => a -> HandlerT site m J.Value
+jsonToRepJson :: (Monad m, J.ToJSON a) => a -> m J.Value
 jsonToRepJson = return . J.toJSON
 
 -- | Parse the request body to a data type as a JSON value.  The
@@ -68,7 +68,7 @@ jsonToRepJson = return . J.toJSON
 -- 'J.Value'@.
 --
 -- /Since: 0.3.0/
-parseJsonBody :: (MonadResource m, J.FromJSON a) => m (J.Result a)
+parseJsonBody :: (MonadResource m, HandlerReader m, J.FromJSON a) => m (J.Result a)
 parseJsonBody = do
     req <- waiRequest
     eValue <- runExceptionT

yesod-core/Yesod/Core/Types.hs

@@ -179,10 +179,11 @@ data RunHandlerEnv site = RunHandlerEnv
       -- Since 1.2.0
     }
 
-data HandlerData site = HandlerData
+data HandlerData site parentRoute = HandlerData
-    { handlerRequest :: !YesodRequest
+    { handlerRequest  :: !YesodRequest
-    , handlerEnv     :: !(RunHandlerEnv site)
+    , handlerEnv      :: !(RunHandlerEnv site)
-    , handlerState   :: !(IORef GHState)
+    , handlerState    :: !(IORef GHState)
+    , handlerToParent :: !(Route site -> parentRoute)
     }
 
 data YesodRunnerEnv site = YesodRunnerEnv
@@ -194,9 +195,13 @@ data YesodRunnerEnv site = YesodRunnerEnv
 -- | 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
-    { unHandlerT :: HandlerData site -> ResourceT m a
+    { unHandlerT :: HandlerData site (MonadRoute m) -> ResourceT m a
     }
 
+type family MonadRoute (m :: * -> *)
+type instance MonadRoute IO = ()
+type instance MonadRoute (HandlerT site m) = (Route site)
+
 data GHState = GHState
     { ghsSession :: SessionMap
     , ghsRBC     :: Maybe RequestBodyContents

yesod-core/Yesod/Core/Widget.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -50,6 +51,8 @@ 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)
 import Data.Text (Text)
@@ -215,3 +218,21 @@ tell w = WidgetT $ return ((), w)
 
 toUnique :: x -> UniqueList x
 toUnique = UniqueList . (:)
+
+liftHandlerT :: MonadIO m
+             => HandlerT site IO a
+             -> HandlerT site m a
+liftHandlerT (HandlerT f) =
+    HandlerT $ transResourceT liftIO . f . fixToParent
+  where
+    fixToParent hd = hd { handlerToParent = const () }
+
+liftWidget :: MonadIO m
+           => WidgetT child IO a
+           -> HandlerT child (HandlerT parent m) (WidgetT parent m a)
+liftWidget (WidgetT f) = HandlerT $ \hd -> do
+    (a, gwd) <- unHandlerT (liftHandlerT f) hd
+    return $ WidgetT $ HandlerT $ const $ return (a, liftGWD (handlerToParent hd) gwd)
+
+liftGWD :: (child -> parent) -> GWData child -> GWData parent
+liftGWD = error "liftGWD"