Contexts can be parsed and included in instances. Standalone deriving is used when

a context is provided. Type variables can be included in routes/TH.

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Yesod.Core.Internal.TH where
 
 import Prelude hiding (exp)
@@ -15,12 +16,16 @@ import Language.Haskell.TH.Syntax
 import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
-import Data.List (foldl')
+import Data.Char (isLower)
+import Data.List (foldl', uncons)
 #if __GLASGOW_HASKELL__ < 710
 import Control.Applicative ((<$>))
 #endif
 import Control.Monad (replicateM, void)
 import Data.Either (partitionEithers)
+import Text.Parsec (parse, many1, many, eof, try, (<|>), option, sepBy1)
+import Text.Parsec.Token (symbol)
+import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
 
 import Yesod.Routes.TH
 import Yesod.Routes.Parse
@@ -55,8 +60,40 @@ mkYesodSubData name = mkYesodDataGeneral name True
 
 mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
 mkYesodDataGeneral name isSub res = do
-    let (name':rest) = words name
+    let (name', rest, cxt) = case parse parseName "" name of
-    fst <$> mkYesodGeneral name' (fmap Left rest) isSub return res
+            Left err -> error $ show err
+            Right a -> a
+    fst <$> mkYesodGeneral' cxt name' (fmap Left rest) isSub return res
+
+    where
+        parseName = do
+            cxt <- option [] parseContext
+            name' <- parseWord
+            args <- many parseWord
+            spaces
+            eof
+            return ( name', args, cxt)
+
+        parseWord = do
+            spaces
+            many1 alphaNum
+
+        parseContext = try $ do
+            cxts <- parseParen parseContexts
+            spaces
+            _ <- string "=>"
+            return cxts
+
+        parseParen p = do
+            spaces
+            _ <- char '('
+            r <- p
+            spaces
+            _ <- char ')'
+            return r
+
+        parseContexts = 
+            sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
 
 -- | See 'mkYesodData'.
 mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
@@ -80,7 +117,17 @@ mkYesodGeneral :: String                    -- ^ foundation type
                -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-mkYesodGeneral namestr args isSub f resS = do
+mkYesodGeneral = mkYesodGeneral' []
+
+mkYesodGeneral' :: [[String]]               -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
+               -> String                    -- ^ foundation type
+               -> [Either String [String]]  -- ^ arguments for the type
+               -> Bool                      -- ^ is this a subsite
+               -> (Exp -> Q Exp)            -- ^ unwrap handler
+               -> [ResourceTree String]
+               -> Q([Dec],[Dec])
+mkYesodGeneral' appCxt' namestr args isSub f resS = do
+    let appCxt = fmap (\(c:rest) -> foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest) appCxt'
     mname <- lookupTypeName namestr
     arity <- case mname of
                Just name -> do
@@ -105,10 +152,15 @@ mkYesodGeneral namestr args isSub f resS = do
     vns <- replicateM (arity - length mtys) $ newName "t"
         -- Base type (site type with variables)
     let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $
-          foldr (\arg (xs,n:ns,cs) ->
+          foldr (\arg (xs,vns',cs) ->
                    case arg of
-                     Left  t  -> ( ConT (mkName t):xs, n:ns, cs )
+                     Left  t@(h:_) | isLower h -> 
-                     Right ts -> ( VarT n         :xs,   ns
+                                 ( VarT (mkName t):xs, vns', cs )
+                     Left  t  -> 
+                                 ( ConT (mkName t):xs, vns', cs )
+                     Right ts -> 
+                                 let (n, ns) = maybe (error "mkYesodGeneral: Should be unreachable.") id $ uncons vns' in
+                                 ( VarT n : xs, ns
                                  , fmap (\t ->
 #if MIN_VERSION_template_haskell(2,10,0)
                                                AppT (ConT $ mkName t) (VarT n)
@@ -119,10 +171,10 @@ mkYesodGeneral namestr args isSub f resS = do
                  ) ([],vns,[]) args
         site = foldl' AppT (ConT name) argtypes
         res = map (fmap parseType) resS
-    renderRouteDec <- mkRenderRouteInstance site res
+    renderRouteDec <- mkRenderRouteInstance' appCxt site res
-    routeAttrsDec  <- mkRouteAttrsInstance site res
+    routeAttrsDec  <- mkRouteAttrsInstance' appCxt site res
     dispatchDec    <- mkDispatchInstance site cxt f res
-    parse <- mkParseRouteInstance site res
+    parseRoute <- mkParseRouteInstance' appCxt site res
     let rname = mkName $ "resources" ++ namestr
     eres <- lift resS
     let resourcesDec =
@@ -130,7 +182,7 @@ mkYesodGeneral namestr args isSub f resS = do
             , FunD rname [Clause [] (NormalB eres) []]
             ]
     let dataDec = concat
-            [ [parse]
+            [ [parseRoute]
             , renderRouteDec
             , [routeAttrsDec]
             , resourcesDec
@@ -138,6 +190,10 @@ mkYesodGeneral namestr args isSub f resS = do
             ]
     return (dataDec, dispatchDec)
 
+    where
+        nameToType t@(h:_) | isLower h = VarT $ mkName t
+        nameToType t = ConT $ mkName t
+
 mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
 mkMDS f rh = MkDispatchSettings
     { mdsRunHandler = rh

yesod-core/Yesod/Routes/Parse.hs

@@ -13,7 +13,7 @@ module Yesod.Routes.Parse
     ) where
 
 import Language.Haskell.TH.Syntax
-import Data.Char (isUpper, isSpace)
+import Data.Char (isUpper, isLower, isSpace)
 import Language.Haskell.TH.Quote
 import qualified System.IO as SIO
 import Yesod.Routes.TH
@@ -252,6 +252,7 @@ toTypeTree orig = do
             gos' (front . (t:)) xs'
 
 ttToType :: TypeTree -> Type
+ttToType (TTTerm s@(h:_)) | isLower h = VarT $ mkName s
 ttToType (TTTerm s) = ConT $ mkName s
 ttToType (TTApp x y) = ttToType x `AppT` ttToType y
 ttToType (TTList t) = ListT `AppT` ttToType t

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

@@ -3,6 +3,7 @@
 module Yesod.Routes.TH.ParseRoute
     ( -- ** ParseRoute
       mkParseRouteInstance
+    , mkParseRouteInstance'
     ) where
 
 import Yesod.Routes.TH.Types
@@ -12,7 +13,10 @@ import Yesod.Routes.Class
 import Yesod.Routes.TH.Dispatch
 
 mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec
-mkParseRouteInstance typ ress = do
+mkParseRouteInstance = mkParseRouteInstance' []
+
+mkParseRouteInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
+mkParseRouteInstance' cxt typ ress = do
     cls <- mkDispatchClause
         MkDispatchSettings
             { mdsRunHandler = [|\_ _ x _ -> x|]
@@ -28,7 +32,7 @@ mkParseRouteInstance typ ress = do
         (map removeMethods ress)
     helper <- newName "helper"
     fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]
-    return $ instanceD [] (ConT ''ParseRoute `AppT` typ)
+    return $ instanceD cxt (ConT ''ParseRoute `AppT` typ)
         [ FunD 'parseRoute $ return $ Clause
             []
             (NormalB $ fixer `AppE` VarE helper)

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

@@ -3,6 +3,7 @@ module Yesod.Routes.TH.RenderRoute
     ( -- ** RenderRoute
       mkRenderRouteInstance
     , mkRenderRouteInstance'
+    , mkRenderRouteInstance'
     , mkRouteCons
     , mkRenderRouteClauses
     ) where
@@ -12,6 +13,7 @@ import Yesod.Routes.TH.Types
 import Language.Haskell.TH (conT)
 #endif
 import Language.Haskell.TH.Syntax
+import Data.Bits (xor)
 import Data.Maybe (maybeToList)
 import Control.Monad (replicateM)
 import Data.Text (pack)
@@ -156,18 +158,23 @@ mkRenderRouteInstance' cxt typ ress = do
     cls <- mkRenderRouteClauses ress
     (cons, decs) <- mkRouteCons ress
 #if MIN_VERSION_template_haskell(2,12,0)
-    did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT clazzes)
+    did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
 #elif MIN_VERSION_template_haskell(2,11,0)
-    did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes
+    did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)
 #else
-    let did = DataInstD [] ''Route [typ] cons clazzes
+    let did = DataInstD [] ''Route [typ] cons (clazzes False)
 #endif
+    let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
     return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)
         [ did
         , FunD (mkName "renderRoute") cls
-        ] : decs
+        ]
+        : sds ++ decs
   where
-    clazzes = [''Show, ''Eq, ''Read]
+    clazzes standalone = if standalone `xor` null cxt then
+          [''Show, ''Eq, ''Read]
+        else
+          []
 
 #if MIN_VERSION_template_haskell(2,11,0)
 notStrict :: Bang

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE RecordWildCards #-}
 module Yesod.Routes.TH.RouteAttrs
     ( mkRouteAttrsInstance
+    , mkRouteAttrsInstance'
     ) where
 
 import Yesod.Routes.TH.Types
@@ -15,9 +16,12 @@ import Control.Applicative ((<$>))
 #endif
 
 mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
-mkRouteAttrsInstance typ ress = do
+mkRouteAttrsInstance = mkRouteAttrsInstance' []
+
+mkRouteAttrsInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
+mkRouteAttrsInstance' cxt typ ress = do
     clauses <- mapM (goTree id) ress
-    return $ instanceD [] (ConT ''RouteAttrs `AppT` typ)
+    return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)
         [ FunD 'routeAttrs $ concat clauses
         ]