Beginning of subsite TH overhaul

yesod-core/Yesod/Core/Dispatch.hs

@@ -86,8 +86,8 @@ mkYesodSub name clazzes =
 mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
 mkYesodData name res = mkYesodDataGeneral name [] False res
 
-mkYesodSubData :: String -> Cxt -> [ResourceTree String] -> Q [Dec]
+mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
+mkYesodSubData name res = mkYesodDataGeneral name [] True res
 
 mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> Q [Dec]
 mkYesodDataGeneral name clazzes isSub res = do
@@ -104,10 +104,6 @@ mkYesodDataGeneral name clazzes isSub res = do
 mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
 mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
 
-mkYesodSubDispatch :: String -> Cxt -> [ResourceTree String] -> Q [Dec]
-mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True 
-  where (name':rest) = words name
-
 mkYesodGeneral :: String                   -- ^ foundation type
                -> [String]                 -- ^ arguments for the type
                -> Cxt                      -- ^ the type constraints
@@ -122,7 +118,7 @@ mkYesodGeneral name args clazzes isSub resS = do
      dispatchDec    <- mkDispatchInstance context (if isSub then Just sub else Nothing) master res
      return (renderRouteDec ++ masterTypeSyns, dispatchDec)
   where sub     = foldl appT subCons subArgs
-        master  = if isSub then (varT $ mkName "master") else sub
+        master  = if isSub then (varT $ mkName "m") else sub
         context = if isSub then cxt $ yesod : map return clazzes
                            else return []
         yesod   = classP ''HandlerReader [master]
@@ -142,7 +138,7 @@ mkDispatchInstance :: CxtQ                -- ^ The context
                    -> TypeQ               -- ^ The master site type
                    -> [ResourceTree a]    -- ^ The resource
                    -> DecsQ
-mkDispatchInstance context Nothing master res = do
+mkDispatchInstance context _sub master res = do
   let yDispatch = conT ''YesodDispatch `appT` master `appT` master
       thisDispatch = do
             clause' <- mkDispatchClause MkDispatchSettings
@@ -156,8 +152,10 @@ mkDispatchInstance context Nothing master res = do
                 } res
             return $ FunD 'yesodDispatch [clause']
    in sequence [instanceD context yDispatch [thisDispatch]]
-mkDispatchInstance context (Just sub) master res = do
+
-    yDispatch <- conT ''YesodSubDispatch `appT` sub `appT` master
+
+mkYesodSubDispatch :: [ResourceTree String] -> Q Exp
+mkYesodSubDispatch res = do
     parentRunner <- newName "parentRunner"
     getSub <- newName "getSub"
     toMaster <- newName "toMaster"
@@ -177,7 +175,6 @@ mkDispatchInstance context (Just sub) master res = do
         , mds405 = [|badMethod >> return ()|]
         } res
     inner <- newName "inner"
-    err <- [|error "FIXME"|]
     let innerFun = FunD inner [clause']
         runnerFun = FunD runner
             [ Clause
@@ -189,14 +186,14 @@ mkDispatchInstance context (Just sub) master res = do
                 )
                 []
             ]
-    context' <- context
+    helper <- newName "helper"
-    let fun = FunD 'yesodSubDispatch
+    let fun = FunD helper
                 [ Clause
                     [VarP parentRunner, VarP getSub, VarP toMaster]
                     (NormalB $ VarE inner)
                     [innerFun, runnerFun]
                 ]
-    return [InstanceD context' yDispatch [fun]]
+    return $ LetE [fun] (VarE helper)
 
 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. This is the same as 'toWaiAppPlain', except it includes two

yesod-core/Yesod/Core/Handler.hs

@@ -22,6 +22,7 @@
 module Yesod.Core.Handler
     ( -- * Handler monad
       GHandler
+    , HandlerT
       -- ** Read information from handler
     , getYesod
     , getYesodSub
@@ -169,6 +170,7 @@ import           Data.Maybe                    (listToMaybe)
 import           Data.Typeable                 (Typeable, typeOf)
 import           Yesod.Core.Class.Handler
 import           Yesod.Core.Types
+import           Yesod.Core.Types.Orphan ()
 import           Yesod.Routes.Class            (Route)
 
 get :: HandlerState m => m GHState

yesod-core/Yesod/Core/Types.hs

@@ -14,6 +14,7 @@ import           Control.Exception                  (Exception, throwIO)
 import           Control.Failure                    (Failure (..))
 import           Control.Monad                      (liftM)
 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,
@@ -202,7 +203,6 @@ newtype HandlerT sub m a = HandlerT
     { unHandlerT :: HandlerData sub sub -> m a
     }
 
-instance MonadTrans (HandlerT sub)
 instance Monad m => Monad (HandlerT sub m) where
     return = HandlerT . const . return
     HandlerT f >>= g = HandlerT $ \hd -> f hd >>= \x -> unHandlerT (g x) hd

yesod-core/Yesod/Core/Types/Orphan.hs

@@ -0,0 +1,7 @@
+module Yesod.Core.Types.Orphan where
+
+import Yesod.Core.Types
+import Control.Monad.Trans.Class
+
+instance MonadTrans (HandlerT sub) where
+    lift = HandlerT . const

yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs

@@ -3,6 +3,7 @@
 module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where
 
 import Test.Hspec
+import YesodCoreTest.NoOverloadedStringsSub
 
 import Yesod.Core
 import Network.Wai
@@ -11,18 +12,18 @@ import Data.Monoid (mempty)
 import qualified Data.Text as T
 import qualified Data.ByteString.Lazy.Char8 as L8
 
-data Subsite = Subsite
-
 getSubsite :: a -> Subsite
 getSubsite = const Subsite
 
-mkYesodSub "Subsite" [] [parseRoutes|
+instance YesodSubDispatch Subsite (GHandler master master) where
-/bar BarR GET
+    yesodSubDispatch = $(mkYesodSubDispatch resourcesSubsite)
-|]
 
 getBarR :: Monad m => m T.Text
 getBarR = return $ T.pack "BarR"
 
+getBazR :: Yesod master => HandlerT Subsite (GHandler master master) RepHtml
+getBazR = lift $ defaultLayout [whamlet|Used Default Layout|]
+
 data Y = Y
 mkYesod "Y" [parseRoutes|
 / RootR GET
@@ -54,7 +55,16 @@ case_subsite = runner $ do
     assertBody (L8.pack "BarR") res
     assertStatus 200 res
 
+case_deflayout :: IO ()
+case_deflayout = runner $ do
+    res <- request defaultRequest
+        { pathInfo = map T.pack ["subsite", "baz"]
+        }
+    assertBodyContains (L8.pack "Used Default Layout") res
+    assertStatus 200 res
+
 noOverloadedTest :: Spec
 noOverloadedTest = describe "Test.NoOverloadedStrings" $ do
       it "sanity" case_sanity
       it "subsite" case_subsite
+      it "deflayout" case_deflayout

yesod-core/yesod-core.cabal

@@ -106,6 +106,7 @@ library
                      Yesod.Core.Class.Dispatch
                      Yesod.Core.Class.Breadcrumbs
                      Yesod.Core.Types
+                     Yesod.Core.Types.Orphan
                      Paths_yesod_core
     ghc-options:     -Wall