mkYesodGeneral arguments can now be monomorphic or polymorphic types. It is possible to impose class instances to polymorphic type arguments.

yesod-core/Yesod/Core/Dispatch.hs

@@ -11,6 +11,7 @@ module Yesod.Core.Dispatch
     , parseRoutesFile
     , parseRoutesFileNoCheck
     , mkYesod
+    , mkYesodWith
       -- ** More fine-grained
     , mkYesodData
     , mkYesodSubData

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

@@ -16,6 +16,7 @@ import qualified Network.Wai as W
 import Data.ByteString.Lazy.Char8 ()
 import Data.List (foldl')
 import Control.Monad (replicateM)
+import Data.Either (partitionEithers)
 
 import Yesod.Routes.TH
 import Yesod.Routes.Parse
@@ -32,6 +33,12 @@ mkYesod :: String -- ^ name of the argument datatype
         -> Q [Dec]
 mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False
 
+mkYesodWith :: String
+            -> [Either String [String]]
+            -> [ResourceTree String]
+            -> Q [Dec]
+mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral name args False
+
 -- | Sometimes, you will want to declare your routes in one file and define
 -- your handlers elsewhere. For example, this is the only way to break up a
 -- monolithic file into smaller parts. Use this function, paired with
@@ -45,7 +52,7 @@ mkYesodSubData name res = mkYesodDataGeneral name True res
 mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
 mkYesodDataGeneral name isSub res = do
     let (name':rest) = words name
-    fmap fst $ mkYesodGeneral name' rest isSub res
+    fmap fst $ mkYesodGeneral name' (fmap Left rest) isSub res
 
 -- | See 'mkYesodData'.
 mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
@@ -60,9 +67,12 @@ masterTypeSyns vs site =
       $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
     ]
 
+-- | 'Left' arguments indicate a monomorphic type, a 'Right' argument
+--   indicates a polymorphic type, and provides the list of classes
+--   the type must be instance of.
 mkYesodGeneral :: String                   -- ^ foundation type
-               -> [String]                 -- ^ arguments for the type
-               -> Bool                     -- ^ it this a subsite
+               -> [Either String [String]] -- ^ arguments for the type
+               -> Bool                     -- ^ is this a subsite
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
 mkYesodGeneral name args isSub resS = do
@@ -75,17 +85,22 @@ mkYesodGeneral name args isSub resS = do
                 NewtypeD _ _ vs _ _ -> length vs
                 _ -> 0
             _ -> 0
+        (mtys,ptys) = partitionEithers args
     -- Generate as many variable names as the arity indicates
-    vns <- replicateM arity $ newName "t"
-        -- Variables for type parameters
-    let vs = fmap VarT vns
+    vns <- replicateM (arity - length mtys) $ newName "t"
         -- Base type (site type with variables)
-        basety = foldl' AppT (ConT $ mkName name) vs
-        site = foldl' AppT basety (map (VarT . mkName) args)
+    let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $
+          foldr (\arg (xs,n:ns,cs) ->
+                   case arg of
+                     Left  t  -> ( ConT (mkName t):xs, n:ns, cs )
+                     Right ts -> ( VarT n         :xs,   ns
+                                 , fmap (\t -> AppT (ConT $ mkName t) (VarT n)) ts ++ cs )
+                 ) ([],vns,[]) args
+        site = foldl' AppT (ConT $ mkName name) argtypes
         res = map (fmap parseType) resS
     renderRouteDec <- mkRenderRouteInstance site res
     routeAttrsDec  <- mkRouteAttrsInstance site res
-    dispatchDec    <- mkDispatchInstance site res
+    dispatchDec    <- mkDispatchInstance site cxt res
     parse <- mkParseRouteInstance site res
     let rname = mkName $ "resources" ++ name
     eres <- lift resS
@@ -128,12 +143,13 @@ mkMDS rh = MkDispatchSettings
 -- when writing library/plugin for yesod, this combinator becomes
 -- handy.
 mkDispatchInstance :: Type                -- ^ The master site type
+                   -> Cxt                 -- ^ Context of the instance
                    -> [ResourceTree a]    -- ^ The resource
                    -> DecsQ
-mkDispatchInstance master res = do
+mkDispatchInstance master cxt res = do
     clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res
     let thisDispatch = FunD 'yesodDispatch [clause']
-    return [InstanceD [] yDispatch [thisDispatch]]
+    return [InstanceD cxt yDispatch [thisDispatch]]
   where
     yDispatch = ConT ''YesodDispatch `AppT` master