diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md
index 14efa3e5..fbb4c521 100644
--- a/yesod-core/ChangeLog.md
+++ b/yesod-core/ChangeLog.md
@@ -1,5 +1,9 @@
# ChangeLog for yesod-core
+## 1.6.18.4
+
+* Fixed a bug where `mkYesod` and other TH functions didn't work for datatypes with explicitly stated type variables, including the case with typeclass constraints. [https://github.com/yesodweb/yesod/pull/1697](#1697)
+
## 1.6.18.3
* Remove mention of an oudated Yesod type (`GHandler`) from the docs for `handlerToIO`. [https://github.com/yesodweb/yesod/pull/1695](#1695)
diff --git a/yesod-core/src/Yesod/Core/Internal/TH.hs b/yesod-core/src/Yesod/Core/Internal/TH.hs
index 5fb6decf..f3505b91 100644
--- a/yesod-core/src/Yesod/Core/Internal/TH.hs
+++ b/yesod-core/src/Yesod/Core/Internal/TH.hs
@@ -141,9 +141,12 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
let name = mkName namestr
-- Generate as many variable names as the arity indicates
vns <- replicateM (arity - length mtys) $ newName "t"
- -- Base type (site type with variables)
+ -- types that you apply to get a concrete site name
let argtypes = fmap nameToType mtys ++ fmap VarT vns
- site = foldl' AppT (ConT name) argtypes
+ -- typevars that should appear in synonym head
+ let argvars = (fmap mkName . filter isTvar) mtys ++ vns
+ -- Base type (site type with variables)
+ let site = foldl' AppT (ConT name) argtypes
res = map (fmap (parseType . dropBracket)) resS
renderRouteDec <- mkRenderRouteInstance appCxt site res
routeAttrsDec <- mkRouteAttrsInstance appCxt site res
@@ -160,7 +163,7 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
, renderRouteDec
, [routeAttrsDec]
, resourcesDec
- , if isSub then [] else masterTypeSyns vns site
+ , if isSub then [] else masterTypeSyns argvars site
]
return (dataDec, dispatchDec)
diff --git a/yesod-core/src/Yesod/Routes/Parse.hs b/yesod-core/src/Yesod/Routes/Parse.hs
index 59d0afb1..15328ffe 100644
--- a/yesod-core/src/Yesod/Routes/Parse.hs
+++ b/yesod-core/src/Yesod/Routes/Parse.hs
@@ -11,6 +11,7 @@ module Yesod.Routes.Parse
, TypeTree (..)
, dropBracket
, nameToType
+ , isTvar
) where
import Language.Haskell.TH.Syntax
@@ -264,8 +265,13 @@ ttToType (TTApp x y) = ttToType x `AppT` ttToType y
ttToType (TTList t) = ListT `AppT` ttToType t
nameToType :: String -> Type
-nameToType t@(h:_) | isLower h = VarT $ mkName t
-nameToType t = ConT $ mkName t
+nameToType t = if isTvar t
+ then VarT $ mkName t
+ else ConT $ mkName t
+
+isTvar :: String -> Bool
+isTvar (h:_) = isLower h
+isTvar _ = False
pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)
diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs
index 80f61c2d..e9f42851 100644
--- a/yesod-core/test/YesodCoreTest.hs
+++ b/yesod-core/test/YesodCoreTest.hs
@@ -11,6 +11,7 @@ import YesodCoreTest.NoOverloadedStrings
import YesodCoreTest.InternalRequest
import YesodCoreTest.ErrorHandling
import YesodCoreTest.Cache
+import YesodCoreTest.ParameterizedSite
import qualified YesodCoreTest.WaiSubsite as WaiSubsite
import qualified YesodCoreTest.Redirect as Redirect
import qualified YesodCoreTest.JsLoader as JsLoader
@@ -43,6 +44,7 @@ specs = do
internalRequestTest
errorHandlingTest
cacheTest
+ parameterizedSiteTest
WaiSubsite.specs
Redirect.specs
JsLoader.specs
diff --git a/yesod-core/test/YesodCoreTest/ParameterizedSite.hs b/yesod-core/test/YesodCoreTest/ParameterizedSite.hs
new file mode 100644
index 00000000..d06c13d3
--- /dev/null
+++ b/yesod-core/test/YesodCoreTest/ParameterizedSite.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+module YesodCoreTest.ParameterizedSite
+ ( parameterizedSiteTest
+ ) where
+
+import Data.ByteString.Lazy (ByteString)
+import Network.Wai.Test (runSession, request, defaultRequest, assertBodyContains)
+import Test.Hspec (Spec, describe, it)
+import Yesod.Core (YesodDispatch)
+import Yesod.Core.Dispatch (toWaiApp)
+
+import YesodCoreTest.ParameterizedSite.PolyAny (PolyAny (..))
+import YesodCoreTest.ParameterizedSite.PolyShow (PolyShow (..))
+import YesodCoreTest.ParameterizedSite.Compat (Compat (..))
+
+-- These are actually tests for template haskell. So if it compiles, it works
+parameterizedSiteTest :: Spec
+parameterizedSiteTest = describe "Polymorphic Yesod sites" $ do
+ it "Polymorphic unconstrained stub" $ runStub (PolyAny ())
+ it "Polymorphic stub with Show" $ runStub' "1337" (PolyShow 1337)
+ it "Polymorphic unconstrained stub, old-style" $ runStub (Compat () ())
+
+runStub :: YesodDispatch a => a -> IO ()
+runStub stub =
+ let actions = do
+ res <- request defaultRequest
+ assertBodyContains "Stub" res
+ in toWaiApp stub >>= runSession actions
+
+
+runStub' :: YesodDispatch a => ByteString -> a -> IO ()
+runStub' body stub =
+ let actions = do
+ res <- request defaultRequest
+ assertBodyContains "Stub" res
+ assertBodyContains body res
+ in toWaiApp stub >>= runSession actions
diff --git a/yesod-core/test/YesodCoreTest/ParameterizedSite/Compat.hs b/yesod-core/test/YesodCoreTest/ParameterizedSite/Compat.hs
new file mode 100644
index 00000000..3a96a324
--- /dev/null
+++ b/yesod-core/test/YesodCoreTest/ParameterizedSite/Compat.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE
+ TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
+ , OverloadedStrings, StandaloneDeriving, FlexibleInstances
+ #-}
+module YesodCoreTest.ParameterizedSite.Compat
+ ( Compat (..)
+ ) where
+
+import Yesod.Core
+
+-- | Parameterized without constraints, and we call mkYesod without type vars,
+-- like people used to do before the last 3 commits
+data Compat a b = Compat a b
+
+mkYesod "Compat" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod (Compat a b)
+
+getHomeR :: Handler a b Html
+getHomeR = defaultLayout
+ [whamlet|
+
+ Stub
+ |]
+
diff --git a/yesod-core/test/YesodCoreTest/ParameterizedSite/PolyAny.hs b/yesod-core/test/YesodCoreTest/ParameterizedSite/PolyAny.hs
new file mode 100644
index 00000000..93f67e1d
--- /dev/null
+++ b/yesod-core/test/YesodCoreTest/ParameterizedSite/PolyAny.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE
+ TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
+ , OverloadedStrings, StandaloneDeriving, FlexibleInstances
+ #-}
+module YesodCoreTest.ParameterizedSite.PolyAny
+ ( PolyAny (..)
+ ) where
+
+import Yesod.Core
+
+-- | Parameterized without constraints
+data PolyAny a = PolyAny a
+
+mkYesod "PolyAny a" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod (PolyAny a)
+
+getHomeR :: Handler a Html
+getHomeR = defaultLayout
+ [whamlet|
+
+ Stub
+ |]
+
diff --git a/yesod-core/test/YesodCoreTest/ParameterizedSite/PolyShow.hs b/yesod-core/test/YesodCoreTest/ParameterizedSite/PolyShow.hs
new file mode 100644
index 00000000..4fa942eb
--- /dev/null
+++ b/yesod-core/test/YesodCoreTest/ParameterizedSite/PolyShow.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE
+ TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
+ , OverloadedStrings, StandaloneDeriving, FlexibleInstances
+ #-}
+module YesodCoreTest.ParameterizedSite.PolyShow
+ ( PolyShow (..)
+ ) where
+
+import Yesod.Core
+
+-- | Parameterized with 'Show' constraint
+data PolyShow a = PolyShow a
+
+mkYesod "(Show a) => PolyShow a" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Show a => Yesod (PolyShow a)
+
+getHomeR :: Show a => Handler a Html
+getHomeR = do
+ PolyShow x <- getYesod
+ defaultLayout
+ [whamlet|
+
+ Stub #{show x}
+ |]
+
diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal
index ce9c902c..dc5cf227 100644
--- a/yesod-core/yesod-core.cabal
+++ b/yesod-core/yesod-core.cabal
@@ -1,5 +1,5 @@
name: yesod-core
-version: 1.6.18.3
+version: 1.6.18.4
license: MIT
license-file: LICENSE
author: Michael Snoyman
@@ -156,6 +156,10 @@ test-suite tests
YesodCoreTest.MediaData
YesodCoreTest.NoOverloadedStrings
YesodCoreTest.NoOverloadedStringsSub
+ YesodCoreTest.ParameterizedSite
+ YesodCoreTest.ParameterizedSite.Compat
+ YesodCoreTest.ParameterizedSite.PolyAny
+ YesodCoreTest.ParameterizedSite.PolyShow
YesodCoreTest.RawResponse
YesodCoreTest.Redirect
YesodCoreTest.Reps