From 22c5e46d5ccd083f36b3789bd6e5f160d45b8556 Mon Sep 17 00:00:00 2001 From: Benjamin-McRae-Tracsis <144912957+Benjamin-McRae-Tracsis@users.noreply.github.com> Date: Mon, 23 Oct 2023 15:39:21 +0100 Subject: [PATCH] Add an options data structure to allow fine-tuned control of what instances are generated for a route (#1819) * remove read from the list of derived instances, partially closing #1773, #1203 * bump version * adjusting a version bound because the next version breaks compilation * make a RouteOpts type that allows for finer control over what instances are derived for a Route * some lintings * adjust versioning and changelog * actually a more major version bump * verified that export list is complete * add @ since --- yesod-core/ChangeLog.md | 4 + yesod-core/src/Yesod/Core/Internal/TH.hs | 114 ++++++++++++++++-- yesod-core/src/Yesod/Routes/TH/RenderRoute.hs | 93 ++++++++++++-- yesod-core/yesod-core.cabal | 2 +- 4 files changed, 191 insertions(+), 22 deletions(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 554f53980..2357433e9 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/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/yesod-core/src/Yesod/Core/Internal/TH.hs b/yesod-core/src/Yesod/Core/Internal/TH.hs index 277566884..4afd5aac6 100644 --- a/yesod-core/src/Yesod/Core/Internal/TH.hs +++ b/yesod-core/src/Yesod/Core/Internal/TH.hs @@ -1,11 +1,42 @@ -{-# 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,7 +68,17 @@ import Yesod.Core.Internal.Run 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. @@ -50,15 +91,30 @@ mkYesodWith :: [[String]] -- ^ list of contexts -> 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 @@ -66,11 +122,22 @@ mkYesodWithParser :: String -- ^ foundation type -> (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,9 +169,17 @@ mkYesodWithParser name isSub f resS = do 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? @@ -115,6 +190,7 @@ masterTypeSyns vs site = $ 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 @@ mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in Ren -> (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 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do -- 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 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do ] 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 @@ mkDispatchInstance master cxt f res = do where yDispatch = ConT ''YesodDispatch `AppT` master + mkYesodSubDispatch :: [ResourceTree a] -> Q Exp mkYesodSubDispatch res = do clause' <- @@ -231,7 +322,8 @@ mkYesodSubDispatch res = do [innerFun] ] return $ LetE [fun] (VarE helper) - + + subTopDispatch :: (YesodSubDispatch sub master) => (forall content. ToTypedContent content => diff --git a/yesod-core/src/Yesod/Routes/TH/RenderRoute.hs b/yesod-core/src/Yesod/Routes/TH/RenderRoute.hs index 6d9e4de13..9f7fb7de2 100644 --- a/yesod-core/src/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-core/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 Data.Text (pack) 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 @@ mkRouteCons rttypes = _ -> [] 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 @@ mkRenderRouteClauses = -- '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 @@ mkRenderRouteInstance cxt typ ress = do clazzes' else [] - clazzes' = [''Show, ''Eq, ''Read] + clazzes' = instanceNamesFromOpts opts notStrict :: Bang notStrict = Bang NoSourceUnpackedness NoSourceStrictness diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index c4c2fd861..0ff93b461 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/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