Accept multiple argument types inside brackets

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

@@ -16,15 +16,13 @@ import Language.Haskell.TH.Syntax
 import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
-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.Parsec (parse, many1, many, eof, try, option, sepBy1)
 import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
 
 import Yesod.Routes.TH
@@ -154,10 +152,8 @@ mkYesodGeneral' appCxt' namestr args isSub f resS = do
     let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $
           foldr (\arg (xs,vns',cs) ->
                    case arg of
-                     Left  t@(h:_) | isLower h -> 
-                                 ( VarT (mkName t):xs, vns', cs )
                      Left  t  -> 
-                                 ( ConT (mkName t):xs, vns', cs )
+                                 ( nameToType t:xs, vns', cs )
                      Right ts -> 
                                  let (n, ns) = maybe (error "mkYesodGeneral: Should be unreachable.") id $ uncons vns' in
                                  ( VarT n : xs, ns
@@ -170,7 +166,7 @@ mkYesodGeneral' appCxt' namestr args isSub f resS = do
                                           ) ts ++ cs )
                  ) ([],vns,[]) args
         site = foldl' AppT (ConT name) argtypes
-        res = map (fmap parseType) resS
+        res = map (fmap (parseType . dropBracket)) resS
     renderRouteDec <- mkRenderRouteInstance' appCxt site res
     routeAttrsDec  <- mkRouteAttrsInstance' appCxt site res
     dispatchDec    <- mkDispatchInstance site cxt f res
@@ -190,10 +186,6 @@ mkYesodGeneral' appCxt' 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

@@ -10,6 +10,8 @@ module Yesod.Routes.Parse
     , parseType
     , parseTypeTree
     , TypeTree (..)
+    , dropBracket
+    , nameToType
     ) where
 
 import Language.Haskell.TH.Syntax
@@ -252,15 +254,18 @@ 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 (TTTerm s) = nameToType s
 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 = ConT $ mkName t
+
 pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
-pieceFromString ('#':'!':x) = Right $ (False, dynamicPieceFromString x)
-pieceFromString ('!':'#':x) = Right $ (False, dynamicPieceFromString x) -- https://github.com/yesodweb/yesod/issues/652
-pieceFromString ('#':x) = Right $ (True, dynamicPieceFromString x)
+pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)
+pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652
+pieceFromString ('#':x) = Right $ (True, Dynamic $ dropBracket x)
 
 pieceFromString ('*':'!':x) = Left (False, x)
 pieceFromString ('+':'!':x) = Left (False, x)
@@ -274,9 +279,9 @@ pieceFromString ('+':x) = Left (True, x)
 pieceFromString ('!':x) = Right $ (False, Static x)
 pieceFromString x = Right $ (True, Static x)
 
-dynamicPieceFromString :: String -> Piece String
-dynamicPieceFromString str@('{':x) = case break (== '}') x of
-    (s, "}") -> Dynamic s
-    _ -> error $ "Invalid path piece: " ++ str
-dynamicPieceFromString x = Dynamic x
--- JP: Should we check if there are curly brackets or other invalid characters?
+dropBracket :: String -> String
+dropBracket str@('{':x) = case break (== '}') x of
+    (s, "}") -> s
+    _ -> error $ "Unclosed bracket ('{'): " ++ str
+dropBracket x = x
+

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

@@ -3,7 +3,6 @@ module Yesod.Routes.TH.RenderRoute
     ( -- ** RenderRoute
       mkRenderRouteInstance
     , mkRenderRouteInstance'
-    , mkRenderRouteInstance'
     , mkRouteCons
     , mkRenderRouteClauses
     ) where