yesod-core: Make it work with ghc-8.0

Use CPP hackery to make it compile with ghc-8.0 and ghc 7.10. If
ghc-7.10 works, I assume earlier supported versions of GHC also
work. All tests pass with both GHC versions.

Unfortunately, the TH changes force changes in the type signature
of Yesod.Routes.TH.RenderRoute.mkRouteCons from:

    mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec])

to

    mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])

and I can't see a way around that.

yesod-core/Yesod/Core/Internal/TH.hs

@@ -86,8 +86,13 @@ mkYesodGeneral namestr args isSub f resS = do
                    case info of
                      TyConI dec ->
                        case dec of
+#if MIN_VERSION_template_haskell(2,11,0)
+                         DataD _ _ vs _ _ _ -> length vs
+                         NewtypeD _ _ vs _ _ _ -> length vs
+#else
                          DataD _ _ vs _ _ -> length vs
                          NewtypeD _ _ vs _ _ -> length vs
+#endif
                          _ -> 0
                      _ -> 0
                _ -> return 0

yesod-core/Yesod/Routes/TH/RenderRoute.hs

@@ -8,6 +8,9 @@ module Yesod.Routes.TH.RenderRoute
     ) where
 
 import Yesod.Routes.TH.Types
+#if MIN_VERSION_template_haskell(2,11,0)
+import Language.Haskell.TH (conT)
+#endif
 import Language.Haskell.TH.Syntax
 import Data.Maybe (maybeToList)
 import Control.Monad (replicateM)
@@ -19,15 +22,15 @@ import Data.Monoid (mconcat)
 #endif
 
 -- | Generate the constructors of a route data type.
-mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec])
+mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])
-mkRouteCons =
+mkRouteCons rttypes =
-    mconcat . map mkRouteCon
+    mconcat <$> mapM mkRouteCon rttypes
   where
     mkRouteCon (ResourceLeaf res) =
-        ([con], [])
+        return ([con], [])
       where
         con = NormalC (mkName $ resourceName res)
-            $ map (\x -> (NotStrict, x))
+            $ map (\x -> (notStrict, x))
             $ concat [singles, multi, sub]
         singles = concatMap toSingle $ resourcePieces res
         toSingle Static{} = []
@@ -39,14 +42,19 @@ mkRouteCons =
             case resourceDispatch res of
                 Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
                 _ -> []
-    mkRouteCon (ResourceParent name _check pieces children) =
+
-        ([con], dec : decs)
+    mkRouteCon (ResourceParent name _check pieces children) = do
+        (cons, decs) <- mkRouteCons children
+#if MIN_VERSION_template_haskell(2,11,0)
+        dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]
+#else
+        let dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]
+#endif
+        return ([con], dec : decs)
       where
-        (cons, decs) = mkRouteCons children
         con = NormalC (mkName name)
-            $ map (\x -> (NotStrict, x))
+            $ map (\x -> (notStrict, x))
             $ concat [singles, [ConT $ mkName name]]
-        dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]
 
         singles = concatMap toSingle pieces
         toSingle Static{} = []
@@ -143,10 +151,23 @@ mkRenderRouteInstance = mkRenderRouteInstance' []
 mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
 mkRenderRouteInstance' cxt typ ress = do
     cls <- mkRenderRouteClauses ress
-    let (cons, decs) = mkRouteCons ress
+    (cons, decs) <- mkRouteCons ress
+#if MIN_VERSION_template_haskell(2,11,0)
+    did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes
+#else
+    let did = DataInstD [] ''Route [typ] cons clazzes
+#endif
     return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ)
-        [ DataInstD [] ''Route [typ] cons clazzes
+        [ did
         , FunD (mkName "renderRoute") cls
         ] : decs
   where
     clazzes = [''Show, ''Eq, ''Read]
+
+#if MIN_VERSION_template_haskell(2,11,0)
+notStrict :: Bang
+notStrict = Bang NoSourceUnpackedness NoSourceStrictness
+#else
+notStrict :: Strict
+notStrict = NotStrict
+#endif

yesod-core/test/YesodCoreTest/Exceptions.hs

@@ -41,7 +41,7 @@ case500 :: IO ()
 case500 = runner $ do
     res <- request defaultRequest
     assertStatus 500 res
-    assertBody "FOOBAR" res
+    assertBodyContains "FOOBAR" res
 
 caseRedirect :: IO ()
 caseRedirect = runner $ do