From adf89bcf8423df59722d6705779577d2b206ad0a Mon Sep 17 00:00:00 2001 From: James Parker Date: Thu, 23 Mar 2017 22:39:41 -0400 Subject: [PATCH 1/3] 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 | 78 +++++++++++++++++++---- yesod-core/Yesod/Routes/Parse.hs | 3 +- yesod-core/Yesod/Routes/TH/ParseRoute.hs | 8 ++- yesod-core/Yesod/Routes/TH/RenderRoute.hs | 17 +++-- yesod-core/Yesod/Routes/TH/RouteAttrs.hs | 8 ++- 5 files changed, 93 insertions(+), 21 deletions(-) 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 ] From 997714f4c2f39964acd636a3479e8fa48118b2b6 Mon Sep 17 00:00:00 2001 From: James Parker Date: Mon, 27 Mar 2017 02:42:47 -0400 Subject: [PATCH 2/3] Accept multiple argument types inside brackets --- yesod-core/Yesod/Core/Internal/TH.hs | 14 +++--------- yesod-core/Yesod/Routes/Parse.hs | 27 ++++++++++++++--------- yesod-core/Yesod/Routes/TH/RenderRoute.hs | 1 - 3 files changed, 19 insertions(+), 23 deletions(-) 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 From 6b000ecfb4ff1106b928f11d441705f65e2f9fe1 Mon Sep 17 00:00:00 2001 From: James Parker Date: Mon, 27 Mar 2017 12:06:44 -0400 Subject: [PATCH 3/3] Version bump and fix for old versions of TH. --- yesod-core/ChangeLog.md | 5 +++++ yesod-core/Yesod/Core/Internal/TH.hs | 18 +++++++++++++++++- yesod-core/Yesod/Routes/TH/RenderRoute.hs | 15 +++++++++++---- yesod-core/yesod-core.cabal | 2 +- 4 files changed, 34 insertions(+), 6 deletions(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 7ee382e4..6ee1fdda 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.4.34 + +* Contexts can be included in generated TH instances. [1365](https://github.com/yesodweb/yesod/issues/1365) +* Type variables can be included in routes. + ## 1.4.32 * Fix warnings diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 565466bb..8ee5b4e0 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -16,7 +16,11 @@ import Language.Haskell.TH.Syntax import qualified Network.Wai as W import Data.ByteString.Lazy.Char8 () +#if MIN_VERSION_base(4,8,0) import Data.List (foldl', uncons) +#else +import Data.List (foldl') +#endif #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif @@ -125,7 +129,13 @@ mkYesodGeneral' :: [[String]] -- ^ Appliction context. Used in Ren -> [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' + let appCxt = fmap (\(c:rest) -> +#if MIN_VERSION_template_haskell(2,10,0) + foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest +#else + ClassP (mkName c) $ fmap nameToType rest +#endif + ) appCxt' mname <- lookupTypeName namestr arity <- case mname of Just name -> do @@ -186,6 +196,12 @@ mkYesodGeneral' appCxt' namestr args isSub f resS = do ] return (dataDec, dispatchDec) +#if !MIN_VERSION_base(4,8,0) + where + uncons (h:t) = Just (h,t) + uncons _ = Nothing +#endif + mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b mkMDS f rh = MkDispatchSettings { mdsRunHandler = rh diff --git a/yesod-core/Yesod/Routes/TH/RenderRoute.hs b/yesod-core/Yesod/Routes/TH/RenderRoute.hs index 3e703757..594c4617 100644 --- a/yesod-core/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-core/Yesod/Routes/TH/RenderRoute.hs @@ -12,7 +12,9 @@ import Yesod.Routes.TH.Types import Language.Haskell.TH (conT) #endif import Language.Haskell.TH.Syntax +#if MIN_VERSION_template_haskell(2,11,0) import Data.Bits (xor) +#endif import Data.Maybe (maybeToList) import Control.Monad (replicateM) import Data.Text (pack) @@ -158,22 +160,27 @@ mkRenderRouteInstance' cxt typ ress = do (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 False)) + let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) #elif MIN_VERSION_template_haskell(2,11,0) did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False) -#else - let did = DataInstD [] ''Route [typ] cons (clazzes False) -#endif let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) +#else + let did = DataInstD [] ''Route [typ] cons clazzes' + let sds = [] +#endif return $ instanceD cxt (ConT ''RenderRoute `AppT` typ) [ did , FunD (mkName "renderRoute") cls ] : sds ++ decs where +#if MIN_VERSION_template_haskell(2,11,0) clazzes standalone = if standalone `xor` null cxt then - [''Show, ''Eq, ''Read] + clazzes' else [] +#endif + clazzes' = [''Show, ''Eq, ''Read] #if MIN_VERSION_template_haskell(2,11,0) notStrict :: Bang diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 8fda2795..ed364acc 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.32 +version: 1.4.34 license: MIT license-file: LICENSE author: Michael Snoyman