yesod-core 1.6.28.0 → 1.6.28.1
raw patch · 11 files changed
+188/−79 lines, 11 filesdep +th-abstractiondep ~template-haskell
Dependencies added: th-abstraction
Dependency ranges changed: template-haskell
Files
- ChangeLog.md +5/−1
- bench/widget.hs +2/−2
- src/Yesod/Core/Dispatch.hs +1/−0
- src/Yesod/Core/Internal/TH.hs +5/−3
- src/Yesod/Routes/Parse.hs +7/−5
- src/Yesod/Routes/TH/RenderRoute.hs +75/−58
- test/Hierarchy.hs +1/−3
- test/RouteSpec.hs +1/−3
- test/YesodCoreTest/ParameterizedSite.hs +19/−2
- test/YesodCoreTest/ParameterizedSite/SubRoute.hs +68/−0
- yesod-core.cabal +4/−2
ChangeLog.md view
@@ -1,6 +1,10 @@ # ChangeLog for yesod-core -## 1.6.28.0 (unreleased)+## 1.6.28.1++* Add type arguments to the sub routes [#1866](https://github.com/yesodweb/yesod/pull/1866)++## 1.6.28.0 * Allow users to control generation of the `resourcesSite :: [ResourceTree String]` value. [#1881](https://github.com/yesodweb/yesod/pull/1881)
bench/widget.hs view
@@ -63,6 +63,6 @@ -} bigTableBlaze :: Show a => [[a]] -> Int64-bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ concatMap row t+bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ foldMap row t where- row r = tr $ concatMap (td . toHtml . show) r+ row r = tr $ foldMap (td . toHtml . show) r
src/Yesod/Core/Dispatch.hs view
@@ -29,6 +29,7 @@ , setShowDerived , setReadDerived , setCreateResources+ , setParameterizedSubroute -- *** Helpers , defaultGen , getGetMaxExpires
src/Yesod/Core/Internal/TH.hs view
@@ -43,6 +43,7 @@ , setShowDerived , setReadDerived , setCreateResources+ , setParameterizedSubroute ) where @@ -223,7 +224,7 @@ let appCxt = fmap (\ctxs -> case ctxs of c:rest ->- foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest+ foldl' (\acc v -> acc `AppT` fst (nameToType v)) (ConT $ mkName c) rest [] -> error $ "Bad context: " ++ show ctxs ) appCxt' mname <- lookupTypeName namestr@@ -244,13 +245,14 @@ -- Generate as many variable names as the arity indicates vns <- replicateM (arity - length mtys) $ newName "t" -- types that you apply to get a concrete site name- let argtypes = fmap nameToType mtys ++ fmap VarT vns+ let boundNames = fmap nameToType mtys+ argtypes = fmap fst boundNames ++ fmap VarT vns -- typevars that should appear in synonym head let argvars = (fmap mkName . filter isTvar) mtys ++ vns -- Base type (site type with variables) let site = foldl' AppT (ConT name) argtypes res = map (fmap (parseType . dropBracket)) resS- renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt site res+ renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt boundNames site res routeAttrsDec <- mkRouteAttrsInstance appCxt site res dispatchDec <- mkDispatchInstance site appCxt f res parseRoute <- mkParseRouteInstance appCxt site res
src/Yesod/Routes/Parse.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter module Yesod.Routes.Parse@@ -265,14 +266,15 @@ gos' (front . (t:)) xs' ttToType :: TypeTree -> Type-ttToType (TTTerm s) = nameToType s+ttToType (TTTerm s) = fst $ nameToType s ttToType (TTApp x y) = ttToType x `AppT` ttToType y ttToType (TTList t) = ListT `AppT` ttToType t -nameToType :: String -> Type-nameToType t = if isTvar t- then VarT $ mkName t- else ConT $ mkName t+nameToType :: String -> (Type, Name)+nameToType t = (, nm) $ if isTvar t+ then VarT nm+ else ConT nm+ where nm = mkName t isTvar :: String -> Bool isTvar (h:_) = isLower h
src/Yesod/Routes/TH/RenderRoute.hs view
@@ -2,12 +2,11 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-} module Yesod.Routes.TH.RenderRoute ( -- ** RenderRoute- mkRenderRouteInstance- , mkRenderRouteInstanceOpts- , mkRouteCons+ mkRenderRouteInstanceOpts , mkRouteConsOpts , mkRenderRouteClauses , shouldCreateResources@@ -18,25 +17,25 @@ , setShowDerived , setReadDerived , setCreateResources+ , setParameterizedSubroute ) where import Yesod.Routes.TH.Types-import Language.Haskell.TH (conT) import Language.Haskell.TH.Syntax-import Data.Bits (xor) import Data.Maybe (maybeToList) import Control.Monad (replicateM) import Data.Text (pack) import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class+import Data.Foldable -- | General opts data type for generating yesod. -- -- Contains options for customizing code generation for the router in -- 'mkYesodData', including what type class instances will be derived for--- the route datatype and whether or not to create the @resources ::--- [ResourceTree String]@ value. Use the setting functions on `defaultOpts`--- to set specific fields.+-- the route datatype, whether to parameterize subroutes,+-- and whether or not to create the @resources :: [ResourceTree String]@ value.+-- Use the setting functions on `defaultOpts` to set specific fields. -- -- @since 1.6.25.0 data RouteOpts = MkRouteOpts@@ -44,12 +43,13 @@ , roDerivedShow :: Bool , roDerivedRead :: Bool , roCreateResources :: Bool+ , roParameterizedSubroute :: Bool } -- | Default options for generating routes. ----- Defaults to all instances derived and to create the @resourcesSite ::--- [ResourceTree String]@ term.+-- Defaults to all instances derived, subroutes being unparameterized, and to+-- create the @resourcesSite :: [ResourceTree String]@ term. -- -- @since 1.6.25.0 defaultOpts :: RouteOpts@@ -58,6 +58,7 @@ , roDerivedShow = True , roDerivedRead = True , roCreateResources = True+ , roParameterizedSubroute = False } -- |@@ -96,6 +97,12 @@ shouldCreateResources :: RouteOpts -> Bool shouldCreateResources = roCreateResources +-- | If True, we will correctly pass parameters for subroutes around.+--+-- @since 1.6.28.0+setParameterizedSubroute :: Bool -> RouteOpts -> RouteOpts+setParameterizedSubroute b rdo = rdo { roParameterizedSubroute = b }+ -- | -- -- @since 1.6.25.0@@ -103,23 +110,37 @@ instanceNamesFromOpts MkRouteOpts {..} = prependIf roDerivedEq ''Eq $ prependIf roDerivedShow ''Show $ prependIf roDerivedRead ''Read [] where prependIf b = if b then (:) else const id --- |------ @since 1.6.28.0---- | Generate the constructors of a route data type.-mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])-mkRouteCons = mkRouteConsOpts defaultOpts+-- | Nullify the list unless we are using parameterised subroutes.+nullifyWhenNoParam :: RouteOpts -> [a] -> [a]+nullifyWhenNoParam opts = if roParameterizedSubroute opts then id else const [] -- | 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+mkRouteConsOpts :: RouteOpts -> Cxt -> [(Type, Name)] -> [ResourceTree Type] -> ([Con], [Dec])+mkRouteConsOpts opts cxt (nullifyWhenNoParam opts -> tyargs) =+ mkRouteConsOpts' where+ -- th-abstraction does cover this but the version it was introduced in+ -- isn't always available+ tyvarbndr =+#if MIN_VERSION_template_haskell(2,21,0)+ (`PlainTV` BndrReq) :: Name -> TyVarBndr BndrVis+#elif MIN_VERSION_template_haskell(2,17,0)+ (`PlainTV` ()) :: Name -> TyVarBndr ()+#else+ PlainTV :: Name -> TyVarBndr+#endif++ subrouteDecTypeArgs = fmap (tyvarbndr . snd) tyargs++ (inlineDerives, mkSds) = getDerivesFor opts (nullifyWhenNoParam opts cxt)++ mkRouteConsOpts' :: [ResourceTree Type] -> ([Con], [Dec])+ mkRouteConsOpts' = foldMap mkRouteCon+ mkRouteCon (ResourceLeaf res) =- return ([con], [])+ ([con], []) where con = NormalC (mkName $ resourceName res) $ map (notStrict,)@@ -135,24 +156,22 @@ Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] _ -> [] - mkRouteCon (ResourceParent name _check pieces children) = do- (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) conts-#else- dec <- DataD [] (mkName name) [] Nothing cons <$> conts-#endif- return ([con], dec : decs)+ mkRouteCon (ResourceParent name _check pieces children) =+ let (cons, decs) = mkRouteConsOpts' children+ dec = DataD [] dataName subrouteDecTypeArgs Nothing cons inlineDerives+ in ([con], dec : decs ++ mkSds consDataType) where- con = NormalC (mkName name)+ con = NormalC dataName $ map (notStrict,)- $ singles ++ [ConT $ mkName name]+ $ singles ++ [consDataType] singles = concatMap toSingle pieces toSingle Static{} = [] toSingle (Dynamic typ) = [typ] + dataName = mkName name+ consDataType = foldl' (\b a -> b `AppT` fst a) (ConT dataName) tyargs+ -- | Clauses for the 'renderRoute' method. mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause] mkRenderRouteClauses =@@ -247,43 +266,41 @@ -- | Generate the 'RenderRoute' instance. -- -- This includes both the 'Route' associated type and the--- 'renderRoute' method. This function uses both 'mkRouteCons' and--- 'mkRenderRouteClasses'.-mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]-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'.+-- 'renderRoute' method. This function uses both 'mkRouteConsOpts' and+-- 'mkRenderRouteClauses'. -- -- @since 1.6.25.0-mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> Type -> [ResourceTree Type] -> Q [Dec]-mkRenderRouteInstanceOpts opts cxt typ ress = do+mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> [(Type, Name)] -> Type -> [ResourceTree Type] -> Q [Dec]+mkRenderRouteInstanceOpts opts cxt tyargs typ ress = do cls <- mkRenderRouteClauses ress- (cons, decs) <- mkRouteConsOpts opts ress+ let (cons, decs) = mkRouteConsOpts opts cxt tyargs ress+ let did = DataInstD [] #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)-#elif MIN_VERSION_template_haskell(2,12,0)- did <- DataInstD [] ''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)+ Nothing routeDataName #else- did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)- let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)+ ''Route [typ] #endif+ Nothing cons inlineDerives return $ instanceD cxt (ConT ''RenderRoute `AppT` typ) [ did , FunD (mkName "renderRoute") cls ]- : sds ++ decs+ : mkSds routeDataName ++ decs where- clazzes standalone = if standalone `xor` null cxt then- clazzes'- else- []- clazzes' = instanceNamesFromOpts opts+ routeDataName = ConT ''Route `AppT` typ+ (inlineDerives, mkSds) = getDerivesFor opts cxt++-- | Get the simple derivation clauses and the standalone derivation clauses+-- for a given type and context.+--+-- If there are any additional classes needed for context, we just produce standalone+-- clauses. Else, we produce basic deriving clauses for a declaration.+getDerivesFor :: RouteOpts -> Cxt -> ([DerivClause], Type -> [Dec])+getDerivesFor opts cxt+ | null cxt = ([DerivClause Nothing clazzes'], const [])+ | otherwise = ([], \typ -> fmap (StandaloneDerivD Nothing cxt . (`AppT` typ)) clazzes')+ where+ clazzes' = ConT <$> instanceNamesFromOpts opts notStrict :: Bang notStrict = Bang NoSourceUnpackedness NoSourceStrictness
test/Hierarchy.hs view
@@ -114,7 +114,7 @@ -- /#Int TrailingIntR GET |] - rrinst <- mkRenderRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources+ rrinst <- mkRenderRouteInstanceOpts defaultOpts [] [] (ConT ''Hierarchy) $ map (fmap parseType) resources rainst <- mkRouteAttrsInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources prinst <- mkParseRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources dispatch <- mkDispatchClause MkDispatchSettings@@ -130,9 +130,7 @@ } resources return $ InstanceD-#if MIN_VERSION_template_haskell(2,11,0) Nothing-#endif [] (ConT ''Dispatcher `AppT` ConT ''Hierarchy
test/RouteSpec.hs view
@@ -73,7 +73,7 @@ [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True ] ress = resParent : resLeaves- rrinst <- mkRenderRouteInstance [] (ConT ''MyApp) ress+ rrinst <- mkRenderRouteInstanceOpts defaultOpts [] [] (ConT ''MyApp) ress rainst <- mkRouteAttrsInstance [] (ConT ''MyApp) ress prinst <- mkParseRouteInstance [] (ConT ''MyApp) ress dispatch <- mkDispatchClause MkDispatchSettings@@ -89,9 +89,7 @@ } ress return $ InstanceD-#if MIN_VERSION_template_haskell(2,11,0) Nothing-#endif [] (ConT ''Dispatcher `AppT` ConT ''MyApp
test/YesodCoreTest/ParameterizedSite.hs view
@@ -5,14 +5,19 @@ ) where import Data.ByteString.Lazy (ByteString)-import Network.Wai.Test (runSession, request, defaultRequest, assertBodyContains)+import Network.Wai.Test (runSession, request, defaultRequest, assertBodyContains, setPath) import Test.Hspec (Spec, describe, it)-import Yesod.Core (YesodDispatch)+import Yesod.Core (YesodDispatch, renderRoute, Route) import Yesod.Core.Dispatch (toWaiApp)+import Data.Traversable+import Data.Foldable+import Data.Text.Encoding+import Data.Text as T import YesodCoreTest.ParameterizedSite.PolyAny (PolyAny (..)) import YesodCoreTest.ParameterizedSite.PolyShow (PolyShow (..)) import YesodCoreTest.ParameterizedSite.Compat (Compat (..))+import qualified YesodCoreTest.ParameterizedSite.SubRoute as SR -- These are actually tests for template haskell. So if it compiles, it works parameterizedSiteTest :: Spec@@ -20,6 +25,7 @@ it "Polymorphic unconstrained stub" $ runStub (PolyAny ()) it "Polymorphic stub with Show" $ runStub' "1337" (PolyShow (1337 :: Int)) it "Polymorphic unconstrained stub, old-style" $ runStub (Compat () ())+ it "Polymorphic stub, sub routes" $ runStubAgainst [(SR.HomeR 456, ["Stub", "123", "456"]), (SR.EditorR (SR.AwayR 789), ["Stub", "123", "789"])] (SR.SubRoute (123 :: Int)) runStub :: YesodDispatch a => a -> IO () runStub stub =@@ -35,4 +41,15 @@ res <- request defaultRequest assertBodyContains "Stub" res assertBodyContains body res+ in toWaiApp stub >>= runSession actions++runStubAgainst :: YesodDispatch a => [(Route a, [ByteString])] -> a -> IO ()+runStubAgainst urlBodies stub =+ let actions = do+ for_ urlBodies $ \(url, bodies) -> do+ let (nonQuery, _query) = renderRoute url+ let render = T.intercalate "/" nonQuery+ let req = setPath defaultRequest (encodeUtf8 render)+ res <- request req+ for bodies (`assertBodyContains` res) in toWaiApp stub >>= runSession actions
+ test/YesodCoreTest/ParameterizedSite/SubRoute.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE+ TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses+ , OverloadedStrings, StandaloneDeriving, FlexibleInstances, FlexibleContexts+ , ViewPatterns, UndecidableInstances, ConstraintKinds+ #-}+module YesodCoreTest.ParameterizedSite.SubRoute where++import Yesod.Core+import Data.Kind (Type)++type Constraints p = (Eq (Key p), Show (Key p), Read (Key p), PathPiece (Key p), Show p)++class Constraints p => SiteClass p where+ type Key p :: Type++newtype SubRoute a v = SubRoute a+ deriving (Eq, Show, Read)++instance SiteClass Int where+ type Key Int = Int++mkYesodOpts (setParameterizedSubroute True defaultOpts) "(SiteClass p) => SubRoute p v" [parseRoutes|+/home/#{Key p} HomeR GET+/editor EditorR:+ /away/#{Key p} AwayR GET+|]++{-+The above generates data structures and instances like the following:++ data Route (SubRoute p v) = HomeR (Key p) | EditorR (EditorR p v)++deriving instance SiteClass p => Eq (Route (SubRoute p v))+deriving instance SiteClass p => Show (Route (SubRoute p v))+deriving instance SiteClass p => Read (Route (SubRoute p v))+data EditorR p v = AwayR (Key p)+deriving instance SiteClass p => Eq (EditorR p v)+deriving instance SiteClass p => Show (EditorR p v)+deriving instance SiteClass p => Read (EditorR p v)++Note that `p` is now threaded through the other data structures.++Otherwise, EditorR's definition would've been:+data EditorR+ = AwayR (Key p)+ deriving (Eq, Show, Read)+which clearly doesn't work, as `p` is not in scope.+-}++instance SiteClass a => Yesod (SubRoute a v)++getHomeR :: SiteClass a => Key a -> HandlerFor (SubRoute a v) Html+getHomeR key = do+ SubRoute x <- liftHandler getYesod+ defaultLayout+ [whamlet|+ <p>+ Stub #{show x} #{show key}+ |]++getAwayR :: SiteClass a => Key a -> HandlerFor (SubRoute a v) Html+getAwayR key1 = do+ SubRoute x <- liftHandler getYesod+ defaultLayout+ [whamlet|+ <p>+ Stub #{show x} #{show key1}+ |]
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.6.28.0+version: 1.6.28.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -53,7 +53,7 @@ , random >= 1.0.0.2 && < 1.4 , resourcet >= 1.2 , shakespeare >= 2.0- , template-haskell >= 2.11+ , template-haskell >= 2.13 , text >= 0.7 , time >= 1.5 , transformers >= 0.4@@ -134,6 +134,7 @@ , random , path-pieces , HUnit+ , th-abstraction test-suite tests default-language: Haskell2010@@ -167,6 +168,7 @@ YesodCoreTest.ParameterizedSite.Compat YesodCoreTest.ParameterizedSite.PolyAny YesodCoreTest.ParameterizedSite.PolyShow+ YesodCoreTest.ParameterizedSite.SubRoute YesodCoreTest.RawResponse YesodCoreTest.Redirect YesodCoreTest.Reps