From 4c4584fde89585bd229fffec1ab5b355c60558db Mon Sep 17 00:00:00 2001
From: d86leader <d86leader@mail.com>
Date: Tue, 22 Sep 2020 15:33:43 +0700
Subject: [PATCH] Fix incorrect code generation for polymorphic datatypes

---
 yesod-core/src/Yesod/Core/Internal/TH.hs |  9 ++++++---
 yesod-core/src/Yesod/Routes/Parse.hs     | 10 ++++++++--
 2 files changed, 14 insertions(+), 5 deletions(-)

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)