yesod-core 1.6.24.5 → 1.6.25.0
raw patch · 4 files changed
+191/−22 lines, 4 filesnew-uploaderPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- src/Yesod/Core/Internal/TH.hs +103/−11
- src/Yesod/Routes/TH/RenderRoute.hs +83/−10
- yesod-core.cabal +1/−1
ChangeLog.md view
@@ -1,5 +1,9 @@ # ChangeLog for yesod-core +## 1.6.25.0++* Add an options structure that allows the user to set which instances will be derived for a routes structure. [#1819](https://github.com/yesodweb/yesod/pull/1819)+ ## 1.6.24.5 * Support Aeson 2.2 [#1818](https://github.com/yesodweb/yesod/pull/1818)
src/Yesod/Core/Internal/TH.hs view
@@ -1,12 +1,43 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}-module Yesod.Core.Internal.TH where+module Yesod.Core.Internal.TH+ ( mkYesod+ , mkYesodOpts + , mkYesodWith++ , mkYesodData+ , mkYesodDataOpts++ , mkYesodSubData+ , mkYesodSubDataOpts++ , mkYesodWithParser+ , mkYesodWithParserOpts++ , mkYesodDispatch+ , mkYesodDispatchOpts++ , masterTypeSyns++ , mkYesodGeneral+ , mkYesodGeneralOpts++ , mkMDS+ , mkDispatchInstance++ , mkYesodSubDispatch+ + , subTopDispatch+ , instanceD+ )+ where+ import Prelude hiding (exp) import Yesod.Core.Handler @@ -37,8 +68,18 @@ mkYesod :: String -- ^ name of the argument datatype -> [ResourceTree String] -> Q [Dec]-mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return+mkYesod = mkYesodOpts defaultOpts +-- | `mkYesod` but with custom options.+--+-- @since 1.6.25.0+mkYesodOpts :: RouteOpts+ -> String+ -> [ResourceTree String]+ -> Q [Dec]+mkYesodOpts opts name = fmap (uncurry (++)) . mkYesodWithParserOpts opts name False return++ {-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-} -- | Similar to 'mkYesod', except contexts and type variables are not parsed. -- Instead, they are explicitly provided. @@ -50,27 +91,53 @@ -> Q [Dec] mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return + -- | Sometimes, you will want to declare your routes in one file and define -- your handlers elsewhere. For example, this is the only way to break up a -- monolithic file into smaller parts. Use this function, paired with -- 'mkYesodDispatch', to do just that. mkYesodData :: String -> [ResourceTree String] -> Q [Dec]-mkYesodData name resS = fst <$> mkYesodWithParser name False return resS+mkYesodData = mkYesodDataOpts defaultOpts +-- | `mkYesodData` but with custom options.+--+-- @since 1.6.25.0+mkYesodDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]+mkYesodDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name False return resS++ mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]-mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS+mkYesodSubData = mkYesodSubDataOpts defaultOpts +-- |+--+-- @since 1.6.25.0+mkYesodSubDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]+mkYesodSubDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name True return resS++ -- | Parses contexts and type arguments out of name before generating TH. mkYesodWithParser :: String -- ^ foundation type -> Bool -- ^ is this a subsite -> (Exp -> Q Exp) -- ^ unwrap handler -> [ResourceTree String] -> Q([Dec],[Dec])-mkYesodWithParser name isSub f resS = do+mkYesodWithParser = mkYesodWithParserOpts defaultOpts++-- | Parses contexts and type arguments out of name before generating TH.+--+-- @since 1.6.25.0+mkYesodWithParserOpts :: RouteOpts -- ^ Additional route options+ -> String -- ^ foundation type+ -> Bool -- ^ is this a subsite+ -> (Exp -> Q Exp) -- ^ unwrap handler+ -> [ResourceTree String]+ -> Q([Dec],[Dec])+mkYesodWithParserOpts opts name isSub f resS = do let (name', rest, cxt) = case parse parseName "" name of Left err -> error $ show err Right a -> a- mkYesodGeneral cxt name' rest isSub f resS+ mkYesodGeneralOpts opts cxt name' rest isSub f resS where parseName = do@@ -102,10 +169,18 @@ parseContexts = sepBy1 (many1 parseWord) (spaces >> char ',' >> return ()) + -- | See 'mkYesodData'. mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]-mkYesodDispatch name = fmap snd . mkYesodWithParser name False return+mkYesodDispatch = mkYesodDispatchOpts defaultOpts +-- | See 'mkYesodDataOpts'+--+-- @since 1.6.25.0+mkYesodDispatchOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec]+mkYesodDispatchOpts opts name = fmap snd . mkYesodWithParserOpts opts name False return++ -- | Get the Handler and Widget type synonyms for the given site. masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself? masterTypeSyns vs site =@@ -115,6 +190,7 @@ $ ConT ''WidgetFor `AppT` site `AppT` ConT ''() ] + mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances. -> String -- ^ foundation type -> [String] -- ^ arguments for the type@@ -122,7 +198,20 @@ -> (Exp -> Q Exp) -- ^ unwrap handler -> [ResourceTree String] -> Q([Dec],[Dec])-mkYesodGeneral appCxt' namestr mtys isSub f resS = do+mkYesodGeneral = mkYesodGeneralOpts defaultOpts++-- |+--+-- @since 1.6.25.0+mkYesodGeneralOpts :: RouteOpts -- ^ Options to adjust route creation+ -> [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.+ -> String -- ^ foundation type+ -> [String] -- ^ arguments for the type+ -> Bool -- ^ is this a subsite+ -> (Exp -> Q Exp) -- ^ unwrap handler+ -> [ResourceTree String]+ -> Q([Dec],[Dec])+mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do let appCxt = fmap (\(c:rest) -> foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest ) appCxt'@@ -150,7 +239,7 @@ -- Base type (site type with variables) let site = foldl' AppT (ConT name) argtypes res = map (fmap (parseType . dropBracket)) resS- renderRouteDec <- mkRenderRouteInstance appCxt site res+ renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt site res routeAttrsDec <- mkRouteAttrsInstance appCxt site res dispatchDec <- mkDispatchInstance site appCxt f res parseRoute <- mkParseRouteInstance appCxt site res@@ -169,6 +258,7 @@ ] return (dataDec, dispatchDec) + mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b mkMDS f rh sd = MkDispatchSettings { mdsRunHandler = rh@@ -212,6 +302,7 @@ where yDispatch = ConT ''YesodDispatch `AppT` master + mkYesodSubDispatch :: [ResourceTree a] -> Q Exp mkYesodSubDispatch res = do clause' <- @@ -231,7 +322,8 @@ [innerFun] ] return $ LetE [fun] (VarE helper)- ++ subTopDispatch :: (YesodSubDispatch sub master) => (forall content. ToTypedContent content =>
src/Yesod/Routes/TH/RenderRoute.hs view
@@ -1,9 +1,20 @@-{-# LANGUAGE TemplateHaskell, CPP #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+ module Yesod.Routes.TH.RenderRoute ( -- ** RenderRoute mkRenderRouteInstance+ , mkRenderRouteInstanceOpts , mkRouteCons+ , mkRouteConsOpts , mkRenderRouteClauses++ , RouteOpts+ , defaultOpts+ , setEqDerived+ , setShowDerived+ , setReadDerived ) where import Yesod.Routes.TH.Types@@ -16,16 +27,67 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class +-- | General opts data type for generating yesod.+--+-- Contains options for what instances are derived for the route. Use the setting+-- functions on `defaultOpts` to set specific fields.+--+-- @since 1.6.25.0+data RouteOpts = MkRouteOpts+ { roDerivedEq :: Bool+ , roDerivedShow :: Bool+ , roDerivedRead :: Bool+ }++-- | Default options for generating routes.+--+-- Defaults to all instances derived.+--+-- @since 1.6.25.0+defaultOpts :: RouteOpts+defaultOpts = MkRouteOpts True True True++-- |+--+-- @since 1.6.25.0+setEqDerived :: Bool -> RouteOpts -> RouteOpts+setEqDerived b rdo = rdo { roDerivedEq = b }++-- |+--+-- @since 1.6.25.0+setShowDerived :: Bool -> RouteOpts -> RouteOpts+setShowDerived b rdo = rdo { roDerivedShow = b }++-- |+--+-- @since 1.6.25.0+setReadDerived :: Bool -> RouteOpts -> RouteOpts+setReadDerived b rdo = rdo { roDerivedRead = b }++-- |+--+-- @since 1.6.25.0+instanceNamesFromOpts :: RouteOpts -> [Name]+instanceNamesFromOpts (MkRouteOpts eq shw rd) = prependIf eq ''Eq $ prependIf shw ''Show $ prependIf rd ''Read []+ where prependIf b = if b then (:) else const id+ -- | Generate the constructors of a route data type. mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])-mkRouteCons rttypes =+mkRouteCons = mkRouteConsOpts defaultOpts++-- | Generate the constructors of a route data type, with custom opts.+--+-- @since 1.6.25.0+mkRouteConsOpts :: RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec])+mkRouteConsOpts opts rttypes = mconcat <$> mapM mkRouteCon rttypes where mkRouteCon (ResourceLeaf res) = return ([con], []) where con = NormalC (mkName $ resourceName res)- $ map (\x -> (notStrict, x))+ $ map (notStrict,) $ concat [singles, multi, sub] singles = concatMap toSingle $ resourcePieces res toSingle Static{} = []@@ -39,16 +101,17 @@ _ -> [] mkRouteCon (ResourceParent name _check pieces children) = do- (cons, decs) <- mkRouteCons children+ (cons, decs) <- mkRouteConsOpts opts children+ let conts = mapM conT $ instanceNamesFromOpts opts #if MIN_VERSION_template_haskell(2,12,0)- dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq])+ dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) conts #else- dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]+ dec <- DataD [] (mkName name) [] Nothing cons <$> conts #endif return ([con], dec : decs) where con = NormalC (mkName name)- $ map (\x -> (notStrict, x))+ $ map (notStrict,) $ singles ++ [ConT $ mkName name] singles = concatMap toSingle pieces@@ -152,9 +215,19 @@ -- 'renderRoute' method. This function uses both 'mkRouteCons' and -- 'mkRenderRouteClasses'. mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]-mkRenderRouteInstance cxt typ ress = do+mkRenderRouteInstance = mkRenderRouteInstanceOpts defaultOpts++-- | Generate the 'RenderRoute' instance.+--+-- This includes both the 'Route' associated type and the+-- 'renderRoute' method. This function uses both 'mkRouteCons' and+-- 'mkRenderRouteClasses'.+--+-- @since 1.6.25.0+mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> Type -> [ResourceTree Type] -> Q [Dec]+mkRenderRouteInstanceOpts opts cxt typ ress = do cls <- mkRenderRouteClauses ress- (cons, decs) <- mkRouteCons ress+ (cons, decs) <- mkRouteConsOpts opts ress #if MIN_VERSION_template_haskell(2,15,0) did <- DataInstD [] Nothing (AppT (ConT ''Route) typ) Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False)) let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)@@ -175,7 +248,7 @@ clazzes' else []- clazzes' = [''Show, ''Eq, ''Read]+ clazzes' = instanceNamesFromOpts opts notStrict :: Bang notStrict = Bang NoSourceUnpackedness NoSourceStrictness
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.6.24.5+version: 1.6.25.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>