yesod-core 1.4.33 → 1.4.35
raw patch · 10 files changed
+158/−35 lines, 10 filesdep ~template-haskell
Dependency ranges changed: template-haskell
Files
- ChangeLog.md +9/−0
- Yesod/Core/Class/Dispatch.hs +10/−1
- Yesod/Core/Dispatch.hs +1/−0
- Yesod/Core/Internal/TH.hs +75/−11
- Yesod/Core/Types.hs +14/−1
- Yesod/Routes/Parse.hs +17/−11
- Yesod/Routes/TH/ParseRoute.hs +6/−2
- Yesod/Routes/TH/RenderRoute.hs +18/−5
- Yesod/Routes/TH/RouteAttrs.hs +6/−2
- yesod-core.cabal +2/−2
ChangeLog.md view
@@ -1,3 +1,12 @@+## 1.4.35++* 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.34++* Add `WaiSubsiteWithAuth`. [#1394](https://github.com/yesodweb/yesod/pull/1394)+ ## 1.4.33 * Adds curly brackets to route parser. [#1363](https://github.com/yesodweb/yesod/pull/1363)
Yesod/Core/Class/Dispatch.hs view
@@ -10,7 +10,7 @@ import qualified Network.Wai as W import Yesod.Core.Types import Yesod.Core.Content-import Yesod.Core.Handler (stripHandlerT)+import Yesod.Core.Handler (sendWaiApplication, stripHandlerT) import Yesod.Core.Class.Yesod import Yesod.Core.Class.Handler @@ -27,6 +27,15 @@ yesodSubDispatch YesodSubRunnerEnv {..} = app where WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv++instance YesodSubDispatch WaiSubsiteWithAuth (HandlerT master IO) where+ yesodSubDispatch YesodSubRunnerEnv {..} req =+ ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req+ where+ base = stripHandlerT handlert ysreGetSub ysreToParentRoute route+ route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []+ WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv+ handlert = sendWaiApplication $ set -- | A helper function for creating YesodSubDispatch instances, used by the -- internal generated code. This function has been exported since 1.4.11.
Yesod/Core/Dispatch.hs view
@@ -34,6 +34,7 @@ , defaultMiddlewaresNoLogging -- * WAI subsites , WaiSubsite (..)+ , WaiSubsiteWithAuth (..) , subHelper ) where
Yesod/Core/Internal/TH.hs view
@@ -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,18 @@ 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 import Control.Monad (replicateM, void) import Data.Either (partitionEithers)+import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)+import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char) import Yesod.Routes.TH import Yesod.Routes.Parse@@ -55,9 +62,41 @@ 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] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return@@ -80,7 +119,23 @@ -> (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) -> +#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@@ -105,10 +160,13 @@ 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 -> + ( nameToType 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)@@ -118,11 +176,11 @@ ) ts ++ cs ) ) ([],vns,[]) args site = foldl' AppT (ConT name) argtypes- res = map (fmap parseType) resS- renderRouteDec <- mkRenderRouteInstance site res- routeAttrsDec <- mkRouteAttrsInstance site res+ res = map (fmap (parseType . dropBracket)) resS+ 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,13 +188,19 @@ , FunD rname [Clause [] (NormalB eres) []] ] let dataDec = concat- [ [parse]+ [ [parseRoute] , renderRouteDec , [routeAttrsDec] , resourcesDec , if isSub then [] else masterTypeSyns vns site ] 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
Yesod/Core/Types.hs view
@@ -175,9 +175,14 @@ type Texts = [Text] --- | Wrap up a normal WAI application as a Yesod subsite.+-- | Wrap up a normal WAI application as a Yesod subsite. Ignore parent site's middleware and isAuthorized. newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } +-- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized.+-- +-- @since 1.4.34+newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }+ data RunHandlerEnv site = RunHandlerEnv { rheRender :: !(Route site -> [(Text, Text)] -> Text) , rheRoute :: !(Maybe (Route site))@@ -559,6 +564,14 @@ renderRoute (WaiSubsiteRoute ps qs) = (ps, qs) instance ParseRoute WaiSubsite where parseRoute (x, y) = Just $ WaiSubsiteRoute x y++instance RenderRoute WaiSubsiteWithAuth where+ data Route WaiSubsiteWithAuth = WaiSubsiteWithAuthRoute [Text] [(Text,Text)]+ deriving (Show, Eq, Read, Ord)+ renderRoute (WaiSubsiteWithAuthRoute ps qs) = (ps,qs)++instance ParseRoute WaiSubsiteWithAuth where+ parseRoute (x, y) = Just $ WaiSubsiteWithAuthRoute x y data Logger = Logger { loggerSet :: !LoggerSet
Yesod/Routes/Parse.hs view
@@ -10,10 +10,12 @@ , parseType , parseTypeTree , TypeTree (..)+ , dropBracket+ , nameToType ) 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,14 +254,18 @@ gos' (front . (t:)) xs' ttToType :: TypeTree -> Type-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)@@ -273,9 +279,9 @@ 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/Routes/TH/ParseRoute.hs view
@@ -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.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 @@ (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/Routes/TH/RenderRoute.hs view
@@ -12,6 +12,9 @@ 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)@@ -156,18 +159,28 @@ 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))+ 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+ did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)+ let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) #else- let did = DataInstD [] ''Route [typ] cons clazzes+ let did = DataInstD [] ''Route [typ] cons clazzes'+ let sds = [] #endif return $ instanceD cxt (ConT ''RenderRoute `AppT` typ) [ did , FunD (mkName "renderRoute") cls- ] : decs+ ]+ : sds ++ decs where- clazzes = [''Show, ''Eq, ''Read]+#if MIN_VERSION_template_haskell(2,11,0)+ clazzes standalone = if standalone `xor` null cxt then+ clazzes'+ else+ []+#endif+ clazzes' = [''Show, ''Eq, ''Read] #if MIN_VERSION_template_haskell(2,11,0) notStrict :: Bang
Yesod/Routes/TH/RouteAttrs.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards #-} module Yesod.Routes.TH.RouteAttrs ( mkRouteAttrsInstance+ , mkRouteAttrsInstance' ) where import Yesod.Routes.TH.Types@@ -15,9 +16,12 @@ #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 ]
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.4.33+version: 1.4.35 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -21,7 +21,7 @@ README.md library- build-depends: base >= 4.6 && < 5+ build-depends: base >= 4.7 && < 5 , time >= 1.1.4 , wai >= 3.0 , wai-extra >= 3.0.7