diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 207137c4..20a1dcfa 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/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 - fst <$> mkYesodGeneral name' (fmap Left rest) isSub return res + let (name', rest, cxt) = case parse parseName "" name of + 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 ) - Right ts -> ( VarT n :xs, ns + Left t@(h:_) | isLower h -> + ( 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 - routeAttrsDec <- mkRouteAttrsInstance site res + renderRouteDec <- mkRenderRouteInstance' appCxt 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 diff --git a/yesod-core/Yesod/Routes/Parse.hs b/yesod-core/Yesod/Routes/Parse.hs index 0a7428f7..2f376023 100644 --- a/yesod-core/Yesod/Routes/Parse.hs +++ b/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 diff --git a/yesod-core/Yesod/Routes/TH/ParseRoute.hs b/yesod-core/Yesod/Routes/TH/ParseRoute.hs index 69318a30..f5ee972a 100644 --- a/yesod-core/Yesod/Routes/TH/ParseRoute.hs +++ b/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) diff --git a/yesod-core/Yesod/Routes/TH/RenderRoute.hs b/yesod-core/Yesod/Routes/TH/RenderRoute.hs index eaa52295..95ad9bbc 100644 --- a/yesod-core/Yesod/Routes/TH/RenderRoute.hs +++ b/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 diff --git a/yesod-core/Yesod/Routes/TH/RouteAttrs.hs b/yesod-core/Yesod/Routes/TH/RouteAttrs.hs index 56e142e9..0348206a 100644 --- a/yesod-core/Yesod/Routes/TH/RouteAttrs.hs +++ b/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 ]