Add tests for mkYesod with polymorphic datatypes

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,35 @@
+{-# 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 (..))
+
+-- 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)
+
+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/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

@@ -156,6 +156,9 @@ test-suite tests
                    YesodCoreTest.MediaData
                    YesodCoreTest.NoOverloadedStrings
                    YesodCoreTest.NoOverloadedStringsSub
+                   YesodCoreTest.ParameterizedSite
+                   YesodCoreTest.ParameterizedSite.PolyAny
+                   YesodCoreTest.ParameterizedSite.PolyShow
                    YesodCoreTest.RawResponse
                    YesodCoreTest.Redirect
                    YesodCoreTest.Reps