refactored mkYesodGeneral to use mkDispatchInstance

yesod-core/Yesod/Dispatch.hs

@@ -110,50 +110,29 @@ 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
+mkYesodGeneral :: String                   -- ^ foundation type
-               -> [String]
+               -> [String]                 -- ^ arguments for the type
-               -> Cxt -- ^ classes
+               -> Cxt                      -- ^ the type constraints
-               -> Bool -- ^ is subsite?
+               -> Bool                     -- ^ it this a subsite
                -> [ResourceTree String]
-               -> Q ([Dec], [Dec])
+               -> Q([Dec],[Dec])
 mkYesodGeneral name args clazzes isSub resS = do
-    let args' = map mkName args
+     subsite        <- sub
-        arg = foldl AppT (ConT name') $ map VarT args'
+     masterTypeSyns <- if isSub then return   [] 
-    let res = map (fmap parseType) resS
+                                else sequence [handler, widget]
-    renderRouteDec <- mkRenderRouteInstance arg res
+     renderRouteDec <- mkRenderRouteInstance subsite res
-
+     dispatchDec    <- mkDispatchInstance context sub master res
-    let logger = mkName "logger"
+     return (renderRouteDec ++ masterTypeSyns, dispatchDec)
-    Clause pat body decs <- mkDispatchClause
+  where sub     = foldl appT subCons subArgs
-        [|yesodRunner $(return $ VarE logger)|]
+        master  = if isSub then (varT $ mkName "master") else sub
-        [|yesodDispatch $(return $ VarE logger)|]
+        context = if isSub then cxt $ yesod : map return clazzes
-        [|fmap chooseRep|]
+                           else return []
-        res
+        yesod   = classP ''Yesod [master]
-    let disp = Clause (VarP logger : pat) body decs
+        handler = tySynD (mkName "Handler") [] [t| GHandler $master $master    |]
-    let master = mkName "master"
+        widget  = tySynD (mkName "Widget")  [] [t| GWidget  $master $master () |]
-    let ctx = if isSub
+        res     = map (fmap parseType) resS
-                then ClassP (mkName "Yesod") [VarT master] : clazzes
+        subCons = conT $ mkName name
-                else []
+        subArgs = map (varT. mkName) args
-    let ytyp = if isSub
-                then ConT ''YesodDispatch `AppT` arg `AppT` VarT master
-                else ConT ''YesodDispatch `AppT` arg `AppT` arg
-    let yesodDispatch' =
-            InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]]
-
-    return (renderRouteDec ++ masterTypSyns, [yesodDispatch'])
-  where
-    name' = mkName name
-    masterTypSyns
-        | isSub = []
-        | otherwise =
-            [ TySynD
-                (mkName "Handler")
-                []
-                (ConT ''GHandler `AppT` ConT name' `AppT` ConT name')
-            , TySynD
-                (mkName "Widget")
-                []
-                (ConT ''GWidget `AppT` ConT name' `AppT` ConT name' `AppT` TupleT 0)
-            ]
         
 -- | If the generation of @'YesodDispatch'@ instance require finer
 -- control of the types, contexts etc. using this combinator. You will