Add an options data structure to allow fine-tuned control of what ins…

…tances 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
yesodweb · Oct 23, 2023 · 22c5e46 · 22c5e46
1 parent 2b29a73
commit 22c5e46
Show file tree

Hide file tree

Showing 4 changed files with 191 additions and 22 deletions.
diff --git 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
@@ -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`. <https://github.com/yesodweb/yesod/pull/1366>" #-}
 -- | Similar to 'mkYesod', except contexts and type variables are not parsed. 
@@ -50,27 +91,53 @@ 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
                   -> 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,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,14 +190,28 @@ 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
                -> Bool                      -- ^ is this a subsite
                -> (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
@@ -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
@@ -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 <[email protected]>