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
This commit is contained in:
Benjamin-McRae-Tracsis
GitHub
parent
2b29a73a50
commit
22c5e46d5c
@ -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)
|
||||
|
||||
@ -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,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 =>
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user