diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/src/Yesod/Core/Internal/TH.hs b/src/Yesod/Core/Internal/TH.hs --- a/src/Yesod/Core/Internal/TH.hs +++ b/src/Yesod/Core/Internal/TH.hs @@ -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`. " #-} -- | 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 => diff --git a/src/Yesod/Routes/TH/RenderRoute.hs b/src/Yesod/Routes/TH/RenderRoute.hs --- a/src/Yesod/Routes/TH/RenderRoute.hs +++ b/src/Yesod/Routes/TH/RenderRoute.hs @@ -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 diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -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