Normal and subsite dispatch code completely unified

Yesod/Core.hs

@@ -10,7 +10,6 @@ module Yesod.Core
     ( -- * Type classes
       Yesod (..)
     , YesodDispatch (..)
-    , YesodSubSite (..)
     , RenderRoute (..)
       -- ** Breadcrumbs
     , YesodBreadcrumbs (..)
@@ -92,25 +91,11 @@ class Yesod master => YesodDispatch a master where
         -> (Route a -> Route master)
         -> Maybe W.Application
 
--- | Same as 'YesodSite', but for subsites. Once again, users should not need
+    yesodRunner :: a
--- to deal with it directly, as mkYesodSub creates instances appropriately.
+                -> master
-class (RenderRoute (Route s)) => YesodSubSite s y where
+                -> (Route a -> Route master)
-    dispatchSubsite :: (Yesod y)
+                -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application
-                    => y
+    yesodRunner = defaultYesodRunner
-                    -> Maybe CS.Key
-                    -> [String]
-                    -> (Route s -> Route y)
-                    -> s
-                    -> W.Application
-    dispatchToSubSubsite
-        :: (Yesod y)
-        => y
-        -> Maybe CS.Key
-        -> [String]
-        -> (Route s -> Route y)
-        -> s
-        -> Maybe W.Application
-    dispatchSubLocal :: y -> Maybe CS.Key -> [String] -> (Route s -> Route y) -> s -> Maybe W.Application
 
 -- | Define settings for a Yesod applications. The only required setting is
 -- 'approot'; other than that, there are intelligent defaults.
@@ -252,14 +237,6 @@ class RenderRoute (Route a) => Yesod a where
     sessionIpAddress :: a -> Bool
     sessionIpAddress _ = True
 
-    -- FIXME this probably needs to be a part of YesodDispatch
-    yesodRunner :: Yesod master
-                => a
-                -> master
-                -> (Route a -> Route master)
-                -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application
-    yesodRunner = defaultYesodRunner
-
 defaultYesodRunner :: Yesod master
                    => a
                    -> master

Yesod/Dispatch.hs

@@ -173,12 +173,11 @@ mkYesodGeneral name args clazzes isSub res = do
     -}
     let sortedRes = filter (not . isSubSite) th' ++ filter isSubSite th'
     yd <- mkYesodDispatch' sortedRes
-    localClauses <- catMaybes <$> mapM mkDispatchLocal th'
-    subsiteClauses <- catMaybes <$> mapM mkDispatchToSubsite th'
-    let subSubsiteClauses = [] -- FIXME subSubsiteClauses
     nothing <- [|Nothing|]
-    let mkYSS = InstanceD clazzes (ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"))
+    let master = mkName "master"
-                [
+    let ctx = ClassP (mkName "Yesod") [VarT master] : clazzes
+    let mkYSS = InstanceD ctx (ConT ''YesodDispatch `AppT` arg `AppT` VarT master)
+                [ FunD (mkName "yesodDispatch") [yd]
                 ]
         mkYS = InstanceD [] (ConT ''YesodDispatch `AppT` arg `AppT` arg) [FunD (mkName "yesodDispatch") [yd]]
     let y = if isSub then mkYSS else mkYS {-InstanceD ctx ytyp
@@ -198,7 +197,7 @@ mkYesodDispatch' sortedRes = do
     nothing <- [|Nothing|]
     body <- foldM (go master sub toMasterRoute mkey segments) nothing sortedRes
     return $ Clause
-        [VarP master, VarP mkey, VarP segments, VarP sub, VarP toMasterRoute]
+        [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute]
         (NormalB body)
         []
   where
@@ -208,7 +207,7 @@ mkYesodDispatch' sortedRes = do
         app <- newName "app"
         return $ CaseE test
             [ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
-            , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []
+            , Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) []
             ]
     go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do
         test <- mkSimpleExp segments pieces id (master, sub, toMasterRoute, mkey, constr, methods)
@@ -294,11 +293,15 @@ mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do
     return exp
 
 mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do
-    ds <- [|dispatchSubsite|]
+    yd <- [|yesodDispatch|]
     let con = foldl' AppE (ConE $ mkName constr) $ frontVars []
     let s' = VarE (mkName toSub) `AppE` VarE master
     let s = foldl' AppE s' $ frontVars []
-    let app = ds `AppE` VarE master `AppE` VarE mkey `AppE` VarE segments `AppE` con `AppE` s
+    let app = yd `AppE` s
+                 `AppE` VarE mkey
+                 `AppE` VarE segments
+                 `AppE` VarE master
+                 `AppE` con
     just <- [|Just|]
     return $ just `AppE` app
 mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do
@@ -400,7 +403,7 @@ mkDispatchToSubsite ((constr, SubSite { ssPieces = pieces }), Just toSub) = do
         <- mkPat' pieces
            (ConE $ mkName constr)
          $ just `AppE` (VarE (mkName toSub) `AppE` VarE master)
-    ds <- [|dispatchSubsite|]
+    ds <- error "FIXME" -- [|dispatchSubsite|]
     goodParse <- (`AppE` tma') <$> [|isJust|]
     tma'' <- (`AppE` tma') <$> [|fromJust|]
     let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest `AppE` toMaster