diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 20a1dcfa..565466bb 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/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 diff --git a/yesod-core/Yesod/Routes/Parse.hs b/yesod-core/Yesod/Routes/Parse.hs index 2f376023..e372fc0f 100644 --- a/yesod-core/Yesod/Routes/Parse.hs +++ b/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 + diff --git a/yesod-core/Yesod/Routes/TH/RenderRoute.hs b/yesod-core/Yesod/Routes/TH/RenderRoute.hs index 95ad9bbc..3e703757 100644 --- a/yesod-core/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-core/Yesod/Routes/TH/RenderRoute.hs @@ -3,7 +3,6 @@ module Yesod.Routes.TH.RenderRoute ( -- ** RenderRoute mkRenderRouteInstance , mkRenderRouteInstance' - , mkRenderRouteInstance' , mkRouteCons , mkRenderRouteClauses ) where