Merge pull request #1697 from d86leader/master

Generate appropriate Handler and Widget synonyms for polymorphic sites

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)

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)
 

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 = if isTvar t
-nameToType t = ConT $ mkName 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)

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

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

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|
+        <p>
+            Stub
+    |]
+

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|
+        <p>
+            Stub
+    |]
+

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|
+            <p>
+                Stub #{show x}
+        |]
+

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 <michael@snoyman.com>
@@ -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