From 366bfbd319e482f91514db8b63b7ab86c56a3369 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20D=C3=ADaz?= <dhelta.diaz@gmail.com>
Date: Thu, 6 Aug 2015 00:35:48 +0200
Subject: [PATCH] Allow Site types to have type parameters.

---
 yesod-core/Yesod/Core/Internal/TH.hs | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs
index 1a9fcf91..49f143ac 100644
--- a/yesod-core/Yesod/Core/Internal/TH.hs
+++ b/yesod-core/Yesod/Core/Internal/TH.hs
@@ -52,11 +52,11 @@ mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
 mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False
 
 -- | Get the Handler and Widget type synonyms for the given site.
-masterTypeSyns :: Type -> [Dec]
-masterTypeSyns site =
-    [ TySynD (mkName "Handler") []
+masterTypeSyns :: [Name] -> Type -> [Dec]
+masterTypeSyns vs site =
+    [ TySynD (mkName "Handler") (fmap PlainTV vs)
       $ ConT ''HandlerT `AppT` site `AppT` ConT ''IO
-    , TySynD (mkName "Widget")  []
+    , TySynD (mkName "Widget")  (fmap PlainTV vs)
       $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
     ]
 
@@ -75,8 +75,13 @@ mkYesodGeneral name args isSub resS = do
                 NewtypeD _ _ vs _ _ -> length vs
                 _ -> 0
             _ -> 0
-    vs <- fmap (fmap VarT) $ replicateM arity $ newName "t"
-    let site = foldl' AppT (foldl' AppT (ConT $ mkName name) vs) (map (VarT . mkName) args)
+    -- Generate as many variable names as the arity indicates
+    vns <- replicateM arity $ newName "t"
+        -- Variables for type parameters
+    let vs = fmap VarT vns
+        -- Base type (site type with variables)
+        basety = foldl' AppT (ConT $ mkName name) vs
+        site = foldl' AppT basety (map (VarT . mkName) args)
         res = map (fmap parseType) resS
     renderRouteDec <- mkRenderRouteInstance site res
     routeAttrsDec  <- mkRouteAttrsInstance site res
@@ -93,7 +98,7 @@ mkYesodGeneral name args isSub resS = do
             , renderRouteDec
             , [routeAttrsDec]
             , resourcesDec
-            , if isSub then [] else masterTypeSyns site
+            , if isSub then [] else masterTypeSyns vns site
             ]
     return (dataDec, dispatchDec)