From 3e06942449cad0b52e218cb7e9f2c06b45b85e69 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 11 Jan 2018 23:13:32 +0200
Subject: [PATCH] Simplify YesodSubDispatch

---
 yesod-auth/Yesod/Auth.hs                          |  3 +--
 yesod-core/Yesod/Core/Class/Dispatch.hs           | 15 +++++++--------
 yesod-core/Yesod/Core/Types.hs                    |  8 ++++----
 .../test/YesodCoreTest/NoOverloadedStringsSub.hs  |  4 ++--
 yesod-static/Yesod/EmbeddedStatic.hs              |  2 +-
 yesod-static/Yesod/Static.hs                      |  2 +-
 6 files changed, 16 insertions(+), 18 deletions(-)

diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs
index 08ad2722..fe22654d 100644
--- a/yesod-auth/Yesod/Auth.hs
+++ b/yesod-auth/Yesod/Auth.hs
@@ -582,8 +582,7 @@ data AuthException = InvalidFacebookResponse
     deriving (Show, Typeable)
 instance Exception AuthException
 
--- FIXME HandlerSite m ~ SubHandlerSite m should be unnecessary
-instance (YesodAuth (HandlerSite m), HandlerSite m ~ SubHandlerSite m, MonadSubHandler m, MonadUnliftIO m) => YesodSubDispatch Auth m where
+instance YesodAuth master => YesodSubDispatch Auth master where
     yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
 
 asHtml :: Html -> Html
diff --git a/yesod-core/Yesod/Core/Class/Dispatch.hs b/yesod-core/Yesod/Core/Class/Dispatch.hs
index 106a0517..c4c1b641 100644
--- a/yesod-core/Yesod/Core/Class/Dispatch.hs
+++ b/yesod-core/Yesod/Core/Class/Dispatch.hs
@@ -19,16 +19,15 @@ import Control.Monad.Trans.Reader (ReaderT (..), ask)
 class Yesod site => YesodDispatch site where
     yesodDispatch :: YesodRunnerEnv site -> W.Application
 
-class YesodSubDispatch sub m where
-    yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m
-                     -> W.Application
+class YesodSubDispatch sub master where
+    yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application
 
 instance YesodSubDispatch WaiSubsite master where
     yesodSubDispatch YesodSubRunnerEnv {..} = app
       where
         WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
 
-instance MonadHandler m => YesodSubDispatch WaiSubsiteWithAuth m where
+instance YesodSubDispatch WaiSubsiteWithAuth master where
   yesodSubDispatch YesodSubRunnerEnv {..} req =
       ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
     where
@@ -90,9 +89,9 @@ instance (MonadSubHandler m, parent ~ SubHandlerSite m) => MonadSubHandler (Read
       }
 
 subHelper
-  :: (ToTypedContent content, MonadSubHandler m, master ~ HandlerSite m, parent ~ SubHandlerSite m)
-  => ReaderT (SubsiteData child master) m content
-  -> YesodSubRunnerEnv child parent m
+  :: ToTypedContent content
+  => ReaderT (SubsiteData child master) (HandlerFor master) content
+  -> YesodSubRunnerEnv child master
   -> Maybe (Route child)
   -> W.Application
 subHelper (ReaderT f) YesodSubRunnerEnv {..} mroute =
@@ -100,7 +99,7 @@ subHelper (ReaderT f) YesodSubRunnerEnv {..} mroute =
   where
     handler = fmap toTypedContent $ do
       tm <- getRouteToParent
-      f SubsiteData
+      liftHandler $ f SubsiteData
         { sdRouteToParent = tm . ysreToParentRoute
         , sdCurrentRoute = mroute
         , sdSubsiteData = ysreGetSub $ yreSite ysreParentEnv
diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs
index 9542ceac..a3936603 100644
--- a/yesod-core/Yesod/Core/Types.hs
+++ b/yesod-core/Yesod/Core/Types.hs
@@ -203,15 +203,15 @@ data YesodRunnerEnv site = YesodRunnerEnv
     , yreGetMaxExpires  :: IO Text
     }
 
-data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv
-    { ysreParentRunner  :: !(ParentRunner parent parentMonad)
+data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv
+    { ysreParentRunner  :: !(ParentRunner parent)
     , 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
+type ParentRunner parent
+    = HandlerFor parent TypedContent
    -> YesodRunnerEnv parent
    -> Maybe (Route parent)
    -> W.Application
diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs
index 170fd711..c2cdc153 100644
--- a/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs
+++ b/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs
@@ -10,7 +10,7 @@ module YesodCoreTest.NoOverloadedStringsSub where
 import Yesod.Core
 import Yesod.Core.Types
 
-data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerFor master) -> Application)
+data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master -> Application)
 
 mkYesodSubData "Subsite" [parseRoutes|
 /bar BarR GET
@@ -21,7 +21,7 @@ mkYesodSubData "Subsite" [parseRoutes|
 /has-three-pieces/#Int/#Int/#Int ThreePiecesR GET
 |]
 
-instance Yesod master => YesodSubDispatch Subsite (HandlerFor master) where
+instance Yesod master => YesodSubDispatch Subsite master where
     yesodSubDispatch ysre =
         f ysre
       where
diff --git a/yesod-static/Yesod/EmbeddedStatic.hs b/yesod-static/Yesod/EmbeddedStatic.hs
index 7663ad9f..7b005c80 100644
--- a/yesod-static/Yesod/EmbeddedStatic.hs
+++ b/yesod-static/Yesod/EmbeddedStatic.hs
@@ -81,7 +81,7 @@ import Yesod.EmbeddedStatic.Generators
 embeddedResourceR :: [T.Text] -> [(T.Text, T.Text)] -> Route EmbeddedStatic
 embeddedResourceR = EmbeddedResourceR
 
-instance YesodSubDispatch EmbeddedStatic (HandlerT master IO) where
+instance YesodSubDispatch EmbeddedStatic master where
     yesodSubDispatch YesodSubRunnerEnv {..} req = resp
         where
             master = yreSite ysreParentEnv
diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs
index 80d96ba1..7c250b88 100644
--- a/yesod-static/Yesod/Static.hs
+++ b/yesod-static/Yesod/Static.hs
@@ -171,7 +171,7 @@ instance RenderRoute Static where
 instance ParseRoute Static where
     parseRoute (x, y) = Just $ StaticRoute x y
 
-instance MonadHandler m => YesodSubDispatch Static m where
+instance YesodSubDispatch Static master where
     yesodSubDispatch YesodSubRunnerEnv {..} req =
         ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
       where